home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / intel86 / kerutil.p86 < prev   
Text File  |  2020-01-01  |  39KB  |  1,231 lines
  1. $large
  2.  
  3. Kermit$util: do;
  4.  
  5. /*
  6.  *      K e r m i t   File Transfer Utility
  7.  *
  8.  *      iRMX-86 Kermit, Version 2.3
  9.  *      by Albert J. Goodman, Grinnell College
  10.  *
  11.  *      General Kermit utilities module.
  12.  *      Edit date:  2-June-1985
  13.  */
  14.  
  15.  
  16. /* Define the system type TOKEN */
  17. $include(:I:LTKSEL.LIT)
  18.  
  19.  
  20. declare
  21.                 /* CONSTANTS */
  22.  
  23.             /* Useful text substitutions */
  24.     boolean                 literally   'byte',     /* define a new type */
  25.     TRUE                    literally   '0FFh',     /* and constants */
  26.     FALSE                   literally   '000h',     /*  of that type */
  27.  
  28.             /* ASCII control character constants */
  29.     NUL                     literally   '00h',  /* null */
  30.     SOH                     literally   '01h',  /* start-of-header */
  31.     CTRL$C                  literally   '03h',  /* CTRL/C */
  32.     BEL                     literally   '07h',  /* bell (beep) */
  33.     BS                      literally   '08h',  /* backspace */
  34.     HT                      literally   '09h',  /* horizontal tab */
  35.     LF                      literally   '0Ah',  /* line-feed */
  36.     CR                      literally   '0Dh',  /* carriage-return */
  37.     CTRL$R$BRAK             literally   '1Dh',  /* CTRL/] */
  38.     DEL                     literally   '7Fh',  /* delete (rubout) */
  39.  
  40.             /* Defaults for various Kermit parameters */
  41.     def$packet$len          literally   '80',
  42.     def$time$limit          literally   '10',
  43.     def$num$pad             literally   '0',
  44.     def$pad$char            literally   'NUL',
  45.     def$eol                 literally   'CR',
  46.     def$quote               literally   '''#''',
  47.  
  48.             /* GET$REMOTE$CHAR return codes (see KERMIT$SYS) */
  49.     TIMEOUT                 literally   '0FFFFh',   /* Time limit expired */
  50.     CTRL$C$CODE             literally   '08003h',   /* CTRL/C abort */
  51.             /* READ$CHAR return code (see KERMIT$SYS) */
  52.     EOF$CODE                literally   '0FF00h',   /* end-of-file */
  53.  
  54.             /* Other constants */
  55.     MAX$PACKET$LEN          literally   '94',
  56.     MAX$KEYWORDS            literally   '5',
  57.  
  58.             /* String constant (for PRINT$SPACES) */
  59.     spaces$string(*)        byte data( 15, '               ' ),
  60.  
  61.  
  62.                 /* GLOBAL VARIABLES */
  63.  
  64.             /* Token (defined in KERMIT$SYS) */
  65.     cur$file    token external, /* Connection to the current file */
  66.  
  67.             /* Kermit parameters (defined in main module) */
  68.     debug       boolean external,   /* Whether we're debugging the program */
  69.     max$retry   byte external,  /* Maximum number of times to retry a packet */
  70.     packet$len  byte external,  /* The maximum length packet to send */
  71.     time$limit  byte external,  /* Seconds to time out if nothing received */
  72.     num$pad     byte external,  /* The number of padding characters to send */
  73.     pad$char    byte external,  /* The padding character to send */
  74.     eol         byte external,  /* The EOL (end-of-line) character to send */
  75.     quote       byte external,  /* The control-quote character to be used */
  76.  
  77.             /* Other Kermit variables (defined in main module) */
  78.     state       byte external,  /* Current state */
  79.     seq         byte external,  /* The current sequence number (0 to 63) */
  80.     tries       byte external,  /* Number of times current packet retried */
  81.  
  82.             /* Buffers */
  83.     com$line    structure(      /* The buffer for the command line */
  84.                     len     byte,
  85.                     ch(80)  byte) external, /* defined in KERMIT$SYS */
  86.  
  87.             /* Comand parsing information */
  88.     num$keywords    byte public,    /* Number of keywords in KEYWORD array */
  89.     keyword(MAX$KEYWORDS)   structure(      /* the keywords in COM$LINE */
  90.                                 index   byte,   /* starting index */
  91.                                 len     byte);  /* length without spaces */
  92.  
  93.  
  94. /*      External procedures defined in KERMIT$SYS   */
  95.  
  96. get$remote$char: procedure( time$limit ) word external;
  97.     declare
  98.         time$limit  word;
  99. end get$remote$char;
  100.  
  101. xmit$remote$char: procedure( ch ) external;
  102.     declare
  103.         ch  byte;
  104. end xmit$remote$char;
  105.  
  106. print: procedure( string$ptr ) external;
  107.     declare
  108.         string$ptr  pointer;
  109. end print;
  110.  
  111. new$line: procedure external;
  112. end new$line;
  113.  
  114. print$char: procedure( ch ) external;
  115.     declare
  116.         ch  byte;
  117. end print$char;
  118.  
  119. read$char: procedure( file ) word external;
  120.     declare
  121.         file    token;
  122. end read$char;
  123.  
  124. write$char: procedure( file, ch ) external;
  125.     declare
  126.         file    token,
  127.         ch      byte;
  128. end write$char;
  129.  
  130.  
  131. /*
  132.  *
  133.  *      General Kermit utility functions
  134.  *
  135.  */
  136.  
  137.  
  138. char: procedure( x ) byte;
  139.  
  140.     /*
  141.      *  Transform an integer in the range 0 to 94 (decimal)
  142.      *  into a printable ASCII character.
  143.      */
  144.  
  145.     declare
  146.         x   byte;
  147.  
  148.     return( x + ' ' );
  149.  
  150. end char;
  151.  
  152.  
  153. unchar: procedure( x ) byte;
  154.  
  155.     /*
  156.      *  Reverse the CHAR transformation.
  157.      */
  158.  
  159.     declare
  160.         x   byte;
  161.  
  162.     return( x - ' ' );
  163.  
  164. end unchar;
  165.  
  166.  
  167. ctl: procedure( x ) byte;
  168.  
  169.     /*
  170.      *  Transform a control character into its printable representation,
  171.      *  and vice-versa.  I.e. CTRL/A becomes A, and A becomes CTRL/A.
  172.      */
  173.  
  174.     declare
  175.         x   byte;
  176.  
  177.     return( x XOR 40h );
  178.  
  179. end ctl;
  180.  
  181.  
  182. upcase: procedure( x ) byte public;
  183.  
  184.     /*
  185.      *  Force an ASCII letter to upper-case;
  186.      *  a non-letter is returned unchanged.
  187.      */
  188.  
  189.     declare
  190.         x   byte;
  191.  
  192.     if ( ( x >= 'a' ) and ( x <= 'z' ) ) then   /* it was lower-case */
  193.         return( x - 'a' + 'A' );    /* return the upper-case equivalent */
  194.     else    /* it was anything else */
  195.         return( x );    /* just return it unchanged */
  196.  
  197. end upcase;
  198.  
  199.  
  200. low7: procedure( x ) byte;
  201.  
  202.     /*
  203.      *  Return the low-order seven bits of a character,
  204.      *  i.e. set the eighth bit to zero, stripping the parity bit.
  205.      */
  206.  
  207.     declare
  208.         x   byte;
  209.  
  210.     return( x AND 07Fh );
  211.  
  212. end low7;
  213.  
  214.  
  215. not$printable: procedure( x ) boolean;
  216.  
  217.     /*
  218.      *  Determine whether an ASCII character is a printable character
  219.      *  or not; return TRUE if it is a control character, FALSE if it's
  220.      *  printable.  Assumes the high-order (parity) bit is not set.
  221.      */
  222.  
  223.     declare
  224.         x   byte;
  225.  
  226.     return( ( x < ' ' ) or ( x = DEL ) );
  227.  
  228. end not$printable;
  229.  
  230.  
  231. special$char: procedure( x ) boolean;
  232.  
  233.     /*
  234.      *  Returns TRUE if X is a quoting or prefix
  235.      *  character currently being used (i.e. if
  236.      *  it needs to be quoted itself).  Assumes
  237.      *  the high-order (parity) bit is not set.
  238.      */
  239.  
  240.     declare
  241.         x       byte;
  242.  
  243.     /* Only the control-quote is implemented so far */
  244.     return( x = quote );
  245.  
  246. end special$char;
  247.  
  248.  
  249. next$seq: procedure( seq$num ) byte public;
  250.  
  251.     /*
  252.      *  Return the next sequence number after SEQ$NUM; that is,
  253.      *  SEQ$NUM + 1 modulo 64.
  254.      */
  255.  
  256.     declare
  257.         seq$num     byte;
  258.  
  259.     return( ( seq$num + 1 ) AND 03Fh );
  260.  
  261. end next$seq;
  262.  
  263.  
  264. previous$seq: procedure( seq$num ) byte public;
  265.  
  266.     /*
  267.      *  Return the previous sequence number to SEQ$NUM.
  268.      */
  269.  
  270.     declare
  271.         seq$num     byte;
  272.  
  273.     if ( seq$num = 0 ) then
  274.         return( 63 );
  275.     else
  276.         return( seq$num - 1 );
  277.  
  278. end previous$seq;
  279.  
  280.  
  281. /*
  282.  *
  283.  *      Output display procedures
  284.  *
  285.  */
  286.  
  287.  
  288. show$char: procedure( ch ) public;
  289.  
  290.     /*
  291.      *  Display a character on the console in readable form,
  292.      *  even if it is a control character.  It is assumed
  293.      *  that the high-order bit is not set.
  294.      */
  295.  
  296.     declare
  297.         ch  byte;
  298.  
  299.     if ( not$printable( ch ) ) then
  300.       do;   /* Display the character in a readable form */
  301.         if ( ch = DEL ) then    /* Display DEL specially */
  302.             call print( @( 5, '<DEL>' ) );
  303.         else
  304.           do;   /* display an ordinary control character */
  305.             call print( @( 6,'<Ctrl-' ) );
  306.             call print$char( ctl( ch ) );
  307.             call print$char( '>' );
  308.           end;  /* else */
  309.       end;  /* if ( not$printable( ch ) ) */
  310.     else    /* It's printable, so just display it */
  311.         call print$char( ch );
  312.  
  313. end show$char;
  314.  
  315.  
  316. show$dec$num: procedure( num ) public;
  317.  
  318.     /*
  319.      *  Display the value of a number in decimal on the console.
  320.      */
  321.  
  322.     declare
  323.         ( num, digit, i )   word,
  324.         string              structure(
  325.                                 len     byte,
  326.                                 ch(5)   byte);
  327.  
  328.     i = 5;  /* Start at the last (least-significant) digit */
  329.     do while ( num > 0 );   /* As long as there are more digits */
  330.         digit = num mod 10;     /* Get the current least-significant digit */
  331.         num = ( num - digit ) / 10;     /* Remove it from the number */
  332.         i = i - 1;                      /* Back up one place */
  333.         string.ch(i) = digit + '0';     /* Convert the digit to ASCII */
  334.     end;    /* do while */
  335.     string.len = 5 - i;     /* Find the length of the number */
  336.     if ( string.len = 0 ) then
  337.         do;     /* Display zero as 0, not a null string */
  338.             string.ch(0) = '0';
  339.             string.len = 1;
  340.         end;    /* if ... */
  341.     else if ( i > 0 ) then  /* If we didn't use all five spaces, */
  342.         /* Move the number down to the start of the buffer */
  343.         call movb( @string.ch(i), @string.ch(0), string.len );
  344.     call print( @string );  /* display the number */
  345.  
  346. end show$dec$num;
  347.  
  348.  
  349. show$flag: procedure( flag ) public;
  350.  
  351.     /*
  352.      *  Display the value of a boolean flag on the console:
  353.      *  If the flag is TRUE, display ON, if the flag is FALSE,
  354.      *  display OFF.
  355.      */
  356.  
  357.     declare
  358.         flag    boolean;
  359.  
  360.     if ( flag ) then
  361.         call print( @( 2,'ON' ) );
  362.     else
  363.         call print( @( 3,'OFF' ) );
  364.  
  365. end show$flag;
  366.  
  367.  
  368. print$spaces: procedure( num );
  369.  
  370.     /*
  371.      *  Print NUM spaces on the console.
  372.      */
  373.  
  374.     declare
  375.         num     byte,
  376.         len     byte at( @spaces$string );
  377.  
  378.     len = num;  /* set length to be printed this time--must not be > 15 */
  379.     call print( @spaces$string );   /* print them */
  380.  
  381. end print$spaces;
  382.  
  383.  
  384. /*
  385.  *
  386.  *      Kermit protocol communication routines
  387.  *
  388.  */
  389.  
  390.  
  391. send$char: procedure( ch );
  392.  
  393.     /*
  394.      *  Send the character CH to the other Kermit.
  395.      */
  396.  
  397.     declare
  398.         ch      byte;
  399.  
  400.     call xmit$remote$char( ch ); /* send it on the remote line */
  401.  
  402. end send$char;
  403.  
  404.  
  405. send$packet: procedure( type, num, info$ptr ) public;
  406.  
  407.     /*
  408.      *  Send a packet to the remote Kermit.  TYPE is the character
  409.      *  for the packet type, NUM is the packet number to be used,
  410.      *  and INFO$PTR points to a string (length byte followed by
  411.      *  data bytes) containing the contents of the packet to be sent,
  412.      *  with all control-quoting or other processing already done.
  413.      *  INFO$PTR may be zero in which case an "emtpy" packet is sent.
  414.      *  The length field is assumed to be at least five less than
  415.      *  PACKET$LEN (the maximum length packet to send, i.e. the other
  416.      *  Kermit's buffer size)--this is not checked here.
  417.      */
  418.  
  419.     declare
  420.         ( type, num, i, checksum )  byte,
  421.         info$ptr                    pointer,
  422.         info based info$ptr         structure(
  423.                                         len     byte,
  424.                                         ch(1)   byte);
  425.  
  426.     send$packet$char: procedure( ch );
  427.  
  428.         /*
  429.          *  Send one character of a packet (other than the SOH or
  430.          *  checksum) by adding it to the checksum and then actually
  431.          *  sending it.
  432.          */
  433.  
  434.         declare
  435.             ch      byte;
  436.  
  437.         checksum = ( checksum + ch );   /* Accumulate checksum */
  438.         call send$char( ch );           /* send the char */
  439.  
  440.     end send$packet$char;
  441.  
  442.  
  443.     /* begin SEND$PACKET */
  444.     if ( debug ) then
  445.       do;
  446.         call print( @( 20,'Send-packet:  num = ' ) );
  447.         call show$dec$num( num );
  448.         call print( @( 9,'; type = ' ) );
  449.         call show$char( type );
  450.         call print( @( 10,'; data = "' ) );
  451.         if ( info$ptr <> 0 ) then
  452.             call print( info$ptr );
  453.         call print$char( '"' );
  454.         call new$line;
  455.       end;
  456.     do i = 1 to num$pad;    /* Send any padding requested */
  457.         call send$char( pad$char );
  458.     end;    /* do i = 1 to num$pad */
  459.     call send$char( SOH );  /* Send the synchronization character */
  460.     checksum = 0;   /* Initialize the checksum */
  461.     if ( info$ptr = 0 ) then    /* no info to be sent */
  462.         call send$packet$char( char( 3 ) );     /* so length is three */
  463.     else    /* send packet length */
  464.         call send$packet$char( char( info.len + 3 ) );
  465.     call send$packet$char( char( num ) );   /* send packet number */
  466.     call send$packet$char( type );  /* send packet type */
  467.     if ( info$ptr <> 0 ) then   /* they gave us an info string */
  468.       if ( info.len > 0 ) then    /* there is some data to be sent */
  469.         do i = 0 to ( info.len - 1 );   /* for each character of data */
  470.             call send$packet$char( info.ch( i ) );  /* send it */
  471.         end;    /* do i = 0 to ( info.len - 1 ) */
  472.     /* Now compute the final checksum by folding the high bits in */
  473.     checksum = ( ( checksum + shr( checksum, 6 ) ) AND 03Fh );
  474.     call send$char( char( checksum ) );    /* and send the checksum */
  475.     /* The packet itself has now been sent */
  476.     call send$char( eol );   /* now send the EOL character */
  477.  
  478. end send$packet;
  479.  
  480.  
  481. receive$char: procedure( time$limit ) word;
  482.  
  483.     /*
  484.      *  Receive a character from the other Kermit, timing out
  485.      *  after TIME$LIMIT seconds.  Returns the same special
  486.      *  codes as GET$REMOTE$CHAR.
  487.      */
  488.  
  489.     declare
  490.         ( time$limit, ch )  word;
  491.  
  492.     ch = get$remote$char( time$limit );     /* receive from remote port */
  493.     if ( ch < 0100h ) then  /* we got a real character, not a special code */
  494.         ch = low7( ch );    /* so strip the 8th bit in case it's parity */
  495.     return( ch );   /* and return what we received */
  496.  
  497. end receive$char;
  498.  
  499.  
  500. receive$packet: procedure( num$ptr, info$ptr ) byte public;
  501.  
  502.     /*
  503.      *  Receive a packet from the remote Kermit.  NUM$PTR points
  504.      *  to a byte which receives the sequence number of the incoming
  505.      *  packet, INFO$PTR points to a string which receives the
  506.      *  data field of the incoming packet, and the function returns
  507.      *  the type character of the incoming packet.  If no character
  508.      *  is received for TIME$LIMIT seconds at any point in the process,
  509.      *  the receive operation will be abandoned and zero will be returned.
  510.      *  (TIME$LIMIT is a global used here.)
  511.      *  Zero will also be returned if a packet with a bad checksum is
  512.      *  received.  If CTRL/C is pressed on the console the receive
  513.      *  will be aborted and 0FFh will be returned.  (Note that if a
  514.      *  character with ASCII value 0 or 0FFh is received during a packet,
  515.      *  that code will be returned; however this does not apply outside
  516.      *  the packet, and if a NUL or character 0FFh is received during a
  517.      *  packet that indicates an error anyway.)
  518.      */
  519.  
  520.     declare
  521.         ( num$ptr, info$ptr )   pointer,
  522.         num based num$ptr       byte,
  523.         ( checksum, type, i )   byte,
  524.         ch                      word,
  525.         info based info$ptr     structure(
  526.                                     len     byte,
  527.                                     ch(1)   byte);
  528.  
  529.     get$packet$char: procedure byte;
  530.  
  531.         /*
  532.          *  Return the next character of a packet and add it to the
  533.          *  checksum.  Returns zero or 0FFh as described above for
  534.          *  RECEVIE$PACKET.
  535.          */
  536.  
  537.         declare
  538.             ch      word;
  539.  
  540.         ch = receive$char( time$limit );    /* Get a char */
  541.         if ( ch = TIMEOUT ) then    /* nothing received in time */
  542.             return( 0 );
  543.         else if ( ch = CTRL$C$CODE ) then   /* CTRL/C abort */
  544.             return( 0FFh );
  545.         else    /* got a character */
  546.           do;
  547.             checksum = ( checksum + ch );   /* accumulate checksum */
  548.             return( ch );       /* and return the character */
  549.           end;
  550.  
  551.     end get$packet$char;
  552.  
  553.  
  554.     /* begin RECEIVE$PACKET */
  555.     ch = receive$char( time$limit );    /* Get first character */
  556.     /* As long as we got characters, but not the synchronization mark */
  557.     do while ( ( ch <> TIMEOUT ) and ( ch <> CTRL$C$CODE ) and ( ch <> SOH ) );
  558.         ch = receive$char( time$limit );    /* keep getting them */
  559.     end;    /* do while ... */
  560.     /* convert error conditions to our return codes */
  561.     if ( ch = TIMEOUT ) then
  562.         ch = 0;
  563.     else if ( ch = CTRL$C$CODE ) then
  564.         ch = 0FFh;
  565.     do while ( ch = SOH );  /* if we got SOH, get the packet which follows */
  566.         checksum = 0;   /* initialize the checksum */
  567.         ch = get$packet$char;   /* get what should be the count */
  568.         /* If we got a character, not SOH */
  569.         if ( ( ch <> 0 ) and ( ch <> 0FFh ) and ( ch <> SOH ) ) then
  570.           do;
  571.             info.len = ( unchar( ch ) - 3 );    /* store data length */
  572.             ch = get$packet$char;   /* now try for the sequence number */
  573.             if ( ( ch <> 0 ) and ( ch <> 0FFh ) and ( ch <> SOH ) ) then
  574.               do;
  575.                 num = unchar( ch );     /* store packet number */
  576.                 ch = get$packet$char;   /* now the type */
  577.                 if ( ( ch <> 0 ) and ( ch <> 0FFh ) and ( ch <> SOH ) ) then
  578.                   do;
  579.                     type = ch;  /* store packet type for later */
  580.                     i = 0;  /* init data index */
  581.                     /* while we're still getting the data field */
  582.                     do while ( ( ch <> 0 ) and ( ch <> 0FFh ) and
  583.                                 ( ch <> SOH ) and ( i < info.len ) );
  584.                         ch = get$packet$char;   /* get next data char */
  585.                         info.ch( i ) = ch;  /* store data character */
  586.                         i = ( i + 1 );  /* and bump data index */
  587.                     end;    /* do while ... */
  588.                     if ( ( ch <> 0 ) and ( ch <> 0FFh ) and
  589.                             ( ch <> SOH ) ) then    /* got data O.K. */
  590.                       do;
  591.                         /* Get the incoming checksum */
  592.                         ch = receive$char( time$limit );
  593.                         if ( ch = TIMEOUT ) then
  594.                             ch = 0;     /* signal no packet received */
  595.                         else if ( ch = CTRL$C$CODE ) then
  596.                             ch = 0FFh;  /* signal CTRL/C abort */
  597.                         else if ( ch <> SOH ) then  /* got checksum */
  598.                           do;
  599.                             /* finish computing our checksum */
  600.                             checksum = ( ( checksum + shr( checksum, 6 ) )
  601.                                                 AND 03Fh );
  602.                             /* if incoming checksum and ours disagree */
  603.                             if ( checksum <> unchar( ch ) ) then
  604.                                 ch = 0; /* signal bad packet received */
  605.                             else    /* finally got good, complete, packet */
  606.                                 ch = type;  /* so return its type */
  607.                           end;  /* else if ( ch <> SOH ) */
  608.                       end;  /* if ... */
  609.                   end;  /* if ... */
  610.               end;  /* if ... */
  611.           end;  /* if ... */
  612.     end;    /* do while ( ch = SOH ) */
  613.     /* Finished with that packet */
  614.     /* We would now flush the input buffer if we were using one */
  615.     if ( debug ) then
  616.       do;
  617.         call print( @( 17,'Receive-packet:  ' ) );
  618.         if ( ch = 0 ) then
  619.             call print( @( 19,'<bad/absent packet>' ) );
  620.         else if ( ch = 0FFh ) then
  621.             call print( @( 14,'<CTRL/C abort>' ) );
  622.         else
  623.           do;
  624.             call print( @( 6,'num = ' ) );
  625.             call show$dec$num( num );
  626.             call print( @( 9,'; type = ' ) );
  627.             call show$char( ch );
  628.             call print( @( 10,'; data = "' ) );
  629.             call print( info$ptr );
  630.             call print$char( '"' );
  631.           end;
  632.         call new$line;
  633.       end;
  634.     return( ch );   /* return packet type or error code (0 or 0FFh) */
  635.  
  636. end receive$packet;
  637.  
  638.  
  639. send$kermit$params: procedure( info$ptr ) public;
  640.  
  641.     /*
  642.      *  This procedure places our current parameters into the
  643.      *  buffer pointed to by INFO$PTR in the format required for
  644.      *  a Send-init packet or the acknowledgement to one.
  645.      */
  646.  
  647.     declare
  648.         info$ptr            pointer,
  649.         info based info$ptr structure(
  650.                                 len     byte,
  651.                                 ch(1)   byte);
  652.  
  653.     info.len = 6;
  654.     info.ch( 0 ) = char( packet$len ); /* longest packet to send */
  655.     info.ch( 1 ) = char( time$limit ); /* number of seconds to time-out */
  656.     info.ch( 2 ) = char( num$pad );    /* number of padding chars */
  657.     info.ch( 3 ) = ctl( pad$char );    /* padding character */
  658.     info.ch( 4 ) = char( eol );        /* end-of-line character */
  659.     info.ch( 5 ) = quote;              /* control-quote character */
  660.  
  661. end send$kermit$params;
  662.  
  663.  
  664. get$kermit$params: procedure( info$ptr ) public;
  665.  
  666.     /*
  667.      *  This procedure sets our parameters based on the contents of
  668.      *  the buffer pointed to by INFO$PTR which should contain the
  669.      *  data field from a Send-init packet or the acknowledgement to one.
  670.      */
  671.  
  672.     declare
  673.         i                   byte,
  674.         info$ptr            pointer,
  675.         info based info$ptr structure(
  676.                                 len     byte,
  677.                                 ch(1)   byte);
  678.  
  679.     do i = info.len to 5;   /* for each field they omitted which we use */
  680.         info.ch( i ) = ' ';     /* make it a space, i.e. default it */
  681.     end;    /* do i = info.len to 5 */
  682.     /* Set buffer size. */
  683.     if ( info.ch( 0 ) = ' ' ) then
  684.         packet$len = def$packet$len;    /* use default */
  685.     else
  686.         packet$len = unchar( info.ch( 0 ) );    /* use what they sent */
  687.     /* Set time-out limit. */
  688.     if ( info.ch( 1 ) = ' ' ) then
  689.         time$limit = def$time$limit;    /* use default */
  690.     else
  691.         time$limit = unchar( info.ch( 1 ) );    /* use theirs */
  692.     /* Set number of padding chars. */
  693.     if ( info.ch( 2 ) = ' ' ) then
  694.         num$pad = def$num$pad;      /* use default */
  695.     else
  696.         num$pad = unchar( info.ch( 2 ) );   /* use theirs */
  697.     /* Set the padding character. */
  698.     if ( info.ch( 3 ) = ' ' ) then
  699.         pad$char = def$pad$char;    /* use default */
  700.     else
  701.         pad$char = ctl( info.ch( 3 ) );     /* use theirs */
  702.     /* Set the end-of-line character. */
  703.     if ( info.ch( 4 ) = ' ' ) then
  704.         eol = def$eol;      /* use default */
  705.     else
  706.         eol = unchar( info.ch( 4 ) );   /* use theirs */
  707.     /* Set the control-quote character. */
  708.     if ( info.ch( 5 ) = ' ' ) then
  709.         quote = def$quote;      /* use default */
  710.     else
  711.         quote = info.ch( 5 );   /* use theirs */
  712.  
  713. end get$kermit$params;
  714.  
  715.  
  716. read$packet$from$file: procedure( info$ptr ) public;
  717.  
  718.     /*
  719.      *  Fill the buffer pointed to by INFO$PTR with the next packet
  720.      *  of the current file.  This routine does the quoting/prefixing.
  721.      *  If zero bytes are loaded into the buffer, then we ran into
  722.      *  end-of-file.
  723.      */
  724.  
  725.     declare
  726.         info$ptr            pointer,
  727.         i                   byte,
  728.         ch                  word,
  729.         info based info$ptr structure(
  730.                                 len     byte,
  731.                                 ch(1)   byte);
  732.  
  733.     i, ch = 0;
  734.     /* While we have more characters from the file and the packet */
  735.     /* has room for another char (possibly with control quote) */
  736.     do while ( ( ch <> EOF$CODE ) and ( i < ( packet$len - 6 ) ) );
  737.         ch = read$char( cur$file );     /* get a char from the file */
  738.         if ( ch <> EOF$CODE ) then  /* we got one */
  739.           do;
  740.             ch = low7( ch );    /* strip the 8th bit, just in case... */
  741.             /* If this character needs to be quoted */
  742.             if ( not$printable( ch ) or special$char( ch ) ) then
  743.               do;
  744.                 info.ch( i ) = quote;   /* Put control-quote in buffer */
  745.                 i = ( i + 1 );  /* and update index */
  746.                 if ( not$printable( ch ) ) then
  747.                     ch = ctl( ch );     /* make control characters printable */
  748.               end;  /* if ... -- needs to be quoted */
  749.             info.ch( i ) = ch;      /* put character in buffer */
  750.             i = ( i + 1 );      /* and update index */
  751.           end;  /* if ( ch <> EOF$CODE ) */
  752.     end;    /* do while ... */
  753.     info.len = i;   /* store length of what we put in buffer */
  754.  
  755. end read$packet$from$file;
  756.  
  757.  
  758. write$packet$to$file: procedure( info$ptr ) public;
  759.  
  760.     /*
  761.      *  Write the contents of a received packet (in the buffer pointed
  762.      *  to by INFO$PTR) out to the current file.  This routine deals
  763.      *  with quoting characters in the incoming data.
  764.      */
  765.  
  766.     declare
  767.         info$ptr            pointer,
  768.         ( x, i )            byte,
  769.         info based info$ptr structure(
  770.                                 len     byte,
  771.                                 ch(1)   byte);
  772.  
  773.     i = 0;      /* start at the beginning */
  774.     do while ( i < info.len );  /* while we have any more data */
  775.         x = info.ch( i );   /* get the current character */
  776.         if ( x = quote ) then   /* it's the control-quote character */
  777.           do;
  778.             i = ( i + 1 );  /* go to the next (quoted) character */
  779.             x = info.ch( i );   /* and get it */
  780.             /* If it's not a quoting or prefix character */
  781.             if ( not special$char( x ) ) then   /* it's a control char */
  782.                 x = ctl( x );       /* so restore the actual character */
  783.           end;  /* if ( x = quote ) */
  784.         call write$char( cur$file, x ); /* write char to file */
  785.         i = ( i + 1 );      /* now go to next char */
  786.     end;    /* do while ( i < info.len ) */
  787.  
  788. end write$packet$to$file;
  789.  
  790.  
  791. /*
  792.  *
  793.  *      Error handling routines
  794.  *
  795.  */
  796.  
  797.  
  798. error$msg: procedure( msg$ptr ) public;
  799.  
  800.     /*
  801.      *  Send an error packet to the remote Kermit
  802.      *  and display the error message on the console too.
  803.      */
  804.  
  805.     declare
  806.         msg$ptr     pointer;
  807.  
  808.     /* Send Error packet to the other Kermit */
  809.     call send$packet( 'E', seq, msg$ptr );  /* send Error packet */
  810.     seq = next$seq( seq );  /* and bump sequence number */
  811.     call print( msg$ptr );  /* print it on the console too */
  812.  
  813. end error$msg;
  814.  
  815.  
  816. unknown$packet$type: procedure( type, packet$ptr ) public;
  817.  
  818.     /*
  819.      *  Deal with a received packet of an unexpected type.
  820.      */
  821.  
  822.     declare
  823.         type        byte,       /* type of the packet received */
  824.         packet$ptr  pointer;    /* points to contents of the packet */
  825.  
  826.     if ( type = 'E' ) then  /* it is an error packet */
  827.       do;
  828.         /* Display the error message we received from the remote Kermit */
  829.         call print( @( 20,'Remote Kermit error:' ) );
  830.         call new$line;
  831.         call print( packet$ptr );
  832.         call new$line;
  833.       end;
  834.     else    /* an unknown packet type */
  835.       do;
  836.         /* Display an appropriate error message */
  837.         call print( @( 24,'Unexpected packet type (' ) );
  838.         call show$char( type );
  839.         call print( @( 11,') received.' ) );
  840.       end;
  841.     state = 'A';    /* In any case, abort the current operation */
  842.  
  843. end unknown$packet$type;
  844.  
  845.  
  846. too$many$retries: procedure public;
  847.  
  848.     /*
  849.      *  Deal with the retry count reaching its limit.
  850.      */
  851.  
  852.     /* Display an error message */
  853.     call print( @( 17,'Too many retries.' ) );
  854.     state = 'A';    /* and abort the operation */
  855.  
  856. end too$many$retries;
  857.  
  858.  
  859. wrong$number: procedure public;
  860.  
  861.     /*
  862.      *  Deal with a received packet with wrong sequence number.
  863.      */
  864.  
  865.     /* Display an error message */
  866.     call print( @( 27,'Unexpected packet sequence.' ) );
  867.     state = 'A';    /* and abort the operation */
  868.  
  869. end wrong$number;
  870.  
  871.  
  872. /*
  873.  *
  874.  *      Command parsing and display procedures
  875.  *
  876.  */
  877.  
  878.  
  879. parse$command: procedure public;
  880.  
  881.     /*
  882.      *  Parse the command line in the global buffer COM$LINE into
  883.      *  keywords, separated by spaces.  The keywords are stored
  884.      *  in the global KEYWORD array, the count in NUM$KEYWORDS.
  885.      */
  886.  
  887.     declare
  888.         ( i, j )    word;
  889.  
  890.     num$keywords = 0;   /* Initially we don't have any keywords yet */
  891.     i = 0;              /* Start at the beginning of the command line */
  892.     /* Go until we get to the end or have the maximum number of keywords */
  893.     do while ( ( i < com$line.len ) and ( num$keywords < MAX$KEYWORDS ) );
  894.         keyword( num$keywords ).index = i;  /* store start of this keyword */
  895.         /* Find the next space (end of this keyword) */
  896.         j = findb( @com$line.ch( i ), ' ', ( com$line.len - i ) );
  897.         if ( j = 0FFFFh ) then  /* there isn't another space */
  898.             j = ( com$line.len - i );   /* this keyword is rest of the line */
  899.         keyword( num$keywords ).len = j;    /* store its length */
  900.         num$keywords = ( num$keywords + 1 );    /* bump the keyword count */
  901.         i = ( i + j + 1 );  /* next keyword starts after the space */
  902.     end;    /* do while ( i < com$line.len ) */
  903.  
  904. end parse$command;
  905.  
  906.  
  907. parse$dec$num: procedure( keyword$num, num$ptr ) boolean public;
  908.  
  909.     /*
  910.      *  Parse a decimal number out of keyword number KEYWORD$NUM;
  911.      *  i.e. interpret the string of characters that make up that
  912.      *  keyword as a decimal number, and place its value into
  913.      *  the word pointed to by NUM$PTR.  It returns a value of
  914.      *  TRUE if this was successful, FALSE if the keyword does not
  915.      *  represent a number (e.g. contains letters).
  916.      */
  917.  
  918.     declare
  919.         ( keyword$num, i )  byte,
  920.         num$ptr             pointer,
  921.         num based num$ptr   word,
  922.         ( first, last, ch ) byte,
  923.         valid               boolean;
  924.  
  925.     num = 0;    /* Init the number to zero */
  926.     valid = TRUE;   /* Assume it's valid until proven otherwise */
  927.     first = keyword( keyword$num ).index;   /* Get starting position */
  928.     last = first + keyword( keyword$num ).len - 1;  /* and ending one */
  929.     do i = first to last;   /* Step through each character in turn */
  930.         ch = com$line.ch( i );  /* Get current character */
  931.         if ( ( ch >= '0' ) and ( ch <= '9' ) ) then /* valid digit */
  932.             num = ( num * 10 ) + ( ch - '0' );  /* Accumulate value */
  933.         else    /* not a decimal digit */
  934.             valid = FALSE;  /* Flag that it's invalid--NUM is meaningless */
  935.     end;    /* do i = first to last */
  936.     return( valid );
  937.  
  938. end parse$dec$num;
  939.  
  940.  
  941. show$keyword: procedure( keyword$num );
  942.  
  943.     /*
  944.      *  Display keyword number KEYWORD$NUM (as parsed into the
  945.      *  global array KEYWORD) on the console.
  946.      */
  947.  
  948.     declare
  949.         ( keyword$num, first, last, i ) byte;
  950.  
  951.     /* Get the location of the first character of the keyword */
  952.     first = keyword( keyword$num ).index;
  953.     /* and the location of the last character of the keyword */
  954.     last = first + keyword( keyword$num ).len - 1;
  955.     /* Display each character in turn */
  956.     do i = first to last;
  957.         call print$char( com$line.ch( i ) );
  958.     end;    /* do i = first to last */
  959.  
  960. end show$keyword;
  961.  
  962.  
  963. show$command: procedure( kp1, kp2, kp3 ) public;
  964.  
  965.     /*
  966.      *  Display a command (one to three keywords) on the console.
  967.      *  Used for error messages.
  968.      */
  969.  
  970.     declare
  971.         ( kp1, kp2, kp3 )   pointer;
  972.  
  973.     call print( kp1 );
  974.     if ( kp2 <> 0 ) then
  975.       do;
  976.         call print$char( ' ' );
  977.         call print( kp2 );
  978.         if ( kp3 <> 0 ) then
  979.           do;
  980.             call print$char( ' ' );
  981.             call print( kp3 );
  982.           end;  /* if ( kp3 <> 0 ) */
  983.       end;  /* if ( kp2 <> 0 ) */
  984.  
  985. end show$command;
  986.  
  987.  
  988. hint$command: procedure( kp1, kp2, kp3 );
  989.  
  990.     /*
  991.      *  Give a hint on using the command (called if too few
  992.      *  parameters or invalid parameter).
  993.      */
  994.  
  995.     declare
  996.         ( kp1, kp2, kp3 )   pointer;
  997.  
  998.     call print( @( 7,'  (Type' ) );
  999.     if ( kp1 <> 0 ) then    /* it's a subcommand */
  1000.       do;
  1001.         call print$char( ' ' );
  1002.         call show$command( kp1, kp2, kp3 );
  1003.       end;  /* if ( kp1 <> 0 ) */
  1004.     call print( @( 23,' ? to see the choices.)' ) );
  1005.  
  1006. end hint$command;
  1007.  
  1008.  
  1009. too$few$params: procedure( kp1, kp2, kp3 ) public;
  1010.  
  1011.     /*
  1012.      *  Issue the error messages for commands which require
  1013.      *  parameters when they were not followed by any keywords.
  1014.      */
  1015.  
  1016.     declare
  1017.         ( kp1, kp2, kp3 )   pointer;
  1018.  
  1019.     call show$command( kp1, kp2, kp3 );
  1020.     call print( @( 22,' requires a parameter.' ) );
  1021.     call hint$command( kp1, kp2, kp3 );
  1022.  
  1023. end too$few$params;
  1024.  
  1025.  
  1026. too$many$params: procedure( kp1, kp2, kp3 ) public;
  1027.  
  1028.     /*
  1029.      *  Issue the error messages for commands which don't take
  1030.      *  parameters when they are followed by extra keyword(s).
  1031.      */
  1032.  
  1033.     declare
  1034.         ( kp1, kp2, kp3 )   pointer;
  1035.  
  1036.     call show$command( kp1, kp2, kp3 );
  1037.     call print( @( 26,' does not take parameters.' ) );
  1038.  
  1039. end too$many$params;
  1040.  
  1041.  
  1042. extra$params: procedure( kp1, kp2, kp3 ) public;
  1043.  
  1044.     /*
  1045.      *  Issue the error messages for commands which take only
  1046.      *  one parameter when they are followed by more than one
  1047.      *  keyword.
  1048.      */
  1049.  
  1050.     declare
  1051.         ( kp1, kp2, kp3 )   pointer;
  1052.  
  1053.     call show$command( kp1, kp2, kp3 );
  1054.     call print( @( 26,' takes only one parameter.' ) );
  1055.  
  1056. end extra$params;
  1057.  
  1058.  
  1059. invalid$param: procedure( k$num, kp1, kp2, kp3 ) public;
  1060.  
  1061.     /*
  1062.      *  Issue the error messages for invalid parameters.
  1063.      */
  1064.  
  1065.     declare
  1066.         k$num               byte,
  1067.         ( kp1, kp2, kp3 )   pointer;
  1068.  
  1069.     call show$keyword( k$num );
  1070.     call print( @( 16,' is not a valid ' ) );
  1071.     if ( kp1 = 0 ) then
  1072.         call print( @( 8,'command.' ) );
  1073.     else
  1074.       do;
  1075.         call print( @( 13,'parameter to ' ) );
  1076.         call show$command( kp1, kp2, kp3 );
  1077.         call print$char( '.' );
  1078.       end;  /* else */
  1079.     call hint$command( kp1, kp2, kp3 );
  1080.  
  1081. end invalid$param;
  1082.  
  1083.  
  1084. keyword$match: procedure( keyword$num, keyword$ptr, min$len ) boolean public;
  1085.  
  1086.     /*
  1087.      *  Compare keyword number KEYWORD$NUM (as parsed into the KEYWORD
  1088.      *  array) with the keyword (string) pointed to by KEYWORD$PTR,
  1089.      *  and return TRUE if the keyword is an abbreviation of the string
  1090.      *  containing at least MIN$LEN characters, otherwise return FALSE.
  1091.      */
  1092.  
  1093.     declare
  1094.         ( keyword$num, min$len )    byte,
  1095.         keyword$ptr                 pointer,
  1096.         string based keyword$ptr    structure(
  1097.                                         len     byte,
  1098.                                         ch(1)   byte);
  1099.  
  1100.     if ( keyword( keyword$num ).len < min$len ) then
  1101.         return( FALSE );    /* the keyword is too short */
  1102.     else if ( keyword( keyword$num ).len > string.len ) then
  1103.         return( FALSE );    /* the keyword is too long */
  1104.     else if ( cmpb( @com$line.ch( keyword( keyword$num ).index ),
  1105.                     @string.ch,
  1106.                     keyword( keyword$num ).len ) = 0FFFFh ) then
  1107.         return( TRUE );     /* the keyword matches */
  1108.     else
  1109.         return( FALSE );    /* the keyword doesn't match */
  1110.  
  1111. end keyword$match;
  1112.  
  1113.  
  1114. list$choices: procedure( kp1, kp2, kp3, list$ptr, list$last ) public;
  1115.  
  1116.     /*
  1117.      *  List the choices for commands or parameters to commands,
  1118.      *  in response to the ? "parameter."
  1119.      */
  1120.  
  1121.     declare
  1122.         ( kp1, kp2, kp3, list$ptr )         pointer,
  1123.         (list$element based list$ptr)(1)    pointer,
  1124.         element$ptr                         pointer,
  1125.         element$len based element$ptr       byte,
  1126.         ( list$last, i, j, k )              byte;
  1127.  
  1128.     call print$spaces( 2 );
  1129.     call print( @( 10,'Available ' ) );
  1130.     if ( kp1 = 0 ) then
  1131.         call print( @( 8,'commands' ) );
  1132.     else
  1133.       do;
  1134.         call print( @( 14,'parameters to ' ) );
  1135.         call show$command( kp1, kp2, kp3 );
  1136.       end;  /* else */
  1137.     call print( @( 5,' are:' ) );
  1138.     k = 5;  /* Set to start a new line immediately */
  1139.     do i = 0 to list$last;  /* for each entry in the list */
  1140.         if ( k > 4 ) then   /* start a new line every 5 columns */
  1141.           do;
  1142.             call new$line;
  1143.             call print$spaces( 4 );    /* indent */
  1144.             k = 0;  /* reset column counter */
  1145.           end;  /* if ( k > 4 ) */
  1146.         element$ptr = list$element( i );
  1147.         /* Compute number of spaces to next column */
  1148.         j = ( 15 - ( element$len MOD 15 ) );
  1149.         /* And update columns on this line so far */
  1150.         k = ( k + ( element$len / 15 ) + 1 );
  1151.         call print( element$ptr );
  1152.         call print$spaces( j );
  1153.     end;    /* do i = 0 to list$last */
  1154.  
  1155. end list$choices;
  1156.  
  1157. /*
  1158.  *
  1159.  *      Other utility procedures
  1160.  *
  1161.  */
  1162.  
  1163.  
  1164. get$filespec: procedure( keyword$num, info$ptr ) public;
  1165.  
  1166.     /*
  1167.      *  Get the filespec in keyword number KEYWORD$NUM into
  1168.      *  the buffer pointed to by INFO$PTR.
  1169.      */
  1170.  
  1171.     declare
  1172.         keyword$num         byte,
  1173.         info$ptr            pointer,
  1174.         info based info$ptr structure(
  1175.                                 len     byte,
  1176.                                 ch(1)   byte);
  1177.  
  1178.     /* Copy the keyword into the INFO buffer */
  1179.     info.len = keyword( keyword$num ).len;
  1180.     call movb( @com$line.ch( keyword( keyword$num ).index ),
  1181.                     @info.ch, info.len );
  1182.  
  1183. end get$filespec;
  1184.  
  1185.  
  1186. send$generic$command: procedure( info$ptr, info2$ptr ) boolean public;
  1187.  
  1188.     /*
  1189.      *  Send a Generic Kermit Command (the data field of which
  1190.      *  INFO$PTR must point to) to the other Kermit.  This only
  1191.      *  deals with commands to which no reply other than ACK or NAK
  1192.      *  or possibly an Error message is expected.  If an Error packet
  1193.      *  is received the error message is displayed and FALSE is returned;
  1194.      *  if a NAK is received the packet is retransmitted up to the
  1195.      *  global MAX$RETRY count, at which point an error message is
  1196.      *  displayed and FALSE is returned; if an ACK is received TRUE
  1197.      *  is returned.  INFO2$PTR points to the buffer which receives
  1198.      *  the contents of the response packet.
  1199.      */
  1200.  
  1201.     declare
  1202.         ( info$ptr, info2$ptr ) pointer,
  1203.         ( type, num )           byte;   /* Incoming packet type, number */
  1204.  
  1205.     seq = 0;    /* Set packet sequence number */
  1206.     tries = 0;  /* Init try count */
  1207.     do while ( tries < max$retry );
  1208.         tries = ( tries + 1 );  /* count a try */
  1209.         call send$packet( 'G', seq, info$ptr ); /* send generic command */
  1210.         type = receive$packet( @num, info2$ptr );   /* get response */
  1211.         if ( ( type = 'Y' ) and ( num = seq ) ) then    /* got good ACK */
  1212.             return( TRUE );
  1213.         else if ( type = 0FFh ) then    /* CTRL/C abort */
  1214.           do;
  1215.             call print( @( 26,'Command aborted by CTRL/C.' ) );
  1216.             return( FALSE );
  1217.           end;
  1218.         else if ( ( type <> 'N' ) and ( type <> 'Y' ) and ( type <> 0 ) ) then
  1219.           do;
  1220.             call unknown$packet$type( type, info2$ptr );
  1221.             return( FALSE );
  1222.           end;
  1223.     end;    /* do while ( tries < max$retry ) */
  1224.     call too$many$retries;
  1225.     return( FALSE );
  1226.  
  1227. end send$generic$command;
  1228.  
  1229.  
  1230. end kermit$util;
  1231.