kermit_: proc; /********************************************************************/ /* This is the kermit protocol machine. */ /* */ /* The kermit_ procedure contains all of the procedures to */ /* handle packet transfer from the micro. Major entry points */ /* are send to send a file, receive to receive one or more */ /* files and server to act as a kermit slave. */ /********************************************************************/ /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>> Declarations <<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ dcl info_ptr ptr parameter; /* Points to the structure below. */ dcl code fixed bin(35) parameter; dcl err_msg char(*) var parameter; /********************************************************************/ /* Communications structure */ /********************************************************************/ /*================== Begin kermit_info.incl.pl1 ==================*/ dcl 1 kermit_info based(info_ptr), 2 state char(2), /* Present state of automaton */ 2 size fixed bin, /* Size of present data */ 2 send_parameters, 3 stimint fixed bin(71), /* Timeout for foreign host on sends */ 3 sp_size fixed bin, /* Maximum send packet size */ 3 pad fixed bin, /* How much padding to send */ 3 pad_char fixed bin, /* Padding character to send */ 3 delay_time fixed bin(71), /* Time to delay for sends */ 3 end_of_line fixed bin, /* End-of-line to send */ 2 receive_parameters, 3 rp_size fixed bin, /* Maximum receive packet size */ 3 remote_quote char(1), /* Quote character, incomming data */ 3 r_eol fixed bin, /* End-of-line to receive */ 3 rtimint fixed bin(71), /* Timeout for host on receives */ 2 max_try fixed bin, /* Times to retry a packet */ 2 num_try fixed bin, /* Times this packet retried */ 2 eight_bit_quote_char char(1),/* Char for quoting 8 bit stuff */ 2 repeat_char char(1), /* CHar for flagging repeat sequences */ 2 chktype fixed bin, /* Type of check code to actually use */ 2 current_packet_no fixed bin, /* Looking for msg number ... */ 2 behavior_switches, 3 trace_sw bit(1), /* Log packets to trace file */ 3 debug_sw bit(1), /* Obtain packets from ext. proc */ 3 eight_bit_quote bit(1), /* Parity quoting allowed */ 3 repeat_allowed bit(1), /* Character compression allowed */ 3 repeat_threshold fixed bin, /* Min # of chars to compress */ 3 text_mode bit(1), /* Type of files to send, init true */ 3 file_warning_sw bit(1), /* Overwrite file warning */ 2 pointers, 3 file_list_ptr ptr, /* Ptr to list of files */ 3 tty_iocb ptr, /* Ptr to tty iocb for modes sw. */ 3 input_bfr_ptr ptr, /* Ptr to input buffer */ 3 orig_fc_ptr ptr, /* Ptr to orig. framing chars */ 3 misc_symbol_ptr ptr, /* Ptr to structure holding some symbls */ 2 other_info, 3 default_dir char(168), /* Default for send or receive */ 3 term_modes char(256), /* To setup terminal for transfer */ 3 old_term_modes char(512), /* For restoring term on completion */ 3 cur_file fixed bin, /* Current file pointer in list */ 3 allowed_ck_codes char(3), /* Allowed error check codes */ 3 default_ck_code fixed bin, /* Type of check code to use by default */ 3 help_dir char(168), /* Help directory */ 2 status_indicators, 3 return_code fixed bin(35), 3 total_packet_trns fixed bin, 3 total_packet_rcvd fixed bin, 3 total_retry_count fixed bin, 3 files_rcvd fixed bin, 3 files_trns fixed bin, 3 failures fixed bin, 3 last_file_transferred char(168); /* Name of last file */ /*=================== End kermit_info.incl.pl1 ===================*/ /********************************************************************/ /* Constants */ /********************************************************************/ /*=============== Begin control_constants.incl.pl1 ===============*/ /********************************************************************/ /* This structure avoids using embedded control characters in */ /* the source. Multics characters are nine bits. */ /********************************************************************/ dcl 1 binary_codes static options(constant) aligned, 2 bits_NULL bit(9) init("000000000"b), 2 bits_CR bit(9) init("000001101"b), 2 bits_LF bit(9) init("000001010"b), 2 bits_CTL_Z bit(9) init("000011010"b), 2 bits_SOH bit(9) init("000000001"b), 2 bits_tilde bit(9) init("001111110"b); dcl 1 overlay_chars based(addr(binary_codes)) aligned, 2 NULL char(1), 2 CR char(1), 2 LF char(1), 2 CTL_Z char(1), 2 SOH char(1), 2 tilde char(1); /*================ End control_constants.incl.pl1 ================*/ dcl big char(26) static options(constant) init("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); dcl sml char(26) static options(constant) init("abcdefghijklmnopqrstuvwxyz"); dcl numbers char(10) static options(constant) init("0123456789"); dcl null_char char(1) init(NULL); dcl null_str char(1) var static init("") options(constant); dcl space char(1) static init(" ") options(constant); dcl colon char(1) static init(":") options(constant); dcl car_ret fixed bin static options(constant) init(13); dcl false bit(1) static options(constant) init("0"b); dcl blank char(1) static options(constant) init(" "); dcl ampersand char(1) static options(constant) init("&"); dcl true bit(1) static options(constant) init("1"b); dcl carraige_return char(1) init(CR); dcl line_feed char(1) init(LF); /********************************************************************/ /* Symbols */ /********************************************************************/ /*================= Begin kermit_symbols.incl.pl1 ================*/ dcl 1 misc_symbols based(misc_symbol_ptr), 2 max_packet_size fixed bin, 2 my_quote char(1), 2 my_pad fixed bin, 2 my_pad_char fixed bin, 2 my_end_of_line fixed bin; /*================== End kermit_symbols.incl.pl1 =================*/ /********************************************************************/ /* Allowed states for the packet automata */ /********************************************************************/ dcl abort_state char(2) static options(constant) init("A"); dcl completed_state char(2) static options(constant) init("C"); dcl send_init_state char(2) static options(constant) init("SI"); dcl send_file_state char(2) static options(constant) init("SF"); dcl send_data_state char(2) static options(constant) init("SD"); dcl send_eof_state char(2) static options(constant) init("SE"); dcl send_break_state char(2) static options(constant) init("SB"); dcl receive_init_state char(2) static options(constant) init("RI"); dcl receive_data_state char(2) static options(constant) init("RD"); dcl receive_file_state char(2) static options(constant) init("RF"); dcl server_state char(2) static options(constant) init("SS"); dcl send_hdr_state char(2) static options(constant) init("SH"); /********************************************************************/ /* Allowed packet types */ /********************************************************************/ dcl file_type char(1) static options(constant) init("F"); dcl data_type char(1) static options(constant) init("D"); dcl eof_type char(1) static options(constant) init("Z"); dcl break_type char(1) static options(constant) init("B"); dcl ack_type char(1) static options(constant) init("Y"); dcl nack_type char(1) static options(constant) init("N"); dcl send_type char(1) static options(constant) init("S"); dcl error_type char(1) static options(constant) init("E"); dcl receive_init_type char(1) static options(constant) init("R"); dcl host_com_type char(1) static options(constant) init("C"); dcl generic_type char(1) static options(constant) init("G"); dcl text_hdr_type char(1) static options(constant) init("X"); dcl info_type char(1) static options(constant) init("I"); dcl last_char_sent char(1) var init(""); /* Flag for transmitting crlfs */ dcl last_char_received char(1) var; /* Flag for receiving same */ dcl segment char(1000000) based(transmit_seg_ptr); /* Info to send */ dcl transmit_seg_ptr ptr init(null()); dcl cur_character fixed bin(24); /* Current character ptr */ /********************************************************************/ /* These are the terminal modes that kermit will attempt to */ /* use. These settings are nominal for connection to Multics */ /* via an FNP through either a hard wired line or dial up (the */ /* fnp requires blk_xfer to handle the packet of characters */ /* in the absense of xon-xoff protocols which are not supported */ /* by the majority of kermits; there are also reports that the fnp */ /* does not handle xon-xoff well at 9600. Finally, even if it did */ /* downward compatibility is still needed). */ /* */ /* The force mode will prevent error codes from arising in the */ /* case of networks where some of these modes are not */ /* appropriate. */ /* */ /* This information has been moved to the info structure so that */ /* the user may change the default values. It is left here as a */ /* reminder on what happers on this end. */ /********************************************************************/ /* dcl term_modes char(256) static init("rawi,rawo,no_outp,8bit,^echoplex"|| /* ",crecho,lfecho,^replay,^polite,^breakall,blk_xfer,force,ctl_char"); */ /********************************************************************/ /* Error codes */ /********************************************************************/ dcl too_many_tries fixed bin static options(constant) init(21); dcl wrong_packet_type fixed bin static options(constant) init(22); dcl unknown_state fixed bin static options(constant) init(23); dcl wrong_packet_no fixed bin static options(constant) init(24); dcl cpu_err fixed bin static options(constant) init(25); dcl no_file fixed bin static options(constant) init(26); dcl record_quota_ov fixed bin static options(constant) init(27); dcl file_overwrite fixed bin static options(constant) init(28); dcl cant_get_seg fixed bin static options(constant) init(29); dcl unknown_server_cmd fixed bin static options(constant) init(30); dcl unknown_generic_cmd fixed bin static options(constant) init(31); /********************************************************************/ /* Multics routines */ /********************************************************************/ dcl continue_to_signal_ entry (fixed bin(35)); dcl cu_$cp entry (ptr, fixed bin(21), fixed bin(35)); dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)); dcl get_pdir_ entry returns(char(168)); dcl get_temp_segment_ entry(char(*), ptr, fixed bin(35)); dcl get_wdir_ entry returns(char(168)); dcl hcs_$initiate_count entry (char(*), char(*), char(*), fixed bin(24), fixed bin(1), ptr, fixed bin(35)); dcl hcs_$terminate_noname entry (ptr, fixed bin(35)); dcl ioa_ entry options(variable); dcl ioa_$nnl entry options(variable); dcl iox_$control entry(ptr, char(*), ptr, fixed bin(35)); dcl iox_$find_iocb entry(char(*), ptr, fixed bin(35)); dcl iox_$get_line entry(ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)); dcl iox_$modes entry (ptr, char(*), char(*), fixed bin(35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin(21), fixed bin(35)); dcl release_temp_segment_ entry(char(*), ptr, fixed bin(35)); dcl timer_manager_$alarm_call entry (fixed bin(71), bit(2), entry); dcl timer_manager_$reset_alarm_call entry (entry); dcl timer_manager_$sleep entry (fixed bin(71), bit(2)); dcl unique_bits_ entry returns(bit(70)); dcl unique_chars_ entry(bit(*)) returns(char(15)); /********************************************************************/ /* Routines to handle on-line debugging through pipe */ /********************************************************************/ dcl kermit_db_$get_packet entry (ptr, fixed bin(21), fixed bin(21), fixed bin(71), bit(1)); dcl kermit_db_$send_packet entry (char(*) var); dcl kermit_db_$init entry; dcl kermit_db_$term entry; /********************************************************************/ /* Other variables */ /********************************************************************/ dcl return_lf bit(1) init(false); dcl enable_ctl_quoting bit(1) init(true); dcl eof_flag bit(1) init(false); dcl input_bfr_len fixed bin(21) static init(100); dcl cur_inpt_bfr_len fixed bin(21); dcl input_buffer char(input_bfr_len) aligned based(input_bfr_ptr); dcl output_iocb_ptr ptr; dcl rel_secs_flag bit(2) static options(constant) init("11"b); dcl seg_length fixed bin(24); /* Number of CHARACTERS to send */ dcl trace_file file; dcl in_command bit(1) init(false); /* Used for server checksum types on succ. packets */ dcl status bit(1); dcl indx fixed bin; dcl server bit(1) init(false); /* Turned on by server entry point */ dcl 1 files based(file_list_ptr), 2 max_num_files fixed bin, 2 num_files fixed bin, 2 names (max_num_files), 3 dir char(168), 3 entry char(32); dcl 1 cur_file_name, 2 dir char(168), 2 entry char(32); /********************************************************************/ /* Conditions */ /********************************************************************/ dcl quit condition; dcl error condition; dcl record_quota_overflow condition; /********************************************************************/ /* Blck transfer framing character info structures. */ /********************************************************************/ dcl 1 orig_framing_chars based(orig_fc_ptr) aligned, 2 start_char char(1) unaligned, 2 end_char char(1) unaligned; dcl 1 new_framing_chars aligned, 2 start_char char(1) unaligned init(NULL), /* no start char */ 2 end_char char(1) unaligned init(CR); /********************************************************************/ /* Builtin functions */ /********************************************************************/ dcl null builtin; dcl length builtin; dcl time builtin; send: entry (info_ptr, code, err_msg); /********************************************************************/ /* This is the external interface to the send_stuff kermit */ /* routine. */ /********************************************************************/ chktype = 1; /* Assume first packet uses standard check sum */ state = send_init_state; num_try = 0; current_packet_no = 0; call send_stuff; return; receive: entry (info_ptr, code, err_msg); /********************************************************************/ /* This is the external interface to the receive_stuff kermit */ /* routine. */ /********************************************************************/ chktype = 1; /* Assume first packet uses standard checksum */ state = receive_init_state; num_try = 0; current_packet_no = 0; call receive_stuff; return; server: entry (info_ptr, code, err_msg); /********************************************************************/ /* This is the controlling procedure for the kermit server. */ /********************************************************************/ /* Reset terminal on quit (especially echoplex) */ on quit begin; if trace_sw then close file(trace_file); call reset_terminal (code); call continue_to_signal_ (code); end; /* If any other error condition arises, reset the terminal and */ /* continue to signal the condition upward. */ on error begin; state = abort_state; kermit_info.return_code = cpu_err; call error_control; if trace_sw then close file(trace_file); call continue_to_signal_ (code); end; /* If the trace is enabled, open the file */ if trace_sw then open file(trace_file) title("vfile_ kermit.trace -extend") output; if debug_sw then call kermit_db_$init; /* Init event channels for ipc */ state = server_state; server = true; chktype = 1; if ^debug_sw then /* Change terminal modes, not necessary under debug */ do; call setup_terminal (code); if code ^= 0 then /* Bad news; won't get badmode because of force, so */ do; /* this is serious */ kermit_info.return_code = code; err_msg = term_modes; return; end; call flush_input_buffer; end; do while(state = server_state); current_packet_no = 0; num_try = 0; call exec_server_command; end; /* Only get here if finish command is executed. */ call reset_terminal (code); if trace_sw then close file(trace_file); if debug_sw then call kermit_db_$term; return; exec_server_command: proc; /********************************************************************/ /* This procedure obtains a packet from the remote system, */ /* identifies the command info and executes it. */ /********************************************************************/ /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>> Declarations <<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ /*===================== Begin packet.incl.pl1 ====================*/ dcl 1 packet, 2 type char(1), 2 len fixed bin(21), 2 num fixed bin, 2 data (max_packet_size) char(1); /*====================== End packet.incl.pl1 =====================*/ dcl status bit(1); dcl comm_str char(255) var init(""); dcl pathname char(168) var init(""); dcl indx fixed bin; dcl code fixed bin(35); dcl chktype_to_send fixed bin; dcl packet_types char(5) init(send_type || receive_init_type || info_type || host_com_type || generic_type); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ call receive_packet (packet, 5*rtimint, status); /* Longer timeout interval */ if status = false then /* Didnt get anything, send a nack anyway */ do; call send_nack (current_packet_no); return; end; /********************************************************************/ /* Got a potential server command, check it out */ /********************************************************************/ indx = index (packet_types, type); if indx = 0 then indx = length(packet_types)+1; goto case(indx); case(1): /* Send initiate packet, we will be getting a file uploaded */ call obtain_parms(packet, chktype_to_send); call send_init_packet (current_packet_no, chktype_to_send, ack_type); state = receive_file_state; chktype = chktype_to_send; current_packet_no = mod(current_packet_no+1,64); cur_file = 0; /* Get filename from packet */ call receive_stuff; /* Get file */ state = server_state; chktype = 1; current_packet_no = 0; num_try = 0; goto endcase; case(2): /* Receive initiate packet, send a file down */ do indx = 1 to len; pathname = pathname || data(indx); end; if index(pathname,">") > 0 | index(pathname,"<")>0 then call expand_pathname_ ((pathname), files.names(1).dir, files.names(1).entry, code); else do; files.names(1).dir = default_dir; files.names(1).entry = pathname; end; /* Check for file existence */ if ^file_exists(files.names(1).dir, files.names(1).entry) then do; kermit_info.return_code = cant_get_seg; call error_control; state = server_state; /* Reset to continue */ end; else do; num_files = 1; cur_file = 1; state = send_init_state; current_packet_no = mod(current_packet_no+1, 64); call send_stuff; state = server_state; chktype = 1; current_packet_no = 0; num_try = 0; end; goto endcase; case(3): /* Initialize Parameters */ call obtain_parms(packet, chktype_to_send); call send_init_packet (current_packet_no, chktype_to_send, ack_type); chktype = chktype_to_send; goto endcase; case(4): /* Host command, send data to command processor */ call unquote_packet (packet, comm_str); if index(comm_str,CR)>0 then comm_str = substr(comm_str,1,index(comm_str,CR)-1); call exec_com_snd_out_back(comm_str); chktype = 1; goto endcase; case(5): /* Generic kermit command */ call unquote_packet (packet, comm_str); if index(comm_str,CR)>0 then comm_str = substr(comm_str,1,index(comm_str,CR)-1); call exec_generic_cmd (comm_str); chktype = 1; goto endcase; case(6): /* Didnt know what that one was */ /* Send an error back to micro */ kermit_info.return_code = unknown_server_cmd; call error_control; chktype = 1; goto endcase; endcase: return; end exec_server_command; exec_generic_cmd: proc (comm_str); /********************************************************************/ /* Execute the kermit server command contained in the data array */ /********************************************************************/ dcl comm_str char(*) var; dcl indx fixed bin; dcl allowed_commands char(7) static init("FLDCTHQ"); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ indx = index(allowed_commands, substr(comm_str,1,1)); if indx = 0 then indx = length(allowed_commands)+1; goto case(indx); case(1): /* Finish command */ call send_ack (current_packet_no); state = completed_state; goto endcase; case(2): /* Logout */ call send_ack (current_packet_no); call exec_com ("logout"); /*** No metering info yet ***/ state = completed_state; goto endcase; /* Just for form (and in case...) */ case(3): /* What directory are we in */ call exec_com_snd_out_back ("pwd"); goto endcase; case(4): /* Change working directory, and default dir */ call exec_com_snd_out_back ("cwd " || decode_len(substr(comm_str,2))); default_dir = get_wdir_(); /* Get it if we were succesful */ goto endcase; case(5): /* Type (print) a file */ call exec_com_snd_out_back ("print " || decode_len(substr(comm_str,2))); goto endcase; case(6): /* Help */ call exec_com_snd_out_back ("print " || rtrim(help_dir) || ">server_online.k.info"); goto endcase; case(7): /* Server Query */ call exec_com_snd_out_back ("kermit -status"); goto endcase; case(8): /* Unknown type */ call exec_com_snd_out_back ("ioa_ ""Command unknown or not implemented."""); goto endcase; endcase: return; end exec_generic_cmd; exec_com_snd_out_back: proc (command); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>> System Dependency <<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ /********************************************************************/ /* Execute a command on the system that generates output; put */ /* it into a temp file in the [pd] and send the contents of the */ /* file down to the micro. */ /********************************************************************/ dcl command char(*) var; /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ call exec_com ("fo [pd]>kermit.tmp -tc;so user_output -ssw error_output"); call exec_com ((command)); call exec_com ("ro -all"); /********************************************************************/ /* Result of command now resides in kermit.tmp in pd. Transfer */ /* it down. */ /********************************************************************/ files.names(1).dir = get_pdir_(); files.names(1).entry = "kermit.tmp"; num_files = 1; cur_file = 1; state = send_hdr_state; call send_stuff; state = server_state; return; end exec_com_snd_out_back; decode_len: proc (line) returns(char(*) var); /********************************************************************/ /* Decode length character in string and return stirng of that len */ /********************************************************************/ dcl line char(*) var; dcl t_line char(length(line)) var; dcl len_char char(1); if length(line) < 2 then return(""); len_char = substr(line,1,1); t_line = substr(line, 2, min(length(line)-1, unchar(len_char))); return(t_line); end decode_len; send_stuff: proc; /********************************************************************/ /* Controlling procedure for sending message packets. */ /********************************************************************/ dcl loop bit(1) init(true); dcl send_states char(16) init(send_hdr_state || send_data_state || send_file_state || send_eof_state || send_init_state || send_break_state || completed_state || abort_state); /* Reset terminal on quit (especially echoplex) */ if ^server then on quit begin; if trace_sw then close file(trace_file); call reset_terminal (code); call continue_to_signal_ (code); end; /* If any other error condition arises, reset the terminal and */ /* continue to signal the condition upward. */ if ^server then on error begin; call reset_terminal (code); /* If it didn't work, we're already in trouble */ state = abort_state; kermit_info.return_code = cpu_err; call error_control; if trace_sw then close file(trace_file); call continue_to_signal_ (code); end; /* If the trace is enabled, open the file */ if trace_sw then open file(trace_file) title("vfile_ kermit.trace -extend") output; /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ if debug_sw & ^server then call kermit_db_$init; /* Init event channels for ipc */ cur_file_name = files.names(cur_file); if ^server then call ioa_("OK"); if delay_time > 0 & ^server then /* Delay for time */ do; call timer_manager_$sleep (delay_time, rel_secs_flag); end; if ^debug_sw & ^server then /* Change terminal modes, not necessary under debug */ do; call setup_terminal (code); if code ^= 0 then /* Bad news; won't get badmode because of force, so */ do; /* this is serious */ kermit_info.return_code = code; err_msg = term_modes; return; end; call flush_input_buffer; end; do while(loop); indx = index(send_states, state); if indx = 0 then indx = (length(send_states)+2)/2; else indx = (indx + 1) / 2; /* Two character state names */ goto case(indx); case(1): /* Send text header (only from server) */ call send_hdr; goto end_case; case(2): /* Send data */ call send_data; goto end_case; case(3): /* Send file */ call send_file; goto end_case; case(4): /* End of file */ call send_eof; goto end_case; case(5): /* Send initial packet */ call send_init; goto end_case; case(6): /* Send a break packet */ call send_break; goto end_case; case(7): /* Transmission Complete */ kermit_info.return_code = 0; loop = false; goto end_case; case(8): /* Abort transmission */ case(9): /* Unknown state */ failures = failures + 1; loop = false; goto end_case; end_case: end; if ^server then do; call reset_terminal (code); if debug_sw then call kermit_db_$term; /* Terminate comm seg */ end; if state = abort_state then call error_control; if trace_sw then close file(trace_file); return; end send_stuff; receive_stuff: proc; /********************************************************************/ /* Receive one or more files. */ /********************************************************************/ /*===================== Begin packet.incl.pl1 ====================*/ dcl 1 packet, 2 type char(1), 2 len fixed bin(21), 2 num fixed bin, 2 data (max_packet_size) char(1); /*====================== End packet.incl.pl1 =====================*/ dcl loop bit(1) init(true); dcl rec_states char(10) init(receive_init_state || receive_file_state || receive_data_state || completed_state || abort_state); /* Reset terminal on quit (especially echoplex) */ if ^server then on quit begin; if trace_sw then close file(trace_file); call reset_terminal (code); call continue_to_signal_ (code); end; /* If any other error condition arises, reset the terminal and */ /* continue to signal the condition upward. */ if ^server then on record_quota_overflow begin; call reset_terminal (code); /* Ignore it if we can't reset things to the way they were. */ state = abort_state; kermit_info.return_code = record_quota_ov; call error_control; if trace_sw then close file(trace_file); call continue_to_signal_ (code); end; if ^server then /* Server has its own traps */ on error begin; call reset_terminal (code); state = abort_state; kermit_info.return_code = cpu_err; call error_control; if trace_sw then close file(trace_file); call continue_to_signal_ (code); end; /* If trace enabled, open file */ if trace_sw then open file(trace_file) title("vfile_ kermit.trace -extend") output; if debug_sw & ^server then call kermit_db_$init; /* Init event channels */ if ^server then call ioa_("OK"); if ^debug_sw & ^server then do; /* Set stty to handle 8 bit no parity raw io */ call setup_terminal (code); if code ^= 0 then /* Bad news; badmode won't come back because of force */ do; /* so something else must have gone wrong. */ kermit_info.return_code = code; err_msg = term_modes; return; end; call flush_input_buffer; end; do while(loop); indx = index(rec_states, state); if indx = 0 then indx = length(rec_states)/2 + 1; else indx = (indx+1) / 2; goto rec_case(indx); rec_case(1): /* Receive an initial packet */ call receive_init; goto rec_endcase; rec_case(2): /* Receive a file header */ call receive_file; goto rec_endcase; rec_case(3): /* Receive data */ call receive_data; goto rec_endcase; rec_case(4): /* Transfer complete */ loop = false; goto rec_endcase; rec_case(5): /* Something failed, in abort */ failures = failures + 1; loop = false; goto rec_endcase; /*** rec_case(6): /* ERROR packet */ rec_case(6): /* Unknown state, abort */ state = abort_state; kermit_info.return_code = unknown_state; loop = false; goto rec_endcase; rec_endcase: end; /* Reset terminal to handle normal I/O */ if ^server then do; if debug_sw then call kermit_db_$term; /* Terminate com seg */ call reset_terminal (code); end; if state = abort_state then call error_control; if trace_sw then close file(trace_file); return; end receive_stuff; send_data: proc; /********************************************************************/ /* Send a data packet */ /********************************************************************/ /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>> Declarations <<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ /*===================== Begin packet.incl.pl1 ====================*/ dcl 1 packet, 2 type char(1), 2 len fixed bin(21), 2 num fixed bin, 2 data (max_packet_size) char(1); /*====================== End packet.incl.pl1 =====================*/ dcl backup_pt fixed bin(24); dcl indx fixed bin; dcl status bit(1); dcl packet_types char(2) init(ack_type || nack_type); if num_try > max_try then do; state = abort_state; kermit_info.return_code = too_many_tries; return; end; num_try = num_try + 1; if num_try > 1 then total_retry_count = total_retry_count + 1; backup_pt = cur_character; /* This is a little tacky, but nec. to resend */ /* data after nack */ call build_data_packet (packet); call send_packet (packet); call receive_packet (packet, stimint, status); if status = false then do; cur_character = backup_pt; return; end; indx = index(packet_types, type); if indx = 0 then indx = length(packet_types)+1; /* Unknown packet type */ goto case(indx); case(1): /* Ack */ if current_packet_no ^= num then return; if end_of_data_reached() then do; state = send_eof_state; end; current_packet_no = mod(current_packet_no+1, 64); num_try = 0; goto endcase; case(2): /* Nack */ cur_character = backup_pt; /* Reset data pointer to resend */ goto endcase; case(3): /* Didnt expect this one */ state = abort_state; kermit_info.return_code = wrong_packet_type; goto endcase; endcase: return; end send_data; send_hdr: proc; /********************************************************************/ /* Send a text header packet. This is an indication in server */ /* mode that a lengthy reply is to follow. After the initial */ /* packet, transfer is identical to a regular file transfer. */ /********************************************************************/ /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>> Declarations <<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ /*===================== Begin packet.incl.pl1 ====================*/ dcl 1 packet, 2 type char(1), 2 len fixed bin(21), 2 num fixed bin, 2 data (max_packet_size) char(1); /*====================== End packet.incl.pl1 =====================*/ dcl indx fixed bin; dcl status bit(1); dcl packet_types char(2) init(ack_type || nack_type); if num_try > max_try then do; state = abort_state; kermit_info.return_code = too_many_tries; return; end; num_try = num_try + 1; if num_try > 1 then total_retry_count = total_retry_count + 1; type = text_hdr_type; len = 0; num = current_packet_no; call send_packet (packet); call receive_packet (packet, stimint, status); if status = false then return; indx = index(packet_types, type); if indx = 0 then indx = length(packet_types)+1; /* Unknown packet type */ goto case(indx); case(1): /* Ack */ if current_packet_no ^= num then return; state = send_data_state; call setup_seg_for_transmit; current_packet_no = mod(current_packet_no+1, 64); num_try = 0; goto endcase; case(2): /* Nack */ goto endcase; case(3): /* Didnt expect this one */ state = abort_state; kermit_info.return_code = wrong_packet_type; goto endcase; endcase: return; end send_hdr; send_file: proc; /********************************************************************/ /* Send a packet containing the name of the data file being */ /* sent. This operates similarly to send_init except when a */ /* correct ACK is received. In that case, the state changes to */ /* send_data_state and get_chars is called to fill up the data */ /* buffer to send to the foreign host. */ /********************************************************************/ /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>> Declarations <<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ /*===================== Begin packet.incl.pl1 ====================*/ dcl 1 packet, 2 type char(1), 2 len fixed bin(21), 2 num fixed bin, 2 data (max_packet_size) char(1); /*====================== End packet.incl.pl1 =====================*/ dcl indx fixed bin; dcl status bit(1); dcl packet_types char(2) init(ack_type || nack_type); if num_try > max_try then do; state = abort_state; kermit_info.return_code = too_many_tries; return; end; num_try = num_try + 1; if num_try > 1 then total_retry_count = total_retry_count + 1; call build_file_packet (packet); call send_packet (packet); call receive_packet (packet, stimint, status); if status = false then return; indx = index(packet_types, type); if indx = 0 then indx = length(packet_types)+1; /* Unknown packet type */ goto case(indx); case(1): /* Ack */ if current_packet_no ^= num then return; state = send_data_state; call setup_seg_for_transmit; current_packet_no = mod(current_packet_no+1, 64); num_try = 0; goto endcase; case(2): /* Nack */ goto endcase; case(3): /* Didnt expect this one */ state = abort_state; kermit_info.return_code = wrong_packet_type; goto endcase; endcase: return; end send_file; send_eof: proc; /********************************************************************/ /* Send an end-of-file packet. On ACK it call get_next_file */ /* which gets next file. If successful (another file to */ /* send), the state is changed to send_file_state. On failure, */ /* the state becomes break_connection_state. */ /********************************************************************/ /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>> Declarations <<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ /*===================== Begin packet.incl.pl1 ====================*/ dcl 1 packet, 2 type char(1), 2 len fixed bin(21), 2 num fixed bin, 2 data (max_packet_size) char(1); /*====================== End packet.incl.pl1 =====================*/ dcl indx fixed bin; dcl status bit(1); dcl packet_types char(2) init(ack_type || nack_type); if num_try > max_try then do; state = abort_state; kermit_info.return_code = too_many_tries; return; end; /********************************************************************/ /* Build EOF packet */ /********************************************************************/ type = eof_type; len = 0; num = current_packet_no; num_try = num_try + 1; if num_try > 1 then total_retry_count = total_retry_count + 1; call send_packet (packet); call finish_with_seg (code); call receive_packet (packet, stimint, status); if status = false then return; indx = index(packet_types, type); if indx = 0 then indx = length(packet_types)+1; /* Unknown packet type */ goto case(indx); case(1): /* Ack */ if current_packet_no ^= num then return; files_trns = files_trns + 1; /* Meter */ call get_next_file (status); if status = true then do; state = send_file_state; end; else do; state = send_break_state; end; current_packet_no = mod(current_packet_no+1,64); num_try = 0; goto endcase; case(2): /* Nack */ goto endcase; case(3): /* Didnt expect this one */ state = abort_state; kermit_info.return_code = wrong_packet_type; goto endcase; endcase: return; end send_eof; send_init: proc; /********************************************************************/ /* Initialize the connection with the other host. This is the */ /* prototype for the other packet sending routines. */ /********************************************************************/ /*===================== Begin packet.incl.pl1 ====================*/ dcl 1 packet, 2 type char(1), 2 len fixed bin(21), 2 num fixed bin, 2 data (max_packet_size) char(1); /*====================== End packet.incl.pl1 =====================*/ dcl packet_types char(2) init(ack_type || nack_type); dcl status bit(1); dcl indx fixed bin; dcl cktype_to_use fixed bin; /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ if num_try > max_try then /* Abort if too many tries */ do; state = abort_state; kermit_info.return_code = too_many_tries; return; end; num_try = num_try + 1; if num_try > 1 then total_retry_count = total_retry_count + 1; call send_init_packet (current_packet_no, default_ck_code, send_type); call receive_packet(packet, stimint, status); if status = false then return; /* Packet not received. */ indx = index(packet_types, type); if indx = 0 then indx = length(packet_types)+1; goto case(indx); case(1): if current_packet_no ^= num then return; /* Wrong ack */ call obtain_parms (packet, cktype_to_use); chktype = cktype_to_use; default_ck_code = chktype; /* Echo back to orig. */ state = send_file_state; num_try = 0; current_packet_no = mod(current_packet_no +1,64); goto endcase; case(2): goto endcase; /* Nack */ case(3): /********************************************************************/ /* Wrong packet type received. Goto abort state */ /********************************************************************/ state = abort_state; kermit_info.return_code = wrong_packet_type; goto endcase; endcase: ; return; end send_init; send_break: proc; /********************************************************************/ /* Send an EOT packet. This procedure may be called either in */ /* send_break_state or in abort_state. In the former, on ACK */ /* change to completed_state. The latter ignores the current */ /* state. */ /********************************************************************/ /*===================== Begin packet.incl.pl1 ====================*/ dcl 1 packet, 2 type char(1), 2 len fixed bin(21), 2 num fixed bin, 2 data (max_packet_size) char(1); /*====================== End packet.incl.pl1 =====================*/ dcl indx fixed bin; dcl packet_types char(2) init(ack_type || nack_type); dcl status bit(1); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ type = break_type; len = 0; num = current_packet_no; if num_try > max_try & state ^= abort_state then do; state = abort_state; kermit_info.return_code = too_many_tries; return; end; num_try = num_try + 1; if num_try > 1 then total_retry_count = total_retry_count + 1; call send_packet(packet); /********************************************************************/ /* Look for ack */ /********************************************************************/ call receive_packet (packet, stimint, status); if status = false then return; /* Send again or (if abort) ignore */ indx = index(packet_types, type); if indx = 0 then indx = length(packet_types)+1; goto case(indx); case(1): /* Ack */ if current_packet_no ^= num then goto endcase; /* Wrong one */ if state ^= abort_state then state = completed_state; num_try = 0; goto endcase; case(2): /* Nack */ goto endcase; case(3): /* Wrong packet type */ if state = abort_state then goto endcase; state = abort_state; kermit_info.return_code = unknown_state; goto endcase; endcase: return; end send_break; get_next_file: proc(status); /********************************************************************/ /* Get the next file in the current list of files to send. Put */ /* it into variable cur_file_name. If there isnt one, return */ /* status as false. */ /********************************************************************/ /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>> Declarations <<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ dcl status bit(1); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ cur_file = cur_file + 1; if cur_file > num_files then do; status = false; return; end; else do; cur_file_name = files.names(cur_file); end; return; end get_next_file; setup_seg_for_transmit: proc; /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>> System Dependency <<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ /********************************************************************/ /* This procedure goes out and looks for the segment with the */ /* name contained in cur_file_name. If found, it is set up for */ /* fill_transmit_buffer. Otherwise, the state goes to abort */ /* state. */ /********************************************************************/ /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>> Declarations <<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ dcl bit_count fixed bin(24); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ call hcs_$initiate_count (cur_file_name.dir, cur_file_name.entry, (""), bit_count, 0, transmit_seg_ptr, code); if transmit_seg_ptr = null then /* It ain't there */ do; state = abort_state; kermit_info.return_code = cant_get_seg; seg_length = 0; end; else do; seg_length = bit_count / 9; /* 9 bit bytes for you non-Multics folk */ cur_character = 1; end; last_file_transferred = rtrim(cur_file_name.dir) || ">" || cur_file_name.entry; last_char_sent = ""; /* init var. This is used to keep track of crlf */ /* combinations. lf -> crlf crlf unchanged */ return; end setup_seg_for_transmit; finish_with_seg: proc(code); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>> System Dependency <<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ /********************************************************************/ /* Close input file equivalent */ /********************************************************************/ dcl code fixed bin(35); call hcs_$terminate_noname (transmit_seg_ptr, code); return; end finish_with_seg; build_packet: proc (data_ptr, data_len, offset, quote_enable, packet); /********************************************************************/ /* Add data from a character string of data_len length pointed */ /* to by data_ptr starting at offset characters into the string */ /* into the packet structure. Quote_enable will allow all */ /* quoting to be performed if the other end has agreed to it. */ /********************************************************************/ dcl data_ptr ptr; dcl data_len fixed bin(24); dcl offset fixed bin(24); dcl quote_enable bit(1); /*===================== Begin packet_parm.incl.pl1 ====================*/ dcl 1 packet, 2 type char(1), 2 len fixed bin(21), 2 num fixed bin, 2 data (*) char(1); /*====================== End packet_parm.incl.pl1 =====================*/ dcl tmp_char char(1) var; dcl cont bit(1); dcl indx fixed bin; dcl ret_str char(10) var; dcl num_chars fixed bin; dcl pkt_len fixed bin init(sp_size-(chktype+2)); /* Amount of data we can send */ /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ len = 0; cont = true; do while (offset ^> data_len & cont & len < pkt_len); tmp_char = last_char_sent; /* Save in case lookahead must backup */ call get_next_chars (data_ptr, data_len, offset, ret_str, num_chars, quote_enable); if len + length(ret_str) > pkt_len then do; cont = false; last_char_sent = tmp_char; end; else do; offset = offset + num_chars; do indx = 1 to length(ret_str); data(len + indx) = substr(ret_str, indx, 1); end; len = len + length(ret_str); end; end; return; end build_packet; build_data_packet: proc(packet); /********************************************************************/ /* Fill a packet with data from the file */ /********************************************************************/ /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>> Declarations <<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ /*===================== Begin packet_parm.incl.pl1 ====================*/ dcl 1 packet, 2 type char(1), 2 len fixed bin(21), 2 num fixed bin, 2 data (*) char(1); /*====================== End packet_parm.incl.pl1 =====================*/ dcl indx fixed bin; /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ type = data_type; num = current_packet_no; /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>> Build data packet <<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ call build_packet (transmit_seg_ptr, seg_length, cur_character, enable_ctl_quoting, packet); return; end build_data_packet; build_file_packet: proc(packet); /********************************************************************/ /* Put the current file name into a packet to send down to the */ /* micro. Only two component names are allowed. */ /********************************************************************/ /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>> Declarations <<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ /*===================== Begin packet_parm.incl.pl1 ====================*/ dcl 1 packet, 2 type char(1), 2 len fixed bin(21), 2 num fixed bin, 2 data (*) char(1); /*====================== End packet_parm.incl.pl1 =====================*/ dcl indx fixed bin; dcl indx2 fixed bin; dcl file_name char(32) var; dcl buf_ptr fixed bin; dcl num_periods fixed bin init(0); dcl char char(1); dcl fixed_name char(32) aligned; /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ type = file_type; num = current_packet_no; file_name = rtrim(cur_file_name.entry); /********************************************************************/ /*>>>>>>>>>>>>>>>>>> Check file name for syntax <<<<<<<<<<<<<<<<<<*/ /********************************************************************/ indx = index(file_name,"."); /* Only two component (at most) allowed. */ if indx > 0 then do; if indx = length(file_name) then file_name = substr(file_name,1,indx-1); else do; indx2 = index(substr(file_name,indx+1),"."); if indx2 > 0 then do; if indx+indx2 = length(file_name) then file_name = substr(file_name,1,indx+indx2-1); else file_name = substr(file_name,1,indx+indx2-1); end; end; end; fixed_name = file_name; /* Transfer to buffer for packet building routines */ /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>> Put it into a packet <<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ call build_packet (addr(fixed_name), length(file_name), (1), enable_ctl_quoting, packet); return; end build_file_packet; receive_init: proc; /********************************************************************/ /* Recieve the send initiate packet from the host sending files */ /* and ack with a packet containing our parameters. */ /********************************************************************/ /*===================== Begin packet.incl.pl1 ====================*/ dcl 1 packet, 2 type char(1), 2 len fixed bin(21), 2 num fixed bin, 2 data (max_packet_size) char(1); /*====================== End packet.incl.pl1 =====================*/ dcl cktype_to_send fixed bin; dcl status bit(1); if num_try > max_try then do; kermit_info.return_code = too_many_tries; state = abort_state; return; end; num_try = num_try + 1; if num_try > 1 then total_retry_count = total_retry_count + 1; call receive_packet (packet, rtimint, status); if status = false then /* Didn't get one, nack it and try again */ do; call send_nack (current_packet_no); return; end; else if type = send_type then do; current_packet_no = num; call obtain_parms (packet, cktype_to_send); data(*) = " "; call send_init_packet(current_packet_no, cktype_to_send, ack_type); state = receive_file_state; num_try = 0; chktype = cktype_to_send; current_packet_no = mod(current_packet_no+1, 64); end; else do; /* Unknown packet type */ state = abort_state; kermit_info.return_code = unknown_state; end; return; end receive_init; obtain_parms: proc (packet, cktype_to_send); /********************************************************************/ /* Extract parameter info from a send-init packet */ /********************************************************************/ /*===================== Begin packet_parm.incl.pl1 ====================*/ dcl 1 packet, 2 type char(1), 2 len fixed bin(21), 2 num fixed bin, 2 data (*) char(1); /*====================== End packet_parm.incl.pl1 =====================*/ dcl cktype_to_send fixed bin; dcl negotiated_ebq bit(1); /********************************************************************/ /* These are the parameters used by the micro to send stuff up */ /* to us; used in receive_packet and associated routines. */ /********************************************************************/ negotiated_ebq = false; repeat_allowed = false; cktype_to_send = 1; /********************************************************************/ /* This is the second half of the negotiation, I'll agree to */ /* anything the other guy says. If nothing, I'll take the default */ /********************************************************************/ if len > 0 then if data(1) ^= blank then rp_size = unchar(data(1)); /* Dont use this */ if len > 1 then if data(2) ^= blank then rtimint = max(12, unchar(data(2))); if len > 2 then if data(3) ^= blank then pad = unchar(data(3)); /* or this one */ if len > 3 then if data(4) ^= blank then pad_char = nctl(data(4)); /* or this one */ if len > 4 then if data(5) ^= blank then end_of_line = unchar(data(5)); /* Use for framing chars (maybe) */ if len > 5 then if data(6) ^= blank then remote_quote = data(6); if len > 6 then if data(7) ^= blank then negotiated_ebq = (data(7) ^= "N"); if negotiated_ebq then do; if data(7) = "Y" then eight_bit_quote_char = ampersand; else eight_bit_quote_char = data(7); end; eight_bit_quote = eight_bit_quote & negotiated_ebq; if ^eight_bit_quote then eight_bit_quote_char = blank; if len > 7 then if data(8) ^= blank then if index(allowed_ck_codes,data(8)) > 0 then cktype_to_send = fixed(data(8)); else cktype_to_send = 1; if len > 8 then if data(9) ^= blank then repeat_allowed = true; if repeat_allowed then repeat_char = data(9); else repeat_char = blank; return; end obtain_parms; receive_file: proc; /********************************************************************/ /* Receive the expected file header packet, acknowledge it and */ /* change state to Receive_data state. Use the filename */ /* supplied by the header if one was not specified by the user. */ /* If a B packet is received and there are no more files , the */ /* state changes to Complete. */ /********************************************************************/ /*===================== Begin packet.incl.pl1 ====================*/ dcl 1 packet, 2 type char(1), 2 len fixed bin(21), 2 num fixed bin, 2 data (max_packet_size) char(1); /*====================== End packet.incl.pl1 =====================*/ dcl t_str char(200) var init(""); dcl packet_types char(4) init( send_type || eof_type || file_type || break_type); dcl status bit(1); dcl indx fixed bin; if num_try > max_try then do; state = abort_state; kermit_info.return_code = too_many_tries; return; end; num_try = num_try + 1; if num_try > 1 then total_retry_count = total_retry_count + 1; call receive_packet(packet, rtimint, status); if status = false then /* Couldn't get one */ do; /* Nack and wait */ call send_nack(current_packet_no); return; end; indx = index(packet_types, type); if indx = 0 then indx = length(packet_types)+1; goto case(indx); case(1): /* Send initiate packet */ /* Must have lost the ack */ if num = previous_packet_no(current_packet_no) then do; call send_init_packet(previous_packet_no(current_packet_no), 1, ack_type); num_try = 0; end; else do; state = abort_state; kermit_info.return_code = wrong_packet_no; end; goto endcase; case(2): /* End of file packet */ /* Saw this one before in receive_data */ if num = previous_packet_no(current_packet_no) then do; call send_ack(previous_packet_no(current_packet_no)); num_try = 0; end; else do; state = abort_state; kermit_info.return_code = wrong_packet_no; end; goto endcase; case(3): /* File header */ if num ^= current_packet_no then do; state = abort_state; kermit_info.return_code = wrong_packet_no; end; else do; call send_ack(current_packet_no); call unquote_packet (packet, t_str); cur_file_name.entry = t_str; if cur_file = 0 then call fix_file_name(cur_file_name); else cur_file_name = files.names(1); call open_file(cur_file_name); num_try = 0; current_packet_no = mod(current_packet_no+1, 64); state = receive_data_state; end; goto endcase; case(4): /* Break transmission */ if current_packet_no ^= num then do; state = abort_state; kermit_info.return_code = wrong_packet_no; end; else do; /* Since I won't listen after this, and it is possible */ /* for the local host to miss the ack while it is */ /* closing files and such like, delay and send it out */ call timer_manager_$sleep (2, rel_secs_flag); call send_ack (current_packet_no); /* Here's a good one. At 300 baud, the fnp may change modes */ /* before the ack packet goes out, so the micro doesn't see */ /* the SOH character (it sees the string \001 instead). */ /* Ha ha. Very funny. */ call timer_manager_$sleep (1, rel_secs_flag); /* 'Course it worked on a loaded system. */ state = completed_state; end; num_try = 0; goto endcase; case(5): /* Unexpected type */ state = abort_state; kermit_info.return_code = wrong_packet_type; goto endcase; endcase: return; end receive_file; receive_data: proc; /********************************************************************/ /* Receive data packets. This state is entered either from a */ /* previous receive_data state or from a receive_file_state. */ /* The file has been opened in either case. Previous packets */ /* of F or D types are acked (the ack must have been lost). If */ /* an end of file packet is received, the file is closed and */ /* state returns to receive_file_state. */ /********************************************************************/ /*===================== Begin packet.incl.pl1 ====================*/ dcl 1 packet, 2 type char(1), 2 len fixed bin(21), 2 num fixed bin, 2 data (max_packet_size) char(1); /*====================== End packet.incl.pl1 =====================*/ dcl data_str char(3500) var init(""); dcl packet_types char(3) init(file_type || data_type || eof_type); dcl indx fixed bin; dcl status bit(1); if num_try > max_try then do; state = abort_state; kermit_info.return_code = too_many_tries; return; end; num_try = num_try + 1; if num_try > 1 then total_retry_count = total_retry_count + 1; call receive_packet (packet, rtimint, status); /********************************************************************/ /* If no packet, Nack it and return to wait for another */ /********************************************************************/ if status = false then do; call send_nack(current_packet_no); return; end; indx = index(packet_types, type); if indx = 0 then indx = length(packet_types)+1; goto case(indx); case(1): /* File header packet (again) */ if num = previous_packet_no(current_packet_no) then do; call send_ack(previous_packet_no(current_packet_no)); num_try = 0; end; else do; state = abort_state; kermit_info.return_code = wrong_packet_no; end; goto endcase; case(2): /* Data packet */ if num = current_packet_no then do; call unquote_packet (packet, data_str); call add_chars(data_str); call send_ack(current_packet_no); num_try = 0; current_packet_no = mod(current_packet_no+1, 64); end; else if num = previous_packet_no(current_packet_no) then do; call send_ack(previous_packet_no(current_packet_no)); num_try = 0; end; else do; state = abort_state; kermit_info.return_code = wrong_packet_no; end; goto endcase; case(3): /* End of file packet */ if num ^= current_packet_no then do; state = abort_state; kermit_info.return_code = wrong_packet_no; end; else do; call close_file; files_rcvd = files_rcvd + 1; call send_ack(current_packet_no); num_try = 0; current_packet_no = mod(current_packet_no+1, 64); state = receive_file_state; end; goto endcase; case(4): /* Unknown packet type */ state = abort_state; kermit_info.return_code = wrong_packet_type; goto endcase; endcase: return; end receive_data; make_char: proc(number) returns(char(1)); /*******************************************************************/ /**** The following procedures through unctl are system dependent **/ /********************************************************************/ /* Convert number to a character. */ /********************************************************************/ dcl number fixed bin; return(substr(collate(),number+33, 1)); end make_char; unchar: proc(char) returns(fixed bin); /********************************************************************/ /* Inverse transformation. */ /********************************************************************/ dcl char char(1); return(index(collate(),char)-33); end unchar; ctl: proc(num) returns(char(1)); /********************************************************************/ /* Controllify a control (Ascii 0 to 37) so that it is */ /* printable. */ /* XOR char with 100 octal */ /********************************************************************/ dcl value fixed bin(9) based(addr(char_rep)) unsigned unaligned; dcl char_rep char(1) aligned; dcl bit_rep bit(9) based(addr(char_rep)); dcl num fixed bin; dcl octal_100 bit(9) static init("001000000"b); dcl octal_100_mask bit(9) static init("110111111"b); value = num; if mod(num,128) < 32 then bit_rep = bit_rep | octal_100; else bit_rep = bit_rep & octal_100_mask; return (char_rep); end ctl; nctl: proc(char) returns(fixed bin); /********************************************************************/ /* Same as above */ /********************************************************************/ dcl char char(1); dcl num fixed bin; dcl value fixed bin(9) unsigned based(addr(char_rep)) unaligned; dcl char_rep char(1) aligned; dcl bit_rep bit(9) based(addr(char_rep)); dcl octal_100 bit(9) static init("001000000"b); dcl octal_100_mask bit(9) static init("110111111"b); char_rep = char; if substr(bit_rep,3,1) then substr(bit_rep,3,1)=false; else substr(bit_rep,3,1)=true; num = value; return(num); end nctl; unctl: proc (char) returns(char(1)); /********************************************************************/ /* Variant of above. */ /********************************************************************/ dcl char char(1); dcl indx fixed bin; dcl num_rep fixed bin(9) unsigned based(addr(char_rep)) unaligned; dcl char_rep char(1) aligned; num_rep = nctl(char); return (char_rep); end unctl; previous_packet_no: proc (pkt_no) returns(fixed bin); /********************************************************************/ /* Return the number of the previous packet. Necessary since */ /* packet no is mod 64 */ /********************************************************************/ dcl pkt_no fixed bin; if pkt_no = 0 then return(63); /* -1 wont do any good */ else return(pkt_no - 1); end previous_packet_no; send_init_packet: proc(pkt_no, chktype_to_send, parm_type); /********************************************************************/ /* Send the packet containing our parameters */ /* This may either be an S, I or Ack packet type. */ /********************************************************************/ dcl pkt_no fixed bin; dcl chktype_to_send fixed bin; dcl parm_type char(1); dcl char_ck_codes char(3) static init("123"); /*===================== Begin packet.incl.pl1 ====================*/ dcl 1 packet, 2 type char(1), 2 len fixed bin(21), 2 num fixed bin, 2 data (max_packet_size) char(1); /*====================== End packet.incl.pl1 =====================*/ /********************************************************************/ /* These are the parameters used in sending items down to the */ /* micro; used in send_packet, build_packet and associated */ /* routines. */ /********************************************************************/ data(1) = make_char(sp_size); data(2) = make_char(fixed(stimint,17)); data(3) = make_char(my_pad); data(4) = ctl(my_pad_char); data(5) = make_char(my_end_of_line); data(6) = my_quote; if eight_bit_quote then do; if eight_bit_quote_char ^= blank then data(7) = eight_bit_quote_char; else do; data(7) = ampersand; eight_bit_quote_char = ampersand; end; end; else do; if parm_type = ack_type then data(7)="N"; /* Didnt ask for it, dont do it */ else data(7)="N"; /* We can do it, but won't */ end; data(8) = substr(char_ck_codes, chktype_to_send, 1); if repeat_allowed then data(9) = repeat_char; /* Initial conn. assumes ability */ else data(9) = blank; data(10) = blank; data(11) = blank; len = 11; type = parm_type; num = pkt_no; call send_packet(packet); /********************************************************************/ /*>>>>>>>>>>>> Notice no quoting on these packet types <<<<<<<<<<<*/ /********************************************************************/ return; end send_init_packet; send_ack: proc(pkt_no); /********************************************************************/ /* Send an ack packet */ /********************************************************************/ dcl pkt_no fixed bin; /*===================== Begin packet.incl.pl1 ====================*/ dcl 1 packet, 2 type char(1), 2 len fixed bin(21), 2 num fixed bin, 2 data (max_packet_size) char(1); /*====================== End packet.incl.pl1 =====================*/ len = 0; type = ack_type; num = pkt_no; call send_packet (packet); return; end send_ack; send_nack: proc (pkt_no); /********************************************************************/ /* Send a NACK packet */ /********************************************************************/ dcl pkt_no fixed bin; /*===================== Begin packet.incl.pl1 ====================*/ dcl 1 packet, 2 type char(1), 2 len fixed bin(21), 2 num fixed bin, 2 data (max_packet_size) char(1); /*====================== End packet.incl.pl1 =====================*/ len = 0; type = nack_type; num = pkt_no; call send_packet(packet); return; end send_nack; error_control: proc; /********************************************************************/ /* This procedure is responsible for the recovery of errors */ /* during file transfer. An error packet is sent down to the */ /* micro containing an error message, a break packet is sent */ /* and then a return is made. */ /********************************************************************/ /*===================== Begin packet.incl.pl1 ====================*/ dcl 1 packet, 2 type char(1), 2 len fixed bin(21), 2 num fixed bin, 2 data (max_packet_size) char(1); /*====================== End packet.incl.pl1 =====================*/ dcl fixed_e_msg char(80); dcl indx fixed bin; dcl status bit(1); dcl err_msgs (11) char(80) var static init ( "Too many retries.", "Wrong packet type.", "Entered unexpected state.", "Wrong packet number.", "Error on host system.", "File missing for send request.", "Record quota overflow; insufficient space available.", "File already exists; transmission aborted.", "Can't get segment for transmission.", "That server command has not been implemented.", "That host command is not recognized."); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ indx = kermit_info.return_code - 20; fixed_e_msg = err_msgs(indx); type = error_type; call build_packet (addr(fixed_e_msg), length(err_msgs(indx)),(1), enable_ctl_quoting, packet); num = current_packet_no; /********************************************************************/ /* It is possible to not have the correct terminal config. */ /********************************************************************/ if ^debug_sw & ^server then call setup_terminal (code); call send_packet(packet); /********************************************************************/ /* Get ack (or timeout) */ /********************************************************************/ call receive_packet(packet, stimint, status); current_packet_no = mod(current_packet_no+1, 64); call send_break; /********************************************************************/ /* Reset terminal config. */ /********************************************************************/ if ^server & ^debug_sw then call reset_terminal (code); return; end error_control; fix_file_name: proc (cur_fn); /********************************************************************/ /* Get the file name sent from the remote system out of the */ /* data array. Do any fixup needed and put it into cur_fn */ /********************************************************************/ /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>> Declarations <<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ dcl len fixed bin(21); dcl 1 cur_fn, 2 dir char(*), 2 entry char(*); dcl tentry char(200) var init(""); dcl indx fixed bin; /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ /********************************************************************/ /* Since directories will not be specified by the remote */ /* kermit, use the default directory. This is changable with */ /* the set command */ /********************************************************************/ dir = default_dir; tentry = rtrim(entry); tentry = translate(tentry, sml, big); /********************************************************************/ /* If any drive specifiers (b:, a:, etc), get rid of them */ /********************************************************************/ if index(tentry, colon) > 0 then do; indx = index(tentry, colon); tentry = substr(tentry, 1, min(indx+1, length(tentry))); end; /********************************************************************/ /* Get rid of period if single component name sent over */ /********************************************************************/ if substr(tentry,length(tentry)) = "." then tentry = substr(tentry,1,length(tentry)-1); /********************************************************************/ /* Finally, supply a default if a null file name was sent */ /********************************************************************/ if tentry||blank = blank then tentry = "kermit.out"; entry = ltrim(tentry); return; end fix_file_name; open_file: proc(file_name); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>> System Dependency <<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ /********************************************************************/ /* Procedure to open a file */ /********************************************************************/ dcl 1 file_name, 2 dir char(*), 2 entry char(*); dcl output file; dcl count fixed bin; dcl fe bit(1); dcl t_entry char(32); /********************************************************************/ /* If file_warning is enabled, determine if file currently exists. */ /* This has already been checked in the case of a user supplied */ /* pathname, but not when the name is supplied by the remote */ /* system. If fw = true & existence then try renaming the file */ /* by adding .1, .2 etc. If we cant do that in 100 tries, make up */ /* a unique filename through a system call. */ /********************************************************************/ if file_warning_sw then do; t_entry = entry; /* In case it doesn't exist */ fe = file_exists (dir, entry); count = 0; do while(fe); count = count + 1; t_entry = rtrim(entry) || "." || ltrim(rtrim(char(count))); if count > 100 then t_entry = unique_chars_(unique_bits_()); fe = file_exists (dir, t_entry); end; entry = t_entry; end; last_file_transferred = rtrim(dir) || ">" || entry; eof_flag = false; open file(output) title("vfile_ " || rtrim(dir) || ">" || entry) output; call iox_$find_iocb("output", output_iocb_ptr, code); return; end open_file; file_exists: proc (dir, entry) returns(bit(1)); /********************************************************************/ /* System Dependent routine to determine if the file with the */ /* given name exists in the storate structure. */ /********************************************************************/ dcl dir char(*); dcl entry char(*); dcl bc fixed bin(24); dcl tst_ptr ptr; dcl code fixed bin(35); call hcs_$initiate_count (dir, entry, "", bc, 0, tst_ptr, code); if tst_ptr ^= null() then do; call hcs_$terminate_noname(tst_ptr, code); return(true); end; return(false); end file_exists; close_file: proc; dcl output file; close file(output); output_iocb_ptr = null(); return; end; end_of_data_reached: proc returns(bit(1)); /***********************************************************************************/ /****** System Dependent routine to return true when end of data to send reached **/ /***********************************************************************************/ if cur_character > seg_length then return(true); else return(false); end end_of_data_reached; add_chars: proc(data_str); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>> System Dependency <<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ /********************************************************************/ /* Put characters in output file */ /********************************************************************/ dcl data_str char(*) var; dcl indx fixed bin; dcl t_str char(150) var init(""); dcl str char(3000) aligned; dcl len fixed bin(21); dcl CRLF char(2) init(CR||LF); /********************************************************************/ /* Since, in some machines, an eof character (ctrl-z) is used */ /* to mark the end of the file instead of using the character */ /* count in the directory like a good computer should, garbage */ /* may be innocently sent by the PC. */ /* This is particularly true in the IBM PC case for files */ /* produced by BASIC. The character count is rounded up to the */ /* nearest 256 bytes. As far as I can tell, all other programs */ /* count characters correctly. Sigh. In any event, that's the */ /* reason for the text mode setting. Text files shouldn't be */ /* hurt by it. */ /* */ /* Text mode also provides for CRLF -> LF conversion on Multics */ /********************************************************************/ if eof_flag & text_mode then return; /* Don't add characters past ^Z */ if text_mode then do; if last_char_received = CR & substr(data_str,1,1) ^= LF then data_str = CR || data_str; indx = index(data_str, CRLF); do while (indx > 0); t_str = substr(data_str,1, indx-1) || LF; if length(data_str) > indx+1 then t_str = t_str || substr(data_str,indx+2); data_str = t_str; indx = index(data_str, CRLF); end; if substr(data_str, length(data_str)) = CR then do; last_char_received = CR; data_str = substr(data_str, 1, length(data_str)-1); end; else last_char_received = ""; if index (data_str, CTL_Z) > 0 then do; data_str = substr(data_str,1,index(data_str,CTL_Z)-1); eof_flag = true; end; end; /* Non-transparent transfer stuff */ str = data_str; len = length(data_str); call iox_$put_chars(output_iocb_ptr, addr(str), len, code); return; end; receive_packet: proc (packet, timeout, status); /********************************************************************/ /* Get a packet from the other host. Decode information into */ /* the packet data structure */ /********************************************************************/ /*===================== Begin packet_parm.incl.pl1 ====================*/ dcl 1 packet, 2 type char(1), 2 len fixed bin(21), 2 num fixed bin, 2 data (*) char(1); /*====================== End packet_parm.incl.pl1 =====================*/ dcl timeout fixed bin(71); dcl cksum fixed bin(35); dcl tsum fixed bin(35); dcl indx fixed bin; dcl line_len fixed bin; dcl line char(150) var; dcl cksum_str char(3) var; dcl i fixed bin init(0); dcl unctl_nxt_char bit(1) init(false); dcl prev_char_not_quote bit(1) init(true); dcl status bit(1); dcl char char(1); dcl found_soh bit(1) init(false); dcl tmp_chktype fixed bin; dcl data_len fixed bin; dcl error condition; /********************************************************************/ /* Error for timer_manager_ */ /********************************************************************/ on error begin; call timer_manager_$reset_alarm_call(abort_read); call continue_to_signal_ (code); end; /********************************************************************/ /* Stop timers if quit encountered. */ /********************************************************************/ on quit begin; call timer_manager_$reset_alarm_call (abort_read); call continue_to_signal_ (code); end; /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ cksum = 0; if debug_sw then do; call kermit_db_$get_packet (input_bfr_ptr, input_bfr_len, cur_inpt_bfr_len, timeout, status); if status = false then return; /* Didn't get one */ end; else do; /********************************************************************/ /* Set up timer for time-out on read. Return status as false */ /* if we time out */ /********************************************************************/ call timer_manager_$alarm_call (timeout, rel_secs_flag, abort_read); call iox_$get_line (tty_iocb, input_bfr_ptr, input_bfr_len, cur_inpt_bfr_len, code); call timer_manager_$reset_alarm_call (abort_read); end; total_packet_rcvd = total_packet_rcvd + 1; if trace_sw then call log_receive (input_bfr_ptr, cur_inpt_bfr_len); line = substr(input_buffer, 1, cur_inpt_bfr_len-1); /********************************************************************/ /* Get rid of SOH character and fragmented packet(s) at */ /* beginning if present */ /********************************************************************/ indx = index(line,SOH); do while (indx > 0 & ^found_soh); found_soh = true; if indx = length(line) then do; line = ""; found_soh = false; end; else do; line = substr(line, indx+1); indx = index(line, SOH); end; end; if ^found_soh | length(line) < 4 then /* Got to have at least 4 */ do; status = false; return; end; /********************************************************************/ /* Obtain type and length fields */ /********************************************************************/ len = unchar(substr(line,1,1)); num = unchar (substr(line,2,1)); type = substr(line,3,1); if length(line) < len+1 then /* Len field does not include SOH or len */ do; /* field, but everything else */ status = false; /* Better has at least as much as we */ return; /* thought we did */ end; /********************************************************************/ /* Set up checksum type. This is necessary since I may have */ /* acked the send init packet and think I am using a */ /* non-default checksum but in reality, my ack was lost and we */ /* are still using the default */ /********************************************************************/ if len - (2+chktype) < 0 then /* A bit of magic here */ do; tmp_chktype = chktype; chktype = 1; end; else tmp_chktype = chktype; /* Save for restore later */ /** Now we can add in the checksums for the first two fields **/ call add_ck_sm (cksum, make_char((len))); call add_ck_sm (cksum, make_char((num))); call add_ck_sm (cksum, type); /********************************************************************/ /* Take data out of string and add checksums */ /********************************************************************/ line = substr(line,4); data_len = len - (2+chktype); do indx = 1 to data_len; data(indx) = substr(line, indx, 1); call add_ck_sm (cksum, data(indx)); end; cksum_str = substr(line, data_len+1); if char_cksum(cksum) ^= cksum_str then status = false; else status = true; len = data_len; chktype = tmp_chktype; return; end_of_receive_packet: /* Target of goto when read times out */ if trace_sw then call log_receive (input_bfr_ptr, 0); return; abort_read: proc; /********************************************************************/ /* Procedure called by timer_manager_ when the read times out */ /* if a CR (ie LF) was lost or the last ACK was lost. */ /********************************************************************/ status = false; if trace_sw then call log_receive (input_bfr_ptr, 0); goto end_of_receive_packet; /* Non-local goto */ end abort_read; end receive_packet; send_packet: proc(packet); /********************************************************************/ /* Build a packet in an interal line and send it out all at */ /* once. Calculate that confounded checksum */ /* Tack on the specified line terminator. */ /********************************************************************/ /*===================== Begin packet_parm.incl.pl1 ====================*/ dcl 1 packet, 2 type char(1), 2 len fixed bin(21), 2 num fixed bin, 2 data (*) char(1); /*====================== End packet_parm.incl.pl1 =====================*/ dcl cksum fixed bin(35); dcl char_cnt fixed bin; dcl packet_line char(250) var init(""); dcl char char(1); dcl indx fixed bin; dcl tsum fixed bin(35); cksum = 0; char_cnt = 0; /********************************************************************/ /* Put out specified number of padding characters */ /********************************************************************/ do indx = 1 to pad; packet_line = packet_line || make_char(pad_char); end; packet_line = packet_line || SOH; /********************************************************************/ /* Packet Format */ /* */ /* <..... data .....> */ /* Length includes type, length and checksum fields, but not */ /* SOH and end_of_line */ /********************************************************************/ /********************************************************************/ /* Put in character count (packet length) */ /********************************************************************/ char = make_char(len+2+chktype); call add_ck_sm (cksum, char); packet_line = packet_line || char; /********************************************************************/ /* Packet number, mod 64 */ /********************************************************************/ num = mod(num, 64); char = make_char(num); call add_ck_sm (cksum, char); packet_line = packet_line || char; /********************************************************************/ /* Packet type */ /********************************************************************/ call add_ck_sm (cksum, type); packet_line = packet_line || type; /********************************************************************/ /* Data */ /********************************************************************/ do indx = 1 to len; call add_ck_sm (cksum, data(indx)); packet_line = packet_line || data(indx); end; packet_line = packet_line || char_cksum(cksum); /********************************************************************/ /* Tack on indicated end of line character */ /********************************************************************/ packet_line = packet_line || substr(collate(), my_end_of_line+1, 1); /********************************************************************/ /* Output line */ /********************************************************************/ if debug_sw then call kermit_db_$send_packet (packet_line); else call output_chars (packet_line); total_packet_trns = total_packet_trns + 1; if trace_sw then call log_trans (packet_line); return; end send_packet; output_chars: proc (line); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>> System Dependency <<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ /********************************************************************/ /* Output characters without any additional linefeed characters */ /* - the line terminator has already been added. */ /********************************************************************/ dcl line char(*) var; call ioa_$nnl ("^a", line); return; end output_chars; add_ck_sm: proc(sum, parm_char); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>> System Dependency <<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ /********************************************************************/ /* Add the binary value of char to sum to do checksums (types 1&2) */ /* Do a table look up procedrue for CRC checksums */ /* The table look up algorithm comes from Byte-wise CRC */ /* Calculations, Perez, Wismer & Becker, IEEE Micro, June 1983. */ /* Thanks Greg. */ /********************************************************************/ dcl sum fixed bin(35); dcl parm_char char(1); dcl char char(1) aligned; dcl al_bit_rep bit(9) based(addr(char)); dcl lower_seven_bits bit(9) static init("001111111"b); dcl 1 nine_bit_counter aligned, 2 twenty_seven_0s bit(27) unaligned init("0"b), 2 num fixed bin(9) unsigned unaligned; dcl lo_byte bit(8); dcl xor bit(4) static options(constant) init("0110"b); /* Xor for bool */ /*=================== Begine crc_table.incl.pl1 ==================*/ /********************************************************************/ /* This table was produced by a procedure implementing the crc */ /* table generating function: */ /* . R16 = x8 x4 R8 = x5 x1 */ /* . R15 = x7 x3 R7 = x4 */ /* . R14 = x6 x2 R6 = x3 */ /* . R13 = x5 x1 R5 = x2 */ /* . R12 = x4 R4 = x8 x4 x1 */ /* . R11 = x8 x4 x3 R3 = x7 x3 */ /* . R10 = x7 x3 x2 R2 = x6 x2 */ /* . R9 = x6 x2 x1 R1 = x5 x1 */ /* */ /* where Rn is the bit of the table word and the xn is an xor */ /* function with the nth bit of the 8 bit table index. See */ /* Perez et all for details. Bits are numbered right to left */ /* with the least significant bit being 1. */ /********************************************************************/ dcl crc_table(0:255) bit(16) static options(constant) init ( "0000"b4, "1189"b4, "2312"b4, "329b"b4, "4624"b4, "57ad"b4, "6536"b4, "74bf"b4, "8c48"b4, "9dc1"b4, "af5a"b4, "bed3"b4, "ca6c"b4, "dbe5"b4, "e97e"b4, "f8f7"b4, "1081"b4, "0108"b4, "3393"b4, "221a"b4, "56a5"b4, "472c"b4, "75b7"b4, "643e"b4, "9cc9"b4, "8d40"b4, "bfdb"b4, "ae52"b4, "daed"b4, "cb64"b4, "f9ff"b4, "e876"b4, "2102"b4, "308b"b4, "0210"b4, "1399"b4, "6726"b4, "76af"b4, "4434"b4, "55bd"b4, "ad4a"b4, "bcc3"b4, "8e58"b4, "9fd1"b4, "eb6e"b4, "fae7"b4, "c87c"b4, "d9f5"b4, "3183"b4, "200a"b4, "1291"b4, "0318"b4, "77a7"b4, "662e"b4, "54b5"b4, "453c"b4, "bdcb"b4, "ac42"b4, "9ed9"b4, "8f50"b4, "fbef"b4, "ea66"b4, "d8fd"b4, "c974"b4, "4204"b4, "538d"b4, "6116"b4, "709f"b4, "0420"b4, "15a9"b4, "2732"b4, "36bb"b4, "ce4c"b4, "dfc5"b4, "ed5e"b4, "fcd7"b4, "8868"b4, "99e1"b4, "ab7a"b4, "baf3"b4, "5285"b4, "430c"b4, "7197"b4, "601e"b4, "14a1"b4, "0528"b4, "37b3"b4, "263a"b4, "decd"b4, "cf44"b4, "fddf"b4, "ec56"b4, "98e9"b4, "8960"b4, "bbfb"b4, "aa72"b4, "6306"b4, "728f"b4, "4014"b4, "519d"b4, "2522"b4, "34ab"b4, "0630"b4, "17b9"b4, "ef4e"b4, "fec7"b4, "cc5c"b4, "ddd5"b4, "a96a"b4, "b8e3"b4, "8a78"b4, "9bf1"b4, "7387"b4, "620e"b4, "5095"b4, "411c"b4, "35a3"b4, "242a"b4, "16b1"b4, "0738"b4, "ffcf"b4, "ee46"b4, "dcdd"b4, "cd54"b4, "b9eb"b4, "a862"b4, "9af9"b4, "8b70"b4, "8408"b4, "9581"b4, "a71a"b4, "b693"b4, "c22c"b4, "d3a5"b4, "e13e"b4, "f0b7"b4, "0840"b4, "19c9"b4, "2b52"b4, "3adb"b4, "4e64"b4, "5fed"b4, "6d76"b4, "7cff"b4, "9489"b4, "8500"b4, "b79b"b4, "a612"b4, "d2ad"b4, "c324"b4, "f1bf"b4, "e036"b4, "18c1"b4, "0948"b4, "3bd3"b4, "2a5a"b4, "5ee5"b4, "4f6c"b4, "7df7"b4, "6c7e"b4, "a50a"b4, "b483"b4, "8618"b4, "9791"b4, "e32e"b4, "f2a7"b4, "c03c"b4, "d1b5"b4, "2942"b4, "38cb"b4, "0a50"b4, "1bd9"b4, "6f66"b4, "7eef"b4, "4c74"b4, "5dfd"b4, "b58b"b4, "a402"b4, "9699"b4, "8710"b4, "f3af"b4, "e226"b4, "d0bd"b4, "c134"b4, "39c3"b4, "284a"b4, "1ad1"b4, "0b58"b4, "7fe7"b4, "6e6e"b4, "5cf5"b4, "4d7c"b4, "c60c"b4, "d785"b4, "e51e"b4, "f497"b4, "8028"b4, "91a1"b4, "a33a"b4, "b2b3"b4, "4a44"b4, "5bcd"b4, "6956"b4, "78df"b4, "0c60"b4, "1de9"b4, "2f72"b4, "3efb"b4, "d68d"b4, "c704"b4, "f59f"b4, "e416"b4, "90a9"b4, "8120"b4, "b3bb"b4, "a232"b4, "5ac5"b4, "4b4c"b4, "79d7"b4, "685e"b4, "1ce1"b4, "0d68"b4, "3ff3"b4, "2e7a"b4, "e70e"b4, "f687"b4, "c41c"b4, "d595"b4, "a12a"b4, "b0a3"b4, "8238"b4, "93b1"b4, "6b46"b4, "7acf"b4, "4854"b4, "59dd"b4, "2d62"b4, "3ceb"b4, "0e70"b4, "1ff9"b4, "f78f"b4, "e606"b4, "d49d"b4, "c514"b4, "b1ab"b4, "a022"b4, "92b9"b4, "8330"b4, "7bc7"b4, "6a4e"b4, "58d5"b4, "495c"b4, "3de3"b4, "2c6a"b4, "1ef1"b4, "0f78"b4); /*==================== End crc_table.incl.pl1 ====================*/ if eight_bit_quote then /* Dont consider parity in checksum computation */ do; char = parm_char; al_bit_rep = al_bit_rep & lower_seven_bits; end; else char = parm_char; goto case(chktype); case(1): /* Single byte */ case(2): /* double byte */ num = fixed ("0"b || unspec(char)); sum = sum + num; return; case(3): /* CRC type */ lo_byte = substr(unspec(sum),29); /* Low 8 bits */ unspec(num) = bool ("0"b || lo_byte, unspec(char), xor); sum = sum / 256; /* Shift 8 bits to right */ unspec(sum) = bool (unspec(sum), "00000000000000000000"b || crc_table(num), xor); return; end add_ck_sm; char_cksum: proc(cksum) returns(char(*) var); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>> System Dependency <<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ /********************************************************************/ /* Take the numeric representation of cksum and return a */ /* character representation of it. Which type ;depends on the */ /* checksum type. */ /********************************************************************/ dcl cksum fixed bin(35); dcl indx fixed bin; dcl tsum fixed bin(35); dcl ret_str char(3) var; dcl low_six bit(36) static options(constant) init ("000000000000000000000000000000111111"b); dcl mid_six bit(36) static options(constant) init ("000000000000000000000000111111000000"b); dcl high_six bit(36) static options(constant) init ("000000000000000000111111000000000000"b); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ goto case(chktype); /* 1, 2 or 3 only */ case(1): /* Standard kermit checksum type */ /* Keep only low order 8 bits of checksum */ cksum = mod(cksum, 256); tsum = cksum; /* Add two high order bits to lower bits */ unspec(cksum) = unspec(cksum) & "000000000000000000000000000011000000"b; cksum = cksum / 64; cksum = cksum + tsum; /* Keep lower 6 bits and add a space to it to make it printable */ unspec(cksum) = unspec(cksum) & low_six; indx = cksum; /* Match up parms */ ret_str = make_char(indx); return (ret_str); case(2): /* Double byte checksum, kermit type 2 */ /* Get low 6 bits */ unspec(tsum) = unspec(cksum) & low_six; ret_str = (make_char((tsum))); /* Get higher 6 bits */ unspec(tsum) = unspec(cksum) & mid_six; tsum = tsum / 64; /* Shift to low end */ ret_str = (make_char((tsum))) || ret_str; return(ret_str); case(3): /* Three byte CRC checksum */ /* Get low 6 bits */ unspec(tsum) = unspec(cksum) & low_six; ret_str = (make_char((tsum))); /* Get middle 6 bits */ unspec(tsum) = unspec(cksum) & mid_six; tsum = tsum / 64; /* Shift to low end */ ret_str = (make_char((tsum))) || ret_str; /* Get higher 6 bits */ unspec(tsum) = unspec(cksum) & high_six; tsum = tsum / 4096; /* Shift to low end */ ret_str = (make_char((tsum))) || ret_str; return(ret_str); end char_cksum; get_next_chars: proc (data_ptr, data_len, offset, ret_str, num_chars, quote_enable); /********************************************************************/ /* Obtain the next character (or group of characters) from the */ /* data string. In worst case, the ret_str may contain up to */ /* five characters: two for repeate group, parity quote, */ /* control quote and the actual character. */ /********************************************************************/ dcl data_ptr ptr; dcl data_len fixed bin(24); dcl offset fixed bin(24); dcl ret_str char(*) var; dcl num_chars fixed bin; dcl quote_enable bit(1); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ ret_str = ""; num_chars = 0; if quote_enable then do; call repeat_quoting (data_ptr, data_len, offset, ret_str, num_chars); end; else do; call single_char (data_ptr, offset, ret_str, num_chars); end; return; end get_next_chars; repeat_quoting: proc (data_ptr, data_len, offset, ret_str, num_chars); /********************************************************************/ /* Handle repeat groups. Each group may contain upto 94 */ /* characters. Also have to make sure we don't fall off the */ /* end of the data. */ /********************************************************************/ dcl data_ptr ptr; dcl data_len fixed bin(24); dcl offset fixed bin(24); dcl ret_str char(*) var; dcl num_chars fixed bin; dcl total_chars_compressed fixed bin init(0); dcl t_offset fixed bin(24); dcl new_str char(10) var; dcl new_chars fixed bin; dcl temp_char char(1); dcl t2_char char(1); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ call ctl_quoting (data_ptr, offset, ret_str, num_chars); if repeat_char ^= blank then do; temp_char = last_char_sent; /* Necessary to buffer 1 char lookahead so */ /* LF->CRLF transformation works. */ call ctl_quoting (data_ptr, offset+num_chars, new_str, new_chars); t_offset = offset + num_chars; total_chars_compressed = num_chars; do while(new_str = ret_str & total_chars_compressed < 94 & t_offset+new_chars < data_len); total_chars_compressed = total_chars_compressed + new_chars; t_offset = t_offset + new_chars; t2_char = last_char_sent; call ctl_quoting (data_ptr, t_offset, new_str, new_chars); end; if total_chars_compressed > repeat_threshold then do; ret_str = repeat_char || make_char (total_chars_compressed) || ret_str; num_chars = total_chars_compressed; last_char_sent = t2_char; end; else last_char_sent = temp_char; end; return; end repeat_quoting; ctl_quoting: proc (data_ptr, offset, ret_str, num_chars); /********************************************************************/ /* Prefix with a control quote character if not a printable */ /* char. */ /********************************************************************/ dcl data_ptr ptr; dcl offset fixed bin(24); dcl ret_str char(*) var; dcl num_chars fixed bin; dcl s_char char(1) aligned; dcl v_char char(2) var; dcl prefix_char char(1) var; dcl bit_rep bit(9) based(addr(s_char)); dcl num_rep fixed bin; dcl l7_char char(1) aligned; dcl l7_bit_rep bit(9) based(addr(l7_char)); dcl lower_seven_bits bit(9) static init("001111111"b); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ call parity_quoting (data_ptr, offset, v_char, num_chars); if length(v_char) > 1 then do; prefix_char = substr(v_char,1,1); s_char = substr(v_char,2); end; else do; prefix_char = ""; s_char = v_char; end; l7_char = s_char; l7_bit_rep = l7_bit_rep & lower_seven_bits; num_rep = fixed(l7_bit_rep); if num_rep < 32 /* Blank */ | num_rep = 127 /* Tilde */ then /********************************************************************/ /* If lower seven bits in range of 0-31 or 127, then prefix and */ /* change original character to controlified character (xor bit */ /* 7 (or 6, depending on terminology -- second bit from left on */ /* 8 bit char)) */ /********************************************************************/ do; ret_str = prefix_char || my_quote || ctl(fixed(bit_rep)); end; else /********************************************************************/ /* If lower seven bits = one of the special prefix characters, */ /* then quote the original character */ /********************************************************************/ do; ret_str = prefix_char || s_char; if l7_char = my_quote | (eight_bit_quote & l7_char = eight_bit_quote_char) | (repeat_char ^= blank & l7_char = repeat_char) then ret_str = prefix_char || my_quote || s_char; end; return; end ctl_quoting; parity_quoting: proc (data_ptr, offset, ret_str, num_chars); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>> SYSTEM DEPENDENCY <<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ /* Get a character an prefix with the parity quote character if */ /* this has been turned on. */ /********************************************************************/ dcl data_ptr ptr; dcl offset fixed bin(24); dcl ret_str char(*) var; dcl num_chars fixed bin; dcl prefix_char char(1) var; dcl char char(1); dcl bit_rep bit(9) based(addr(char)); dcl mask_parity bit(9) static init("001111111"b); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ call single_char (data_ptr, offset, ret_str, num_chars); if eight_bit_quote then do; char = ret_str; if substr(bit_rep, 2, 1) then /* Parity bit on NOTE: 9 BIT BYTES */ do; bit_rep = bit_rep & mask_parity; ret_str = eight_bit_quote_char || char; end; end; return; end parity_quoting; single_char: proc (data_ptr, offset, ret_char, num_chars); /********************************************************************/ /* Translation routine. Multics LF goes to CRLF combination. */ /* */ /* This is a good place for ebcdic to ascii translation. */ /********************************************************************/ dcl data_ptr ptr; dcl offset fixed bin(24); dcl ret_char char(*) var; dcl num_chars fixed bin; /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ num_chars = 1; ret_char = get_a_char (data_ptr, offset); if ret_char = LF & last_char_sent ^= CR & text_mode then do; last_char_sent = CR; num_chars = 0; /* Do not advance pointer in buffer */ ret_char = CR; end; else do; last_char_sent = ret_char; end; return; end single_char; get_a_char: proc (data_ptr, offset) returns(char(1)); /********************************************************************/ /* Obtain a character from the data buffer */ /********************************************************************/ dcl data_ptr ptr; dcl offset fixed bin(24); dcl data_str char(offset) based(data_ptr); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ return (substr(data_str, offset, 1)); end get_a_char; unquote_packet: proc (packet, data_str); /********************************************************************/ /* Take the data contained in the packet data structure and */ /* turn it into a regular string, undoing all of the quoting */ /* that was performed on the other end. */ /********************************************************************/ dcl indx fixed bin; dcl ret_str char(100) var; dcl num_scanned fixed bin; dcl data_str char(*) var; /*===================== Begin packet_parm.incl.pl1 ====================*/ dcl 1 packet, 2 type char(1), 2 len fixed bin(21), 2 num fixed bin, 2 data (*) char(1); /*====================== End packet_parm.incl.pl1 =====================*/ /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ indx = 1; num_scanned = 0; data_str = ""; do while (indx ^> len); call undo_repeat (data, indx, num_scanned, ret_str); data_str = data_str || ret_str; indx = indx + num_scanned; end; return; end unquote_packet; undo_repeat: proc (data, indx, num_scanned, ret_str); /********************************************************************/ /* Expand the character by the number of times specified in the */ /* repeat field if it is present. */ /********************************************************************/ dcl data(*) char(1); dcl indx fixed bin; dcl num_scanned fixed bin; dcl ret_str char(*) var; dcl t_indx fixed bin; dcl fin_str char(100) var init(""); dcl t_str char(10) var; dcl repeat_count fixed bin; /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ if repeat_char = blank then /* Skip repeat quoting */ do; call undo_trans (data, indx, num_scanned, ret_str); end; else do; if data(indx) = repeat_char then do; repeat_count = unchar (data(indx+1)); call undo_trans (data, indx+2, num_scanned, t_str); num_scanned = num_scanned + 2; do t_indx = 1 to repeat_count; fin_str = fin_str || t_str; end; ret_str = fin_str; end; else do; call undo_trans (data, indx, num_scanned, ret_str); end; end; return; end undo_repeat; undo_trans: proc (data, indx, num_scanned, char); /********************************************************************/ /* Undo any character translation done in sending */ /********************************************************************/ dcl data(*) char(1); dcl indx fixed bin; dcl num_scanned fixed bin; dcl char char(*) var; /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ /*** This is a dummy routine since Multics is an ascii machine ***/ call undo_ctl (data, indx, num_scanned, char); return; end undo_trans; undo_ctl: proc (data, indx, num_scanned, ret_char); /********************************************************************/ /* Undo control prefixing. If repeat quoting, parity quoting */ /* are allowed, these characters will also be quoted, otherwise */ /* they are literals */ /********************************************************************/ dcl data(*) char(1); dcl indx fixed bin; dcl num_scanned fixed bin; dcl char char(1); dcl l7_char char(1) aligned; dcl l7_bit_rep bit(9) based(addr(l7_char)); dcl lower_seven_bits bit(9) static init("001111111"b); dcl ret_char char(*) var; dcl handle_parity bit(1) init(false); dcl t_indx fixed bin; dcl char_type fixed bin; dcl special_chars char(3) init(eight_bit_quote_char || repeat_char || remote_quote); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ if data(indx) = eight_bit_quote_char & eight_bit_quote then do; handle_parity = true; num_scanned = 1; t_indx = indx + 1; end; else do; num_scanned = 0; t_indx = indx; end; if data(t_indx) ^= remote_quote then /* Easy out */ do; num_scanned = num_scanned + 1; ret_char = data(t_indx); end; else do; num_scanned = num_scanned + 2; char = data(t_indx+1); l7_char = char; l7_bit_rep = l7_bit_rep & lower_seven_bits; char_type = index(special_chars, l7_char); if char_type = 0 then char_type = length(special_chars)+1; /* Reg ctl quote */ goto case(char_type); case(1): /* Parity quote character */ if eight_bit_quote then ret_char = char; else ret_char = unctl(char); goto endcase; case(2): /* Repeat quote character */ if repeat_char ^= blank then ret_char = char; else ret_char = unctl(char); goto endcase; case(3): /* Quote character */ ret_char = char; goto endcase; case(4): /* Standard ctl quoting */ ret_char = unctl(char); goto endcase; endcase: ; end; if handle_parity then call undo_parity (ret_char); return; end undo_ctl; undo_parity: proc (ret_str); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>> SYSTEM DEPENDENCY <<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ /* Undo the parity quoting if enabled and present */ /********************************************************************/ dcl ret_str char(*) var; dcl char char(1) aligned; dcl bit_rep bit(9) based(addr(char)); dcl parity_bit bit(9) static init("010000000"b); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ char = ret_str; /** Prepare to add parity bit **/ bit_rep = bit_rep | parity_bit; ret_str = char; return; end undo_parity; log_receive: proc(lptr, llen); /********************************************************************/ /* Log received packets in trace_file */ /********************************************************************/ dcl time_str char(12) var; dcl line char(llen) based(lptr); dcl lptr ptr; dcl llen fixed bin(21); time_str = time(); time_str = substr(time_str,3,2) || ":" || substr(time_str,5,2); if llen > 0 then put file(trace_file) edit(time_str, "R", line)(a,x(1)); else put file(trace_file) edit(time_str, "R", "- null packet -")(a,x(1)); put file(trace_file) skip; return; end log_receive; log_trans: proc(packet_line); /********************************************************************/ /* Log transmitted packets in trace_file */ /********************************************************************/ dcl packet_line char(*) var; dcl time_str char(12) var; time_str = time(); time_str = substr(time_str,3,2) || ":" || substr(time_str,5,2); put file(trace_file) edit(time_str, "T", packet_line)(a,x(1)); put file(trace_file) skip; return; end log_trans; flush_input_buffer: proc; /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>> System Dependency <<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ /********************************************************************/ /* A call to iox_$control to clean out the input buffer */ /********************************************************************/ dcl lcl_code fixed bin(35); call iox_$control (tty_iocb, "resetread", null(), lcl_code); return; end flush_input_buffer; exec_com: proc(line); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>> System Dependency <<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ /********************************************************************/ /* Pass line along to the command processor. */ /********************************************************************/ dcl line char(*) var; dcl com_line char(length(line)) aligned init(line); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ call cu_$cp(addr(com_line), length(line), code); return; end exec_com; setup_terminal: proc (code); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>> System Dependency <<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ /********************************************************************/ /* Configure the terminal modes so that packets will get */ /* through the fnp. See note on new_term_modes in beginning. */ /********************************************************************/ dcl code fixed bin(35); call iox_$control (tty_iocb, "set_framing_chars", addr(new_framing_chars), code); if code ^= 0 then return; call iox_$modes (tty_iocb, term_modes, "", code); return; end setup_terminal; reset_terminal: proc (code); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>> System Dependency <<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ /********************************************************************/ /* Reverse action of above procedure */ /********************************************************************/ dcl code fixed bin(35); call iox_$modes (tty_iocb, old_term_modes, "", code); if code ^= 0 then return; call iox_$control (tty_iocb, "set_framing_chars", orig_fc_ptr, code); return; end reset_terminal; end kermit_;