ftp.barnyard.co.uk/2015.02.ftp.barnyard.co.uk.tar/ftp.barnyard.co.uk/cpm/walnut-creek-CDROM/CPM/STARTKIT/UUENCODE.PAS

Pascal/Delphi Source File | 2000-06-30 | 7KB | 290 lines

Program uuencode;
{Fixed 'off-by-one' error @ EOF in routine ENCODE1 - B.Eiben@MARKET - 16-Aug-86}

  CONST header = 'begin';
        trailer = 'end';
        defaultMode = '644';
        defaultExtension = '.uue';
        offset = 32;
        charsPerLine = 60;
        bytesPerHunk = 3;
        sixBitMask = $3F;
        endofinfile : boolean = FALSE;

  TYPE string80 = string[80];

  VAR inf : file;
      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;  }

{Binary file read added by Ross Alford,  ...!mcnc!ecsvax!alford.  The original
 MSDOS versions of uuencode/decode just use read/write on a FILE OF BYTE.
 CP/M Turbo expects some file info to be stored in the first 4 bytes of files
 of any type other than TEXT.  Getbyte (below) and Putbyte (in UUDECODE)
 bypass this 'feature' by using blockread and blockwrite.  The only global
 variables either use are 'infilename' and 'inf' or 'outfilename' and 'outf'}

function getbyte(var b : byte) : boolean;

type bufptr = ^bufrec;
     bufrec = record
                next : bufptr;
                buffer : array[1..128] of byte
              end;

const sectstobuf = 8;                {max number of sectors to buffer}
      sectsread : integer = 0;       {constants are essentially statics}
      bytptr : integer = 129;
      notopen : boolean = TRUE;
      j : integer = 0;
      infsize : integer = 0;
      listsave : integer  = 0;

var list,temp,temp2 : bufptr;

begin
  if notopen then
    begin
      notopen := FALSE;
      assign(inf,infilename);
      {$i-}
      reset(inf);
      {$i+}
      if ioresult <> 0 then
        begin
          writeln('File ',infilename,' not found.  Aborting');
          halt
        end;
      infsize := filesize(inf);
      new(list);
      list^.next := NIL;
      listsave := ord(list);
      sectsread := 0
    end;
  list := ptr(listsave);
  if bytptr > 128 then
    begin
      if list^.next <> NIL then
        begin
          temp := list^.next;
          dispose(list);
          list := temp;
          bytptr := 1
        end
        else begin
          dispose(list);
          list := NIL;
          j := 0;
          while (sectsread<infsize) and (j<sectstobuf) do
            begin
              new(temp2);
              temp2^.next := NIL;
              if list=NIL then
                begin
                  list := temp2;
                  temp := list
                end
                else begin
                  temp^.next := temp2;
                  temp := temp2
                end;
              blockread(inf,temp^.buffer,1);
              j := succ(j);
              sectsread := succ(sectsread)
            end;
          bytptr := 1
        end
    end;
    listsave := ord(list);
    if list <> NIL then
      begin
        b := list^.buffer[bytptr];
        bytptr := succ(bytptr);
        getbyte := TRUE
      end
      else begin
        b := 0;
        getbyte := FALSE
      end
end;

  procedure Abort (message: string80);

    begin {abort}
      writeln(message);
      close(inf);
      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 (inf, infilename);
        reset (inf);
        {$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;
      endofinfile := not (getbyte(hunk[numbytes]));
      if not endofinfile then numbytes := succ(numbytes)  {No succ at EOF -BE}
    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 (inf);
    end; {terminate}


  begin {uuencode}
    init;
    while not endofinfile do encode1;
    terminate
  end. {uuencode}