Columbia Kermit/kermit.zip/intelmdsb/mdsrcv.p80

Text File | 2020-01-01 | 14KB | 566 lines

$TITLE ('RECV - RECEIVES FILES FROM REMOTE KERMIT')
recv$module:

/* COPYRIGHT (C) 1985, Trustees of Columbia University in the City of New */
/* York.  Permission is granted to any individual or institution to use,  */
/* copy, or redistribute this software so long as it is not sold for      */
/* profit, provided this copyright notice is retained. /*

/* Contains the following public routines: */
/*      movevar, rdata, ready, rechelp, recv, and rfile */
do;

declare true literally '0FFH';
declare false literally '00H';

declare port1cmd literally '0F5H';
declare port2cmd literally '0F7H';
declare rx$rdy literally '02H';

declare null literally '00';
declare cr literally '0DH';
declare lf literally '0AH';
declare crlf literally 'cr,lf,null';
declare bel literally '07H';
declare myquote literally '023H';
declare chrmsk literally '07FH';

declare readonly literally '1';
declare writeonly literally '2';
declare noedit literally '0';

declare state byte external;
declare msgnum byte external;
declare tries byte external;
declare oldtry byte external;

declare pktcnt address;
declare errcnt address;

declare port byte external;
declare debug byte external;
declare maxtry byte external;
declare warning$flag byte external;
declare def$drive(5) byte external;
declare localname(20) byte;
declare filename address external;

declare pksize literally '94';
declare packet(pksize) byte external;
declare (jfn, count, status) address;

/* Current Kermit parameters */
declare spsize byte external;    /* the present packet size */
declare timeint byte external;    /* the present time out */
declare numpads byte external;    /* how many pads to send */
declare padchar byte external;    /* the present pad character */
declare eol byte external;        /* the present eol character */
declare quote byte external;    /* the present quote character */

ci:    procedure byte external;
end ci;

csts:    procedure byte external;
end csts;

co:    procedure(char)external;
    declare char byte;
end co;

print:  procedure(string)external;
    declare string address;
end print;

nout:     procedure(num)external;
    declare num address;
end nout;

newline: procedure external; end newline;

token:    procedure address external;    end token;

open:    procedure(jfn, file, access, mode, status) external;
    declare (jfn, file, access, mode, status) address;
end open;

write:     procedure(jfn, buffer, count, status) external;
    declare (jfn, buffer, count, status) address;
end write;

close:    procedure(jfn, status) external;
    declare (jfn, status) address;
end close;

delete:    procedure(file, status) external;
    declare (file, status) address;
end delete;

exit:    procedure external;
end exit;

getc:    procedure(port) byte external;
    declare port byte;
end getc;

ctl:    procedure(char) byte external;
    declare char byte;
end ctl;

spack:     procedure(type, pknum, length, packet) external;
    declare (type, pknum, length, packet) address;
end spack;

rpack:     procedure(length, pknum, packet) byte external;
    declare (length, pknum, packet) address;
end rpack;

spar:    procedure (a) external;
    declare a address;
end spar;

rpar:    procedure (a) external;
    declare a address;
end rpar;

/* Print an error packet */
prerrpkt: procedure (pkt) external;
    declare pkt address;
end prerrpkt;

/* Move a variable string from source to dest until a null is found. */
/*   The value of offset defines the starting point in dest of the move */
movevar: procedure (offset, source, dest) byte public;
    declare offset byte;
    declare (source, dest) address;
    declare schr based source byte;
    declare dchr based dest byte;
    dest = dest + offset;
    do while schr <> null;
      dchr = schr;
      source = source + 1;
      dest = dest + 1;
      offset = offset + 1;
    end;
    dchr = null; /* append a null */
    return offset;
end movevar;

/* Alter the local file name in an effort to create a unique name */
altername:    procedure (flname);
    declare flname address;
    declare (fnchar based flname)(20) byte;
    declare (basestart, perloc, stopper) byte;
    declare (adjusted, offset) byte;
    declare (i, j) byte;

    /* Locate the start of the root name */
    if fnchar(0) = ':' then basestart = 4; /* skip drive spec */
    else basestart = 0;
    i = basestart;
    perloc = 0;
    do while fnchar(i) <> null;
      if fnchar(i) = '.' then /* found a period */
        if perloc = 0 then perloc = i;
      i = i + 1;
    end;
    stopper = i;
    if perloc = 0 then
      do; /* name has no extension, so add an extension of "0" */
        fnchar(stopper) = '.';
        fnchar(stopper+1) = '0';
        fnchar(stopper+2) = null;
        stopper = stopper + 2;
      end;
    else
      if (perloc - basestart) < 6 then
        do; /* the base name is shorter than 6 chars */
          i = stopper;
          do while i >= perloc; /* shift the extension right 1 char */
            fnchar(i+1) = fnchar(i);
            i = i - 1;
          end;
          fnchar(perloc) = '0'; /* insert a zero before the period */
          perloc = perloc + 1; /* Adjust the */
          stopper = stopper + 1; /*  pointers */
        end;
      else
        if (stopper - perloc) < 4 then
          do; /* Extension is short, so add a zero */
            fnchar(stopper) = '0';
            stopper = stopper + 1;
            fnchar(stopper) = null;
          end;
        else /* Both parts of the name are full */
          do;
            i = perloc - 1; /* point to end of base name */
            adjusted = false;
            do while not adjusted;
              if fnchar(i) < 'Z' then
                do;
                  fnchar(i) = fnchar(i) + 1;
                  adjusted = true;
                end;
              else
                if fnchar(i) >= 'a' and fnchar(i) < 'z' then
                  do;
                    fnchar(i) = fnchar(i) + 1;
                    adjusted = true;
                  end;
                else
                  do;
                    if i <= basestart then i = stopper - 1;
                    else i = i - 1;
                    if i = perloc then
                      do;
                        offset = movevar(0,
                          .('A00000.000',null), flname);
                        adjusted = true;
                      end;
                  end;
            end;
          end;
