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