jrc@ritcv.UUCP (James R. Carbin) (02/29/88)
Here are Pascal source files for "uuencode" and "uudecode"
The original author is unknown to me, so unfortunately I am
unable to give credit where credit is due.
While these are obviously not binary files, it seemed appropriate
to post them here as they are essential for anyone wanting to
access other postings in this newsgroup. Please route any
complaints to your local /dev/null.
Enjoy!
___________ ____
@~~~~~/~~~~> /~~~~)
/ / / Jim Carbin
. / o ____ / _ / o __ Rochester Institute of Technology
<___/ _< _/ / < \_____.( /_/~/~~)_<_/ < UUCP: rochester!ritcv!jrc
~~~~ ~~ ~ ~ ~ ~~~~~ ~~^~ ~~~ ~ ~ ~
The following will give you the pascal source files for
uuencode and uudecode.
-------------------------------------------------------------
THIS IS THE FILE uuencode in Pascal source
-----------------------cut here------------------------------
Program uuencode;
CONST header = 'begin';
trailer = 'end';
defaultMode = '644';
defaultExtension = '.uue';
offset = 32;
charsPerLine = 60;
bytesPerHunk = 3;
sixBitMask = $3F;
TYPE string80 = string[80];
VAR infile: file of byte;
outfile: text;
infilename, outfilename, mode: string80;
lineLength, numbytes, bytesInLine: integer;
line: array [0..59] of char;
hunk: array [0..2] of byte;
chars: array [0..3] of byte;
{ procedure debug;
var i: integer;
procedure writebin(x: byte);
var i: integer;
begin
for i := 1 to 8 do
begin
write ((x and $80) shr 7);
x := x shl 1
end;
write (' ')
end;
begin
for i := 0 to 2 do writebin(hunk[i]);
writeln;
for i := 0 to 3 do writebin(chars[i]);
writeln;
for i := 0 to 3 do writebin(chars[i] and sixBitMask);
writeln
end; }
procedure Abort (message: string80);
begin {abort}
writeln(message);
close(infile);
close(outfile);
halt
end; {abort}
procedure Init;
procedure GetFiles;
VAR i: integer;
temp: string80;
ch: char;
begin {GetFiles}
if ParamCount < 1 then abort ('No input file specified.');
infilename := ParamStr(1);
{$I-}
assign (infile, infilename);
reset (infile);
{$i+}
if IOResult > 0 then abort (concat ('Can''t open file ', infilename));
write('Uuencoding file ', infilename);
i := pos('.', infilename);
if i = 0
then outfilename := infilename
else outfilename := copy (infilename, 1, pred(i));
mode := defaultMode;
if ParamCount > 1 then
for i := 2 to ParamCount do
begin
temp := Paramstr(i);
if temp[1] in ['0'..'9']
then mode := temp
else outfilename := temp
end;
if pos ('.', outfilename) = 0
then outfilename := concat(outfilename, defaultExtension);
assign (outfile, outfilename);
writeln (' to file ', outfilename, '.');
{$i-}
reset(outfile);
{$i+}
if IOresult = 0 then
begin
Write ('Overwrite current ', outfilename, '? [Y/N] ');
repeat
read (kbd, ch);
ch := Upcase(ch)
until ch in ['Y', 'N'];
writeln (ch);
if ch = 'N' then abort(concat (outfilename, ' not overwritten.'))
end;
close(outfile);
{$i-}
rewrite(outfile);
{$i+}
if ioresult > 0 then abort(concat('Can''t open ', outfilename));
end; {getfiles}
begin {Init}
GetFiles;
bytesInLine := 0;
lineLength := 0;
numbytes := 0;
writeln (outfile, header, ' ', mode, ' ', infilename);
end; {init}
procedure FlushLine;
VAR i: integer;
procedure writeout(ch: char);
begin {writeout}
if ch = ' ' then write(outfile, '`')
else write(outfile, ch)
end; {writeout}
begin {FlushLine}
write ('.');
writeout(chr(bytesInLine + offset));
for i := 0 to pred(lineLength) do
writeout(line[i]);
writeln (outfile);
lineLength := 0;
bytesInLine := 0
end; {FlushLine}
procedure FlushHunk;
VAR i: integer;
begin {FlushHunk}
if lineLength = charsPerLine then FlushLine;
chars[0] := hunk[0] shr 2;
chars[1] := (hunk[0] shl 4) + (hunk[1] shr 4);
chars[2] := (hunk[1] shl 2) + (hunk[2] shr 6);
chars[3] := hunk[2] and sixBitMask;
{debug;}
for i := 0 to 3 do
begin
line[lineLength] := chr((chars[i] and sixBitMask) + offset);
{write(line[linelength]:2);}
lineLength := succ(lineLength)
end;
{writeln;}
bytesInLine := bytesInLine + numbytes;
numbytes := 0
end; {FlushHunk}
procedure encode1;
begin {encode1};
if numbytes = bytesperhunk then flushhunk;
read (infile, hunk[numbytes]);
numbytes := succ(numbytes)
end; {encode1}
procedure terminate;
begin {terminate}
if numbytes > 0 then flushhunk;
if lineLength > 0
then
begin
flushLine;
flushLine;
end
else flushline;
writeln (outfile, trailer);
close (outfile);
close (infile);
end; {terminate}
begin {uuencode}
init;
while not eof (infile) do encode1;
terminate
end. {uuencode}
-----------------------cut here------------------------------
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
-------------------------------------------------------------
THIS IS THE FILE uudecode in Pascal source
-----------------------cut here------------------------------
program uudecode;
CONST defaultSuffix = '.uue';
offset = 32;
TYPE string80 = string[80];
VAR infile: text;
outfile: file of byte;
lineNum: integer;
line: string80;
procedure Abort(message: string80);
begin {abort}
writeln;
if lineNum > 0 then write('Line ', lineNum, ': ');
writeln(message);
halt
end; {Abort}
procedure NextLine(var s: string80);
begin {NextLine}
LineNum := succ(LineNum);
write('.');
readln(infile, s)
end; {NextLine}
procedure Init;
procedure GetInFile;
VAR infilename: string80;
begin {GetInFile}
if ParamCount = 0 then abort ('Usage: uudecode <filename>');
infilename := ParamStr(1);
if pos('.', infilename) = 0
then infilename := concat(infilename, defaultSuffix);
assign(infile, infilename);
{$i-}
reset(infile);
{$i+}
if IOresult > 0 then abort (concat('Can''t open ', infilename));
writeln ('Decoding ', infilename)
end; {GetInFile}
procedure GetOutFile;
var header, mode, outfilename: string80;
ch: char;
procedure ParseHeader;
VAR index: integer;
Procedure NextWord(var word:string80; var index: integer);
begin {nextword}
word := '';
while header[index] = ' ' do
begin
index := succ(index);
if index > length(header) then abort ('Incomplete header')
end;
while header[index] <> ' ' do
begin
word := concat(word, header[index]);
index := succ(index)
end
end; {NextWord}
begin {ParseHeader}
header := concat(header, ' ');
index := 7;
NextWord(mode, index);
NextWord(outfilename, index)
end; {ParseHeader}
begin {GetOutFile}
if eof(infile) then abort('Nothing to decode.');
NextLine (header);
while not ((copy(header, 1, 6) = 'begin ') or eof(infile)) do
NextLine(header);
writeln;
if eof(infile) then abort('Nothing to decode.');
ParseHeader;
assign(outfile, outfilename);
writeln ('Destination is ', outfilename);
{$i-}
reset(outfile);
{$i+}
if IOresult = 0 then
begin
write ('Overwrite current ', outfilename, '? [Y/N] ');
repeat
read (kbd, ch);
ch := UpCase(ch)
until ch in ['Y', 'N'];
writeln(ch);
if ch = 'N' then abort ('Overwrite cancelled.')
end;
rewrite (outfile);
end; {GetOutFile}
begin {init}
lineNum := 0;
GetInFile;
GetOutFile;
end; { init}
Function CheckLine: boolean;
begin {CheckLine}
if line = '' then abort ('Blank line in file');
CheckLine := not (line[1] in [' ', '`'])
end; {CheckLine}
procedure DecodeLine;
VAR lineIndex, byteNum, count, i: integer;
chars: array [0..3] of byte;
hunk: array [0..2] of byte;
{ procedure debug;
var i: integer;
procedure writebin(x: byte);
var i: integer;
begin
for i := 1 to 8 do
begin
write ((x and $80) shr 7);
x := x shl 1
end;
write (' ')
end;
begin
writeln;
for i := 0 to 3 do writebin(chars[i]);
writeln;
for i := 0 to 2 do writebin(hunk[i]);
writeln
end; }
function nextch: char;
begin {nextch}
lineIndex := succ(lineIndex);
if lineIndex > length(line) then abort('Line too short.');
if not (line[lineindex] in [' '..'`'])
then abort('Illegal character in line.');
{ write(line[lineindex]:2);}
if line[lineindex] = '`' then nextch := ' '
else nextch := line[lineIndex]
end; {nextch}
procedure DecodeByte;
procedure GetNextHunk;
VAR i: integer;
begin {GetNextHunk}
for i := 0 to 3 do chars[i] := ord(nextch) - offset;
hunk[0] := (chars[0] shl 2) + (chars[1] shr 4);
hunk[1] := (chars[1] shl 4) + (chars[2] shr 2);
hunk[2] := (chars[2] shl 6) + chars[3];
byteNum := 0 {;
debug }
end; {GetNextHunk}
begin {DecodeByte}
if byteNum = 3 then GetNextHunk;
write (outfile, hunk[byteNum]);
{writeln(bytenum, ' ', hunk[byteNum]);}
byteNum := succ(byteNum)
end; {DecodeByte}
begin {DecodeLine}
lineIndex := 0;
byteNum := 3;
count := (ord(nextch) - offset);
for i := 1 to count do DecodeByte
end; {DecodeLine}
procedure terminate;
var trailer: string80;
begin {terminate}
if eof(infile) then abort ('Abnormal end.');
NextLine (trailer);
if length (trailer) < 3 then abort ('Abnormal end.');
if copy (trailer, 1, 3) <> 'end' then abort ('Abnormal end.');
close (infile);
close (outfile)
end;
begin {uudecode}
init;
NextLine(line);
while CheckLine do
begin
DecodeLine;
NextLine(line)
end;
terminate
end.
-----------------------cut here------------------------------
That's all folks!