end altername;

/* Find a local file name which doesn't conflict with existing files */
find$good$name:    procedure (flname);
    declare flname address;
    declare successful byte;

    successful = false;
    do while not successful;
      call altername(flname);
      call open(.jfn, flname, readonly, noedit, .status);
      if status = 0 then call close(jfn, .status); /* still a duplicate */
      else successful = true;
    end;
end find$good$name;

ready:    procedure (port) byte public;
    declare (port, status) byte;
    do case port;
      do;
        status = csts;
      end;
      do;
        status = input(port1cmd) and rx$rdy;
      end;
      do;
        status = input(port2cmd) and rx$rdy;
      end;
    end;
    return status;
end ready;

bufemp:    procedure(packet, len);
    declare packet address;
    declare inchar based packet byte;
    declare (i, char, len) byte;

    if debug then call print(.('Writing to disk...',null));
    i = 0;
    do while (i < len);
      char  = inchar;
      if char = myquote then do;
        packet = packet + 1;
        i = i + 1;
        char = inchar;
        if (char and chrmsk) <> myquote then char = ctl(char);
      end;
      if debug then call co(char);
      call write(jfn, .char, 1, .status);
      if status > 0 then do;
        call print(.('Write error ',null));
        call nout(status);
        call newline;
      call exit;
      end;
      packet = packet + 1;
      i = i + 1;
    end;
    if debug then call newline;
end bufemp;

rinit:     procedure byte;
    declare (len, num, retc) byte;

    if tries > maxtry then return 'A';
    else tries = tries + 1;

    if debug then call print(.('rinit...',crlf));

    retc = rpack(.len, .num, .packet);
    if (retc = 'S') then /* send init received */
      do;
        call rpar(.packet);
        call spar(.packet);
        call spack('Y', msgnum, 6, .packet);
        oldtry = tries;
        tries = 0;
        msgnum = (msgnum + 1) mod 64;
        return 'F';
      end;

    if (retc = 'E') then do; /* Error packet received */
      call prerrpkt(.packet);
      return 'A';
    end;

    if (retc = false) then
      do;
        call spack('N', msgnum, 0, 0);
        return state;
      end;

    return 'A';
end rinit;

rfile:    procedure byte public;
    declare (len, num, retc) byte;
    declare foffset byte;
    declare fnptr address;
    declare fnchr based fnptr byte;

    if tries > maxtry then return 'A';
    else tries = tries + 1;

    if debug then call print(.('rfile...',crlf));

    retc = rpack(.len, .num, .packet);

    if retc = 'S' then do;
      if (oldtry > maxtry) then return 'A';
        else oldtry = oldtry + 1;
      if (((num + 1) mod 64) = msgnum) then /* previous packet again */
        do;
          call spar(.packet);
           call spack('Y', num, 6, .packet); /* re-ACK it */
          tries = 0;
          return state;
        end;
      else return 'A';
    end;

    if retc = 'Z' then do;
      if (oldtry > maxtry) then return 'A';
        else oldtry = oldtry + 1;
      if (num = msgnum - 1) then
        do;
          call spack('Y', num, 0, 0);
          tries = 0;
          return state;
        end;
      else return 'A';
    end;

    if retc = 'F' then do;
      if (num <> msgnum) then return 'A';
      call print(.(cr,lf,'Receiving ',null));
      /* Construct the (local) ISIS file name */
      if (filename = 0) then /* Use the remote name if no operand */
        do;
          foffset = movevar(0,.def$drive,.localname);
          foffset = movevar(foffset,.packet,.localname);
        end;
      else
        do;
          call print(.packet);
          call print(.(' to $'));
          fnptr = filename;
          if fnchr = ':' then /* File name on command line has a drive */
            foffset = movevar(0, filename, .localname);
          else
            do; /* Build file name from default drive */
              foffset = movevar(0, .def$drive, .localname);
              foffset = movevar(foffset, filename, .localname);
            end;
        end;
      call print(.localname);
      call print(.(crlf));
      if warning$flag then
        do; /* Check for a pre-existing local file */
          call open(.jfn, .localname, readonly, noedit, .status);
          if status = 0 then
            do; /* the file already exists */
              call close(jfn, .status);
              call find$good$name(.localname); /* Mod file name */
              call print(.('Using local file name of $'));
              call print(.localname);
              call print(.('; other name already in use.\$'));
            end;
        end;
      call open(.jfn, .localname, writeonly, noedit, .status);
      if status > 0 then
        do;
          call print (.('Unable to create file, error ', null));
          call nout(status);
          call newline;
          return 'A';
        end;
      call spack('Y', msgnum, 0, 0);
      oldtry = tries;
      tries = 0;
      msgnum = (msgnum + 1) mod 64;
      pktcnt = 0;
      errcnt = 0;
      return 'D';
    end;

    if retc = 'B' then do;
      if (num <> msgnum) then return 'A';
      call spack('Y', msgnum, 0, 0);
      return 'C';
    end;

    if retc = 'E' then do; /* Error packet received */
      call prerrpkt(.packet);
      return 'A';
    end;

    return state;
