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

Pascal/Delphi Source File | 1991-03-29 | 15.0 KB | 562 lines

unit uuestuff;

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

interface
uses CRT,DOS;
procedure encode;
procedure decode;
procedure hide(question_name:string);
implementation




procedure  decode;
{v1.1 Toad Hall Tweak, 9 May 90
 - Reformatted in case, style, indentation, etc. to my preferences.
 - Tweaked for Turbo Pascal v5.0
 David Kirschbaum
 Toad Hall
}
CONST
  DefaultSuffix = '.uue';
  OFFSET = 32;
TYPE
  Str80 = STRING[80];
VAR
  Infile: TEXT;
  Fi    : FILE OF Byte;
  Outfile: FILE OF Byte;
  linenum: INTEGER;
  Line: Str80;
  size,remaining : longint;  {v1.1 REAL;}
PROCEDURE Abort(Msg: Str80);
  BEGIN
    WRITELN;
    IF linenum > 0 THEN WRITE('Aborting, line = ', linenum, ': ');
    WRITELN(Msg);
    HALT
  END; {of Abort}
PROCEDURE NextLine(VAR S: Str80);
  BEGIN
    Inc(linenum);
    {write('.');}
    READLN(Infile, S);
    Dec(remaining,LENGTH(S)-2);  {-2 is for CR/LF}
    (*WRITE('bytes remaining: ',remaining:7,' (',
          remaining/size*100.0:3:0,'%)',CHR(13));*)
  END; {of NextLine}
PROCEDURE Init;
  PROCEDURE GetInFile;
    VAR Infilename: Str80;
    BEGIN
      Infilename := 'OLDGRADE.BK$';
      ASSIGN(Infile, Infilename);
      {$I-}
      RESET(Infile);
      {$i+}
      IF IOResult > 0 THEN Abort (CONCAT('Can''t open ', Infilename));
      ASSIGN(Fi,Infilename); RESET(Fi);
      size := FileSize(Fi);
      CLOSE(Fi);
{      IF size < 0 THEN size:=size+65536.0; }
      remaining := size;
    END;  {of GetInFile}
  PROCEDURE GetOutFile;
    VAR
      Header, Mode, Outfilename: Str80;
      Ch: CHAR;
    PROCEDURE ParseHeader;
      VAR index: INTEGER;
      PROCEDURE NextWord(VAR Word:Str80; VAR index: INTEGER);
        BEGIN
          Word := '';
          WHILE Header[index] = ' ' DO BEGIN
            Inc(index);
            IF index > LENGTH(Header) THEN Abort ('Incomplete header')
          END;
          WHILE Header[index] <> ' ' DO BEGIN
            Word := CONCAT(Word, Header[index]);
            Inc(index);
          END
        END; {of NextWord}
      BEGIN {ParseHeader}
        Header := CONCAT(Header, ' ');
        index := 7;
        NextWord(Mode, index);
        NextWord(Outfilename, index)
      END; {of ParseHeader}
    BEGIN {GetOutFile}
      IF EOF(Infile) THEN Abort('Nothing to decode.');
      NextLine (Header);
      WHILE NOT ((COPY(Header, 1, 6) = 'begin ') OR EOF(Infile)) DO
        NextLine(Header);
      WRITELN;
      IF EOF(Infile) THEN Abort('Nothing to decode.');
      ParseHeader;

      OutFileName := 'NEWGRADE.BK$';

      ASSIGN(Outfile, Outfilename);
      {$I-}
      RESET(Outfile);
      {$I+}
      IF IOResult = 0 THEN BEGIN
        WRITE ('Overwrite current ', Outfilename, '? [Y/N] ');
        REPEAT
          Ch := Upcase(ReadKey);  {v1.1}
        UNTIL Ch IN ['Y', 'N'];
        WRITELN(Ch);
        IF Ch = 'N' THEN Abort ('Overwrite cancelled.')
      END;
      REWRITE (Outfile);
    END; {of GetOutFile}
  BEGIN {Init}
    linenum := 0;
    GetInFile;
    GetOutFile;
  END; { init}
