ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/MISC/EDUCATIO/CATTEST.ZIP/UUENC.PAS

Pascal/Delphi Source File | 1990-06-15 | 5.6 KB | 198 lines

{$A+,B-,D+,E+,F-,I+,L+,N-,O-,R-,S+,V+}
{$M 16384,0,655360}
program uuetest;
Uses Dos,Crt;
procedure 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.)
}

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;}
  out_file_OK : Boolean;
  i1 : integer;
{  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; }*)
(* get the number of bytes of data to be encrypted and saved *)
      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); *)
      Outfilename := 'STUDREC.UUE';
      out_file_OK := False;
      repeat
      ASSIGN (Outfile, Outfilename);
      {$I-}
      RESET(Outfile);
      {$I+}
      IF IOResult = 0 THEN BEGIN         {output file exists!}
         i1 := Ord(outfilename[11]);
         OutFileName[11] := CHR(i1);     {system allows uue, uuf, uug etc.}
      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,';Major error'))
      else out_file_OK := True;
      until Out_file_OK;

    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]);*)
    (*move numbytes of internal data to 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}
begin
end.