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

Text File | 2020-01-01 | 20KB | 766 lines

$TITLE ('SEND - HANDLES PACKET TRANSFER BETWEEN LOCAL AND HOST SYSTEM')
send$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: */
/*      ctl, getc, prerrpkt, putc, rpack, rpar, send, senhelp, spack, */
/*        spar, tochar, and unchar */
do;

/* Global declarations for the communication module */

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

declare port1cmd literally '0F5H';
declare port2cmd literally '0F7H';
declare port1dat literally '0F4H';
declare port2dat literally '0F6H';

declare tx$rdy literally '01H';
declare rx$rdy literally '02H';
declare chrmsk literally '07FH';

declare space literally '020H';
declare cr literally '0DH';
declare lf literally '0AH';
declare null literally '00H';
declare crlf literally 'cr,lf,null';
declare bel literally '07H';
declare soh literally '1';
declare eofl literally '0';
declare delete literally '07FH';

declare myquote literally '023H';
declare mynumpads literally '0';
declare mypadchr literally '0';
declare myeol literally 'cr';
declare mytime literally '5';

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

declare pksize literally '94';
declare packet(pksize) byte public;    /* buffer for packets */
declare input$and byte external;        /* Mask for comm input bytes */
declare output$and byte external;        /* Mask for comm output bytes */
declare output$or byte external;        /* Mask for comm output bytes */

declare state byte external;        /* FSM last state */
declare msgnum byte external;        /* message number */
declare tries byte external;        /* max number of retries */

/* 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 */

declare pktcnt address;            /* tally of good blocks sent */
declare errcnt address;            /* tally of error transfers */

declare port byte external;        /* the port to use */
declare maxtry byte external;    /* the number of retries to attempt */
declare def$drive(5) byte external;     /* the default local drive */
declare filename address external;    /* the address of the filename */
declare localfile(15) byte;        /* full name of file on the local disk */
declare remotefile(11) byte;        /* file name sent to remote host */
declare fnptr address;
declare fnchr based fnptr byte;
declare (jfn, status, pklen) address;

declare debug byte external;

/* here are the subroutines */

exit:    procedure external;
end exit;

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

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

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

ci:    procedure byte external;
end ci;

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

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

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

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

newline: procedure external; end newline;

token:    procedure address external; end token;

movevar: procedure(offset, source, dest) byte external;
    declare offset byte;
    declare (source, dest) address;
end movevar;

/* GNXTFN: this routine returns a pointer to the next file in a file     */
/* list, or false if there are none.                                    */
gnxtfn:    procedure address;
    filename = token;
    return (filename > 0);
end gnxtfn;

/* PUTC: takes a character and a port, waits for transmit ready from    */
/* port and then sends the character to it.  Doesn't return a result       */
putc:   procedure (c, port) public;
    declare (c, status, port) byte;

    status = 0;
    do case port;
      do;
        call co(c);
      end;
      do;
        do while (status := input(port1cmd) and tx$rdy) = 0; end;
        output(port1dat) = ((c and output$and) or output$or);
      end;
      do;
        do while (status := input(port2cmd) and tx$rdy) = 0; end;
        output(port2dat) = ((c and output$and) or output$or);
      end;
    end;
end putc;

/* GETC: this routine waits for something from the receive port then     */
/* brings in the character and returns as a result.            */
getc:     procedure (port) byte public;
    declare (c, status, port) byte;

    status = 0;
    do case port;
      do;
        c = ci;
      end;
      do;
        do while status = 0;
          status = (input(port1cmd) and rx$rdy);
        end;
        c = (input(port1dat) and input$and);
      end;
      do;
        do while status = 0;
          status = (input(port2cmd) and rx$rdy);
        end;
        c = (input(port2dat) and input$and);
      end;
    end;
    return c;
end getc;

/* TOCHAR: takes a character and converts it to a printable character      */
/*         by adding a space                        */
tochar: procedure(char) byte public;
    declare char byte;
    return (char + space);
