Simtel MSDOS - Coast to Coast/simteldosarchivecoasttocoast.iso/starter/uuencode.tp5

Pascal/Delphi Source File | 1994-03-05 | 5KB | 222 lines

PROGRAM uuencode;

{v1.1 Toad Hall Tweak, 9 May 90
 - Converted reserved, other word case to my preferred style.
 - Converted for Turbo Pascal v5.0 compilation ("Uses", etc.)
}

Uses Dos,Crt;

CONST
  Header = 'begin';
  Trailer = 'end';
  DefaultMode = '644';
  DefaultExtension = '.uue';
  OFFSET = 32;
  CHARSPERLINE = 60;
  BYTESPERHUNK = 3;
  SIXBITMASK = $3F;

TYPE
  Str80 = STRING[80];

VAR
  Infile: FILE OF Byte;
  Outfile: TEXT;
  Infilename, Outfilename, Mode: Str80;
  lineLength, numbytes, bytesInLine: INTEGER;
  Line: ARRAY [0..59] OF CHAR;
  hunk: ARRAY [0..2] OF Byte;
  chars: ARRAY [0..3] OF Byte;
  size,remaining : longint;  {v1.1 REAL;}

{  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 (Msg : Str80);
  BEGIN
    WRITELN(Msg);
    {$I-}                 {v1.1}
    CLOSE(Infile);
    CLOSE(Outfile);
    {$I+}                 {v1.1}
    HALT
  END; {of Abort}


PROCEDURE Init;

  PROCEDURE GetFiles;
    VAR
      i : INTEGER;
      TempS : Str80;
      Ch : CHAR;
    BEGIN
      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));

      size := FileSize(Infile);
{     IF size < 0 THEN size:=size+65536.0; }
      remaining := size;
      WRITE('Uuencoding file ', Infilename);

      i := POS('.', Infilename);
      IF i = 0
      THEN Outfilename := Infilename
      ELSE Outfilename := COPY (Infilename, 1, PRED(i));

      Mode := DefaultMode;
      { Process 2d cmdline arg (if any).
        It could be a new mode (rather than default "644")
        or it could be a forced output name (rather than
        "infile.uue")
      }
      IF ParamCount > 1                         {got more args}
      THEN FOR i := 2 TO ParamCount DO BEGIN
        TempS := ParamStr(i);
        IF TempS[1] IN ['0'..'9']               {numeric : it's a mode}
        THEN Mode := TempS
        ELSE Outfilename := TempS               {it's output filename}
      END;

      IF POS ('.', Outfilename) = 0       {he didn't give us extension..}
                                          {..so make it ".uue"}
      THEN Outfilename := CONCAT(Outfilename, DefaultExtension);

      ASSIGN (Outfile, Outfilename);
      WRITELN (' to file ', Outfilename, '.');

      {$I-}
      RESET(Outfile);
      {$I+}
      IF IOResult = 0 THEN BEGIN          {output file exists!}
        WRITE ('Overwrite current ', Outfilename, '? [Y/N] ');
        REPEAT
          Ch := Upcase(ReadKey);
        UNTIL Ch IN ['Y', 'N'];
        WRITELN (Ch);
        IF Ch = 'N' THEN Abort(CONCAT (Outfilename, ' not overwritten.'))
      END;

      {$I-}
      CLOSE(Outfile);
      IF IOResult <> 0 THEN ;  {v1.1 we don't care}

      REWRITE(Outfile);
      {$I+}
      IF IOResult > 0 THEN Abort(CONCAT('Can''t open ', Outfilename));
    END; {of GetFiles}

  BEGIN {Init}
    GetFiles;
    bytesInLine := 0;
    lineLength := 0;
    numbytes := 0;
    WRITELN (Outfile, Header, ' ', Mode, ' ', Infilename);
  END; {init}


{You'll notice from here on we don't do any error-trapping on disk
 read/writes.  We just let DOS do the job.  Any errors are terminal
 anyway, right?
}

PROCEDURE FlushLine;
  VAR i: INTEGER;


  PROCEDURE WriteOut(Ch: CHAR);
    BEGIN
      IF Ch = ' ' THEN WRITE(Outfile, '`')
                  ELSE WRITE(Outfile, Ch)
    END; {of WriteOut}

  BEGIN {FlushLine}
    {write ('.');}
    WRITE('bytes remaining: ',remaining:7,' (',
          remaining/size*100.0:3:0,'%)',CHR(13));
    WriteOut(CHR(bytesInLine + OFFSET));
    FOR i := 0 TO PRED(lineLength) DO
      WriteOut(Line[i]);
    WRITELN (Outfile);
    lineLength := 0;
    bytesInLine := 0
  END; {of FlushLine}


PROCEDURE FlushHunk;
  VAR i: INTEGER;
  BEGIN
    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);}
      Inc(lineLength);
    END;
    {writeln;}
    Inc(bytesInLine,numbytes);
    numbytes := 0
  END; {of FlushHunk}


PROCEDURE Encode1;
  BEGIN
    IF numbytes = BYTESPERHUNK THEN FlushHunk;

    READ (Infile, hunk[numbytes]);
    Dec(remaining);
    Inc(numbytes);
  END; {of Encode1}


PROCEDURE Terminate;
  BEGIN
    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;
    WRITELN;
  END. {uuencode}