🚀 go-pugleaf

Received: by DJUKFA11 (Mailer X1.23b) id 9235; Thu, 07 May 87 15:11:13 MEZ
Date:         Thu, 07 May 87 15:11:08 MEZ
From:         Christian Bode <KPH017@DJUKFA11>
To:           INFO-ATARI16@SCORE.STANFORD.EDU

[INHERIT('SYS$LIBRARY:STARLET')]
program uuencode_vms (INPUT,output,infile,OUTFILE);
{originally written by Christian Bode KPH017@DJUKFA11.BITNET}

  CONST offset = 32;

  TYPE string80      = varying[80] of char;
       string65535   = varying[65535] of char;
       string62      = varying[62] of char;
       pack_128      = packed array[1..128] of char;
       unsigned_word = [word] 0..65535;
       cells         = @box;
       box           = record
                        info : char;
                        next : cells;
                       end;

  VAR infile     : text;
      outfile    : text;
      lineNum    : integer;
      line       : cells;
      inidx      : integer;
      inbuf      : pack_128;
      outidx     : integer;
      outbuf     : string62;
      lines      : integer;
      display    : integer;
      pasteboard : integer;
      keyboard   : integer;
      errors     : integer;
      size       : integer;
      i          : integer;
      l          : integer;
      l_line     : integer;
      op_mode    : string65535;
      e_o_f      : boolean;
      go_on      : boolean;

FUNCTION SMG$CREATE_VIRTUAL_DISPLAY(
    ROWS, COLUMNS : INTEGER;
    VAR DISPLAY_ID : INTEGER;
    DISPLAY_ATTRIBUTES, VIDEO_ATTRIBUTES, CHAR_SET : UNSIGNED
        := %IMMED 0) : UNSIGNED; EXTERN;

FUNCTION SMG$CREATE_PASTEBOARD (
    VAR PASTEBOARD_ID : INTEGER;
    OUTPUT_DEVICE : PACKED ARRAY[A..B:INTEGER] OF CHAR:= %IMMED 0;
    ROWS, COLUMNS : INTEGER := %IMMED 0;
    PRESERVE_SCREEN_FLAG : BOOLEAN := %IMMED 0) : UNSIGNED; EXTERN;

FUNCTION SMG$CREATE_VIRTUAL_KEYBOARD (
    VAR KEYBOARD_ID : INTEGER;
    FILESPEC : PACKED ARRAY[A..B:INTEGER] OF CHAR := %IMMED 0;
    DEFAULT_FILESPEC : PACKED ARRAY [C..D:INTEGER] OF CHAR := %IMMED 0;
    RESULTANT_FILESPEC : PACKED ARRAY [E..F:INTEGER] OF CHAR := %IMMED 0
    ) : UNSIGNED; EXTERN;

FUNCTION SMG$PASTE_VIRTUAL_DISPLAY (
    DISPLAY_ID, PASTEBOARD_ID : INTEGER;
    ROW, COLUMN : INTEGER) : UNSIGNED; EXTERN;

FUNCTION SMG$UNPASTE_VIRTUAL_DISPLAY (
    DISPLAY_ID,PASTEBOARD_ID : INTEGER) : UNSIGNED; EXTERN;

FUNCTION SMG$PUT_CHARS (
    DISPLAY_ID : INTEGER;
    TEXT : PACKED ARRAY [A..B:INTEGER] OF CHAR;
    ROW : INTEGER := %IMMED 0;
    COLUMN : INTEGER := %IMMED 0;
    ERASE_FLAG, RENDITION_SET, RENDITION_COMPLEMENT : UNSIGNED := %IMMED 0;
    CHAR_SET : UNSIGNED := %IMMED 0) : UNSIGNED; EXTERN;

FUNCTION SMG$CREATE_VIRTUAL_KEYBOARD (
    VAR KEYBOARD_ID : INTEGER;
    FILESPEC : PACKED ARRAY[A..B:INTEGER] OF CHAR := %IMMED 0;
    DEFAULT_FILESPEC : PACKED ARRAY [C..D:INTEGER] OF CHAR := %IMMED 0;
    RESULTANT_FILESPEC : PACKED ARRAY [E..F:INTEGER] OF CHAR := %IMMED 0
    ) : UNSIGNED; EXTERN;

FUNCTION SMG$READ_KEYSTROKE (
    KEYBOARD_ID : INTEGER;
    VAR TERMINATOR_CODE : UNSIGNED_WORD;
    PROMPT : PACKED ARRAY[A..B:INTEGER] OF CHAR := %IMMED 0;
    TIMEOUT, DISPLAY_ID : INTEGER := %IMMED 0) : UNSIGNED; EXTERN;

  Function nil_qu : cells;
  begin nil_qu:=nil; end;

  Function ismt_qu (stack : cells) : boolean;
  begin ismt_qu:=stack=nil; end;

  Procedure qu (ch : char; var stack : cells);
  var new_member : cells;
  begin
   if ismt_qu(stack)
    then
     begin
      new(new_member);
      new_member@.info:=ch;
      new_member@.next:=nil;
      stack:=new_member;
     end
    else qu(ch,stack@.next);
  end;

  Function Pull (var stack : cells) : char;
  var help : cells;
  begin
   help:=stack;
   stack:=stack@.next;
   help@.next:=nil;
   pull:=help@.info;
   dispose(help);
  end;

  Procedure Writebin (ch: char);
  begin
   if ch=' ' then ch:='`';
   outbuf:=outbuf+ch;
   if outidx =  l_line div 3 *4 +2
    then
     begin
      writeln(outfile,outbuf);
      outidx:=1;
      outbuf:='';
      size:=size+l_line;
      smg$put_chars(display_id:=display,row:=7,column:=53,text:=dec(size,5,1));
      lineNum:=succ(lineNum);
      smg$put_chars(display_id:=display,row:=8,column:=53,
                    text:=dec(lineNum,5,1));
     end
    else outidx:=outidx+1;
