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