FUNCTION Check_Line: BOOLEAN;
  BEGIN
    IF Line = '' THEN Abort ('Blank line in file');
    Check_Line := NOT (Line[1] IN [' ', '`'])
  END; {of Check_Line}
PROCEDURE DecodeLine;
  VAR
    lineIndex, byteNum, count, i: INTEGER;
    chars: ARRAY [0..3] OF Byte;
    hunk: ARRAY [0..2] 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
        writeln;
        for i := 0 to 3 do writebin(chars[i]);
        writeln;
        for i := 0 to 2 do writebin(hunk[i]);
        writeln
      end;      }
  FUNCTION Next_Ch: CHAR;
    BEGIN
      Inc(lineIndex);
      IF lineIndex > LENGTH(Line) THEN Abort('Line too short.');
      IF NOT (Line[lineindex] IN [' '..'`'])
      THEN Abort('Illegal character in line.');
{     write(line[lineindex]:2);}
      IF Line[lineindex] = '`' THEN Next_Ch := ' '
                               ELSE Next_Ch := Line[lineIndex]
    END; {of Next_Ch}
  PROCEDURE DecodeByte;
    PROCEDURE GetNextHunk;
      VAR i: INTEGER;
      BEGIN
        FOR i := 0 TO 3 DO chars[i] := ORD(Next_Ch) - OFFSET;
        hunk[0] := (chars[0] ShL 2) + (chars[1] ShR 4);
        hunk[1] := (chars[1] ShL 4) + (chars[2] ShR 2);
        hunk[2] := (chars[2] ShL 6) + chars[3];
        byteNum := 0  {;
        debug          }
      END; {of GetNextHunk}
    BEGIN {DecodeByte}
      IF byteNum = 3 THEN GetNextHunk;
      WRITE (Outfile, hunk[byteNum]);
      {writeln(bytenum, ' ', hunk[byteNum]);}
      Inc(byteNum)
    END; {of DecodeByte}
  BEGIN {DecodeLine}
    lineIndex := 0;
    byteNum := 3;
    count := (ORD(Next_Ch) - OFFSET);
    FOR i := 1 TO count DO DecodeByte
  END; {of DecodeLine}
PROCEDURE Terminate;
  VAR Trailer: Str80;
  BEGIN
    IF EOF(Infile) THEN Abort ('Abnormal end.');
    NextLine (trailer);
    IF LENGTH (trailer) < 3 THEN Abort ('Abnormal end.');
    IF COPY (trailer, 1, 3) <> 'end' THEN Abort ('Abnormal end.');
    CLOSE (Infile);
    CLOSE (Outfile)
  END;  {of Terminate}
BEGIN {uudecode}
  Init;
  NextLine(Line);
  WHILE Check_Line DO BEGIN
    DecodeLine;
    NextLine(Line)
  END;
  Terminate
END;

procedure hide(question_name:string);
{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
  P : PathStr;
  D : DirStr;
  N : NameStr;
  E : ExtStr;
  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);*)
      InFileName := Question_Name+'.$$$';
      {$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;*)
      Outfilename := Question_Name+'.UUE';
      Mode := DefaultMode;
      out_file_OK := False;
      repeat
      ASSIGN (Outfile, Outfilename);
      {$I-}
      RESET(Outfile);
      {$I+}
      IF IOResult = 0 THEN BEGIN         {output file exists!}
         FSplit(P,D,N,E);
         i1 := Ord(E[4]);
         E[4] := Chr(i1);
         OutFileName := D + N + E;    {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, ' ', Question_Name+'.ENC');
  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 ('.');}
    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);
    Erase(Infile); {get rid of the student response file}
  END; {Terminate}
  BEGIN {uuencode}
    Init;
    WHILE NOT EOF (Infile) DO Encode1;
    Terminate;
    WRITELN;
  END; {hide-really just uuencode again}

procedure encode;
{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);*)
      InFileName := 'NEWGRADE.BK$';
      {$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;*)
      Outfilename := 'GRADE.BK$';
      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")
      }

      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, ' ', 'GRADEB.OOK');
  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 ('.');}
    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}
END.