/* MULTICS KERMIT in PL/I */ /* Editor's note: 3 short PL/I preprocessor "include" files follow. */ /* These should be separated into files of the indicated names. */ /* After these 3 include files comes the main program, which accounts */ /* for the rest of this file. */ /*===================== 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 =====================*/ /*===================== 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 =====================*/ /*================= Begin ret_structure.incl.pl1 <<<<<<<<<<<<<<<<<*/ dcl 1 ret_structure, 2 line char(100) var, 2 more_commands bit(1), 2 command_code fixed bin, 2 error bit(1), 2 error_code fixed bin, 2 type fixed bin, 2 parm fixed bin, 2 parm_val fixed bin; /*================== End ret_structure.incl.pl1 <<<<<<<<<<<<<<<<<<*/ new_kermit: old_kermit: latest_kermit: frog: kermit: proc; /********************************************************************/ /* This is a packet-based communications program implementing */ /* the Kermit protocol. The target is a microcomputer running */ /* a local version of Kermit. */ /********************************************************************/ /********************************************************************/ /*>>>>>>>>>>>>> Copyright (C) Oakland University 1983 <<<<<<<<<<<<*/ /*>>> Copying without fee is permitted provided that the copies <<*/ /*>>> are not made or distributed for commercial advantage and <<<*/ /*>>>>>>>>>>>>>>>> credit to the source is given. <<<<<<<<<<<<<<<<*/ /********************************************************************/ /********************************************************************/ /* The Version 1 protocol supporting send and receive with most */ /* of the commands in the help file implemented was finished */ /* around Sept 20, 1983. */ /* */ /* */ /* The Author of this program is: */ /* . Paul Amaranth */ /* . Oakland University */ /* . Academic Computer Services */ /* . Rochester, MI 48063 */ /* . (313) 377 - 4329 */ /* */ /* Please send copies of any changes to me at the above address. */ /* */ /* */ /* UPDATES: */ /* 1 Dec 83: Fix packet number compares for mod 64 wraparound */ /* by adding proc previous_packet_no() */ /* */ /********************************************************************/ /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>> Declarations <<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ %include ret_structure; /********************************************************************/ /* Constants */ /********************************************************************/ dcl big char(26) static static options(constant) init("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); dcl sml char(26) static static options(constant) init("abcdefghijklmnopqrstuvwxyz"); dcl numbers char(10) static options(constant) init("0123456789"); dcl null_char char(1) 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 static options(constant) init("0"b); dcl blank char(1) static static options(constant) init(" "); dcl true bit(1) static static options(constant) init("1"b); dcl carraige_return char(1) static options(constant) init(" "); dcl line_feed char(1) static options(constant) init(" "); /********************************************************************/ /* Symbols */ /********************************************************************/ dcl max_packet_size fixed bin static init(94); dcl delete char(1) static init("") static; dcl my_quote char(1) static init("#") static; dcl my_pad fixed bin static init(0) static; dcl my_pad_char fixed bin static init(0) static; dcl my_end_of_line fixed bin init(car_ret) ; /********************************************************************/ /* 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"); /********************************************************************/ /* 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"); /********************************************************************/ /* Blck transfer framing character info structures. */ /********************************************************************/ dcl 1 orig_framing_chars static aligned, 2 start_char char(1) unaligned, 2 end_char char(1) unaligned; dcl 1 new_framing_chars static aligned, 2 start_char char(1) unaligned init(""), /* no start char */ 2 end_char char(1) unaligned init(" "); dcl orig_fc_ptr ptr init(addr(orig_framing_chars)); dcl new_fc_ptr ptr init(addr(new_framing_chars)); /********************************************************************/ /* Global variables */ /********************************************************************/ dcl state char(2); /* Present state of automaton */ dcl size fixed bin; /* Size of present data */ dcl file_ptr fixed bin; /* Ptr to name of file being transmitted */ dcl rp_size fixed bin static; /* Maximum receive packet size */ dcl sp_size fixed bin static; /* Maximum send packet size */ dcl quote char(1) static; /* Quote character in incomming data */ dcl pad fixed bin static; /* How much padding to send */ dcl pad_char fixed bin static; /* Padding character to send */ dcl end_of_line fixed bin static; /* End-of-line to send */ dcl r_eol fixed bin static; /* End-of-line to receive */ dcl stimint fixed bin(71) static; /* Timeout for foreign host on sends */ dcl rtimint fixed bin(71) static; /* Timeout for host on receives */ dcl delay_time fixed bin(71) static; /* Time to delay for sends */ dcl max_try fixed bin init(25); /* Times to retry a packet */ dcl num_try fixed bin; /* Times this packet retried */ dcl old_try fixed bin; /* Times previous packet retried */ dcl current_packet_no fixed bin; /* Looking for msg number ... */ dcl init bit(1) static init("0"b); /* Flag for static ialization */ dcl packet_error_code fixed bin init(0); /* Status code for trans. */ dcl text_mode bit(1) static; /* Type of files to send, init true */ dcl eof_flag bit(1); /* Used with above. */ dcl num_files fixed bin; /* Number of files to send/receive */ dcl cur_file fixed bin; /* Current file pointer in list */ dcl file_warning_sw bit(1) static; /* Overwrite file warning */ dcl trace_sw bit(1) init(false); /* Trace facilty (debug) */ dcl trace_file file; /* For above */ dcl debug_sw bit(1) init(false); /* interactive debug */ dcl 1 files(100), /* List of 1 files to send/receive */ 2 dir char(168), 2 entry char(32); dcl 1 cur_file_name, 2 dir char(168), 2 entry char(32); dcl arg_lst_ptr ptr; dcl code fixed bin(35); dcl cur_inpt_bfr_len fixed bin(21); dcl default_dir char(168); dcl input_buffer char(input_bfr_len) aligned; dcl input_bfr_ptr ptr; dcl input_bfr_len fixed bin(21) static init(100); dcl iocb_ptr ptr; dcl iox_$user_io ptr static external; dcl nargs fixed bin; dcl output_iocb_ptr ptr; dcl prog char(6) static init("kermit"); dcl rel_secs_flag bit(2) static options(constant) init("11"b); dcl switch_name char(20) static init("user_input"); dcl tty_iocb ptr; /* Pointer to tty_ iocb for modes switching */ dcl last_char_sent char(1) var; /* 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 seg_length fixed bin(35); /* Number of CHARACTERS to send */ dcl cur_character fixed bin(35); /* Current character ptr */ dcl 1 transmit_buffer, 2 length fixed bin, 2 data (max_packet_size) char(1); dcl cleanup condition; dcl quit condition; dcl term_modes char(256) static init("rawi,rawo,no_outp,8bit,^echoplex"|| ",crecho,lfecho,^replay,^polite,^breakall,blk_xfer"); dcl old_term_modes char(256); /********************************************************************/ /* Error codes */ /********************************************************************/ dcl bad_command fixed bin static options(constant) init(1); dcl bad_file_spec fixed bin static options(constant) init(2); dcl bad_help_option fixed bin static options(constant) init(3); dcl bad_set_parm fixed bin static options(constant) init(4); dcl bad_set_spec fixed bin static options(constant) init(5); dcl bad_show_spec fixed bin static options(constant) init(6); dcl bad_syntax fixed bin static options(constant) init(7); dcl missing_set_parm fixed bin static options(constant) init(8); dcl mssng_set_parm_val fixed bin static options(constant) init(9); dcl non_numeric_val fixed bin static options(constant) init(10); dcl bad_octal_val fixed bin static options(constant) init(11); dcl bad_dir_name fixed bin static options(constant) init(12); dcl not_dir_name fixed bin static options(constant) init(13); 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); /********************************************************************/ /* Multics routines */ /********************************************************************/ dcl check_star_name_$entry entry (char(*), fixed bin(35)); dcl com_err_ entry options(variable); dcl continue_to_signal_ entry(fixed bin(35)); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin(21), fixed bin(35), ptr); dcl cu_$cp entry(ptr, fixed bin(21), fixed bin(35)); dcl cv_oct_ entry(char(*)) returns (fixed bin(35)); dcl cv_oct_check_ entry(char(*), fixed bin(35)) returns(fixed bin(35)); dcl expand_pathname_ entry(char(*), char(*), char(*), fixed bin(35)); 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_$star_ entry (char(*), char(*), fixed bin(2), ptr, fixed bin, ptr, ptr, fixed bin(35)); dcl hcs_$status_ entry(char(*), char(*), fixed bin(1), ptr, 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)); /********************************************************************/ /* 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; /********************************************************************/ /* Builtin functions */ /********************************************************************/ dcl null builtin; dcl length builtin; dcl time builtin; /********************************************************************/ /* Conditions */ /********************************************************************/ dcl program_interrupt condition; /********************************************************************/ /* Initialize stuff */ /********************************************************************/ /* Get and store terminal modes so terminal can be reset to init config. */ tty_iocb = iox_$user_io; call iox_$modes(tty_iocb, " ", old_term_modes, code); call iox_$find_iocb (switch_name, iocb_ptr, code); call iox_$control (tty_iocb, "get_framing_chars", orig_fc_ptr, code); input_bfr_ptr = addr(input_buffer); default_dir = get_wdir_(); more_commands = true; if ^init then do; quote = my_quote; pad = 0; rp_size = max_packet_size; stimint = 20; sp_size = max_packet_size; pad_char = my_pad_char; end_of_line = car_ret; my_pad = 0; delay_time = 8; file_warning_sw = false; r_eol = car_ret; rtimint = 20; init = true; text_mode = true; end; last_char_received = ""; current_packet_no = 0; file_ptr = 0; num_try = 0; old_try = 0; num_files = 0; cur_file = 0; /********************************************************************/ /* Main Procedure */ /********************************************************************/ call cu_$arg_count(nargs); if nargs > 0 then do; call cu_$arg_list_ptr (arg_lst_ptr); call process_command_args (arg_lst_ptr, nargs); return; end; else do; on program_interrupt goto mn_lp; mn_lp: do while(more_commands); error = false; call get_command(ret_structure); call check_syntax(ret_structure); if ^error then call exec_command(ret_structure); else call print_err_msg(error_code); end; end; return; process_command_args: proc (arg_list_ptr, nargs); /********************************************************************/ /* Process the multics command line args. These can be -logout */ /* for automatic logout on successful completion of the */ /* operation, -server for server mode (unknown at this time), */ /* -send to send a group of files, -receive */ /* [ to receive a file, or -set to */ /* set parameters. */ /********************************************************************/ /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>> Declarations <<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ dcl nargs fixed bin; dcl indx fixed bin; dcl cindx fixed bin; dcl argl fixed bin(21); dcl num_options fixed bin static init(6) options(constant); dcl com_arg(num_options) char(20) var init ("-logout", "-server", "-receive", "-send", "-set", "-debug"); dcl file_str char(200) var; dcl arg char(argl) based(argp); dcl arg_list_ptr ptr; dcl argp ptr; dcl found bit(1); dcl auto_logout bit(1) init(false); dcl server_mode bit(1) init(false); dcl receive bit(1) init(false); dcl send bit(1) init(false); dcl status bit(1); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ on program_interrupt goto end_it; indx = 1; do while (indx ^> nargs); call cu_$arg_ptr_rel (indx, argp, argl, code, arg_list_ptr); found = false; cindx = 1; do while (cindx ^> num_options & ^found); if com_arg(cindx) = arg then found = true; else cindx = cindx + 1; end; goto case(cindx); case(1): /* -logout */ auto_logout = true; goto endcase; case(2): /* -server */ server_mode = true; call com_err_ (0,prog,"Warning: Server mode not implemented."); goto endcase; case(3): /* -receive [] */ receive = true; call cu_$arg_ptr_rel (indx+1, argp, argl, code, arg_list_ptr); if code ^= 0 then file_str = " "; /* Nothing else on line */ else file_str = arg; if substr(file_str,1,1) = "-" then file_str = ""; /* Oops ctrl arg */ else indx = indx + 1; file_str = rtrim(file_str); call check_filenames(file_str, status, num_files, files); if num_files > 1 | status = false then do; call com_err_ (0, prog, "Bad file name: " || arg); return; end; cur_file = num_files; /* 0 or 1 */ goto endcase; case(4): /* -send */ send = true; indx = indx + 1; call cu_$arg_ptr_rel (indx, argp, argl, code, arg_list_ptr); if code ^= 0 then do; call com_err_ (0, prog, "Missing file name."); return; end; file_str = arg; call check_filenames (file_str, status, num_files, files); if status = false | substr(file_str,1,1) = "-" then do; call com_err_ (0, prog, "Bad file name: "||file_str); return; end; cur_file = 1; /* First in list */ goto endcase; case(5): /* -set */ call com_err_ (0, prog, "Set control args not available."); return; case(6): /* Debug */ debug_sw = true; goto endcase; case(7): /* Bad control arg */ call com_err_ (0, prog, "Bad control arg: "||arg); return; endcase: indx = indx + 1; end; /********************************************************************/ /* Make sure only one of send or receive specified. */ /********************************************************************/ if ^send & ^receive then do; call com_err_ (0, prog, "You must specify either -send or -receive []"); return; end; if send & receive then do; call com_err_ (0, prog, "You can send, or receive, but not both at once."); return; end; /********************************************************************/ /* Actual transfer */ /********************************************************************/ if send then do; call send_stuff; end; if receive then do; call receive_stuff; end; if packet_error_code = 0 & auto_logout then /********************************************************************/ /* Logout if specified and no errors in transmission. */ /********************************************************************/ do; call exec_com("logout"); end; end_it: return; end process_command_args; get_command: proc(ret_structure); /********************************************************************/ /* Read a command from the terminal and put it into the comm */ /* structure. */ /********************************************************************/ %include ret_structure; dcl prompt char(16) static options(constant) init("Kermit-Multics> "); call ioa_$nnl(prompt); call iox_$get_line (iocb_ptr, input_bfr_ptr, input_bfr_len, cur_inpt_bfr_len, code); line = substr(input_buffer,1,cur_inpt_bfr_len-1); return; end get_command; check_syntax: proc(ret_structure); /********************************************************************/ /* Take line apart and check its syntax. Set pieces into */ /* ret_structure. */ /********************************************************************/ /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>> Declarations <<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ %include ret_structure; dcl str char(20); dcl t_line char(80) var; dcl item char(80) var; dcl non_trans_item char(80) var; dcl num_coms fixed bin static options(constant) init(12); dcl command(num_coms) char(20) var init ( "SEND", "RECEIVE", "HELP", "EXIT", "QUIT", "Q", "SET", "SHOW", "EXEC", "E", "STATUS", "DEBUG"); dcl num_set_ops fixed bin static options(constant) init(8); dcl option(num_set_ops) char(20) var init ( "PACKET-LENGTH", "PADDING", "PADCHAR", "TIMEOUT", "END-OF-LINE", "QUOTE", "ON", "OFF"); dcl send_str char(20) var static init("SEND"); dcl receive char(20) var static init("RECEIVE"); dcl delay char(20) var static init("DELAY"); dcl file_warning char(20) var static init("FILE-WARNING"); dcl trace char(20) var static init("TRACE"); dcl dir char(20) var static init("DIR"); dcl text char(20) var static init("TEXT"); dcl status bit(1); dcl found bit(1) init(false); dcl indx fixed bin; dcl send_type fixed bin static options(constant) init(1); dcl receive_type fixed bin static options(constant) init(2); dcl delay_type fixed bin static options(constant) init(3); dcl file_wrnng_type fixed bin static options(constant) init(4); dcl trace_type fixed bin static options(constant) init(5); dcl dir_type fixed bin static options(constant) init(6); dcl text_type fixed bin static options(constant) init(7); dcl all_type fixed bin static options(constant) init(8); dcl send_code fixed bin static options(constant) init(1); dcl receive_code fixed bin static options(constant) init(2); dcl stop_code fixed bin static options(constant) init(3); dcl set_code fixed bin static options(constant) init(4); dcl show_code fixed bin static options(constant) init(5); dcl help_code fixed bin static options(constant) init(6); dcl exec_code fixed bin static options(constant) init(7); dcl status_code fixed bin static options(constant) init(8); dcl null_command fixed bin static options(constant) init(9); dcl debug_code fixed bin static options(constant) init(10); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ if line || blank = blank then do; command_code = null_command; return; end; t_line = line; call get_item(t_line, item); item = translate(item,big,sml); do indx = 1 to num_coms while(^found); if command(indx) = item then do; found = true; command_code = indx; end; end; if ^found then do; error = true; error_code = bad_command; return; end; goto case(command_code); case(1) : /* Send files down to micro */ call check_filenames(t_line, status, num_files, files); if status = false then do; error = true; error_code = bad_file_spec; end; else do; command_code = send_code; end; cur_file = 1; goto endcase; case(2) : /* Receive files from micro */ call check_filenames(t_line, status, num_files, files); if num_files > 1 | status = false then do; error = true; error_code = bad_file_spec; end; else command_code = receive_code; cur_file = num_files; /* Will be a 0 or 1 */ goto endcase; case(3) : /* Help comamnd */ found = false; t_line = translate(t_line, big, sml); do indx = 1 to num_coms while(^found); if command(indx) = t_line then do; found = true; parm = indx; end; end; if ^found then do; if t_line = "" then parm = help_code; else do; error = true; error_code = bad_help_option; end; end; command_code = help_code; goto endcase; case(4) : case(5) : case(6) : /* Exit or Quit */ if t_line ^= "" then do; error = true; error_code = bad_syntax; end; else command_code = stop_code; goto endcase; case(7) : /* Set Parameters */ command_code = set_code; call get_item(t_line, item); item = translate(item,big,sml); if item = send_str then type = send_type; else if item = receive then type = receive_type; else if item = delay then type = delay_type; else if item = file_warning then type = file_wrnng_type; else if item = trace then type = trace_type; else if item = dir then type = dir_type; else if item = text then type = text_type; else do; error = true; error_code = bad_set_spec; end; /********************************************************************/ /* Continue processing of set parameters. At this point, the */ /* option has been identified, although the value has not. */ /********************************************************************/ if ^error then do; parm = 0; call get_item(t_line, item); non_trans_item = item; /* Save for possible later use */ item = translate(item,big,sml); found = false; do indx = 1 to num_set_ops; if option(indx) = item then do; parm = indx; found = true; end; end; if ^found & type ^= delay_type & type ^= dir_type then do; error = true; error_code = bad_set_parm; end; else do; if type = delay_type then t_line = item; if t_line = "" & type < delay_type then do; error = true; error_code = mssng_set_parm_val; end; else if (parm ^> 2 | parm = 4) & type ^= dir_type then /* Decimal arg */ do; if verify(t_line, numbers) > 0 then do; error = true; error_code = non_numeric_val; end; else parm_val = fixed(t_line); end; else if parm ^> 6 & parm ^< 3 then /* Octal arg */ do; str = t_line; parm_val = cv_oct_check_ (rtrim(str), code); if code ^= 0 | (code=0 & parm_val > 127) then do; error = true; error_code = bad_octal_val; end; end; else if type = dir_type then do; if non_trans_item = "" then do; error = true; error_code = mssng_set_parm_val; end; else line = non_trans_item; end; end; end; goto endcase; case(8) : /* Show Parameter values */ t_line = translate(t_line,big,sml); if t_line = send_str then type = send_type; else if t_line = receive then type = receive_type; else if t_line = file_warning then type = file_wrnng_type; else if t_line = delay then type = delay_type; else if t_line = trace then type = trace_type; else if t_line = dir then type = dir_type; else if t_line = text then type = text_type; else if t_line = "" then type = all_type; else do; error = true; error_code = bad_show_spec; end; command_code = show_code; goto endcase; case(9) : case(10) : /* Send a line to Multics */ command_code = exec_code; line = t_line; goto endcase; case(11) : /* Show the current status of transmission (error or complete) */ command_code = status_code; goto endcase; case(12) : /* Debug switch - on or off */ command_code = debug_code; found = false; parm = 0; do indx = 7 to num_set_ops while(^found); /* On or off only */ if option(indx) = t_line then do; parm = indx; found = true; end; end; if ^found then do; error = true; error_code = bad_syntax; end; goto endcase; endcase: return; end check_syntax; get_item: proc(line, item); /********************************************************************/ /* Chop off an item in line and return it. */ /********************************************************************/ dcl line char(*) var; dcl item char(*) var; dcl indx fixed bin; /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ line = ltrim(line); line = line || blank; indx = index(line,blank); item = substr(line,1,indx); item = rtrim(item); if indx < length(line) then line = substr(line,indx+1); else line = ""; line = rtrim(line); return; end get_item; check_filenames: proc (list, status, num_files, file_list); /********************************************************************/ /* Decode list into separate file names. List may be a */ /* starname or a single file name. */ /* */ /* */ /********************************************************************/ dcl list char(*) var; dcl status bit(1); dcl num_files fixed bin; dcl 1 file_list(*), 2 dir char(*), 2 entry char(*); dcl t_list char(80); dcl dirname char(168); dcl entryname char(32); dcl seg_ptr ptr; dcl entry_ptr ptr; dcl name_ptr ptr; dcl count fixed bin; dcl indx fixed bin; dcl seg_type bit(2) init("01"b) static; dcl 1 entries(count) aligned based(entry_ptr), (2 type bit(2), 2 nnames fixed bin(15), 2 nindex fixed bin(17)) unaligned; dcl names (sum(nnames(*))) char(32) aligned based(name_ptr); dcl name_area area(10000); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ status = true; num_files = 0; if list = "" then return; /* Null name list */ t_list = list; call expand_pathname_ (t_list, dirname, entryname, code); if code ^= 0 then do; status = false; return; end; call check_star_name_$entry (entryname, code); if code = 0 then /* Not a starname, single entry */ do; num_files = 1; status = true; file_list(1).dir = dirname; file_list(1).entry = entryname; return; end; if code ^= 1 & code ^= 2 then do; /* Bad starname */ status = false; return; end; /********************************************************************/ /* Have a good starname, expand it */ /********************************************************************/ seg_ptr = addr(name_area); call hcs_$star_ (dirname, entryname, 2, seg_ptr, count, entry_ptr, name_ptr, code); if code ^= 0 then do; status = false; return; end; do indx = 1 to count; if type(indx) = seg_type then do; num_files = num_files + 1; dir(num_files) = dirname; entry(num_files) = names(nindex(indx)); end; end; return; end check_filenames; print_err_msg: proc(err_code); /********************************************************************/ /* Print an error message on the terminal. */ /********************************************************************/ dcl err_code fixed bin; dcl errors (29) char(80) var static init ( "Unrecognized command. No action performed.", "Bad file specification.", "Unrecognized help option.", "Bad parameter on set command.", "Bad specification on set command.", "Bad parameter on show command.", "Improper syntax.", "Missing parameter on set command.", "Missing parameter value on set command.", "Non-numeric value where number should be.", "Bad value for octal argument.", "Bad directory name.", "That directory does not exist.", /* Reserved for future syntax errors */ "", "", "", "", "", "", "", "Too many retries", "Wrong packet type.", "Entered an unexpected state.", "Wrong packet number.", "Error on host CPU.", "File missing for send request.", "Record quota overflow; insufficient space available.", "File already exists; transmission aborted.", "Can't get segment for transmission."); call ioa_("Kermit-Multics **ERROR** -> "|| errors(err_code)); return; end print_err_msg; exec_command: proc(ret_structure); /********************************************************************/ /* This procedure is a case statement for the execution of */ /* kermit commands. */ /********************************************************************/ %include ret_structure; /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ goto case(command_code); /* Errors won't get to here */ case(1) : /* Send file(s) down to micro */ call send_stuff; goto endcase; case(2) : /* Receive file(s) from micro */ call receive_stuff; goto endcase; case(3) : /* Quit */ more_commands = false; goto endcase; case(4) : /* Set command */ call set_options(type, parm, parm_val, line); goto endcase; case(5) : /* Show current settings */ call display_parms(type); goto endcase; case(6) : /* Help */ call ioa_ ("Help not available at this time."); goto endcase; case(7) : /* Pass a line through to the command processor */ call exec_com (line); goto endcase; case(8) : /* Show status of last transmission */ call disp_status; goto endcase; case(9) : /* Null command */ goto endcase; case(10): /* Debug */ call set_debug (parm); goto endcase; endcase: return; end exec_command; set_debug: proc (val); /********************************************************************/ /* Turn the debug switch on or off. This is in a separate */ /* procedure from set_options because the command syntax is */ /* different. */ /********************************************************************/ dcl val fixed bin; if val = 7 then do; debug_sw = true; call ioa_ ("Debug enabled."); call ioa_ ("WARNING: Linkage faults will occur unless kermit_db_ is available."); end; else debug_sw = false; return; end set_debug; set_options: proc(type, parm, parm_val, str); /********************************************************************/ /* Set global variables according to commands */ /********************************************************************/ dcl type fixed bin; dcl parm fixed bin; dcl parm_val fixed bin; dcl error bit(1) init(false); dcl error_code fixed bin; dcl send fixed bin static init(1); dcl on fixed bin static init(7); dcl char char(1); dcl status bit(1); dcl str char(*) var; dcl f_str char(length(str)); dcl dirname char(168); dcl entryname char(32); dcl status_ptr ptr; dcl 1 status_info aligned based(status_ptr), 2 info, 3 type fixed bin(2) unaligned unsigned, 3 nnames fixed bin(16) unaligned unsigned, 3 names_relp bit(18) unaligned, 3 dtcm bit(36) unaligned, 3 dtu bit(36) unaligned, 3 mode bit(5) unaligned, 3 raw_mode bit(5) unaligned, 3 pad1 bit(8) unaligned, 3 records_unsigneded fixed bin(18) unaligned unsigned; /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ goto case(type); case(1): /* Send */ case(2): /* Receive */ if parm > 6 then do; error = true; error_code = bad_set_parm; end; else do; goto pcase(parm); pcase(1): /* Packet length */ if parm_val < 5 | parm_val > max_packet_size then do; error = true; error_code = bad_set_parm; end; else if type = send then sp_size = parm_val; else rp_size = parm_val; goto end_pcase; pcase(2): /* Number of padding characters */ if type = send then my_pad = parm_val; else pad = parm_val; goto end_pcase; pcase(3): /* Padding character */ char = substr(collate(),parm_val+1,1); if type = send then my_pad_char = parm_val; else pad_char = parm_val; goto end_pcase; pcase(4): /* Timeout interval */ if type = send then stimint = parm_val; else rtimint = parm_val; goto end_pcase; pcase(5): /* End of line terminator */ if type = send then end_of_line = parm_val; else r_eol = parm_val; goto end_pcase; pcase(6): /* Quote character */ char = substr(collate(),parm_val+1,1); if type = send then my_quote = char; else do; error = true; error_code = bad_set_parm; end; end_pcase: ; end; goto endcase; case(3): /* Delay */ delay_time = parm_val; goto endcase; case(4): /* File warning */ call ioa_("WARNING: File-warning not implemented."); if parm < 7 then do; error = true; error_code = bad_set_parm; end; else if parm = on then file_warning_sw = true; else file_warning_sw = false; goto endcase; case(5): /* Trace facility */ if parm < 7 then do; error = true; error_code = bad_set_parm; end; else if parm = on then trace_sw = true; else trace_sw = false; goto endcase; case(6): /* Change the default working directory */ if str = "-WD" then do; default_dir = get_wdir_(); end; else do; f_str = str; call expand_pathname_(f_str, dirname, entryname, code); if code ^= 0 then do; error = true; error_code = bad_dir_name; end; else do; allocate status_info; call hcs_$status_ (dirname, entryname, 0, status_ptr, null(), code); if code ^= 0 then do; error = true; error_code = bad_dir_name; end; else if status_info.type ^= 2 then do; error = true; error_code = not_dir_name; end; else do; default_dir = rtrim(dirname) || ">" || rtrim(entryname); end; free status_info; end; end; goto endcase; case(7): /* Text/Binary mode */ if parm < 7 then do; error = true; error_code = bad_set_parm; end; else if parm = on then text_mode = true; else text_mode = false; goto endcase; endcase: ; if error then call print_err_msg(error_code); return; end set_options; display_parms: proc(type); /********************************************************************/ /* Display various parameters on command. */ /********************************************************************/ dcl type fixed bin; /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ goto case(type); case(1): /* Send parameters */ call disp_send; goto endcase; case(2): /* Receive parameters */ call disp_receive; goto endcase; case(3): /* Delay time */ call disp_delay; goto endcase; case(4): /* File warning */ call disp_fw; goto endcase; case(5): /* Display Trace status */ call disp_trace; goto endcase; case(6): /* Display default directory */ call disp_dir; goto endcase; case(7): /* Mode */ call disp_mode; goto endcase; case(8): /* Everything */ call disp_send; call disp_receive; call disp_mode; call disp_delay; call disp_fw; call disp_dir; goto endcase; endcase: return; end display_parms; disp_send: proc; /********************************************************************/ /* Display send parameters */ /********************************************************************/ call ioa_(""); call ioa_("Send Parameters"); call ioa_("----------------------"); call ioa_("Packet size: ^d (decimal)",sp_size); call ioa_("Number of padding characters: ^d",my_pad); call ioa_("Pad character: ^o (octal)", my_pad_char); call ioa_("Timeout interval: ^d seconds",stimint); call ioa_("End of line character: ^o (octal)",end_of_line); call ioa_("Quote character: ^o (octal)", index(collate(),my_quote)-1); return; end disp_send; disp_receive: proc; /********************************************************************/ /* Display similar parameters for receive. */ /********************************************************************/ call ioa_(""); call ioa_("Receive Parameters"); call ioa_("----------------------"); call ioa_("Packet size: ^d (decimal)",rp_size); call ioa_("Number of padding characters: ^d",pad); call ioa_("Pad character: ^o (octal)",pad_char); call ioa_("Timeout interval: ^d seconds",rtimint); call ioa_("End of line character: ^o (octal)",r_eol); call ioa_("Quote character: ^o (octal)",index(collate(),quote)-1); return; end disp_receive; disp_delay: proc; call ioa_ (""); call ioa_("Initial delay: ^d seconds.", delay_time); return; end disp_delay; disp_fw: proc; call ioa_ (""); if file_warning_sw then call ioa_("File warning switch is ON."); else call ioa_("File warning switch is OFF."); return; end disp_fw; disp_trace: proc; call ioa_(""); if trace_sw then call ioa_("The trace facility is ON."); else call ioa_("The trace facility is OFF."); return; end disp_trace; disp_dir: proc; call ioa_(""); call ioa_("The default directory is: " || rtrim(default_dir)); return; end disp_dir; disp_mode: proc; if text_mode then call ioa_("Text mode is in effect."); else call ioa_("Binary mode is in effect."); return; end disp_mode; disp_status: proc; /********************************************************************/ /* Display the status of the last transmission */ /********************************************************************/ dcl msgs(4) char(80) var static init ( "Too many retries on last packet; transmission aborted.", "Wrong packet type on transmitted packet.", "Unexpected program state entered; transmission aborted.", "Wrong packet number on transmitted packet."); dcl indx fixed bin; if packet_error_code = 0 then do; call ioa_ ("Last attempted transmission (if any) was successful."); end; else do; indx = packet_error_code - 20; call ioa_ (msgs(indx)); end; return; end disp_status; exec_com: proc(line); /********************************************************************/ /* 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; send_stuff: proc; /********************************************************************/ /* Controlling procedure for sending message packets. Returns */ /* true if completed successfullyl, false otherwise. False is */ /* used to send errors back. */ /********************************************************************/ /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>> Declarations <<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ dcl loop bit(1) init(true); dcl status bit(1); dcl indx fixed bin; dcl states char(14) init(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) */ on quit begin; if trace_sw then close file(trace_file); call iox_$control (tty_iocb, "set_framing_chars", orig_fc_ptr, code); call iox_$modes(tty_iocb,old_term_modes,(""),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; call iox_$control (tty_iocb, "set_framing_chars", orig_fc_ptr, code); call iox_$modes(tty_iocb, old_term_modes, (""), code); state = abort_state; packet_error_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 then call kermit_db_$init; /* Init event channels for ipc */ state = send_init_state; cur_file_name = files(cur_file); current_packet_no = 0; num_try = 0; call ioa_("OK"); if delay_time > 0 then /* Delay for time */ do; call timer_manager_$sleep (delay_time, rel_secs_flag); end; if ^debug_sw then /* Change terminal modes, not necessary under debug */ do; call iox_$control (tty_iocb, "set_framing_chars", new_fc_ptr, code); call iox_$modes (tty_iocb, term_modes, (""), code); /* Set up raw io mode */ end; do while(loop); indx = index(states, state); if indx = 0 then indx = 8; else indx = (indx + 1) / 2; /* Two character state names */ goto case(indx); case(1): /* Send data */ call send_data; goto end_case; case(2): /* Send file */ call send_file(file_ptr); goto end_case; case(3): /* End of file */ call send_eof; goto end_case; case(4): /* Send initial packet */ call send_init; goto end_case; case(5): /* Send a break packet */ call send_break; goto end_case; case(6): /* Transmission Complete */ packet_error_code = 0; loop = false; goto end_case; case(7): /* Abort transmission */ case(8): /* Unknown state */ loop = false; goto end_case; end_case: end; if debug_sw then call kermit_db_$term; /* Terminate comm seg */ call iox_$modes (tty_iocb, old_term_modes, (""), code); /* Reset terminal */ call iox_$control (tty_iocb, "set_framing_chars", orig_fc_ptr, code); if state = abort_state then call error_control; if trace_sw then close file(trace_file); return; end send_stuff; send_data: proc; /********************************************************************/ /* Send a data packet */ /********************************************************************/ /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>> Declarations <<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ %include packet; 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; packet_error_code = too_many_tries; return; end; call build_data_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 = 3; /* Unknown packet type */ goto case(indx); case(1): /* Ack */ if current_packet_no ^= num then return; call fill_transmit_buffer (status); if status = false then do; state = send_eof_state; end; current_packet_no = mod(current_packet_no+1, 64); goto endcase; case(2): /* Nack */ goto endcase; case(3): /* Didnt expect this one */ state = abort_state; packet_error_code = wrong_packet_type; goto endcase; endcase: return; end send_data; send_file: proc(file_ptr); /********************************************************************/ /* 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 <<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ %include packet; dcl indx fixed bin; dcl status bit(1); dcl packet_types char(2) init(ack_type || nack_type); dcl file_ptr fixed bin; if num_try > max_try then do; state = abort_state; packet_error_code = too_many_tries; return; end; 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 = 3; /* 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; call fill_transmit_buffer (status); /* Better be true */ current_packet_no = mod(current_packet_no+1, 64); goto endcase; case(2): /* Nack */ goto endcase; case(3): /* Didnt expect this one */ state = abort_state; packet_error_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 advances the file_ptr. If successful (another file to */ /* send), the state is changed to send_file_state. On failure, */ /* the state becomes break_connection_state. */ /********************************************************************/ /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>> Declarations <<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ %include packet; 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; packet_error_code = too_many_tries; return; end; /********************************************************************/ /* Build EOF packet */ /********************************************************************/ type = eof_type; len = 0; num = current_packet_no; call send_packet (packet); call hcs_$terminate_noname (transmit_seg_ptr, code); call receive_packet (packet, stimint, status); if status = false then return; indx = index(packet_types, type); if indx = 0 then indx = 3; /* Unknown packet type */ goto case(indx); case(1): /* Ack */ if current_packet_no ^= num then return; 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); goto endcase; case(2): /* Nack */ goto endcase; case(3): /* Didnt expect this one */ state = abort_state; packet_error_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. */ /********************************************************************/ %include packet; dcl packet_types char(2) init(ack_type || nack_type); dcl status bit(1); dcl indx fixed bin; /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ num = current_packet_no; len = 6; type = send_type; 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 num_try > max_try then /* Abort if too many tries */ do; state = abort_state; packet_error_code = too_many_tries; return; end; num_try = num_try + 1; call send_packet(packet); call receive_packet(packet, stimint, status); if status = false then return; /* Packet not received. */ indx = index(packet_types, type); if indx = 0 then indx = 3; goto case(indx); case(1): if current_packet_no ^= num then return; /* Wrong ack */ rp_size = unchar(data(1)); /* Packet size */ rtimint = max(12, unchar(data(2))); /* Timeout */ pad = unchar(data(3)); /* Num padding chars */ pad_char = nctl(data(4)); /* Pad charancter */ if data(5) = null_char then r_eol = car_ret; else r_eol = unchar(data(5)); if data(6) = null_char then quote = my_quote; else quote = data(6); 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; packet_error_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. */ /********************************************************************/ %include packet; 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; packet_error_code = too_many_tries; return; end; num_try = num_try + 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 = 3; goto case(indx); case(1): /* Ack */ if current_packet_no ^= num then goto endcase; /* Wrong one */ if state ^= abort_state then state = completed_state; goto endcase; case(2): /* Nack */ goto endcase; case(3): /* Wrong packet type */ if state = abort_state then goto endcase; state = abort_state; packet_error_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(cur_file); end; return; end get_next_file; setup_seg_for_transmit: proc; /********************************************************************/ /* 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; packet_error_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_char_sent = ""; /* init var. This is used to keep track of crlf */ /* combinations. lf -> crlf crlf unchanged */ return; end setup_seg_for_transmit; fill_transmit_buffer: proc (status); /********************************************************************/ /* This procedure fills the global variable transmit_buffer */ /* with characters from the current segment. It advances the */ /* global variable cur_character to point to the next one. */ /* This procedure is responsible for quoting non-printable */ /* characters and quotes as well as repeat characters and */ /* parity quoting whenever I get around to that stuff. */ /********************************************************************/ /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>> Declarations <<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ dcl status bit(1); dcl char char(1); dcl num_rep fixed bin; dcl stop_reading bit(1) init(false); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ if cur_character > seg_length then /* No more to send */ do; status = false; return; end; transmit_buffer.length = 0; do while(transmit_buffer.length < sp_size-3 & ^stop_reading & cur_character ^> seg_length); char = substr(segment, cur_character,1); num_rep = fixed ("0"b || unspec(char)); if char = line_feed then /* Change to CRLF combination */ do; if last_char_sent = carraige_return & transmit_buffer.length < sp_size-4 then do; transmit_buffer.data(transmit_buffer.length+1) = quote; transmit_buffer.data(transmit_buffer.length+2) = "J"; /* ctrl-j -> lf */ transmit_buffer.length = transmit_buffer.length+2; end; else if last_char_sent ^= carraige_return & transmit_buffer.length < sp_size-6 then do; /* Send controllified CRLF combination */ transmit_buffer.data(transmit_buffer.length+1) = quote; transmit_buffer.data(transmit_buffer.length+2) = "M"; /* ctrl-m -> cr */ transmit_buffer.data(transmit_buffer.length+3) = quote; transmit_buffer.data(transmit_buffer.length+4) = "J"; /* ctrl-j -> lf */ transmit_buffer.length = transmit_buffer.length+4; end; else stop_reading = true; end; else if num_rep < 32 /* Blank */ | num_rep > 126 /* Tilde */ then do; /* Must be controllified - if sufficient space remains in the buffer */ if transmit_buffer.length < sp_size-4 then do; transmit_buffer.data(transmit_buffer.length+1) = quote; transmit_buffer.data(transmit_buffer.length+2) = ctl(num_rep); transmit_buffer.length = transmit_buffer.length + 2; end; else stop_reading = true; end; else if char = quote then do; if transmit_buffer.length < sp_size-4 then do; transmit_buffer.data(transmit_buffer.length+1) = quote; transmit_buffer.data(transmit_buffer.length+2) = quote; transmit_buffer.length = transmit_buffer.length + 2; end; else stop_reading = true; end; else do; transmit_buffer.data(transmit_buffer.length+1) = char; transmit_buffer.length = transmit_buffer.length+1; end; if ^stop_reading then do; cur_character = cur_character + 1; last_char_sent = char; end; end; /* while */ return; end fill_transmit_buffer; build_data_packet: proc(packet); /********************************************************************/ /* Put the stuff in the transmit buffer into the packet data */ /* structure. */ /********************************************************************/ /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>> Declarations <<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ %include packet_parm; dcl indx fixed bin; /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ type = data_type; len = transmit_buffer.length; num = current_packet_no; do indx = 1 to len; data(indx) = transmit_buffer.data(indx); end; 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 <<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ %include packet_parm; dcl indx fixed bin; dcl file_name char(32) var; dcl buf_ptr fixed bin; dcl num_periods fixed bin init(0); dcl char char(1); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ type = file_type; num = current_packet_no; file_name = rtrim(cur_file_name.entry); buf_ptr = 1; indx = 1; do while (indx ^> length(file_name)); char = substr(file_name, indx,1); if char = "." then num_periods = num_periods + 1; if num_periods = 2 then do; indx = length(file_name)+1; /* exit loop */ buf_ptr = buf_ptr - 1; /* Adjust count */ end; else do; data(buf_ptr) = char; if char = quote then do; data(buf_ptr+1) = quote; buf_ptr = buf_ptr + 1; end; end; buf_ptr = buf_ptr + 1; indx = indx + 1; end; len = buf_ptr - 1; return; end build_file_packet; receive_stuff: proc; /********************************************************************/ /* Receive a packet. Return a true is operation successfully */ /* completes. */ /********************************************************************/ %include packet; dcl states char(10) init(receive_init_state || receive_file_state || receive_data_state || completed_state || abort_state); dcl loop bit(1) init(true); dcl indx fixed bin; dcl record_quota_overflow condition; dcl error condition; /* Reset terminal on quit (especially echoplex) */ on quit begin; if trace_sw then close file(trace_file); call iox_$control (tty_iocb, "set_framing_chars", orig_fc_ptr, code); call iox_$modes(tty_iocb,old_term_modes,(""),code); call continue_to_signal_ (code); end; /* If any other error condition arises, reset the terminal and */ /* continue to signal the condition upward. */ on record_quota_overflow begin; call iox_$control (tty_iocb, "set_framing_chars", orig_fc_ptr, code); call iox_$modes(tty_iocb, old_term_modes, (""), code); state = abort_state; packet_error_code = record_quota_ov; call error_control; if trace_sw then close file(trace_file); call continue_to_signal_ (code); end; on error begin; call iox_$control (tty_iocb, "set_framing_chars", orig_fc_ptr, code); call iox_$modes(tty_iocb, old_term_modes, (""), code); state = abort_state; packet_error_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 then call kermit_db_$init; /* Init event channels */ state = receive_init_state; num_try = 0; call ioa_("OK"); if ^debug_sw then do; /* Set stty to handle 8 bit no parity raw io */ call iox_$control(tty_iocb, "set_framing_chars", new_fc_ptr, code); call iox_$modes(tty_iocb, term_modes, (""), code); end; do while(loop); indx = index(states, state); if indx = 0 then indx = 6; else indx = (indx+1) / 2; goto case(indx); case(1): /* Receive an initial packet */ call receive_init; goto endcase; case(2): /* Receive a file header */ call receive_file; goto endcase; case(3): /* Receive data */ call receive_data; goto endcase; case(4): /* Transfer complete */ loop = false; goto endcase; case(5): /* Something failed, in abort */ loop = false; goto endcase; case(6): /* Unknown state, abort */ state = abort_state; packet_error_code = unknown_state; loop = false; goto endcase; endcase: end; if debug_sw then call kermit_db_$term; /* Terminate com seg */ /* Reset terminal to handle normal I/O */ call iox_$modes(tty_iocb, old_term_modes, (""), code); call iox_$control(tty_iocb, "set_framing_chars", orig_fc_ptr, code); if state = abort_state then call error_control; if trace_sw then close file(trace_file); return; end receive_stuff; receive_init: proc; /********************************************************************/ /* Recieve the send initiate packet from the host sending files */ /* and ack with a packet containing our parameters. */ /********************************************************************/ %include packet; dcl status bit(1); if num_try > max_try then do; packet_error_code = too_many_tries; state = abort_state; return; end; num_try = num_try + 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; rp_size = unchar(data(1)); rtimint = max(12, unchar(data(2))); pad = unchar(data(3)); pad_char = nctl(data(4)); end_of_line = unchar(data(5)); quote = data(6); data(*) = " "; call send_init_packet(current_packet_no); state = receive_file_state; old_try = num_try; num_try = 0; current_packet_no = mod(current_packet_no+1, 64); end; else do; /* Unknown packet type */ state = abort_state; packet_error_code = unknown_state; end; return; end receive_init; 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. */ /********************************************************************/ %include packet; 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; packet_error_code = too_many_tries; return; end; num_try = num_try + 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 = 5; goto case(indx); case(1): /* Send initiate packet */ /* Must have lost the ack */ if old_try > max_try then do; state = abort_state; packet_error_code = too_many_tries; end; else do; old_try = old_try + 1; if num = previous_packet_no(current_packet_no) then do; call send_init_packet(previous_packet_no(current_packet_no)); num_try = 0; end; else do; state = abort_state; packet_error_code = wrong_packet_no; end; end; goto endcase; case(2): /* End of file packet */ /* Saw this one before in receive_data */ if old_try > max_try then do; state = abort_state; packet_error_code = too_many_tries; end; else do; old_try = old_try + 1; 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; packet_error_code = wrong_packet_no; end; end; goto endcase; case(3): /* File header */ if num ^= current_packet_no then do; state = abort_state; packet_error_code = wrong_packet_no; end; else do; call send_ack(current_packet_no); if cur_file = 0 then call get_file_name(data, len, cur_file_name); else cur_file_name = files(1); call open_file(cur_file_name); old_try = num_try; 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; packet_error_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 */ /* more than once. (grumble) This really shouldn't be */ /* necessary. */ status = true; do while(status); call send_ack (current_packet_no); call receive_packet(packet, 3, status); /* If we've timed out, assume ack received. */ end; state = completed_state; end; goto endcase; case(5): /* Unexpected type */ state = abort_state; packet_error_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. */ /********************************************************************/ %include packet; 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; packet_error_code = too_many_tries; return; end; num_try = num_try + 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 = 4; goto case(indx); case(1): /* File header packet (again) */ if old_try > max_try then do; state = abort_state; packet_error_code = too_many_tries; end; else do; old_try = old_try + 1; 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; packet_error_code = wrong_packet_no; end; end; goto endcase; case(2): /* Data packet */ if old_try > max_try then do; state = abort_state; packet_error_code = too_many_tries; end; else if num = current_packet_no then do; call add_chars(data, len); call send_ack(current_packet_no); old_try = num_try; 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; packet_error_code = wrong_packet_no; end; goto endcase; case(3): /* End of file packet */ if old_try > num_try then do; state = abort_state; packet_error_code = too_many_tries; end; else if num ^= current_packet_no then do; state = abort_state; packet_error_code = wrong_packet_no; end; else do; call close_file; call send_ack(current_packet_no); old_try = num_try; 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; packet_error_code = wrong_packet_type; goto endcase; endcase: return; end receive_data; make_char: proc(number) returns(char(1)); /********************************************************************/ /* 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 num fixed bin; dcl indx fixed bin; if num < 32 then indx = num + 64; else indx = num - 64; return(substr(collate(),indx+1,1)); end ctl; nctl: proc(char) returns(fixed bin); /********************************************************************/ /* Same as above */ /********************************************************************/ dcl char char(1); dcl indx fixed bin; indx = index(collate(), char); indx = indx - 1; if indx < 32 then indx = indx + 64; else indx = indx - 64; return(indx); end nctl; unctl: proc (char) returns(char(1)); /********************************************************************/ /* Variant of above. */ /********************************************************************/ dcl char char(1); dcl indx fixed bin; indx = nctl(char) + 1; return(substr(collate(),indx,1)); end unctl; add_data: proc (array, var_string, len); /********************************************************************/ /* Put data in var_string into character array. This routine */ /* SHOULD BE REMOVED when the next rewrite is done. */ /********************************************************************/ dcl var_string char(*) var; dcl array(*) char(*); dcl len fixed bin(21); dcl indx fixed bin; /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ do indx = 1 to len; array(indx) = substr(var_string,indx,1); end; return; end add_data; previous_packet_no: proc(pkt_no) returns(fixed bin); /********************************************************************/ /* Return number of previous packet */ /********************************************************************/ dcl pkt_no fixed bin; if pkt_no = 0 then retun(63); else return(pkt_no - 1); end previous_packet_no; send_init_packet: proc(pkt_no); /********************************************************************/ /* Send the packet containing our parameters */ /********************************************************************/ dcl pkt_no fixed bin; %include packet; 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; len = 6; type = ack_type; num = pkt_no; call send_packet(packet); return; end send_init_packet; send_ack: proc(pkt_no); /********************************************************************/ /* Send an ack packet */ /********************************************************************/ dcl pkt_no fixed bin; %include packet; 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; %include packet; 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. */ /********************************************************************/ %include packet; dcl indx fixed bin; dcl status bit(1); dcl err_msgs (9) 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."); /********************************************************************/ /*>>>>>>>>>>>>>>>>>>>>>>>>>>> Procedure <<<<<<<<<<<<<<<<<<<<<<<<<<*/ /********************************************************************/ indx = packet_error_code - 20; type = error_type; len = length(err_msgs(indx)); call add_data (data, err_msgs(indx), len); num = current_packet_no; /********************************************************************/ /* It is possible to not have the correct terminal config. */ /********************************************************************/ call iox_$modes(tty_iocb, term_modes, (""), 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. */ /********************************************************************/ call iox_$modes(tty_iocb, old_term_modes, (""), code); return; end error_control; get_file_name: proc (data, len, 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 data (*) char(1); 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; do indx = 1 to len; tentry = tentry || data(indx); end; 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 get_file_name; open_file: proc(file_name); /********************************************************************/ /* Procedure to open a file */ /********************************************************************/ dcl 1 file_name, 2 dir char(*), 2 entry char(*); dcl output file; eof_flag = false; open file(output) title("vfile_ " || rtrim(dir) || ">" || entry) output; call iox_$find_iocb("output", output_iocb_ptr, code); return; end; close_file: proc; dcl output file; close file(output); output_iocb_ptr = null(); return; end; add_chars: proc(data, len); /********************************************************************/ /* Put characters in output file */ /********************************************************************/ dcl data(*) char(1); dcl len fixed bin(21); dcl indx fixed bin; dcl t_str char(150) var init(""); dcl str char(150) aligned; dcl eof_char char(1) static options(constant) init(""); /********************************************************************/ /* 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. */ /********************************************************************/ if text_mode then do; if eof_flag then return; indx = 1; do while (indx ^> len & ^eof_flag); if data(indx) = eof_char then eof_flag = true; else t_str = t_str || data(indx); indx = indx + 1; end; if eof_flag then len = length(t_str); /* Adj char count on eof */ end; else do indx = 1 to len; t_str = t_str || data(indx); end; str = t_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 */ /********************************************************************/ %include packet_parm; 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 i fixed bin init(0); dcl SOH char(1) static options(constant) init(""); 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 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 (iocb_ptr, input_bfr_ptr, input_bfr_len, cur_inpt_bfr_len, code); call timer_manager_$reset_alarm_call (abort_read); end; if trace_sw then call log_receive (input_bfr_ptr, cur_inpt_bfr_len); line = substr(input_buffer, 1, cur_inpt_bfr_len-1); line_len = length(line); indx = index(line, SOH); if indx = 0 | indx = line_len then do; status = false; return; end; /********************************************************************/ /* Cut off Start of Header character */ /********************************************************************/ start_with_header: /* This is the possible target of a goto. */ /* I'll rewrite this one of these days.... */ line = substr(line, indx+1); line_len = length(line); if line_len < 4 then /* No control info */ do; status = false; return; end; /********************************************************************/ /* Handle checksum for first 4 bytes (not including SOH) */ /********************************************************************/ do indx = 1 to 3; call add_ck_sm (cksum, substr(line,indx,1)); end; /* Space will be in position 33 in collating sequence */ /* Numbers have been shifted to printable characters */ /* by adding a space (octal 040) to their value */ len = index(collate(), substr(line,1,1)) - 33; len = len - 3; /* Remove other control and checksum from len */ num = index(collate(), substr(line,2,1)) - 33; /* Message number */ type = substr(line,3,1); /********************************************************************/ /* Handle rest of characters in packet */ /********************************************************************/ do indx = 4 to line_len-1; char = substr(line, indx, 1); if char = SOH then /* Resynch problem */ do; cksum = 0; goto start_with_header; end; else /********************************************************************/ /* Quote characters identify following characters that have to */ /* be fixed up. EXCEPT in initial packets where the quote */ /* character is sent in the packet as a literal. Picky picky. */ /********************************************************************/ if char = my_quote & type ^= send_type & prev_char_not_quote then do; unctl_nxt_char = true; prev_char_not_quote = false; end; else if unctl_nxt_char & char ^= my_quote then do; i = i + 1; /* Since the quote character was counted in the packet length, */ /* it must be subtracted in order to get the correct data length */ len = len - 1; data(i) = unctl(char); unctl_nxt_char = false; prev_char_not_quote = true; end; else do; i = i + 1; data(i) = char; if unctl_nxt_char then /* Last character was a quote and so is this one */ do; prev_char_not_quote = true; unctl_nxt_char = false; len = len - 1; end; end; if i>0 then do; /********************************************************************/ /* Handle various CR - LF combinations, including the case */ /* where they are split across packets. */ /********************************************************************/ if data(i) = line_feed & last_char_received = carraige_return & i > 1 then do; /* Change to Multics representation - single line feed */ i = i - 1; data(i) = line_feed; len = len - 1; /* Adjust downward */ end; else if data(i) = carraige_return & indx = line_len - 1 then do; /*********************************************************/ /* May be splitting CRLF between packets, defer to later */ /*********************************************************/ len = len - 1; end; else if last_char_received = carraige_return & indx < 6 & data(1) ^= line_feed then do; /***************************************************************/ /* Here the CR deferred from the prev. packet is handled. Note */ /* that if it is a CRLF, the CR is just ignored. */ /***************************************************************/ data(2) = data(1); /* Put the thing thats not a LF in pos 2 */ data(1) = carraige_return; i = i + 1; len = len + 1; end; last_char_received = data(i); /* Save last character to handle CRLF stuff */ end; call add_ck_sm (cksum, char); end; /* Get checksum in variable char */ char = substr(line, line_len); /********************************************************************/ /* Fix up check sum */ /********************************************************************/ /********************************************************************/ /* 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) & "000000000000000000000000000000111111"b; cksum = cksum + 32; if index(collate(),char)-1 ^= cksum then status = false; else status = true; 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; 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. */ /********************************************************************/ %include packet_parm; dcl cksum fixed bin(35); dcl char_cnt fixed bin; dcl packet_line char(250) var init(""); dcl SOH char(1) static options(constant) 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; /********************************************************************/ /* Put in character count (packet length) */ /********************************************************************/ char = make_char(len+3); 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; 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) & "000000000000000000000000000000111111"b; indx = cksum; /* Match up parameter types */ char = make_char(indx); packet_line = packet_line || char; /********************************************************************/ /* Tack on indicated end of line character */ /********************************************************************/ packet_line = packet_line || substr(collate(), end_of_line+1, 1); /********************************************************************/ /* Output line */ /********************************************************************/ if debug_sw then call kermit_db_$send_packet (packet_line); else call ioa_$nnl(packet_line); if trace_sw then call log_trans (packet_line); return; end send_packet; add_ck_sm: proc(sum, char); /********************************************************************/ /* Add the binary value of char to sum to do checksums */ /********************************************************************/ dcl sum fixed bin(35); dcl char char(1); dcl num fixed bin(9) unsigned; num = fixed ("0"b || unspec(char)); sum = sum + num; return; end add_ck_sm; 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; end kermit;