end tochar;

/* UNCHAR: undoes 'tochar' */
unchar:    procedure(char) byte public;
    declare char byte;
    return (char - space);
end unchar;

/* CTL: this routine takes a character and toggles the control bit    */
/* (ie. ^A becomes A and A becomes ^A).                    */
ctl:     procedure(char) byte public;
    declare char byte;
    declare cntrlbit literally '040H';
    return (char xor cntrlbit);
end ctl;

/* Print the contents of an error packet received from the remote host */
prerrpkt: procedure (pkt) public;
    declare pkt address;
    declare pkbyte based pkt byte;

    call print(.(cr,lf,'Error from remote KERMIT',null));
    if pkbyte = null then call newline; /* no message text */
    else
      do; /* display the message */
        call print(.(':\$'));
        call print(pkt);
      end;
    call newline;
end prerrpkt;

/* Close the disk input file */
closeup: procedure;
    call close(jfn, .status);
    if status > 0 then call print(.('\Unable to close file\$'));
end closeup;

/* spar: Build a Kermit initialization packet */
spar:     procedure (a) public;
    declare a address;
    declare b based a byte;

    b = tochar(pksize);        /* set up header */
    a = a + 1;
    b = tochar(mytime);
    a = a + 1;
    b = tochar(mynumpads);
    a = a + 1;
    b = ctl(mypadchr);
    a = a + 1;
    b = tochar(myeol);
    a = a + 1;
    b = myquote;
end spar;

/* rpar: Extract information from a Kermit initialization packet */
rpar:    procedure (addr) public;
    declare addr address;
    declare item based addr byte;

    spsize = unchar(item);        /* isn't plm wonderful? */
    addr = addr + 1;
    timeint = unchar(item);
    addr = addr + 1;
    numpads = unchar(item);
    addr = addr + 1;
    padchar = ctl(item);
    addr = addr + 1;
    eol = unchar(item);
    addr = addr + 1;
    quote = item;
end rpar;

bufill:    procedure (packet) byte;
    declare packet address;
    declare (pp, maxpp) address;
    declare (i, c, done) byte;
    declare chr based pp byte;
    declare count address;

    done = false;
    pp = packet;
    maxpp = pp + spsize - 8;
    do while not done;
      call read(jfn, .c, 1, .count, .status);
      if status > 0 then
        do;
          call print(.('Error reading file\$'));
          call exit;
        end;
      if count = 0 then
        done = true;
      else
        do;
          if ((c and chrmsk) < space) or
          ((c and chrmsk) = delete) then
            do;
              chr = quote;
              pp = pp + 1;
              chr = ctl(c);
            end;
          else
          if (c and chrmsk) = quote then
            do;
              chr = quote;
              pp = pp + 1;
              chr = c;
            end;
          else
            chr = c;
          pp = pp + 1;
          if pp >= maxpp then done = true;
        end;
    end;
    return (pp - packet);
end bufill;

/* SPACK: this routine sends a packet of data to the host.  It takes    */
/* four parameters, the type of packet, message number, packet length   */
/* and a pointer to a buffer containing what is to be output. It does    */
/* not return a value.                            */
spack:    procedure(type, pknum, length, packet) public;
    declare (type, pknum, length) byte;
    declare packet address;
    declare char based packet byte;
    declare (i, chksum) byte;

    if debug then do;
      call print(.('Sending packet ',null));
      call nout(pknum);
      call print(.(', total packet length is ',null));
      call nout(length + 5);  /* +5 for soh, count, seq, type, & chksum */
      call newline;
    end;

    i = 1;                    /* do padding */
    do while (i <= numpads);
      call putc(padchar, port);
      if debug then call co('p');
      i = i + 1;
    end;

    chksum = 0;
    /* send the packet header */

    call putc(soh, port);            /* send packet marker (soh) */
    if debug then call co('s');
    i = tochar(length + 3);
    chksum = i;
    call putc(i, port);            /* send character count     */
    if debug then call co('c');
    i = tochar(pknum);
    chksum = chksum + i;            /* add in packet number     */
    call putc(i, port);            /* send packet number        */
    if debug then call co('n');
    chksum = chksum + type;            /* add in packet type        */
    call putc(type, port);            /* send the packet type        */
    if debug then call co(type);

    /* now send the data */
    do i = 1 to length;
      chksum = chksum + char;
      call putc(char, port);
      if debug then call co(char); /* was co('.') */
      packet = packet + 1;
    end;

    /* check sum generation */

    chksum = ((chksum + (chksum and 192) / 64) and 63);
    chksum = tochar(chksum);
    call putc(chksum, port);        /* send the chksum */
    if debug then call co('c');

    call putc(eol, port);            /* terminate the packet */
    if debug then do;
      call print(.('e\$'));
      call co('.');
    end;
