home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / multics / mukmt.pl1 < prev    next >
Text File  |  2020-01-01  |  83KB  |  2,495 lines
  1. new_kermit: old_kermit:
  2. latest_kermit: frog:
  3. kermit: proc;
  4. /********************************************************************/
  5. /*  This is a packet-based communications program implementing      */
  6. /*  the Kermit protocol.  The target is a microcomputer running     */
  7. /*  a local version of Kermit.                                      */
  8. /********************************************************************/
  9.  
  10. /********************************************************************/
  11. /*>>>>>>>>>>>>>  Copyright (C) Oakland University 1983  <<<<<<<<<<<<*/
  12. /*>>>>>>>>>>>>>  Copyright (C) Oakland University 1984  <<<<<<<<<<<<*/
  13. /*>>>  Copying without fee is permitted provided that the copies  <<*/
  14. /*>>>  are not made or distributed for commercial advantage and  <<<*/
  15. /*>>>>>>>>>>>>>>>>  credit to the source is given.  <<<<<<<<<<<<<<<<*/
  16. /********************************************************************/
  17.  
  18. /********************************************************************/
  19. /*  The Version 1 protocol supporting send and receive with most    */
  20. /*  of the commands in the help file implemented was finished       */
  21. /*  around Sept 20, 1983.                                           */
  22. /*                                                                  */
  23. /*                                                                  */
  24. /*  The Author of this program is:                                  */
  25. /*  .          Paul Amaranth                                        */
  26. /*  .          Oakland University                                   */
  27. /*  .          Academic Computer Services                           */
  28. /*  .          Rochester, MI  48063                                 */
  29. /*  .          (313) 377 - 4329                                     */
  30. /*                                                                  */
  31. /*  Please send copies of any changes to me at the above address.   */
  32. /*                                                                  */
  33. /*                                                                  */
  34. /*  UPDATES:                                                        */
  35. /*                                                                  */
  36. /*      11/30/83  Added previous_pkt_no proc to return number of    */
  37. /*                previous packet PGA                               */
  38. /*                                                                  */
  39. /*      Version Numbering:  <rewrite>.<major_change><twiddle>       */
  40. /*                                                                  */
  41. /*      1/84  2.0 Many features added, some at suggestion of jkc of */
  42. /*            MIT.  -set now works, improved error checks, ..       */
  43. /*            and . commands added, file-warning operational,       */
  44. /*            improved status message, -show, internal on-line      */
  45. /*            help and more.                                        */
  46. /*                                                                  */
  47. /*            The program itself has been divided into two separate */
  48. /*            modules, kermit performs the user interface services  */
  49. /*            and kermit_ serves as the protocol machine.           */
  50. /*                                                                  */
  51. /*            The kermit protocol as set forth in version           */
  52. /*            5 of the Kermit Protocol Manual is more or less       */
  53. /*            supported except  for file attributes.                */
  54. /*                                                                  */
  55. /*     6/84   2.0c  Most changes completed, although a few holes    */
  56. /*            are left.  Time to get it out the door.               */ 
  57. /*                                                                  */
  58. /*     7/84   2.0d  Tidied up help files - Put all online help      */
  59. /*            info into a single segment.                           */
  60. /*                                                                  */
  61. /*     7/84   2.0e  Checksum negotiation bug fixed                  */
  62. /*                  CRC fixed.  Packet length check bug fixed       */
  63. /*                                                                  */
  64. /*     8/84   2.0f  Download nack problem, ioa_ formatting detail   */
  65. /*                                                                  */
  66. /*     8/84   2.0g  Download nack problem, server bug, repeat "ing  */
  67. /*                                                                  */
  68. /*     9/84   2.0h  Fix 300 baud timing problem                     */
  69. /*                                                                  */
  70. /********************************************************************/
  71.  
  72. /*************************  METERING VARIABLES **********************/
  73.  
  74.     dcl meter_enable bit(1) init(true);
  75.     dcl kermit_mbx_ctl_arg char(5) var static init("-pn");  /* Make null string for psn.proj mbx */
  76.     dcl kermit_mbx char(168) var static init(">udd>acs>pga>meter>kermit.mbx");
  77.  
  78. /********************************************************************/
  79. /*>>>>>>>>>>>>>>>>>>>>>>>>>  Declarations  <<<<<<<<<<<<<<<<<<<<<<<<<*/
  80. /********************************************************************/
  81.  
  82. /*=================  Begin ret_structure.incl.pl1  <<<<<<<<<<<<<<<<<*/
  83.  
  84.     dcl 1 ret_structure,
  85.           2 line char(255) var,
  86.           2 more_commands bit(1),
  87.           2 command_code fixed bin,
  88.           2 error bit(1),
  89.           2 error_code fixed bin(35),
  90.           2 err_msg char(255) var,
  91.           2 type fixed bin,
  92.           2 parm fixed bin,
  93.           2 parm_val fixed bin;
  94.     
  95. /*==================  End ret_structure.incl.pl1  <<<<<<<<<<<<<<<<<<*/
  96.  
  97.  
  98.  
  99. /********************************************************************/
  100. /*  Constants                                                       */
  101. /********************************************************************/
  102.  
  103.     dcl big   char(26) static static options(constant)
  104.               init("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
  105.     dcl sml   char(26) static static options(constant)
  106.               init("abcdefghijklmnopqrstuvwxyz");
  107.     dcl numbers char(10) static options(constant) init("0123456789");
  108.     dcl null_char   char(1) based(addr(control_char.NULL));
  109.     dcl null_str    char(1) var static init("") options(constant);
  110.     dcl space       char(1) static init(" ") options(constant);
  111.     dcl colon       char(1) static init(":") options(constant);
  112.     dcl car_ret     fixed bin  static options(constant) init(13);
  113.     dcl false bit(1) static static options(constant) init("0"b);
  114.     dcl blank char(1) static static options(constant) init(" ");
  115.     dcl ampersand char(1) static options(constant) init("&");
  116.     dcl true  bit(1) static static options(constant) init("1"b);
  117.  
  118.     dcl carraige_return char(1) based(addr(control_char.CR));
  119.     dcl line_feed       char(1) based(addr(control_char.LF));
  120.  
  121.  
  122.     dcl kermit_info_dir char(168) static init(">am>KERMIT>info");
  123.  
  124.  
  125.  
  126. /********************************************************************/
  127. /*  Symbols                                                         */
  128. /********************************************************************/
  129.  
  130.     dcl 1 misc_symbols static,
  131.          2  max_packet_size  fixed bin init(94),
  132.          2  my_quote     char(1) init("#"),
  133.          2  my_pad       fixed bin init(0),
  134.          2 my_pad_char fixed bin init(0),
  135.          2 my_end_of_line fixed bin init(13);
  136.  
  137.  
  138.  
  139. /********************************************************************/
  140. /*  Blck transfer framing character info structures.                */
  141. /********************************************************************/
  142.  
  143.     dcl 1 orig_framing_chars static aligned,
  144.           2 start_char char(1) unaligned,
  145.           2 end_char char(1) unaligned;
  146.  
  147. /********************************************************************/
  148. /*  Global variables                                                */
  149. /********************************************************************/
  150.  
  151. /*==================  Begin kermit_info.incl.pl1  ==================*/
  152.  
  153.  
  154.     dcl 1 kermit_info based(info_ptr),
  155.           2 state      char(2),          /* Present state of automaton */
  156.           2 size       fixed bin,        /* Size of present data       */
  157.           2 send_parameters,
  158.             3 stimint     fixed bin(71),   /* Timeout for foreign host on sends */
  159.             3 sp_size    fixed bin,        /* Maximum send packet size */
  160.             3 pad        fixed bin,        /* How much padding to send */
  161.             3 pad_char   fixed bin,        /* Padding  character to send */
  162.             3 delay_time fixed bin(71),    /* Time to delay for sends     */
  163.             3 end_of_line fixed bin,       /* End-of-line to send */
  164.           2 receive_parameters,
  165.             3 rp_size    fixed bin,        /* Maximum receive packet size */
  166.             3 remote_quote  char(1),       /* Quote character, incomming data */
  167.             3 r_eol       fixed bin,       /* End-of-line to receive */
  168.             3 rtimint   fixed bin(71),     /* Timeout for host on receives */
  169.           2 max_try   fixed bin,         /* Times to retry a packet */
  170.           2 num_try   fixed bin,         /* Times this packet retried */
  171.           2 eight_bit_quote_char char(1),/* Char for quoting 8 bit stuff */
  172.           2 repeat_char  char(1),        /* CHar for flagging repeat sequences */
  173.           2 chktype fixed bin,           /* Type of check code to actually use */
  174.           2 current_packet_no fixed bin, /* Looking for msg number ... */
  175.           2 behavior_switches,
  176.             3 trace_sw bit(1),           /* Log packets to trace file   */
  177.             3 debug_sw bit(1),           /* Obtain packets from ext. proc */
  178.             3 eight_bit_quote bit(1),    /* Parity quoting allowed    */
  179.             3 repeat_allowed  bit(1),    /* Character compression allowed */
  180.             3 repeat_threshold fixed bin, /* Min # of chars to compress */
  181.             3 text_mode bit(1),          /* Type of files to send, init true */
  182.             3 file_warning_sw bit(1),    /* Overwrite file warning */
  183.           2 pointers,
  184.             3 file_list_ptr ptr,         /* Ptr to list of files          */
  185.             3 tty_iocb ptr,              /* Ptr to tty iocb for modes sw. */
  186.             3 input_bfr_ptr ptr,         /* Ptr to input buffer           */
  187.             3 orig_fc_ptr ptr,           /* Ptr to orig. framing chars    */
  188.             3 misc_symbol_ptr ptr,       /* Ptr to structure holding some symbls */
  189.           2 other_info,
  190.             3 default_dir char(168),     /* Default for send or receive  */
  191.             3 term_modes char(256),      /* To setup terminal for transfer */
  192.             3 old_term_modes char(512),  /* For restoring term on completion */
  193.             3 cur_file  fixed bin,       /* Current file pointer in list    */
  194.             3 allowed_ck_codes char(3),  /* Allowed error check codes        */
  195.             3 default_ck_code fixed bin, /* Type of check code to use by default */
  196.             3 help_dir char(168),        /* Help directory */
  197.           2 status_indicators,
  198.             3 return_code fixed bin(35),
  199.             3 total_packet_trns fixed bin,
  200.             3 total_packet_rcvd fixed bin,
  201.             3 total_retry_count  fixed bin,
  202.             3 files_rcvd fixed bin,
  203.             3 files_trns fixed bin,
  204.             3 failures   fixed bin,
  205.             3 last_file_transferred char(168); /* Name of last file */
  206.  
  207. /*===================  End kermit_info.incl.pl1  ===================*/
  208.  
  209.  
  210.     dcl init bit(1) static init("0"b);  /* Flag for static initialization */
  211.  
  212.     dcl server_mode bit(1) init(false);  /* Slave? */
  213.  
  214.  
  215.     dcl 1 files static,            /* List of files to send/receive   */
  216.           2 total_num fixed bin init(100),
  217.           2 num_files fixed bin init(0),
  218.           2 names (100),
  219.             3 dir char(168),
  220.             3 entry char(32);
  221.  
  222.     dcl current_version char(10) var static init("2.0h");
  223.     dcl version_date char(8) var static init("8/31/84");
  224.  
  225. /*===============  Begin control_constants.incl.pl1  ===============*/
  226.  
  227. /********************************************************************/
  228. /*  This structure avoids using embedded control characters in      */
  229. /*  the source. Multics characters are nine bits.                   */
  230. /********************************************************************/
  231.  
  232.  
  233.     dcl 1 binary_codes static options(constant) aligned,
  234.           2 bits_NULL bit(9) init("000000000"b),
  235.           2 bits_CR   bit(9) init("000001101"b),
  236.           2 bits_LF   bit(9) init("000001010"b),
  237.           2 bits_CTL_Z bit(9) init("000011010"b),
  238.           2 bits_SOH   bit(9) init("000000001"b),
  239.           2 bits_tilde bit(9) init("001111110"b);
  240.  
  241.     dcl 1 overlay_chars based(addr(binary_codes)) aligned,
  242.           2 NULL char(1),
  243.           2 CR   char(1),
  244.           2 LF   char(1),
  245.           2 CTL_Z char(1),
  246.           2 SOH   char(1),
  247.           2 tilde char(1);
  248.  
  249. /*================  End control_constants.incl.pl1  ================*/
  250.  
  251.  
  252. /********************************************************************/
  253. /*  More variables                                                  */
  254. /********************************************************************/
  255.  
  256.     dcl arg_lst_ptr ptr;
  257.     dcl code     fixed bin(35);
  258.     dcl cur_inpt_bfr_len fixed bin(21);
  259.     dcl input_buffer char(input_bfr_len) aligned;
  260.     dcl input_bfr_len fixed bin(21) static init(100);
  261.     dcl info_ptr ptr static;   /* ptr to pass info to kermit_ */
  262.     dcl iox_$user_io ptr static external;
  263.     dcl nargs fixed bin;
  264.     dcl prog char(6) static init("kermit");
  265.     dcl server_used bit(1) init(false);
  266.  
  267.     dcl cum_pkt_trns fixed bin init(0);
  268.     dcl cum_pkt_rcvd fixed bin init(0);
  269.     dcl cum_pkt_retry fixed bin init(0);
  270.     dcl cum_files_trns fixed bin init(0);
  271.     dcl cum_files_rcvd fixed bin init(0);
  272.     dcl cum_failures fixed bin init(0);
  273.  
  274.  
  275. /********************************************************************/
  276. /*  Error codes                                                     */
  277. /********************************************************************/
  278.  
  279.     dcl bad_command      fixed bin static options(constant) init(1);
  280.     dcl bad_file_spec    fixed bin static options(constant) init(2);
  281.     dcl bad_help_option  fixed bin static options(constant) init(3);
  282.     dcl bad_set_parm     fixed bin static options(constant) init(4);
  283.     dcl bad_set_spec     fixed bin static options(constant) init(5);
  284.     dcl bad_show_spec    fixed bin static options(constant) init(6);
  285.     dcl bad_syntax       fixed bin static options(constant) init(7);
  286.     dcl missing_set_parm fixed bin static options(constant) init(8);
  287.     dcl mssng_set_parm_val fixed bin static options(constant) init(9);
  288.     dcl non_numeric_val  fixed bin static options(constant) init(10);
  289.     dcl bad_octal_val    fixed bin static options(constant) init(11);
  290.     dcl bad_dir_name     fixed bin static options(constant) init(12);
  291.     dcl not_dir_name     fixed bin static options(constant) init(13);
  292.  
  293. /********************************************************************/
  294. /*  Multics error codes                                             */
  295. /********************************************************************/
  296.  
  297.     dcl error_table_$action_not_performed fixed bin(35) external;
  298.     dcl error_table_$bad_arg fixed bin(35) external;
  299.     dcl error_table_$badstar fixed bin(35) external;
  300.     dcl error_table_$dirseg fixed bin(35) external;
  301.     dcl error_table_$noarg fixed bin(35) external;
  302.     dcl error_table_$noentry  fixed bin(35) external;
  303.  
  304.  
  305.  
  306. /********************************************************************/
  307. /*  Multics routines                                                */
  308. /********************************************************************/
  309.  
  310.     dcl check_star_name_$entry entry (char(*), fixed bin(35));
  311.     dcl com_err_ entry options(variable);
  312.     dcl com_err_$suppress_name entry options(variable);
  313.     dcl cu_$arg_count entry (fixed bin);
  314.     dcl cu_$arg_list_ptr  entry (ptr);
  315.     dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin(21), fixed bin(35), ptr);
  316.     dcl cu_$cp      entry(ptr, fixed bin(21), fixed bin(35));
  317.     dcl cv_oct_check_ entry(char(*), fixed bin(35)) returns(fixed bin(35));
  318.     dcl expand_pathname_ entry(char(*), char(*), char(*), fixed bin(35));
  319.     dcl get_temp_segment_ entry (char(*), ptr, fixed bin(35));
  320.     dcl get_wdir_   entry returns(char(168));
  321.     dcl hcs_$star_ entry (char(*), char(*), fixed bin(2), ptr, fixed bin, ptr, ptr, fixed bin(35));
  322.     dcl hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35));
  323.     dcl ioa_        entry options(variable);
  324.     dcl ioa_$nnl    entry options(variable);
  325.     dcl ioa_$rsnnl  entry options(variable);
  326.     dcl iox_$control   entry(ptr, char(*), ptr, fixed bin(35));
  327.     dcl iox_$get_line  entry(ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35));
  328.     dcl iox_$modes entry (ptr, char(*), char(*), fixed bin(35));
  329.     dcl send_message_silent entry options(variable);
  330.  
  331.  
  332.  
  333. /********************************************************************/
  334. /*  Kermit routines to handle actual file transfer                  */
  335. /********************************************************************/
  336.  
  337.     dcl kermit_$send entry (ptr, fixed bin(35), char(*) var);
  338.     dcl kermit_$receive entry (ptr, fixed bin(35), char(*) var);
  339.     dcl kermit_$server  entry (ptr, fixed bin(35), char(*) var);
  340.  
  341.  
  342.  
  343. /********************************************************************/
  344. /*  Builtin functions                                               */
  345. /********************************************************************/
  346.  
  347.     dcl null builtin;
  348.     dcl length builtin;
  349.     dcl time   builtin;
  350.  
  351.  
  352. /********************************************************************/
  353. /*  Conditions                                                      */
  354. /********************************************************************/
  355.  
  356.     dcl program_interrupt condition;
  357.  
  358.  
  359. /********************************************************************/
  360. /*  Initialize stuff                                                */
  361. /********************************************************************/
  362.  
  363.  
  364. if ^init then
  365. do;
  366. /********************************************************************/
  367. /*  Set up static area for protocol machine parameters.  This       */
  368. /*  area also serves as a communication channel between the         */
  369. /*  machine and the user interface.                                 */
  370. /********************************************************************/
  371.  
  372.    call get_temp_segment_ (prog, info_ptr, code);
  373.    if code ^= 0 then
  374.    do;
  375.      call com_err_ (code, prog, "Allocating segment for kermit info.");
  376.      return;
  377.      end;
  378.  
  379.    help_dir = kermit_info_dir;   /* Server got to know where its at too */
  380.    repeat_threshold = 4;
  381.    remote_quote = my_quote;
  382.    pad = 0;
  383.    rp_size = max_packet_size;
  384.    stimint = 20;
  385.    sp_size = max_packet_size;
  386.    pad_char = my_pad_char;
  387.    end_of_line = car_ret;
  388.    my_pad = 0;
  389.    delay_time = 8;
  390.    file_warning_sw = false;
  391.    r_eol = car_ret;
  392.    rtimint = 20;
  393.    init = true;
  394.    text_mode = true;
  395.    repeat_char = tilde;
  396.    repeat_allowed = true;
  397.    eight_bit_quote_char = blank;
  398.    eight_bit_quote = false;
  399.    allowed_ck_codes = "123";  /* Allowed checksum types */
  400.    orig_fc_ptr = addr(orig_framing_chars);
  401.    file_list_ptr = addr(files);
  402.    misc_symbol_ptr = addr(misc_symbols);
  403.    default_ck_code = 1;
  404.    max_try = 10;         /* Set up for maximum of 10 retries */
  405.    total_packet_trns = 0;  /* Status indicators */
  406.    total_packet_rcvd = 0;
  407.    total_retry_count = 0;
  408.    last_file_transferred = "";
  409.    term_modes = "rawi,rawo,no_outp,8bit,^echoplex,crecho,lfecho,^replay," ||
  410.                 "^polite,^breakall,blk_xfer,force,ctl_char";
  411.    end;
  412.  
  413.  
  414. current_packet_no = 0;
  415. num_try = 0;
  416. num_files = 0;
  417. cur_file = 0;
  418. debug_sw = false;
  419.  
  420. failures = 0;
  421. files_trns = 0;
  422. files_rcvd = 0;
  423.  
  424. /* Get and store terminal modes so terminal can be reset to init config. */
  425. tty_iocb = iox_$user_io;
  426. call iox_$modes(tty_iocb, " ", old_term_modes, code);
  427. if code ^= 0 then  /* Bad news, cant get terminal modes */
  428. do;
  429.    call com_err_ (code, prog, "getting terminal modes.");
  430.    return;
  431.    end;
  432.  
  433. call iox_$control (tty_iocb, "get_framing_chars", orig_fc_ptr, code);
  434. if code ^= 0  then /* Can't get block mode framing characters */
  435. do;
  436.    call com_err_ (code, prog, "getting block framing characters");
  437.    return;
  438.    end;
  439.  
  440. input_bfr_ptr = addr(input_buffer);
  441. default_dir = get_wdir_();
  442.  
  443. more_commands = true;
  444.  
  445.  
  446. /********************************************************************/
  447. /*  Main Procedure                                                  */
  448. /********************************************************************/
  449.  
  450. call cu_$arg_count(nargs);
  451. if nargs > 0 then
  452. do;
  453.    call cu_$arg_list_ptr (arg_lst_ptr);
  454.    call process_command_args (arg_lst_ptr, nargs);
  455.    end;
  456.  
  457. else
  458. do;
  459.    on program_interrupt goto mn_lp;
  460.    mn_lp:
  461.    do while(more_commands);
  462.       error = false;
  463.       call get_command(ret_structure);
  464.       call check_syntax(ret_structure);
  465.       if ^error then call exec_command(ret_structure);
  466.                 else call print_err_msg(error_code, err_msg);
  467.       end;
  468.    end;
  469.  
  470. if meter_enable then call meter_usage;
  471.  
  472. return;
  473.  
  474. process_command_args: proc (arg_list_ptr, nargs);
  475. /********************************************************************/
  476. /*  Process the multics command line args.  These can be -logout    */
  477. /*  for automatic logout on successful completion of the            */
  478. /*  operation, -server for server mode,                             */
  479. /*  -send <star_name> to send a group of files, -receive            */
  480. /*  [<path_name]> to receive a file, -set <option_list> to          */
  481. /*  set parameters or -status to print the status of  last trans.   */
  482. /********************************************************************/
  483.  
  484. /********************************************************************/
  485. /*>>>>>>>>>>>>>>>>>>>>>>>>>  Declarations  <<<<<<<<<<<<<<<<<<<<<<<<<*/
  486. /********************************************************************/
  487.  
  488.     dcl nargs fixed bin;
  489.     dcl indx fixed bin;
  490.     dcl cindx fixed bin;
  491.     dcl indx2 fixed bin;
  492.     dcl argl fixed bin(21);
  493.  
  494.     dcl num_options fixed bin static init(8) options(constant);
  495.     dcl com_arg(num_options) char(20) var init
  496.         ("-logout", "-server", "-receive", "-send", "-set", "-debug",
  497.           "-status", "-show");
  498.  
  499.     dcl err_msg char(100) var;
  500.     dcl set_str char(200) var;
  501.  
  502.     dcl file_str char(200) var;
  503.     dcl arg char(argl) based(argp);
  504.  
  505.     dcl arg_list_ptr ptr;
  506.     dcl argp ptr;
  507.  
  508.  
  509.     dcl found bit(1);
  510.     dcl required bit(1) init(true);
  511.     dcl auto_logout bit(1) init(false);
  512.     dcl server_mode bit(1) init(false);
  513.     dcl receive     bit(1) init(false);
  514.     dcl send        bit(1) init(false);
  515.     dcl set         bit(1) init(false);
  516.     dcl show_stat   bit(1) init(false);
  517.     dcl show_parm   bit(1) init(false);
  518.  
  519.     dcl code fixed bin(35);
  520.  
  521.  
  522.  
  523.  
  524. /********************************************************************/
  525. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  526. /********************************************************************/
  527.  
  528. on program_interrupt goto end_it;
  529.  
  530. indx = 1;
  531. do while (indx ^> nargs);
  532.    call cu_$arg_ptr_rel (indx, argp, argl, code, arg_list_ptr);
  533.  
  534.    found = false;
  535.    cindx = 1;
  536.    do while (cindx ^> num_options  &  ^found);
  537.      if com_arg(cindx) = arg then found = true;
  538.                              else cindx = cindx + 1;
  539.      end;
  540.    goto case(cindx);
  541.  
  542.    case(1): /* -logout */
  543.             auto_logout = true;
  544.             goto endcase;
  545.  
  546.    case(2): /* -server */
  547.             server_mode = true;
  548.             goto endcase;
  549.  
  550.    case(3): /* -receive [<path_name>] */
  551.             receive = true;
  552.             call cu_$arg_ptr_rel (indx+1, argp, argl, code, arg_list_ptr);
  553.             if code ^= 0 then file_str = ""; /* Nothing else on line */
  554.                          else file_str = arg;
  555.             if substr(file_str,1,1) = "-" then file_str = ""; /* Oops ctrl arg */
  556.                        else indx = indx + 1;
  557.             file_str = rtrim(file_str);
  558.             call check_filenames(file_str, ^required, num_files, files.names, code, err_msg);
  559.             if num_files > 1  |  code ^= 0  then
  560.             do;
  561.               call com_err_ (code, prog, err_msg);
  562.               return;
  563.               end;
  564.             cur_file = num_files;  /* 0 or 1 */
  565.             goto endcase;
  566.  
  567.    case(4): /* -send <star_name> */
  568.             send = true;
  569.             indx = indx + 1;
  570.             call cu_$arg_ptr_rel (indx, argp, argl, code, arg_list_ptr);
  571.             if code ^= 0 then
  572.             do;
  573.               call com_err_ (0, prog, "Missing file name.");
  574.               return;
  575.               end;
  576.             file_str = arg;
  577.             call check_filenames (file_str, required, num_files, files.names, code, err_msg);
  578.             if code ^= 0 then
  579.             do;
  580.               call com_err_ (code, prog, err_msg);
  581.               return;
  582.               end;
  583.             cur_file = 1;  /* First in list */
  584.             goto endcase;
  585.  
  586.  
  587.    case(5): /* -set <option_list> */
  588.             set_str = null_str;
  589.             do indx2 = indx+1 to nargs;
  590.               call cu_$arg_ptr_rel (indx2, argp, argl, code, arg_list_ptr);
  591.               set_str = set_str || arg || blank;
  592.               end;
  593.             call handle_set_args (set_str, nargs-indx, code, err_msg);
  594.             if code ^= 0 then
  595.             do;
  596.               call com_err_ (code, prog, err_msg);
  597.               return;
  598.               end;
  599.             set = true;
  600.             indx = nargs;
  601.             goto endcase;
  602.  
  603.    case(6): /* Debug */
  604.             debug_sw = true;
  605.             goto endcase;
  606.  
  607.    case(7): /* -status */
  608.             show_stat = true;
  609.             goto endcase;
  610.  
  611.    case(8): /* -show */
  612.             show_parm = true;
  613.             goto endcase;
  614.  
  615.    case(9): /* Bad control arg */
  616.             call com_err_ (error_table_$bad_arg, prog, arg);
  617.             return;
  618.  
  619.    endcase:
  620.    indx = indx + 1;
  621.    end;
  622.  
  623. /********************************************************************/
  624. /*  Make sure only one of send or receive specified.                */
  625. /********************************************************************/
  626. if ^send & ^receive & ^server_mode & ^set  &  ^show_stat & ^show_parm  then
  627. do;
  628.    call com_err_ (0, prog, "You must specify either -send <path>, -receive [<path>] or -server");
  629.    return;
  630.    end;
  631.  
  632. if send & receive  & ^server_mode then
  633. do;
  634.    call com_err_ (0, prog, "You can send, or receive, but not both at once.");
  635.    return;
  636.    end;
  637.  
  638. if (send | receive) & server_mode then
  639. do;
  640.    call com_err_ (0, prog, "Server mode is not compatible with send or receive args.");
  641.    return;
  642.    end;
  643.  
  644. /********************************************************************/
  645. /*  Actual transfer                                                 */
  646. /********************************************************************/
  647.  
  648. if server_mode then
  649. do;
  650.    call kermit_$server (info_ptr, code, err_msg);
  651.    server_used = true;
  652.    end;
  653.  
  654. else
  655. if send then
  656. do;
  657.    call kermit_$send (info_ptr, code, err_msg);
  658.    end;
  659.  
  660. else
  661. if receive then
  662. do;
  663.    call kermit_$receive (info_ptr, code, err_msg);
  664.    end;
  665.  
  666. else
  667. do;
  668.    if show_stat then call disp_status;
  669.    if show_parm then call display_parms(12);
  670.    end;
  671.  
  672. if code = 0  &  auto_logout then
  673. /********************************************************************/
  674. /*  Logout if specified and no errors in transmission.              */
  675. /********************************************************************/
  676. do;
  677.    call exec_com("logout");
  678.    end;
  679.  
  680. if code ^= 0 then
  681. do;
  682.    call com_err_ (code, prog, err_msg);
  683.    end;
  684.  
  685. end_it:
  686. call add_in_totals;  /* Keep track of usage */
  687. return;
  688. end process_command_args;
  689.  
  690. handle_set_args: proc(set_str, nargs, code, error_msg);
  691. /********************************************************************/
  692. /*  This procedure parses the set command arguments and executes    */
  693. /*  the requests                                                    */
  694. /*  It operates by reformatting the control args to look like set   */
  695. /*  commands typed in the request loop.  In this way the same       */
  696. /*  routines can be used to check and execute them as in the        */
  697. /*  request loop.                                                   */
  698. /********************************************************************/
  699.  
  700.     dcl set_str char(*) var;
  701.     dcl error_msg char(*) var;
  702.  
  703.     dcl item char(200) var;
  704.     dcl orig_item char(200) var;
  705.     dcl found bit(1);
  706.     dcl indx fixed bin;
  707.  
  708.     dcl set_option(13) char(15) var init (
  709.         "SEND", "RECEIVE", "REC", "DELAY", "FILE-WARNING", "FW",
  710.         "TRACE", "DIR", "TEXT", "CHECKTYPE", "PARITY", "REPEAT", "MODES");
  711.     dcl string_indx(13) fixed bin init (
  712.          0,      0,          0,     1,       2,             2,
  713.          3,      4,          5,     6,         7,         8,         9);
  714.     dcl set char(3) static init("set");
  715.  
  716.     dcl op_code fixed bin;
  717.  
  718.     dcl code fixed bin(35);
  719.     dcl nargs fixed bin;
  720.  
  721.     dcl com_string(9) char(200) var init((9)(1)"");
  722.  
  723.     dcl send_item fixed bin init(0);
  724.     dcl rec_item fixed bin init(0);
  725.  
  726.     dcl send_str(nargs) char(20) var;  /* Worst case size */
  727.     dcl rec_str(nargs) char(20) var;
  728.  
  729. /*=================  Begin ret_structure.incl.pl1  <<<<<<<<<<<<<<<<<*/
  730.  
  731.     dcl 1 ret_structure,
  732.           2 line char(255) var,
  733.           2 more_commands bit(1),
  734.           2 command_code fixed bin,
  735.           2 error bit(1),
  736.           2 error_code fixed bin(35),
  737.           2 err_msg char(255) var,
  738.           2 type fixed bin,
  739.           2 parm fixed bin,
  740.           2 parm_val fixed bin;
  741.     
  742. /*==================  End ret_structure.incl.pl1  <<<<<<<<<<<<<<<<<<*/
  743.  
  744.  
  745.  
  746. /********************************************************************/
  747. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  748. /********************************************************************/
  749. /********************************************************************/
  750. /*  Segregate various parms into separate variables                 */
  751. /********************************************************************/
  752.  
  753. code = 0;
  754.  
  755. if nargs < 2 then
  756. do;
  757.    code = error_table_$noarg;
  758.    error_msg = "-set requires at least two parameters.";
  759.    return;
  760.    end;
  761.  
  762.  
  763. do while(length(set_str) > 0  &  code = 0);
  764.  
  765.    call get_item(set_str, item);
  766.    orig_item = item;
  767.    item = translate(item, big, sml);
  768.  
  769.    found = false;
  770.    do indx = 1 to dim(set_option,1) while(^found);
  771.      if set_option(indx) = item then
  772.      do;
  773.        found = true;
  774.        op_code = indx;
  775.        end;
  776.      end;
  777.  
  778.    if ^found  &  op_code = 0 then op_code = dim(set_option,1)+1;
  779.    goto case(op_code);
  780.  
  781.  
  782.    case(1): /* send */
  783.             /* Normally I hate null thens, but this appears to be the easiest */
  784.             /* way to handle this  problem.  This allows things of the sort   */
  785.             /* -set send <args..> receive <args..> send <args>                */
  786.             /* Ive only included this to avoid complaints if I hadn't         */
  787.             if item = set_option(1) & send_item > 0  then;
  788.             else do;
  789.               send_item = send_item + 1;
  790.               send_str(send_item) = item;
  791.               end;
  792.             goto endcase;
  793.  
  794.    case(2): /* receive */
  795.    case(3): /* rec */
  796.             /* See comment above. */
  797.             if (item = set_option(2) | item = set_option(3)) & rec_item > 0 then;
  798.             else do;
  799.               rec_item = rec_item + 1;
  800.               rec_str(rec_item) = item;
  801.               end;
  802.             goto endcase;
  803.  
  804.    case(4): /* delay */          case(5): /* file warning */
  805.    case(6): /* fw */             case(7): /* trace */
  806.    case(8): /* dir */            case(9): /* text */
  807.    case(10): /* checktype */     case(11): /* parity */
  808.    case(12): /* repeat */        case(13): /* modes */
  809.              com_string(string_indx(op_code))
  810.                 = com_string(string_indx(op_code)) || orig_item || blank;
  811.              goto endcase;
  812.  
  813.    case(14): /* Unrecognized keyword */
  814.             code = error_table_$bad_arg;
  815.             error_msg = orig_item;
  816.             goto endcase;
  817.  
  818.    endcase: end;
  819.  
  820. if code ^= 0 then return;  /* Bail out at this point */
  821.  
  822. /********************************************************************/
  823. /*  Perform syntax check and execute options                        */
  824. /********************************************************************/
  825.  
  826. ret_structure.error = false;
  827.  
  828. /********************************************************************/
  829. /*  First syntax check.  Execute if options ok.                     */
  830. /********************************************************************/
  831.  
  832. do indx = 1 to 9;
  833.    if com_string(indx) ^= null_str then
  834.    do;
  835.      line = set || blank || com_string(indx);
  836.      line = rtrim(line);
  837.      call check_syntax (ret_structure);
  838.      if error then
  839.      do;
  840.        code = error_table_$bad_arg;
  841.        error_msg = com_string(indx);
  842.        return;
  843.        end;
  844.      call exec_command (ret_structure);
  845.      end;
  846.    end;
  847.  
  848.  
  849.  
  850. /********************************************************************/
  851. /*  Send and Receive options require special processing since       */
  852. /*  they may contain a list that must be parsed out properly.  A    */
  853. /*  subroutine handles this.                                        */
  854. /********************************************************************/
  855.  
  856. if rec_item > 0 then
  857. do;
  858.    call process_parms (rec_str, rec_item, code, error_msg);
  859.    if code ^= 0 then return;
  860.    end;
  861.  
  862. if send_item > 0 then
  863. do;
  864.    call process_parms (send_str, send_item, code, error_msg);
  865.    if code ^= 0 then return;
  866.    end;
  867.  
  868. /********************************************************************/
  869. /*  All finished.                                                   */
  870. /********************************************************************/
  871.  
  872. return;
  873.  
  874. process_parms: proc (string, num, code, error_msg); /* Int to handle_set_args */
  875. /********************************************************************/
  876. /*  Process pairs of send or receive options                        */
  877. /********************************************************************/
  878.  
  879.     dcl string(*) char(*) var;
  880.     dcl num fixed bin;
  881.     dcl code fixed bin(35);
  882.     dcl error_msg char(*) var;
  883.     dcl prefix char(30) var;
  884.     dcl indx fixed bin;
  885.  
  886. /*=================  Begin ret_structure.incl.pl1  <<<<<<<<<<<<<<<<<*/
  887.  
  888.     dcl 1 ret_structure,
  889.           2 line char(255) var,
  890.           2 more_commands bit(1),
  891.           2 command_code fixed bin,
  892.           2 error bit(1),
  893.           2 error_code fixed bin(35),
  894.           2 err_msg char(255) var,
  895.           2 type fixed bin,
  896.           2 parm fixed bin,
  897.           2 parm_val fixed bin;
  898.     
  899. /*==================  End ret_structure.incl.pl1  <<<<<<<<<<<<<<<<<<*/
  900.  
  901.  
  902.  
  903. /********************************************************************/
  904. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  905. /********************************************************************/
  906.  
  907. if num < 3 then
  908. do;
  909.    code = error_table_$noarg;
  910.    do indx = 1 to num;
  911.      error_msg = error_msg || string(indx) || blank;
  912.      end;
  913.    return;
  914.    end;
  915.  
  916. ret_structure.error = false;
  917. ret_structure.parm = 0;
  918. ret_structure.parm_val = 0;
  919.  
  920. prefix = set || blank || string(1) || blank;
  921. indx = 2;
  922.  
  923. do while (indx ^> num);
  924.    /* Send pairs of opitons over */
  925.    line = prefix || string(indx) || blank;
  926.    indx = indx + 1;
  927.    if indx > num then
  928.    do;
  929.      code = error_table_$noarg;
  930.      error_msg = string (indx-1);
  931.      return;
  932.      end;
  933.  
  934.    line = line || string (indx);
  935.    call check_syntax (ret_structure);
  936.  
  937.    if error then
  938.    do;
  939.      code = error_table_$bad_arg;
  940.      error_msg = string(indx-1) || blank || string(indx);
  941.      return;
  942.      end;
  943.  
  944.    call exec_command (ret_structure);
  945.    if error then
  946.    do;
  947.      code = error_table_$bad_arg;
  948.      error_msg = string(indx-1) || blank || string(indx);
  949.      return;
  950.      end;
  951.  
  952.    indx = indx + 1;
  953.    end;
  954.  
  955. /********************************************************************/
  956. /*  All options now covered.                                        */
  957. /********************************************************************/
  958.  
  959. return;
  960. end process_parms;
  961. end handle_set_args;
  962.  
  963.  
  964.  
  965. get_command: proc(ret_structure);
  966. /********************************************************************/
  967. /*  Read a command from the terminal and put it into the comm       */
  968. /*  structure.                                                      */
  969. /********************************************************************/
  970.  
  971. /*=================  Begin ret_structure.incl.pl1  <<<<<<<<<<<<<<<<<*/
  972.  
  973.     dcl 1 ret_structure,
  974.           2 line char(255) var,
  975.           2 more_commands bit(1),
  976.           2 command_code fixed bin,
  977.           2 error bit(1),
  978.           2 error_code fixed bin(35),
  979.           2 err_msg char(255) var,
  980.           2 type fixed bin,
  981.           2 parm fixed bin,
  982.           2 parm_val fixed bin;
  983.     
  984. /*==================  End ret_structure.incl.pl1  <<<<<<<<<<<<<<<<<<*/
  985.  
  986.  
  987.     dcl prompt char(16) static options(constant) init("Kermit-Multics> ");
  988.  
  989. call read_term (prompt, line);
  990.  
  991. return;
  992. end get_command;
  993.  
  994.  
  995.  
  996.  
  997. read_term: proc (prompt, line);
  998. /********************************************************************/
  999. /*  This procedure handles the direct io to and from the terminal   */
  1000. /********************************************************************/
  1001.  
  1002.     dcl prompt char(*);
  1003.     dcl line char(*) var;
  1004.  
  1005. call ioa_$nnl(prompt);
  1006. call iox_$get_line (tty_iocb, input_bfr_ptr, input_bfr_len, cur_inpt_bfr_len, code);
  1007. line = substr(input_buffer,1,cur_inpt_bfr_len-1);
  1008.  
  1009.  
  1010. return;
  1011. end read_term;
  1012.  
  1013. check_syntax: proc(ret_structure);
  1014. /********************************************************************/
  1015. /*  Take line apart and check its syntax.  Set pieces into          */
  1016. /*  ret_structure.                                                  */
  1017. /********************************************************************/
  1018.  
  1019.  
  1020. /********************************************************************/
  1021. /*>>>>>>>>>>>>>>>>>>>>>>>>>  Declarations  <<<<<<<<<<<<<<<<<<<<<<<<<*/
  1022. /********************************************************************/
  1023.  
  1024. /*=================  Begin ret_structure.incl.pl1  <<<<<<<<<<<<<<<<<*/
  1025.  
  1026.     dcl 1 ret_structure,
  1027.           2 line char(255) var,
  1028.           2 more_commands bit(1),
  1029.           2 command_code fixed bin,
  1030.           2 error bit(1),
  1031.           2 error_code fixed bin(35),
  1032.           2 err_msg char(255) var,
  1033.           2 type fixed bin,
  1034.           2 parm fixed bin,
  1035.           2 parm_val fixed bin;
  1036.     
  1037. /*==================  End ret_structure.incl.pl1  <<<<<<<<<<<<<<<<<<*/
  1038.  
  1039.  
  1040.     dcl str char(20);
  1041.     dcl t_line char(255) var;
  1042.     dcl item   char(255) var;
  1043.     dcl non_trans_item char(255) var;
  1044.  
  1045.     dcl command(16) char(20) var init (
  1046.         "SEND", "RECEIVE", "HELP", "?", "EXIT", "QUIT", "Q", "SET", "SHOW",
  1047.         "EXEC", "E", "..", "STATUS", "DEBUG", "SERVER", ".");
  1048.  
  1049.     dcl set_types(13) char(15) var init
  1050.         ("SEND", "RECEIVE", "REC", "DELAY", "FILE-WARNING", "FW",
  1051.          "TRACE", "DIR", "TEXT", "CHECKTYPE", "REPEAT", "PARITY", "MODES");
  1052.  
  1053.     dcl set_type_code(13) fixed bin init
  1054.         (1,        2,        2,      3,       4,              4,
  1055.          5,        6,        7,       8,         9,       10,        11);
  1056.  
  1057.  
  1058.     dcl option(8) char(20) var init (
  1059.         "PACKET-LENGTH", "PADDING", "PADCHAR", "TIMEOUT",
  1060.         "END-OF-LINE", "QUOTE", "ON", "OFF");
  1061.  
  1062.     dcl found bit(1) init(false);
  1063.     dcl required bit(1) init(true);
  1064.  
  1065.     dcl indx fixed bin;
  1066.  
  1067.     dcl delay_type        fixed bin static options(constant) init(3);
  1068.     dcl dir_type          fixed bin static options(constant) init(6);
  1069.     dcl check_type        fixed bin static options(constant) init(8);
  1070.     dcl all_type          fixed bin static options(constant) init(12);
  1071.  
  1072.     dcl send_code    fixed bin static options(constant) init(1);
  1073.     dcl receive_code fixed bin static options(constant) init(2);
  1074.     dcl stop_code    fixed bin static options(constant) init(3);
  1075.     dcl set_code     fixed bin static options(constant) init(4);
  1076.     dcl show_code    fixed bin static options(constant) init(5);
  1077.     dcl help_code    fixed bin static options(constant) init(6);
  1078.     dcl exec_code    fixed bin static options(constant) init(7);
  1079.     dcl status_code  fixed bin static options(constant) init(8);
  1080.     dcl null_command fixed bin static options(constant) init(9);
  1081.     dcl debug_code   fixed bin static options(constant) init(10);
  1082.     dcl server_code  fixed bin static options(constant) init(11);
  1083.     dcl id_code      fixed bin static options(constant) init(12);
  1084.  
  1085. /********************************************************************/
  1086. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  1087. /********************************************************************/
  1088. if line || blank = blank then
  1089. do;
  1090.    command_code = null_command;
  1091.    return;
  1092.    end;
  1093.  
  1094. t_line = line;
  1095. if length(t_line)>2 then 
  1096.   if substr(t_line,1,2) = ".." then t_line = ".. " || substr(t_line,3);
  1097.   /* Allow ..command type of thing */
  1098.  
  1099. call get_item(t_line, item);
  1100. item = translate(item,big,sml);
  1101. do indx = 1 to dim(command,1) while(^found);
  1102.    if command(indx) = item then
  1103.    do;
  1104.      found = true;
  1105.      command_code = indx;
  1106.      end;
  1107.    end;
  1108.  
  1109. if ^found then
  1110. do;
  1111.    error = true;
  1112.    error_code = bad_command;
  1113.    return;
  1114.    end;
  1115. goto case(command_code);
  1116.  
  1117. case(1)  : /* Send files down to micro */
  1118.            call check_filenames(t_line, required, num_files, files.names, code, err_msg);
  1119.            if code ^= 0 then
  1120.            do;
  1121.              error = true;
  1122.              error_code = code;
  1123.              end;
  1124.            else
  1125.            do;
  1126.              command_code = send_code;
  1127.              end;
  1128.            cur_file = 1;
  1129.            goto endcase;
  1130.  
  1131. case(2)  : /* Receive files from micro */
  1132.            call check_filenames(t_line, ^required, num_files, files.names, code, err_msg);
  1133.            if num_files > 1  |  code ^= 0 then
  1134.            do;
  1135.              error = true;
  1136.              if code ^= 0 then error_code = code;
  1137.              else error_code = bad_file_spec;
  1138.              end;
  1139.            else
  1140.              command_code = receive_code;
  1141.              cur_file = num_files;  /* Will be a 0 or 1 */
  1142.            goto endcase;
  1143.  
  1144.  
  1145. case(3)  :
  1146. case(4)  : /* Help comamnd */
  1147.            found = false;
  1148.            t_line = translate(t_line, big, sml);
  1149.            do indx = 1 to dim(command,1) while(^found);
  1150.              if command(indx) = t_line then
  1151.              do;
  1152.                found = true;
  1153.                parm = indx;
  1154.                end;
  1155.              end;
  1156.            if ^found then
  1157.            do;
  1158.              if t_line = "" then parm = help_code;
  1159.              else
  1160.              do;
  1161.                error = true;
  1162.                error_code = bad_help_option;
  1163.                end;
  1164.              end;
  1165.            command_code = help_code;
  1166.            goto endcase;
  1167.  
  1168.  
  1169. case(5)  :
  1170. case(6)  :
  1171. case(7)  :  /* Exit or Quit */
  1172.             if t_line ^= "" then
  1173.             do;
  1174.               error = true;
  1175.               error_code = bad_syntax;
  1176.               end;
  1177.             else command_code = stop_code;
  1178.             goto endcase;
  1179.  
  1180.  
  1181. case(8)  : /* Set Parameters */
  1182.            command_code = set_code;
  1183.            call parse_set_parms (t_line, ret_structure);
  1184.            goto endcase;
  1185.  
  1186. case(9)  : /* Show Parameter values */
  1187.            t_line = translate(t_line,big,sml);
  1188.            if t_line = "" then type = all_type;
  1189.            else
  1190.            do;
  1191.              found = false;
  1192.              do indx = 1 to dim(set_types,1) while(^found);
  1193.                if set_types(indx) = t_line then
  1194.                do;
  1195.                  found = true;
  1196.                  type = set_type_code(indx);
  1197.                  end;
  1198.                end;
  1199.              if ^found then
  1200.              do;
  1201.                error = true;
  1202.                error_code = bad_show_spec;
  1203.                end;
  1204.              end;
  1205.            command_code = show_code;
  1206.            goto endcase;
  1207.  
  1208. case(10) :
  1209. case(11) :
  1210. case(12) : /* Send a line to Multics */
  1211.            command_code = exec_code;
  1212.            line = t_line;
  1213.            goto endcase;
  1214.  
  1215. case(13) : /* Show the current status of transmission (error or complete) */
  1216.            command_code = status_code;
  1217.            goto endcase;
  1218.  
  1219. case(14) : /* Debug switch - on or off */
  1220.           command_code = debug_code;
  1221.           found = false;
  1222.           parm = 0;
  1223.           do indx = 7 to dim(option,1) while(^found); /* On or off only */
  1224.              if option(indx) = t_line then
  1225.              do;
  1226.                parm = indx;
  1227.                found = true;
  1228.                end;
  1229.              end;
  1230.           if ^found then
  1231.           do;
  1232.             error = true;
  1233.             error_code = bad_syntax;
  1234.             end;
  1235.           goto endcase;
  1236.  
  1237. case(15) : /* Turn on server mode */
  1238.            command_code = server_code;
  1239.            goto endcase;
  1240.  
  1241. case(16) : /* Identify myself */
  1242.            command_code = id_code;
  1243.            goto endcase;
  1244.  
  1245. endcase: return;
  1246. end check_syntax;
  1247.  
  1248. parse_set_parms: proc (t_line, ret_structure);
  1249. /********************************************************************/
  1250. /*  Parse the set arguments                                         */
  1251. /********************************************************************/
  1252.  
  1253.     dcl t_line char(*) var;
  1254.  
  1255. /*=================  Begin ret_structure.incl.pl1  <<<<<<<<<<<<<<<<<*/
  1256.  
  1257.     dcl 1 ret_structure,
  1258.           2 line char(255) var,
  1259.           2 more_commands bit(1),
  1260.           2 command_code fixed bin,
  1261.           2 error bit(1),
  1262.           2 error_code fixed bin(35),
  1263.           2 err_msg char(255) var,
  1264.           2 type fixed bin,
  1265.           2 parm fixed bin,
  1266.           2 parm_val fixed bin;
  1267.     
  1268. /*==================  End ret_structure.incl.pl1  <<<<<<<<<<<<<<<<<<*/
  1269.  
  1270.  
  1271.  
  1272.     dcl option(8) char(20) var init (
  1273.         "PACKET-LENGTH", "PADDING", "PADCHAR", "TIMEOUT",
  1274.         "END-OF-LINE", "QUOTE", "ON", "OFF");
  1275.  
  1276.     dcl set_types(13) char(15) var init
  1277.         ("SEND", "RECEIVE", "REC", "DELAY", "FILE-WARNING", "FW",
  1278.          "TRACE", "DIR", "TEXT", "CHECKTYPE", "REPEAT", "PARITY", "MODES");
  1279.     dcl set_type_code(13) fixed bin init
  1280.         (1,        2,        2,      3,       4,              4,
  1281.          5,        6,        7,       8,   9,   10,   11);
  1282.  
  1283.  
  1284.     dcl found bit(1);
  1285.     dcl item char(255) var;
  1286.     dcl indx fixed bin;
  1287.  
  1288.     dcl on  char(5) static init("ON");
  1289.     dcl off char(5) static init("OFF");
  1290.  
  1291.  
  1292.  
  1293. /********************************************************************/
  1294. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  1295. /********************************************************************/
  1296.  
  1297. call get_item (t_line, item);
  1298. item = translate(item, big, sml);
  1299.  
  1300. found = false;
  1301. indx = 1;
  1302. do while (indx ^> dim(set_types, 1)  &  ^found);
  1303.    if set_types(indx) = item then
  1304.   do;
  1305.      found = true;
  1306.      type = set_type_code(indx);
  1307.      end;
  1308.    else indx = indx + 1;
  1309.    end;
  1310.  
  1311. if ^found then
  1312. do;
  1313.    error = true;
  1314.    error_code = bad_set_spec;
  1315.    return;
  1316.    end;
  1317.  
  1318. goto case(type);
  1319.  
  1320.  
  1321. case(1):  /* Send */
  1322. case(2):  /* Receive, Rec */
  1323.           call get_item (t_line, item);
  1324.           item = translate(item, big, sml);
  1325.           found = false;
  1326.           indx = 1;
  1327.           do while (indx ^> dim(option,1)  &  ^found);
  1328.             if option(indx) = item then
  1329.             do;
  1330.               parm = indx;
  1331.               found = true;
  1332.               end;
  1333.             else indx = indx + 1;
  1334.             end;
  1335.  
  1336.          if ^found then
  1337.          do;
  1338.            error = true;
  1339.            error_code = bad_set_parm;
  1340.            return;
  1341.            end;
  1342.  
  1343.          if t_line = "" then
  1344.          do;
  1345.            error = true;
  1346.            error_code = mssng_set_parm_val;
  1347.            return;
  1348.            end;
  1349.  
  1350.         goto pcase(parm);
  1351.  
  1352.         pcase(1): /* packet-length */
  1353.         pcase(2): /* padding */
  1354.         pcase(4): /* timeout */     /*** Decimal args ***/
  1355.                   if verify (t_line, numbers) > 0 then
  1356.                   do;
  1357.                     error = true;
  1358.                     error_code = non_numeric_val;
  1359.                     return;
  1360.                     end;
  1361.                   parm_val = fixed(t_line);
  1362.                   goto end_pcase;
  1363.  
  1364.         pcase(3): /* padchar */
  1365.         pcase(5): /* end of line */
  1366.         pcase(6): /* quote char */   /* Octal arg */
  1367.                   parm_val = cv_oct_check_(rtrim(t_line), code);
  1368.                   if code ^= 0 | (code=0 & parm_val>127) then
  1369.                   do;
  1370.                     error = true;
  1371.                     error_code = bad_octal_val;
  1372.                     return;
  1373.                     end;
  1374.                   goto end_pcase;
  1375.  
  1376.         pcase(7): /* on */
  1377.         pcase(8): /* off */
  1378.                   error = true;
  1379.                   error_code = bad_set_parm;
  1380.                   return;
  1381.  
  1382.         end_pcase: goto endcase;
  1383.  
  1384.  
  1385. case(3):  /* Delay n */
  1386.           if t_line = "" | verify (t_line, numbers) > 0 then
  1387.           do;
  1388.             error = true;
  1389.             error_code = non_numeric_val;
  1390.             return;
  1391.             end;
  1392.           parm_val = fixed(t_line);
  1393.           goto endcase;
  1394.  
  1395. case(4):  /* File warning */
  1396. case(5):  /* Trace        */
  1397. case(7):  /* Text         */
  1398. case(9):  /* Repeat       */
  1399. case(10): /* Parity       */
  1400.           item = translate (t_line, big, sml);
  1401.           if item ^= on  &  item ^= off then
  1402.           do;
  1403.             error = true;
  1404.             error_code = bad_set_parm;
  1405.             return;
  1406.             end;
  1407.           if option(8) = item then parm=8;
  1408.           if option(7) = item then parm=7;
  1409.           goto endcase;
  1410.  
  1411. case(8):  /* Checktype */
  1412.           if t_line ^= "1"  &  t_line ^= "2"  &  t_line ^= "3" then
  1413.           do;
  1414.             error = true;
  1415.             error_code = bad_set_parm;
  1416.             return;
  1417.             end;
  1418.           parm_val = fixed(t_line);
  1419.           goto endcase;
  1420.  
  1421. case(6):  /* Dir */
  1422. case(11): /* Modes */
  1423.           if t_line = "" | index(t_line, blank)> 0 then
  1424.           do;
  1425.             error = true;
  1426.             error_code = bad_set_parm;
  1427.             return;
  1428.             end;
  1429.           line = t_line;
  1430.           goto endcase;
  1431.  
  1432. endcase: return;
  1433.  
  1434. end parse_set_parms;
  1435.  
  1436.  
  1437. get_item: proc(line, item);
  1438. /********************************************************************/
  1439. /*  Chop off an item in line and return it.                         */
  1440. /********************************************************************/
  1441.  
  1442.     dcl line char(*) var;
  1443.     dcl item char(*) var;
  1444.  
  1445.     dcl indx fixed bin;
  1446.  
  1447. /********************************************************************/
  1448. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  1449. /********************************************************************/
  1450.  
  1451. line = ltrim(line);
  1452. line = line || blank;
  1453. indx = index(line,blank);
  1454. item = substr(line,1,indx);
  1455. item = rtrim(item);
  1456.  
  1457. if indx < length(line) then line = substr(line,indx+1);
  1458.                        else line = "";
  1459. line = rtrim(line);
  1460. return;
  1461. end get_item;
  1462.  
  1463.  
  1464. check_filenames: proc (list, must_be_there, num_files, file_list, code, error_msg);
  1465. /********************************************************************/
  1466. /*  Decode list into separate file names.  List may be a            */
  1467. /*  starname or a single file name.                                 */
  1468. /********************************************************************/
  1469.  
  1470.     dcl list char(*) var;
  1471.     dcl num_files fixed bin;
  1472.     dcl 1 file_list(*),
  1473.           2 dir char(*),
  1474.           2 entry char(*);
  1475.  
  1476.     dcl must_be_there bit(1);
  1477.     dcl code fixed bin(35);
  1478.     dcl error_msg char(*) var;
  1479.  
  1480.     dcl t_list char(80);
  1481.     dcl dirname char(168);
  1482.     dcl entryname char(32);
  1483.  
  1484.     dcl resp char(10) var;
  1485.  
  1486.     dcl seg_ptr ptr;
  1487.     dcl entry_ptr ptr;
  1488.     dcl name_ptr ptr;
  1489.  
  1490.     dcl count fixed bin;
  1491.     dcl indx  fixed bin;
  1492.     dcl dir_seg_type fixed bin(2);
  1493.     dcl seg_type bit(2) init("01"b) static;
  1494.  
  1495.     dcl 1 entries(count) aligned based(entry_ptr),
  1496.           (2 type bit(2),
  1497.            2 nnames fixed bin(15),
  1498.            2 nindex fixed bin(17)) unaligned;
  1499.  
  1500.     dcl names (sum(nnames(*))) char(32) aligned based(name_ptr);
  1501.  
  1502.     dcl name_area area(10000);
  1503.  
  1504.  
  1505.  
  1506. /********************************************************************/
  1507. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  1508. /********************************************************************/
  1509.  
  1510. code = 0;
  1511. error_msg = "";
  1512. num_files = 0;
  1513. if list = "" then   /* Null name list */
  1514. do;
  1515.    if must_be_there then
  1516.    do;
  1517.      code = error_table_$noarg;
  1518.      error_msg = "File name required.";
  1519.      end;
  1520.    return;
  1521.    end;
  1522.  
  1523. t_list = list;
  1524. if index(t_list,">") > 0  |  index(t_list,"<") > 0 then
  1525.    call expand_pathname_ (t_list, dirname, entryname, code);
  1526. else
  1527.  do;
  1528.    dirname = default_dir;
  1529.    entryname = rtrim(t_list);
  1530.    end;
  1531.  
  1532. if code ^= 0 then
  1533. do;
  1534.    error_msg = list;
  1535.    return;
  1536.    end;
  1537.  
  1538. call check_star_name_$entry (entryname, code);
  1539.  
  1540. if code = 0 then /* Not a starname, single entry */
  1541. do;
  1542.    /* Check to make sure that if present, it is a seg and not a dir and */
  1543.    /* that it is present when we expect it (ie during send)             */
  1544.    call hcs_$status_minf (dirname, entryname, 1, dir_seg_type, 0, code);
  1545.    if code = error_table_$noentry & must_be_there then
  1546.    do;
  1547.      error_msg = "The segment must exist to send it.";
  1548.      return;
  1549.      end;
  1550.    else
  1551.    if code ^= 0  &  code ^= error_table_$noentry then
  1552.    do;
  1553.      error_msg = rtrim(dirname) || ">" || rtrim(entryname);
  1554.      return;
  1555.      end;
  1556.    else
  1557.    if dir_seg_type = 2 then /* Cant do this to a dir */
  1558.    do;
  1559.      error_msg = rtrim(dirname) || ">" || rtrim(entryname);
  1560.      code = error_table_$dirseg;
  1561.      return;
  1562.      end;
  1563.    if file_warning_sw & ^must_be_there & code = 0 then
  1564.    do;
  1565.      call ioa_("WARNING: file ^a>^a already exists and will be overwritten.",
  1566.                 dirname, entryname);
  1567.  
  1568.      /* command_query_$yes_no, except this works on non-Multics machines */
  1569.      resp = " ";
  1570.      do while(resp ^= "Y"  &  resp ^= "N");
  1571.        call read_term ("Do you want to continue? (y or n):", resp);
  1572.        resp = translate(resp, big, sml);
  1573.        end;
  1574.  
  1575.      if resp ^= "Y" then
  1576.      do;
  1577.        code = error_table_$action_not_performed;
  1578.        error_msg = "";
  1579.        return;
  1580.        end;
  1581.      end;
  1582.    code = 0;  /* May be noentry */
  1583.    num_files = 1;
  1584.    file_list(1).dir = dirname;
  1585.    file_list(1).entry = entryname;
  1586.    return;
  1587.    end;
  1588.  
  1589. if code ^= 1  &  code ^= 2 then
  1590. do;
  1591.    /* Bad starname */
  1592.    code = error_table_$badstar;
  1593.    error_msg = list;
  1594.    return;
  1595.    end;
  1596.  
  1597. /********************************************************************/
  1598. /*  Have a good starname, expand it                                 */
  1599. /********************************************************************/
  1600.  
  1601. seg_ptr = addr(name_area);
  1602.  
  1603. call hcs_$star_ (dirname, entryname, 2, seg_ptr, count, entry_ptr, name_ptr, code);
  1604. if code ^= 0 then
  1605. do;
  1606.    error_msg = list;
  1607.    return;
  1608.    end;
  1609.  
  1610. do indx = 1 to count;
  1611.    if type(indx) = seg_type then
  1612.    do;
  1613.      num_files = num_files + 1;
  1614.      dir(num_files) = dirname;
  1615.      entry(num_files) = names(nindex(indx));
  1616.      end;
  1617.    end;
  1618.  
  1619. if num_files = 0 then
  1620. do;
  1621.    code = error_table_$dirseg;
  1622.    error_msg = "Star name does not match any segments.";
  1623.    end;
  1624.  
  1625.  
  1626. return;
  1627. end check_filenames;
  1628.  
  1629. print_err_msg: proc(err_code, err_msg);
  1630. /********************************************************************/
  1631. /*  Print an error message on the terminal.                         */
  1632. /********************************************************************/
  1633.  
  1634.     dcl err_code fixed bin(35);
  1635.     dcl err_msg char(*) var;
  1636.  
  1637.     dcl errors (29) char(80) var static init (
  1638.         "Unrecognized command.  No action performed.",
  1639.         "Bad file specification.",
  1640.         "Unrecognized help option.",
  1641.         "Bad parameter on set command.",
  1642.         "Bad specification on set command.",
  1643.         "Bad parameter on show command.",
  1644.         "Improper syntax.",
  1645.         "Missing parameter on set command.",
  1646.         "Missing parameter value on set command.",
  1647.         "Non-numeric value where number should be.",
  1648.         "Bad value for octal argument.",
  1649.         "Bad directory name.",
  1650.         "That directory does not exist.",
  1651.         /* Reserved for future syntax errors */
  1652.         "", "", "", "", "", "", "",
  1653.         "Too many retries",
  1654.         "Wrong packet type.",
  1655.         "Entered an unexpected state.",
  1656.         "Wrong packet number.",
  1657.         "Error on host CPU.",
  1658.         "File missing for send request.",
  1659.         "Record quota overflow; insufficient space available.",
  1660.         "File already exists; transmission aborted.",
  1661.         "Can't get segment for transmission.");
  1662.  
  1663. if err_code < 100 then
  1664.   call ioa_("Kermit ERROR: "|| errors(err_code));
  1665. else
  1666.   call com_err_ (err_code,"Kermit ERROR", err_msg);
  1667. return;
  1668. end print_err_msg;
  1669.  
  1670.  
  1671.  
  1672. exec_command: proc(ret_structure);
  1673. /********************************************************************/
  1674. /*  This procedure is a case statement for the execution of         */
  1675. /*  kermit commands.                                                */
  1676. /********************************************************************/
  1677.  
  1678. /*=================  Begin ret_structure.incl.pl1  <<<<<<<<<<<<<<<<<*/
  1679.  
  1680.     dcl 1 ret_structure,
  1681.           2 line char(255) var,
  1682.           2 more_commands bit(1),
  1683.           2 command_code fixed bin,
  1684.           2 error bit(1),
  1685.           2 error_code fixed bin(35),
  1686.           2 err_msg char(255) var,
  1687.           2 type fixed bin,
  1688.           2 parm fixed bin,
  1689.           2 parm_val fixed bin;
  1690.     
  1691. /*==================  End ret_structure.incl.pl1  <<<<<<<<<<<<<<<<<<*/
  1692.  
  1693.  
  1694.     dcl code fixed bin(35) init(0);
  1695.     dcl err_msg char(100) var;
  1696.  
  1697. /********************************************************************/
  1698. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  1699. /********************************************************************/
  1700.  
  1701. goto case(command_code);  /* Errors won't get to here */
  1702.  
  1703. case(1) : /* Send file(s) down to micro */
  1704.           call zero_counters;
  1705.           call kermit_$send (info_ptr, code, err_msg);
  1706.           call add_in_totals;
  1707.           goto endcase;
  1708.  
  1709. case(2) : /* Receive file(s) from micro */
  1710.           call zero_counters;
  1711.           call kermit_$receive (info_ptr, code, err_msg);
  1712.           call add_in_totals;
  1713.           goto endcase;
  1714.  
  1715. case(3) : /* Quit */
  1716.           more_commands = false;
  1717.           goto endcase;
  1718.  
  1719. case(4) : /* Set command */
  1720.           call set_options(type, parm, parm_val, line);
  1721.           goto endcase;
  1722.  
  1723. case(5) : /* Show current settings */
  1724.           call display_parms(type);
  1725.           goto endcase;
  1726.  
  1727. case(6) : /* Help */
  1728.           call help_rtn (line, code);
  1729.           goto endcase;
  1730.  
  1731. case(7) : /* Pass a line through to the command processor */
  1732.           call exec_com (line);
  1733.           goto endcase;
  1734.  
  1735. case(8) : /* Show status of last transmission */
  1736.           call disp_status;
  1737.           goto endcase;
  1738.  
  1739. case(9) : /* Null command */
  1740.           goto endcase;
  1741.  
  1742. case(10): /* Debug */
  1743.           call set_debug (parm);
  1744.           goto endcase;
  1745.  
  1746. case(11): /* Server */
  1747.           call zero_counters;
  1748.           call kermit_$server (info_ptr, code, err_msg);
  1749.           server_used = true;
  1750.           call add_in_totals;
  1751.           goto endcase;
  1752.  
  1753. case(12): /* Identification */
  1754.           call ioa_ ("Multics - kermit   Version ^a of ^a.",
  1755.                       current_version, version_date);
  1756.           goto endcase;
  1757.  
  1758. endcase: if code ^= 0 then /* But some might come back from the protocol */
  1759.          do;               /* machine, so let the user know.             */
  1760.            call com_err_ (code, prog, err_msg);
  1761.            end;
  1762.          return;
  1763. end exec_command;
  1764.  
  1765.  
  1766. add_in_totals: proc;
  1767. /********************************************************************/
  1768. /*  Add in totals for metering purposes.                            */
  1769. /********************************************************************/
  1770.  
  1771. cum_pkt_rcvd = cum_pkt_rcvd + total_packet_rcvd;
  1772. cum_pkt_trns = cum_pkt_trns + total_packet_trns;
  1773. cum_pkt_retry = cum_pkt_retry + total_retry_count;
  1774.  
  1775. cum_files_rcvd = cum_files_rcvd + files_rcvd;
  1776. cum_files_trns = cum_files_trns + files_trns;
  1777. cum_failures = cum_failures + failures;
  1778.  
  1779. return;
  1780. end add_in_totals;
  1781.  
  1782.  
  1783. zero_counters: proc;
  1784. /********************************************************************/
  1785. /* Reset kermit_ meters                                             */
  1786. /********************************************************************/
  1787.  
  1788. files_rcvd = 0;
  1789. files_trns = 0;
  1790. failures = 0;
  1791.  
  1792. total_packet_trns = 0;
  1793. total_packet_rcvd = 0;
  1794. total_retry_count = 0;
  1795.  
  1796. return;
  1797. end zero_counters;
  1798.  
  1799.  
  1800.  
  1801. set_debug: proc (val);
  1802. /********************************************************************/
  1803. /*  Turn the debug switch on or off.  This is in a separate         */
  1804. /*  procedure from set_options because the command syntax is        */
  1805. /*  different.                                                      */
  1806. /********************************************************************/
  1807.  
  1808.     dcl val fixed bin;
  1809.  
  1810. if val = 7 then
  1811. do;
  1812.    debug_sw = true;
  1813.    call ioa_ ("Debug enabled.");
  1814.    call ioa_ ("WARNING: Linkage faults will occur unless kermit_db_ is available.");
  1815.    end;
  1816. else debug_sw = false;
  1817.  
  1818. return;
  1819. end set_debug;
  1820.  
  1821.  
  1822. set_options: proc(type, parm, parm_val, str);
  1823. /********************************************************************/
  1824. /*  Set global variables according to commands                      */
  1825. /********************************************************************/
  1826.  
  1827.     dcl type fixed bin;
  1828.     dcl parm fixed bin;
  1829.     dcl parm_val fixed bin;
  1830.  
  1831.     dcl error bit(1) init(false);
  1832.     dcl error_code fixed bin(35);
  1833.  
  1834.     dcl send fixed bin static init(1);
  1835.     dcl on   fixed bin static init(7);
  1836.  
  1837.     dcl char char(1);
  1838.  
  1839.     dcl str char(*) var;
  1840.     dcl f_str char(length(str));
  1841.     dcl dirname char(168);
  1842.     dcl entryname char(32);
  1843.  
  1844.     dcl dir_seg_type fixed bin(2);
  1845.  
  1846.  
  1847.  
  1848.  
  1849. /********************************************************************/
  1850. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  1851. /********************************************************************/
  1852.  
  1853. goto case(type);
  1854.  
  1855. case(1): /* Send     */
  1856. case(2): /* Receive  */
  1857.          if parm > 6 then
  1858.          do;
  1859.            error = true;
  1860.            error_code = bad_set_parm;
  1861.            end;
  1862.          else
  1863.          do;
  1864.            goto pcase(parm);
  1865.  
  1866.            pcase(1): /* Packet length */
  1867.                      if parm_val < 5  |  parm_val > max_packet_size then
  1868.                      do;
  1869.                        error = true;
  1870.                        error_code = bad_set_parm;
  1871.                        end;
  1872.                      else
  1873.                      if type = send then sp_size = parm_val;
  1874.                                     else rp_size = parm_val;
  1875.                      goto end_pcase;
  1876.  
  1877.            pcase(2): /* Number of padding characters */
  1878.                      if type = send then my_pad = parm_val;
  1879.                                     else pad = parm_val;
  1880.                      goto end_pcase;
  1881.  
  1882.            pcase(3): /* Padding character */
  1883.                      char = substr(collate(),parm_val+1,1);
  1884.                      if type = send then my_pad_char = parm_val;
  1885.                                     else pad_char = parm_val;
  1886.                      goto end_pcase;
  1887.  
  1888.            pcase(4): /* Timeout interval */
  1889.                      if type = send then stimint = parm_val;
  1890.                                     else rtimint = parm_val;
  1891.                      goto end_pcase;
  1892.  
  1893.            pcase(5): /* End of line terminator */
  1894.                      if type = send then end_of_line = parm_val;
  1895.                                     else r_eol = parm_val;
  1896.                      goto end_pcase;
  1897.  
  1898.            pcase(6): /* Quote character */
  1899.                      char = substr(collate(),parm_val+1,1);
  1900.                      if type = send then my_quote = char;
  1901.                      else
  1902.                      do;
  1903.                        error = true;
  1904.                        error_code = bad_set_parm;
  1905.                        end;
  1906.  
  1907.            end_pcase: ;
  1908.            end;
  1909.         goto endcase;
  1910.  
  1911.  
  1912. case(3): /* Delay */
  1913.          delay_time = parm_val;
  1914.          goto endcase;
  1915.  
  1916. case(4): /* File warning */
  1917.          if parm < 7 then
  1918.          do;
  1919.            error = true;
  1920.            error_code = bad_set_parm;
  1921.            end;
  1922.          else
  1923.          if parm = on then file_warning_sw = true;
  1924.                       else file_warning_sw = false;
  1925.          goto endcase;
  1926.  
  1927. case(5): /* Trace facility */
  1928.          if parm < 7 then
  1929.          do;
  1930.            error = true;
  1931.            error_code = bad_set_parm;
  1932.            end;
  1933.          else
  1934.          if parm = on then trace_sw = true;
  1935.                       else trace_sw = false;
  1936.          goto endcase;
  1937.  
  1938. case(6): /* Change the default working directory */
  1939.          if translate(str,big,sml) = "-WD" then
  1940.          do;
  1941.            default_dir = get_wdir_();
  1942.            end;
  1943.          else
  1944.          do;
  1945.            f_str = str;
  1946.            call expand_pathname_(f_str, dirname, entryname, error_code);
  1947.            if error_code ^= 0 then
  1948.            do;
  1949.              error = true;
  1950.              error_code = bad_dir_name;
  1951.              end;
  1952.            else
  1953.            do;
  1954.              call hcs_$status_minf (dirname, entryname, 1, dir_seg_type, 0, error_code);
  1955.              if error_code ^= 0 then
  1956.              do;
  1957.                error = true;
  1958.                error_code = bad_dir_name;
  1959.                end;
  1960.              else
  1961.              if dir_seg_type ^= 2 then
  1962.              do;
  1963.                error = true;
  1964.                error_code = not_dir_name;
  1965.                end;
  1966.              else
  1967.              do;
  1968.                default_dir = rtrim(dirname) || ">" || rtrim(entryname);
  1969.                end;
  1970.              end;
  1971.            end;
  1972.          goto endcase;
  1973.  
  1974.  
  1975. case(7): /* Text/Binary mode */
  1976.          if parm < 7 then
  1977.          do;
  1978.            error = true;
  1979.            error_code = bad_set_parm;
  1980.            end;
  1981.          else
  1982.          if parm = on then text_mode = true;
  1983.                       else text_mode = false;
  1984.          goto endcase;
  1985.  
  1986. case(8): /* Check code value */
  1987.          if parm_val > length(allowed_ck_codes)  |
  1988.             parm_val = 0 then /*Assumes impl. in order */
  1989.          do;
  1990.            error = true;
  1991.            error_code = bad_set_parm;  /* Maybe a better error message?   */
  1992.            end;
  1993.          else
  1994.            default_ck_code = parm_val;
  1995.          goto endcase;
  1996.  
  1997. case(9): /* Turn repeat capability on or off */
  1998.          if parm < 7 then
  1999.          do;
  2000.            error = true;
  2001.            error_code = bad_set_parm;
  2002.            end;
  2003.          else
  2004.          if parm = on then repeat_allowed = true;
  2005.                       else repeat_allowed = false;
  2006.          goto endcase;
  2007.  
  2008. case(10): /* Parity */
  2009.           if parm < 7 then
  2010.           do;
  2011.             error = true;
  2012.             error_code = bad_set_parm;
  2013.             end;
  2014.           else
  2015.           if parm = on then eight_bit_quote = true;
  2016.                        else eight_bit_quote = false;
  2017.           goto endcase;
  2018.  
  2019. case(11): /* Modes setting */
  2020.           f_str = str;
  2021.           call iox_$modes (tty_iocb, f_str, "", code);
  2022.           error_code = code;
  2023.           call iox_$modes (tty_iocb, old_term_modes, "", code);
  2024.           if error_code ^= 0 then error = true;
  2025.              else term_modes = f_str;
  2026.           goto endcase;
  2027.  
  2028.  
  2029. endcase: ;
  2030.  
  2031. if error then call print_err_msg(error_code, "");
  2032.  
  2033. return;
  2034. end set_options;
  2035.  
  2036. display_parms: proc(type);
  2037. /********************************************************************/
  2038. /*  Display various parameters on command.                          */
  2039. /********************************************************************/
  2040.  
  2041.     dcl type fixed bin;
  2042.  
  2043.  
  2044. /********************************************************************/
  2045. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  2046. /********************************************************************/
  2047.  
  2048.  
  2049. goto case(type);
  2050.  
  2051. case(1): /* Send parameters */
  2052.          call disp_send;
  2053.          goto endcase;
  2054.  
  2055. case(2): /* Receive parameters */
  2056.          call disp_receive;
  2057.          goto endcase;
  2058.  
  2059. case(3): /* Delay time */
  2060.          call disp_delay;
  2061.          goto endcase;
  2062.  
  2063. case(4): /* File warning */
  2064.          call disp_fw;
  2065.          goto endcase;
  2066.  
  2067. case(5): /* Display Trace status */
  2068.          call disp_trace;
  2069.          goto endcase;
  2070.  
  2071. case(6): /* Display default directory */
  2072.          call disp_dir;
  2073.          goto endcase;
  2074.  
  2075. case(7): /* Mode */
  2076.          call disp_mode;
  2077.          goto endcase;
  2078.  
  2079. case(8): /* Type of checksum */
  2080.          call disp_ckcd;
  2081.          goto endcase;
  2082.  
  2083. case(9): /* Repeat */
  2084.          call disp_rpt;
  2085.          goto endcase;
  2086.  
  2087. case(10): /* Parity */
  2088.          call disp_par;
  2089.          goto endcase;
  2090.  
  2091. case(11): /* Modes string */
  2092.          call disp_modes;
  2093.          goto endcase;
  2094.  
  2095. case(12): /* Everything */
  2096.          call disp_send;
  2097.          call disp_receive;
  2098.          call disp_mode;
  2099.          call disp_delay;
  2100.          call disp_fw;
  2101.          call disp_dir;
  2102.          call disp_ckcd;
  2103.          goto endcase;
  2104.  
  2105. endcase: return;
  2106. end display_parms;
  2107.  
  2108.  
  2109. disp_send: proc;
  2110. /********************************************************************/
  2111. /*  Display send parameters                                         */
  2112. /********************************************************************/
  2113.  
  2114. call ioa_("");
  2115. call ioa_("(Set Parm Name)      Send Parameters");
  2116. call ioa_("------------------------------------------------");
  2117. call ioa_("(PACKET-LENGTH) Packet size: ^d (decimal)",sp_size);
  2118. call ioa_("(PADDING)       Number of padding characters: ^d",my_pad);
  2119. call ioa_("(PADCHAR)       Pad character: ^o (octal)", my_pad_char);
  2120. call ioa_("(TIMEOUT)       Timeout interval: ^d seconds",stimint);
  2121. call ioa_("(END-OF-LINE)   End of line character: ^o (octal)",end_of_line);
  2122. call ioa_("(QUOTE)         Quote character: ^o (octal)", index(collate(),my_quote)-1);
  2123.  
  2124. return;
  2125. end disp_send;
  2126.  
  2127.  
  2128.  
  2129. disp_receive: proc;
  2130. /********************************************************************/
  2131. /*  Display similar parameters for receive.                         */
  2132. /********************************************************************/
  2133.  
  2134.  
  2135. call ioa_("");
  2136. call ioa_("(Set Parm Name)        Receive Parameters");
  2137. call ioa_("-----------------------------------------------");
  2138. call ioa_("(PACKET-LENGTH)  Packet size: ^d (decimal)",rp_size);
  2139. call ioa_("(PADDING)        Number of padding characters: ^d",pad);
  2140. call ioa_("(PADCHAR)        Pad character: ^o (octal)",pad_char);
  2141. call ioa_("(TIMEOUT)        Timeout interval: ^d seconds",rtimint);
  2142. call ioa_("(END-OF-LINE)    End of line character: ^o (octal)",r_eol);
  2143. call ioa_("(QUOTE)          Quote character: ^o (octal)",index(collate(),remote_quote)-1);
  2144. return;
  2145. end disp_receive;
  2146.  
  2147.  
  2148. disp_delay: proc;
  2149.  
  2150. call ioa_ ("");
  2151. call ioa_("Initial delay: ^d seconds.", delay_time);
  2152. return;
  2153. end disp_delay;
  2154.  
  2155.  
  2156.  
  2157. disp_fw: proc;
  2158.  
  2159. call ioa_ ("");
  2160. if file_warning_sw then call ioa_("File warning switch is ON.");
  2161.                    else call ioa_("File warning switch is OFF.");
  2162. return;
  2163. end disp_fw;
  2164.  
  2165.  
  2166. disp_trace: proc;
  2167. call ioa_("");
  2168. if trace_sw then call ioa_("The trace facility is ON.");
  2169.             else call ioa_("The trace facility is OFF.");
  2170. return;
  2171. end disp_trace;
  2172.  
  2173. disp_dir: proc;
  2174. call ioa_("");
  2175. call ioa_("The default directory is: " || rtrim(default_dir));
  2176. return;
  2177. end disp_dir;
  2178.  
  2179. disp_rpt: proc;
  2180.  
  2181. call ioa_();
  2182. if repeat_allowed then call ioa_("Repeat quoting will be requested.");
  2183.                   else call ioa_("Repeat quoting will not be done.");
  2184. return;
  2185. end disp_rpt;
  2186.  
  2187.  
  2188. disp_par: proc;
  2189.  
  2190. call ioa_();
  2191. if eight_bit_quote then call ioa_("Parity quoting will be requested.");
  2192.                    else call ioa_("Parity quoting will not be done.");
  2193. return;
  2194. end disp_par;
  2195.  
  2196.  
  2197.  
  2198. disp_modes: proc;
  2199.  
  2200. call ioa_();
  2201. call ioa_ ("Modes string: ^a", term_modes);
  2202. return;
  2203. end disp_modes;
  2204.  
  2205.  
  2206. disp_mode: proc;
  2207.  
  2208.    if text_mode then call ioa_("Text mode is in effect.");
  2209.                  else call ioa_("Binary mode is in effect.");
  2210. return;
  2211. end disp_mode;
  2212.  
  2213. disp_ckcd: proc;
  2214.  
  2215.     dcl msg(3) char(50) var static init (
  2216.         "TYPE 1  Single byte checksum - Kermit standard",
  2217.         "TYPE 2  Double byte checksum",
  2218.         "TYPE 3  CRC checksum");
  2219.  
  2220. call ioa_ (msg(default_ck_code));
  2221. return;
  2222. end disp_ckcd;
  2223.  
  2224.  
  2225. disp_status: proc;
  2226. /********************************************************************/
  2227. /*  Display the status of the last transmission                     */
  2228. /********************************************************************/
  2229.  
  2230.     dcl msgs(4) char(80) var static init (
  2231.         "Too many retries on last packet; transmission aborted.",
  2232.         "Wrong packet type on transmitted packet.",
  2233.         "Unexpected program state entered; transmission aborted.",
  2234.         "Wrong packet number on transmitted packet.");
  2235.  
  2236.     dcl indx fixed bin;
  2237.  
  2238.  
  2239.  
  2240. if return_code = 0 then
  2241. do;
  2242.    if last_file_transferred = "" then call ioa_ ("No previous transfer.");
  2243.    else
  2244.    do;
  2245.      call ioa_ ("Transmission ending with ^a was successful.", last_file_transferred);
  2246.      call ioa_ ("^d total packets were transferred with ^d retries.",
  2247.                  total_packet_trns+total_packet_rcvd, total_retry_count);
  2248.      end;
  2249.    end;
  2250.  
  2251. else
  2252. do;
  2253.    call ioa_ ("Transmission ending with ^a was not successful.", last_file_transferred);
  2254.    if return_code < 100 then
  2255.    do;
  2256.      indx = return_code - 20;
  2257.      call ioa_ (msgs(indx));
  2258.      end;
  2259.    else
  2260.      call com_err_$suppress_name (return_code, prog);
  2261.    end;
  2262.  
  2263. return;
  2264. end disp_status;
  2265.  
  2266. exec_com: proc(line);
  2267. /********************************************************************/
  2268. /*  Pass line along to the command processor.                       */
  2269. /********************************************************************/
  2270.  
  2271.     dcl line char(*) var;
  2272.     dcl com_line char(length(line)) aligned init(line);
  2273.  
  2274. /********************************************************************/
  2275. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  2276. /********************************************************************/
  2277.  
  2278. call cu_$cp(addr(com_line), length(line), code);
  2279.  
  2280. return;
  2281. end exec_com;
  2282.  
  2283.  
  2284. help_rtn: proc(line, code);
  2285. /********************************************************************/
  2286. /*  This routine serves as an interface to the help subsystem.      */
  2287. /*  In its current draft version, it wil not intercept some         */
  2288. /*  error conditions raised by help.                                */
  2289. /********************************************************************/
  2290.  
  2291. /********************************************************************/
  2292. /*>>>>>>>>>>>>>>>>>>>>>>>>>  Declarations  <<<<<<<<<<<<<<<<<<<<<<<<<*/
  2293. /********************************************************************/
  2294.  
  2295. /*    BEGIN OF:    help_args_.incl.pl1          *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
  2296.  
  2297.     /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
  2298.     /*                                    */
  2299.     /* Name:   help_args_.incl.pl1                        */
  2300.     /*                                    */
  2301.     /* This include file declares the structure used by the help command and other subsystems    */
  2302.     /* to pass info segment selection and printing control information to the help_        */
  2303.     /* subroutine.  This based structure is NEVER allocated.  Instead, the caller of help_    */
  2304.     /* must call help_$init to get a pointer to a temporary segment which is used for    */
  2305.     /* storage for the structure.  The structure contains 5 arrays with refer extents,    /*
  2306.     /* allowing complete freedom in the numbers of selection values given.  Typically, the    */
  2307.     /* caller fills in the arrays at the top of the structure first, growing the arrays    */
  2308.     /* as each new element is added.  After each array is filled, the caller begins filling    */
  2309.     /* in the next array.  Note that, on return from help_$init, all of the arrays have 0    */
  2310.     /* extents, except that the search_dirs array contains the list of directories to be    */
  2311.     /* searched in to find info segments, as defined by the search facility.  The caller    */
  2312.     /* may of course change or replace these search directories.            */
  2313.     /*                                    */
  2314.     /* A legend describing the variable naming convention follows.            */
  2315.     /*                                    */
  2316.     /*   STARTING LETTER    STANDS FOR                    */
  2317.     /*    P        pointer to                    */
  2318.     /*    L        length of                        */
  2319.     /*    D        descriptor of                    */
  2320.     /*    S        switch                        */
  2321.     /*    V        version                        */
  2322.     /*                                    */
  2323.     /* Status                                    */
  2324.     /*                                    */
  2325.     /* 0) Created:   October, 1978    by Gary Dixon                    */
  2326.     /*                                    */
  2327.     /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
  2328.  
  2329.      dcl    1 help_args aligned based (Phelp_args),        /* help's input arguments.            */
  2330.       2 version        fixed bin,    /* = 1, currently. Use Vhelp_args_1.        */
  2331.                         /*    (set by help_$init, checked by caller)    */
  2332.       2 Sctl,                    /* control argument switches.            */
  2333.                         /*    (SET BY CALLER OF help_)        */
  2334.        (3 he_only,                /*   print only a heading, nothing else.    */
  2335.         3 he_pn,                /*   when heading printed, include info pathname.    */
  2336.         3 he_info_name,                /*   when heading printed, include info_name.    */
  2337.         3 he_counts,                /*   when heading printed, include line counts.    */
  2338.                         /*   If none of the 3 switches above are set,    */
  2339.                         /*   then only info header is incl. in heading.    */
  2340.         3 title,                /*   -title                */
  2341.         3 scn,                /*   -section                */
  2342.         3 srh,                /*   -search                */
  2343.         3 bf,                    /*   -brief                */
  2344.         3 ca,                    /*   -control_arg                */
  2345.         3 ep,                    /*   -entry_point                */
  2346.         3 all)        bit(1) unal,    /*   -all                    */
  2347.         3 pad1        bit(25) unal,
  2348.       2 Nsearch_dirs        fixed bin,    /* number of info_segment (or other) search dirs.    */
  2349.                         /*    (set by help_$init, CALLER CAN CHANGE)    */
  2350.       2 Npaths        fixed bin,    /* number of info segment names.        */
  2351.                         /*    (SET BY CALLER OF help_)        */
  2352.       2 Ncas            fixed bin,    /* number of control arg names given with -ca    */
  2353.                         /*    (SET BY CALLER OF help_)        */
  2354.       2 Nscns            fixed bin,    /* number of section substrings.        */
  2355.                         /*    (SET BY CALLER OF help_)        */
  2356.       2 Nsrhs            fixed bin,    /* number of search strings.            */
  2357.                         /*    (SET BY CALLER OF help_)        */
  2358.       2 min_Lpgh        fixed bin,    /* minimum length of a paragraph.        */
  2359.                         /*    (set by help_$init, CALLER CAN CHANGE)    */
  2360.       2 max_Lpgh        fixed bin,    /* maximum lines in group of aggregated paragraphs*/
  2361.                         /* or in paragraphs constructed by help_.    */
  2362.                         /*    (set by help_$init, CALLER CAN CHANGE)    */
  2363.       2 Lspace_between_infos    fixed bin,    /* spaces inserted between infos when several    */
  2364.                         /* printed by one invocation.            */
  2365.                         /*    (set by help_$init, CALLER CAN CHANGE)    */
  2366.       2 min_date_time        fixed bin(71),    /* do not process infos modified before this date.*/
  2367.                         /*    (SET BY CALLER OF help_)        */
  2368.       2 pad2 (10)         fixed bin,    /* reserved for future expansion.        */
  2369.  
  2370.     /*        End of fixed-length part of the structure.                */
  2371.  
  2372.       2 search_dirs (0 refer (help_args.Nsearch_dirs))
  2373.                 char (168) unal,    /* directories help_ will look in to find info    */
  2374.                         /*   segments when relative paths (without < or >)*/
  2375.                         /*   are given.  When help_$init is called, the    */
  2376.                         /*   current search rules (from a search list of    */
  2377.                         /*   caller's choice) will be given here.  Caller    */
  2378.                         /*   may modify this list if desired before    */
  2379.                         /*   calling help_.                */
  2380.       2 path (0 refer (help_args.Npaths)),        /* names of sought info segments.        */
  2381.         3 value        char(425) varying,    /*   These are the args themselves, without    */
  2382.                             /*   processing by expand_pathname_, etc.    */
  2383.                         /*   Their length is length(path) + length("$")    */
  2384.                         /*   + length(entry_point_name).        */
  2385.                         /*   Note that entry_point_names can be 256 chars.*/
  2386.                         /*    (SET BY CALLER OF help_)        */
  2387.         3 info_name        char(32) unal,    /*   name of logical info to be printed.    */
  2388.                         /*    (SET BY CALLER OF help_)        */
  2389.                         /*   "" = help_ should set this to entry part    */
  2390.                         /*        of path.value, minus the suffix.    */
  2391.                         /*   other = logical info name not a name on the    */
  2392.                         /*        physical info segment.        */
  2393.         3 dir (1)        char(168) unal,    /*   dir part of a pathname (set by help_).    */
  2394.         3 ent            char(32) unal,    /*   ent part of name (set by help_).        */
  2395.         3 ep            char(32) varying,    /*   entry point part of name. (set by help_)    */
  2396.         3 code        fixed bin(35),    /*   error code while processing this path.    */
  2397.                         /*     (set by help_)            */
  2398.         3 S,                    /*   switches indicating path type.        */
  2399.          (4 pn_ctl_arg,                /*     -pn ctl given before this path.         */
  2400.                         /*         (SET BY CALLER OF help_)        */
  2401.           4 info_name_not_starname,        /*     caller-supplied path.info_name is not a    */
  2402.                         /*       star name, even if it has * or ? chars.    */
  2403.                         /*         (SET BY CALLER OF help_)        */
  2404.           4 less_greater,            /*     A < or > appears in path.value.        */
  2405.                         /*         (set by help_)            */
  2406.           4 starname_ent,            /*     on if ent is a starname.        */
  2407.                         /*    (set by help_)            */
  2408.           4 starname_info_name,            /*     on if info_name is a starname.        */
  2409.                         /*    (set by help_)            */
  2410.           4 separate_info_name)     bit(1) unal,    /*     on if info_name given by caller.        */
  2411.                         /*    (set by help_)            */
  2412.           4 pad3         bit(30) unal,
  2413.       2 ca (0 refer (help_args.Ncas))        /* the ctl_arg names, without leading - just as    */
  2414.                 char(32) varying,    /*   req'd by the -ca ctl_arg of help.        */
  2415.                         /*    (SET BY CALLER OF help_)        */
  2416.       2 scn (0 refer (help_args.Nscns))        /* substrings sought in section titles.        */
  2417.                 char(80) varying,    /*    (SET BY CALLER OF help_)        */
  2418.       2 srh (0 refer (help_args.Nsrhs))        /* search strings.                */
  2419.                 char(80) varying,    /*    (SET BY CALLER OF help_)        */
  2420.     Phelp_args        ptr,
  2421.     Vhelp_args_1        fixed bin int static options(constant) init(1);
  2422.  
  2423.      dcl    help_            entry (char(*), ptr, char(*), fixed bin, fixed bin(35)),
  2424.     help_$init        entry (char(*), char(*), char(*), fixed bin, ptr, fixed bin(35)),
  2425.     help_$term        entry (char(*), ptr, fixed bin(35));
  2426.  
  2427. /*    END OF:    help_args_.incl.pl1          *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
  2428.  
  2429.  
  2430.     dcl line char(*) var;
  2431.     dcl code fixed bin(35);
  2432.     dcl progress fixed bin;
  2433.     dcl t_line char(100) var;
  2434.  
  2435.  
  2436.  
  2437. /********************************************************************/
  2438. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  2439. /********************************************************************/
  2440.  
  2441. call help_$init (prog, "", "", Vhelp_args_1, Phelp_args, code);
  2442. if code ^= 0 then return;
  2443.  
  2444. Sctl.all = true;
  2445.  
  2446. if substr(line,1,1) = "?" then t_line = rtrim(substr(line||blank, 2));
  2447. else t_line = rtrim(substr(line||blank, 5));
  2448. t_line = ltrim(t_line);
  2449.  
  2450. if t_line = "" then t_line = prog;
  2451.  
  2452. Nsearch_dirs = 1;
  2453. search_dirs(1) = kermit_info_dir;
  2454. Npaths = 1;
  2455. path(1).value =  t_line;
  2456. path(1).info_name = " ";
  2457.  
  2458. call help_ (prog, Phelp_args, "k.info", progress, code);
  2459.  
  2460. call help_$term (prog, Phelp_args, (0));
  2461. code = 0;  /* help_ already has printed error msgs if any */
  2462.  
  2463. return;
  2464. end help_rtn;
  2465.  
  2466.  
  2467. meter_usage: proc;
  2468. /********************************************************************/
  2469. /*   If metering was enabled, send a message to the specified mail  */
  2470. /*   box with the particulars of this invokation of kermit.         */
  2471. /********************************************************************/
  2472.  
  2473.     dcl msg_string char(55);
  2474.     dcl len fixed bin(21);
  2475.     dcl server_ind char(1) init("R");
  2476.  
  2477.  
  2478. if cum_files_trns + cum_files_rcvd + cum_failures = 0 then return;  /* No transfers */
  2479.  
  2480.  
  2481. if server_used then server_ind = "S";
  2482.  
  2483. call ioa_$rsnnl ("^d TP   ^d RP   ^d RT   ^d FS   ^d FR   ^d FF", msg_string, len,
  2484.                   cum_pkt_trns, cum_pkt_rcvd, cum_pkt_retry, cum_files_trns,
  2485.                   cum_files_rcvd, cum_failures);
  2486. msg_string = rtrim(msg_string) || blank || server_ind;
  2487.  
  2488.  
  2489. call send_message_silent (kermit_mbx_ctl_arg, kermit_mbx, msg_string);
  2490. return;
  2491.  
  2492. end meter_usage;
  2493.  
  2494. end kermit;
  2495.