end rfile;

rdata:     procedure byte public;
    declare (num, len, retc, retst, c) byte;

    if tries > maxtry then return 'A';
      else tries = tries + 1;

    if debug then call print(.('rdata...',crlf));

    retc = rpack(.len, .num, .packet);

    if retc = 'D' then do;
      if (num <> msgnum) then
        do;
          if (oldtry > maxtry) then return 'A';
          oldtry = oldtry + 1;
          if (((num + 1) mod 64) = msgnum) then /* prev packet again */
            do;
              call spar(.packet);
              call spack('Y', num, 6, .packet); /* re-ACK it */
              tries = 0;
              retst = state;
            end;
          else return 'A';
        end;
      else
        do; /* correct packet */
          call bufemp(.packet, len);
          if ready(0) = 0 then /* no console input */
            call spack('Y', msgnum, 0, 0);
          else
            do; /* There is a keystroke ready */
              c = getc(0);
              if (c = 24 or c = 26) then /* ctrl-X or ctrl-Z */
                do; /* Send the char with the ACK */
                  packet(0) = ctl(c);
                  call spack('Y', msgnum, 1, .packet);
                end;
              else /* Ignore the keystroke */
                call spack('Y', msgnum, 0, 0);
            end;
          oldtry = tries;
          pktcnt = pktcnt + 1;
           tries = 0;
           msgnum = (msgnum + 1) mod 64;
          retst = 'D';
        end;
      end;

    else if retc = 'F' then do;
      if (oldtry > maxtry) then return 'A';
        else oldtry = oldtry + 1;
      if (num = msgnum - 1) then
        do;
          call spack('Y', num, 0, 0);
          tries = 0;
          retst = state;
        end;
      else return 'A';
      end;

    else if retc = 'Z' then do;
      if (num <> msgnum) then return 'A';
      call spack('Y', msgnum, 0, 0);
      call close(jfn, .status);
      if status > 0 then call print(.(cr,lf,'Unable to close file',null));
      if len > 0 then /* There was data with the packet */
        if packet(0) = 'D' then
          do; /* File deletion requested by remote Kermit */
            call delete(.localname, .status);
            if status = 0 then
              do;
                call print(.(cr,lf,'File $'));
                call print(.localname);
                call print(.(' deleted on request from remote Kermit',crlf));
              end;
            else
              call print(.('Requested file delete failed',crlf));
          end;
      msgnum = (msgnum + 1) mod 64;
      retst = 'F';
      end;

    else if retc = 'E' then /* Error packet received */
      do;
        call prerrpkt(.packet);
        return 'A';
      end;

    else if retc = false then /* Reception error */
      do;
        errcnt = errcnt + 1;
        call spack('N', msgnum, 0, 0);
        retst = state;
      end;
    if retst <> 'A' and retst <> 'F' then
      do;
        /* Report transfer progress */
        call print(.(cr,'Packets received: $'));
        call nout(pktcnt);
        call print(.('; number of retries: $'));
        call nout(errcnt);
        if debug then call print(.(crlf));
      end;
    return retst;

end rdata;

/* Display help for the RECEIVE command */
rechelp:procedure public;
    call print(.('\RECEIVE\\$'));
    call print(.('  The RECEIVE command causes KERMIT to wait for $'));
    call print(.('a file to be sent by the\$'));
    call print(.('remote Kermit.\\$'));
    call print(.('Syntax:\\$'));
    call print(.('    RECEIVE [local-file]\\$'));
    call print(.('If the "local-file" is not specified, Kermit will $'));
    call print(.('name the local file with\$'));
    call print(.('the file name sent by the remote Kermit.\\$'));
end rechelp;

recv:   procedure public;

    if debug then call print(.('Receive a file',crlf));
    state = 'R';
    msgnum = 0;
    tries = 0;
    oldtry = 0;
    filename = token; /* Capture operand, if any */
    do while (state <> true and state <> false);
      if state = 'D' then state = rdata;
      else
         if state = 'F' then state = rfile;
         else
            if state = 'R' then state = rinit;
        else
            if state = 'C' then state = true;
            else state = false;
    end;
    if state then call print(.('\OK',bel,crlf));
    else call print(.('receive failed\$'));

end recv;

end recv$module;