end spack;

/* RPACK: this routine receives a packet from the host.  It takes three    */
/* parameters: the address of where to put the length of the packet,    */
/* the address of where to put the packet number and the address of the */
/* buffer to receive the data.  It returns true for a positive reply or */
/* false for a NEGative reply.                        */
rpack:     procedure(length, pknum, packet) byte public;
    declare (length, pknum, packet, pkptr) address;

    declare len based length byte;
    declare num based pknum byte;
    declare pk based pkptr byte;
    declare (i, index, chksum, hischksum, type, inchar, msglen) byte;

    declare buffer(128) byte;

    if debug then call print(.('rpack | ',null));

    inchar = 0;            /* wait for a header */
    do while inchar <> soh; inchar = getc(port); end;
    index = 0;
    inchar = getc(port);
    do while (inchar <> myeol);
      buffer(index) = inchar;
      index = index + 1;
      inchar = getc(port);
    end;
    buffer(index) = null;
    if debug then
      do;
        call print(.('Received packet: [',null));
        call print(.buffer);
        call print(.(']\Length of message: $'));
      end;
    msglen = index - 1;
    if debug then
      do;
        call nout(msglen);
        call newline;
        call print(.('Length field: $'));
        call nout(buffer(0));
        call co('_');
  end;
    len = unchar(buffer(0)-3);
    if debug then
      do;
        call nout(len);
        call print(.('\Message number: $'));
        call nout(buffer(1));
        call co('_');
      end;
    num = unchar(buffer(1));
    if debug then
      do;
        call nout(num);
        call print(.('\Type: $'));
      end;
    type = buffer(2);
    if debug then
      do;
        call co(type);
        call newline;
      end; /* debug */

    pkptr = packet;
    chksum = buffer(0) + buffer(1) + buffer(2);

    i = 3;                /* index of first data character */
    do while (i < msglen);
      chksum = (pk := buffer(i)) + chksum;
      pkptr = pkptr+1;
      i = i + 1;
    end;
    pk = null;        /* terminate with null for printing */

    chksum = (chksum + ((chksum and 192) / 64)) and 63;
    if debug then
      do;
        call print(.('His checksum: $'));
        call nout(buffer(msglen));
        call co('_');
      end; /* debug */
    hischksum = unchar(buffer(msglen));
    if debug then
      do;
        call nout(hischksum);
        call print(.('\Our checksum: $'));
        call nout(chksum);
        call newline;
      end; /* debug */
    if chksum <> hischksum then
      do;
        if debug then call print(.('Bad checksum received\$'));
        return false;
      end;
    return type;
end rpack;