end;

  procedure NextLine(var line : cells; var s_length : integer);
  var i : integer;
      l : integer;
      ch : char;
      s : string65535;
    begin {NextLine}
      l:=s_length;
      while (l<=45) and not eof(infile)  do
      begin
       s:='';
       readln(infile,s);
       s_length:=length(s);
       if op_mode = 'VAX'
        then
         begin
          qu(chr(s_length div 256),line);
          qu(chr(s_length mod 256),line);
          l:=l+2;
         end;
       for i:=1 to s_length do qu(s[i],line);
       l:=l+s_length;
      end;
      if eof(infile)
       then
        while (l mod 3 <> 0) do begin qu(chr(0),line); l:=l+1; end;
      s_length:=l;
    end; {NextLine}

  procedure Init;
  var infilename : string80;

procedure trailer;
BEGIN
    SMG$CREATE_VIRTUAL_DISPLAY (ROWS:=9,COLUMNS:=60,display_id:=display,
        DISPLAY_ATTRIBUTES:=SMG$M_BORDER);
    SMG$CREATE_PASTEBOARD (PASTEBOARD_ID:=pasteboard);
    SMG$CREATE_VIRTUAL_KEYBOARD(KEYBOARD_ID:=keyboard);
    SMG$PASTE_VIRTUAL_DISPLAY(DISPLAY_ID:=DISPLAY,
        PASTEBOARD_ID:=pasteboard,ROW:=8,COLUMN:=10);
    smg$put_chars(display_id:=display,row:=2,column:=24,text:='UUENCODE V 1.5');
    smg$put_chars(display_id:=display,row:=5,column:=2,text:='Destination:');
    smg$put_chars(display_id:=display,row:=7,column:=2,text:='Filesize:');
    smg$put_chars(display_id:=display,row:=8,column:=2,text:='Lines encoded:');
end;

    procedure GetInFile;
    begin
     readln(infilename);
     open(infile,infilename,history:=old);
     reset(infile);
    end;

    procedure GetOutFile;
    var header, mode, outfilename: string80;
      begin {GetOutFile}
        readln(outfilename);
        open(outfile,outfilename,history:=new);
        rewrite(outfile);
        mode:='666 ';
        header:='begin '+mode+infilename;
        writeln(outfile,header);
        smg$put_chars(display_id:=display,row:=5,column:=59-length(outfilename),
                      text:=outfilename);
      end; {GetOutFile}

    procedure GetOpMode;
    begin {GetOpMode}
     readln(op_mode)
    end;

    begin {init}
      lineNum := 0;
      errors:=0;
      trailer;
      GetinFile;
      GetOutFile;
      GetOpMode;
    end; { init}


  procedure EncodeLine (var line : cells; var l : integer; count : integer);

    VAR lineIndex, CharNum, byteNum, i, act_length : integer;
        chars: array [0..3] of integer;
        hunk: array [0..2] of  integer;

    function nextch: char;
    var ch : char;

      begin {nextch}
       nextch:=pull(line);
      end; {nextch}

    procedure EncodeByte;

      procedure GetNextHunk;

        VAR i: integer;

        begin {GetNextHunk}
          for i := 0 to 2  do  hunk[i] := ord(nextch);
          chars[0]:= (hunk[0] div 4) + offset;
          chars[1]:= (hunk[0] mod 4) * 16 + (hunk[1] div 16) + offset;
          chars[2]:= (hunk[1] mod 16) * 4 + (hunk[2] div 64) + offset;
          chars[3]:= (hunk[2] mod 64) + offset;
          byteNum := 0
        end; {GetNextHunk}

      begin {EncodeByte}
        if byteNum = 3
         then
          begin
           GetNextHunk;
           for CharNum:=0 to 3 do writebin(chr(chars[CharNum]));
          end;
        byteNum:= succ(byteNum)
      end; {EncodeByte}

    begin {EncodeLine}
      outidx:=1;
      byteNum:=3;
      writebin(chr(count+offset));
      for i := 1 to count do begin l:=l-1; EncodeByte; end;
      writebin(chr(65));
    end; {EncodeLine}

  procedure terminate;

    var trailer    : string80;
        TERMINATOR : UNSIGNED_WORD;
        keyboard   : integer;

    begin {terminate}
     writeln(outfile,' A');
     writeln(outfile,'end');
     close (infile);
     close(outfile);
     smg$put_chars(display_id:=display,row:=9,column:=2,
                   text:='Finished. Please press Return.');
     smg$create_virtual_keyboard(keyboard_id:=keyboard);
     repeat
      smg$read_keystroke(keyboard_id:=keyboard,terminator_code:=terminator,
          display_id:=display,timeout:=1);
     until (terminator=270) or (terminator=13);
     smg$unpaste_virtual_display(display_id:=display,pasteboard_id:=pasteboard);
    end;

  begin {uuencode}
    init;
    line:=nil_qu;
    l:=0;
    nextline(line,l);
    l_line:=45;
    while not eof(infile) do
    begin
     while l>45 do encodeline(line,l,l_line);
     nextline(line,l);
    end;
    while l>45 do encodeline(line,l,l_line);
    l_line:=l;
    encodeline(line,l,l_line);
    terminate
  end.