home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1995 October / Simtel-MSDOS-Oct1995-CD2.iso / starter / uuencode.pas < prev    next >
Pascal/Delphi Source File  |  1986-12-12  |  5KB  |  203 lines

  1. Program uuencode;
  2.  
  3.   CONST header = 'begin';
  4.         trailer = 'end';
  5.         defaultMode = '644';
  6.         defaultExtension = '.uue';
  7.         offset = 32;
  8.         charsPerLine = 60;
  9.         bytesPerHunk = 3;
  10.         sixBitMask = $3F;
  11.  
  12.   TYPE string80 = string[80];
  13.  
  14.   VAR infile: file of byte;
  15.       outfile: text;
  16.       infilename, outfilename, mode: string80;
  17.       lineLength, numbytes, bytesInLine: integer;
  18.       line: array [0..59] of char;
  19.       hunk: array [0..2] of byte;
  20.       chars: array [0..3] of byte;
  21.       size,remaining :real;
  22.  
  23. {  procedure debug;
  24.  
  25.     var i: integer;
  26.  
  27.     procedure writebin(x: byte);
  28.  
  29.       var i: integer;
  30.  
  31.       begin
  32.         for i := 1 to 8 do
  33.           begin
  34.             write ((x and $80) shr 7);
  35.             x := x shl 1
  36.           end;
  37.         write (' ')
  38.       end;
  39.  
  40.     begin
  41.       for i := 0 to 2 do writebin(hunk[i]);
  42.       writeln;
  43.       for i := 0 to 3 do writebin(chars[i]);
  44.       writeln;
  45.       for i := 0 to 3 do writebin(chars[i] and sixBitMask);
  46.       writeln
  47.     end;  }
  48.  
  49.   procedure Abort (message: string80);
  50.  
  51.     begin {abort}
  52.       writeln(message);
  53.       close(infile);
  54.       close(outfile);
  55.       halt
  56.     end; {abort}
  57.  
  58.   procedure Init;
  59.  
  60.     procedure GetFiles;
  61.  
  62.       VAR i: integer;
  63.           temp: string80;
  64.           ch: char;
  65.  
  66.       begin {GetFiles}
  67.         if ParamCount < 1 then abort ('No input file specified.');
  68.         infilename := ParamStr(1);
  69.         {$I-}
  70.         assign (infile, infilename);
  71.         reset (infile);
  72.         {$i+}
  73.         if IOResult > 0 then abort (concat ('Can''t open file ', infilename));
  74.         size:=FileSize(infile);
  75.         if size < 0 then size:=size+65536.0;
  76.         remaining:=size;
  77.         write('Uuencoding file ', infilename);
  78.  
  79.         i := pos('.', infilename);
  80.         if i = 0
  81.           then outfilename := infilename
  82.           else outfilename := copy (infilename, 1, pred(i));
  83.         mode := defaultMode;
  84.         if ParamCount > 1 then
  85.           for i := 2 to ParamCount do
  86.             begin
  87.               temp := Paramstr(i);
  88.               if temp[1] in ['0'..'9']
  89.                 then mode := temp
  90.                 else outfilename := temp
  91.             end;
  92.         if pos ('.', outfilename) = 0
  93.           then outfilename := concat(outfilename, defaultExtension);
  94.         assign (outfile, outfilename);
  95.         writeln (' to file ', outfilename, '.');
  96.  
  97.         {$i-}
  98.         reset(outfile);
  99.         {$i+}
  100.         if IOresult = 0 then
  101.           begin
  102.             Write ('Overwrite current ', outfilename, '? [Y/N] ');
  103.             repeat
  104.               read (kbd, ch);
  105.               ch := Upcase(ch)
  106.             until ch in ['Y', 'N'];
  107.             writeln (ch);
  108.             if ch = 'N' then abort(concat (outfilename, ' not overwritten.'))
  109.           end;
  110.         close(outfile);
  111.  
  112.         {$i-}
  113.         rewrite(outfile);
  114.         {$i+}
  115.         if ioresult > 0 then abort(concat('Can''t open ', outfilename));
  116.       end; {getfiles}
  117.  
  118.     begin {Init}
  119.       GetFiles;
  120.       bytesInLine := 0;
  121.       lineLength := 0;
  122.       numbytes := 0;
  123.       writeln (outfile, header, ' ', mode, ' ', infilename);
  124.     end; {init}
  125.  
  126.   procedure FlushLine;
  127.  
  128.     VAR i: integer;
  129.  
  130.     procedure writeout(ch: char);
  131.  
  132.       begin {writeout}
  133.         if ch = ' ' then write(outfile, '`')
  134.                     else write(outfile, ch)
  135.       end; {writeout}
  136.  
  137.     begin {FlushLine}
  138.       {write ('.');}
  139.       write('bytes remaining: ',remaining:7:0,' (',
  140.             remaining/size*100.0:3:0,'%)',chr(13));
  141.       writeout(chr(bytesInLine + offset));
  142.       for i := 0 to pred(lineLength) do
  143.         writeout(line[i]);
  144.       writeln (outfile);
  145.       lineLength := 0;
  146.       bytesInLine := 0
  147.     end; {FlushLine}
  148.  
  149.   procedure FlushHunk;
  150.  
  151.     VAR i: integer;
  152.  
  153.     begin {FlushHunk}
  154.       if lineLength = charsPerLine then FlushLine;
  155.       chars[0] := hunk[0] shr 2;
  156.       chars[1] := (hunk[0] shl 4) + (hunk[1] shr 4);
  157.       chars[2] := (hunk[1] shl 2) + (hunk[2] shr 6);
  158.       chars[3] := hunk[2] and sixBitMask;
  159.       {debug;}
  160.       for i := 0 to 3 do
  161.         begin
  162.           line[lineLength] := chr((chars[i] and sixBitMask) + offset);
  163.           {write(line[linelength]:2);}
  164.           lineLength := succ(lineLength)
  165.         end;
  166.       {writeln;}
  167.       bytesInLine := bytesInLine + numbytes;
  168.       numbytes := 0
  169.     end; {FlushHunk}
  170.  
  171.   procedure encode1;
  172.  
  173.     begin {encode1};
  174.       if numbytes = bytesperhunk then flushhunk;
  175.       read (infile, hunk[numbytes]);
  176.       remaining:=remaining-1;
  177.       numbytes := succ(numbytes)
  178.     end; {encode1}
  179.  
  180.   procedure terminate;
  181.  
  182.     begin {terminate}
  183.       if numbytes > 0 then flushhunk;
  184.       if lineLength > 0
  185.         then
  186.           begin
  187.             flushLine;
  188.             flushLine;
  189.           end
  190.         else flushline;
  191.       writeln (outfile, trailer);
  192.       close (outfile);
  193.       close (infile);
  194.     end; {terminate}
  195.  
  196.  
  197.   begin {uuencode}
  198.     init;
  199.     while not eof (infile) do encode1;
  200.     terminate;
  201.     writeln;
  202.   end. {uuencode}
  203.