/* SDATA: this routine sends the data from the buffer area to the host.    */
/* It takes no parameters but returns the next state depending on the    */
/* type of acknowledgement.                        */
sdata:     procedure byte;
    declare (num, length, retc, retst, c) byte;

    if debug then call print(.('sdata...\$'));

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

    if ready(0) > 0 then
      do; /* There is a keystroke ready */
        c = getc(0);
        if (c = 24 or c = 26) then /* ctrl-X or ctrl-Z */
          do;
            call closeup;
            packet(0) = 'D'; /* Delete this file */
            call spack('Z', msgnum, 1, .packet);
            if c = 26 then /* ctrl-Z means stop all */
              do;
                msgnum = (msgnum + 1) mod 64;
                return 'B';
              end;
            else
              do;
                if gnxtfn = false then /* No more file names */
                  do;
                    msgnum = (msgnum + 1) mod 64;
                    return 'B';
                  end;
                else return 'S';
              end;
          end;
      end;

    call spack('D', msgnum, pklen, .packet);

    retc = rpack(.length, .num, .packet);
    if (retc = 'N') then
      do;
        if (((msgnum + 1) mod 64) = num) then /* NAK for next packet */
          retc = 'Y'; /* force into next test */
        else
          do;
            errcnt = errcnt + 1;
            retst = state; /* establish return state */
          end;
      end;

    if (retc = 'Y') then
      do;
        tries = 0;
        pktcnt = pktcnt + 1;
        msgnum = (msgnum + 1) mod 64;
        pklen = bufill(.packet);
        if pklen > 0 then retst = 'D';
        else retst = 'Z';
      end;

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

    else if (retc = false) then retst = state;

    else return 'A';

    /* Report transfer progress */
    call print(.(cr,'Packets sent: $'));
    call nout(pktcnt);
    call print(.('; number of retries: $'));
    call nout(errcnt);
    if debug then call print(.(crlf));
    return retst;
end sdata;

/* SFILE: this routine sends a packet to the host which contains the     */
/* filename of the file being sent so that the file can be created at    */
/* the host end. It returns a new state depending on the nature of the    */
/* the host's acknowledgement.                        */
sfile:     procedure byte;
    declare (num, length, retc) byte;

    if debug then call print(.('sfile...\$'));

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

    length = 0;            /* count characters in filename */
    fnptr = .remotefile;
    do while fnchr > space;
      length = length + 1;
      fnptr = fnptr + 1;
    end;
    if debug then call print(.('\Filename is: $'));
    call print(.localfile);
    if (filename > 0) then
      do;
        call print(.(' to $'));
        call print(.remotefile);
      end;
    call newline;
    if debug then
      do;
        call print(.('File name length is: $'));
        call nout(length);
        call newline;
      end; /* debug */
    call spack('F', msgnum, length, .remotefile);
    retc = rpack(.length, .num, .packet);

    if (retc = 'N') then return state;
    if (retc = 'E') then
      do;
        call prerrpkt(.packet);
        return 'A';
      end;
    if (retc <> 'Y') then return 'A';
    /* here on valid acknowledgement */
    tries = 0;
    msgnum = (msgnum + 1) mod 64;
    pktcnt = 0;
    errcnt = 0;
    pklen = bufill(.packet);
    if pklen > 0 then return 'D';
      else return 'Z';
end sfile;

/* SEOF: this routine is used when eof is detected, it closes up and    */
/* returns the new state as usual.    */
seof:    procedure byte;
    declare (num, length, retc) byte;

    if debug then call print(.('seof...\$'));

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

    call spack('Z', msgnum, 0, .packet);
    retc = rpack(.length, .num, .packet);
    if (retc = 'N') then return state;
    if (retc = 'E') then
      do;
        call prerrpkt(.packet);
        return 'A';
      end;
    if (retc <> 'Y') then return 'A';
    /* here on valid acknowledgement */
    tries = 0;
    call closeup;
    if gnxtfn = false then
      do;
        msgnum = (msgnum + 1) mod 64;
        return 'B';
      end;
    else return 'S';
end seof;

