home *** CD-ROM | disk | FTP | other *** search
/ kermit.columbia.edu / kermit.columbia.edu.tar / kermit.columbia.edu / extra / mukmtp.pl1 < prev    next >
Text File  |  1988-08-16  |  126KB  |  3,643 lines
  1. kermit_: proc;
  2. /********************************************************************/
  3. /*  This is the kermit protocol machine.                            */
  4. /*                                                                  */
  5. /*  The kermit_ procedure contains all of the procedures to         */
  6. /*  handle packet transfer from the micro.  Major entry points      */
  7. /*  are send to send a file, receive to receive one or more         */
  8. /*  files and server to act as a kermit slave.                      */
  9. /********************************************************************/
  10.  
  11. /********************************************************************/
  12. /*>>>>>>>>>>>>>>>>>>>>>>>>>  Declarations  <<<<<<<<<<<<<<<<<<<<<<<<<*/
  13. /********************************************************************/
  14.  
  15.     dcl info_ptr ptr parameter;   /* Points to the structure below. */
  16.     dcl code fixed bin(35) parameter;
  17.     dcl err_msg char(*) var parameter;
  18.  
  19.  
  20. /********************************************************************/
  21. /*    Communications structure                                      */
  22. /********************************************************************/
  23.  
  24. /*==================  Begin kermit_info.incl.pl1  ==================*/
  25.  
  26.  
  27.     dcl 1 kermit_info based(info_ptr),
  28.           2 state      char(2),          /* Present state of automaton */
  29.           2 size       fixed bin,        /* Size of present data       */
  30.           2 send_parameters,
  31.             3 stimint     fixed bin(71),   /* Timeout for foreign host on sends */
  32.             3 sp_size    fixed bin,        /* Maximum send packet size */
  33.             3 pad        fixed bin,        /* How much padding to send */
  34.             3 pad_char   fixed bin,        /* Padding  character to send */
  35.             3 delay_time fixed bin(71),    /* Time to delay for sends     */
  36.             3 end_of_line fixed bin,       /* End-of-line to send */
  37.           2 receive_parameters,
  38.             3 rp_size    fixed bin,        /* Maximum receive packet size */
  39.             3 remote_quote  char(1),       /* Quote character, incomming data */
  40.             3 r_eol       fixed bin,       /* End-of-line to receive */
  41.             3 rtimint   fixed bin(71),     /* Timeout for host on receives */
  42.           2 max_try   fixed bin,         /* Times to retry a packet */
  43.           2 num_try   fixed bin,         /* Times this packet retried */
  44.           2 eight_bit_quote_char char(1),/* Char for quoting 8 bit stuff */
  45.           2 repeat_char  char(1),        /* CHar for flagging repeat sequences */
  46.           2 chktype fixed bin,           /* Type of check code to actually use */
  47.           2 current_packet_no fixed bin, /* Looking for msg number ... */
  48.           2 behavior_switches,
  49.             3 trace_sw bit(1),           /* Log packets to trace file   */
  50.             3 debug_sw bit(1),           /* Obtain packets from ext. proc */
  51.             3 eight_bit_quote bit(1),    /* Parity quoting allowed    */
  52.             3 repeat_allowed  bit(1),    /* Character compression allowed */
  53.             3 repeat_threshold fixed bin, /* Min # of chars to compress */
  54.             3 text_mode bit(1),          /* Type of files to send, init true */
  55.             3 file_warning_sw bit(1),    /* Overwrite file warning */
  56.           2 pointers,
  57.             3 file_list_ptr ptr,         /* Ptr to list of files          */
  58.             3 tty_iocb ptr,              /* Ptr to tty iocb for modes sw. */
  59.             3 input_bfr_ptr ptr,         /* Ptr to input buffer           */
  60.             3 orig_fc_ptr ptr,           /* Ptr to orig. framing chars    */
  61.             3 misc_symbol_ptr ptr,       /* Ptr to structure holding some symbls */
  62.           2 other_info,
  63.             3 default_dir char(168),     /* Default for send or receive  */
  64.             3 term_modes char(256),      /* To setup terminal for transfer */
  65.             3 old_term_modes char(512),  /* For restoring term on completion */
  66.             3 cur_file  fixed bin,       /* Current file pointer in list    */
  67.             3 allowed_ck_codes char(3),  /* Allowed error check codes        */
  68.             3 default_ck_code fixed bin, /* Type of check code to use by default */
  69.             3 help_dir char(168),        /* Help directory */
  70.           2 status_indicators,
  71.             3 return_code fixed bin(35),
  72.             3 total_packet_trns fixed bin,
  73.             3 total_packet_rcvd fixed bin,
  74.             3 total_retry_count  fixed bin,
  75.             3 files_rcvd fixed bin,
  76.             3 files_trns fixed bin,
  77.             3 failures   fixed bin,
  78.             3 last_file_transferred char(168); /* Name of last file */
  79.  
  80. /*===================  End kermit_info.incl.pl1  ===================*/
  81.  
  82.  
  83. /********************************************************************/
  84. /*  Constants                                                       */
  85. /********************************************************************/
  86.  
  87. /*===============  Begin control_constants.incl.pl1  ===============*/
  88.  
  89. /********************************************************************/
  90. /*  This structure avoids using embedded control characters in      */
  91. /*  the source. Multics characters are nine bits.                   */
  92. /********************************************************************/
  93.  
  94.  
  95.     dcl 1 binary_codes static options(constant) aligned,
  96.           2 bits_NULL bit(9) init("000000000"b),
  97.           2 bits_CR   bit(9) init("000001101"b),
  98.           2 bits_LF   bit(9) init("000001010"b),
  99.           2 bits_CTL_Z bit(9) init("000011010"b),
  100.           2 bits_SOH   bit(9) init("000000001"b),
  101.           2 bits_tilde bit(9) init("001111110"b);
  102.  
  103.     dcl 1 overlay_chars based(addr(binary_codes)) aligned,
  104.           2 NULL char(1),
  105.           2 CR   char(1),
  106.           2 LF   char(1),
  107.           2 CTL_Z char(1),
  108.           2 SOH   char(1),
  109.           2 tilde char(1);
  110.  
  111. /*================  End control_constants.incl.pl1  ================*/
  112.  
  113.  
  114.     dcl big   char(26) static options(constant)
  115.               init("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
  116.     dcl sml   char(26) static options(constant)
  117.               init("abcdefghijklmnopqrstuvwxyz");
  118.     dcl numbers char(10) static options(constant) init("0123456789");
  119.     dcl null_char   char(1) init(NULL);
  120.     dcl null_str    char(1) var static init("") options(constant);
  121.     dcl space       char(1) static init(" ") options(constant);
  122.     dcl colon       char(1) static init(":") options(constant);
  123.     dcl car_ret     fixed bin  static options(constant) init(13);
  124.     dcl false bit(1) static options(constant) init("0"b);
  125.     dcl blank char(1) static options(constant) init(" ");
  126.     dcl ampersand char(1) static options(constant) init("&");
  127.     dcl true  bit(1) static options(constant) init("1"b);
  128.  
  129.     dcl carraige_return char(1) init(CR);
  130.     dcl line_feed       char(1) init(LF);
  131.  
  132.  
  133.  
  134. /********************************************************************/
  135. /*  Symbols                                                         */
  136. /********************************************************************/
  137.  
  138. /*=================  Begin kermit_symbols.incl.pl1  ================*/
  139.  
  140.     dcl 1 misc_symbols based(misc_symbol_ptr),
  141.         2 max_packet_size  fixed bin,
  142.         2 my_quote     char(1),
  143.         2 my_pad       fixed bin,
  144.         2 my_pad_char fixed bin,
  145.         2 my_end_of_line fixed bin;
  146.  
  147. /*==================  End kermit_symbols.incl.pl1  =================*/
  148.  
  149.  
  150. /********************************************************************/
  151. /*  Allowed states for the packet automata                          */
  152. /********************************************************************/
  153.  
  154.     dcl abort_state         char(2) static options(constant) init("A");
  155.     dcl completed_state     char(2) static options(constant) init("C");
  156.     dcl send_init_state     char(2) static options(constant) init("SI");
  157.     dcl send_file_state     char(2) static options(constant) init("SF");
  158.     dcl send_data_state     char(2) static options(constant) init("SD");
  159.     dcl send_eof_state      char(2) static options(constant) init("SE");
  160.     dcl send_break_state    char(2) static options(constant) init("SB");
  161.     dcl receive_init_state  char(2) static options(constant) init("RI");
  162.     dcl receive_data_state  char(2) static options(constant) init("RD");
  163.     dcl receive_file_state  char(2) static options(constant) init("RF");
  164.     dcl server_state        char(2) static options(constant) init("SS");
  165.     dcl send_hdr_state      char(2) static options(constant) init("SH");
  166.  
  167. /********************************************************************/
  168. /*  Allowed packet types                                            */
  169. /********************************************************************/
  170.  
  171.     dcl file_type char(1)  static options(constant) init("F");
  172.     dcl data_type char(1)  static options(constant) init("D");
  173.     dcl eof_type char(1)   static options(constant) init("Z");
  174.     dcl break_type char(1) static options(constant) init("B");
  175.     dcl ack_type char(1)   static options(constant) init("Y");
  176.     dcl nack_type char(1)  static options(constant) init("N");
  177.     dcl send_type char(1)  static options(constant) init("S");
  178.     dcl error_type char(1) static options(constant) init("E");
  179.     dcl receive_init_type char(1) static options(constant) init("R");
  180.     dcl host_com_type     char(1) static options(constant) init("C");
  181.     dcl generic_type      char(1) static options(constant) init("G");
  182.     dcl text_hdr_type     char(1) static options(constant) init("X");
  183.     dcl info_type         char(1) static options(constant) init("I");
  184.  
  185.  
  186.     dcl last_char_sent char(1) var init("");  /* Flag for transmitting crlfs */
  187.     dcl last_char_received char(1) var; /* Flag for receiving same  */
  188.     dcl segment char(1000000) based(transmit_seg_ptr);  /* Info to send */
  189.     dcl transmit_seg_ptr ptr init(null());
  190.     dcl cur_character fixed bin(24);  /* Current character ptr */
  191.  
  192. /********************************************************************/
  193. /*  These are the terminal modes that kermit will attempt to        */
  194. /*  use.  These settings are nominal for connection to Multics      */
  195. /*  via an FNP through either a hard wired line or dial up (the     */
  196. /*  fnp requires  blk_xfer to handle the packet of characters       */
  197. /*  in the absense of xon-xoff protocols which are not supported    */
  198. /*  by the majority of kermits; there are also reports that the fnp */
  199. /*  does not handle xon-xoff well at 9600. Finally, even if it did  */
  200. /*  downward compatibility is still needed).                        */
  201. /*                                                                  */
  202. /*  The force mode will prevent error codes from arising in the     */
  203. /*  case of networks where some of these modes are not              */
  204. /*  appropriate.                                                    */
  205. /*                                                                  */
  206. /*  This information has been moved to the info structure so that   */
  207. /*  the user may change the default values.  It is left here as a   */
  208. /*  reminder on what happers on this end.                           */
  209. /********************************************************************/
  210.  
  211.  
  212. /*    dcl term_modes  char(256) static init("rawi,rawo,no_outp,8bit,^echoplex"||
  213. /*                        ",crecho,lfecho,^replay,^polite,^breakall,blk_xfer,force,ctl_char");
  214. */
  215.  
  216. /********************************************************************/
  217. /*  Error codes                                                     */
  218. /********************************************************************/
  219.  
  220.     dcl too_many_tries   fixed bin static options(constant) init(21);
  221.     dcl wrong_packet_type fixed bin static options(constant) init(22);
  222.     dcl unknown_state    fixed bin static options(constant) init(23);
  223.     dcl wrong_packet_no  fixed bin static options(constant) init(24);
  224.     dcl cpu_err          fixed bin static options(constant) init(25);
  225.     dcl no_file          fixed bin static options(constant) init(26);
  226.     dcl record_quota_ov  fixed bin static options(constant) init(27);
  227.     dcl file_overwrite   fixed bin static options(constant) init(28);
  228.     dcl cant_get_seg     fixed bin static options(constant) init(29);
  229.     dcl unknown_server_cmd fixed bin static options(constant) init(30);
  230.     dcl unknown_generic_cmd fixed bin static options(constant) init(31);
  231.  
  232.  
  233.  
  234. /********************************************************************/
  235. /*  Multics routines                                                */
  236. /********************************************************************/
  237.  
  238.     dcl continue_to_signal_ entry (fixed bin(35));
  239.     dcl cu_$cp entry (ptr, fixed bin(21), fixed bin(35));
  240.     dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35));
  241.     dcl get_pdir_ entry returns(char(168));
  242.     dcl get_temp_segment_ entry(char(*), ptr, fixed bin(35));
  243.     dcl get_wdir_ entry returns(char(168));
  244.     dcl hcs_$initiate_count entry (char(*), char(*), char(*), fixed bin(24),
  245.                                    fixed bin(1), ptr, fixed bin(35));
  246.     dcl hcs_$terminate_noname entry (ptr, fixed bin(35));
  247.     dcl ioa_        entry options(variable);
  248.     dcl ioa_$nnl    entry options(variable);
  249.     dcl iox_$control   entry(ptr, char(*), ptr, fixed bin(35));
  250.     dcl iox_$find_iocb entry(char(*), ptr, fixed bin(35));
  251.     dcl iox_$get_line  entry(ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35));
  252.     dcl iox_$modes entry (ptr, char(*), char(*), fixed bin(35));
  253.     dcl iox_$put_chars entry (ptr, ptr, fixed bin(21), fixed bin(35));
  254.     dcl release_temp_segment_ entry(char(*), ptr, fixed bin(35));
  255.     dcl timer_manager_$alarm_call entry (fixed bin(71), bit(2), entry);
  256.     dcl timer_manager_$reset_alarm_call entry (entry);
  257.     dcl timer_manager_$sleep entry (fixed bin(71), bit(2));
  258.     dcl unique_bits_ entry returns(bit(70));
  259.     dcl unique_chars_ entry(bit(*)) returns(char(15));
  260.  
  261. /********************************************************************/
  262. /*  Routines to handle on-line debugging through pipe               */
  263. /********************************************************************/
  264.  
  265.     dcl kermit_db_$get_packet entry (ptr, fixed bin(21), fixed bin(21),
  266.                                      fixed bin(71), bit(1));
  267.     dcl kermit_db_$send_packet entry (char(*) var);
  268.     dcl kermit_db_$init entry;
  269.     dcl kermit_db_$term entry;
  270.  
  271.  
  272. /********************************************************************/
  273. /*  Other variables                                                 */
  274. /********************************************************************/
  275.  
  276.     dcl return_lf bit(1) init(false);
  277.     dcl enable_ctl_quoting bit(1) init(true);
  278.     dcl eof_flag bit(1) init(false);
  279.     dcl input_bfr_len fixed bin(21) static init(100);
  280.     dcl cur_inpt_bfr_len fixed bin(21);
  281.     dcl input_buffer char(input_bfr_len) aligned based(input_bfr_ptr);
  282.     dcl output_iocb_ptr ptr;
  283.     dcl rel_secs_flag bit(2) static options(constant) init("11"b);
  284.     dcl seg_length fixed bin(24);  /* Number of CHARACTERS to send */
  285.     dcl trace_file file;
  286.  
  287.     dcl in_command bit(1) init(false); /* Used for server checksum types on succ. packets */
  288.     dcl status bit(1);
  289.     dcl indx fixed bin;
  290.  
  291.  
  292.     dcl server bit(1) init(false);  /* Turned on by server entry point */
  293.  
  294.     dcl 1 files based(file_list_ptr),
  295.           2 max_num_files fixed bin,
  296.           2 num_files fixed bin,
  297.           2 names (max_num_files),
  298.             3 dir char(168),
  299.             3 entry char(32);
  300.  
  301.     dcl 1 cur_file_name,
  302.           2 dir char(168),
  303.           2 entry char(32);
  304.  
  305. /********************************************************************/
  306. /*  Conditions                                                      */
  307. /********************************************************************/
  308.  
  309.     dcl quit condition;
  310.     dcl error condition;
  311.     dcl record_quota_overflow condition;
  312.  
  313.  
  314.  
  315. /********************************************************************/
  316. /*  Blck transfer framing character info structures.                */
  317. /********************************************************************/
  318.  
  319.     dcl 1 orig_framing_chars based(orig_fc_ptr) aligned,
  320.           2 start_char char(1) unaligned,
  321.           2 end_char char(1) unaligned;
  322.  
  323.     dcl 1 new_framing_chars aligned,
  324.           2 start_char char(1) unaligned init(NULL), /* no start char */
  325.           2 end_char char(1) unaligned init(CR);
  326.  
  327.  
  328.  
  329. /********************************************************************/
  330. /*  Builtin functions                                               */
  331. /********************************************************************/
  332.  
  333.     dcl null builtin;
  334.     dcl length builtin;
  335.     dcl time   builtin;
  336.  
  337.  
  338. send: entry (info_ptr, code, err_msg);
  339. /********************************************************************/
  340. /*  This is the external interface to the send_stuff kermit         */
  341. /*  routine.                                                        */
  342. /********************************************************************/
  343.  
  344.   chktype = 1; /* Assume first packet uses standard check sum */
  345.   state = send_init_state;
  346.   num_try = 0;
  347.   current_packet_no = 0;
  348.  
  349.  
  350.   call send_stuff;
  351.   return;
  352.  
  353.  
  354. receive: entry (info_ptr, code, err_msg);
  355. /********************************************************************/
  356. /*  This is the external interface to the receive_stuff kermit      */
  357. /*  routine.                                                        */
  358. /********************************************************************/
  359.  
  360.    chktype = 1;  /* Assume first packet uses standard checksum */
  361.    state = receive_init_state;
  362.    num_try = 0;
  363.    current_packet_no = 0;
  364.  
  365.  
  366.    call receive_stuff;
  367.    return;
  368.  
  369.  
  370.  
  371.  
  372. server: entry (info_ptr, code, err_msg);
  373. /********************************************************************/
  374. /*  This is the controlling procedure for the kermit server.        */
  375. /********************************************************************/
  376.  
  377.  
  378.  
  379. /* Reset terminal on quit (especially echoplex) */
  380. on quit begin;
  381.        if trace_sw then close file(trace_file);
  382.        call reset_terminal (code);
  383.        call continue_to_signal_ (code);
  384.        end;
  385.  
  386. /* If any other error condition arises, reset the terminal and   */
  387. /* continue to signal the condition upward.                      */
  388.  
  389. on error begin;
  390.          state = abort_state;
  391.          kermit_info.return_code = cpu_err;
  392.          call error_control;
  393.          if trace_sw then close file(trace_file);
  394.          call continue_to_signal_ (code);
  395.          end;
  396.  
  397. /*  If the trace is enabled, open the file */
  398. if trace_sw then
  399.    open file(trace_file) title("vfile_ kermit.trace -extend") output;
  400.  
  401.  
  402. if debug_sw then call kermit_db_$init;  /* Init event channels for ipc */
  403. state = server_state;
  404. server = true;
  405. chktype = 1;
  406.  
  407. if ^debug_sw then  /* Change terminal modes, not necessary under debug */
  408. do;
  409.    call setup_terminal (code);
  410.    if code ^= 0 then  /* Bad news; won't get badmode because of force, so    */
  411.    do;                /* this is serious                                     */
  412.      kermit_info.return_code = code;
  413.      err_msg = term_modes;
  414.      return;
  415.      end;
  416.    call flush_input_buffer;
  417.    end;
  418.  
  419.  
  420.  
  421. do while(state = server_state);
  422.   current_packet_no = 0;
  423.   num_try = 0;
  424.   call exec_server_command;
  425.   end;
  426.  
  427. /* Only get here if finish command is executed. */
  428. call reset_terminal (code);
  429. if trace_sw then close file(trace_file);
  430. if debug_sw then call kermit_db_$term;
  431.  
  432. return;
  433.  
  434. exec_server_command: proc;
  435. /********************************************************************/
  436. /*  This procedure obtains a packet from the remote system,         */
  437. /*  identifies the command info and executes it.                    */
  438. /********************************************************************/
  439.  
  440. /********************************************************************/
  441. /*>>>>>>>>>>>>>>>>>>>>>>>>>  Declarations  <<<<<<<<<<<<<<<<<<<<<<<<<*/
  442. /********************************************************************/
  443.  
  444. /*=====================  Begin packet.incl.pl1  ====================*/
  445.  
  446.    dcl 1 packet,
  447.          2 type char(1),
  448.          2 len fixed bin(21),
  449.          2 num fixed bin,
  450.          2 data (max_packet_size) char(1);
  451.  
  452. /*======================  End packet.incl.pl1  =====================*/
  453.  
  454.  
  455.     dcl status bit(1);
  456.  
  457.     dcl comm_str char(255) var init("");
  458.     dcl pathname char(168) var init("");
  459.  
  460.     dcl indx fixed bin;
  461.     dcl code fixed bin(35);
  462.     dcl chktype_to_send fixed bin;
  463.  
  464.     dcl packet_types char(5) init(send_type || receive_init_type ||
  465.                 info_type || host_com_type || generic_type);
  466.  
  467.  
  468. /********************************************************************/
  469. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  470. /********************************************************************/
  471.  
  472.  
  473. call receive_packet (packet, 5*rtimint, status); /* Longer timeout interval */
  474. if status = false then /* Didnt get anything, send a nack anyway */
  475. do;
  476.    call send_nack (current_packet_no);
  477.    return;
  478.    end;
  479.  
  480. /********************************************************************/
  481. /*  Got a potential server command, check it out                    */
  482. /********************************************************************/
  483.  
  484. indx = index (packet_types, type);
  485. if indx = 0 then indx = length(packet_types)+1;
  486. goto case(indx);
  487.  
  488. case(1):  /* Send initiate packet, we will be getting a file uploaded */
  489.           call obtain_parms(packet, chktype_to_send);
  490.           call send_init_packet (current_packet_no, chktype_to_send, ack_type);
  491.           state = receive_file_state;
  492.           chktype = chktype_to_send;
  493.           current_packet_no = mod(current_packet_no+1,64);
  494.           cur_file = 0;  /* Get filename from packet */
  495.           call receive_stuff;  /* Get file */
  496.           state = server_state;
  497.           chktype = 1;
  498.           current_packet_no = 0;
  499.           num_try = 0;
  500.           goto endcase;
  501.  
  502. case(2):  /* Receive initiate packet, send a file down */
  503.           do indx = 1 to len;
  504.             pathname = pathname || data(indx);
  505.             end;
  506.           if index(pathname,">") > 0  |  index(pathname,"<")>0 then
  507.             call expand_pathname_ ((pathname), files.names(1).dir, files.names(1).entry, code);
  508.           else
  509.           do;
  510.             files.names(1).dir = default_dir;
  511.             files.names(1).entry = pathname;
  512.             end;
  513.           /* Check for file existence */
  514.           if ^file_exists(files.names(1).dir, files.names(1).entry) then
  515.           do;
  516.             kermit_info.return_code = cant_get_seg;
  517.             call error_control;
  518.             state = server_state;  /* Reset to continue */
  519.             end;
  520.           else
  521.           do;
  522.             num_files = 1;
  523.             cur_file = 1;
  524.             state = send_init_state;
  525.             current_packet_no = mod(current_packet_no+1, 64);
  526.             call send_stuff;
  527.             state = server_state;
  528.             chktype = 1;
  529.             current_packet_no = 0;
  530.             num_try = 0;
  531.             end;
  532.           goto endcase;
  533.  
  534.  
  535. case(3):  /* Initialize Parameters */
  536.           call obtain_parms(packet, chktype_to_send);
  537.           call send_init_packet (current_packet_no, chktype_to_send, ack_type);
  538.           chktype = chktype_to_send;
  539.           goto endcase;
  540.  
  541. case(4):  /* Host command, send data to command processor */
  542.           call unquote_packet (packet, comm_str);
  543.           if index(comm_str,CR)>0 then comm_str = substr(comm_str,1,index(comm_str,CR)-1);
  544.           call exec_com_snd_out_back(comm_str);
  545.           chktype = 1;
  546.           goto endcase;
  547.  
  548. case(5):  /* Generic kermit command */
  549.           call unquote_packet (packet, comm_str);
  550.           if index(comm_str,CR)>0 then comm_str = substr(comm_str,1,index(comm_str,CR)-1);
  551.           call exec_generic_cmd (comm_str);
  552.           chktype = 1;
  553.           goto endcase;
  554.  
  555. case(6):  /* Didnt know what that one was */
  556.           /* Send an error back to micro */
  557.           kermit_info.return_code = unknown_server_cmd;
  558.           call error_control;
  559.           chktype = 1;
  560.           goto endcase;
  561.  
  562. endcase: return;
  563.  
  564. end exec_server_command;
  565.  
  566. exec_generic_cmd: proc (comm_str);
  567. /********************************************************************/
  568. /*  Execute the kermit server command contained in the data array   */
  569. /********************************************************************/
  570.  
  571.     dcl comm_str char(*) var;
  572.  
  573.     dcl indx fixed bin;
  574.     dcl allowed_commands char(7) static init("FLDCTHQ");
  575.  
  576. /********************************************************************/
  577. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  578. /********************************************************************/
  579.  
  580. indx = index(allowed_commands, substr(comm_str,1,1));
  581. if indx = 0 then indx = length(allowed_commands)+1;
  582.  
  583. goto case(indx);
  584.  
  585.  
  586. case(1):  /* Finish command */
  587.           call send_ack (current_packet_no);
  588.           state = completed_state;
  589.           goto endcase;
  590.  
  591. case(2):  /* Logout */
  592.           call send_ack (current_packet_no);
  593.           call exec_com ("logout");    /*** No metering info yet ***/
  594.           state = completed_state;
  595.           goto endcase;  /* Just for form (and in case...) */
  596.  
  597. case(3):  /* What directory are we in */
  598.           call exec_com_snd_out_back ("pwd");
  599.           goto endcase;
  600.  
  601. case(4):  /* Change working directory, and default dir */
  602.           call exec_com_snd_out_back ("cwd " || decode_len(substr(comm_str,2)));
  603.           default_dir = get_wdir_();  /* Get it if we were succesful */
  604.           goto endcase;
  605.  
  606. case(5):  /* Type (print) a file */
  607.           call exec_com_snd_out_back ("print " || decode_len(substr(comm_str,2)));
  608.           goto endcase;
  609.  
  610. case(6):  /* Help */
  611.           call exec_com_snd_out_back ("print " || rtrim(help_dir) || ">server_online.k.info");
  612.           goto endcase;
  613.  
  614. case(7):  /* Server Query */
  615.           call exec_com_snd_out_back ("kermit -status");
  616.           goto endcase;
  617.  
  618. case(8):  /* Unknown type */
  619.           call exec_com_snd_out_back ("ioa_ ""Command unknown or not implemented.""");
  620.           goto endcase;
  621.  
  622. endcase:  return;
  623.  
  624. end exec_generic_cmd;
  625.  
  626.  
  627. exec_com_snd_out_back: proc (command);
  628. /********************************************************************/
  629. /*>>>>>>>>>>>>>>>>>>>>     System Dependency     <<<<<<<<<<<<<<<<<<<*/
  630. /********************************************************************/
  631. /********************************************************************/
  632. /*  Execute a command on the system that generates output; put      */
  633. /*  it into a temp file in the [pd] and send the contents of the    */
  634. /*  file down to the micro.                                         */
  635. /********************************************************************/
  636.  
  637.     dcl command char(*) var;
  638.  
  639.  
  640. /********************************************************************/
  641. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  642. /********************************************************************/
  643.  
  644. call exec_com ("fo [pd]>kermit.tmp -tc;so user_output -ssw error_output");
  645. call exec_com ((command));
  646. call exec_com ("ro -all");
  647.  
  648. /********************************************************************/
  649. /*  Result of command now resides in kermit.tmp in pd.  Transfer    */
  650. /*  it down.                                                        */
  651. /********************************************************************/
  652.  
  653. files.names(1).dir = get_pdir_();
  654. files.names(1).entry = "kermit.tmp";
  655. num_files = 1;
  656. cur_file = 1;
  657. state = send_hdr_state;
  658. call send_stuff;
  659. state = server_state;
  660. return;
  661.  
  662. end exec_com_snd_out_back;
  663.  
  664.  
  665. decode_len: proc (line) returns(char(*) var);
  666. /********************************************************************/
  667. /*  Decode length character in string and return stirng of that len */
  668. /********************************************************************/
  669.  
  670.     dcl line char(*) var;
  671.     dcl t_line char(length(line)) var;
  672.     dcl len_char char(1);
  673.  
  674. if length(line) < 2 then return("");
  675. len_char = substr(line,1,1);
  676. t_line = substr(line, 2, min(length(line)-1, unchar(len_char)));
  677.  
  678. return(t_line);
  679. end decode_len;
  680.  
  681. send_stuff: proc;
  682. /********************************************************************/
  683. /*  Controlling procedure for sending message packets.              */
  684. /********************************************************************/
  685.  
  686.     dcl loop bit(1) init(true);
  687.  
  688.     dcl send_states char(16) init(send_hdr_state || send_data_state ||
  689.                send_file_state || send_eof_state || send_init_state ||
  690.                send_break_state || completed_state || abort_state);
  691.  
  692.  
  693. /* Reset terminal on quit (especially echoplex) */
  694. if ^server then
  695.  
  696. on quit begin;
  697.        if trace_sw then close file(trace_file);
  698.        call reset_terminal (code);
  699.        call continue_to_signal_ (code);
  700.        end;
  701.  
  702. /* If any other error condition arises, reset the terminal and   */
  703. /* continue to signal the condition upward.                      */
  704.  
  705. if ^server then
  706. on error begin;
  707.          call reset_terminal (code);
  708.          /* If it didn't work, we're already in trouble */
  709.          state = abort_state;
  710.          kermit_info.return_code = cpu_err;
  711.          call error_control;
  712.          if trace_sw then close file(trace_file);
  713.          call continue_to_signal_ (code);
  714.          end;
  715.  
  716. /*  If the trace is enabled, open the file */
  717. if trace_sw then
  718.    open file(trace_file) title("vfile_ kermit.trace -extend") output;
  719.  
  720.  
  721. /********************************************************************/
  722. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  723. /********************************************************************/
  724.  
  725. if debug_sw  &  ^server then call kermit_db_$init;  /* Init event channels for ipc */
  726. cur_file_name = files.names(cur_file);
  727.  
  728. if ^server then call ioa_("OK");
  729.  
  730. if delay_time > 0  &  ^server then  /* Delay for time */
  731. do;
  732.    call timer_manager_$sleep (delay_time, rel_secs_flag);
  733.    end;
  734.  
  735. if ^debug_sw  &  ^server then  /* Change terminal modes, not necessary under debug */
  736. do;
  737.    call setup_terminal (code);
  738.    if code ^= 0 then  /* Bad news; won't get badmode because of force, so    */
  739.    do;                /* this is serious                                     */
  740.      kermit_info.return_code = code;
  741.      err_msg = term_modes;
  742.      return;
  743.      end;
  744.    call flush_input_buffer;
  745.    end;
  746.  
  747. do while(loop);
  748.  
  749.    indx = index(send_states, state);
  750.    if indx = 0 then indx = (length(send_states)+2)/2;
  751.                else indx = (indx + 1) / 2;  /* Two character state names */
  752.    goto case(indx);
  753.  
  754.    case(1): /* Send text header (only from server) */
  755.             call send_hdr;
  756.             goto end_case;
  757.  
  758.    case(2): /* Send data */
  759.             call send_data;
  760.             goto end_case;
  761.  
  762.    case(3): /* Send file */
  763.             call send_file;
  764.             goto end_case;
  765.  
  766.    case(4): /* End of file */
  767.             call send_eof;
  768.             goto end_case;
  769.  
  770.    case(5): /* Send initial packet */
  771.             call send_init;
  772.             goto end_case;
  773.  
  774.    case(6): /* Send a break packet */
  775.             call send_break;
  776.             goto end_case;
  777.  
  778.    case(7): /* Transmission Complete */
  779.             kermit_info.return_code = 0;
  780.             loop = false;
  781.             goto end_case;
  782.  
  783.    case(8): /* Abort transmission */
  784.    case(9): /* Unknown state */
  785.             failures = failures + 1;
  786.             loop = false;
  787.             goto end_case;
  788.  
  789.    end_case: end;
  790.  
  791. if ^server then
  792. do;
  793.    call reset_terminal (code);
  794.    if debug_sw then call kermit_db_$term;  /* Terminate comm seg */
  795.    end;
  796. if state = abort_state then call error_control;
  797. if trace_sw then close file(trace_file);
  798. return;
  799. end send_stuff;
  800.  
  801. receive_stuff: proc;
  802. /********************************************************************/
  803. /*  Receive one or more files.                                      */
  804. /********************************************************************/
  805.  
  806.  
  807. /*=====================  Begin packet.incl.pl1  ====================*/
  808.  
  809.    dcl 1 packet,
  810.          2 type char(1),
  811.          2 len fixed bin(21),
  812.          2 num fixed bin,
  813.          2 data (max_packet_size) char(1);
  814.  
  815. /*======================  End packet.incl.pl1  =====================*/
  816.  
  817.  
  818.     dcl loop bit(1) init(true);
  819.  
  820.     dcl rec_states char(10) init(receive_init_state || receive_file_state ||
  821.                         receive_data_state || completed_state ||
  822.                         abort_state);
  823.  
  824. /* Reset terminal on quit (especially echoplex) */
  825. if ^server then
  826. on quit begin;
  827.        if trace_sw then close file(trace_file);
  828.        call reset_terminal (code);
  829.        call continue_to_signal_ (code);
  830.        end;
  831.  
  832. /* If any other error condition arises, reset the terminal and   */
  833. /* continue to signal the condition upward.                      */
  834. if ^server then
  835. on record_quota_overflow begin;
  836.          call reset_terminal (code);
  837.          /* Ignore it if we can't reset things to the way they were. */
  838.          state = abort_state;
  839.          kermit_info.return_code = record_quota_ov;
  840.          call error_control;
  841.          if trace_sw then close file(trace_file);
  842.          call continue_to_signal_ (code);
  843.          end;
  844.  
  845. if ^server then  /* Server has its own traps */
  846. on error begin;
  847.          call reset_terminal (code);
  848.          state = abort_state;
  849.          kermit_info.return_code = cpu_err;
  850.          call error_control;
  851.          if trace_sw then close file(trace_file);
  852.          call continue_to_signal_ (code);
  853.          end;
  854.  
  855.  
  856. /* If trace enabled, open file */
  857. if trace_sw then
  858.    open file(trace_file) title("vfile_ kermit.trace -extend") output;
  859.  
  860. if debug_sw  &  ^server then call kermit_db_$init;  /* Init event channels */
  861.  
  862. if ^server then call ioa_("OK");
  863.  
  864. if ^debug_sw  &  ^server then
  865. do;
  866.    /* Set stty to handle 8 bit no parity raw io */
  867.    call setup_terminal (code);
  868.    if code ^= 0 then /* Bad news; badmode won't come back because of force */
  869.    do;               /* so something else must have gone wrong.            */
  870.      kermit_info.return_code = code;
  871.      err_msg = term_modes;
  872.      return;
  873.      end;
  874.    call flush_input_buffer;
  875.    end;
  876.  
  877. do while(loop);
  878.    indx = index(rec_states, state);
  879.    if indx = 0 then indx = length(rec_states)/2 + 1;
  880.                else indx = (indx+1) / 2;
  881.    goto rec_case(indx);
  882.  
  883.  
  884.    rec_case(1): /* Receive an initial packet */
  885.             call receive_init;
  886.             goto rec_endcase;
  887.  
  888.    rec_case(2): /* Receive a file header */
  889.             call receive_file;
  890.             goto rec_endcase;
  891.  
  892.    rec_case(3): /* Receive data */
  893.             call receive_data;
  894.             goto rec_endcase;
  895.  
  896.    rec_case(4): /* Transfer complete */
  897.             loop = false;
  898.             goto rec_endcase;
  899.  
  900.    rec_case(5): /* Something failed, in abort */
  901.             failures = failures + 1;
  902.             loop = false;
  903.             goto rec_endcase;
  904.  
  905. /*** rec_case(6):  /* ERROR packet */
  906.  
  907.    rec_case(6): /* Unknown state, abort */
  908.             state = abort_state;
  909.             kermit_info.return_code = unknown_state;
  910.             loop = false;
  911.             goto rec_endcase;
  912.  
  913.    rec_endcase: end;
  914.  
  915. /* Reset terminal to handle normal I/O */
  916. if ^server then
  917. do;
  918.    if debug_sw then call kermit_db_$term;  /* Terminate com seg */
  919.    call reset_terminal (code);
  920.    end;
  921.  
  922. if state = abort_state then call error_control;
  923. if trace_sw then close file(trace_file);
  924. return;
  925. end receive_stuff;
  926.  
  927.  
  928. send_data: proc;
  929. /********************************************************************/
  930. /*  Send a data packet                                              */
  931. /********************************************************************/
  932.  
  933. /********************************************************************/
  934. /*>>>>>>>>>>>>>>>>>>>>>>>>>  Declarations  <<<<<<<<<<<<<<<<<<<<<<<<<*/
  935. /********************************************************************/
  936.  
  937. /*=====================  Begin packet.incl.pl1  ====================*/
  938.  
  939.    dcl 1 packet,
  940.          2 type char(1),
  941.          2 len fixed bin(21),
  942.          2 num fixed bin,
  943.          2 data (max_packet_size) char(1);
  944.  
  945. /*======================  End packet.incl.pl1  =====================*/
  946.  
  947.  
  948.     dcl backup_pt fixed bin(24);
  949.     dcl indx fixed bin;
  950.     dcl status bit(1);
  951.     dcl packet_types char(2) init(ack_type || nack_type);
  952.  
  953.  
  954. if num_try > max_try then
  955. do;
  956.    state = abort_state;
  957.    kermit_info.return_code = too_many_tries;
  958.    return;
  959.    end;
  960.  
  961. num_try = num_try + 1;
  962. if num_try > 1 then total_retry_count = total_retry_count + 1;
  963.  
  964. backup_pt = cur_character;     /* This is a little tacky, but nec. to resend */
  965.                                /* data after nack                            */
  966. call build_data_packet (packet);
  967. call send_packet (packet);
  968. call receive_packet (packet, stimint, status);
  969. if status = false then
  970. do;
  971.    cur_character = backup_pt;
  972.    return;
  973.    end;
  974.  
  975. indx = index(packet_types, type);
  976. if indx = 0 then indx = length(packet_types)+1;  /* Unknown packet type */
  977. goto case(indx);
  978.  
  979. case(1): /* Ack */
  980.          if current_packet_no ^= num then return;
  981.          if end_of_data_reached() then
  982.          do;
  983.            state = send_eof_state;
  984.            end;
  985.          current_packet_no = mod(current_packet_no+1, 64);
  986.          num_try = 0;
  987.          goto endcase;
  988.  
  989. case(2): /* Nack */
  990.          cur_character = backup_pt;  /* Reset data pointer to resend */
  991.          goto endcase;
  992.  
  993. case(3): /* Didnt expect this one */
  994.          state = abort_state;
  995.          kermit_info.return_code = wrong_packet_type;
  996.          goto endcase;
  997.  
  998. endcase: return;
  999.  
  1000.  
  1001. end send_data;
  1002.  
  1003. send_hdr: proc;
  1004. /********************************************************************/
  1005. /*  Send a text header packet.  This is an indication in server     */
  1006. /*  mode that a lengthy reply is to follow.  After the initial      */
  1007. /*  packet, transfer is identical to a regular file transfer.       */
  1008. /********************************************************************/
  1009.  
  1010. /********************************************************************/
  1011. /*>>>>>>>>>>>>>>>>>>>>>>>>>  Declarations  <<<<<<<<<<<<<<<<<<<<<<<<<*/
  1012. /********************************************************************/
  1013.  
  1014. /*=====================  Begin packet.incl.pl1  ====================*/
  1015.  
  1016.    dcl 1 packet,
  1017.          2 type char(1),
  1018.          2 len fixed bin(21),
  1019.          2 num fixed bin,
  1020.          2 data (max_packet_size) char(1);
  1021.  
  1022. /*======================  End packet.incl.pl1  =====================*/
  1023.  
  1024.  
  1025.     dcl indx fixed bin;
  1026.     dcl status bit(1);
  1027.     dcl packet_types char(2) init(ack_type || nack_type);
  1028.  
  1029.  
  1030. if num_try > max_try then
  1031. do;
  1032.    state = abort_state;
  1033.    kermit_info.return_code = too_many_tries;
  1034.    return;
  1035.    end;
  1036.  
  1037. num_try = num_try + 1;
  1038. if num_try > 1 then total_retry_count = total_retry_count + 1;
  1039.  
  1040. type = text_hdr_type;
  1041. len = 0;
  1042. num = current_packet_no;
  1043. call send_packet (packet);
  1044. call receive_packet (packet, stimint, status);
  1045. if status = false then return;
  1046.  
  1047. indx = index(packet_types, type);
  1048. if indx = 0 then indx = length(packet_types)+1;  /* Unknown packet type */
  1049. goto case(indx);
  1050.  
  1051. case(1): /* Ack */
  1052.          if current_packet_no ^= num then return;
  1053.          state = send_data_state;
  1054.          call setup_seg_for_transmit;
  1055.          current_packet_no = mod(current_packet_no+1, 64);
  1056.          num_try = 0;
  1057.          goto endcase;
  1058.  
  1059. case(2): /* Nack */
  1060.          goto endcase;
  1061.  
  1062. case(3): /* Didnt expect this one */
  1063.          state = abort_state;
  1064.          kermit_info.return_code = wrong_packet_type;
  1065.          goto endcase;
  1066.  
  1067. endcase: return;
  1068.  
  1069. end send_hdr;
  1070.  
  1071. send_file: proc;
  1072. /********************************************************************/
  1073. /*  Send a packet containing the name of the data file being        */
  1074. /*  sent.  This operates similarly to send_init except when a       */
  1075. /*  correct ACK is received.  In that case, the state changes to    */
  1076. /*  send_data_state and get_chars is called to fill up the data     */
  1077. /*  buffer to send to the foreign host.                             */
  1078. /********************************************************************/
  1079.  
  1080. /********************************************************************/
  1081. /*>>>>>>>>>>>>>>>>>>>>>>>>>  Declarations  <<<<<<<<<<<<<<<<<<<<<<<<<*/
  1082. /********************************************************************/
  1083.  
  1084. /*=====================  Begin packet.incl.pl1  ====================*/
  1085.  
  1086.    dcl 1 packet,
  1087.          2 type char(1),
  1088.          2 len fixed bin(21),
  1089.          2 num fixed bin,
  1090.          2 data (max_packet_size) char(1);
  1091.  
  1092. /*======================  End packet.incl.pl1  =====================*/
  1093.  
  1094.  
  1095.     dcl indx fixed bin;
  1096.     dcl status bit(1);
  1097.     dcl packet_types char(2) init(ack_type || nack_type);
  1098.  
  1099.  
  1100. if num_try > max_try then
  1101. do;
  1102.    state = abort_state;
  1103.    kermit_info.return_code = too_many_tries;
  1104.    return;
  1105.    end;
  1106.  
  1107. num_try = num_try + 1;
  1108. if num_try > 1 then total_retry_count = total_retry_count + 1;
  1109.  
  1110. call build_file_packet (packet);
  1111. call send_packet (packet);
  1112. call receive_packet (packet, stimint, status);
  1113. if status = false then return;
  1114.  
  1115. indx = index(packet_types, type);
  1116. if indx = 0 then indx = length(packet_types)+1;  /* Unknown packet type */
  1117. goto case(indx);
  1118.  
  1119. case(1): /* Ack */
  1120.          if current_packet_no ^= num then return;
  1121.          state = send_data_state;
  1122.          call setup_seg_for_transmit;
  1123.          current_packet_no = mod(current_packet_no+1, 64);
  1124.          num_try = 0;
  1125.          goto endcase;
  1126.  
  1127. case(2): /* Nack */
  1128.          goto endcase;
  1129.  
  1130. case(3): /* Didnt expect this one */
  1131.          state = abort_state;
  1132.          kermit_info.return_code = wrong_packet_type;
  1133.          goto endcase;
  1134.  
  1135. endcase: return;
  1136.  
  1137. end send_file;
  1138.  
  1139.  
  1140. send_eof: proc;
  1141. /********************************************************************/
  1142. /*  Send an end-of-file packet.  On ACK it call get_next_file       */
  1143. /*  which gets next file.  If successful (another file to           */
  1144. /*  send), the state is changed to send_file_state.  On failure,    */
  1145. /*  the state becomes break_connection_state.                       */
  1146. /********************************************************************/
  1147.  
  1148. /********************************************************************/
  1149. /*>>>>>>>>>>>>>>>>>>>>>>>>>  Declarations  <<<<<<<<<<<<<<<<<<<<<<<<<*/
  1150. /********************************************************************/
  1151.  
  1152. /*=====================  Begin packet.incl.pl1  ====================*/
  1153.  
  1154.    dcl 1 packet,
  1155.          2 type char(1),
  1156.          2 len fixed bin(21),
  1157.          2 num fixed bin,
  1158.          2 data (max_packet_size) char(1);
  1159.  
  1160. /*======================  End packet.incl.pl1  =====================*/
  1161.  
  1162.     dcl indx fixed bin;
  1163.     dcl status bit(1);
  1164.     dcl packet_types char(2) init(ack_type || nack_type);
  1165.  
  1166.  
  1167. if num_try > max_try then
  1168. do;
  1169.    state = abort_state;
  1170.    kermit_info.return_code = too_many_tries;
  1171.    return;
  1172.    end;
  1173.  
  1174.  
  1175. /********************************************************************/
  1176. /*  Build EOF packet                                                */
  1177. /********************************************************************/
  1178. type = eof_type;
  1179. len = 0;
  1180. num = current_packet_no;
  1181.  
  1182. num_try = num_try + 1;
  1183. if num_try > 1 then total_retry_count = total_retry_count + 1;
  1184.  
  1185. call send_packet (packet);
  1186. call finish_with_seg (code);
  1187. call receive_packet (packet, stimint, status);
  1188. if status = false then return;
  1189.  
  1190. indx = index(packet_types, type);
  1191. if indx = 0 then indx = length(packet_types)+1;  /* Unknown packet type */
  1192. goto case(indx);
  1193.  
  1194. case(1): /* Ack */
  1195.          if current_packet_no ^= num then return;
  1196.          files_trns = files_trns + 1;   /*  Meter */
  1197.          call get_next_file (status);
  1198.          if status = true then
  1199.          do;
  1200.            state = send_file_state;
  1201.            end;
  1202.          else
  1203.          do;
  1204.            state = send_break_state;
  1205.            end;
  1206.          current_packet_no = mod(current_packet_no+1,64);
  1207.          num_try = 0;
  1208.          goto endcase;
  1209.  
  1210. case(2): /* Nack */
  1211.          goto endcase;
  1212.  
  1213. case(3): /* Didnt expect this one */
  1214.          state = abort_state;
  1215.          kermit_info.return_code = wrong_packet_type;
  1216.          goto endcase;
  1217.  
  1218. endcase: return;
  1219.  
  1220.  
  1221. end send_eof;
  1222.  
  1223. send_init: proc;
  1224. /********************************************************************/
  1225. /*  Initialize the connection with the other host.  This is the     */
  1226. /*  prototype for the other packet sending routines.                */
  1227. /********************************************************************/
  1228.  
  1229. /*=====================  Begin packet.incl.pl1  ====================*/
  1230.  
  1231.    dcl 1 packet,
  1232.          2 type char(1),
  1233.          2 len fixed bin(21),
  1234.          2 num fixed bin,
  1235.          2 data (max_packet_size) char(1);
  1236.  
  1237. /*======================  End packet.incl.pl1  =====================*/
  1238.  
  1239.     dcl packet_types char(2) init(ack_type || nack_type);
  1240.     dcl status bit(1);
  1241.     dcl indx fixed bin;
  1242.     dcl cktype_to_use fixed bin;
  1243.  
  1244. /********************************************************************/
  1245. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  1246. /********************************************************************/
  1247.  
  1248.  
  1249. if num_try > max_try then  /* Abort if too many tries */
  1250. do;
  1251.    state = abort_state;
  1252.    kermit_info.return_code = too_many_tries;
  1253.    return;
  1254.    end;
  1255.  
  1256. num_try = num_try + 1;
  1257. if num_try > 1 then total_retry_count = total_retry_count + 1;
  1258. call send_init_packet (current_packet_no, default_ck_code, send_type);
  1259. call receive_packet(packet, stimint, status);
  1260. if status = false then return;  /* Packet not received. */
  1261.  
  1262. indx = index(packet_types, type);
  1263. if indx = 0 then indx = length(packet_types)+1;
  1264. goto case(indx);
  1265.  
  1266. case(1): if current_packet_no ^= num then return;  /* Wrong ack */
  1267.          call obtain_parms (packet, cktype_to_use);
  1268.          chktype = cktype_to_use;
  1269.          default_ck_code = chktype;  /* Echo back to orig. */
  1270.          state = send_file_state;
  1271.          num_try = 0;
  1272.          current_packet_no = mod(current_packet_no +1,64);
  1273.          goto endcase;
  1274.  
  1275. case(2): goto endcase;  /* Nack */
  1276.  
  1277. case(3):
  1278. /********************************************************************/
  1279. /*  Wrong packet type received.  Goto abort state                   */
  1280. /********************************************************************/
  1281. state = abort_state;
  1282. kermit_info.return_code = wrong_packet_type;
  1283. goto endcase;
  1284.  
  1285. endcase: ;
  1286. return;
  1287. end send_init;
  1288.  
  1289. send_break: proc;
  1290. /********************************************************************/
  1291. /*  Send an EOT packet.  This procedure may be called either in     */
  1292. /*  send_break_state or in abort_state.  In the former, on ACK      */
  1293. /*  change to completed_state.  The latter ignores the current      */
  1294. /*  state.                                                          */
  1295. /********************************************************************/
  1296.  
  1297. /*=====================  Begin packet.incl.pl1  ====================*/
  1298.  
  1299.    dcl 1 packet,
  1300.          2 type char(1),
  1301.          2 len fixed bin(21),
  1302.          2 num fixed bin,
  1303.          2 data (max_packet_size) char(1);
  1304.  
  1305. /*======================  End packet.incl.pl1  =====================*/
  1306.  
  1307.  
  1308.     dcl indx fixed bin;
  1309.     dcl packet_types char(2) init(ack_type || nack_type);
  1310.     dcl status bit(1);
  1311.  
  1312.  
  1313. /********************************************************************/
  1314. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  1315. /********************************************************************/
  1316.  
  1317. type = break_type;
  1318. len = 0;
  1319. num = current_packet_no;
  1320.  
  1321.  
  1322. if num_try > max_try  &  state ^= abort_state then
  1323. do;
  1324.    state = abort_state;
  1325.    kermit_info.return_code = too_many_tries;
  1326.    return;
  1327.    end;
  1328.  
  1329. num_try = num_try + 1;
  1330. if num_try > 1 then total_retry_count = total_retry_count + 1;
  1331. call send_packet(packet);
  1332.  
  1333. /********************************************************************/
  1334. /*  Look for ack                                                    */
  1335. /********************************************************************/
  1336.  
  1337. call receive_packet (packet, stimint, status);
  1338. if status = false then return;  /* Send again or (if abort) ignore */
  1339.  
  1340.  
  1341. indx = index(packet_types, type);
  1342. if indx = 0 then indx = length(packet_types)+1;
  1343. goto case(indx);
  1344.  
  1345. case(1): /* Ack */
  1346.          if current_packet_no ^= num then goto endcase; /* Wrong one */
  1347.          if state ^= abort_state then state = completed_state;
  1348.          num_try = 0;
  1349.          goto endcase;
  1350.  
  1351. case(2): /* Nack */
  1352.          goto endcase;
  1353.  
  1354. case(3): /* Wrong packet type */
  1355.          if state = abort_state then goto endcase;
  1356.          state = abort_state;
  1357.          kermit_info.return_code = unknown_state;
  1358.          goto endcase;
  1359.  
  1360. endcase: return;
  1361. end send_break;
  1362.  
  1363. get_next_file: proc(status);
  1364. /********************************************************************/
  1365. /*  Get the next file in the current list of files to send.  Put    */
  1366. /*  it into variable cur_file_name.  If there isnt one, return      */
  1367. /*  status as false.                                                */
  1368. /********************************************************************/
  1369.  
  1370. /********************************************************************/
  1371. /*>>>>>>>>>>>>>>>>>>>>>>>>>  Declarations  <<<<<<<<<<<<<<<<<<<<<<<<<*/
  1372. /********************************************************************/
  1373.  
  1374.     dcl status bit(1);
  1375.  
  1376.  
  1377. /********************************************************************/
  1378. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  1379. /********************************************************************/
  1380.  
  1381. cur_file = cur_file + 1;
  1382. if cur_file > num_files then
  1383. do;
  1384.    status = false;
  1385.    return;
  1386.    end;
  1387. else
  1388. do;
  1389.    cur_file_name = files.names(cur_file);
  1390.    end;
  1391.  
  1392. return;
  1393. end get_next_file;
  1394.  
  1395.  
  1396. setup_seg_for_transmit: proc;
  1397. /********************************************************************/
  1398. /*>>>>>>>>>>>>>>>>>>>>     System Dependency     <<<<<<<<<<<<<<<<<<<*/
  1399. /********************************************************************/
  1400. /********************************************************************/
  1401. /*  This procedure goes out and looks for the segment with the      */
  1402. /*  name contained in cur_file_name.  If found, it is set up for    */
  1403. /*  fill_transmit_buffer.  Otherwise, the state goes to abort       */
  1404. /*  state.                                                          */
  1405. /********************************************************************/
  1406.  
  1407.  
  1408. /********************************************************************/
  1409. /*>>>>>>>>>>>>>>>>>>>>>>>>>  Declarations  <<<<<<<<<<<<<<<<<<<<<<<<<*/
  1410. /********************************************************************/
  1411.  
  1412.     dcl bit_count fixed bin(24);
  1413.  
  1414. /********************************************************************/
  1415. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  1416. /********************************************************************/
  1417.  
  1418. call hcs_$initiate_count (cur_file_name.dir, cur_file_name.entry, (""), bit_count,
  1419.                           0, transmit_seg_ptr, code);
  1420.  
  1421. if transmit_seg_ptr = null then  /* It ain't there */
  1422. do;
  1423.    state = abort_state;
  1424.    kermit_info.return_code = cant_get_seg;
  1425.    seg_length = 0;
  1426.    end;
  1427.  
  1428. else
  1429. do;
  1430.    seg_length = bit_count / 9; /* 9 bit bytes for you non-Multics folk */
  1431.    cur_character = 1;
  1432.    end;
  1433.  
  1434. last_file_transferred = rtrim(cur_file_name.dir) || ">" || cur_file_name.entry;
  1435.  
  1436. last_char_sent = "";  /* init var.  This is used to keep track of crlf */
  1437.                       /* combinations.  lf -> crlf  crlf unchanged     */
  1438. return;
  1439. end setup_seg_for_transmit;
  1440.  
  1441.  
  1442.  
  1443. finish_with_seg: proc(code);
  1444. /********************************************************************/
  1445. /*>>>>>>>>>>>>>>>>>>>>     System Dependency     <<<<<<<<<<<<<<<<<<<*/
  1446. /********************************************************************/
  1447. /********************************************************************/
  1448. /*  Close input file equivalent                                     */
  1449. /********************************************************************/
  1450.  
  1451.     dcl code fixed bin(35);
  1452.  
  1453. call hcs_$terminate_noname (transmit_seg_ptr, code);
  1454.  
  1455. return;
  1456. end finish_with_seg;
  1457.  
  1458. build_packet: proc (data_ptr, data_len, offset, quote_enable, packet);
  1459. /********************************************************************/
  1460. /*  Add data from a character string of data_len length pointed     */
  1461. /*  to by data_ptr starting at offset characters into the string    */
  1462. /*  into the packet structure.  Quote_enable will allow all         */
  1463. /*  quoting to be performed if the other end has agreed to it.      */
  1464. /********************************************************************/
  1465.  
  1466.     dcl data_ptr ptr;
  1467.     dcl data_len fixed bin(24);
  1468.     dcl offset fixed bin(24);
  1469.     dcl quote_enable bit(1);
  1470.  
  1471. /*=====================  Begin packet_parm.incl.pl1  ====================*/
  1472.  
  1473.    dcl 1 packet,
  1474.          2 type char(1),
  1475.          2 len fixed bin(21),
  1476.          2 num fixed bin,
  1477.          2 data (*) char(1);
  1478.  
  1479. /*======================  End packet_parm.incl.pl1  =====================*/
  1480.  
  1481.  
  1482.     dcl tmp_char char(1) var;
  1483.     dcl cont bit(1);
  1484.     dcl indx fixed bin;
  1485.     dcl ret_str char(10) var;
  1486.     dcl num_chars fixed bin;
  1487.     dcl pkt_len fixed bin init(sp_size-(chktype+2));  /* Amount of data we can send */
  1488.  
  1489. /********************************************************************/
  1490. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  1491. /********************************************************************/
  1492.  
  1493. len = 0;
  1494. cont = true;
  1495.  
  1496. do while (offset ^> data_len  &  cont  &  len < pkt_len);
  1497.    tmp_char = last_char_sent;  /* Save in case lookahead must backup */
  1498.    call get_next_chars (data_ptr, data_len, offset, ret_str, num_chars, quote_enable);
  1499.    if len + length(ret_str) > pkt_len then
  1500.    do;
  1501.      cont = false;
  1502.      last_char_sent = tmp_char;
  1503.      end;
  1504.    else
  1505.    do;
  1506.      offset = offset + num_chars;
  1507.      do indx = 1 to length(ret_str);
  1508.        data(len + indx) = substr(ret_str, indx, 1);
  1509.        end;
  1510.      len = len + length(ret_str);
  1511.      end;
  1512.    end;
  1513.  
  1514. return;
  1515.  
  1516. end build_packet;
  1517.  
  1518. build_data_packet: proc(packet);
  1519. /********************************************************************/
  1520. /*  Fill a packet with data from the file                           */
  1521. /********************************************************************/
  1522.  
  1523. /********************************************************************/
  1524. /*>>>>>>>>>>>>>>>>>>>>>>>>>  Declarations  <<<<<<<<<<<<<<<<<<<<<<<<<*/
  1525. /********************************************************************/
  1526.  
  1527. /*=====================  Begin packet_parm.incl.pl1  ====================*/
  1528.  
  1529.    dcl 1 packet,
  1530.          2 type char(1),
  1531.          2 len fixed bin(21),
  1532.          2 num fixed bin,
  1533.          2 data (*) char(1);
  1534.  
  1535. /*======================  End packet_parm.incl.pl1  =====================*/
  1536.  
  1537.  
  1538.     dcl indx fixed bin;
  1539.  
  1540. /********************************************************************/
  1541. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  1542. /********************************************************************/
  1543.  
  1544. type = data_type;
  1545. num = current_packet_no;
  1546.  
  1547. /********************************************************************/
  1548. /*>>>>>>>>>>>>>>>>>>>>>>>  Build data packet  <<<<<<<<<<<<<<<<<<<<<<*/
  1549. /********************************************************************/
  1550.  
  1551. call build_packet (transmit_seg_ptr, seg_length, cur_character, enable_ctl_quoting, packet);
  1552.  
  1553. return;
  1554. end build_data_packet;
  1555.  
  1556.  
  1557.  
  1558.  
  1559.  
  1560. build_file_packet: proc(packet);
  1561. /********************************************************************/
  1562. /*  Put the current file name into a packet to send down to the     */
  1563. /*  micro.  Only two component names are allowed.                   */
  1564. /********************************************************************/
  1565.  
  1566. /********************************************************************/
  1567. /*>>>>>>>>>>>>>>>>>>>>>>>>>  Declarations  <<<<<<<<<<<<<<<<<<<<<<<<<*/
  1568. /********************************************************************/
  1569.  
  1570. /*=====================  Begin packet_parm.incl.pl1  ====================*/
  1571.  
  1572.    dcl 1 packet,
  1573.          2 type char(1),
  1574.          2 len fixed bin(21),
  1575.          2 num fixed bin,
  1576.          2 data (*) char(1);
  1577.  
  1578. /*======================  End packet_parm.incl.pl1  =====================*/
  1579.  
  1580.  
  1581.     dcl indx fixed bin;
  1582.     dcl indx2 fixed bin;
  1583.     dcl file_name char(32) var;
  1584.     dcl buf_ptr fixed bin;
  1585.     dcl num_periods fixed bin init(0);
  1586.     dcl char char(1);
  1587.     dcl fixed_name char(32) aligned;
  1588.  
  1589. /********************************************************************/
  1590. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  1591. /********************************************************************/
  1592.  
  1593. type = file_type;
  1594. num = current_packet_no;
  1595.  
  1596. file_name = rtrim(cur_file_name.entry);
  1597.  
  1598. /********************************************************************/
  1599. /*>>>>>>>>>>>>>>>>>>  Check file name for syntax  <<<<<<<<<<<<<<<<<<*/
  1600. /********************************************************************/
  1601. indx = index(file_name,".");  /* Only two component (at most) allowed. */
  1602. if indx > 0 then
  1603. do;
  1604.    if indx = length(file_name) then file_name = substr(file_name,1,indx-1);
  1605.    else
  1606.    do;
  1607.      indx2 = index(substr(file_name,indx+1),".");
  1608.      if indx2 > 0 then
  1609.      do;
  1610.        if indx+indx2 = length(file_name) then file_name = substr(file_name,1,indx+indx2-1);
  1611.        else
  1612.          file_name = substr(file_name,1,indx+indx2-1);
  1613.        end;
  1614.      end;
  1615.    end;
  1616.  
  1617. fixed_name = file_name;  /* Transfer to buffer for packet building routines */
  1618.  
  1619. /********************************************************************/
  1620. /*>>>>>>>>>>>>>>>>>>>>>  Put it into a packet  <<<<<<<<<<<<<<<<<<<<<*/
  1621. /********************************************************************/
  1622.  
  1623. call build_packet (addr(fixed_name), length(file_name), (1), enable_ctl_quoting, packet);
  1624.  
  1625. return;
  1626. end build_file_packet;
  1627.  
  1628.  
  1629.  
  1630. receive_init: proc;
  1631. /********************************************************************/
  1632. /*  Recieve the send initiate packet from the host sending files    */
  1633. /*  and ack with a packet containing our parameters.                */
  1634. /********************************************************************/
  1635.  
  1636. /*=====================  Begin packet.incl.pl1  ====================*/
  1637.  
  1638.    dcl 1 packet,
  1639.          2 type char(1),
  1640.          2 len fixed bin(21),
  1641.          2 num fixed bin,
  1642.          2 data (max_packet_size) char(1);
  1643.  
  1644. /*======================  End packet.incl.pl1  =====================*/
  1645.  
  1646.     dcl cktype_to_send fixed bin;
  1647.     dcl status bit(1);
  1648.  
  1649.  
  1650. if num_try > max_try then
  1651. do;
  1652.    kermit_info.return_code = too_many_tries;
  1653.    state = abort_state;
  1654.    return;
  1655.    end;
  1656.  
  1657. num_try = num_try + 1;
  1658. if num_try > 1 then total_retry_count = total_retry_count + 1;
  1659. call receive_packet (packet, rtimint, status);
  1660.  
  1661. if status = false then  /* Didn't get one, nack it and try again */
  1662. do;
  1663.    call send_nack (current_packet_no);
  1664.    return;
  1665.    end;
  1666.  
  1667. else
  1668. if type = send_type then
  1669. do;
  1670.    current_packet_no = num;
  1671.    call obtain_parms (packet, cktype_to_send);
  1672.    data(*) = " ";
  1673.  
  1674.    call send_init_packet(current_packet_no, cktype_to_send, ack_type);
  1675.  
  1676.    state = receive_file_state;
  1677.    num_try = 0;
  1678.    chktype = cktype_to_send;
  1679.    current_packet_no = mod(current_packet_no+1, 64);
  1680.    end;
  1681.  
  1682. else
  1683. do;  /* Unknown packet type */
  1684.    state = abort_state;
  1685.    kermit_info.return_code = unknown_state;
  1686.    end;
  1687.  
  1688. return;
  1689.  
  1690. end receive_init;
  1691.  
  1692. obtain_parms: proc (packet, cktype_to_send);
  1693. /********************************************************************/
  1694. /*  Extract parameter info from a send-init packet                  */
  1695. /********************************************************************/
  1696.  
  1697. /*=====================  Begin packet_parm.incl.pl1  ====================*/
  1698.  
  1699.    dcl 1 packet,
  1700.          2 type char(1),
  1701.          2 len fixed bin(21),
  1702.          2 num fixed bin,
  1703.          2 data (*) char(1);
  1704.  
  1705. /*======================  End packet_parm.incl.pl1  =====================*/
  1706.  
  1707.  
  1708.     dcl cktype_to_send fixed bin;
  1709.     dcl negotiated_ebq bit(1);
  1710.  
  1711.  
  1712. /********************************************************************/
  1713. /*  These are the parameters used by the micro to send stuff up     */
  1714. /*  to us; used in receive_packet and associated routines.          */
  1715. /********************************************************************/
  1716.  
  1717. negotiated_ebq = false;
  1718. repeat_allowed = false;
  1719. cktype_to_send = 1;
  1720.  
  1721. /********************************************************************/
  1722. /* This is the second half of the negotiation, I'll agree to        */
  1723. /* anything the other guy says.  If nothing, I'll take the default  */
  1724. /********************************************************************/
  1725.  
  1726. if len > 0 then
  1727.   if data(1) ^= blank then  rp_size = unchar(data(1));  /* Dont use this */
  1728. if len > 1 then
  1729.   if data(2) ^= blank then  rtimint = max(12, unchar(data(2)));
  1730. if len > 2 then
  1731.   if data(3) ^= blank then  pad = unchar(data(3));      /* or this one   */
  1732. if len > 3 then
  1733.   if data(4) ^= blank then  pad_char = nctl(data(4));   /* or this one   */
  1734. if len > 4 then
  1735.   if data(5) ^= blank then  end_of_line = unchar(data(5)); /* Use for framing chars (maybe) */
  1736. if len > 5 then
  1737.   if data(6) ^= blank then  remote_quote = data(6);
  1738. if len > 6 then
  1739.   if data(7) ^= blank then  negotiated_ebq = (data(7) ^= "N");
  1740.  
  1741. if negotiated_ebq then
  1742. do;
  1743.   if data(7) = "Y" then eight_bit_quote_char = ampersand; 
  1744.                    else eight_bit_quote_char = data(7);
  1745.   end;
  1746. eight_bit_quote = eight_bit_quote & negotiated_ebq;
  1747. if ^eight_bit_quote then eight_bit_quote_char = blank;
  1748.  
  1749. if len > 7 then
  1750.   if data(8) ^= blank then
  1751.      if index(allowed_ck_codes,data(8)) > 0 then cktype_to_send = fixed(data(8));
  1752.                                           else cktype_to_send = 1;
  1753.  
  1754. if len > 8 then
  1755.   if data(9) ^= blank then  repeat_allowed =  true;
  1756.  
  1757. if repeat_allowed then repeat_char = data(9);
  1758.                   else repeat_char = blank;
  1759.  
  1760. return;
  1761. end obtain_parms;
  1762.  
  1763. receive_file: proc;
  1764. /********************************************************************/
  1765. /*  Receive the expected file header packet, acknowledge it and     */
  1766. /*  change state to Receive_data state.  Use the filename           */
  1767. /*  supplied by the header if one was not specified by the user.    */
  1768. /*  If a B packet is received and there are no more files , the     */
  1769. /*  state changes to Complete.                                      */
  1770. /********************************************************************/
  1771.  
  1772.  
  1773. /*=====================  Begin packet.incl.pl1  ====================*/
  1774.  
  1775.    dcl 1 packet,
  1776.          2 type char(1),
  1777.          2 len fixed bin(21),
  1778.          2 num fixed bin,
  1779.          2 data (max_packet_size) char(1);
  1780.  
  1781. /*======================  End packet.incl.pl1  =====================*/
  1782.  
  1783.  
  1784.     dcl t_str char(200) var init("");
  1785.     dcl packet_types char(4) init( send_type || eof_type || file_type ||
  1786.                              break_type);
  1787.     dcl status bit(1);
  1788.     dcl indx fixed bin;
  1789.  
  1790.  
  1791. if num_try > max_try then
  1792. do;
  1793.    state = abort_state;
  1794.    kermit_info.return_code = too_many_tries;
  1795.    return;
  1796.    end;
  1797.  
  1798. num_try = num_try + 1;
  1799. if num_try > 1 then total_retry_count = total_retry_count + 1;
  1800.  
  1801. call receive_packet(packet, rtimint, status);
  1802.  
  1803. if status = false then   /* Couldn't get one */
  1804. do;                      /* Nack and wait    */
  1805.    call send_nack(current_packet_no);
  1806.    return;
  1807.    end;
  1808.  
  1809. indx = index(packet_types, type);
  1810. if indx = 0 then indx = length(packet_types)+1;
  1811. goto case(indx);
  1812.  
  1813. case(1): /* Send initiate packet   */
  1814.          /* Must have lost the ack */
  1815.          if num = previous_packet_no(current_packet_no) then
  1816.          do;
  1817.            call send_init_packet(previous_packet_no(current_packet_no), 1, ack_type);
  1818.            num_try = 0;
  1819.            end;
  1820.          else
  1821.          do;
  1822.            state = abort_state;
  1823.            kermit_info.return_code = wrong_packet_no;
  1824.            end;
  1825.          goto endcase;
  1826.  
  1827.  
  1828. case(2): /* End of file packet                  */
  1829.          /* Saw this one before in receive_data */
  1830.          if num = previous_packet_no(current_packet_no) then
  1831.          do;
  1832.            call send_ack(previous_packet_no(current_packet_no));
  1833.            num_try = 0;
  1834.            end;
  1835.          else
  1836.          do;
  1837.            state = abort_state;
  1838.            kermit_info.return_code = wrong_packet_no;
  1839.            end;
  1840.          goto endcase;
  1841.  
  1842. case(3): /* File header */
  1843.          if num ^= current_packet_no then
  1844.          do;
  1845.            state = abort_state;
  1846.            kermit_info.return_code = wrong_packet_no;
  1847.            end;
  1848.          else
  1849.          do;
  1850.            call send_ack(current_packet_no);
  1851.            call unquote_packet (packet, t_str);
  1852.            cur_file_name.entry = t_str;
  1853.            if cur_file = 0 then
  1854.               call fix_file_name(cur_file_name);
  1855.            else
  1856.               cur_file_name = files.names(1);
  1857.            call open_file(cur_file_name);
  1858.            num_try = 0;
  1859.            current_packet_no = mod(current_packet_no+1, 64);
  1860.            state = receive_data_state;
  1861.            end;
  1862.          goto endcase;
  1863.  
  1864. case(4): /* Break transmission */
  1865.          if current_packet_no ^= num then
  1866.          do;
  1867.            state = abort_state;
  1868.            kermit_info.return_code = wrong_packet_no;
  1869.            end;
  1870.          else
  1871.          do;
  1872.            /* Since I won't listen after this, and it is possible   */
  1873.            /* for the  local host to miss the ack while it is       */
  1874.            /* closing files and such like, delay and send it out    */
  1875.             call timer_manager_$sleep (2, rel_secs_flag);
  1876.             call send_ack (current_packet_no);
  1877.            /* Here's a good one.  At 300 baud, the fnp may change modes */
  1878.            /* before the ack packet goes out, so the micro doesn't see  */
  1879.            /* the SOH character (it sees the string \001 instead).      */
  1880.            /* Ha ha.   Very funny.                                      */
  1881.             call timer_manager_$sleep (1, rel_secs_flag);
  1882.            /* 'Course it worked on a loaded system.                     */
  1883.            state = completed_state;
  1884.            end;
  1885.          num_try = 0;
  1886.          goto endcase;
  1887.  
  1888. case(5): /* Unexpected type */
  1889.          state = abort_state;
  1890.          kermit_info.return_code = wrong_packet_type;
  1891.          goto endcase;
  1892.  
  1893. endcase: return;
  1894. end receive_file;
  1895.  
  1896.  
  1897. receive_data: proc;
  1898. /********************************************************************/
  1899. /*  Receive data packets.  This state is entered either from a      */
  1900. /*  previous receive_data state or from a receive_file_state.       */
  1901. /*  The file has been opened in either case.  Previous packets      */
  1902. /*  of F or D types are acked (the ack must have been lost).  If    */
  1903. /*  an end of file packet is received, the file is closed and       */
  1904. /*  state returns to receive_file_state.                            */
  1905. /********************************************************************/
  1906.  
  1907.  
  1908. /*=====================  Begin packet.incl.pl1  ====================*/
  1909.  
  1910.    dcl 1 packet,
  1911.          2 type char(1),
  1912.          2 len fixed bin(21),
  1913.          2 num fixed bin,
  1914.          2 data (max_packet_size) char(1);
  1915.  
  1916. /*======================  End packet.incl.pl1  =====================*/
  1917.  
  1918.  
  1919.     dcl data_str char(3500) var init("");
  1920.     dcl packet_types char(3) init(file_type || data_type || eof_type);
  1921.     dcl indx fixed bin;
  1922.     dcl status bit(1);
  1923.  
  1924.  
  1925.  
  1926. if num_try > max_try then
  1927. do;
  1928.    state = abort_state;
  1929.    kermit_info.return_code = too_many_tries;
  1930.    return;
  1931.    end;
  1932.  
  1933. num_try = num_try + 1;
  1934. if num_try > 1 then total_retry_count = total_retry_count + 1;
  1935. call receive_packet (packet, rtimint, status);
  1936.  
  1937. /********************************************************************/
  1938. /*  If no packet, Nack it and return to wait for another            */
  1939. /********************************************************************/
  1940. if status = false then
  1941. do;
  1942.    call send_nack(current_packet_no);
  1943.    return;
  1944.    end;
  1945.  
  1946. indx = index(packet_types, type);
  1947. if indx = 0 then indx = length(packet_types)+1;
  1948. goto case(indx);
  1949.  
  1950. case(1): /* File header packet (again) */
  1951.          if num = previous_packet_no(current_packet_no) then
  1952.          do;
  1953.            call send_ack(previous_packet_no(current_packet_no));
  1954.            num_try = 0;
  1955.            end;
  1956.          else
  1957.          do;
  1958.            state = abort_state;
  1959.            kermit_info.return_code = wrong_packet_no;
  1960.            end;
  1961.          goto endcase;
  1962.  
  1963.  
  1964. case(2): /* Data packet */
  1965.          if num = current_packet_no then
  1966.          do;
  1967.            call unquote_packet (packet, data_str);
  1968.            call add_chars(data_str);
  1969.            call send_ack(current_packet_no);
  1970.            num_try = 0;
  1971.            current_packet_no = mod(current_packet_no+1, 64);
  1972.            end;
  1973.          else
  1974.          if num = previous_packet_no(current_packet_no) then
  1975.          do;
  1976.            call send_ack(previous_packet_no(current_packet_no));
  1977.            num_try = 0;
  1978.            end;
  1979.          else
  1980.          do;
  1981.            state = abort_state;
  1982.            kermit_info.return_code = wrong_packet_no;
  1983.            end;
  1984.          goto endcase;
  1985.  
  1986. case(3): /* End of file packet */
  1987.          if num ^= current_packet_no then
  1988.          do;
  1989.            state = abort_state;
  1990.            kermit_info.return_code = wrong_packet_no;
  1991.            end;
  1992.          else
  1993.          do;
  1994.            call close_file;
  1995.            files_rcvd = files_rcvd + 1;
  1996.            call send_ack(current_packet_no);
  1997.            num_try = 0;
  1998.            current_packet_no = mod(current_packet_no+1, 64);
  1999.            state = receive_file_state;
  2000.            end;
  2001.          goto endcase;
  2002.  
  2003. case(4): /* Unknown packet type */
  2004.          state = abort_state;
  2005.          kermit_info.return_code = wrong_packet_type;
  2006.          goto endcase;
  2007.  
  2008. endcase: return;
  2009. end receive_data;
  2010.  
  2011.  
  2012. make_char: proc(number) returns(char(1));
  2013. /*******************************************************************/
  2014. /**** The following procedures through unctl are system dependent **/
  2015. /********************************************************************/
  2016. /*  Convert number to a character.                                  */
  2017. /********************************************************************/
  2018.  
  2019.     dcl number fixed bin;
  2020.  
  2021. return(substr(collate(),number+33, 1));
  2022. end make_char;
  2023.  
  2024.  
  2025. unchar: proc(char) returns(fixed bin);
  2026. /********************************************************************/
  2027. /*  Inverse transformation.                                         */
  2028. /********************************************************************/
  2029.  
  2030.     dcl char char(1);
  2031.  
  2032. return(index(collate(),char)-33);
  2033. end unchar;
  2034.  
  2035.  
  2036. ctl: proc(num) returns(char(1));
  2037. /********************************************************************/
  2038. /*  Controllify a control (Ascii 0 to 37) so that it is             */
  2039. /*  printable.                                                      */
  2040. /*  XOR char with 100 octal                                         */
  2041. /********************************************************************/
  2042.  
  2043.  
  2044.     dcl value fixed bin(9) based(addr(char_rep)) unsigned unaligned;
  2045.     dcl char_rep char(1) aligned;
  2046.     dcl bit_rep bit(9) based(addr(char_rep));
  2047.  
  2048.     dcl num fixed bin;
  2049.     dcl octal_100 bit(9) static init("001000000"b);
  2050.     dcl octal_100_mask bit(9) static init("110111111"b);
  2051.  
  2052.  
  2053. value = num;
  2054.  
  2055. if mod(num,128) < 32 then bit_rep = bit_rep | octal_100;
  2056.             else bit_rep = bit_rep & octal_100_mask;
  2057. return (char_rep);
  2058.  
  2059. end ctl;
  2060.  
  2061.  
  2062. nctl: proc(char) returns(fixed bin);
  2063. /********************************************************************/
  2064. /*  Same as above                                                   */
  2065. /********************************************************************/
  2066.  
  2067.     dcl char char(1);
  2068.     dcl num fixed bin;
  2069.  
  2070.     dcl value fixed bin(9) unsigned based(addr(char_rep)) unaligned;
  2071.     dcl char_rep char(1) aligned;
  2072.     dcl bit_rep bit(9) based(addr(char_rep));
  2073.  
  2074.     dcl octal_100 bit(9) static init("001000000"b);
  2075.     dcl octal_100_mask bit(9) static init("110111111"b);
  2076.  
  2077.  
  2078. char_rep = char;
  2079.  
  2080. if substr(bit_rep,3,1) then substr(bit_rep,3,1)=false;
  2081.                        else substr(bit_rep,3,1)=true;
  2082.  
  2083. num = value;
  2084.  
  2085. return(num);
  2086. end nctl;
  2087.  
  2088.  
  2089. unctl: proc (char) returns(char(1));
  2090. /********************************************************************/
  2091. /*  Variant of above.                                               */
  2092. /********************************************************************/
  2093.  
  2094.     dcl char char(1);
  2095.     dcl indx fixed bin;
  2096.  
  2097.     dcl num_rep fixed bin(9) unsigned based(addr(char_rep)) unaligned;
  2098.     dcl char_rep char(1) aligned;
  2099.  
  2100.  
  2101. num_rep = nctl(char);
  2102. return (char_rep);
  2103. end unctl;
  2104.  
  2105. previous_packet_no: proc (pkt_no) returns(fixed bin);
  2106. /********************************************************************/
  2107. /*  Return the number of the previous packet.  Necessary since      */
  2108. /*  packet no is mod 64                                             */
  2109. /********************************************************************/
  2110.  
  2111.     dcl pkt_no fixed bin;
  2112.  
  2113.  
  2114. if pkt_no = 0 then return(63); /* -1 wont do any good */
  2115. else
  2116.    return(pkt_no - 1);
  2117.  
  2118. end previous_packet_no;
  2119.  
  2120. send_init_packet: proc(pkt_no, chktype_to_send, parm_type);
  2121. /********************************************************************/
  2122. /*  Send the packet containing our parameters                       */
  2123. /*  This may either be an S, I or Ack packet type.                  */
  2124. /********************************************************************/
  2125.  
  2126.     dcl pkt_no fixed bin;
  2127.     dcl chktype_to_send fixed bin;
  2128.     dcl parm_type char(1);
  2129.  
  2130.     dcl char_ck_codes char(3) static init("123");
  2131.  
  2132. /*=====================  Begin packet.incl.pl1  ====================*/
  2133.  
  2134.    dcl 1 packet,
  2135.          2 type char(1),
  2136.          2 len fixed bin(21),
  2137.          2 num fixed bin,
  2138.          2 data (max_packet_size) char(1);
  2139.  
  2140. /*======================  End packet.incl.pl1  =====================*/
  2141.  
  2142.  
  2143. /********************************************************************/
  2144. /*  These are the parameters used in sending items down to the      */
  2145. /*  micro; used in send_packet, build_packet and associated         */
  2146. /*  routines.                                                       */
  2147. /********************************************************************/
  2148.  
  2149. data(1) = make_char(sp_size);
  2150. data(2) = make_char(fixed(stimint,17));
  2151. data(3) = make_char(my_pad);
  2152. data(4) = ctl(my_pad_char);
  2153. data(5) = make_char(my_end_of_line);
  2154. data(6) = my_quote;
  2155. if eight_bit_quote then 
  2156. do;
  2157.    if eight_bit_quote_char ^= blank then data(7) = eight_bit_quote_char;
  2158.    else
  2159.    do;
  2160.      data(7) = ampersand;
  2161.      eight_bit_quote_char = ampersand;
  2162.      end;
  2163.    end;
  2164.  
  2165. else
  2166. do;
  2167.    if parm_type = ack_type then data(7)="N";  /* Didnt ask for it, dont do it */
  2168.                            else data(7)="N";  /* We can do it, but won't    */
  2169.    end;
  2170.  
  2171. data(8) = substr(char_ck_codes, chktype_to_send, 1);
  2172. if repeat_allowed then data(9) = repeat_char;  /* Initial conn. assumes ability */
  2173.                   else data(9) = blank;
  2174. data(10) = blank;
  2175. data(11) = blank;
  2176.  
  2177. len = 11;
  2178. type = parm_type;
  2179. num = pkt_no;
  2180. call send_packet(packet);
  2181.  
  2182. /********************************************************************/
  2183. /*>>>>>>>>>>>>  Notice no quoting on these packet types  <<<<<<<<<<<*/
  2184. /********************************************************************/
  2185.  
  2186.  
  2187. return;
  2188. end send_init_packet;
  2189.  
  2190.  
  2191. send_ack: proc(pkt_no);
  2192. /********************************************************************/
  2193. /*  Send an ack packet                                              */
  2194. /********************************************************************/
  2195.  
  2196.     dcl pkt_no fixed bin;
  2197.  
  2198. /*=====================  Begin packet.incl.pl1  ====================*/
  2199.  
  2200.    dcl 1 packet,
  2201.          2 type char(1),
  2202.          2 len fixed bin(21),
  2203.          2 num fixed bin,
  2204.          2 data (max_packet_size) char(1);
  2205.  
  2206. /*======================  End packet.incl.pl1  =====================*/
  2207.  
  2208.  
  2209. len = 0;
  2210. type = ack_type;
  2211. num = pkt_no;
  2212. call send_packet (packet);
  2213. return;
  2214. end send_ack;
  2215.  
  2216.  
  2217.  
  2218. send_nack: proc (pkt_no);
  2219. /********************************************************************/
  2220. /*  Send a NACK packet                                              */
  2221. /********************************************************************/
  2222.  
  2223.     dcl pkt_no fixed bin;
  2224.  
  2225. /*=====================  Begin packet.incl.pl1  ====================*/
  2226.  
  2227.    dcl 1 packet,
  2228.          2 type char(1),
  2229.          2 len fixed bin(21),
  2230.          2 num fixed bin,
  2231.          2 data (max_packet_size) char(1);
  2232.  
  2233. /*======================  End packet.incl.pl1  =====================*/
  2234.  
  2235.  
  2236.  
  2237. len = 0;
  2238. type = nack_type;
  2239. num = pkt_no;
  2240. call send_packet(packet);
  2241. return;
  2242. end send_nack;
  2243.  
  2244. error_control: proc;
  2245. /********************************************************************/
  2246. /*  This procedure is responsible for the recovery of errors        */
  2247. /*  during file transfer.  An error packet is sent down to the      */
  2248. /*  micro containing an error message, a break packet is sent       */
  2249. /*  and then a return is made.                                      */
  2250. /********************************************************************/
  2251.  
  2252. /*=====================  Begin packet.incl.pl1  ====================*/
  2253.  
  2254.    dcl 1 packet,
  2255.          2 type char(1),
  2256.          2 len fixed bin(21),
  2257.          2 num fixed bin,
  2258.          2 data (max_packet_size) char(1);
  2259.  
  2260. /*======================  End packet.incl.pl1  =====================*/
  2261.  
  2262.  
  2263.     dcl fixed_e_msg char(80);
  2264.     dcl indx fixed bin;
  2265.     dcl status bit(1);
  2266.     dcl err_msgs (11) char(80) var static init (
  2267.         "Too many retries.",
  2268.         "Wrong packet type.",
  2269.         "Entered unexpected state.",
  2270.         "Wrong packet number.",
  2271.         "Error on host system.",
  2272.         "File missing for send request.",
  2273.         "Record quota overflow; insufficient space available.",
  2274.         "File already exists; transmission aborted.",
  2275.         "Can't get segment for transmission.",
  2276.         "That server command has not been implemented.",
  2277.         "That host command is not recognized.");
  2278.  
  2279. /********************************************************************/
  2280. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  2281. /********************************************************************/
  2282.  
  2283. indx = kermit_info.return_code - 20;
  2284. fixed_e_msg = err_msgs(indx);
  2285. type = error_type;
  2286. call build_packet (addr(fixed_e_msg), length(err_msgs(indx)),(1), enable_ctl_quoting, packet);
  2287. num = current_packet_no;
  2288.  
  2289. /********************************************************************/
  2290. /*  It is possible to not have the correct terminal config.         */
  2291. /********************************************************************/
  2292. if ^debug_sw  &  ^server then call setup_terminal (code);
  2293.  
  2294. call send_packet(packet);
  2295.  
  2296. /********************************************************************/
  2297. /*  Get ack (or timeout)                                            */
  2298. /********************************************************************/
  2299. call receive_packet(packet, stimint, status);
  2300.  
  2301. current_packet_no = mod(current_packet_no+1, 64);
  2302. call send_break;
  2303.  
  2304. /********************************************************************/
  2305. /*  Reset terminal config.                                          */
  2306. /********************************************************************/
  2307. if ^server  &  ^debug_sw then call reset_terminal (code);
  2308. return;
  2309. end error_control;
  2310.  
  2311. fix_file_name: proc (cur_fn);
  2312. /********************************************************************/
  2313. /*  Get the file name sent from the remote system out of the        */
  2314. /*  data array. Do any fixup needed and put it into cur_fn          */
  2315. /********************************************************************/
  2316.  
  2317. /********************************************************************/
  2318. /*>>>>>>>>>>>>>>>>>>>>>>>>>  Declarations  <<<<<<<<<<<<<<<<<<<<<<<<<*/
  2319. /********************************************************************/
  2320.  
  2321.     dcl len fixed bin(21);
  2322.     dcl 1 cur_fn,
  2323.           2 dir char(*),
  2324.           2 entry char(*);
  2325.     dcl tentry char(200) var init("");
  2326.     dcl indx fixed bin;
  2327.  
  2328.  
  2329. /********************************************************************/
  2330. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  2331. /********************************************************************/
  2332.  
  2333. /********************************************************************/
  2334. /*  Since directories will not be specified by the remote           */
  2335. /*  kermit, use the default directory.  This is changable with      */
  2336. /*  the set command                                                 */
  2337. /********************************************************************/
  2338.  
  2339. dir = default_dir;
  2340.  
  2341. tentry = rtrim(entry);
  2342.  
  2343. tentry = translate(tentry, sml, big);
  2344.  
  2345. /********************************************************************/
  2346. /*  If any drive specifiers (b:, a:, etc), get rid of them          */
  2347. /********************************************************************/
  2348.  
  2349. if index(tentry, colon) > 0 then
  2350. do;
  2351.    indx = index(tentry, colon);
  2352.    tentry = substr(tentry, 1, min(indx+1, length(tentry)));
  2353.    end;
  2354.  
  2355. /********************************************************************/
  2356. /*  Get rid of period if single component name sent over            */
  2357. /********************************************************************/
  2358.  
  2359. if substr(tentry,length(tentry)) = "." then tentry = substr(tentry,1,length(tentry)-1);
  2360.  
  2361.  
  2362. /********************************************************************/
  2363. /*  Finally, supply a default if a null file name was sent          */
  2364. /********************************************************************/
  2365.  
  2366. if tentry||blank = blank then tentry = "kermit.out";
  2367.  
  2368. entry = ltrim(tentry);
  2369. return;
  2370. end fix_file_name;
  2371.  
  2372.  
  2373. open_file: proc(file_name);
  2374. /********************************************************************/
  2375. /*>>>>>>>>>>>>>>>>>>>>     System Dependency     <<<<<<<<<<<<<<<<<<<*/
  2376. /********************************************************************/
  2377. /********************************************************************/
  2378. /*  Procedure to open a file                                        */
  2379. /********************************************************************/
  2380.  
  2381.     dcl 1 file_name,
  2382.           2 dir char(*),
  2383.           2 entry char(*);
  2384.  
  2385.     dcl output file;
  2386.     dcl count fixed bin;
  2387.     dcl fe bit(1);
  2388.     dcl t_entry char(32);
  2389.  
  2390. /********************************************************************/
  2391. /* If file_warning is enabled, determine if file currently exists.  */
  2392. /*  This has already been checked in the case of a user supplied    */
  2393. /*  pathname, but not when the name is supplied by the remote       */
  2394. /*  system.  If fw = true & existence then try renaming the file    */
  2395. /*  by adding .1, .2 etc.  If we cant do that in 100 tries, make up */
  2396. /*  a unique filename through a system call.                        */
  2397. /********************************************************************/
  2398.  
  2399. if file_warning_sw then
  2400. do;
  2401.    t_entry = entry;  /* In case it doesn't exist */
  2402.    fe = file_exists (dir, entry);
  2403.    count = 0;
  2404.    do while(fe);
  2405.      count = count + 1;
  2406.      t_entry = rtrim(entry) || "." || ltrim(rtrim(char(count)));
  2407.      if count > 100 then t_entry = unique_chars_(unique_bits_());
  2408.      fe = file_exists (dir, t_entry);
  2409.      end;
  2410.    entry = t_entry;
  2411.    end;
  2412.  
  2413. last_file_transferred = rtrim(dir) || ">" || entry;
  2414.  
  2415. eof_flag = false;
  2416. open file(output) title("vfile_ " || rtrim(dir) || ">" || entry) output;
  2417. call iox_$find_iocb("output", output_iocb_ptr, code);
  2418. return;
  2419.  
  2420. end open_file;
  2421.  
  2422. file_exists: proc (dir, entry) returns(bit(1));
  2423. /********************************************************************/
  2424. /*  System Dependent routine to determine if the file with the      */
  2425. /*  given name exists in the storate structure.                     */
  2426. /********************************************************************/
  2427.  
  2428.     dcl dir char(*);
  2429.     dcl entry char(*);
  2430.  
  2431.     dcl bc fixed bin(24);
  2432.     dcl tst_ptr ptr;
  2433.     dcl code fixed bin(35);
  2434.  
  2435.  
  2436. call hcs_$initiate_count (dir, entry, "", bc, 0, tst_ptr, code);
  2437. if tst_ptr ^= null() then
  2438. do;
  2439.    call hcs_$terminate_noname(tst_ptr, code);
  2440.    return(true);
  2441.    end;
  2442.  
  2443. return(false);
  2444.  
  2445. end file_exists;
  2446.  
  2447. close_file: proc;
  2448.  
  2449.     dcl output file;
  2450.  
  2451. close file(output);
  2452. output_iocb_ptr = null();
  2453. return;
  2454. end;
  2455.  
  2456.  
  2457.  
  2458.  
  2459.  
  2460. end_of_data_reached: proc returns(bit(1));
  2461.  
  2462. /***********************************************************************************/
  2463. /******  System Dependent routine to return true when end of data to send reached **/
  2464. /***********************************************************************************/
  2465.  
  2466. if cur_character > seg_length then return(true);
  2467.                               else return(false);
  2468.  
  2469. end end_of_data_reached;
  2470.  
  2471. add_chars: proc(data_str);
  2472. /********************************************************************/
  2473. /*>>>>>>>>>>>>>>>>>>>>     System Dependency     <<<<<<<<<<<<<<<<<<<*/
  2474. /********************************************************************/
  2475. /********************************************************************/
  2476. /*  Put characters in output file                                   */
  2477. /********************************************************************/
  2478.  
  2479.     dcl data_str char(*) var;
  2480.  
  2481.     dcl indx fixed bin;
  2482.     dcl t_str char(150) var init("");
  2483.     dcl str   char(3000) aligned;
  2484.     dcl len   fixed bin(21);
  2485.  
  2486.     dcl CRLF char(2) init(CR||LF);
  2487.  
  2488.  
  2489.  
  2490. /********************************************************************/
  2491. /*  Since, in some machines, an eof character (ctrl-z) is used      */
  2492. /*  to mark the end of the file instead of using the character      */
  2493. /*  count in the directory like a good computer should, garbage     */
  2494. /*  may be innocently sent by the PC.                               */
  2495. /*  This is particularly true in the IBM PC case for files          */
  2496. /*  produced by BASIC. The character count is rounded up to the     */
  2497. /*  nearest 256 bytes.  As far as I can tell, all other programs    */
  2498. /*  count characters correctly.  Sigh.  In any event, that's the    */
  2499. /*  reason for the text mode setting.  Text files shouldn't be      */
  2500. /*  hurt by it.                                                     */
  2501. /*                                                                  */
  2502. /*  Text mode also provides for CRLF -> LF conversion on Multics    */
  2503. /********************************************************************/
  2504.  
  2505. if eof_flag & text_mode then return;  /* Don't add characters past ^Z */
  2506.  
  2507. if  text_mode then
  2508. do;
  2509.    if last_char_received = CR  &  substr(data_str,1,1) ^= LF then
  2510.       data_str = CR || data_str;
  2511.  
  2512.    indx = index(data_str, CRLF);
  2513.    do while (indx > 0);
  2514.      t_str = substr(data_str,1, indx-1) || LF;
  2515.      if length(data_str) > indx+1 then t_str = t_str || substr(data_str,indx+2);
  2516.      data_str = t_str;
  2517.      indx = index(data_str, CRLF);
  2518.      end;
  2519.  
  2520.    if substr(data_str, length(data_str)) = CR then
  2521.    do;
  2522.      last_char_received = CR;
  2523.      data_str = substr(data_str, 1, length(data_str)-1);
  2524.      end;
  2525.    else last_char_received = "";
  2526.  
  2527.    if index (data_str, CTL_Z) > 0 then
  2528.    do;
  2529.      data_str = substr(data_str,1,index(data_str,CTL_Z)-1);
  2530.      eof_flag = true;
  2531.      end;
  2532.  
  2533.    end;  /* Non-transparent transfer stuff */
  2534.  
  2535. str = data_str;
  2536. len = length(data_str);
  2537. call iox_$put_chars(output_iocb_ptr, addr(str), len, code);
  2538.  
  2539. return;
  2540. end;
  2541.  
  2542. receive_packet: proc (packet, timeout, status);
  2543. /********************************************************************/
  2544. /*  Get a packet from the other host.  Decode information into      */
  2545. /*  the packet data structure                                       */
  2546. /********************************************************************/
  2547.  
  2548. /*=====================  Begin packet_parm.incl.pl1  ====================*/
  2549.  
  2550.    dcl 1 packet,
  2551.          2 type char(1),
  2552.          2 len fixed bin(21),
  2553.          2 num fixed bin,
  2554.          2 data (*) char(1);
  2555.  
  2556. /*======================  End packet_parm.incl.pl1  =====================*/
  2557.  
  2558.  
  2559.     dcl timeout fixed bin(71);
  2560.     dcl cksum fixed bin(35);
  2561.     dcl tsum  fixed bin(35);
  2562.     dcl indx fixed bin;
  2563.     dcl line_len fixed bin;
  2564.  
  2565.     dcl line char(150) var;
  2566.     dcl cksum_str char(3) var;
  2567.     dcl i fixed bin init(0);
  2568.     dcl unctl_nxt_char bit(1) init(false);
  2569.     dcl prev_char_not_quote bit(1) init(true);
  2570.     dcl status bit(1);
  2571.     dcl char char(1);
  2572.  
  2573.     dcl found_soh bit(1) init(false);
  2574.     dcl tmp_chktype fixed bin;
  2575.     dcl data_len fixed bin;
  2576.  
  2577.     dcl error condition;
  2578.  
  2579.  
  2580. /********************************************************************/
  2581. /*  Error   for timer_manager_                                      */
  2582. /********************************************************************/
  2583.  
  2584. on error begin;
  2585.            call timer_manager_$reset_alarm_call(abort_read);
  2586.            call continue_to_signal_ (code);
  2587.            end;
  2588.  
  2589.  
  2590. /********************************************************************/
  2591. /*  Stop timers if quit encountered.                                */
  2592. /********************************************************************/
  2593.  
  2594. on quit begin;
  2595.         call timer_manager_$reset_alarm_call (abort_read);
  2596.         call continue_to_signal_ (code);
  2597.         end;
  2598.  
  2599.  
  2600.  
  2601.  
  2602. /********************************************************************/
  2603. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  2604. /********************************************************************/
  2605.  
  2606. cksum = 0;
  2607.  
  2608.  
  2609. if debug_sw then
  2610. do;
  2611.     call kermit_db_$get_packet (input_bfr_ptr, input_bfr_len, cur_inpt_bfr_len, timeout, status);
  2612.     if status = false then return;  /* Didn't get one */
  2613.     end;
  2614.  
  2615. else
  2616. do;
  2617.    /********************************************************************/
  2618.    /*  Set up timer for time-out on read.  Return status as false      */
  2619.    /*  if we time out                                                  */
  2620.    /********************************************************************/
  2621.  
  2622.    call timer_manager_$alarm_call (timeout, rel_secs_flag, abort_read);
  2623.    call iox_$get_line (tty_iocb, input_bfr_ptr, input_bfr_len, cur_inpt_bfr_len, code);
  2624.    call timer_manager_$reset_alarm_call (abort_read);
  2625.    end;
  2626.  
  2627. total_packet_rcvd = total_packet_rcvd + 1;
  2628. if trace_sw then call log_receive (input_bfr_ptr, cur_inpt_bfr_len);
  2629.  
  2630. line = substr(input_buffer, 1, cur_inpt_bfr_len-1);
  2631.  
  2632. /********************************************************************/
  2633. /*  Get rid of SOH character and fragmented packet(s) at            */
  2634. /*  beginning if present                                            */
  2635. /********************************************************************/
  2636.  
  2637. indx = index(line,SOH);
  2638. do while (indx > 0  &  ^found_soh);
  2639.    found_soh = true;
  2640.    if indx = length(line) then
  2641.    do;
  2642.      line = "";
  2643.      found_soh = false;
  2644.      end;
  2645.    else
  2646.    do;
  2647.      line = substr(line, indx+1);
  2648.      indx = index(line, SOH);
  2649.      end;
  2650.    end;
  2651.  
  2652. if ^found_soh | length(line) < 4 then  /* Got to have at least 4 */
  2653. do;
  2654.    status = false;
  2655.    return;
  2656.    end;
  2657.  
  2658.  
  2659. /********************************************************************/
  2660. /*  Obtain type and length fields                                   */
  2661. /********************************************************************/
  2662.  
  2663. len = unchar(substr(line,1,1));
  2664. num = unchar (substr(line,2,1));
  2665. type = substr(line,3,1);
  2666.  
  2667. if  length(line) < len+1 then    /* Len field does not include SOH or len */
  2668. do;                              /* field, but everything else            */
  2669.    status = false;               /* Better has at least as much as we     */
  2670.    return;                       /* thought we did                        */
  2671.    end;
  2672.  
  2673.  
  2674. /********************************************************************/
  2675. /*  Set up checksum type.  This is necessary since I may have       */
  2676. /*  acked the send init packet and think I am using a               */
  2677. /*  non-default checksum but in reality, my ack was lost and we     */
  2678. /*  are still using the default                                     */
  2679. /********************************************************************/
  2680.  
  2681. if len - (2+chktype) < 0 then /* A bit of magic here */
  2682. do;
  2683.    tmp_chktype = chktype;
  2684.    chktype = 1;
  2685.    end;
  2686. else tmp_chktype = chktype;   /* Save for restore later */
  2687.  
  2688. /** Now we can add in the checksums for the first two fields **/
  2689. call add_ck_sm (cksum, make_char((len)));
  2690. call add_ck_sm (cksum, make_char((num)));
  2691. call add_ck_sm (cksum, type);
  2692.  
  2693.  
  2694. /********************************************************************/
  2695. /*  Take data out of string and add checksums                       */
  2696. /********************************************************************/
  2697.  
  2698. line = substr(line,4);
  2699. data_len = len - (2+chktype);
  2700. do indx = 1 to data_len;
  2701.    data(indx) = substr(line, indx, 1);
  2702.    call add_ck_sm (cksum, data(indx));
  2703.    end;
  2704.  
  2705. cksum_str = substr(line, data_len+1);
  2706.  
  2707. if char_cksum(cksum) ^= cksum_str then status = false;
  2708.                                     else status = true;
  2709. len = data_len;
  2710. chktype = tmp_chktype;
  2711.  
  2712. return;
  2713.  
  2714. end_of_receive_packet:  /* Target of goto when read times out */
  2715. if trace_sw then call log_receive (input_bfr_ptr, 0);
  2716. return;
  2717.  
  2718.  
  2719.  
  2720. abort_read: proc;
  2721. /********************************************************************/
  2722. /*  Procedure called by timer_manager_ when the read times out      */
  2723. /*  if a CR (ie LF) was lost or the last ACK was lost.              */
  2724. /********************************************************************/
  2725.  
  2726. status = false;
  2727. if trace_sw then call log_receive (input_bfr_ptr, 0);
  2728. goto end_of_receive_packet;  /* Non-local goto */
  2729. end abort_read;
  2730.  
  2731.  
  2732. end receive_packet;
  2733.  
  2734. send_packet: proc(packet);
  2735. /********************************************************************/
  2736. /*  Build a packet in an interal line and send it out all at        */
  2737. /*  once. Calculate that confounded checksum                        */
  2738. /*  Tack on the specified line terminator.                          */
  2739. /********************************************************************/
  2740.  
  2741. /*=====================  Begin packet_parm.incl.pl1  ====================*/
  2742.  
  2743.    dcl 1 packet,
  2744.          2 type char(1),
  2745.          2 len fixed bin(21),
  2746.          2 num fixed bin,
  2747.          2 data (*) char(1);
  2748.  
  2749. /*======================  End packet_parm.incl.pl1  =====================*/
  2750.  
  2751.  
  2752.     dcl cksum fixed bin(35);
  2753.     dcl char_cnt fixed bin;
  2754.     dcl packet_line char(250) var init("");
  2755.     dcl char char(1);
  2756.     dcl indx fixed bin;
  2757.     dcl tsum fixed bin(35);
  2758.  
  2759.  
  2760. cksum = 0;
  2761. char_cnt = 0;
  2762. /********************************************************************/
  2763. /*  Put out specified number of padding characters                  */
  2764. /********************************************************************/
  2765.  
  2766. do indx = 1 to pad;
  2767.    packet_line = packet_line || make_char(pad_char);
  2768.    end;
  2769.  
  2770. packet_line = packet_line || SOH;
  2771.  
  2772.  
  2773. /********************************************************************/
  2774. /*  Packet Format                                                   */
  2775. /*                                                                  */
  2776. /*  <SOH> <len> <num> <type> <..... data .....> <checksum> <eol>    */
  2777. /*  Length includes type, length and checksum fields, but not       */
  2778. /*  SOH and end_of_line                                             */
  2779. /********************************************************************/
  2780.  
  2781.  
  2782. /********************************************************************/
  2783. /*  Put in character count (packet length)                          */
  2784. /********************************************************************/
  2785. char = make_char(len+2+chktype);
  2786. call add_ck_sm (cksum, char);
  2787. packet_line = packet_line || char;
  2788.  
  2789. /********************************************************************/
  2790. /*  Packet number, mod 64                                           */
  2791. /********************************************************************/
  2792. num = mod(num, 64);
  2793. char = make_char(num);
  2794. call add_ck_sm (cksum, char);
  2795. packet_line = packet_line || char;
  2796.  
  2797. /********************************************************************/
  2798. /*  Packet type                                                     */
  2799. /********************************************************************/
  2800. call add_ck_sm (cksum, type);
  2801. packet_line = packet_line || type;
  2802.  
  2803.  
  2804.  
  2805. /********************************************************************/
  2806. /*  Data                                                            */
  2807. /********************************************************************/
  2808.  
  2809. do indx = 1 to len;
  2810.    call add_ck_sm (cksum, data(indx));
  2811.    packet_line = packet_line || data(indx);
  2812.    end;
  2813.  
  2814. packet_line = packet_line || char_cksum(cksum);
  2815.  
  2816. /********************************************************************/
  2817. /*  Tack on indicated end of line character                         */
  2818. /********************************************************************/
  2819. packet_line = packet_line || substr(collate(), my_end_of_line+1, 1);
  2820.  
  2821.  
  2822. /********************************************************************/
  2823. /*  Output line                                                     */
  2824. /********************************************************************/
  2825. if debug_sw then call kermit_db_$send_packet (packet_line);
  2826. else
  2827.    call output_chars (packet_line);
  2828.  
  2829. total_packet_trns = total_packet_trns + 1;
  2830. if trace_sw then call log_trans (packet_line);
  2831.  
  2832. return;
  2833.  
  2834.  
  2835.  
  2836.  
  2837. end send_packet;
  2838.  
  2839.  
  2840. output_chars: proc (line);
  2841. /********************************************************************/
  2842. /*>>>>>>>>>>>>>>>>>>>>     System Dependency     <<<<<<<<<<<<<<<<<<<*/
  2843. /********************************************************************/
  2844. /********************************************************************/
  2845. /*  Output characters without any additional linefeed characters    */
  2846. /*  - the line terminator has already been added.                   */
  2847. /********************************************************************/
  2848.  
  2849.     dcl line char(*) var;
  2850.  
  2851. call ioa_$nnl ("^a", line);
  2852.  
  2853. return;
  2854. end output_chars;
  2855.  
  2856.  
  2857.  
  2858. add_ck_sm: proc(sum, parm_char);
  2859. /********************************************************************/
  2860. /*>>>>>>>>>>>>>>>>>>>>     System Dependency     <<<<<<<<<<<<<<<<<<<*/
  2861. /********************************************************************/
  2862. /********************************************************************/
  2863. /*  Add the binary value of char to sum to do checksums (types 1&2) */
  2864. /*  Do a table look up procedrue for CRC checksums                  */
  2865. /*  The table look up algorithm comes from Byte-wise CRC            */
  2866. /*  Calculations, Perez, Wismer & Becker, IEEE Micro, June 1983.    */
  2867. /*  Thanks Greg.                                                    */
  2868. /********************************************************************/
  2869.  
  2870.     dcl sum fixed bin(35);
  2871.     dcl parm_char char(1);
  2872.     dcl char char(1) aligned;
  2873.     dcl al_bit_rep bit(9) based(addr(char));
  2874.     dcl lower_seven_bits bit(9) static init("001111111"b);
  2875.     dcl 1 nine_bit_counter aligned,
  2876.           2 twenty_seven_0s bit(27) unaligned init("0"b),
  2877.           2 num fixed bin(9) unsigned unaligned;
  2878.  
  2879.     dcl lo_byte bit(8);
  2880.     dcl xor bit(4) static options(constant) init("0110"b); /* Xor for bool */
  2881.  
  2882. /*===================  Begine crc_table.incl.pl1  ==================*/
  2883.  
  2884.  
  2885. /********************************************************************/
  2886. /*  This table was produced by a procedure implementing the crc     */
  2887. /*  table generating function:                                      */
  2888. /*  .  R16 = x8 x4        R8 = x5 x1                                */
  2889. /*  .  R15 = x7 x3        R7 = x4                                   */
  2890. /*  .  R14 = x6 x2        R6 = x3                                   */
  2891. /*  .  R13 = x5 x1        R5 = x2                                   */
  2892. /*  .  R12 = x4           R4 = x8 x4 x1                             */
  2893. /*  .  R11 = x8 x4 x3     R3 = x7 x3                                */
  2894. /*  .  R10 = x7 x3 x2     R2 = x6 x2                                */
  2895. /*  .  R9 = x6 x2 x1      R1 = x5 x1                                */
  2896. /*                                                                  */
  2897. /*  where Rn is the bit of the table word and the xn is an xor      */
  2898. /*  function with the nth bit of the 8 bit table index.  See        */
  2899. /*  Perez et all for details.  Bits are numbered right to left      */
  2900. /*  with the least significant bit being 1.                         */
  2901. /********************************************************************/
  2902.  
  2903.     dcl crc_table(0:255) bit(16) static options(constant) init (
  2904.           "0000"b4,   "1189"b4,   "2312"b4,   "329b"b4,   "4624"b4,   "57ad"b4,
  2905.           "6536"b4,   "74bf"b4,   "8c48"b4,   "9dc1"b4,   "af5a"b4,   "bed3"b4,
  2906.           "ca6c"b4,   "dbe5"b4,   "e97e"b4,   "f8f7"b4,   "1081"b4,   "0108"b4,
  2907.           "3393"b4,   "221a"b4,   "56a5"b4,   "472c"b4,   "75b7"b4,   "643e"b4,
  2908.           "9cc9"b4,   "8d40"b4,   "bfdb"b4,   "ae52"b4,   "daed"b4,   "cb64"b4,
  2909.           "f9ff"b4,   "e876"b4,   "2102"b4,   "308b"b4,   "0210"b4,   "1399"b4,
  2910.           "6726"b4,   "76af"b4,   "4434"b4,   "55bd"b4,   "ad4a"b4,   "bcc3"b4,
  2911.           "8e58"b4,   "9fd1"b4,   "eb6e"b4,   "fae7"b4,   "c87c"b4,   "d9f5"b4,
  2912.           "3183"b4,   "200a"b4,   "1291"b4,   "0318"b4,   "77a7"b4,   "662e"b4,
  2913.           "54b5"b4,   "453c"b4,   "bdcb"b4,   "ac42"b4,   "9ed9"b4,   "8f50"b4,
  2914.           "fbef"b4,   "ea66"b4,   "d8fd"b4,   "c974"b4,   "4204"b4,   "538d"b4,
  2915.           "6116"b4,   "709f"b4,   "0420"b4,   "15a9"b4,   "2732"b4,   "36bb"b4,
  2916.           "ce4c"b4,   "dfc5"b4,   "ed5e"b4,   "fcd7"b4,   "8868"b4,   "99e1"b4,
  2917.           "ab7a"b4,   "baf3"b4,   "5285"b4,   "430c"b4,   "7197"b4,   "601e"b4,
  2918.           "14a1"b4,   "0528"b4,   "37b3"b4,   "263a"b4,   "decd"b4,   "cf44"b4,
  2919.           "fddf"b4,   "ec56"b4,   "98e9"b4,   "8960"b4,   "bbfb"b4,   "aa72"b4,
  2920.           "6306"b4,   "728f"b4,   "4014"b4,   "519d"b4,   "2522"b4,   "34ab"b4,
  2921.           "0630"b4,   "17b9"b4,   "ef4e"b4,   "fec7"b4,   "cc5c"b4,   "ddd5"b4,
  2922.           "a96a"b4,   "b8e3"b4,   "8a78"b4,   "9bf1"b4,   "7387"b4,   "620e"b4,
  2923.           "5095"b4,   "411c"b4,   "35a3"b4,   "242a"b4,   "16b1"b4,   "0738"b4,
  2924.           "ffcf"b4,   "ee46"b4,   "dcdd"b4,   "cd54"b4,   "b9eb"b4,   "a862"b4,
  2925.           "9af9"b4,   "8b70"b4,   "8408"b4,   "9581"b4,   "a71a"b4,   "b693"b4,
  2926.           "c22c"b4,   "d3a5"b4,   "e13e"b4,   "f0b7"b4,   "0840"b4,   "19c9"b4,
  2927.           "2b52"b4,   "3adb"b4,   "4e64"b4,   "5fed"b4,   "6d76"b4,   "7cff"b4,
  2928.           "9489"b4,   "8500"b4,   "b79b"b4,   "a612"b4,   "d2ad"b4,   "c324"b4,
  2929.           "f1bf"b4,   "e036"b4,   "18c1"b4,   "0948"b4,   "3bd3"b4,   "2a5a"b4,
  2930.           "5ee5"b4,   "4f6c"b4,   "7df7"b4,   "6c7e"b4,   "a50a"b4,   "b483"b4,
  2931.           "8618"b4,   "9791"b4,   "e32e"b4,   "f2a7"b4,   "c03c"b4,   "d1b5"b4,
  2932.           "2942"b4,   "38cb"b4,   "0a50"b4,   "1bd9"b4,   "6f66"b4,   "7eef"b4,
  2933.           "4c74"b4,   "5dfd"b4,   "b58b"b4,   "a402"b4,   "9699"b4,   "8710"b4,
  2934.           "f3af"b4,   "e226"b4,   "d0bd"b4,   "c134"b4,   "39c3"b4,   "284a"b4,
  2935.           "1ad1"b4,   "0b58"b4,   "7fe7"b4,   "6e6e"b4,   "5cf5"b4,   "4d7c"b4,
  2936.           "c60c"b4,   "d785"b4,   "e51e"b4,   "f497"b4,   "8028"b4,   "91a1"b4,
  2937.           "a33a"b4,   "b2b3"b4,   "4a44"b4,   "5bcd"b4,   "6956"b4,   "78df"b4,
  2938.           "0c60"b4,   "1de9"b4,   "2f72"b4,   "3efb"b4,   "d68d"b4,   "c704"b4,
  2939.           "f59f"b4,   "e416"b4,   "90a9"b4,   "8120"b4,   "b3bb"b4,   "a232"b4,
  2940.           "5ac5"b4,   "4b4c"b4,   "79d7"b4,   "685e"b4,   "1ce1"b4,   "0d68"b4,
  2941.           "3ff3"b4,   "2e7a"b4,   "e70e"b4,   "f687"b4,   "c41c"b4,   "d595"b4,
  2942.           "a12a"b4,   "b0a3"b4,   "8238"b4,   "93b1"b4,   "6b46"b4,   "7acf"b4,
  2943.           "4854"b4,   "59dd"b4,   "2d62"b4,   "3ceb"b4,   "0e70"b4,   "1ff9"b4,
  2944.           "f78f"b4,   "e606"b4,   "d49d"b4,   "c514"b4,   "b1ab"b4,   "a022"b4,
  2945.           "92b9"b4,   "8330"b4,   "7bc7"b4,   "6a4e"b4,   "58d5"b4,   "495c"b4,
  2946.           "3de3"b4,   "2c6a"b4,   "1ef1"b4,   "0f78"b4);
  2947.  
  2948.  
  2949. /*====================  End crc_table.incl.pl1  ====================*/
  2950.  
  2951.  
  2952.  
  2953.  
  2954.  
  2955. if eight_bit_quote then  /* Dont consider parity in checksum computation */
  2956. do;
  2957.    char = parm_char;
  2958.    al_bit_rep = al_bit_rep  &  lower_seven_bits;
  2959.    end;
  2960. else
  2961.    char = parm_char;
  2962.  
  2963.  
  2964. goto case(chktype);
  2965.  
  2966. case(1):  /* Single byte */
  2967. case(2):  /* double byte */
  2968.           num = fixed ("0"b || unspec(char));
  2969.           sum = sum + num;
  2970.           return;
  2971.  
  2972. case(3): /* CRC type */
  2973.          lo_byte = substr(unspec(sum),29);  /* Low 8 bits */
  2974.          unspec(num) = bool ("0"b || lo_byte, unspec(char), xor);
  2975.          sum = sum / 256;  /* Shift 8 bits to right */
  2976.          unspec(sum) = bool (unspec(sum), "00000000000000000000"b || crc_table(num), xor);
  2977.          return;
  2978.  
  2979. end add_ck_sm;
  2980.  
  2981. char_cksum: proc(cksum) returns(char(*) var);
  2982. /********************************************************************/
  2983. /*>>>>>>>>>>>>>>>>>>>>     System Dependency     <<<<<<<<<<<<<<<<<<<*/
  2984. /********************************************************************/
  2985. /********************************************************************/
  2986. /*  Take the numeric representation of cksum and return a           */
  2987. /*  character representation of it.  Which type ;depends on the     */
  2988. /*  checksum type.                                                  */
  2989. /********************************************************************/
  2990.  
  2991.     dcl cksum fixed bin(35);
  2992.     dcl indx fixed bin;
  2993.     dcl tsum fixed bin(35);
  2994.     dcl ret_str char(3) var;
  2995.  
  2996.     dcl low_six bit(36) static options(constant) init
  2997.         ("000000000000000000000000000000111111"b);
  2998.     dcl mid_six bit(36) static options(constant) init
  2999.         ("000000000000000000000000111111000000"b);
  3000.     dcl high_six bit(36) static options(constant) init
  3001.         ("000000000000000000111111000000000000"b);
  3002.  
  3003.  
  3004. /********************************************************************/
  3005. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  3006. /********************************************************************/
  3007.  
  3008. goto case(chktype);  /* 1, 2 or 3 only */
  3009.  
  3010.  
  3011.  
  3012. case(1):  /* Standard kermit checksum type */
  3013.     /*  Keep only low order 8 bits of checksum                          */
  3014.     cksum = mod(cksum, 256);
  3015.     tsum = cksum;
  3016.  
  3017.     /*  Add two high order bits to lower bits                           */
  3018.     unspec(cksum) = unspec(cksum) & "000000000000000000000000000011000000"b;
  3019.     cksum = cksum / 64;
  3020.     cksum = cksum + tsum;
  3021.  
  3022.     /*  Keep lower 6 bits and add a space to it to make it printable    */
  3023.     unspec(cksum) = unspec(cksum) & low_six;
  3024.     indx = cksum;  /* Match up parms */
  3025.     ret_str = make_char(indx);
  3026.     return (ret_str);
  3027.  
  3028.  
  3029. case(2):  /* Double byte checksum, kermit type 2 */
  3030.  
  3031.           /* Get low 6 bits  */
  3032.           unspec(tsum) = unspec(cksum) & low_six;
  3033.           ret_str = (make_char((tsum)));
  3034.  
  3035.           /* Get higher 6 bits                   */
  3036.           unspec(tsum) = unspec(cksum) & mid_six;
  3037.           tsum = tsum / 64;  /* Shift to low end */
  3038.           ret_str = (make_char((tsum))) || ret_str;
  3039.           return(ret_str);
  3040.  
  3041.  
  3042. case(3):  /* Three byte CRC checksum  */
  3043.           /* Get low 6 bits  */
  3044.           unspec(tsum) = unspec(cksum) & low_six;
  3045.           ret_str = (make_char((tsum)));
  3046.  
  3047.           /* Get middle 6 bits                   */
  3048.           unspec(tsum) = unspec(cksum) & mid_six;
  3049.           tsum = tsum / 64;  /* Shift to low end */
  3050.           ret_str = (make_char((tsum))) || ret_str;
  3051.  
  3052.           /* Get higher 6 bits                    */
  3053.           unspec(tsum) = unspec(cksum) & high_six;
  3054.           tsum = tsum / 4096; /* Shift to low end   */
  3055.           ret_str = (make_char((tsum))) || ret_str;
  3056.           return(ret_str);
  3057.  
  3058. end char_cksum;
  3059.  
  3060. get_next_chars: proc (data_ptr, data_len, offset, ret_str, num_chars, quote_enable);
  3061. /********************************************************************/
  3062. /*  Obtain the next character (or group of characters) from the     */
  3063. /*  data string. In worst case, the ret_str may contain up to       */
  3064. /*  five characters: two for repeate group, parity quote,           */
  3065. /*  control quote and the actual character.                         */
  3066. /********************************************************************/
  3067.  
  3068.     dcl data_ptr ptr;
  3069.     dcl data_len fixed bin(24);
  3070.     dcl offset fixed bin(24);
  3071.     dcl ret_str char(*) var;
  3072.     dcl num_chars fixed bin;
  3073.     dcl quote_enable bit(1);
  3074.  
  3075. /********************************************************************/
  3076. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  3077. /********************************************************************/
  3078.  
  3079. ret_str = "";
  3080. num_chars = 0;
  3081.  
  3082. if quote_enable then
  3083. do;
  3084.    call repeat_quoting (data_ptr, data_len, offset, ret_str, num_chars);
  3085.    end;
  3086.  
  3087. else
  3088. do;
  3089.    call single_char (data_ptr, offset, ret_str, num_chars);
  3090.    end;
  3091.  
  3092. return;
  3093. end get_next_chars;
  3094.  
  3095. repeat_quoting: proc (data_ptr, data_len, offset, ret_str, num_chars);
  3096. /********************************************************************/
  3097. /*  Handle repeat groups.  Each group may contain upto 94           */
  3098. /*  characters.  Also have to make sure we don't fall off the       */
  3099. /*  end of the data.                                                */
  3100. /********************************************************************/
  3101.  
  3102.     dcl data_ptr ptr;
  3103.     dcl data_len fixed bin(24);
  3104.     dcl offset fixed bin(24);
  3105.     dcl ret_str char(*) var;
  3106.     dcl num_chars fixed bin;
  3107.  
  3108.     dcl total_chars_compressed fixed bin init(0);
  3109.     dcl t_offset fixed bin(24);
  3110.     dcl new_str char(10) var;
  3111.     dcl new_chars fixed bin;
  3112.  
  3113.     dcl temp_char char(1);
  3114.     dcl t2_char char(1);
  3115.  
  3116. /********************************************************************/
  3117. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  3118. /********************************************************************/
  3119.  
  3120. call ctl_quoting (data_ptr, offset, ret_str, num_chars);
  3121.  
  3122. if repeat_char ^= blank then
  3123. do;
  3124.    temp_char = last_char_sent;  /* Necessary to buffer 1 char lookahead so */
  3125.                                 /* LF->CRLF transformation works.          */
  3126.    call ctl_quoting (data_ptr, offset+num_chars, new_str, new_chars);
  3127.    t_offset = offset + num_chars;
  3128.    total_chars_compressed = num_chars;
  3129.  
  3130.    do while(new_str = ret_str   &  total_chars_compressed < 94  &  t_offset+new_chars < data_len);
  3131.      total_chars_compressed = total_chars_compressed + new_chars;
  3132.      t_offset = t_offset + new_chars;
  3133.      t2_char = last_char_sent;
  3134.      call ctl_quoting (data_ptr, t_offset, new_str, new_chars);
  3135.      end;
  3136.  
  3137.    if total_chars_compressed > repeat_threshold then
  3138.    do;
  3139.      ret_str = repeat_char || make_char (total_chars_compressed) || ret_str;
  3140.      num_chars = total_chars_compressed;
  3141.      last_char_sent = t2_char;
  3142.      end;
  3143.    else
  3144.      last_char_sent = temp_char;
  3145.    end;
  3146.  
  3147. return;
  3148. end repeat_quoting;
  3149.  
  3150. ctl_quoting: proc (data_ptr, offset, ret_str, num_chars);
  3151. /********************************************************************/
  3152. /*  Prefix with a control quote character if not a printable        */
  3153. /*  char.                                                           */
  3154. /********************************************************************/
  3155.  
  3156.     dcl data_ptr ptr;
  3157.     dcl offset fixed bin(24);
  3158.     dcl ret_str char(*) var;
  3159.     dcl num_chars fixed bin;
  3160.  
  3161.     dcl s_char char(1) aligned;
  3162.     dcl v_char char(2) var;
  3163.     dcl prefix_char char(1) var;
  3164.     dcl bit_rep bit(9) based(addr(s_char));
  3165.     dcl num_rep fixed bin;
  3166.  
  3167.     dcl l7_char char(1) aligned;
  3168.     dcl l7_bit_rep bit(9) based(addr(l7_char));
  3169.     dcl lower_seven_bits bit(9) static init("001111111"b);
  3170.  
  3171.  
  3172. /********************************************************************/
  3173. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  3174. /********************************************************************/
  3175.  
  3176. call parity_quoting (data_ptr, offset, v_char, num_chars);
  3177. if length(v_char) > 1 then
  3178. do;
  3179.    prefix_char = substr(v_char,1,1);
  3180.    s_char = substr(v_char,2);
  3181.    end;
  3182. else
  3183. do;
  3184.    prefix_char = "";
  3185.    s_char = v_char;
  3186.    end;
  3187.  
  3188. l7_char = s_char;
  3189. l7_bit_rep = l7_bit_rep & lower_seven_bits;
  3190.  
  3191. num_rep = fixed(l7_bit_rep);
  3192.  
  3193. if num_rep < 32 /* Blank */  |  num_rep = 127 /* Tilde */ then
  3194. /********************************************************************/
  3195. /*  If lower seven bits in range of 0-31 or 127, then prefix and    */
  3196. /*  change original character to controlified character (xor bit    */
  3197. /*  7 (or 6, depending on terminology -- second bit from left on    */
  3198. /*  8 bit char))                                                    */
  3199. /********************************************************************/
  3200. do;
  3201.    ret_str = prefix_char || my_quote || ctl(fixed(bit_rep));
  3202.    end;
  3203.  
  3204. else
  3205. /********************************************************************/
  3206. /*  If lower seven bits = one of the special prefix characters,     */
  3207. /*  then quote the original character                               */
  3208. /********************************************************************/
  3209. do;
  3210.    ret_str = prefix_char || s_char;
  3211.    if l7_char = my_quote  |
  3212.       (eight_bit_quote & l7_char = eight_bit_quote_char)  |
  3213.       (repeat_char ^= blank  &  l7_char = repeat_char)
  3214.       then ret_str = prefix_char || my_quote || s_char;
  3215.    end;
  3216.  
  3217. return;
  3218.  
  3219. end ctl_quoting;
  3220.  
  3221. parity_quoting: proc (data_ptr, offset, ret_str, num_chars);
  3222. /********************************************************************/
  3223. /*>>>>>>>>>>>>>>>>>>>>>>  SYSTEM DEPENDENCY <<<<<<<<<<<<<<<<<<<<<<<<*/
  3224. /********************************************************************/
  3225. /*  Get a character an prefix with the parity quote character if    */
  3226. /*  this has been turned on.                                        */
  3227. /********************************************************************/
  3228.  
  3229.     dcl data_ptr ptr;
  3230.     dcl offset fixed bin(24);
  3231.     dcl ret_str char(*) var;
  3232.     dcl num_chars fixed bin;
  3233.  
  3234.     dcl prefix_char char(1) var;
  3235.     dcl char  char(1);
  3236.     dcl bit_rep bit(9) based(addr(char));
  3237.     dcl mask_parity bit(9) static init("001111111"b);
  3238.  
  3239. /********************************************************************/
  3240. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  3241. /********************************************************************/
  3242.  
  3243. call single_char (data_ptr, offset, ret_str, num_chars);
  3244.  
  3245. if eight_bit_quote then
  3246. do;
  3247.    char = ret_str;
  3248.    if substr(bit_rep, 2, 1) then  /* Parity bit on NOTE: 9 BIT BYTES */
  3249.    do;
  3250.      bit_rep = bit_rep & mask_parity;
  3251.      ret_str = eight_bit_quote_char || char;
  3252.      end;
  3253.    end;
  3254.  
  3255. return;
  3256. end parity_quoting;
  3257.  
  3258. single_char: proc (data_ptr, offset, ret_char, num_chars);
  3259. /********************************************************************/
  3260. /*  Translation routine.  Multics LF goes to CRLF combination.      */
  3261. /*                                                                  */
  3262. /*  This is a good place for ebcdic to ascii translation.           */
  3263. /********************************************************************/
  3264.  
  3265.     dcl data_ptr ptr;
  3266.     dcl offset fixed bin(24);
  3267.     dcl ret_char char(*) var;
  3268.     dcl num_chars fixed bin;
  3269.  
  3270.  
  3271. /********************************************************************/
  3272. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  3273. /********************************************************************/
  3274.  
  3275. num_chars = 1;
  3276.  
  3277. ret_char = get_a_char (data_ptr, offset);
  3278. if ret_char = LF  &  last_char_sent ^= CR  &  text_mode  then
  3279. do;
  3280.    last_char_sent = CR;
  3281.    num_chars = 0;  /* Do not advance pointer in buffer */
  3282.    ret_char = CR;
  3283.    end;
  3284.  
  3285. else
  3286. do;
  3287.    last_char_sent = ret_char;
  3288.    end;
  3289.  
  3290. return;
  3291. end single_char;
  3292.  
  3293.  
  3294. get_a_char: proc (data_ptr, offset) returns(char(1));
  3295. /********************************************************************/
  3296. /*  Obtain a character from the data buffer                         */
  3297. /********************************************************************/
  3298.  
  3299.     dcl data_ptr ptr;
  3300.     dcl offset fixed bin(24);
  3301.  
  3302.     dcl data_str char(offset) based(data_ptr);
  3303.  
  3304. /********************************************************************/
  3305. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  3306. /********************************************************************/
  3307.  
  3308. return (substr(data_str, offset, 1));
  3309.  
  3310. end get_a_char;
  3311.  
  3312. unquote_packet: proc (packet, data_str);
  3313. /********************************************************************/
  3314. /*  Take the data contained in the packet data structure and        */
  3315. /*  turn it into a regular string, undoing all of the quoting       */
  3316. /*  that was performed on the other end.                            */
  3317. /********************************************************************/
  3318.  
  3319.     dcl indx fixed bin;
  3320.     dcl ret_str char(100) var;
  3321.     dcl num_scanned fixed bin;
  3322.     dcl data_str char(*) var;
  3323.  
  3324. /*=====================  Begin packet_parm.incl.pl1  ====================*/
  3325.  
  3326.    dcl 1 packet,
  3327.          2 type char(1),
  3328.          2 len fixed bin(21),
  3329.          2 num fixed bin,
  3330.          2 data (*) char(1);
  3331.  
  3332. /*======================  End packet_parm.incl.pl1  =====================*/
  3333.  
  3334.  
  3335. /********************************************************************/
  3336. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  3337. /********************************************************************/
  3338.  
  3339. indx = 1;
  3340. num_scanned = 0;
  3341. data_str = "";
  3342.  
  3343. do while (indx ^> len);
  3344.    call undo_repeat (data, indx, num_scanned, ret_str);
  3345.    data_str = data_str || ret_str;
  3346.    indx = indx + num_scanned;
  3347.    end;
  3348.  
  3349. return;
  3350. end unquote_packet;
  3351.  
  3352. undo_repeat: proc (data, indx, num_scanned, ret_str);
  3353. /********************************************************************/
  3354. /*  Expand the character by the number of times specified in the    */
  3355. /*  repeat field if it is present.                                  */
  3356. /********************************************************************/
  3357.  
  3358.     dcl data(*) char(1);
  3359.     dcl indx fixed bin;
  3360.     dcl num_scanned fixed bin;
  3361.     dcl ret_str char(*) var;
  3362.  
  3363.     dcl t_indx fixed bin;
  3364.     dcl fin_str char(100) var init("");
  3365.     dcl t_str char(10) var;
  3366.     dcl repeat_count fixed bin;
  3367.  
  3368. /********************************************************************/
  3369. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  3370. /********************************************************************/
  3371.  
  3372. if repeat_char = blank then  /* Skip repeat quoting */
  3373. do;
  3374.    call undo_trans (data, indx, num_scanned, ret_str);
  3375.    end;
  3376.  
  3377. else
  3378. do;
  3379.    if data(indx) = repeat_char then
  3380.    do;
  3381.      repeat_count = unchar (data(indx+1));
  3382.      call undo_trans (data, indx+2, num_scanned, t_str);
  3383.      num_scanned = num_scanned + 2;
  3384.      do t_indx = 1 to repeat_count;
  3385.        fin_str = fin_str || t_str;
  3386.        end;
  3387.      ret_str = fin_str;
  3388.      end;
  3389.  
  3390.    else
  3391.    do;
  3392.      call undo_trans (data, indx, num_scanned, ret_str);
  3393.      end;
  3394.    end;
  3395.  
  3396. return;
  3397. end undo_repeat;
  3398.  
  3399. undo_trans: proc (data, indx, num_scanned, char);
  3400. /********************************************************************/
  3401. /*  Undo any character translation done in sending                  */
  3402. /********************************************************************/
  3403.  
  3404.     dcl data(*) char(1);
  3405.     dcl indx fixed bin;
  3406.     dcl num_scanned fixed bin;
  3407.     dcl char char(*) var;
  3408.  
  3409. /********************************************************************/
  3410. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  3411. /********************************************************************/
  3412.  
  3413. /*** This is a dummy routine since Multics is an ascii machine ***/
  3414. call undo_ctl (data, indx, num_scanned, char);
  3415.  
  3416. return;
  3417. end undo_trans;
  3418.  
  3419. undo_ctl: proc (data, indx, num_scanned, ret_char);
  3420. /********************************************************************/
  3421. /*  Undo control prefixing.  If repeat quoting, parity quoting      */
  3422. /*  are allowed, these characters will also be quoted, otherwise    */
  3423. /*  they are literals                                               */
  3424. /********************************************************************/
  3425.  
  3426.     dcl data(*) char(1);
  3427.     dcl indx fixed bin;
  3428.     dcl num_scanned fixed bin;
  3429.     dcl char char(1);
  3430.     dcl l7_char char(1) aligned;
  3431.     dcl l7_bit_rep bit(9) based(addr(l7_char));
  3432.     dcl lower_seven_bits bit(9) static init("001111111"b);
  3433.     dcl ret_char char(*) var;
  3434.  
  3435.     dcl handle_parity bit(1) init(false);
  3436.     dcl t_indx fixed bin;
  3437.     dcl char_type fixed bin;
  3438.  
  3439.     dcl special_chars char(3) init(eight_bit_quote_char || repeat_char || remote_quote);
  3440.  
  3441. /********************************************************************/
  3442. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  3443. /********************************************************************/
  3444.  
  3445. if data(indx) = eight_bit_quote_char & eight_bit_quote then
  3446. do;
  3447.    handle_parity = true;
  3448.    num_scanned = 1;
  3449.    t_indx = indx + 1;
  3450.    end;
  3451. else
  3452. do;
  3453.    num_scanned = 0;
  3454.    t_indx = indx;
  3455.    end;
  3456.  
  3457. if data(t_indx) ^= remote_quote then   /* Easy out */
  3458. do;
  3459.    num_scanned = num_scanned + 1;
  3460.    ret_char = data(t_indx);
  3461.    end;
  3462.  
  3463. else
  3464. do;
  3465.    num_scanned = num_scanned + 2;
  3466.    char = data(t_indx+1);
  3467.    l7_char = char;
  3468.    l7_bit_rep = l7_bit_rep  &  lower_seven_bits;
  3469.    char_type = index(special_chars, l7_char);
  3470.  
  3471.    if char_type = 0 then char_type = length(special_chars)+1;  /* Reg ctl quote */
  3472.    goto case(char_type);
  3473.  
  3474.    case(1): /* Parity quote character */
  3475.             if eight_bit_quote then ret_char = char;
  3476.                                else ret_char = unctl(char);
  3477.             goto endcase;
  3478.  
  3479.    case(2): /* Repeat quote character */
  3480.             if repeat_char ^= blank then ret_char = char;
  3481.                                else ret_char = unctl(char);
  3482.             goto endcase;
  3483.  
  3484.    case(3): /* Quote character */
  3485.             ret_char = char;
  3486.             goto endcase;
  3487.  
  3488.    case(4): /* Standard ctl quoting */
  3489.             ret_char = unctl(char);
  3490.             goto endcase;
  3491.  
  3492.    endcase: ;
  3493.    end;
  3494.  
  3495. if handle_parity then call undo_parity (ret_char);
  3496.  
  3497. return;
  3498. end undo_ctl;
  3499.  
  3500. undo_parity: proc (ret_str);
  3501. /********************************************************************/
  3502. /*>>>>>>>>>>>>>>>>>>>>  SYSTEM DEPENDENCY  <<<<<<<<<<<<<<<<<<<<<<<<<*/
  3503. /********************************************************************/
  3504. /*  Undo the parity quoting if enabled and present                  */
  3505. /********************************************************************/
  3506.  
  3507.     dcl ret_str char(*) var;
  3508.  
  3509.     dcl char char(1) aligned;
  3510.     dcl bit_rep bit(9) based(addr(char));
  3511.     dcl parity_bit bit(9) static init("010000000"b);
  3512.  
  3513. /********************************************************************/
  3514. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  3515. /********************************************************************/
  3516.  
  3517. char = ret_str;    /** Prepare to add parity bit **/
  3518. bit_rep = bit_rep | parity_bit;
  3519. ret_str = char;
  3520.  
  3521. return;
  3522. end undo_parity;
  3523.  
  3524. log_receive: proc(lptr, llen);
  3525. /********************************************************************/
  3526. /*  Log received packets in trace_file                              */
  3527. /********************************************************************/
  3528.  
  3529.     dcl time_str char(12) var;
  3530.     dcl line char(llen) based(lptr);
  3531.     dcl lptr ptr;
  3532.     dcl llen fixed bin(21);
  3533.  
  3534. time_str = time();
  3535. time_str = substr(time_str,3,2) || ":" || substr(time_str,5,2);
  3536.  
  3537. if llen > 0 then put file(trace_file) edit(time_str, "R", line)(a,x(1));
  3538.             else put file(trace_file) edit(time_str, "R", "- null packet -")(a,x(1));
  3539. put file(trace_file) skip;
  3540. return;
  3541. end log_receive;
  3542.  
  3543.  
  3544.  
  3545. log_trans: proc(packet_line);
  3546. /********************************************************************/
  3547. /*  Log transmitted packets in trace_file                           */
  3548. /********************************************************************/
  3549.  
  3550.     dcl packet_line char(*) var;
  3551.     dcl time_str char(12) var;
  3552.  
  3553. time_str = time();
  3554. time_str = substr(time_str,3,2) || ":" || substr(time_str,5,2);
  3555.  
  3556. put file(trace_file) edit(time_str, "T", packet_line)(a,x(1));
  3557. put file(trace_file) skip;
  3558.  
  3559. return;
  3560. end log_trans;
  3561.  
  3562.  
  3563.  
  3564.  
  3565. flush_input_buffer: proc;
  3566. /********************************************************************/
  3567. /*>>>>>>>>>>>>>>>>>>>>     System Dependency     <<<<<<<<<<<<<<<<<<<*/
  3568. /********************************************************************/
  3569. /********************************************************************/
  3570. /*  A call to iox_$control to clean out the input buffer            */
  3571. /********************************************************************/
  3572.  
  3573.     dcl lcl_code fixed bin(35);
  3574.  
  3575. call iox_$control (tty_iocb, "resetread", null(), lcl_code);
  3576. return;
  3577.  
  3578. end flush_input_buffer;
  3579.  
  3580.  
  3581.  
  3582. exec_com: proc(line);
  3583. /********************************************************************/
  3584. /*>>>>>>>>>>>>>>>>>>>>     System Dependency     <<<<<<<<<<<<<<<<<<<*/
  3585. /********************************************************************/
  3586. /********************************************************************/
  3587. /*  Pass line along to the command processor.                       */
  3588. /********************************************************************/
  3589.  
  3590.     dcl line char(*) var;
  3591.     dcl com_line char(length(line)) aligned init(line);
  3592.  
  3593. /********************************************************************/
  3594. /*>>>>>>>>>>>>>>>>>>>>>>>>>>>  Procedure  <<<<<<<<<<<<<<<<<<<<<<<<<<*/
  3595. /********************************************************************/
  3596.  
  3597. call cu_$cp(addr(com_line), length(line), code);
  3598.  
  3599. return;
  3600. end exec_com;
  3601.  
  3602. setup_terminal: proc (code);
  3603. /********************************************************************/
  3604. /*>>>>>>>>>>>>>>>>>>>>     System Dependency     <<<<<<<<<<<<<<<<<<<*/
  3605. /********************************************************************/
  3606. /********************************************************************/
  3607. /*  Configure the terminal modes so that packets will get           */
  3608. /*  through the fnp. See note on new_term_modes in beginning.       */
  3609. /********************************************************************/
  3610.  
  3611.     dcl code fixed bin(35);
  3612.  
  3613.  
  3614. call iox_$control (tty_iocb, "set_framing_chars", addr(new_framing_chars), code);
  3615. if code ^= 0 then return;
  3616.  
  3617. call iox_$modes (tty_iocb, term_modes, "", code);
  3618.  
  3619. return;
  3620. end setup_terminal;
  3621.  
  3622.  
  3623.  
  3624. reset_terminal: proc (code);
  3625. /********************************************************************/
  3626. /*>>>>>>>>>>>>>>>>>>>>     System Dependency     <<<<<<<<<<<<<<<<<<<*/
  3627. /********************************************************************/
  3628. /********************************************************************/
  3629. /*  Reverse action of above procedure                               */
  3630. /********************************************************************/
  3631.  
  3632.     dcl code fixed bin(35);
  3633.  
  3634. call iox_$modes (tty_iocb, old_term_modes, "", code);
  3635. if code ^= 0 then return;
  3636.  
  3637. call iox_$control (tty_iocb, "set_framing_chars", orig_fc_ptr, code);
  3638.  
  3639. return;
  3640. end reset_terminal;
  3641.  
  3642. end kermit_;
  3643.