home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / intel86b / kersys.p86 < prev    next >
Text File  |  2020-01-01  |  36KB  |  1,000 lines
  1. $large  ram  optimize(3)
  2.  
  3. Kermit$sys: 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.  *      System-dependent interface and utility procedures module.
  12.  *      Edit date:  22-August-1985
  13.  */
  14.  
  15.         /* Define the iRMX-86 operating system interface */
  16. /* Define the exception codes we use */
  17. declare
  18.     E$OK                literally   '0000h',
  19.     E$FNEXIST           literally   '0021h',    /* non-existent file */
  20.     E$FACCESS           literally   '0026h',    /* file access not granted */
  21.     E$FTYPE             literally   '0027h',    /* bad file type */
  22.     E$LOG$NAME$NEXIST   literally   '0045h',    /* non-existent logical name */
  23.     E$CONTINUED         literally   '0083h';    /* continued command line */
  24. /* Define the system type TOKEN */
  25. $include(:I:LTKSEL.LIT)
  26. /* Include external definitions for the iRMX-86 system calls we use */
  27. $include(:I:HSNCOR.EXT)
  28. $include(:I:HFMTEX.EXT)
  29. $include(:I:HGTICN.EXT)
  30. $include(:I:HCRCCN.EXT)
  31. $include(:I:HSNCMD.EXT)
  32. $include(:I:HGTCMD.EXT)
  33. $include(:I:IEXIOJ.EXT)
  34. $include(:I:ISATFL.EXT)
  35. $include(:I:ISCRFL.EXT)
  36. $include(:I:ISOPEN.EXT)
  37. $include(:I:ISSPEC.EXT)
  38. $include(:I:ISRDMV.EXT)
  39. $include(:I:ISWRMV.EXT)
  40. $include(:I:ISCLOS.EXT)
  41. $include(:I:ISDLCN.EXT)
  42. $include(:I:ISDLFL.EXT)
  43. $include(:I:IGTTIM.EXT)
  44. $include(:I:NSTEXH.EXT)
  45. $include(:I:NRCUNI.EXT)
  46. $include(:I:NCRSEM.EXT)
  47.  
  48.  
  49. declare
  50.                 /* CONSTANTS */
  51.  
  52.             /* Useful text substitutions */
  53.     boolean                 literally   'byte',     /* define a new type */
  54.     TRUE                    literally   '0FFh',     /* and constants */
  55.     FALSE                   literally   '000h',     /*  of that type */
  56.  
  57.             /* ASCII control character constants */
  58.     CTRL$C                  literally   '03h',  /* CTRL/C */
  59.     HT                      literally   '09h',  /* horizontal tab */
  60.     LF                      literally   '0Ah',  /* line-feed */
  61.     CR                      literally   '0Dh',  /* carriage-return */
  62.  
  63.             /* String constants */
  64.     remote$name(*)          byte data( 12, ':KERMITPORT:' ),
  65.     console$name(*)         byte data( 4, ':CO:' ),
  66.     file$list$name(*)       byte data( 20, ':WORK:KERMITFLST.TMP' ),
  67.  
  68.             /* GET$CONSOLE$CHAR and GET$REMOTE$CHAR return codes */
  69.     TIMEOUT                 literally   '0FFFFh',   /* Time limit expired */
  70.     CTRL$C$CODE             literally   '08003h',   /* CTRL/C abort */
  71.             /* READ$CHAR return code */
  72.     EOF$CODE                literally   '0FF00h',   /* end-of-file */
  73.  
  74.  
  75.                 /* GLOBAL VARIABLES */
  76.  
  77.             /* Tokens (what the system uses to identify objects) */
  78.     cur$file    token public,   /* Connection to the current file */
  79.     comm$conn   token,  /* token for our command connection */
  80.     file$list   token,  /* Connection to the file containg a filename list */
  81.     console$tok token,  /* Connection to the console */
  82.     remote$tok  token,  /* Connection to the remote port */
  83.     cc$sema4    token,  /* Semaphore to signal when CTRL/C pressed */
  84.  
  85.             /* Buffers */
  86.     in$buff     structure(      /* Buffer for input from remote */
  87.                     next    byte,   /* next char to be read from buffer */
  88.                     len     byte,   /* number of chars in the buffer */
  89.                     ch(256) byte) initial( 0, 0 ),
  90.     com$line    structure(      /* The buffer for the command line */
  91.                     len     byte,
  92.                     ch(80)  byte) public;
  93.  
  94.  
  95. /*      External procedures defined in KERMIT$UTIL      */
  96.  
  97. get$filespec: procedure( keyword$num, info$ptr ) external;
  98.     declare
  99.         keyword$num     byte,
  100.         info$ptr        pointer;
  101. end get$filespec;
  102.  
  103. upcase: procedure( x ) byte external;
  104.     declare
  105.         x   byte;
  106. end upcase;
  107.  
  108.  
  109. /*
  110.  *
  111.  *      System-dependent utility procedures used by Kermit.
  112.  *
  113.  */
  114.  
  115.  
  116. print: procedure( string$ptr ) public;
  117.  
  118.     /*
  119.      *  Print the string pointed to by STRING$PTR on the console.
  120.      *  A string consists of a length byte followed by the specified
  121.      *  number of characters (bytes).
  122.      */
  123.  
  124.     declare
  125.         string$ptr              pointer,
  126.         status                  word;
  127.  
  128.     call rq$c$send$co$response( 0, 0, string$ptr, @status );
  129.  
  130. end print;
  131.  
  132.  
  133. new$line: procedure public;
  134.  
  135.     /*
  136.      *  Get the cursor to a new line on the console (i.e. print CR/LF).
  137.      */
  138.  
  139.     call print( @( 2,CR,LF ) );
  140.  
  141. end new$line;
  142.  
  143.  
  144. print$char: procedure( char ) public;
  145.  
  146.     /*
  147.      *  Print the character CHAR on the console.
  148.      */
  149.  
  150.     declare
  151.         char    byte,
  152.         string  structure(
  153.                     len     byte,
  154.                     ch      byte);
  155.  
  156.     /* Form a one-character string and then print it */
  157.     string.ch = char;
  158.     string.len = 1;
  159.     call print( @string );
  160.  
  161. end print$char;
  162.  
  163.  
  164. exit$program: procedure public;
  165.  
  166.     /*
  167.      *  Exit from the program, i.e. return to the operating system.
  168.      *  This procedure does not return to the calling routine.
  169.      */
  170.  
  171.     declare
  172.         status      word;
  173.  
  174.     call new$line;  /* make sure the cursor's on a new line */
  175.     call rq$exit$io$job( 0, 0, @status );
  176.  
  177. end exit$program;
  178.  
  179.  
  180. disp$excep: procedure( excep$code );
  181.  
  182.     /*
  183.      *  Display the exception code and associated mnemonic (error
  184.      *  message) on the console.  (Does not include any CRLFs.)
  185.      */
  186.  
  187.     declare
  188.         ( excep$code, status )  word,
  189.         string$buffer           structure(
  190.                                     len     byte,
  191.                                     ch(40)  byte);
  192.  
  193.     string$buffer.len = 0;  /* Init to null string */
  194.     /* Get the exception code and mnemonic */
  195.     call rq$c$format$exception( @string$buffer, size(string$buffer),
  196.                                     excep$code, 1, @status );
  197.     call print( @string$buffer );   /* Display the exception message */
  198.  
  199. end disp$excep;
  200.  
  201.  
  202. check$status: procedure( status );
  203.  
  204.     /*
  205.      *  Check the exception code returned by a system call to the
  206.      *  variable STATUS.  If it is not E$OK, display the exception code
  207.      *  and mnemonic at the console and abort the program.
  208.      */
  209.  
  210.     declare
  211.         status      word;
  212.  
  213.     if ( status <> E$OK ) then
  214.       do;   /* Handle an exceptional condition */
  215.         call new$line;  /* Make sure we're at the start of a line */
  216.         call disp$excep( status );  /* Display the error message */
  217.         call print( @( 18,', program aborted.' ) ); /* And what we're doing */
  218.         call new$line;
  219.         /* And abort the program. */
  220.         call exit$program;
  221.       end;  /* if ( status <> E$OK ) */
  222.  
  223. end check$status;
  224.  
  225.  
  226. disable$exception$handler: procedure;
  227.  
  228.     /*
  229.      *  Disable the default exception handler, to prevent it from gaining
  230.      *  control and aborting the program as soon as any exception occurs.
  231.      */
  232.  
  233.     declare
  234.         status                  word,
  235.         exception$handler$info  structure(
  236.                                     offset  word,
  237.                                     base    word,
  238.                                     mode    byte);
  239.  
  240.     exception$handler$info.offset = 0;
  241.     exception$handler$info.base = 0;
  242.     exception$handler$info.mode = 0;    /* Never pass control to EH */
  243.     call rq$set$exception$handler( @exception$handler$info, @status );
  244.     call check$status( status );
  245.  
  246. end disable$exception$handler;
  247.  
  248.  
  249. setup$terminals: procedure;
  250.  
  251.     /*
  252.      *  Set up both terminal lines used by the program--the line to
  253.      *  the remote computer and our local console--by getting
  254.      *  connections to them, opening them in read/write mode,
  255.      *  and setting their terminal characteristics to no echo and
  256.      *  transparent/polling (no line editing) modes.
  257.      *  Initializes the globals REMOTE$TOK and CONSOLE$TOK.
  258.      */
  259.  
  260.     declare
  261.         status          word,
  262.         terminal$data   structure(
  263.                             number$param        word,
  264.                             number$used         word,
  265.                             connection$flags    word,
  266.                             terminal$flags      word,
  267.                             in$baud$rate        word,
  268.                             out$baud$rate       word,
  269.                             scroll$lines        word);
  270.  
  271.     /* Get both connections */
  272.     remote$tok = rq$s$attach$file( @remote$name, @status );
  273.     if ( status = E$LOG$NAME$NEXIST ) then
  274.       do;   /* Give a more helpful error message */
  275.         call print( @( 32,'Terminal line to remote computer' ) );
  276.         call print( @( 21,' must be attached as ' ) );
  277.         call print( @remote$name );
  278.         call new$line;
  279.         /* And abort the program */
  280.         call exit$program;
  281.       end;  /* if ( status = E$LOG$NAME$NEXIST ) */
  282.     else
  283.         call check$status( status );
  284.     console$tok = rq$s$attach$file( @console$name, @status );
  285.     call check$status( status );
  286.  
  287.     /* Open both for both reading and writing */
  288.     /* Specify zero buffers for interactive use */
  289.     call rq$s$open( remote$tok, 3, 0, @status );
  290.     call check$status( status );
  291.     call rq$s$open( console$tok, 3, 0, @status );
  292.     call check$status( status );
  293.  
  294.     /* Get current remote terminal characteristics */
  295.     terminal$data.number$param = 5;
  296.     terminal$data.number$used = 1;
  297.     call rq$s$special( remote$tok, 4, @terminal$data, 0, @status );
  298.     call check$status( status );
  299.     /* Set to transparent/polling mode and no echo */
  300.     terminal$data.connection$flags =
  301.                         ( terminal$data.connection$flags OR 0007h );
  302.     terminal$data.number$param = 5;
  303.     terminal$data.number$used = 1;
  304.     call rq$s$special( remote$tok, 5, @terminal$data, 0, @status );
  305.     call check$status( status );
  306.  
  307.     /* Get current console characteristics */
  308.     terminal$data.number$param = 5;
  309.     terminal$data.number$used = 1;
  310.     call rq$s$special( console$tok, 4, @terminal$data, 0, @status );
  311.     call check$status( status );
  312.     /* Set to transparent/polling mode and no echo */
  313.     terminal$data.connection$flags =
  314.                         ( terminal$data.connection$flags OR 0007h );
  315.     terminal$data.number$param = 5;
  316.     terminal$data.number$used = 1;
  317.     call rq$s$special( console$tok, 5, @terminal$data, 0, @status );
  318.     call check$status( status );
  319.  
  320. end setup$terminals;
  321.  
  322.  
  323. retrap$control$c: procedure;
  324.  
  325.     /*
  326.      *  Prevent a CTRL/C typed on the console from interrupting
  327.      *  the program, after TRAP$CONTROL$C has been called once.
  328.      *  This is needed because each call to C$SEND$COMMAND re-enables
  329.      *  the system's CTRL/C trap, so this must be called to re-enable
  330.      *  ours.
  331.      */
  332.  
  333.     declare
  334.         status      word,
  335.         signal$pair structure(
  336.                         semaphore   token,
  337.                         character   byte);
  338.  
  339.     /* Associate CTRL/C from the console with our semaphore */
  340.     signal$pair.semaphore = cc$sema4;
  341.     signal$pair.character = CTRL$C;
  342.     call rq$s$special( console$tok, 6, @signal$pair, 0, @status );
  343.     call check$status( status );
  344.  
  345. end retrap$control$c;
  346.  
  347.  
  348. trap$control$c: procedure;
  349.  
  350.     /*
  351.      *  Prevent a CTRL/C typed on the console from interrupting
  352.      *  the program, and instead allow us to test for whether CTRL/C
  353.      *  has been pressed by calling the function CONTROL$C$FLAG (defined
  354.      *  below).  Initializes the global CC$SEMA4.  (SETUP$TERMINALS must
  355.      *  have previously been called to get a connection to the console
  356.      *  into the global CONSOLE$TOK.)
  357.      */
  358.  
  359.     declare
  360.         status      word;
  361.  
  362.     /* Create a semaphore to receive a unit when a CTRL/C is pressed */
  363.     cc$sema4 = rq$create$semaphore( 0, 1, 0, @status );
  364.     call check$status( status );
  365.     /* And assign CTRL/C to our semaphore */
  366.     call retrap$control$c;
  367.  
  368. end trap$control$c;
  369.  
  370.  
  371. control$c$flag: procedure boolean;
  372.  
  373.     /*
  374.      *  Return TRUE if CTRL/C has been pressed on the console,
  375.      *  FALSE otherwise.  (TRAP$CONTROL$C must previously have been
  376.      *  called.)  If it returns TRUE, it will return FALSE on succeeding
  377.      *  calls unless CTRL/C was pressed again.
  378.      */
  379.  
  380.     declare
  381.         ( units$left, status )  word;
  382.  
  383.     /* Check for a unit at the semaphore (don't wait for one) */
  384.     units$left = rq$receive$units( cc$sema4, 0, 0, @status );
  385.     call check$status( status );
  386.     if ( units$left = 0 ) then  /* there wasn't one */
  387.         return( FALSE );    /* so signal no CTRL/C */
  388.     else    /* there was one */
  389.       do;
  390.         /* Take that unit from the semaphore (so it won't be seen again) */
  391.         units$left = rq$receive$units( cc$sema4, 1, 0, @status );
  392.         call check$status( status );
  393.         return( TRUE );     /* And signal that we got a CTRL/C */
  394.       end;  /* else */
  395.  
  396. end control$c$flag;
  397.  
  398.  
  399. setup: procedure public;
  400.  
  401.     /*
  402.      *  This procedure does the system-dependent setup
  403.      *  which must be done when the Kermit program
  404.      *  is first started.
  405.      */
  406.  
  407.     declare
  408.         status      word;
  409.  
  410.     call disable$exception$handler;
  411.     call setup$terminals;
  412.     call trap$control$c;
  413.     /* Create a command connection, using the console for :CI: and :CO: */
  414.     comm$conn = rq$c$create$command$connection( console$tok, console$tok,
  415.                                                 0, @status );
  416.     call check$status( status );
  417.  
  418. end setup;
  419.  
  420.  
  421. read$char: procedure( source ) word public;
  422.  
  423.     /*
  424.      *  Return the next character from the file (or device) specified
  425.      *  by SOURCE (which must be a connection open for reading).
  426.      *  Returns the constant EOF$CODE (which cannot be a character
  427.      *  because it is larger than 0FFh) if the file pointer is
  428.      *  at end-of-file.
  429.      */
  430.  
  431.     declare
  432.         source                  token,
  433.         ( bytes$read, status )  word,
  434.         ch                      byte;
  435.  
  436.     if ( source = remote$tok) then
  437.       do;   /* do buffered input from remote */
  438.         if ( in$buff.next >= in$buff.len ) then
  439.           do;   /* re-fill the buffer */
  440.             bytes$read = rq$s$read$move( source, @in$buff.ch, 256, @status );
  441.             call check$status( status );
  442.             in$buff.next = 0;   /* reset the pointers */
  443.             in$buff.len = bytes$read;
  444.             if ( in$buff.len = 0 ) then     /* there's no more to be read */
  445.                 return( EOF$CODE ); /* so signal end-of-file */
  446.           end;  /* if ... */
  447.         ch = in$buff.ch( in$buff.next );    /* get next char from the buffer */
  448.         in$buff.next = in$buff.next + 1;    /* update the pointer */
  449.         return( ch );               /* and return the character */
  450.       end;  /* if ... */
  451.     else
  452.       do;   /* Read the next byte from the file */
  453.         bytes$read = rq$s$read$move( source, @ch, 1, @status );
  454.         call check$status( status );
  455.         if ( bytes$read = 0 ) then  /* we ran into end-of-file */
  456.             return( EOF$CODE );     /* so signal that */
  457.         else    /* we got a character */
  458.             return( ch );       /* so return it */
  459.       end;  /* else */
  460.  
  461. end read$char;
  462.  
  463.  
  464. get$next$file$name: procedure( info$ptr ) public;
  465.  
  466.     /*
  467.      *  Place the name of the next file to be sent into the buffer
  468.      *  pointed to by INFO$PTR.  This assumes that GET$FIRST$FILE$NAME
  469.      *  has previously been called.  When there are no more filenames,
  470.      *  the buffer receives a null string (length zero).
  471.      */
  472.  
  473.     declare
  474.         info$ptr            pointer,
  475.         ch                  word,
  476.         info based info$ptr structure(
  477.                                 len     byte,
  478.                                 ch(1)   byte);
  479.  
  480.     info.len = 0;   /* init to null string */
  481.     ch = read$char( file$list );    /* read the first character */
  482.     /* Read characters from the file-list file up to return or EOF */
  483.     do while ( ( ch <> CR ) and ( ch <> EOF$CODE ) );
  484.         info.ch( info.len ) = ch;   /* store previous char */
  485.         info.len = ( info.len + 1 );    /* update length */
  486.         ch = read$char( file$list );    /* get next char */
  487.     end;    /* do while ( ( ch <> CR ) and ( ch <> EOF$CODE ) ) */
  488.     if ( ch = CR ) then     /* we got a return */
  489.         ch = read$char( file$list );    /* discard the line-feed too */
  490.  
  491. end get$next$file$name;
  492.  
  493.  
  494. get$first$file$name: procedure( keyword$num, info$ptr ) public;
  495.  
  496.     /*
  497.      *  Get the first filename matching the filespec in keyword number
  498.      *  KEYWORD$NUM into the buffer pointed to by INFO$PTR.  This routine
  499.      *  also does the setup necessary for handling wild-card file names so
  500.      *  that GET$NEXT$FILE$NAME can return the subsequent matching file
  501.      *  names.  Returns a null string to the buffer if the name cannot
  502.      *  be parsed (e.g. contains wildcards which don't match any files).
  503.      */
  504.  
  505.     declare
  506.         keyword$num             byte,
  507.         info$ptr                pointer,
  508.         ( status, com$status )  word,
  509.         info based info$ptr     structure(
  510.                                     len     byte,
  511.                                     ch(1)   byte);
  512.  
  513.     /* Get the filespec (possibly with wildcards) into the INFO buffer */
  514.     call get$filespec( keyword$num, info$ptr );
  515.     /* Send the ITEMIZE command to list the matching filenames */
  516.     call rq$c$send$command( comm$conn, @( 9,'ITEMIZE &' ), @com$status,
  517.                                 @status );
  518.     if ( status <> E$CONTINUED ) then   /* should be continued */
  519.         call check$status( status );
  520.     /* Append an ampersand to the filespec */
  521.     info.ch( info.len ) = '&';
  522.     info.len = ( info.len + 1 );
  523.     /* And concatenate it to the ITEMIZE command */
  524.     call rq$c$send$command( comm$conn, @info, @com$status, @status );
  525.     if ( status <> E$CONTINUED ) then   /* should still be continued */
  526.         call check$status( status );
  527.     /* Form the rest of the command in the INFO buffer */
  528.     call movb( @( ' OVER ' ), @info.ch( 0 ), 6 );   /* the preposition */
  529.     /* and the output filename */
  530.     call movb( @file$list$name( 1 ), @info.ch( 6 ), file$list$name( 0 ) );
  531.     info.len = ( file$list$name( 0 ) + 8 ); /* store length */
  532.     info.ch( info.len - 2 ) = CR;
  533.     info.ch( info.len - 1 ) = LF;
  534.     /* Send the rest of the command and exectue it */
  535.     call rq$c$send$command( comm$conn, @info, @com$status, @status );
  536.     call check$status( status );
  537.     call retrap$control$c;
  538.     if ( com$status = E$OK ) then   /* it executed O.K. */
  539.       do;
  540.         /* Get a connection to the file produced */
  541.         file$list = rq$c$get$input$connection( @file$list$name, @status );
  542.         call check$status( status );
  543.         call get$next$file$name( @info );   /* and get the first filename */
  544.       end;  /* if ( com$status = E$OK ) */
  545.     else    /* A problem with the ITEMIZE command */
  546.         info.len = 0;   /* Return null-string as the file-name */
  547.  
  548. end get$first$file$name;
  549.  
  550.  
  551. finish$send: procedure public;
  552.  
  553.     /*
  554.      *  Clean up after the ITEMIZE command.
  555.      */
  556.  
  557.     declare
  558.         status  word;
  559.  
  560.     /* Delete the file connection, if possible */
  561.     call rq$s$delete$connection( file$list, @status );
  562.     /* And delete the temporary file itself, if possible */
  563.     call rq$s$delete$file( @file$list$name, @status );
  564.     /* STATUS is ignored because the file may not */
  565.     /* have been successfully created */
  566.  
  567. end finish$send;
  568.  
  569.  
  570. prepare$file$name: procedure( info$ptr ) public;
  571.  
  572.     /*
  573.      *  Prepare the filename in the buffer pointed to by INFO$PTR for
  574.      *  sending to the other Kermit--i.e. remove directory and/or device
  575.      *  names, leaving only the filename itself in the buffer.
  576.      */
  577.  
  578.     declare
  579.         info$ptr            pointer,
  580.         ( i, ch )           byte,
  581.         info based info$ptr structure(
  582.                                 len     byte,
  583.                                 ch(1)   byte);
  584.  
  585.     i = info.len;   /* Start at the end of the pathname */
  586.     ch = info.ch( i - 1 );  /* Get last character */
  587.     do while ( ( ch <> '/' ) and ( ch <> '^' ) and ( ch <> ':' )
  588.                 and ( i > 0 ) );    /* while we're still in the filename */
  589.         i = ( i - 1 );  /* scan backwards to the start of actual filename */
  590.         ch = info.ch( i - 1 );  /* get current character */
  591.     end;    /* do while ... */
  592.     if ( i > 0 ) then   /* there's a logical or directory name to be trimmed */
  593.       do;
  594.         /* move the actual filename to the beginning of the buffer */
  595.         call movb( @info.ch( i ), @info.ch( 0 ), ( info.len - i ) );
  596.         info.len = ( info.len - i );    /* and update length */
  597.       end;  /* if ( i > 0 ) */
  598.  
  599. end prepare$file$name;
  600.  
  601.  
  602. open$file: procedure( name$ptr ) boolean public;
  603.  
  604.     /*
  605.      *  Open the file specified in the string (length byte followed
  606.      *  by the characters of the name) pointed to by NAME$PTR, which is
  607.      *  assumed to already exist, for reading.  Sets the global CUR$FILE.
  608.      *  Returns TRUE if the open was successful, otherwise it prints
  609.      *  an error message on the console describing the problem
  610.      *  encountered and returns FALSE.
  611.      */
  612.  
  613.     declare
  614.         status      word,
  615.         name$ptr    pointer;
  616.  
  617.     /* Get a connection to the file */
  618.     cur$file = rq$s$attach$file( name$ptr, @status );
  619.     if ( status = E$OK ) then   /* we got a connection */
  620.         /* so open it, for reading only, with two buffers */
  621.         call rq$s$open( cur$file, 1, 2, @status );
  622.     if ( status = E$OK ) then   /* we successfully opened the file */
  623.         return( TRUE );     /* indicate success */
  624.     else    /* we encountered a problem */
  625.       do;   /* Display an error message */
  626.         call print( @( 17,'Can''t open file "' ) );
  627.         call print( name$ptr );
  628.         call print( @( 3,'"; ' ) );
  629.         if ( status = E$FACCESS ) then
  630.             call print( @( 20,'read access required' ) );
  631.         else if ( status = E$FNEXIST ) then
  632.             call print( @( 19,'file does not exist' ) );
  633.         else if ( status = E$FTYPE ) then
  634.             call print( @( 32,'can''t use data file as directory' ) );
  635.         else
  636.             call disp$excep( status );
  637.         return( FALSE );    /* and indicate failure */
  638.       end;
  639.  
  640. end open$file;
  641.  
  642.  
  643. create$file: procedure( name$ptr ) boolean public;
  644.  
  645.     /*
  646.      *  Create the file specified in the string (length byte followed
  647.      *  by the characters of the name pointed to by NAME$PTR and open
  648.      *  it for writing.  If it already exists the user will be asked
  649.      *  whether to overwrite it.  If the operation is successful the
  650.      *  global CUR$FILE is set and TRUE is returned, otherwise an
  651.      *  error message is displayed at the console and FALSE is returned.
  652.      */
  653.  
  654.     declare
  655.         status      word,
  656.         answer      byte,
  657.         name$ptr    pointer;
  658.  
  659.     /* First, check whether the file already exists */
  660.     cur$file = rq$s$attach$file( name$ptr, @status );
  661.     if ( status = E$OK ) then   /* the file does already exist */
  662.       do;
  663.         /* First, delete the connection we didn't really want */
  664.         call rq$s$delete$connection( cur$file, @status );
  665.         call check$status( status );
  666.         /* Now, ask the user whether to overwrite the file */
  667.         call print( @( 6,'File "' ) );
  668.         call print( name$ptr );
  669.         call print( @( 37,'" already exists; overwrite it <no>? ' ) );
  670.         answer = get$console$char( 0FFFFh );    /* wait for an answer */
  671.         call print$char( answer );  /* show them what they typed */
  672.         call new$line;  /* and that the question is finished */
  673.         if ( upcase( answer ) = 'Y' ) then
  674.             status = E$FNEXIST;     /* act as if the file didn't exist */
  675.         else    /* they don't want to overwrite it */
  676.             return( FALSE );    /* indicate failure, with no error message */
  677.       end;
  678.     if ( status = E$FNEXIST ) then  /* it's O.K. to go ahead and create it */
  679.       do;
  680.         cur$file = rq$s$create$file( name$ptr, @status );
  681.         if ( status = E$OK ) then   /* we created the file O.K. */
  682.             /* so open it, for writing only, with two buffers */
  683.             call rq$s$open( cur$file, 2, 2, @status );
  684.       end;
  685.     if ( status = E$OK ) then   /* we successfully created the file */
  686.         return( TRUE );     /* indicate success */
  687.     else    /* we encountered a problem */
  688.       do;   /* Display an error message */
  689.         call print( @( 19,'Can''t create file "' ) );
  690.         call print( name$ptr );
  691.         call print( @( 3,'"; ' ) );
  692.         if ( status = E$FACCESS ) then
  693.             call print( @( 21,'write access required' ) );
  694.         else if ( status = E$FNEXIST ) then
  695.             call print( @( 19,'file does not exist' ) );
  696.         else if ( status = E$FTYPE ) then
  697.             call print( @( 32,'can''t use data file as directory' ) );
  698.         else
  699.             call disp$excep( status );
  700.         return( FALSE );    /* and indicate failure */
  701.       end;
  702.  
  703. end create$file;
  704.  
  705.  
  706. close$file: procedure public;
  707.  
  708.     /*
  709.      *  Close the file specified by the connection in the global
  710.      *  token CUR$FILE.
  711.      */
  712.  
  713.     declare
  714.         status      word;
  715.  
  716.     call rq$s$close( cur$file, @status );   /* close the file */
  717.     call check$status( status );
  718.     /* and delete the connection */
  719.     call rq$s$delete$connection( cur$file, @status );
  720.     call check$status( status );
  721.  
  722. end close$file;
  723.  
  724.  
  725. get$char: procedure( source, time$limit ) word;
  726.  
  727.     /*
  728.      *  Return the next character from the terminal line (connection)
  729.      *  indicated by SOURCE, waiting until a character arrives or
  730.      *  TIME$LIMIT seconds have elapsed; if the time limit expires
  731.      *  with no character having been received, return the constant
  732.      *  TIMEOUT (which cannot be a character because it is larger than
  733.      *  0FFh).  If CTRL/C is pressed on the console, it will immediately
  734.      *  return the constant CTRL$C$CODE (which also cannot be a character).
  735.      *  If TIME$LIMIT is zero, will return immediately, with a character
  736.      *  if one was waiting (or CTRL$C$CODE), otherwise with TIMEOUT.  If
  737.      *  TIME$LIMIT = 0FFFFh it is taken to be infinite, i.e. it will
  738.      *  never time out.
  739.      */
  740.  
  741.     declare
  742.         source                      token,
  743.         ( time$limit, ch, status )  word,
  744.         ( start$time, time$now )    dword,
  745.         timed$out                   boolean;
  746.  
  747.     /* Store the time at which we started waiting */
  748.     start$time = rq$get$time( @status );
  749.     call check$status( status );
  750.     ch = EOF$CODE;  /* we haven't gotten anything yet */
  751.     timed$out = FALSE;  /* Ensure that we go through the loop at least once */
  752.     /* Loop until we time out or get a character */
  753.     do while ( ( not timed$out ) and ( ch = EOF$CODE ) );
  754.         /* Check for a control-C interrupt from the console */
  755.         if ( control$c$flag ) then  /* We got one */
  756.             ch = CTRL$C$CODE;   /* so return the "character" CTRL$C$CODE */
  757.         else    /* no control-C */
  758.             ch = read$char( source );   /* look for a normal character */
  759.         if ( ch = EOF$CODE ) then   /* if we didn't get anything */
  760.           do;   /* check on the time limit */
  761.             if ( time$limit = 0 ) then  /* if they don't want to wait */
  762.                 timed$out = TRUE;   /* time out immediately */
  763.             /* if they gave a finite time limit */
  764.             else if ( time$limit < 0FFFFh ) then
  765.               do;   /* check whether we've run out of time yet */
  766.                 /* Get the time now */
  767.                 time$now = rq$get$time( @status );
  768.                 call check$status( status );
  769.                 /* If the elapsed time is greater than the limit */
  770.                 if ( ( time$now - start$time ) > time$limit ) then
  771.                     timed$out = TRUE;   /* we ran out of time, stop waiting */
  772.               end;  /* if ( time$limit < 0FFFFh ) */
  773.             /* If TIME$LIMIT is infinite (0FFFFh), TIMED$OUT stays FALSE */
  774.           end;  /* if ( ch = EOF$CODE ) */
  775.     end;    /* do while ( ( not timed$out ) and ( ch = EOF$CODE ) ) */
  776.     if ( timed$out ) then   /* we ran out of time */
  777.         return( TIMEOUT );  /* so return that information */
  778.     else    /* we got a character (or control-C) */
  779.         return( ch );   /* so return that */
  780.  
  781. end get$char;
  782.  
  783.  
  784. get$console$char: procedure( time$limit ) word public;
  785.  
  786.     declare
  787.         time$limit  word;
  788.  
  789.     return( get$char( console$tok, time$limit ) );
  790.  
  791. end get$console$char;
  792.  
  793.  
  794. get$remote$char: procedure( time$limit ) word public;
  795.  
  796.     declare
  797.         time$limit  word;
  798.  
  799.     return( get$char( remote$tok, time$limit ) );
  800.  
  801. end get$remote$char;
  802.  
  803.  
  804. put$char: procedure( destination, ch ) public;
  805.  
  806.     /*
  807.      *  Put the character CH out to the file or terminal line
  808.      *  specified by DESTINATION (which must be a connection
  809.      *  open for writing).
  810.      */
  811.  
  812.     declare
  813.         destination                 token,
  814.         ch                          byte,
  815.         ( bytes$written, status )   word;
  816.  
  817.     bytes$written = rq$s$write$move( destination, @ch, 1, @status );
  818.     call check$status( status );
  819.  
  820. end put$char;
  821.  
  822.  
  823. xmit$console$char: procedure( ch ) public;
  824.  
  825.     /*
  826.      *  Send character CH to the console.
  827.      */
  828.  
  829.     declare
  830.         ch  byte;
  831.  
  832.     call put$char( console$tok, ch );
  833.  
  834. end xmit$console$char;
  835.  
  836.  
  837. xmit$remote$char: procedure( ch ) public;
  838.  
  839.     /*
  840.      *  Send character CH out to the remote port.
  841.      */
  842.  
  843.     declare
  844.         ch  byte;
  845.  
  846.     call put$char( remote$tok, ch );
  847.  
  848. end xmit$remote$char;
  849.  
  850.  
  851. xmit$packet: procedure( packet$ptr, len ) public;
  852.  
  853.     /*
  854.      *  Send a whole packet, pointed to by PACKET$PTR and
  855.      *  containing LEN characters, out to the remote port.
  856.      */
  857.  
  858.     declare
  859.         packet$ptr                      pointer,
  860.         ( len, bytes$written, status )  word;
  861.  
  862.     bytes$written = rq$s$write$move( remote$tok, packet$ptr, len, @status );
  863.     call check$status( status );
  864.  
  865. end xmit$packet;
  866.  
  867.  
  868. flush$input$buffer: procedure public;
  869.  
  870.     /*
  871.      *  Flush (empty) the input ("type-ahead") buffer for the
  872.      *  line on which we are connected to the other Kermit.
  873.      *  Also clears any stored-up CTRL/C's from the console.
  874.      */
  875.  
  876.     do while ( read$char( remote$tok ) <> EOF$CODE );
  877.         /* Keep reading (and discarding) characters */
  878.         /* until there aren't any more */
  879.     end;    /* do while ( read$char( remote$tok ) <> EOF$CODE ) */
  880.     do while ( control$c$flag = TRUE );
  881.         /* And the same with control-C's */
  882.     end;    /* do while ( control$c$flag = TRUE ) */
  883.  
  884. end flush$input$buffer;
  885.  
  886.  
  887. get$command$line: procedure( prompt$ptr ) public;
  888.  
  889.     /*
  890.      *  Display the string pointed to by PROMPT$PTR and get a command
  891.      *  line from the console into the global buffer COM$LINE.  This
  892.      *  procedure also does some preliminary processing of the command line:
  893.      *  All letters are converted to upper-case, tabs are converted to
  894.      *  spaces, spaces which are redundant or at the beginning of the
  895.      *  command line are removed, and line terminators are removed.
  896.      *  Thus upon return the COM$LINE buffer should contain simply the
  897.      *  keyword(s), separated by only one space each.
  898.      */
  899.  
  900.     declare
  901.         prompt$ptr  pointer,
  902.         space$flag  boolean,    /* TRUE if a space here is significant */
  903.         ( i, j )    byte,       /* Indicies into the command line buffer */
  904.         status      word;
  905.  
  906.     /* Issue the prompt and get the command line into the buffer */
  907.     call rq$c$send$co$response( @com$line, size( com$line ),
  908.                                     prompt$ptr, @status );
  909.     call check$status( status );
  910.  
  911.     if ( com$line.len = 0 ) then    /* We got EOF (end-of-file, or ^Z) */
  912.       do;   /* Treat the EOF like an EXIT command */
  913.         call print( @( 2,'^Z' ) );  /* Echo the ^Z */
  914.         call new$line;  /* And echo a CRLF */
  915.         /* Put the EXIT command in the buffer */
  916.         call movb( @( 4,'EXIT' ), @com$line, 5 );
  917.       end;  /* if ( com$line.len = 0 ) */
  918.     else    /* We got a command line */
  919.       do;   /* do the preliminary processing of the command line */
  920.         /* If the last character wasn't a line-feed */
  921.         if ( com$line.ch( com$line.len - 1 ) <> LF ) then
  922.             call new$line;  /* Get the cursor onto a new line */
  923.         /* Add a CR at the end in case there isn't one */
  924.         com$line.ch( com$line.len ) = CR;
  925.         i, j = 0;   /* init the pointers to the start of the buffer */
  926.         space$flag = FALSE; /* Initial spaces are meaningless */
  927.         /* Process the line until the CR */
  928.         do while ( com$line.ch( i ) <> CR );
  929.             if ( com$line.ch( i ) = HT ) then
  930.                 com$line.ch( i ) = ' ';     /* convert tabs to spaces */
  931.             /* If this is a significant character */
  932.             if ( space$flag or ( com$line.ch( i ) <> ' ' ) ) then
  933.               do;   /* Process this character */
  934.                 /* Store it (capitalized) in the resulting command line */
  935.                 com$line.ch( j ) = upcase( com$line.ch( i ) );
  936.                 j = j + 1;  /* Increment the pointer to the result */
  937.                 if ( com$line.ch( i ) = ' ' ) then  /* if it's a space */
  938.                     space$flag = FALSE; /* further spaces are redundant */
  939.                 else    /* it's not a space */
  940.                     space$flag = TRUE;  /* so a space after it is meaningful */
  941.               end;  /* if ( space$flag or ( com$line.ch( i ) <> ' ' ) ) */
  942.             i = i + 1;  /* Move to the next character of input */
  943.         end;    /* do while ( com$line.ch( i ) <> CR ) */
  944.         com$line.len = j;   /* Store the length of the result */
  945.       end;  /* else -- we got a command line */
  946.  
  947. end get$command$line;
  948.  
  949.  
  950. do$help: procedure( num$params ) public;
  951.  
  952.     /*
  953.      *  Perform the HELP command.  This procedure passes the name
  954.      *  of our help library and the number of parameters specified
  955.      *  by NUM$PARAMS to the HELP program.
  956.      */
  957.  
  958.     declare
  959.         ( num$params, i )       byte,
  960.         ( com$status, status )  word,
  961.         buffer                  structure(
  962.                                     len     byte,
  963.                                     ch(50)  byte);
  964.  
  965.     /* Get the name of the file containing this program */
  966.     call rq$c$get$command$name( @buffer, size( buffer ), @status );
  967.     call check$status( status );
  968.     /* Append the .HLP suffix to it, forming the name of the help library */
  969.     call movb( @( '.HLP &' ), @buffer.ch( buffer.len ), 6 );
  970.     buffer.len = ( buffer.len + 6 );
  971.     /* Send the HELP command, with @ to signal library name comes next */
  972.     call rq$c$send$command( comm$conn, @( 7,'HELP @&' ), @com$status,
  973.                                 @status );
  974.     if ( status <> E$CONTINUED ) then   /* should be continued */
  975.         call check$status( status );
  976.     /* Add our help library name to it */
  977.     call rq$c$send$command( comm$conn, @buffer, @com$status, @status );
  978.     if ( status <> E$CONTINUED ) then   /* should still be continued */
  979.         call check$status( status );
  980.     /* For each parameter which we have */
  981.     do i = 1 to num$params;
  982.         call get$filespec( i, @buffer );    /* get the parameter */
  983.         buffer.ch( buffer.len ) = ' ';
  984.         buffer.ch( buffer.len + 1 ) = '&';  /* add space and ampersand */
  985.         buffer.len = ( buffer.len + 2 );
  986.         /* Append the parameter to the HELP command line */
  987.         call rq$c$send$command( comm$conn, @buffer, @com$status, @status );
  988.         if ( status <> E$CONTINUED ) then   /* should still be continued */
  989.             call check$status( status );
  990.     end;    /* do i = 1 to num$params */
  991.     /* And finally execute the command */
  992.     call rq$c$send$command( comm$conn, @( 2,CR,LF ), @com$status, @status );
  993.     call check$status( status );
  994.     call retrap$control$c;
  995.  
  996. end do$help;
  997.  
  998.  
  999. end kermit$sys;
  1000.