/* SINIT: this routine does initializations and opens the file to be    */
/* sent; it returns a new state depending on the outcome of trying to   */
/* open the file. */
sinit:    procedure byte;
    declare (len, num, retc) byte;
    declare foffset byte;

    call print(.('\Sending $'));

    if debug then call print(.('sinit...\$'));

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

    if filename = 0 then return 'A';
    call spar(.packet);
    call spack('S', msgnum, 6, .packet);    /* send start packet */

    retc = rpack(.len, .num, .packet);
    if (retc = 'N') then return state;
    if (retc = 'E') then
      do;
        call prerrpkt(.packet);
        return 'A';
      end;
    if (retc <> 'Y') then return 'A';
    /* here on valid acknowledgement */
    call rpar(.packet);
    if eol = 0 then eol = myeol;
    if quote = 0 then quote = myquote;
    tries = 0;
    msgnum = (msgnum + 1) mod 64;
    /* Crack the file name */
    fnptr = filename;
    if fnchr = ':' then
      do; /* File name on command has a drive */
        foffset = movevar(0,filename,.localfile); /* Use file name as-is */
        foffset = movevar(0,filename+4,.remotefile); /* Strip drive */
      end;
    else
      do;
        foffset = movevar(0,.def$drive,.localfile); /* Build local file name */
        foffset = movevar(foffset,filename,.localfile); /*  from default drive */
        foffset = movevar(0,filename,.remotefile);
      end;
    filename = token; /* Check for second operand */
    if (filename > 0) then /* use 2nd operand for remote file name */
      foffset = movevar(0,filename,.remotefile);
    call open(.jfn, .localfile, readonly, noedit, .status);
    if (status > 0) then
      do;
        call print(.('\Cannot open file $'));
        call print(.localfile);
        call print(.(crlf));
        return 'A';
      end;
    else return 'F';
end sinit;

/* SBREAK: this module breaks the flow of control at the end of a     */
/* transmission and allows the send routine to terminate by returning    */
/* either a successful or failure condition to the main kermit routine. */
sbreak:    procedure byte;
    declare (num, length, retc) byte;

    if debug then call print(.('sbreak...\$'));

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

    call spack('B', msgnum, 0, .packet);
    retc = rpack(.length, .num, .packet);

    if (retc = 'N') then return state;
    if (retc = 'E') then
      do;
        call prerrpkt(.packet);
        return 'A';
      end;
    if (retc <> 'Y') then return 'A';
    /* we only get here if we received a valid acknowledgement */
    tries = 0;
    msgnum = (msgnum + 1) mod 64;
    return 'C';
end sbreak;

/* Display help for the SEND command */
senhelp: procedure public;
    call print(.('\SEND\\$'));
    call print(.('  The SEND command causes Kermit to send a file $'));
    call print(.('to the remote Kermit.\\$'));
    call print(.('Syntax:\\$'));
    call print(.('    SEND file [remote-file]\\$'));
    call print(.('If the "remote-file" is specified, that name will be $'));
    call print(.('used by the remote\$'));
    call print(.('Kermit.\\$'));
end senhelp;

/* SEND: This is the main code for the send command.  It is an FSM for    */
/* sending files. The main loop calls various routines until it     */
/* finishes or an error occurs. */
send:   procedure public;

    filename = token; /* Get the command line file name */
    if (filename = 0) then
      do;
        call print(.('No files specified\$'));
        return;
      end;
    state = 'S';                /* start in Send-Init state */
    msgnum = 0;
    tries = 0;

    do while (state <> true and state <> false);
      if debug then
        do;
          call print(.('state : ',null));
          call co(state);
          call newline;
        end;
      if state = 'D' then state = sdata;
      else
        if state = 'F' then state = sfile;
        else
          if state = 'Z' then state = seof;
          else
            if state = 'S' then state = sinit;
        else
          if state = 'B' then state = sbreak;
              else
            if state = 'C' then state = true;
            else
              if state = 'A' then state = false;
              else state = false;
    end;
    if state then call print(.('\OK',bel,crlf));
    else call print(.('Send failed\$'));

end send;

end send$module;