[net.micro.atari16] Uuencode in OSS Pascal

beatyr@pur-ee.UUCP (Robert Beaty) (09/12/86)

<<<<<>>>>>

  This is the uuencode program to go with the uudecode program
posted previously. Same things apply - cut at the marks, remove
address at the end of this posting, and feed to OSS Pascal.
  Have Fun!

****** cut here ******
Program uuencode;

  CONST
    {$I gemconst }
    header = 'begin';
    trailer = 'end';
    defaultMode = '644';
    defaultExtension = '.uue';
    offset = 32;
    charsPerLine = 60;
    bytesPerHunk = 3;
    sixBitMask = $3F;

  TYPE
    {$I gemtype }
    string80 = string[80];

  VAR
    infile: file of integer;
    outfile: text;
    infilename, outfilename, mode, mess : string80;
    lineLength, numbytes, bytesInLine: integer;
    uuline: array [0..59] of char;
    hunk: array [0..2] of integer;
    chars: array [0..3] of integer;
    x : Str255;
    i : integer;
    one_waiting, eof_infile : Boolean;
    waiting_Byte : integer;

  {$I gemsubs }

  procedure Abort (message: string80);

    begin {abort}
      x:=Concat( '[3][ ', message,' ][ Exit ]' );
      i:=Do_Alert( x, 1 );
      close(infile);
      close(outfile);
      halt
    end; {abort}

  procedure Init;

    procedure GetFiles;

      VAR i: integer;
          temp: string80;
          ch: char;
          path, name : Path_Name;

      begin {GetFiles}
        path:='A:\*.*';    { this is the default path for the input file }
        name:='';          { reset the name of the file }
        if not(Get_In_File( path, name )) then
          abort ('No input file specified.');
        infilename := name;
        IO_Check( False );
        Reset(infile, infilename);
        IO_Check( True );
        if IO_Result <> 0 then
          begin
            mess:=Concat( 'Cannot open file ', infilename );
            abort( mess );
          end;

        i := pos('.', infilename);
        if i = 0 then
          outfilename := infilename
        else
          outfilename := copy (infilename, 1, pred(i));
        outfilename := concat(outfilename, defaultExtension);
        mode := defaultMode;
        x:=Concat( '[0][ Coding to file ', outfilename, ' ][ Fine ]' );
        i:=Do_Alert( x, 1 );

        IO_Check( False );
        reset(outfile, outfilename);
        IO_Check( True );
        if IO_Result = 0 then
          begin
            x:='[2][';
            x:=Concat(x,' Overwrite current |');
            x:=Concat(x,outfilename,'? ]');
            x:=Concat(x,'[ Yes | No ]');
            i:=Do_Alert( x, 0 );
            if i = 2 then abort ('Overwrite cancelled.');
          end;
        close(outfile);

        IO_Check( False );
        rewrite(outfile, outfilename);
        IO_Check( True );
        if IO_Result <> 0 then
          begin
            mess:=Concat( 'Cannot open ', outfilename );
            abort( mess );
          end;
      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}
      writeout(chr(bytesInLine + offset));
      for i := 0 to pred(lineLength) do
        writeout(uuline[i]);
      writeln (outfile);
      lineLength := 0;
      bytesInLine := 0
    end; {FlushLine}

  procedure FlushHunk;

    VAR i: integer;

    begin {FlushHunk}
      if lineLength = charsPerLine then FlushLine;
      chars[0] := ShR( hunk[0], 2 );
      chars[1] := ( ShL(hunk[0],4) ) + ( ShR(hunk[1],4) );
      chars[2] := ( ShL(hunk[1],2) ) + ( ShR(hunk[2],6) );
      chars[3] := hunk[2] & sixBitMask;
      for i := 0 to 3 do
        begin
          uuline[lineLength] := chr((chars[i] & sixBitMask) + offset);
          lineLength := succ(lineLength)
        end;
      bytesInLine := bytesInLine + numbytes;
      numbytes := 0
    end; {FlushHunk}

  function get_a_byte : integer;
    { This function returns a byte input from the file 'infile'
      a file of two byte integers.                               }
    var
      two_bytes : integer;
    begin
      if one_waiting then
        begin
          get_a_byte:=waiting_byte;
          one_waiting:=False;
        end
      else
        begin
          two_bytes:=infile^;
          IO_Check( False );
          Get(infile);               { get two bytes from the file }
          IO_Check( True );
          if IO_Result=0 then
            begin    { this is a normal in the file read }
              get_a_byte:=ShR( two_bytes, 8 ) & $00FF;   { get the first byte }
              waiting_byte:=two_bytes & $00FF;  { and the lower second byte }
              one_waiting:=True;
            end
          else
            begin    { this is an EOF mark }
              get_a_byte:=ShR( two_bytes, 8 ) & $00FF;   { get the first byte }
              eof_infile:=True;     { stop all this }
            end;
        end;
    end;

  procedure encode1;

    begin {encode1};
      if numbytes = bytesperhunk then flushhunk;
      hunk[numbytes]:=get_a_byte;
      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}
    if Init_GEM >= 0 then
      begin
        Init;
        eof_infile:=false;
        while not eof_infile do encode1;
        terminate;
        Exit_GEM;
      end;
  end. {uuencode}
****** cut here ******
----------
   ... ihnp4!pur-ee!beatyr      <- usenet
  ... beatyr@ed.ecn.purdue.edu  <- arpa-net
   ... beatyr@pur-ee.UUCP       <- UUCP
----------