/* KERMIT.BUILD.CPL -- Build file for PRIME Kermit. */ &severity &error &routine err /* &args rest_of_line : uncl; compile : -c, -comp, -compile fn : entry = @.plp; ~ como : -como como_file : tree = kermit.build.como; load : -l, -load; ~ no_compress : -noc, -no_compress; rebuild : -r, -reb, -rebuild; ~ help : -h, -help, -u, -usage /* &if [null %compile%%load%%rebuild%] &then ~ &s help := HELP /* &if ^ [null %help%] &then ~ &do &call print_help &stop &end /* &if ^ [null %rebuild%] &then ~ &do &s compile := true &s load := true &end /* &if [null %no_compress%] & [index [quote %rest_of_line%] -debug] = 0 &then ~ &s compress := compress &else ~ &s compress := /* &if ^ [null %como%] &then ~ &do &debug &echo com como %como_file% date &end /* &if ^ [null %compile%] &then ~ &do &if [index [quote %rest_of_line%] -b] = 0 &then ~ &s binary := -b *>obj>=.+bin &else ~ &s binary := &if ^ [exists *>obj -dir] &then ~ create *>obj &else ~ &if ^ [null %rebuild%] &then ~ delete *>obj>@@ -nvfy -force /* &if [entryname %fn%] = %fn% &then /* [dir %fn%] = *, doesn't work. ~ &s fn := *>source>%fn% /* plp %fn% %binary% %rest_of_line% &end /* &if ^ [null %load%] &then ~ &data bind lo *>obj>kermit lo *>obj>kermit_init lo *>obj>bk_hndlr lo *>obj>timeout_hndlr lo *>obj>ren_hndlr lo *>obj>get_user_info lo *>obj>comnd lo *>obj>server lo *>obj>generic_cmd lo *>obj>rec_switch lo *>obj>rec_packet lo *>obj>get_response lo *>obj>send_switch lo *>obj>send_packet lo *>obj>connect lo *>obj>rec_amlc lo *>obj>send_amlc lo *>obj>input lo *>obj>utilities lo *>obj>chks lo *>obj>ack_send_init lo *>obj>prs_send_init lo *>obj>set_params lo *>obj>set_path lo *>obj>read_input lo *>obj>write_output lo *>obj>write_ibuf lo *>obj>log_packet lo *>obj>log_info lo *>obj>next_file lo *>obj>setup_trans_char lo *>obj>get_attr lo *>obj>get_dtc lo *>obj>get_len lo *>obj>change_dir lo *>obj>open_input lo *>obj>open_output lo *>obj>close_input lo *>obj>close_output lo *>obj>discard_output lo *>obj>open_log lo *>obj>match_file lo *>obj>assign lo *>obj>xfer_mode lo *>obj>get_error_msg lo *>obj>convert_file li dynt -all rdc nwc &if ^ [null %compress%] &then ~ %compress% map -undefined file &end /* &if ^ [null %como%] &then ~ como -e /* &stop /* &routine err /* type Error detected in Kermit build. /* &if ^ [null %como%] &then ~ como -e /* &stop /* &routine print_help /* type ~type ' Usage : CPL KERMIT.BUILD [-Compile [path_name]] [-Load] [-Rebuild]' ~type ' [-COMO [como_file]] [-NO_Compress] [-Help]' type type ' Where "path_name" is a Kermit source file path name which' type ' defaults to "*>SOURCE>@.PLP", and "como_file" is a COMO path' type ' name which defaults to "*>KERMIT.BUILD.COMO".' type /* &return ------------------------------------------------------------------------------- /* COMMON.INS.PLP -- Variables held in common storage for Kermit. */ %nolist; %Replace max_msg by 100, max_msg_less1 by 99, max_matches by 100, max_rem_pad_chrs by 255, ibuffer_size by 1024, ibuffer_size_wds by 512, max_take_level by 25; /* Message variables. */ Dcl snd_msg char (max_msg) var external, msg_number fixed bin external, rec_msg char (max_msg) var external, rec_pkt_type char (1) aligned external, /* Type of message received. */ rec_seq fixed bin external, rec_length fixed bin external, rec_file_size fixed bin (31) external, /* Received file attributes. */ rec_file_dtc fixed bin (31) external, rec_file_type fixed bin external, use_attributes bit (1) aligned external, /* Do we use the attributes ? */ 1 msg_table external, /* Packet table for windowing. */ 2 slot (0 : 63), 3 msg char (max_msg) var, 3 acked bit (1) aligned, 3 retries fixed bin, tab_first fixed bin external, /* First msg in the table. */ tab_next fixed bin external; /* Position of next msg. */ /* File transfer status variables. */ Dcl state fixed bin external, /* Current state. */ delay fixed bin external, /* Amount of time to delay. */ num_retries fixed bin external, /* Number of retries. */ max_retries fixed bin external, /* Maximum number of retries. */ quote8_char char (1) external, /* 8-bit quoting character. */ file_type fixed bin external, /* File storage type. */ explicit_ft_set bit (1) aligned external, /* File type has been set. */ first_write bit (1) aligned external, /* First write of the data. */ filename_warning bit (1) aligned external, /* File re-naming warning. */ do_repeats bit (1) aligned external, /* TRUE if repeat processing. */ do_transparent bit (1) aligned external, /* TRUE when transparent. */ do_flush bit (1) aligned external, /* Flush rcv buffer when sending. */ do_8bit_chks bit (1) aligned external, /* TRUE for none parity. */ auto_sum bit (1) aligned external, /* Try 7 and 8-bit checksums. */ packet_log_opened bit (1) aligned external, /* Packet log file opened. */ packet_log_unit fixed bin external, /* Packet log file unit. */ packet_log_pathname char (128) var external, /* Packet log pathname. */ session_log_opened bit (1) aligned external, /* Session log file opened. */ session_log_unit fixed bin external, /* Session log file unit. */ session_log_pathname char (128) var external, /* Session log pathname. */ session_log_save_line char (256) var external, /* Session log data. */ window_size fixed bin external, /* Transmission window size. */ errmsg char (128) var external, /* Error message buffer. */ timeout label external, /* Return point on timeout. */ brk_lbl label external, /* Return point on break. */ ren_lbl label external, /* Return point on re-enter. */ take_level fixed bin external, /* Number of TAKE files open. */ take_unit (max_take_level) fixed bin external; /* TAKE file units used. */ /* Local parameters. */ Dcl loc_pkt_size fixed bin external, /* Receive packet size. */ loc_npad fixed bin external, /* Padding length. */ loc_padchar char (1) external, /* Padding character. */ loc_timeout fixed bin external, /* Time out. */ loc_eol char (1) external, /* Eol character. */ loc_quote_chr char (1) external, /* Quote character. */ loc_8quote_chr char (1) external, /* 8-bit quoting character. */ loc_chk_type char (1) external, /* Checksum type. */ loc_rep_chr char (1) external, /* Repeat character. */ loc_capas1 fixed bin external, /* Capabilities byte 1. */ loc_file_attrib bit (1) aligned external, /* Ability to rcv attributes. */ loc_max_wsize fixed bin external; /* Max window size. */ /* Remote parameters. */ Dcl rem_pkt_size fixed bin external, /* Send packet size. */ rem_npad fixed bin external, /* Padding length. */ rem_padchar char (1) external, /* Padding character. */ rem_pad_chars char (max_rem_pad_chrs) external, /* String of padding characters. */ rem_timeout fixed bin external, /* Time out. */ rem_eol char (1) external, /* Eol character. */ rem_quote_chr char (1) external, /* Quote character. */ rem_8quote_chr char (1) external, /* 8-bit quoting character. */ rem_chk_type char (1) external, /* Checksum type. */ rem_rep_chr char (1) external, /* Repeat character. */ rem_capas1 fixed bin external, /* Capabilities byte 1. */ rem_file_attrib bit (1) aligned external, /* Ability to rcv attributes. */ rem_windowing bit (1) aligned external, /* Ability to do windowing. */ rem_max_wsize fixed bin external; /* Max window size. */ /* User Interface. */ Dcl kversion char (32) var external, /* Kermit version number. */ kprompt char (32) var external, /* Kermit command prompt. */ kprompt_len fixed bin external, /* Kermit prompt length. */ in_init_file bit (1) aligned external, /* In the initialization file. */ kermit_init_file char (128) var external, uppercase char (26) static external init ('ABCDEFGHIJKLMNOPQRSTUVWXYZ'), lowercase char (26) static external init ('abcdefghijklmnopqrstuvwxyz'); /* File Variables. */ Dcl path_name char (128) var external, /* Current path name. */ dir_name char (128) var external, /* Current directory name. */ non_null_dir bit (1) aligned external, /* Directory name is not null ? */ file_name char (32) var external, /* Current file name. */ alternate_fname char (32) var external, /* Alternate file name. */ file_unit fixed bin external, /* File unit. */ file_opened bit (1) aligned external, /* Flag for open files. */ file_len fixed bin (31) external, /* File length (bytes). */ file_pos fixed bin (31) external, /* File position (bytes). */ space_count fixed bin external, /* Space compression count. */ ignore_next bit (1) aligned external, /* Ignore next char after LF. */ next_is_lf bit (1) aligned external, /* Next char must be LF. */ saved_msg char (6) var external, /* Saved part of packet. */ saved_char char (1) var external, /* Saved last char from buffer. */ matches(max_matches) char (128) var external, /* Pathname list. */ num_matches fixed bin external, /* Number matches found. */ file_idx fixed bin external, /* Index into matches. */ del_incomplete bit (1) aligned external, /* Delete incomplete files. */ ibuffer char (ibuffer_size) external, /* Intermediate file buffer. */ ibuffer_ptr ptr external, /* Pointer to int_buffer. */ ibuflen fixed bin external, /* Length of int_buffer. */ ibuf_ptr fixed bin external, /* Pointer into int_buffer. */ char2 (2) char (1) unal external, /* Two character buffer. */ char2_ptr ptr external, /* And its pointer. */ pound_conversion bit (1) aligned external, /* Convert DOS pound signs. */ explicit_pound_set bit (1) aligned external, /* True if SET POUND used. */ trans_char (0 : 255) char (3) var external; /* Translation table. */ /* User Environment. */ Dcl my_msg_state fixed bin external, my_duplex bit (16) aligned external, my_half_duplex bit (16) aligned external, my_user_number fixed bin external, my_erase char (2) external, my_kill char (2) external, my_new_erase char (2) external, my_new_kill char (2) external; /* Character codes. */ Dcl nul_7bit_asc char (1) external, nul_8bit_asc char (1) external, ctrl_a_7bit_asc char (1) external, ctrl_a_8bit_asc char (1) external, bs_7bit_asc char (1) external, bs_8bit_asc char (1) external, cr_7bit_asc char (1) external, cr_8bit_asc char (1) external, lf_7bit_asc char (1) external, lf_8bit_asc char (1) external, ff_7bit_asc char (1) external, dc1_8bit_asc char (1) external, ctrl_z_7bit_asc char (1) external, ctrl_z_8bit_asc char (1) external, space_7bit_asc char (1) external, query_7bit_asc char (1) external, grave_7bit_asc char (1) external, del_8bit_asc char (1) external; /* Assigned line variables. */ Dcl use_amlc_line bit (1) aligned external, escape_char char (1) external, abort_char char (1) external, break_char char (1) external, saved_amlc_chrs char (128) var external, amlc_line fixed bin external, baud_rate fixed bin (31) external, baud_rate_index fixed bin external; %list; /* End of COMMON.INS.PLP */ ------------------------------------------------------------------------------- /* CONSTANTS.INS.PLP -- Constant values used by KERMIT. */ %nolist; %Replace /* Protocol states. */ state_s by 1, /* Send init state. */ state_sf by 2, /* Send file header. */ state_sd by 3, /* Send file data packet. */ state_sz by 4, /* Send EOF packet. */ state_sb by 5, /* Send break. */ state_r by 6, /* Receive send_init. */ state_rf by 7, /* Receive file header packet. */ state_rd by 8, /* Receive file data packet. */ state_x by 9, /* Text send init. */ state_xf by 10, /* Text header. */ state_c by 11, /* Send complete. */ state_a by 12, /* Abort. */ state_ra by 13, /* Receive attributes. */ state_sa by 14, /* Send attributes. */ state_rdw by 15, /* Rec data windowing. */ state_sdw by 16; /* Send data windowing. */ %Replace /* Status codes. */ ker_normal by 0, ker_internalerr by 1, ker_eof by 2, ker_nomorfiles by 3, ker_illfiltyp by 4, ker_exit by 5, ker_unimplgen by 6, ker_protoerr by 7; %Replace /* Message constants. */ pkt_count by 2, /* */ pkt_seq by 3, /* */ pkt_type by 4, /* */ pkt_msg by 5, /* */ pkt_ovr_head by 3, /* Overhead added to data length. */ pkt_tot_ovr_head by 6; /* Total overhead of the message. */ %Replace /* Message types. */ msg_data by 'D', /* Data packet. */ msg_attrib by 'A', /* File attributes. */ msg_ack by 'Y', /* Acknowledgement. */ msg_nak by 'N', /* Negative acknowledgement. */ msg_snd_init by 'S', /* Send initiate. */ msg_break by 'B', /* Break transmission. */ msg_file by 'F', /* File header. */ msg_eof by 'Z', /* End of file (EOF). */ msg_error by 'E', /* Error. */ msg_rcv_init by 'R', /* Receive initiate. */ msg_host_command by 'C', /* Host command. */ msg_text by 'X', /* Plain Text. */ msg_init_info by 'I', /* Initialize parameters. */ msg_kermit by 'K', /* Interactive KERMIT command. */ msg_kermit_generic by 'G', /* Generic KERMIT command. */ msg_timeout by 'T', /* Timeout. */ msg_check_err by 'Q'; /* Checksum error. */ %Replace /* Generic commands. */ msg_gen_login by 'I', /* Login. */ msg_gen_finish by 'F', /* Finish (exit to OS). */ msg_gen_cwd by 'C', /* Change Working Directory. */ msg_gen_logout by 'L', /* Logout. */ msg_gen_directory by 'D', /* List the directory. */ msg_gen_disk_usage by 'U', /* Disk usage. */ msg_gen_delete by 'E', /* Delete a file. */ msg_gen_type by 'T', /* Type a file. */ msg_gen_rename by 'R', /* Rename file. */ msg_gen_copy by 'K', /* Copy file. */ msg_gen_program by 'P', /* Program invocation. */ msg_gen_who by 'W', /* Who's logged in. */ msg_gen_send by 'M', /* Send a message to a user. */ msg_gen_help by 'H', /* Help. */ msg_gen_query by 'Q', /* Query status. */ msg_gen_journal by 'J', /* Transaction Journal. */ msg_gen_variable by 'V'; /* Set/Read Variables. */ /* * INITIALIZATION PACKET FORMAT. * * The following describes the send initiate packet. * All fields in the message data area are optional. * * <"S"> * <8-bit-quote> * * Bufsiz * Sending Kermit's maximum buffer size. * * Timeout * Number of seconds after which the sending Kermit wishes to be timed out. * * Npad * Number of padding characters the sending Kermit needs before each packet. * * PAD * Padding character. * * EOL * A line terminator required on all packets set by the receiving Kermit. * * Quote * The printable ASCII character the sending Kermit will use when quoting * the control characters. Default is "#". * * 8-bit-quote * Specify quoting mechanism for 8-bit quantities. A quoting mechanism is * necessary when sending to hosts which prevent the use of the 8th bit for * data. When elected, the quoting mechanism will be used by both hosts, * and the quote character must be in the range of 41-76 or 140-176 octal, * but different from the control-quoting character. This field is * interpreted as follows : * * "Y" - I agree to 8-bit quoting if you request it, * "N" - I will not do 8-bit quoting, * "&" - (or any other character in the range of 41-76 or 140-176) I want * to do 8-bit quoting using this character (it will be done if the * other Kermit puts a "Y" in this field), * Anything else : Quoting will not be done. * * Repeat * A printable ASCII character for compressing repeated characters. * The default is "~". A " " means no repeat character processing, also * it will only be done if both sides request it with the same character. */ %Replace /* Positions within the packet. */ p_si_bufsiz by 0, /* Buffer size. */ p_si_timout by 1, /* Time out. */ p_si_npad by 2, /* Number of padding characters. */ p_si_pad by 3, /* Padding character. */ p_si_eol by 4, /* End of line character. */ p_si_quote by 5, /* Quoting character. */ p_si_8quote by 6, /* 8-bit quoting character. */ p_si_chk by 7, /* Checksum type. */ p_si_rep by 8, /* Repeat character. */ p_si_capas by 9; /* Capabilities. */ %Replace /* Default initialization values. */ my_pkt_size by 94, /* My packet size. */ my_timeout by 15, /* My time out. */ my_npad by 0, /* Amount of padding I require. */ my_pad_chr by '00'b4, /* My pad character. */ my_eol_chr by '8D'b4, /* My EOL character. */ my_quote_chr by '#', /* My quoting character. */ my_8quote_chr by '&', /* My 8-bit quote character. */ my_chk_type by '1', /* My checksum type => single char. */ my_rep_chr by '~', /* My repeat character prefix. */ my_capas1 by '0C'b4, /* My capabilities => attr+windows. */ my_max_wsize by 6; /* My default window size. */ %Replace /* File types. */ automatic_ft by -1, /* AUTOMATIC file type detection. */ illegal_ft by 0, /* An ILLEGAL file type. */ ascii_ft by 1, /* ASCII/TEXT files. */ binary_ft by 2; /* BINARY/IMAGE files. */ %Replace /* Miscellaneous values. */ true by '1'b, /* Logical .TRUE. */ false by '0'b, /* Logical .FALSE. */ default_delay by 5, /* Initial delay time. */ default_max_retries by 5, /* Maximum number of retries. */ bignum by 2147483647, /* The biggest fixed bin number. */ current_attach_point by -1, /* File unit of current a.p. */ default_lword by 'E000'b4, /* Default async lword. */ default_config by '04CB'b4, /* Default async line configuration. */ default_packet_log by '*>PACKET.LOG', /* Default packet log path name. */ default_session_log by '*>SESSION.LOG', /* Default session log path name. */ default_kermit_init_fname by '*>PRIME_KERMIT.INIT', /* Default init file. */ ctrl_a_7bit_dec by '01'b4, /* Control-A */ ctrl_a_8bit_dec by '81'b4, cr_7bit_dec by '0D'b4, /* Carriage Return */ cr_8bit_dec by '8D'b4, lf_7bit_dec by '0A'b4, /* Line Feed */ lf_8bit_dec by '8A'b4, space_8bit_asc by ' ', query_8bit_asc by '?', grave_8bit_asc by '`', packet_log by 1, session_log by 2, enc110 by '000'b, /* Baud rate encryption bits. */ enc134 by '001'b, /* Actually 134.5 bps. */ enc300 by '010'b, enc1200 by '011'b, enc_clock by '100'b, /* Default 9600 */ enc_j1 by '101'b, /* Default 75 */ enc_j2 by '110'b, /* Default 150 */ enc_j3 by '111'b; /* Default 1800 */ %list; /* End of CONSTANTS.INS.PLP */ ------------------------------------------------------------------------------- /* KERMIT.INS.PLP -- Kermit declarations. */ /* This insert file contains all the declarations for the Kermit subroutines and functions. It also contains some based variables. */ %nolist; Dcl ack_send_init entry, assign entry (fixed bin, fixed bin, fixed bin), bk_hndlr entry (ptr), change_dir entry (char (128) var, fixed bin), chks entry (fixed bin, char (*) var) returns (fixed bin), close_input entry, close_output entry returns (fixed bin), comnd entry, connect entry (fixed bin), convert_file entry returns (fixed bin), discard_output entry (fixed bin), generic_cmd entry returns (fixed bin), get_attr entry, get_dtc entry returns (char (32) var), get_error_msg entry (fixed bin), get_len entry (bit (1) aligned) returns (fixed bin), get_response entry returns (bit (1) aligned), get_user_info entry, input entry (char (*) var, fixed bin) returns (bit (1) aligned), log_info entry (fixed bin, char (256) var), log_packet entry (char (1), fixed bin, char (*) var), match_file entry returns (fixed bin), kermit_init entry, next_file entry returns (fixed bin), open_input entry returns (fixed bin), open_log entry (fixed bin, char (128) var) returns (fixed bin), open_output entry returns (fixed bin), prs_send_init entry, read_input entry (fixed bin) returns (fixed bin), rec_amlc entry (fixed bin, char (*), fixed bin, fixed bin) returns (fixed bin), rec_packet entry, rec_switch entry, ren_hndlr entry (ptr), send_amlc entry (fixed bin, char (*), fixed bin) returns (fixed bin), send_packet entry (char (1), fixed bin, fixed bin), send_switch entry, server entry, set_params entry, set_path entry (char (128) var), setup_trans_char entry, timeout_hndlr entry (ptr), write_ibuf entry (fixed bin, fixed bin), write_output entry returns (fixed bin), xfer_mode entry (fixed bin, fixed bin); /* Kermit utilities. */ Dcl between entry (fixed bin, fixed bin, fixed bin) returns (bit (1) aligned), clr8 entry (char (1)) returns (char (1)), clr8str entry (char (*) var) returns (char (1024) var), ctl entry (char (1)) returns (char (1)), ctl_trans entry (bit (1) aligned, char (*) var) returns (char (128) var), knum entry (char (1)) returns (fixed bin), more entry returns (bit (1) aligned), set8 entry (char (1)) returns (char (1)), set8str entry (char (*) var) returns (char (1024) var); /* Based variables. */ Dcl fb15_based fixed bin (15) based, fb31_based fixed bin (31) based, char1_based char (1) based, char2_based char (2) based, bit8_based bit (8) aligned based, bit16_based bit (16) aligned based, 1 capas based, /* Capability structure. */ 2 rsv2 bit (12), 2 file_attributes bit (1), 2 windowing bit (1), 2 rsv1 bit (1), 2 continues bit (1); %list; /* End of KERMIT.INS.PLP */ ------------------------------------------------------------------------------- /* PRIMOS.INS.PLP -- PRIMOS declarations. */ /* This insert file contains all the PRIMOS subroutine and function declarations. It also contains the directory entries structure. */ %nolist; Dcl asnln$ entry (fixed bin, fixed bin, char (6), bit (16) aligned, fixed bin, fixed bin), as$set entry (fixed bin, fixed bin, fixed bin, ptr, ptr, fixed bin, fixed bin, fixed bin), at$ entry (fixed bin, char (*) var, fixed bin), at$hom entry (fixed bin), at$or entry (fixed bin, fixed bin), c1in entry ((2) char (1) unal), cl$get entry (char (*) var, fixed bin, fixed bin), cl$pix entry (bit (16) aligned, char (*) var, ptr, fixed bin, char (*) var, ptr, fixed bin, fixed bin, fixed bin), clo$fu entry (fixed bin, fixed bin), cnam$$ entry (char (*), fixed bin, char (*), fixed bin, fixed bin, fixed bin), cnin$ entry (char (*), fixed bin, fixed bin), comi$$ entry (char (*), fixed bin, fixed bin, fixed bin), comlv$ entry, cv$dtb entry (char (*) var, fixed bin (31), fixed bin), cv$fda entry (fixed bin (31), fixed bin, char (21)), date$ entry returns (fixed bin (31)), dir$rd entry (fixed bin, fixed bin, ptr, fixed bin, fixed bin), ds$avl entry (ptr, fixed bin, fixed bin), duplx$ entry (bit (16) aligned) returns (bit (16) aligned), ent$rd entry (fixed bin, char (*) var, ptr, fixed bin, fixed bin), erkl$$ entry (fixed bin, char (2), char (2), fixed bin), ertxt$ entry (fixed bin, char (*) var), fil$dl entry (char (*) var, fixed bin), finfo$ entry (fixed bin, ptr, fixed bin), fnchk$ entry (fixed bin, char (*) var) returns (bit (1) aligned), gpath$ entry (fixed bin, fixed bin, char (128), fixed bin, fixed bin, fixed bin), ioa$ entry options (variable), ioa$rs entry options (variable), limit$ entry (fixed bin, fixed bin (31), fixed bin, fixed bin), logo$$ entry (fixed bin, fixed bin, char (*), fixed bin, fixed bin (31), fixed bin), mgset$ entry (fixed bin, fixed bin), mkonu$ entry (char (*) var, entry) options (shortcall (20)), msg$st entry (fixed bin, fixed bin, char (*), fixed bin, char (*), fixed bin, fixed bin), pri$rv entry (char (*) var), prwf$$ entry (fixed bin, fixed bin, ptr options (short), fixed bin, fixed bin (31), fixed bin, fixed bin), q$read entry (char (*) var, (4) fixed bin (31), fixed bin, fixed bin, fixed bin), satr$$ entry (fixed bin, char (*), fixed bin, fixed bin (31), fixed bin), sleep$ entry (fixed bin (31)), smsg$ entry (fixed bin, char (32), fixed bin, fixed bin, char (*), fixed bin, char (*), fixed bin, (4) fixed bin), srch$$ entry (fixed bin, char (*), fixed bin, fixed bin, fixed bin, fixed bin), srsfx$ entry (fixed bin, char (*) var, fixed bin, fixed bin, fixed bin, char (*) var, char (*) var, fixed bin, fixed bin), t$amlc entry (fixed bin, ptr options (short), fixed bin, fixed bin, (2) fixed bin, fixed bin, fixed bin), timdat entry (1, fixed bin), tnchk$ entry (fixed bin, char (*) var) returns (bit (1) aligned), tnou entry (char (*), fixed bin), tnoua entry (char (*), fixed bin), tonl entry, tty$in entry returns (bit (1) aligned), tty$rs entry (fixed bin, fixed bin), uid$bt entry (char (6) aligned), uid$ch entry (char (6) aligned, char (13)), user$ entry (fixed bin, fixed bin), wild$ entry (char (*) var, char (*) var, fixed bin) returns (bit (1) aligned), wtlin$ entry (fixed bin, char (*), fixed bin, fixed bin); Dcl old_primos_revision bit (1) aligned external; /* True if Pre-rev 22. */ %Replace dir_entry_size by 37; /* Correct size at PRIMOS revision 22.1.1b. */ Dcl dir_entry_ptr ptr external; /* Pointer to the following structure. */ Dcl 1 dir_entry external, /* PRIMOS directory entry structure. */ 2 ecw, 3 type bit (8), 3 len bit (8), 2 entryname char (32), 2 pw_protection bit (16) aligned, 2 non_dflt_protection bit (1) aligned, 2 file_inf, 3 (long_rat_hdr, dumped, dos_mod, special) bit (1), 3 rwlock bit (2), 3 pad1 bit (2), 3 type bit (8), 2 dtm fixed bin (31), 2 spare (2) fixed bin, 2 trunc bit (1) aligned, 2 (dtb, dtc, dta) fixed bin (31), 2 bra fixed bin (31), 2 fileid char (8); Dcl file_info_ptr ptr external; /* Pointer to the following structure. */ Dcl 1 file_info external, /* PRIMOS file information structure. */ 2 version fixed bin, 2 status_and_mode bit (16) aligned, 2 file_information (4) fixed bin, 2 system_name char (32) var, 2 ldevno fixed bin, 2 diskname char (32) var; %list; /* End of PRIMOS.INS.PLP */ ------------------------------------------------------------------------------- /* ACK_SEND_INIT -- Setup our SND_INIT packet to send to other Kermit. */ Ack_send_init : proc; $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>constants.ins.plp Dcl (eol_bin, temp) fixed bin, eol char (1), capa_ptr ptr; /* ************************************************************************* */ call prs_send_init; /* Extract the fields from the init packet. */ capa_ptr = addr (loc_capas1); /* Set parameters for file transfer. */ loc_file_attrib = capa_ptr -> capas.file_attributes; call set_params; /* Build our ACK packet, and set the printable bit. */ char2(1) = nul_7bit_asc; char2(2) = loc_eol; char2_ptr -> fb15_based = char2_ptr -> fb15_based + 32; eol = char2(2); eol_bin = loc_pkt_size + 32; temp = loc_timeout + 32; snd_msg = substr (addr (eol_bin) -> char2_based, 2, 1) || substr (addr (temp) -> char2_based, 2, 1); eol_bin = loc_npad + 32; temp = loc_capas1 + 32; snd_msg = snd_msg || substr (addr (eol_bin) -> char2_based, 2, 1) || ctl (loc_padchar) || eol || loc_quote_chr || quote8_char || loc_chk_type || loc_rep_chr || substr (addr (temp) -> char2_based, 2, 1); temp = loc_max_wsize + 32; snd_msg = snd_msg || substr (addr (temp) -> char2_based, 2, 1); call send_packet (msg_ack, length (snd_msg), rec_seq); /* Send the packet. */ return; end; /* Ack_send_init */ ------------------------------------------------------------------------------- /* ASSIGN -- Assign an asynchronous line according to various flag settings. */ Assign : proc (action, linex, code); Dcl (action, linex, code) fixed bin; $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp $Insert syscom>errd.ins.pl1 Dcl (line, list_len, errcount) fixed bin, line_data (2, 2) fixed bin, errors (2, 2) fixed bin, config bit (16) aligned, baud_change bit (3); %Replace k$plst by 1; /* ************************************************************************* */ code = 0; line = linex; /* At the moment AS$SET changes the line argument. */ config = default_config; if action ^= 0 then do; select (baud_rate); when (110) do; baud_change = enc110; substr (config, 12, 1) = '1'b; /* Set 2 stop bits as well. */ end; when (134) baud_change = enc134; when (300) baud_change = enc300; when (1200) baud_change = enc1200; when (0) baud_change = enc_clock; when (-1) baud_change = enc_j1; when (-2) baud_change = enc_j2; when (-3) baud_change = enc_j3; otherwise if ^old_primos_revision then baud_change = enc1200; /* We MUST set this. */ else do; code = e$inre; /* Invalid baud rate given. */ return; end; end; substr (config, 8, 3) = baud_change; end; call asnln$ (action, line, 'TRAN ', config, default_lword, code); if action = 0 then if code = e$nass then /* Not really an error. */ code = 0; else ; else if ^old_primos_revision & baud_rate > 0 & (baud_rate ^= 110 & baud_rate ^= 134 & baud_rate ^= 300 & baud_rate ^= 1200) then do; list_len = 2; line_data(1, 1) = 11; line_data(1, 2) = baud_rate_index; line_data(2, 1) = 51; if baud_rate <= 110 then /* Set the number of stop bits. */ line_data(2,2) = 2; else line_data(2,2) = 1; call as$set (line, k$plst, 1, addr (line_data), addr (errors), list_len, errcount, code); if code ^= 0 then do; baud_rate = 1200; baud_rate_index = 3; end; end; return; end; /* Assign */ ------------------------------------------------------------------------------- /* BK_HNDLR -- Break handler for Kermit. */ Bk_hndlr : proc (point); Dcl point ptr; $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp Dcl code fixed bin; /* ************************************************************************* */ call limit$ ('0702'b4, 0, 0, code); /* Turn off watchdog timer. */ call log_info (packet_log, '.BREAK. received!'); /* Log the break. */ call xfer_mode (0, code); /* Reset the user's environment. */ call ioa$('%/QUIT.%/Leaving Kermit...Returning to Primos.%.', 99); goto brk_lbl; end; /* Bk_hndlr */ ------------------------------------------------------------------------------- /* CHANGE_DIR -- Change current directory. */ Change_dir : proc (treename, code); Dcl treename char (128) var, code fixed bin; $Insert *>insert>common.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp $Insert syscom>keys.ins.pl1 Dcl pathlen fixed bin, new_dir char (128); /* ************************************************************************* */ code = 0; if length (treename) = 0 then /* Attach to origin if no treename given. */ do; call at$or (k$seth, code); if code = 0 then snd_msg = 'Now in your origin directory.'; end; else do; call at$ (k$seth, treename, code); /* Don't forget we may have had */ if code = 0 then /* passwords, so we can't use SET_PATH. */ do; if substr (treename, 1, 2) = '*>' then do; /* Find out where we are! */ call gpath$ (k$homa, 0, new_dir, 128, pathlen, code); if code = 0 then treename = substr (new_dir, 1, pathlen); else code = 0; /* We do this for later. */ end; snd_msg = 'Now in directory ' || before (treename, space_8bit_asc) || '.'; end; end; return; end; /* Change_dir */ ------------------------------------------------------------------------------- /* CHKS -- Subroutine to compute Kermit checksum. */ Chks : proc (key, str) returns (fixed bin); Dcl key fixed bin, str char (96) var; $Insert *>insert>constants.ins.plp Dcl topbyte bit (1) aligned, str_ptr ptr, (i, str_len, total, word_index) fixed bin; Dcl 1 non_trans_data (1) based, 2 a1skip bit (1), 2 a1 bit (7), 2 a2skip bit (1), 2 a2 bit (7); Dcl 1 trans_data (1) based, 2 a1 bit (8), 2 a2 bit (8); Dcl 1 checksum_format based, 2 s1 bit (8), 2 s2 bit (2), 2 s3 bit (6); /* ************************************************************************* */ topbyte = false; /* Skip first char (mark), take low order byte. */ word_index = 2; /* Word index into char var string (skip length). */ total = 0; str_len = length (str); str_ptr = addr (str); do i = 2 to str_len; if topbyte then do; word_index = word_index + 1; if key = 1 then /* Parity NONE, 8 bit data, transparent mode. */ total = total + str_ptr -> trans_data(word_index).a1; else /* 7 bit data, non-transparent mode. */ total = total + str_ptr -> non_trans_data(word_index).a1; end; else if key = 1 then total = total + str_ptr -> trans_data(word_index).a2; else total = total + str_ptr -> non_trans_data(word_index).a2; topbyte = ^topbyte; end; /* Compute checksum from total of character values, (Add bits 6 - 7 to bits 0 - 5 then return 6-bit value). */ total = total + addr (total) -> checksum_format.s2; total = addr (total) -> checksum_format.s3; return (total); end; /* Chks */ ------------------------------------------------------------------------------- /* CLOSE_INPUT -- Close an input file. */ Close_input : proc; $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp $Insert syscom>errd.ins.pl1 Dcl code fixed bin; /* ************************************************************************* */ if ^explicit_ft_set then file_type = automatic_ft; /* Now we have finished, reset this. */ if ^explicit_pound_set then /* This may have changed for BINARY files. */ pound_conversion = true; if file_opened then do; call clo$fu (file_unit, code); if code ^= 0 & code ^= e$unop then do; call get_error_msg (code); snd_msg = 'Unable to close the input file on remote system. ' || errmsg; call send_packet (msg_error, length (snd_msg), msg_number); end; file_opened = false; end; return; end; /* Close_input */ ------------------------------------------------------------------------------- /* CLOSE_OUTPUT -- Close an output file. */ Close_output : proc returns (fixed bin); $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp $Insert syscom>keys.ins.pl1 $Insert syscom>errd.ins.pl1 Dcl (code, code2) fixed bin; /* ************************************************************************* */ code = 0; if ^file_opened then do; rec_file_type = automatic_ft; if ^explicit_ft_set then file_type = automatic_ft; return (code); end; call write_ibuf (1, code); /* Write the buffer to the file first. */ rec_file_type = automatic_ft; /* We MUST do this before returning. */ if ^explicit_ft_set then file_type = automatic_ft; if code ^= 0 then return (code); call clo$fu (file_unit, code); if code = e$unop then code = 0; if use_attributes & (rec_file_dtc ^= 0 & rec_file_dtc ^= -1) & code = 0 then do; code2 = 0; if non_null_dir then call at$ (k$setc, dir_name, code2); /* We set the files' DTM as well as the DTC since this seems to be more meaningful to most users. */ if code2 = 0 then do; call satr$$ (k$dtc, (file_name), length (file_name), rec_file_dtc, code2); call satr$$ (k$dtim, (file_name), length (file_name), rec_file_dtc, code2); end; if non_null_dir then call at$hom (code2); end; file_opened = false; call set_path (''); return (code); end; /* Close_output */ ------------------------------------------------------------------------------- /* COMND -- Kermit command level processor. */ Comnd : proc; $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp $Insert syscom>keys.ins.pl1 $Insert syscom>errd.ins.pl1 %Replace num_tokens by 3; Dcl token (num_tokens) char (128) var, (num_tok, command, i, code, code2) fixed bin, statv (2) fixed bin, new_baud_rate fixed bin (31), (from_comi_hndlr, ok) bit (1) aligned, kermit_state_ptr ptr, (reenter, comi_eof) char (10) var, cmd_option char (128) var, (cmd_buf, cmd_data) char (160) var, tempstr char (256) var; Dcl 1 fs, 2 date_today fixed bin, 2 qsecs fixed bin; %Replace kermit_len by 24, ambiguous_cmd by -1; Dcl kermit_state (kermit_len) char (16) var static init ( 'EXIT', 'HELP', 'QUIT', 'RECEIVE', 'SET', 'SEND', 'SERVER', 'SHOW', 'TAKE', 'VERSION', 'CONVERT', 'LOG', 'CLOSE', 'PUSH', 'STOP', 'POP', 'CONNECT', 'FINISH', 'BYE', 'GET', 'INPUT', 'OUTPUT', 'PAUSE', 'CLEAR'); %Replace cmd_exit by 1, cmd_help by 2, cmd_quit by 3, cmd_receive by 4, cmd_set by 5, cmd_send by 6, cmd_server by 7, cmd_show by 8, cmd_take by 9, cmd_version by 10, cmd_convert by 11, cmd_log by 12, cmd_close by 13, cmd_push by 14, cmd_stop by 15, cmd_pop by 16, cmd_connect by 17, cmd_finish by 18, cmd_bye by 19, cmd_get by 20, cmd_input by 21, cmd_output by 22, cmd_pause by 23, cmd_clear by 24; %Replace show_len by 18; Dcl show_state (show_len) char (16) var static init ( 'ALL', 'DELAY', 'RETRIES', 'TIMEOUT', 'PARITY', 'QUOTE', '8QUOTE', 'REPEAT', 'WINDOW', 'FILE_TYPE', 'INCOMPLETE', 'POUND', 'ATTRIBUTES', 'WARNING', 'LOG', 'LINE', 'ESCAPE', 'BAUD'); %Replace show_all by 1, show_delay by 2, show_retries by 3, show_timeout by 4, show_parity by 5, show_quote by 6, show_8quote by 7, show_repeat by 8, show_wsize by 9, show_store by 10, show_incomplete by 11, show_pound by 12, show_attributes by 13, show_warning by 14, show_log by 15, show_amlc by 16, show_escape by 17, show_baud by 18; /* ************************************************************************* */ code = 0; from_comi_hndlr = false; kermit_state_ptr = addr (kermit_state); reenter = 'REENTER$'; ren_lbl = ren_point; call mkonu$ (reenter, ren_hndlr); comi_eof = 'COMI_EOF$'; call mkonu$ (comi_eof, comi_hndlr); if in_init_file then if length (kermit_init_file) = 0 then do; in_init_file = false; go to comi_restart; end; else do; num_tok = 2; command = cmd_take; cmd_option = kermit_init_file; go to next_command; end; Ren_point : do while (true); do until (((length (cmd_buf) > 0) & substr (cmd_buf, 1, 1) ^= ctrl_a_8bit_asc) | (code ^= 0)); call tnoua ((kprompt), kprompt_len); Comi_restart : call cl$get (cmd_buf, 160, code); end; if code ^= 0 then do; call get_error_msg (code); call ioa$ ('Error reading the command line. %v%.', 99, errmsg); return; end; call tokenize (cmd_buf); command = type (token(1), kermit_state_ptr, kermit_len); cmd_option = token(2); Next_command : select (command); /* Now process the command. */ when (cmd_take) /* TAKE input from a file. */ if num_tok < 2 then call tnou ('No pathname given for TAKE command.', 35); else if length (cmd_option) <= 8 & (cmd_option = 'TTY' | cmd_option = 'PAUSE' | cmd_option = substr ('CONTINUE', 1, length (cmd_option))) then do; if in_init_file & take_level = 0 then tempstr = 'INIT option'; else tempstr = 'TAKE command'; call ioa$ ( 'The filename "%v" is NOT allowed for the %v. %.', 99, cmd_option, tempstr); if in_init_file & take_level = 0 then do; in_init_file = false; return; end; end; else if take_level + 1 > max_take_level then call ioa$ ( 'You have reached the maximum number (%d) of nested TAKE files.%.', 99, max_take_level); else do; i = get_unit (code); if i > 0 then do; code = 0; call set_path (cmd_option); if non_null_dir then call at$ (k$setc, dir_name, code); if code = 0 then call comi$$ ((file_name), length (file_name), i, code); if non_null_dir then call at$hom (code2); end; if code = 0 then do; take_level = take_level + 1; take_unit(take_level) = i; end; else do; call get_error_msg (code); call ioa$ ('Error opening file %v. %v%.', 99, cmd_option, errmsg); if in_init_file & take_level = 0 then do; in_init_file = false; return; end; end; end; when (cmd_version) /* Display the current VERSION number. */ call tnou ((kversion), length (kversion)); when (cmd_help) /* Display HELP information. */ call comnd_help; when (cmd_set) /* SET option. */ if num_tok < 2 then call tnou ('No SET option specified.', 24); else call comnd_set; when (cmd_show) /* SHOW option. */ do; if num_tok < 2 then cmd_option = 'ALL'; if cmd_option = 'FT' then cmd_option = 'FILE_TYPE'; if cmd_option = 'RETRY' then cmd_option = 'RETRIES'; call tonl; call comnd_show (type (cmd_option, addr (show_state), show_len)); call tonl; end; when (cmd_server) /* SERVER. */ if take_level = 0 then do; call xfer_mode (1, code); call tnou ('Kermit server started.', 22); call server; call xfer_mode (0, code); return; end; else call tnou ('SERVER command not allowed.', 27); when (cmd_send) /* SEND. */ if take_level = 0 then if num_tok < 2 then call tnou ('No pathname(s) given for SEND command.', 38); else if tnchk$ (k$uprc + k$wldc, cmd_option) then do; call set_path (cmd_option); state = state_s; call xfer_mode (1, code); call tnou ('Kermit send started.', 20); call send_switch; call xfer_mode (0, code); end; else call ioa$ ('Invalid SEND pathname(s) "%v".%.', 99, cmd_option); else call tnou ('SEND command not allowed.', 25); when (cmd_receive) /* RECEIVE. */ if take_level = 0 then do; state = state_r; call set_path (cmd_option); call xfer_mode (1, code); call tnou ('Kermit receive started.', 23); call rec_switch; call xfer_mode (0, code); end; else call tnou ('RECEIVE command not allowed.', 28); when (cmd_convert) /* CONVERT a file. */ if num_tok < 2 then call tnou ('No pathname given for CONVERT command.', 38); else do; call set_path (cmd_option); code = convert_file (); if code ^= 0 then do; call get_error_msg (code); call ioa$ ('%v%v%.', 99, snd_msg, errmsg); end; else call ioa$ ('Conversion of file %v successful.%.', 99, cmd_option); end; when (cmd_log) /* LOG command. */ do; i = 0; if index ('SESSION', cmd_option) = 1 then if session_log_opened then call tnou ('Session log file already open.', 30); else i = session_log; else if index ('PACKETS', cmd_option) = 1 then if packet_log_opened then call tnou ('Packet log file already open.', 29); else i = packet_log; else if length (cmd_option) = 0 then call tnou ('No PACKET or SESSION log type specified.', 40); else call ioa$ ('Invalid log type specified. "%v"%.', 99, cmd_option); if i > 0 then do; code = open_log (i, token(3)); if code ^= 0 then do; call get_error_msg (code); call ioa$ ('Error opening log file. %v%.', 99, errmsg); end; else if i = session_log then call tnou ('Session log file opened.', 24); else call tnou ('Packet log file opened.', 23); end; end; when (cmd_close) /* CLOSE the log file. */ do; i = 0; if length (cmd_option) = 0 & ^(session_log_opened & packet_log_opened) then if packet_log_opened then cmd_option = 'P'; else if session_log_opened then cmd_option = 'S'; if index ('SESSION', cmd_option) = 1 then if session_log_opened then do; i = session_log; session_log_opened = false; call clo$fu (session_log_unit, code); end; else call tnou ('Session log file not open.', 26); else if index ('PACKETS', cmd_option) = 1 then if packet_log_opened then do; i = packet_log; packet_log_opened = false; call clo$fu (packet_log_unit, code); end; else call tnou ('Packet log file not open.', 25); else if length (cmd_option) = 0 then if ^(session_log_opened | packet_log_opened) then call tnou ('No log files currently open.', 28); else call tnou ( 'No PACKET or SESSION log type specified.', 40); else call ioa$ ('Invalid log type specified. "%v"%.', 99, cmd_option); if i > 0 then if code ^= 0 & code ^= e$unop then do; call get_error_msg (code); call ioa$ ('Error closing the log file. %v%.', 99, errmsg); end; else if i = session_log then call tnou ('Session log file closed.', 24); else call tnou ('Packet log file closed.', 23); end; when (cmd_push) /* PUSH to a new command level. */ call comlv$; when (cmd_pop) /* POP back a level. */ if take_level > 0 then do; Comi_point : call comi$$ ('TTY', 3, take_unit(take_level), code); take_unit(take_level) = 0; take_level = take_level - 1; if code = 0 then if take_level > 0 then do; call comi$$ ('CONTINUE', 8, take_unit(take_level), code); if code ^= 0 then do; call get_error_msg (code); call ioa$ ( 'Unable to continue the previous TAKE file. %v%.', 99, errmsg); go to comi_point; end; end; else ; else do; call get_error_msg (code); call ioa$ ('Error closing the current TAKE file. %v%.', errmsg); end; if from_comi_hndlr then do; from_comi_hndlr = false; if in_init_file & take_level = 0 then return; else go to comi_restart; end; else if in_init_file & take_level = 0 then do; in_init_file = false; return; end; end; when (cmd_stop) /* STOP (suddenly) all TAKE files. */ if take_level > 0 then do; /* If this call fails then the on-unit should catch EOF. */ call comi$$ ('TTY', 3, take_unit(take_level), code); take_unit(take_level) = 0; take_level = take_level - 1; do i = 1 to take_level; call clo$fu (take_unit(i), code); take_unit(i) = 0; end; take_level = 0; if in_init_file then do; in_init_file = false; return; end; end; when (cmd_connect) /* CONNECT using an async line. */ if use_amlc_line then call connect (amlc_line); else call tnou ('No asynchronous line has been SET for use.', 42); when (cmd_finish) /* FINISH (end) the connection. */ if ^use_amlc_line then call tnou ('Remote server not started.', 26); else do; call xfer_mode (1, code); msg_number = 0; snd_msg = msg_gen_finish; call send_packet (msg_kermit_generic, 1, 0); if ^get_response () then call tnou ('No remote response received to FINISH command.', 46); call xfer_mode (0, code); end; when (cmd_bye) /* Logout remote server. */ if ^use_amlc_line then call tnou ('Remote server not started.', 26); else do; call xfer_mode (1, code); msg_number = 0; snd_msg = msg_gen_logout; call send_packet (msg_kermit_generic, 1, 0); if ^get_response () then call tnou ('No remote response received to BYE command.', 43); call xfer_mode (0, code); end; when (cmd_get) /* GET wildcarded file(s). */ if length (cmd_option) > 0 then do; call xfer_mode (1, code); msg_number = 0; snd_msg = cmd_option; call send_packet (msg_rcv_init, length (snd_msg), 0); cmd_option = ''; call set_path (cmd_option); state = state_r; call tnou ('In receive mode.', 16); call rec_switch; call xfer_mode (0, code); end; else call tnou ('No filename given for GET command.', 34); when (cmd_input) /* INPUT command. */ do; ok = false; if ^use_amlc_line then call tnou ('No CONNECTion currently started.', 32); else if length (cmd_option) = 0 then call tnou ('No INPUT string specified.', 26); else if length (token(3)) ^= 0 then if verify (cmd_option, '0123456789') ^= 0 then call ioa$ ('Invalid INPUT wait time "%v".%.', 99, cmd_option); else ok = input (trim (after (cmd_data, space_8bit_asc), '11'b), bin (cmd_option, 15)); else ok = input (cmd_data, 0); if ^ok & take_level > 0 then do; /* Abort any current TAKE file on errors. */ cmd_option = ''; command = cmd_pop; goto next_command; end; end; when (cmd_output) /* OUTPUT command. */ if ^use_amlc_line then call tnou ('No CONNECTion currently started.', 32); else do; tempstr = ctl_trans (ok, cmd_data); if length (tempstr) > 0 then do; if do_transparent then tempstr = clr8str (tempstr); code = send_amlc (amlc_line, (tempstr), length (tempstr)); if code ^= 0 then call tnou ('Unable to send OUTPUT data.', 27); end; else if ok then call tnou ('No OUTPUT string specified.', 27); else call ioa$ ('Invalid OUTPUT string given. "%v"%.', 99, cmd_data); end; when (cmd_pause) /* PAUSE for a while. */ if length (cmd_option) > 0 then if verify (cmd_option, '0123456789') = 0 then call sleep$ (bin (cmd_option, 31) * 1000); else do; /* Check 24-hour clock time. */ addr (fs) -> fb31_based = date$ (); i = fs.qsecs; /* Number of quadseconds so far. */ call cv$dtb (cmd_option, addr (fs) -> fb31_based, code); if code ^= 0 then call ioa$ ('Invalid PAUSE time given. "%v"%.', 99, cmd_option); else if fs.qsecs <= i then call tnou ('Already past the specified PAUSE time.', 38); else call sleep$ ((fs.qsecs - i) * 4000); end; else call tnou ('No PAUSE time specified.', 24); when (cmd_clear) /* CLEAR the connection. */ if ^use_amlc_line then call tnou ('No CONNECTion currently started.', 32); else do; code = send_amlc (amlc_line, ctl ('Q'), 1); call t$amlc (amlc_line, addr (i), 0, 10, statv, 1, code); saved_amlc_chrs = ''; if code ^= 0 then call tnou ('Unable to CLEAR the I/O buffers.', 32); end; when (cmd_quit, cmd_exit) /* EXIT to PRIMOS. */ return; when (ambiguous_cmd) call ioa$ ( 'Ambiguous command "%v". Type HELP for a list of commands.%.', 99, token(1)); otherwise call ioa$ ( 'Unrecognized command "%v". Type HELP for a list of commands.%.', 99, token(1)); end; /* select */ end; /* do while */ return; /* ******************************* Comnd_help ****************************** */ Comnd_help : proc; /* ************************************************************************* */ call ioa$ ('%/Interactive mode commands : %/%.', 99); call ioa$ ('Commands may be abbreviated to those letters in uppercase.%/%.', 99); call ioa$ (' Receive [pathname]%17xUpload a file.%.', 99); call ioa$ (' SENd wildcard%22xDownload file(s) using wildcards.%.', 99); call ioa$ (' SERver%29xStart Kermit server.%/%.', 99); call ioa$ (' Bye%32xLogout the remote server.%.', 99); call ioa$ (' CLEar%30xFlush the asynchronous line I/O buffers.%.', 99); call ioa$ ( ' CLOse {PACKET | SESSION}%11xClose the specified type of log file.%.', 99); call ioa$ (' CONNect%28xConnect to the Prime with an assigned line.%.', 99); call ioa$ (' CONVert pathname%19xConverts a file to PRIME ASCII.%.', 99); call ioa$ (' Exit or Quit%23xLeave Kermit.%.', 99); call ioa$ (' Finish%29xShutdown the remote server.%.', 99); call ioa$ (' Get wildcard%23xGet file(s) using wildcards.%.', 99); call ioa$ (' Help%31xDisplay this message.%.', 99); call ioa$ (' Input [time] string%16xMonitor assigned line for a time.%.', 99); call ioa$ (' Log {PACKET | SESSION} [pathname] Start log file. %$', 99); call tnou ('Default is type dependant.', 26); call ioa$ (' Output string%22xSend string along an assigned line.%.', 99); call ioa$ ( ' PAuse {time | hh:mm:ss}%12xWait for a specified time (seconds).%.', 99); call ioa$ (' POp%32xClose the current TAKE file.%.', 99); if ^more () then return; call ioa$ (' PUsh%31xReturn to PRIMOS, and may re-enter Kermit.%.', 99); call ioa$ (' SHow [{option | ALL}]%14xDisplay the required option.%.', 99); call ioa$ (' STop%31xClose all TAKE files, and return to Kermit.%.', 99); call ioa$ (' Take pathname%22xExecute commands from a file.%.', 99); call ioa$ (' Version%28xDisplay the current version number.%/%.', 99); call ioa$ ('%/ SET option%25xSet one of the following options :%.', 99); call ioa$ ( '%6xAttributes {ON | OFF}%13xUse the received file attributes. DTC%.', 99); call ioa$ ('%40xand file type are used. Default is ON.%.', 99); call ioa$ ('%6xBaud n%28xBaud rate to use for the assigned line.%.', 99); call ioa$ ('%40xDefault is 1200.%.', 99); call ioa$ ('%6xDelay n%27xDelay time in seconds before sending a%.', 99); call ioa$ ('%40xfile. Default is %d seconds.%.', 99, default_delay); call ioa$ ('%6xEscape char%23xEscape character to use for Connect%.', 99); call ioa$ ('%40xexits and breaks. Default is ^]%.', 99); call ioa$ ( '%6xFile_Type {AUTO | TEXT | BINARY} Set the type of file(s) to be sent or%.', 99); call ioa$ ('%40xreceived. Default is AUTO.%.', 99); call ioa$ ( '%6xIncomplete {SAVE | DELETE}%8xKeep or delete incompletely received%.', 99); call ioa$ ('%40xfiles. Default is DELETE.%.', 99); call ioa$ ('%6xLine [n]%26xAsync line number (decimal) to use. No%.', 99); call ioa$ ('%40xline number unassigns the current line.%.', 99); if ^more () then return; call ioa$ ('%6xPArity {MARK | NONE}%14xSet the character parity type.%.', 99); call ioa$ ('%40xDefault parity is MARK.%.', 99); call ioa$ ('%6xPOUnd {ON | OFF}%18xSets the conversion of DOS pound%.', 99); call ioa$ ('%40xsigns. Default is ON.%.', 99); call ioa$ ('%6xQuote char%24xControl quoting character to use.%.', 99); call ioa$ ('%40x("char" = ASCII printable character).%.', 99); call ioa$ ('%6x8Quote char%23x8-bit quoting character to use.%.', 99); call ioa$ ('%40x("char" = ASCII grammatical character).%.', 99); call ioa$ ('%6xREPeat char%23xRepeat character prefix to use.%.', 99); call ioa$ ('%40x("char" = ASCII printable character).%.', 99); call ioa$ ('%6xRETries n%25xMaximum number of send and receive%.', 99); call ioa$ ('%40xpacket retries. Default is %d.%.', 99, default_max_retries); call ioa$ ('%6xTimeout n%25xSend packet timeout in seconds. Default%.', 99); call ioa$ ('%40xtimeout is %d seconds.%.', 99, my_timeout); call ioa$ ( '%6xWArning {ON | OFF}%16xFile name collision warning. Prevents%.' , 99); call ioa$ ('%40xoverwriting of files. Default is ON.%.', 99); call ioa$ ('%6xWIndow n%26xFile transfer window size.%.', 99); call ioa$ ('%40x(1 <= "n" <= 31).%.', 99); call tonl; return; end; /* Comnd_help */ /* ******************************* Comnd_show ****************************** */ Comnd_show : proc (option); Dcl option fixed bin; /* ************************************************************************* */ select (option); when (show_all) do i = 2 to show_len; call comnd_show (i); end; when (show_delay) call ioa$ ('Time delay before sending a file is %d seconds.%.', 99, delay); when (show_retries) call ioa$ ( 'Maximum number of packet retries is %d (Send and Receive).%.', 99, max_retries); when (show_timeout) call ioa$ ( 'Timeouts are %#(.%) Send = %d seconds, Receive = %d seconds.%.', 99, 24, loc_timeout, rem_timeout); when (show_parity) do; call tnoua ('Character parity I will use ......... ', 38); if do_transparent then call tnou ('NONE', 4); else call tnou ('MARK', 4); end; when (show_quote) call ioa$ ('Quoting character I will use ........ "%c"%.', 99, loc_quote_chr, 1); when (show_8quote) do; call ioa$ ('8-Bit quoting character I want to use "%c"%$', 99, loc_8quote_chr, 1); if loc_8quote_chr = 'N' then call tnou (' (No 8-bit quoting).', 22); else call tonl; end; when (show_repeat) do; call ioa$ ('Repeat character prefix I want to use "%c"%$', 99, loc_rep_chr, 1); if loc_rep_chr = space_8bit_asc then call tnou (' (No repeat character processing).', 36); else call tonl; end; when (show_wsize) call ioa$ ('Window size I want to use ........... %d%.', 99, loc_max_wsize); when (show_store) do; call tnoua ('File storage type is ................ ', 38); select (file_type); when (automatic_ft) call tnou ('AUTOMATIC', 9); when (ascii_ft) call tnou ('TEXT', 4); when (binary_ft) call tnou ('BINARY', 6); otherwise call tnou ('ILLEGAL', 7); end; end; when (show_incomplete) do; call tnoua ('Incomplete files are ................ ', 38); if del_incomplete then call tnou ('DELETED', 7); else call tnou ('SAVED', 5); end; when (show_pound) do; call tnoua ('DOS pound sign conversion is ........ ', 38); if pound_conversion then call tnou ('ON', 2); else call tnou ('OFF', 3); end; when (show_attributes) do; call tnoua ('Use of the file attributes is ....... ', 38); if use_attributes then call tnou ('ON', 2); else call tnou ('OFF', 3); end; when (show_warning) do; call tnoua ('File name collision warning is ...... ', 38); if filename_warning then call tnou ('ON', 2); else call tnou ('OFF', 3); end; when (show_log) do; call tnoua ('Packet logging is ................... ', 38); if packet_log_opened then do; call tnoua ('ON', 2); if length (packet_log_pathname) > 15 then call tonl; call ioa$ (' (Log pathname is "%v").%.', 99, packet_log_pathname); end; else call tnou ('OFF', 3); call tnoua ('Session logging is .................. ', 38); if session_log_opened then do; call tnoua ('ON', 2); if length (session_log_pathname) > 15 then call tonl; call ioa$ (' (Log pathname is "%v").%.', 99, session_log_pathname); end; else call tnou ('OFF', 3); end; when (show_amlc) do; call tnoua ('Asynchronous line to use ............ ', 38); if use_amlc_line then call ioa$ ('%d (decimal)%.', 99, amlc_line); else call tnou ('NONE', 4); end; when (show_escape) do; call tnoua ('Escape character is ................. "', 39); if clr8 (escape_char) < space_7bit_asc then call tnoua ('^' || ctl (escape_char), 2); else call tnoua (escape_char, 1); call tnou ('"', 1); end; when (show_baud) do; call tnoua ('Baud rate to use is ................. ', 38); select (baud_rate); when (0) call tnou ('CLOCK (Default = 9600).', 23); when (-1) call tnou ('JUMPER_1 (Default = 75).', 24); when (-2) call tnou ('JUMPER_2 (Default = 150).', 25); when (-3) call tnou ('JUMPER_3 (Default = 1800).', 26); otherwise call ioa$ ('%:2d%.', 99, baud_rate); end; end; when (ambiguous_cmd) call ioa$ ( 'Ambiguous SHOW option "%v". Type HELP for a list of options.%.', 99, cmd_option); otherwise call ioa$ ( 'Unrecognized SHOW option "%v". Type HELP for a list of options.%.', 99, cmd_option); end; /* select */ return; end; /* Comnd_show */ /* ******************************* Comnd_set ******************************* */ Comnd_set : proc; Dcl baud_table (0 : 31) fixed bin (31) static init (110, 134, 300, 1200, 600, 75, 150, 1800, 200, 100, 50, -1, 2400, 4800, 9600, 19200, 48000, 56000, 64000, -1 ,-1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 3600, 7200); %Replace set_len by 16; Dcl set_state (set_len) char (16) var static init ( 'DELAY', 'RETRIES', 'TIMEOUT', 'PARITY', 'QUOTE', '8QUOTE', 'WINDOW', 'FILE_TYPE', 'POUND', 'INCOMPLETE', 'ATTRIBUTES', 'REPEAT', 'WARNING', 'LINE', 'ESCAPE', 'BAUD'); %Replace set_delay by 1, set_retries by 2, set_timeout by 3, set_parity by 4, set_quote by 5, set_8quote by 6, set_wsize by 7, set_store by 8, set_pound by 9, set_incomplete by 10, set_attributes by 11, set_repeat by 12, set_warning by 13, set_amlc by 14, set_escape by 15, set_baud by 16; /* ************************************************************************* */ if cmd_option = 'FT' then cmd_option = 'FILE_TYPE'; if cmd_option = 'RETRY' then cmd_option = 'RETRIES'; command = type (cmd_option, addr (set_state), set_len); cmd_option = token(3); select (command); when (set_delay) if num_tok < 3 then call ioa$ ( 'No DELAY time given, the current value of %d seconds will be unchanged.%.', 99, delay); else if verify (cmd_option, '0123456789') ^= 0 then call ioa$ ('Invalid DELAY time given "%v".%.', 99, cmd_option); else /* Everything is okay at this point. */ do; delay = bin (cmd_option, 15); call comnd_show (show_delay); end; when (set_retries) if num_tok < 3 then do; call tnou ( 'No RETRIES count given, the current value will be unchanged.', 60); call comnd_show (show_retries); end; else if verify (cmd_option, '0123456789') ^= 0 then call ioa$ ('Invalid RETRIES count given "%v".%.', 99, cmd_option); else do; i = bin (cmd_option, 15); if i = 0 then call tnou ( 'Specified RETRIES value is out of range. It must be greater than 0.', 67); else do; max_retries = i; call comnd_show (show_retries); end; end; when (set_timeout) if num_tok < 3 then do; call tnou ( 'No TIMEOUT given, the current value will be unchanged.', 54); call comnd_show (show_timeout); end; else if verify (cmd_option, '0123456789') ^= 0 then call ioa$ ('Invalid TIMEOUT given "%v".%.', 99, cmd_option); else do; i = bin (cmd_option, 15); if i > 94 then call tnou ( 'Specified TIMEOUT is out of range. It must be between 0 and 94 seconds.', 71); else do; loc_timeout = i; call comnd_show (show_timeout); end; end; when (set_parity) do; ok = false; if cmd_option = 'M' | cmd_option = 'MARK' then do; ok = true; do_transparent = false; do_8bit_chks = false; if loc_8quote_chr = 'Y' | loc_8quote_chr = 'N' then do; call tnoua ('WARNING : 8-bit quoting MUST be used', 36); call tnoua (' with MARK parity for binary', 28); call tnou (' file transfers.', 16); call comnd_show (show_8quote); end; call comnd_show (show_parity); end; else if cmd_option = 'N' | cmd_option = 'NONE' then do; ok = true; do_transparent = true; do_8bit_chks = true; if loc_8quote_chr ^= 'Y' & loc_8quote_chr ^= 'N' then do; call tnoua ('NOTE : 8-bit quoting is not ', 28); call tnou ('necessary when no parity is in use.', 35); call comnd_show (show_8quote); end; call comnd_show (show_parity); end; else if length (cmd_option) = 0 then do; call tnou ( 'No PARITY option given. The current setting will be unchanged.', 62); call comnd_show (show_parity); end; else call ioa$ ('Invalid PARITY option given "%v".%.', 99, cmd_option); if ok & use_amlc_line then do; call assign (0, amlc_line, code); if code = 0 then call assign (1, amlc_line, code); if code > 0 then do; amlc_line = -1; use_amlc_line = false; call get_error_msg (code); call ioa$ ( 'Unable to change the parity on the line.%.', 99, errmsg); call tnou ('No asynchronous line currently set.', 35); end; end; end; when (set_quote) if length (cmd_option) > 1 then do; call ioa$ ('Invalid control quoting character given "%v".%.', 99, cmd_option); call tnou ('Only one character may be specified.', 36); end; else select (cmd_option); when ('') do; call tnou ( 'No control quoting character given. The current setting will be unchanged.', 74); call comnd_show (show_quote); end; when (loc_8quote_chr) do; call ioa$ ( 'Invalid control quoting character given "%v".%.', 99, cmd_option); call tnou ( 'It is the same as the 8-bit quoting character.%.', 46); end; when (loc_rep_chr) do; call ioa$ ( 'Invalid control quoting character given "%v".%.', 99, cmd_option); call tnou ( 'It is the same as the repeat character prefix.', 46); end; otherwise if cmd_option < space_8bit_asc | cmd_option > '~' then do; call tnoua ('Invalid control quoting character given.', 40); call tnou (' It must be a printable ASCII character.', 40); end; else do; loc_quote_chr = cmd_option; call comnd_show (show_quote); end; end; when (set_8quote) if length (cmd_option) > 1 then do; call ioa$ ('Invalid 8-bit quoting character given "%v".%.', 99, cmd_option); call tnou ('Only one character may be specified.', 36); end; else select (cmd_option); when ('') do; call tnou ( 'No 8-bit quoting character given. The current setting will be unchanged.', 72); call comnd_show (show_8quote); end; when (loc_quote_chr) do; call ioa$ ('Invalid 8-bit quoting character given "%v".%.' , 99, cmd_option); call tnou ( 'It is the same as the control quoting character.', 48); end; when (loc_rep_chr) do; call ioa$ ('Invalid 8-bit quoting character given "%v".%.' , 99, cmd_option); call tnou ( 'It is the same as the repeat character prefix.', 46); end; otherwise do; loc_8quote_chr = cmd_option; if ^do_transparent & (cmd_option <= space_8bit_asc | (cmd_option > '>' & cmd_option < grave_8bit_asc) | cmd_option > '~') then do; call tnoua ('WARNING : 8-bit quoting MUST be ', 32); call tnou ( 'used with MARK parity for binary file transfers.', 48); call comnd_show (show_parity); end; call comnd_show (show_8quote); end; end; when (set_repeat) if length (cmd_option) > 1 then do; call ioa$ ('Invalid repeat character prefix given "%v".%.', 99, cmd_option); call tnou ('Only one character may be specified.', 36); end; else select (cmd_option); when (loc_quote_chr) do; call ioa$ ('Invalid repeat character prefix given "%v".%.' , 99, cmd_option); call tnou ( 'It is the same as the control quoting character.', 48); end; when (loc_8quote_chr) do; call ioa$ ('Invalid repeat character prefix given "%v".%.' , 99, cmd_option); call tnou ( 'It is the same as the 8-bit quoting character.', 46); end; otherwise if (cmd_option < space_8bit_asc | (cmd_option > '>' & cmd_option < grave_8bit_asc) | cmd_option > '~') & length (cmd_option) ^= 0 then do; call tnoua ('Invalid repeat character prefix given.', 38); call tnou (' It must be a printable ASCII character.', 40); end; else do; if length (cmd_option) = 0 then cmd_option = space_8bit_asc; loc_rep_chr = cmd_option; call comnd_show (show_repeat); end; end; when (set_wsize) if num_tok < 3 then do; call tnou ( 'No WINDOW size given, the current value will be unchanged.', 58); call comnd_show (show_wsize); end; else if verify (cmd_option, '0123456789') ^= 0 then call ioa$ ('Invalid WINDOW size given "%v".%.', 99, cmd_option); else do; i = bin (cmd_option, 15); if i = 0 | i > 31 then call tnou ( 'Specified WINDOW size out of range. It must be between 1 and 31 inclusive.', 74); else do; loc_max_wsize = i; call comnd_show (show_wsize); end; end; when (set_store) select (cmd_option); when ('AU', 'AUTO', 'AUTOMATIC') do; file_type = automatic_ft; explicit_ft_set = false; if ^explicit_pound_set then /* Reset this in case it got */ pound_conversion = true; /* set before. */ call comnd_show (show_store); end; when ('AS', 'ASC', 'ASCII', 'T', 'TEXT') do; file_type = ascii_ft; explicit_ft_set = true; if ^explicit_pound_set then pound_conversion = true; call comnd_show (show_store); end; when ('B', 'BIN', 'BINARY', 'I', 'IMAGE') do; file_type = binary_ft; explicit_ft_set = true; if ^explicit_pound_set then pound_conversion = false; call comnd_show (show_store); end; when ('') do; call tnou ( 'No file type given. The current setting will be unchanged.', 58); call comnd_show (show_store); end; otherwise call ioa$ ('Invalid file type "%v".%.', 99, cmd_option); end; when (set_pound) select (cmd_option); when ('ON', 'Y', 'YES') do; pound_conversion = true; explicit_pound_set = true; call comnd_show (show_pound); end; when ('OFF', 'N', 'NO') do; pound_conversion = false; explicit_pound_set = true; call comnd_show (show_pound); end; when ('') do; call tnou ( 'No POUND option given. The current setting will be unchanged.', 61); call comnd_show (show_pound); end; otherwise call ioa$ ('Invalid POUND option "%v".%.', 99, cmd_option); end; when (set_incomplete) select (cmd_option); when ('D', 'DEL', 'DELETE', 'DISCARD') do; del_incomplete = true; call comnd_show (show_incomplete); end; when ('S', 'SAVE', 'KEEP') do; del_incomplete = false; call comnd_show (show_incomplete); end; when ('') do; call tnou ( 'No INCOMPLETE option given, the current setting will be unchanged.', 66); call comnd_show (show_incomplete); end; otherwise call ioa$ ('Invalid INCOMPLETE option "%v".%.', 99, cmd_option); end; when (set_attributes) select (cmd_option); when ('ON', 'Y', 'YES') use_attributes = true; when ('OFF', 'N', 'NO') use_attributes = false; when ('') do; call tnou ( 'No ATTRIBUTES option given, the current setting will be unchanged.', 66); call comnd_show (show_attributes); end; otherwise call ioa$ ('Invalid ATTRIBUTES option "%v".%.', 99, cmd_option); end; when (set_warning) select (cmd_option); when ('ON', 'Y', 'YES') filename_warning = true; when ('OFF', 'N', 'NO') filename_warning = false; when ('') do; call tnou ( 'No file name WARNING option given, the current setting will be unchanged.', 73); call comnd_show (show_warning); end; otherwise call ioa$ ('Invalid file name WARNING option "%v".%.', 99, cmd_option); end; when (set_amlc) if verify (cmd_option, '0123456789') ^= 0 then call ioa$ ('Invalid line number specified "%v".%.', 99, cmd_option); else do; if use_amlc_line then /* Unassign any lines first. */ do; use_amlc_line = false; call assign (0, amlc_line, code); if code > 0 then do; call get_error_msg (code); call ioa$ ('Unable to unassign line %d. %v%.', 99, amlc_line, errmsg); end; amlc_line = -1; end; if length (cmd_option) > 0 then do; /* Now assign our new line. */ amlc_line = bin (cmd_option, 15); call assign (1, amlc_line, code); if code > 0 then do; call get_error_msg (code); call ioa$ ('Unable to assign line %d. %v%.', 99, amlc_line, errmsg); amlc_line = -1; end; use_amlc_line = (amlc_line >= 0); end; call comnd_show (show_amlc); end; when (set_escape) if length (cmd_option) = 0 then do; call tnou ( 'No ESCAPE character given. The current setting will be unchanged.', 65); call comnd_show (show_escape); end; else do; tempstr = ctl_trans (ok, cmd_option); if length (tempstr) ^= 1 then do; if ^ok then call ioa$ ('Invalid ESCAPE character(s) given "%v".%.', cmd_option); else call tnoua ('More than one ESCAPE character given. ', 38); call tnou ('The current setting will be unchanged.', 38); call comnd_show (show_escape); end; else do; escape_char = set8 (substr (tempstr, 1, 1)); call comnd_show (show_escape); end; end; when (set_baud) if length (cmd_option) = 0 then do; call tnou ( 'No BAUD rate given. The current value will be unchanged.', 56); call comnd_show (show_baud); end; else do; code = 0; select (cmd_option); when ('134', '134.5') do; baud_rate = 134; baud_rate_index = 1; end; when ('CLOCK') baud_rate = 0; when ('J1', 'JUMPER_1', 'JUMPER1') baud_rate = -1; when ('J2', 'JUMPER_2', 'JUMPER2') baud_rate = -2; when ('J3', 'JUMPER_3', 'JUMPER3') baud_rate = -3; otherwise if verify (cmd_option, '0123456789') ^= 0 then do; code = e$barg; call ioa$ ('Invalid BAUD rate given "%v".%.', 99, cmd_option); end; else do; new_baud_rate = bin (cmd_option, 31); ok = false; do baud_rate_index = 0 to 31 until (ok); ok = (baud_table(baud_rate_index) =new_baud_rate); end; if ok then baud_rate = new_baud_rate; else do; code = e$vnfc; call tnou ( 'Unsupported BAUD rate. The current setting will be unchanged.', 61); if old_primos_revision then do; call tnoua ( 'Supported values are 110, 134, 300, 1200, CLOCK (Default = ', 59); call ioa$ ( '9600), %/%21xJUMPER_1 (Default = 75), JUMPER_2 (Default = %$', 99); call ioa$ ( '150),%/%21xand JUMPER_3 (Default = 1800).%.', 99); end; call comnd_show (show_baud); end; end; end; if code = 0 then do; if use_amlc_line then do; call assign (0, amlc_line, code); if code = 0 then call assign (1, amlc_line, code); if code > 0 then do; amlc_line = -1; use_amlc_line = false; call get_error_msg (code); call ioa$ ( 'Unable to change the baud rate. %v%.', 99, errmsg); call tnou ( 'No asynchronous line currently set.', 35); end; end; if code = 0 then call comnd_show (show_baud); end; end; when (ambiguous_cmd) do; call ioa$ ('Ambiguous SET option "%v". %$', 99, token(2)); call tnou ('Type HELP for a list of options.', 32); end; otherwise do; call ioa$ ('Unrecognized SET option "%v". %$', 99, token(2)); call tnou ('Type HELP for a list of options.', 32); end; end; /* select */ return; end; /* Comnd_set */ /* ********************************* Type ********************************** */ /* TYPE -- determine command type from a list of possibilities. */ Type : proc (str, table_ptr, table_len) returns (fixed bin); Dcl str char (128) var, table_ptr ptr, table_len fixed bin; Dcl (str_len, entry_found, i) fixed bin, table_entry char (16) var, table (1) char (16) var based; /* ************************************************************************* */ entry_found = 0; str_len = length (str); do i = 1 to table_len; table_entry = table_ptr -> table(i); if length (table_entry) >= str_len then if substr (table_entry, 1, str_len) = str then if entry_found ^= 0 then return (ambiguous_cmd); /* More than one match found! */ else entry_found = i; end; return (entry_found); end; /* Type */ /* ******************************* Tokenize ******************************** */ Tokenize : proc (buff); Dcl buff char (160) var; /* ************************************************************************* */ /* A command line is passed back split up into tokens. The code only expects and handles 3 options, any others are ignored. The rest of the line after the command is also stored intact since it is used by some commands. */ do num_tok = 1 to num_tokens; token(num_tok) = ''; end; cmd_data = trim (after (buff, space_8bit_asc), '11'b); buff = translate (buff, uppercase || space_8bit_asc, lowercase || ','); buff = trim (buff, '11'b); do num_tok = 1 to num_tokens while (length (buff) ^= 0); token(num_tok) = before (buff, space_8bit_asc); buff = trim (after (buff, space_8bit_asc), '11'b); end; num_tok = num_tok - 1; return; end; /* Tokenize */ /* ****************************** Comi_hndlr ******************************* */ Comi_hndlr : proc (point); Dcl point ptr; /* ************************************************************************* */ /* This on-unit for the condition COMI_EOF$ makes life easier by treating the condition just as if the user had issued a POP command. We must remember that we were here though, so that the prompts come out okay. */ from_comi_hndlr = true; go to comi_point; end; /* Comi_hndlr */ /* ******************************* Get_unit ******************************** */ Get_unit : proc (code) returns (fixed bin); Dcl code fixed bin; Dcl (unit, rnw) fixed bin, pos fixed bin (31); /* ************************************************************************* */ code = 0; unit = 0; /* We start the file unit numbers at 7 to allow the lower ones to be used by other programs and, if the user PUSHes, commands like LISTING and BINARY (which use units 2 and 3) may also be used. The upper limit can, at the moment, only be guessed at. To allow a "decent" number of TAKE's to be nested we have used the figure of 127. This may need to be changed by other sites. */ do unit = 7 to 127 until (code = e$unop); call prwf$$ (k$rpos, unit, null (), 0, pos, rnw, code); end; if code = 0 | code = e$dire | code = e$bunt then code = e$fuiu; if code = e$unop then code = 0; else unit = 0; return (unit); end; /* Get_unit */ end; /* Comnd */ ------------------------------------------------------------------------------- /* CONNECT -- Connect to a remote system in transparent mode. */ Connect : proc (newline); Dcl newline fixed bin; $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp $Insert syscom>errd.ins.pl1 Dcl (tty, code, temp, i) fixed bin, statv (2) fixed bin, (exit, escape_seen) bit (1) aligned, (chr, tempchr, ctrl_p) char, tempbuffer char (256) var, bufferfrom char (256), bufferfrom_ptr ptr; %Replace sleep_interval by 100; /* ************************************************************************* */ exit = false; escape_seen = false; bufferfrom_ptr = addr (bufferfrom); ctrl_p = clr8 (ctl ('P')); tty = duplx$ (my_half_duplex); call ioa$ ('%/Starting connection to remote system...%/Press <%$', 99); if clr8 (escape_char) < space_7bit_asc then call tnoua ('^' || ctl (escape_char), 2); else call tnoua (escape_char, 1); if clr8 (abort_char) < space_7bit_asc then call tnoua ('^' || ctl (abort_char), 2); else call tnoua (abort_char, 1); call ioa$ ('> to return to command mode.%/%.', 99); if newline ^= amlc_line then /* See if we are using another line. */ do; call assign (1, newline, code); if code ^= 0 then do; tty = duplx$ (my_duplex); call get_error_msg (code); call ioa$ ('Unable to assign line %d. %v%.', 99, newline, errmsg); return; end; end; if length (saved_amlc_chrs) > 0 then do; call tnoua ((saved_amlc_chrs), length (saved_amlc_chrs)); saved_amlc_chrs = ''; end; do while (^exit); do while (tty$in ()); /* Handle terminal input. */ call c1in (char2); chr = char2(2); tempchr = translate (chr, uppercase, lowercase); if escape_seen then /* Handle escape sequences. */ select (tempchr); when (abort_char) /* Close the connection. */ exit = true; when (break_char) /* Send a break character. */ do; escape_seen = false; code = send_amlc (newline, ctrl_p, 1); if code ^= 0 then do; exit = true; call tnou ('Unable to send break character.', 31); end; end; when (escape_char) /* Send the escape character itself. */ do; escape_seen = false; code = send_amlc (newline, escape_char, 1); if code ^= 0 then do; exit = true; call tnou ('Unable to send escape character.', 32); end; end; when ('0') /* Send a NUL character. */ do; escape_seen = false; code = send_amlc (newline, nul_7bit_asc, 1); if code ^= 0 then do; exit = true; call tnou ('Unable to send NUL character.', 29); end; end; otherwise escape_seen = false; end; /* Select */ else if tempchr = escape_char then escape_seen = true; else do; chr = clr8 (chr); if chr = lf_7bit_asc then chr = cr_7bit_asc; code = send_amlc (newline, chr, 1); if code ^= 0 then do; exit = true; call tnou ('Unable to send data.', 20); end; end; end; /* Do while */ /* Handle input coming up the line. */ call t$amlc (newline, bufferfrom_ptr, 256, 6, statv, 1, code); if code ^= 0 then do; exit = true; call tnou ('Unable to receive data on assigned line.', 40); end; do while (statv(1) > 0); call tnoua (bufferfrom, statv(1)); if session_log_opened then do; tempbuffer = ''; char2(1) = nul_7bit_asc; do i = 1 to statv(1); char2(2) = set8 (substr (bufferfrom, i, 1)); temp = char2_ptr -> fb15_based; if temp ^= 128 then if temp < 160 & temp ^= cr_8bit_dec & temp ^= lf_8bit_dec then tempbuffer = tempbuffer || '^' || ctl (char2(2)); else tempbuffer = tempbuffer || char2(2); end; call log_info (session_log, tempbuffer); end; call t$amlc (newline, bufferfrom_ptr, 256, 6, statv, 1, code); if code ^= 0 then do; exit = true; call tnou ('Unable to receive data on assigned line.', 40); end; end; /* Do while */ call sleep$ (sleep_interval); /* Wait awhile. */ end; /* Do while */ if newline ^= amlc_line then do; call assign (0, newline, code); if code ^= 0 then do; call get_error_msg (code); call ioa$ ('Unable to unassign line %d. %v%.', 99, newline, errmsg); end; end; tty = duplx$ (my_duplex); call ioa$ ('%/Returning to command mode...%/%.', 99); return; end; /* Connect */ ------------------------------------------------------------------------------- /* CONVERT_FILE -- Convert uploaded file to Primos text file. */ Convert_file : proc returns (fixed bin); $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp $Insert syscom>keys.ins.pl1 $Insert syscom>errd.ins.pl1 Dcl temp_pathname char (128) var, buffer char (1026) var, /* This MUST be at least IBUFFER_SIZE + 2. */ (temp_filename, basename) char (32) var, (code, type, nw, i, unit2, rnw, sufusd) fixed bin, fn char (13), unique_bits char (6) aligned, (char_ptr, buff_ptr) ptr, (character, last_char) char (1); Dcl 1 bit_char based, 2 high_bit bit (1), 2 next_bits bit (7); /* ************************************************************************* */ buffer = ''; snd_msg = ''; last_char = ''; char_ptr = addr (character); buff_ptr = addr (buffer); buff_ptr = addrel (buff_ptr, 1); call srsfx$ (k$read + k$getu, path_name, file_unit, type, 0, '', basename, sufusd, code); if type > 1 & type ^= 7 then do; call clo$fu (file_unit, rnw); if code = 0 then code = e$wft; end; file_opened = (code = 0); if code ^= 0 then do; snd_msg = 'Error opening file to convert. '; return (code); end; call uid$bt (unique_bits); call uid$ch (unique_bits, fn); temp_filename = fn || '.KERMIT.CONV'; if ^non_null_dir then temp_pathname = temp_filename; else temp_pathname = dir_name || '>' || temp_filename; i = k$writ + k$getu; if type = 1 then i = i + k$ndam; else if type = 7 then i = i + k$ncam; call srsfx$ (i, temp_pathname, unit2, type, 0, '', basename, sufusd, code); if code ^= 0 then do; file_opened = false; call clo$fu (file_unit, rnw); snd_msg = 'Error opening temporary output file. '; return (code); end; do until (code ^= 0); call prwf$$ (k$read, file_unit, ibuffer_ptr, ibuffer_size_wds, 0, rnw, code); if code = e$eof & rnw = 0 & last_char ^= '' then do; /* This takes care of any last odd character. */ rnw = 1; buffer = ''; if last_char = lf_8bit_asc then last_char = space_8bit_asc; substr (ibuffer, 1, 2) = last_char || lf_8bit_asc; end; if rnw > 0 then /* This assumes that rnw > 0 for code = 0 or e$eof. */ do; /* And rnw = 0 for any error. */ ibuflen = 2 * rnw; call convert_to_ascii; if code ^= 0 then snd_msg = 'Error converting the file. '; end; else snd_msg = 'Error reading from the file. '; end; file_opened = false; call clo$fu (file_unit, rnw); call clo$fu (unit2, rnw); if code = e$eof then do; code = 0; snd_msg = ''; end; if code ^= 0 then do; call fil$dl (temp_pathname, rnw); return (code); end; else do; code = rnw; if code ^= 0 then do; snd_msg = 'Unable to close the output file. '; return (code); end; end; if non_null_dir then do; call at$ (k$setc, dir_name, code); if code ^= 0 then do; call fil$dl (temp_pathname, rnw); snd_msg = 'Error attaching to upload directory. '; return (code); end; end; call fil$dl (file_name, code); if code ^= 0 then do; if non_null_dir then call at$hom (rnw); snd_msg = 'Unable to delete the original file. '; return (code); end; rnw = 0; if length (temp_filename) = length (file_name) then sufusd = 1; else sufusd = 0; call cnam$$ ((temp_filename), length (temp_filename), (file_name), length (file_name), code, sufusd); if code ^= 0 then snd_msg = 'Error trying to rename the temporary file. '; if non_null_dir then call at$hom (rnw); if code = 0 then code = rnw; return (code); /* **************************** Convert_to_ascii *************************** */ Convert_to_ascii : proc; /* ************************************************************************* */ do i = 1 to ibuflen; character = substr (ibuffer, i, 1); char_ptr -> bit_char.high_bit = '1'b; if character ^= cr_8bit_asc then buffer = buffer || character; if character = lf_8bit_asc then if mod (length (buffer), 2) ^= 0 then buffer = buffer || nul_7bit_asc; end; last_char = ''; sufusd = length (buffer); if mod (sufusd, 2) ^= 0 then if code = e$eof then do; sufusd = sufusd + 1; buffer = buffer || lf_8bit_asc; end; else last_char = substr (buffer, sufusd, 1); call prwf$$ (k$writ, unit2, buff_ptr, divide (sufusd, 2, 15), 0, rnw, code); buffer = last_char; return; end; /* Convert_to_ascii */ end; /* Convert_file */ ------------------------------------------------------------------------------- /* DISCARD_OUTPUT -- Discard an output file. */ Discard_output : proc (code); Dcl code fixed bin; $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp $Insert syscom>errd.ins.pl1 /* ************************************************************************* */ code = 0; rec_file_type = automatic_ft; if ^explicit_ft_set then file_type = automatic_ft; if file_opened then do; call clo$fu (file_unit, code); if code = e$unop then code = 0; if code = 0 & del_incomplete then call fil$dl (path_name, code); if code = e$fntf | code = e$ninf then code = 0; /* Possible if the unit wasn't open. */ file_opened = false; end; return; end; /* Discard_output */ ------------------------------------------------------------------------------- /* GENERIC_CMD -- Generic server command process. */ Generic_cmd : proc returns (fixed bin); $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp $Insert syscom>keys.ins.pl1 $Insert syscom>errd.ins.pl1 %Replace maxargs by 3, maxalen by 96; Dcl (args, nargs) char (maxalen) var, arg (maxargs) char (maxalen) var; Dcl (treename, line) char (128) var, basename char (32) var, fn char (13), unique_bits char (6) aligned, (print_header, continue) bit (1) aligned, (code, rnw, funit, type, dir_type, dir_unit, code2, sufusd, key) fixed bin, (to_user_num, to_name_len) fixed bin, errvec (4) fixed bin, to_name char (32); Dcl 1 disk_info, 2 version fixed bin, 2 disk_name char (32) var, 2 part_size fixed bin (31), 2 avail fixed bin (31), 2 dts fixed bin (31); Dcl 1 quota_info, 2 (record_size, dir_used, max_quota, quota_used) fixed bin (31), 2 (duff1, duff2, duff3, duff4) fixed bin (31), inf_array (8) fixed bin (31) based; /* ************************************************************************* */ call parse_cmd; /* Parse any arguments sent. */ select (set8 (substr (rec_msg, pkt_msg, 1))); /* Process the message type. */ when (msg_gen_cwd) /* CWD - Change Working Directory. */ do; treename = arg(1); if length (arg(2)) ^= 0 then /* Do we have a password ? */ treename = treename || space_8bit_asc || arg(2); call change_dir (treename, code); if code = 0 then call send_packet (msg_ack, length (snd_msg), rec_seq); else do; call get_error_msg (code); snd_msg = 'Error trying to change directory. ' || errmsg; call send_packet (msg_error, length (snd_msg), msg_number); end; end; when (msg_gen_finish) /* FINISH command. */ do; call send_packet (msg_ack, 0, rec_seq); return (ker_exit); end; when (msg_gen_logout) /* LOGOUT command. */ do; call send_packet (msg_ack, 0, rec_seq); call logo$$ (0, 0, '', 0, 0, code); end; when (msg_gen_delete) /* DELETE command. */ do; treename = arg(1); call fil$dl (treename, code); if code = 0 then do; snd_msg = 'File deleted.'; call send_packet (msg_ack, length (snd_msg), rec_seq); end; else do; call get_error_msg (code); snd_msg = 'Unable to delete the file. ' || errmsg; call send_packet (msg_error, length (snd_msg), msg_number); end; end; when (msg_gen_directory) /* DIRECTORY command. */ do; call uid$bt (unique_bits); call uid$ch (unique_bits, fn); treename = arg(1); if length (treename) = 0 then treename = fn || '.KERMIT.DIR'; else treename = treename || '>' || fn || '.KERMIT.DIR'; call set_path (treename); call srch$$ (k$rdwr + k$getu, (file_name), length (file_name), file_unit, type, code); if code ^= 0 then do; call get_error_msg (code); snd_msg = 'Error opening a temporary file. ' || errmsg; call send_packet (msg_error, length (snd_msg), msg_number); return (ker_normal); end; file_opened = true; call srsfx$ (k$read + k$getu, dir_name, dir_unit, dir_type, 0, '', basename, sufusd, code); if code ^= 0 then do; call get_error_msg (code); snd_msg = 'Error opening the directory. ' || errmsg; call send_packet (msg_error, length (snd_msg), msg_number); file_opened = false; call clo$fu (file_unit, code); call fil$dl (file_name, code); return (ker_normal); end; continue = false; print_header = true; call dir$rd (k$init, dir_unit, dir_entry_ptr, dir_entry_size, code); do until (code ^= 0); call dir$rd (k$read, dir_unit, dir_entry_ptr, dir_entry_size, code); if code = 0 then if trim (dir_entry.entryname, '01'b) ^= file_name then do; if print_header then do; print_header = false; call wtlin$ (file_unit, '*** Start of Directory Listing. *** ', 18, code); end; if ^continue then line = dir_entry.entryname; else do; line = line || ' ' || dir_entry.entryname || ' '; call wtlin$ (file_unit, (line), divide (length (line), 2, 15), code); end; if code = 0 then continue = ^continue; end; end; call clo$fu (dir_unit, code2); if code = e$eof then do; code = 0; if continue then do; line = line || ' '; call wtlin$ (file_unit, (line), divide (length (line), 2, 15), code); end; else /* We will be here if we had an empty directory. */ if print_header then call wtlin$ (file_unit, '*** There are NO file system objects in this directory. *** ', 30, code); end; if code ^= 0 then do; call get_error_msg (code); snd_msg = 'Error listing the directory. ' || errmsg; call send_packet (msg_error, length (snd_msg), msg_number); file_opened = false; call clo$fu (file_unit, code); call fil$dl (file_name, code); return (ker_normal); end; if ^print_header then call wtlin$ (file_unit, '*** End of Directory Listing. *** ', 17, code); call xsend_file; file_opened = false; call clo$fu (file_unit, code); call fil$dl (file_name, code); end; when (msg_gen_type) /* TYPE command. */ do; treename = arg(1); call set_path (treename); code = open_input (); if code = 0 then do; state = state_x; call send_switch; end; else do; call get_error_msg (code); snd_msg = 'Error accessing the file. ' || errmsg; call send_packet (msg_error, length (snd_msg), msg_number); end; end; when (msg_gen_disk_usage) /* Disk Usage. */ do; treename = arg(1); /* Anything sent will actually be a directory. */ if length (treename) ^= 0 then treename = treename || '>DUMMY_FILE_NAME'; call set_path (treename); call q$read (dir_name, addr (quota_info) -> inf_array, 4, type, code); if code ^= 0 then do; call get_error_msg (code); snd_msg = 'Error reading the disk quota. ' || errmsg; call send_packet (msg_error, length (snd_msg), msg_number); end; else do; basename = trim (char (quota_info.quota_used), '10'b); snd_msg = 'Records = ' || basename || ', '; if type = 1 then snd_msg = snd_msg || 'No Quota.'; else snd_msg = snd_msg || 'Quota = ' || trim (char (quota_info.max_quota),'10'b) || '.'; if file_info.ldevno = -1 then call finfo$ (current_attach_point, file_info_ptr, code); if code = 0 then do; disk_info.version = 1; call ds$avl (addr (disk_info), file_info.ldevno, code); if code = 0 then do; basename = trim (char (disk_info.avail), '10'b); snd_msg = snd_msg || ' (' || basename || ' records available on disk).'; end; end; if code ^= 0 then snd_msg = snd_msg || ' (Disk space information not available).'; call send_packet (msg_ack, length (snd_msg), rec_seq); end; file_info.ldevno = -1; /* Reset this for next time. */ end; when (msg_gen_rename) /* RENAME command. */ do; code = 0; treename = arg(1); call set_path (treename); if non_null_dir then call at$ (k$setc, dir_name, code); if code = 0 then do; rnw = length (file_name); type = length (arg(2)); if rnw = type then sufusd = 1; else sufusd = 0; call cnam$$ ((file_name), rnw, (arg(2)), type, code, sufusd); if non_null_dir then call at$hom (code2); end; if code ^= 0 then do; call get_error_msg (code); snd_msg = 'Error trying to change the file name. ' || errmsg; call send_packet (msg_error, length (snd_msg), msg_number); end; else do; snd_msg = 'File renamed.'; call send_packet (msg_ack, length (snd_msg), rec_seq); end; end; when (msg_gen_copy) /* COPY command. */ do; treename = arg(1); line = arg(2); call srsfx$ (k$read + k$getu, treename, file_unit, type, 0, '', basename, sufusd, code); if type > 1 & type ^= 7 then do; call clo$fu (file_unit, rnw); if code = 0 then code = e$wft; end; if code ^= 0 then do; call get_error_msg (code); snd_msg = 'Unable to open the file to copy from. ' || errmsg; call send_packet (msg_error, length (snd_msg), msg_number); return (ker_normal); end; key = k$writ + k$getu; if type = 1 then key = key + k$ndam; else if type = 7 then key = key + k$ncam; call srsfx$ (key, line, funit, type, 0, '', basename, sufusd, code); if code ^= 0 then do; call get_error_msg (code); snd_msg = 'Unable to open the file to copy to. ' || errmsg; call send_packet (msg_error, length (snd_msg), msg_number); return (ker_normal); end; do until (code ^= 0); call prwf$$ (k$read, file_unit, ibuffer_ptr, ibuffer_size_wds, 0, rnw, code); if code = 0 | (code = e$eof & rnw ^= 0) then call prwf$$ (k$writ, funit, ibuffer_ptr, rnw, 0, sufusd, code); end; call clo$fu (file_unit, code2); call clo$fu (funit, code2); if code = e$eof then code = 0; if code ^= 0 then do; call fil$dl (line, code2); call get_error_msg (code); snd_msg = 'Error copying the file. ' || errmsg; call send_packet (msg_error, length (snd_msg), msg_number); end; else do; snd_msg = 'File copied.'; call send_packet (msg_ack, length (snd_msg), rec_seq); end; end; when (msg_gen_send) /* SEND command. */ do; line = after (arg(1), space_8bit_asc); arg(1) = translate (trim (before (arg(1), space_8bit_asc), '11'b), uppercase, lowercase); if substr (arg(1), 1, 1) = '-' then arg(1) = substr (arg(1), 2); if verify (arg(1), '+-0123456789') = 0 then /* User number given. */ do; to_name = ''; to_name_len = 0; to_user_num = bin (arg(1), 15); if to_user_num <= 0 then do; snd_msg = 'Invalid user-number given.'; call send_packet (msg_error, length (snd_msg), msg_number); return (ker_normal); end; end; else do; to_name = arg(1); to_name_len = length (to_name); to_user_num = 0; end; if length (line) > 80 then line = substr (line, 1, 80); rnw = length (line); errvec(2) = 1; call mgset$ (k$acpt, code); call smsg$ (1, to_name, to_name_len, to_user_num, '', 0, (line), rnw, errvec); call mgset$ (my_msg_state, code); if errvec(1) = 0 then do; snd_msg = 'Message sent.'; call send_packet (msg_ack, length (snd_msg), rec_seq); end; else do; call get_error_msg (errvec(1)); snd_msg = 'Unable to send the message. ' || errmsg; call send_packet (msg_error, length (snd_msg), msg_number); end; end; when (msg_gen_who) /* WHO command. */ do; if substr (arg(1), 1, 1) = '-' then arg(1) = substr (arg(1), 2); if length (arg(1)) = 0 then do; snd_msg = 'No user-id given.'; call send_packet (msg_error, length (snd_msg), msg_number); return (ker_normal); end; if verify (arg(1), '+-0123456789') = 0 then do; /* User number given. */ key = k$read; to_name = ''; to_name_len = 32; to_user_num = bin (arg(1), 15); if to_user_num <= 0 then do; snd_msg = 'Invalid user-number given.'; call send_packet (msg_error, length (snd_msg), msg_number); return (ker_normal); end; end; else do; key = 2; to_name = arg(1); to_name_len = length (to_name); to_user_num = 0; end; call msg$st (key, to_user_num, '', 0, to_name, to_name_len, code); if code = k$none then do; snd_msg = 'User ' || arg(1) || ' is not logged in.'; call send_packet (msg_error, length (snd_msg), msg_number); end; else do; snd_msg = 'User ' || trim (to_name, '11'b) || ' is currently logged in as process number ' || trim (char (to_user_num), '11'b) || '.'; call send_packet (msg_ack, length (snd_msg), rec_seq); end; end; otherwise /* Unknown command. */ do; snd_msg = 'Unimplemented generic command.'; call send_packet (msg_error, length (snd_msg), msg_number); return (ker_unimplgen); end; end; /* select */ return (ker_normal); /* ******************************* Parse_cmd ******************************* */ Parse_cmd : proc; Dcl (arg_num, arg_len, i, temp, rep_count) fixed bin, do_trans bit (1) aligned, (chr, rem_quo) char (1); /* ************************************************************************* */ do_repeats = (loc_rep_chr = set8 (rem_rep_chr)) & (loc_rep_chr ^= space_8bit_asc); do i = 1 to maxargs; arg(i) = ''; end; if length (rec_msg) <= pkt_tot_ovr_head then return; args = set8str (substr (rec_msg, pkt_tot_ovr_head, length (rec_msg) - pkt_tot_ovr_head)); nargs = ''; rem_quo = set8 (rem_quote_chr); /* For local processing only. */ i = 0; /* Convert any quoted and repeated characters. */ do while (i < length (args)); i = i + 1; chr = substr (args, i, 1); rep_count = 1; if do_repeats then if chr = loc_rep_chr then do; i = i + 1; rep_count = knum (substr (args, i, 1)); i = i + 1; chr = substr (args, i, 1); end; if chr = rem_quo then do; i = i + 1; chr = substr (args, i, 1); if chr >= query_8bit_asc & chr < grave_8bit_asc then chr = ctl (chr); end; do temp = 1 to rep_count; nargs = nargs || chr; end; end; i = 0; arg_num = 0; do_trans = (set8 (substr (rec_msg, pkt_msg, 1)) ^= msg_gen_send); do while (i < length (nargs)); /* Now fill in the argument list. */ i = i + 1; arg_len = knum (substr (nargs, i, 1)); arg_num = arg_num + 1; arg(arg_num) = substr (nargs, i + 1, arg_len); if do_trans then /* Don't do this for the SEND command. */ arg(arg_num) = translate (trim (arg(arg_num), '11'b), uppercase, lowercase); i = i + arg_len; end; return; end; /* Parse_cmd */ /* ******************************* Xsend_file ****************************** */ Xsend_file : proc; /* ************************************************************************* */ /* First we rewind the file to the beginning. */ call prwf$$ (k$posn + k$prea, file_unit, null (), 0, 0, rnw, code); if code ^= 0 then do; call get_error_msg (code); snd_msg = 'Unable to position to the beginning of the file. ' || errmsg; call send_packet (msg_error, length (snd_msg), msg_number); end; else do; file_pos = 0; ibuflen = 0; ibuf_ptr = 1; key = file_type; /* Keep this for later. */ file_type = ascii_ft; if ^explicit_pound_set then pound_conversion = true; ibuffer = ''; state = state_x; /* Send the file as text to be typed to the user. */ call send_switch; file_type = key; /* Reset the file type. */ end; return; end; /* Xsend_file */ end; /* Generic_cmd */ ------------------------------------------------------------------------------- /* GET_ATTR -- Get file attributes and put them in SND_MSG. */ Get_attr : proc; $Insert *>insert>kermit.ins.plp $Insert *>insert>common.ins.plp $Insert *>insert>constants.ins.plp %Replace primos by 'G'; Dcl 1 a_sub_pkt, 2 type char (1), 2 pkt_len char (1), 2 data char (32) var; Dcl sub_pkt_ptr ptr; /* ************************************************************************* */ sub_pkt_ptr = addr (a_sub_pkt); a_sub_pkt.type = '.'; /* Set up machine/OS sub-packet. */ char2_ptr -> fb15_based = 33; /* i.e. 1 + 32 */ a_sub_pkt.pkt_len = char2(2); a_sub_pkt.data = primos; snd_msg = sub_pkt_ptr -> char2_based || a_sub_pkt.data; a_sub_pkt.type = '!'; /* Set up kbyte length sub-packet. */ a_sub_pkt.data = trim (char (divide (file_len + 1023, 1024, 31)), '11'b); char2_ptr -> fb15_based = length (a_sub_pkt.data) + 32; a_sub_pkt.pkt_len = char2(2); snd_msg = snd_msg || sub_pkt_ptr -> char2_based || a_sub_pkt.data; a_sub_pkt.data = get_dtc (); /* Set up DTC sub-packet. */ if length (a_sub_pkt.data) ^= 0 then do; a_sub_pkt.type = '#'; char2_ptr -> fb15_based = length (a_sub_pkt.data) + 32; a_sub_pkt.pkt_len = char2(2); snd_msg = snd_msg || sub_pkt_ptr -> char2_based || a_sub_pkt.data; end; a_sub_pkt.type = '1'; /* Set up the byte file length sub-packet. */ a_sub_pkt.data = trim (char (file_len), '11'b); char2_ptr -> fb15_based = length (a_sub_pkt.data) + 32; a_sub_pkt.pkt_len = char2(2); snd_msg = snd_msg || sub_pkt_ptr -> char2_based || a_sub_pkt.data; if file_type = ascii_ft | file_type = binary_ft then do; a_sub_pkt.type = '"'; if file_type = ascii_ft then a_sub_pkt.data = 'A'; else a_sub_pkt.data = 'B'; char2_ptr -> fb15_based = 33; a_sub_pkt.pkt_len = char2(2); snd_msg = snd_msg || sub_pkt_ptr -> char2_based || a_sub_pkt.data; end; return; end; /* Get_attr */ ------------------------------------------------------------------------------- /* GET_DTC -- Get the DTC of the file given by "path_name". */ Get_dtc : proc returns (char (32) var); $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp $Insert syscom>keys.ins.pl1 Dcl (type, code, dow, funit, sufusd) fixed bin, formatted_date char (21), (buffer, basename) char (32) var; /* ************************************************************************* */ buffer = ''; call srsfx$ (k$read + k$getu, dir_name, funit, type, 0, '', basename, sufusd, code); if code ^= 0 then do; call get_error_msg (code); call ioa$ ('Unable to open the directory %v. %v%.', 99, dir_name, errmsg); return (buffer); end; call ent$rd (funit, file_name, dir_entry_ptr, dir_entry_size, code); call clo$fu (funit, sufusd); /* We don't need this anymore. */ if code ^= 0 then do; call get_error_msg (code); call ioa$ ('Unable to read the directory entry for file %v. %v%.', 99, file_name, errmsg); return (buffer); end; /* We now use the files' Date/Time last modified attribute than its Date/Time of creation since this is of more use to most users. */ call cv$fda (dir_entry.dtm, dow, formatted_date); if dow >= 0 then buffer = '19' || substr (formatted_date, 1, 2) || substr (formatted_date, 4, 2) || substr (formatted_date, 7, 2) || space_8bit_asc || substr (formatted_date, 10, 8); return (buffer); end; /* Get_dtc */ ------------------------------------------------------------------------------- /* GET_ERROR_MSG -- Get the PRIMOS error message from the given code. */ Get_error_msg : proc (code); Dcl code fixed bin; $Insert *>insert>common.ins.plp $Insert *>insert>primos.ins.plp /* ************************************************************************* */ call ertxt$ (code, errmsg); if length (errmsg) = 0 then errmsg = '(Code = ' || trim (char (code), '11'b) || ')'; return; end; /* Get_error_msg */ ------------------------------------------------------------------------------- /* GET_LEN -- Determine logical and physical length of file in bytes. */ Get_len : proc (exact) returns (fixed bin); Dcl exact bit (1) aligned; $Insert *>insert>common.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp $Insert syscom>keys.ins.pl1 $Insert syscom>errd.ins.pl1 Dcl (unit2, sufusd, type ,code, rnw) fixed bin, long_temp fixed bin (31), basename char (32) var; /* ************************************************************************* */ file_len = 0; file_pos = 0; /* The following call will work, but for large SAM files it may hold the file system lock for a time. */ call prwf$$ (k$posn + k$prea, file_unit, null (), 0, bignum, rnw, code); if code = 0 then code = e$fitb; /* The file is too big! */ if code = e$eof then /* Determine the EOF position. */ call prwf$$ (k$rpos, file_unit, null (), 0, file_len, rnw, code); if code = e$eof then do; code = 0; /* This will allow for empty files. */ file_len = 0; return (code); end; if code ^= 0 then return (code); file_len = 2 * file_len; if exact then do; long_temp = exact_len (); if long_temp > 0 then file_len = long_temp; end; file_pos = file_len; /* PRIMOS keeps the file length in 2 byte words. The Kermit upload process will change the files read/write lock if the last byte is not significant. So we must now check the files read/write lock. */ call srsfx$ (k$read + k$getu, dir_name, unit2, type, 0, '', basename, sufusd, code); if code ^= 0 then return (code); call ent$rd (unit2, file_name, dir_entry_ptr, dir_entry_size, code); call clo$fu (unit2, sufusd); /* We don't need this anymore. */ if code ^= 0 then return (code); if dir_entry.file_inf.rwlock = k$none then file_len = file_len - 1; /* Now we can rewind the file to the beginning. */ call prwf$$ (k$posn + k$prea, file_unit, null (), 0, 0, rnw, code); if code = 0 then file_pos = 0; return (code); /* ******************************** Exact_len ****************************** */ Exact_len : proc returns (fixed bin (31)); Dcl (chr, ctrl_q, last_right) fixed bin, size fixed bin (31), left bit (1) aligned; Dcl 1 buff (ibuffer_size_wds) based, 2 left bit (8) unal, 2 right bit (8) unal; /* ************************************************************************* */ chr = 0; code = 0; size = 0; last_right = 0; left = true; ctrl_q = 145; call prwf$$ (k$posn + k$prea, file_unit, null (), 0, 0, rnw, code); do until (rnw = 0); call prwf$$ (k$read, file_unit, ibuffer_ptr, ibuffer_size_wds, 0, rnw, code); if rnw > 0 then do sufusd = 1 to rnw; if left then do; chr = ibuffer_ptr -> buff(sufusd).left; last_right = ibuffer_ptr -> buff(sufusd).right; end; else do; sufusd = sufusd - 1; chr = ibuffer_ptr -> buff(sufusd).right; end; if chr = ctrl_q then do; if left then chr = last_right; else do; sufusd = sufusd + 1; chr = ibuffer_ptr -> buff(sufusd).left; end; left = ^left; size = size + chr; end; else size = size + 1; left = ^left; end; end; if code ^= e$eof then size = 0; else if last_right ^= 0 then size = size + 1; return (size); end; /* Exact_len */ end; /* Get_len */ ------------------------------------------------------------------------------- /* GET_RESPONSE -- Try to get an ACK packet from the remote system. */ Get_response : proc returns (bit (1) aligned); $Include *>insert>constants.ins.plp $Include *>insert>kermit.ins.plp $Include *>insert>common.ins.plp Dcl fail bit (1) aligned; /* ************************************************************************* */ fail = false; call rec_packet; /* Get a packet from the remote side. */ select (rec_pkt_type); /* Check the packet type. */ when (msg_timeout, msg_check_err) /* Timeout. */ fail = true; when (msg_ack) /* ACK type. */ if rec_seq ^= msg_number then fail = true; when (msg_nak) /* NAK type. */ /* Treat an ACK to packet n+1 as an ACK of packet n. This covers the case when the ACK to packet n is lost, and the remote later sends a NAK. Any other NAKs cause a retransmit. */ if rec_seq ^= mod (msg_number + 1, 64) then fail = true; when (msg_error) /* Error type. */ do; state = state_a; return (false); end; otherwise do; snd_msg = 'Unexpected packet type "' || rec_pkt_type || '" received on remote system.'; call send_packet (msg_error, length (snd_msg), msg_number); state = state_a; return (false); end; end; /* Select */ if ^fail then /* A good response. */ do; num_retries = 0; msg_number = mod (msg_number + 1, 64); return (true); end; if num_retries > max_retries then /* No response ? */ do; num_retries = 0; snd_msg = 'Retry limit exceeded on remote system.'; call send_packet (msg_error, length (snd_msg), msg_number); state = state_a; end; else num_retries = num_retries + 1; return (false); end; /* Get_response */ ------------------------------------------------------------------------------- /* GET_USER_INFO -- Get the users PRIMOS environment variables. */ Get_user_info : proc; Dcl code fixed bin, u_name char (32); $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp $Insert syscom>keys.ins.pl1 /* ************************************************************************* */ call erkl$$ (k$read, my_erase, my_kill, code); /* Keep these for our user. */ if code ^= 0 then do; my_erase = nul_7bit_asc || nul_7bit_asc; my_kill = my_erase; /* Set these so that no "funnies" occur later. */ call get_error_msg (code); call ioa$ ('Error getting erase and kill characters. %v%.', 99, errmsg); end; my_duplex = duplx$ ('FFFF'b4); my_half_duplex = my_duplex | 'C000'b4; call msg$st (k$read, my_user_number, '', 0, u_name, 32, my_msg_state); return; end; /* Get_user_info */ ------------------------------------------------------------------------------- /* INPUT -- Wait for a specified string for a specified time. */ Input : proc (string, wait_time) returns (bit (1) aligned); Dcl string char (128) var, wait_time fixed bin; $Insert *>insert>constants.ins.plp $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp Dcl (begin_min, begin_sec, idx, code, len) fixed bin, statv (2) fixed bin, esecs fixed bin (31), inbuffer_ptr ptr, (tempchr, ctrl_at) char, begin_day char (2), mainbuffer char (768) var, tempbuffer char (256) var, inbuffer char (256); Dcl 1 time, 2 (month, day, year) char (2), 2 (minmidnt, seconds, ticks, cpusec, cputick, iosec, iotick, ticks_pre_sec, usernum) fixed bin, 2 logname char (32); /* ************************************************************************* */ len = length (string) - 1; mainbuffer = saved_amlc_chrs; saved_amlc_chrs = ''; inbuffer_ptr = addr (inbuffer); ctrl_at = ctl ('@'); call timdat (time, 28); begin_day = time.day; begin_min = time.minmidnt; begin_sec = time.seconds; do while (true); idx = index (mainbuffer, string); /* Test the buffer initially. */ if idx > 0 then do; call tnou ((mainbuffer), idx + len); saved_amlc_chrs = after (mainbuffer, string); return (true); end; else do; /* Output all but the last LEN characters. */ idx = length (mainbuffer) - len; if idx > 0 then do; call tnoua ((mainbuffer), idx); if len > 0 then mainbuffer = substr (mainbuffer, idx + 1, len); else mainbuffer = ''; end; end; do until (statv(1) > 0); /* Read until we get some characters. */ if wait_time > 0 then /* Check if it's time to go. */ do; call timdat (time, 28); esecs = 0; if time.day ^= begin_day then esecs = 86400; /* Handle day boundaries. */ esecs = esecs + (time.minmidnt - begin_min) * 60 + (time.seconds - begin_sec); if esecs >= wait_time then /* Time to go. */ do; call tonl; return (false); end; end; call sleep$ (500); call t$amlc (amlc_line, inbuffer_ptr, 256, 6, statv, 1, code); if code ^= 0 then do; call tnou ('Unable to receive asynchronous data.', 36); return (false); end; end; /* Do until */ do idx = 1 to statv(1); tempchr = set8 (substr (inbuffer, idx, 1)); if tempchr ^= ctrl_at then if tempchr < space_8bit_asc & tempchr ^= cr_8bit_asc & tempchr ^= lf_8bit_asc then mainbuffer = mainbuffer || '^' || ctl (tempchr); else mainbuffer = mainbuffer || tempchr; end; if session_log_opened then do; do while (length (mainbuffer) > 256); tempbuffer = substr (mainbuffer, 1, 256); call log_info (session_log, tempbuffer); mainbuffer = substr (mainbuffer, 257, length (mainbuffer) - 256); end; tempbuffer = mainbuffer; call log_info (session_log, tempbuffer); end; end; /* Do while */ return (false); end; /* Input */ ------------------------------------------------------------------------------- /* KERMIT -- Main Kermit subroutine. */ Kermit : proc (cmd_line, code, com_name); Dcl cmd_line char (256) var, com_name char (32) var, code fixed bin; $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp $Insert syscom>keys.ins.pl1 $Insert syscom>errd.ins.pl1 %Replace cl_width by 64; Dcl cl_pic (12) char (cl_width) var static init ( '-r, -rec, -receive tree;', '-s, -send tree;', '-a, -as, -alt, -alternate entry;', '-l, -log tree;', '-ft, -file, -file_type, -st, -store, -storage_type char;', '-init tree;', '-p, -par, -parity char;', '-h, -help;', '-u, -usage;', '-ser, -server;', '-pou, -pound char;', 'end' ); Dcl 1 cl_struc external, 2 rec_flag bit (1) aligned, 2 rec_path char (128) var, 2 send_flag bit (1) aligned, 2 send_path char (128) var, 2 alt_flag bit (1) aligned, 2 alt_name char (32) var, 2 log_flag bit (1) aligned, 2 log_path char (128) var, 2 storage_flag bit (1) aligned, 2 storage_type char (80) var, 2 kermit_init_flag bit (1) aligned, 2 kinit_fname char (128) var, 2 parity_flag bit (1) aligned, 2 parity_type char (80) var, 2 help_flag bit (1) aligned, 2 usage_flag bit (1) aligned, 2 ser_flag bit (1) aligned, 2 pound_flag bit (1) aligned, 2 pound_option char (80) var; Dcl quit char (5) var, alarm char (6) var, basename char (32) var, (funit, type, sufusd, pix_index, bad_index) fixed bin; /* ************************************************************************* */ code = 0; call kermit_init; brk_lbl = done; quit = 'QUIT$'; call mkonu$ (quit, bk_hndlr); /* On-unit for quits. */ alarm = 'ALARM$'; call mkonu$ (alarm, timeout_hndlr); /* On-unit for timeouts. */ call cl$pix ('0002'b4, com_name, addr (cl_pic), cl_width, cmd_line, addr (cl_struc), pix_index, bad_index, code); if code ^= 0 then return; if cl_struc.help_flag then do; call print_cl_help; return; end; if cl_struc.usage_flag then do; call print_cl_usage; return; end; if (cl_struc.rec_flag & (cl_struc.send_flag | cl_struc.ser_flag)) | (cl_struc.send_flag & cl_struc.ser_flag) then do; code = e$null; call tnou ( 'Incompatible options; only ONE of SEND, RECEIVE, or SERVER may be given.', 72); return; end; if cl_struc.alt_flag then if length (cl_struc.alt_name) = 0 then call tnou ('No ALTERNATE file name specified, none being used.', 50); else if fnchk$ (k$uprc, cl_struc.alt_name) then alternate_fname = cl_struc.alt_name; else do; code = e$bnam; call ioa$ ('Invalid ALTERNATE file name "%v".%.', 99, cl_struc.alt_name); return; end; if cl_struc.log_flag then call start_log_file; in_init_file = cl_struc.kermit_init_flag; if ^in_init_file then do; call srsfx$ (k$exst, default_kermit_init_fname, funit, type, 0, '', basename, sufusd, code); in_init_file = (code = 0 & (type <= 1 | type = 7)); code = 0; end; if in_init_file then do; if length (cl_struc.kinit_fname) = 0 then kermit_init_file = default_kermit_init_fname; else kermit_init_file = cl_struc.kinit_fname; call comnd; kermit_init_file = ''; end; if cl_struc.pound_flag then do; explicit_pound_set = true; select (cl_struc.pound_option); when ('OFF', 'N', 'NO') pound_conversion = false; when ('', 'ON', 'Y', 'YES') do; pound_conversion = true; if length (cl_struc.pound_option) = 0 then call tnou ( 'No POUND option given, defaulting to ON for pound sign conversion.', 66); end; otherwise do; pound_conversion = true; call ioa$ ('Unknown POUND option "%v", %$', 99, cl_struc.pound_option); call tnou ('defaulting to ON for pound sign conversion.', 43); end; end; end; if cl_struc.storage_flag then do; explicit_ft_set = true; select (cl_struc.storage_type); when ('AS', 'ASC', 'ASCII', 'T', 'TEXT') file_type = ascii_ft; when ('B', 'BIN', 'BINARY', 'I', 'IMAGE') do; file_type = binary_ft; if ^explicit_pound_set then /* We DON'T want this! */ pound_conversion = false; end; when ('', 'AU', 'AUTO', 'AUTOMATIC') do; file_type = automatic_ft; explicit_ft_set = false; /* Assume we haven't set it. */ if length (cl_struc.storage_type) = 0 then call tnou ( 'No FILE TYPE specified, defaulting to AUTOMATIC.', 51); end; otherwise do; file_type = automatic_ft; explicit_ft_set = false; call ioa$ ( 'Unknown FILE TYPE "%v", defaulting to AUTOMATIC.%.', 99, cl_struc.storage_type); end; end; end; if cl_struc.parity_flag then select (cl_struc.parity_type); when ('', 'M', 'MARK') do; /* No need to check 8-bit quoting, it hasn't changed yet. */ do_transparent = false; do_8bit_chks = false; if length (cl_struc.parity_type) = 0 then call tnou ('No PARITY type specified, defaulting to MARK.', 45); end; when ('N', 'NONE') do; do_transparent = true; do_8bit_chks = true; loc_8quote_chr = 'Y'; end; otherwise do; do_transparent = false; do_8bit_chks = false; call ioa$ ('Unknown PARITY type "%v", defaulting to MARK.%.', 99, cl_struc.parity_type); end; end; if cl_struc.rec_flag then call rec_setup; else if cl_struc.send_flag then if length (cl_struc.send_path) = 0 then do; if in_init_file then do; call tonl; in_init_file = false; end; call tnou ( 'No SEND pathname given; Interactive mode will be used.', 54); call comnd; end; else if tnchk$ (k$uprc + k$wldc, cl_struc.send_path) then call send_setup; else do; code = e$itre; call ioa$ ('Invalid SEND pathname(s) "%v".%.', 99, cl_struc.send_path); end; else if cl_struc.ser_flag then call server_setup; else call comnd; Done : /* Return point for the QUIT$ on-unit. Since we are returning to PRIMOS we will close these files. */ if take_level > 0 then do; call comi$$ ('TTY', 3, take_unit(take_level), bad_index); take_level = take_level - 1; do pix_index = 1 to take_level; call clo$fu (take_unit(pix_index), bad_index); end; end; if file_opened then call clo$fu (file_unit, bad_index); if packet_log_opened then call clo$fu (packet_log_unit, bad_index); if session_log_opened then call clo$fu (session_log_unit, bad_index); if use_amlc_line then call assign (0, amlc_line, bad_index); return; /* ******************************* Rec_setup ******************************* */ /* REC_SETUP -- Setup to receive a file. */ Rec_setup : proc; /* ************************************************************************* */ call xfer_mode (1, code); /* Switch to transfer mode. */ if code ^= 0 then return; if in_init_file then call tonl; state = state_r; call set_path (cl_struc.rec_path); call tnou ('Kermit receive started.', 23); call rec_switch (); /* Start receiving now. */ call xfer_mode (0, code); return; end; /* Rec_setup */ /* ****************************** Send_setup ******************************* */ /* SEND_SETUP -- Setup to send a group of files. */ Send_setup : proc; /* ************************************************************************* */ call xfer_mode (1, code); /* Switch to transfer mode. */ if code ^= 0 then return; if in_init_file then call tonl; state = state_s; call set_path (cl_struc.send_path); call tnou ('Kermit send started.', 20); call send_switch (); /* Start sending now. */ call xfer_mode (0, code); return; end; /* Send_setup */ /* ***************************** Server_setup ****************************** */ /* SERVER_SETUP -- Setup to start server. */ Server_setup : proc; /* ************************************************************************* */ call xfer_mode (1, code); /* Switch to transfer mode. */ if code ^= 0 then return; if in_init_file then call tonl; call tnou ('Kermit server started.', 22); call server; call xfer_mode (0, code); return; end; /* Server_setup */ /* ***************************** Print_cl_usage **************************** */ Print_cl_usage : proc; /* ************************************************************************* */ bad_index = length (com_name) + 10; call ioa$ ('%/ Usage : %v [{-Receive [pathname] | -Send wildcard%$', 99, com_name); call tnou (' | -SERver}]', 12); call ioa$ ('%#x[-Alternate filename] [-Log [pathname]] %$', 99, bad_index); call tnou ('[-Parity {MARK | NONE}]', 23); call ioa$ ('%#x[-File_Type {AUTOMATIC | TEXT | BINARY}]%$', 99, bad_index); call tnou (' [-INIT [pathname]]', 19); call ioa$ ('%#x[-POUnd {ON | OFF}] [-Help] [-Usage]%/%.', 99, bad_index); return; end; /* Print_cl_usage */ /* ***************************** Print_cl_help ***************************** */ Print_cl_help : proc; /* ************************************************************************* */ call print_cl_usage; call ioa$ (' The first three options are mutually exclusive, %$', 99); call ioa$ ('but if none are specified%.', 99); call ioa$ (' then the user enters an interactive mode and is %$', 99); call ioa$ ('prompted for commands. All%.', 99); call ioa$ (' of the options may be abbreviated to those letters %$', 99); call ioa$ ('in uppercase.%/%.', 99); call ioa$ (' The options are :%/%.', 99); call ioa$ ('%5x-Receive [pathname]%/%8xUpload ONE file with the %$', 99); call ioa$ ('specified name or its original filename.%.', 99); call ioa$ ('%/%5x-Send wildcard%/%8xDownload several files. %$', 99); call ioa$ ('Wildcards may be used, but the -ALTERNATE%.', 99); call ioa$ ('%8xoption is then ignored.%.', 99); call ioa$ ('%/%5x-SERver%/%8xEnter server mode. Files may be %$', 99); call ioa$ ('sent and received, and additional%.', 99); call ioa$ ('%8xcommands may be issued.%.', 99); if ^more () then return; call ioa$ ('%/%5x-Alternate filename%.', 99); call ioa$ ('%8xAlternate file name for when ONE file is being sent.%.', 99); call ioa$ ('%/%5x-File_Type {AUTOMATIC | TEXT | BINARY}%.', 99); call ioa$ ('%8xSpecifies the type of file, %$', 99); call ioa$ ('or if AUTOMATIC is used then Kermit%.', 99); call ioa$ ('%8xwill try to determine its type. Default is AUTOMATIC.%.', 99); call ioa$ ('%/%5x-INIT [pathname]%.', 99); call tnou (' By default an initialization file is executed.', 54); call ioa$ ('%8xDefault pathname is "%a".%.', 99, default_kermit_init_fname, length (default_kermit_init_fname)); call ioa$ ('%/%5x-Parity {MARK | NONE}%.', 99); call ioa$ ('%8xSpecifies the character parity to %$', 99); call ioa$ ('use. Default is MARK.%.', 99); call ioa$ ('%/%5x-Log [pathname]%.', 99); call ioa$ ('%8xOpens a packet log file for recording the packets %$', 99); call ioa$ ('sent and received.%/%8xDefault log pathname is "%a".%.', 99, default_packet_log, length (default_packet_log)); call ioa$ ('%/%5x-POUnd {ON | OFF}%/%8xDetermines whether to convert DOS %$', 99); call ioa$ ('pound signs. Default is ON.%/%.', 99); if ^more () then return; call ioa$ ('%/%5x-Help%/%8xDisplays this HELP message.%.', 99); call ioa$ ('%/%5x-Usage%/%8xDisplays the Kermit usage syntax only.%/%.', 99); return; end; /* Print_cl_help */ /* ***************************** Start_log_file **************************** */ Start_log_file : proc; /* ************************************************************************* */ code = open_log (packet_log, cl_struc.log_path); if code ^= 0 then do; call get_error_msg (code); call ioa$ ('Log file not opened. %v%.', 99, errmsg); end; return; end; /* Start_log_file */ end; /* Kermit */ ------------------------------------------------------------------------------- /* KERMIT_INIT -- Initialize Kermit variables. */ Kermit_init : proc; $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp $Insert syscom>keys.ins.pl1 Dcl temp fixed bin, b8 bit (8) aligned, b8_ptr ptr, primos_version char (16) var; /* ************************************************************************* */ b8_ptr = addr (b8); kversion = 'Public domain version 8.15'; kprompt = 'Prime-Kermit> '; kprompt_len = length (kprompt); in_init_file = false; kermit_init_file = ''; delay = default_delay; rec_seq = 0; msg_number = 0; snd_msg = ''; rec_msg = ''; rec_pkt_type = ''; rec_length = 0; rec_file_size = -1; /* Received file attributes. */ rec_file_dtc = -1; rec_file_type = automatic_ft; use_attributes = true; do temp = 0 to 63; msg_table.slot(temp).msg = ''; msg_table.slot(temp).acked = false; msg_table.slot(temp).retries = 0; end; tab_first = 0; /* Default transfer parameters. */ tab_next = 0; state = 0; num_retries = 0; max_retries = default_max_retries; quote8_char = 'N'; file_type = automatic_ft; /* Unknown file type. */ explicit_ft_set = false; first_write = true; filename_warning = true; do_repeats = false; do_transparent = false; do_flush = true; do_8bit_chks = false; auto_sum = true; packet_log_opened = false; packet_log_unit = 0; packet_log_pathname = default_packet_log; session_log_opened = false; session_log_unit = 0; session_log_pathname = default_session_log; session_log_save_line = ''; window_size = 1; errmsg = ''; take_level = 0; do temp = 1 to max_take_level; take_unit(temp) = 0; end; loc_pkt_size = my_pkt_size; /* Default send init parameters. */ loc_npad = my_npad; b8 = my_pad_chr; loc_padchar = b8_ptr -> char1_based; loc_timeout = my_timeout; b8 = my_eol_chr; loc_eol = b8_ptr -> char1_based; loc_quote_chr = my_quote_chr; loc_8quote_chr = my_8quote_chr; loc_chk_type = my_chk_type; loc_rep_chr = my_rep_chr; loc_capas1 = my_capas1; loc_file_attrib = false; loc_max_wsize = my_max_wsize; path_name = ''; dir_name = ''; non_null_dir = false; file_name = ''; alternate_fname = ''; file_unit = 0; file_opened = false; file_len = 0; file_pos = 0; space_count = 0; ignore_next = false; next_is_lf = false; saved_msg = ''; saved_char = ''; do temp = 1 to max_matches; matches(temp) = ''; end; num_matches = 0; file_idx = 0; del_incomplete = true; ibuffer = copy (space_8bit_asc, ibuffer_size); ibuffer_ptr = addr (ibuffer); ibuflen = 0; ibuf_ptr = 0; char2_ptr = addr (char2); char2_ptr -> fb15_based = 0; pound_conversion = true; explicit_pound_set = false; do temp = 0 to 255; trans_char(temp) = ''; end; dir_entry_ptr = addr (dir_entry); file_info_ptr = addr (file_info); file_info.version = 1; file_info.ldevno = -1; /* No valid logical device number yet. */ b8 = '00'b4; /* Setup all the character codes we need. */ nul_7bit_asc = b8_ptr -> char1_based; b8 = '80'b4; nul_8bit_asc = b8_ptr -> char1_based; b8 = ctrl_a_7bit_dec; ctrl_a_7bit_asc = b8_ptr -> char1_based; b8 = ctrl_a_8bit_dec; ctrl_a_8bit_asc = b8_ptr -> char1_based; b8 = '08'b4; bs_7bit_asc = b8_ptr -> char1_based; b8 = '88'b4; bs_8bit_asc = b8_ptr -> char1_based; b8 = cr_7bit_dec; cr_7bit_asc = b8_ptr -> char1_based; rem_timeout = 60; /* Default remote Kermit timeout for SHOW. */ rem_eol = cr_7bit_asc; /* We need these for the FIRST packet sent. */ rem_npad = 0; b8 = cr_8bit_dec; cr_8bit_asc = b8_ptr -> char1_based; b8 = lf_7bit_dec; lf_7bit_asc = b8_ptr -> char1_based; b8 = lf_8bit_dec; lf_8bit_asc = b8_ptr -> char1_based; b8 = '0C'b4; ff_7bit_asc = b8_ptr -> char1_based; b8 = '91'b4; dc1_8bit_asc = b8_ptr -> char1_based; b8 = '1A'b4; ctrl_z_7bit_asc = b8_ptr -> char1_based; b8 = '9A'b4; ctrl_z_8bit_asc = b8_ptr -> char1_based; b8 = '20'b4; space_7bit_asc = b8_ptr -> char1_based; b8 = '3F'b4; query_7bit_asc = b8_ptr -> char1_based; b8 = '60'b4; grave_7bit_asc = b8_ptr -> char1_based; b8 = 'FF'b4; del_8bit_asc = b8_ptr -> char1_based; my_new_erase = nul_7bit_asc || bs_8bit_asc; my_new_kill = nul_7bit_asc || del_8bit_asc; call user$ (my_user_number, temp); /* Get my user number for later. */ call get_user_info; call pri$rv (primos_version); /* See how up to date we are PRIMOS-wise. */ old_primos_revision = (substr (primos_version, 1, 2) ^= '22'); use_amlc_line = false; /* Asynchronous line variables. */ escape_char = ctl (']'); abort_char = 'C'; break_char = 'B'; saved_amlc_chrs = ''; amlc_line = -1; baud_rate = 1200; baud_rate_index = 3; /* Default to 1200 baud. */ return; end; /* Kermit_init */ ------------------------------------------------------------------------------- /* LOG_INFO -- Log one line of info to log file. */ Log_info : proc (type, data); Dcl type fixed bin, data char (256) var; $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp Dcl code fixed bin, (newdata, tempdata) char (512) var; /* ************************************************************************* */ if type = packet_log then do; if use_amlc_line then call tnou ('---- ' || data, length (data) + 5); if packet_log_opened then do; call wtlin$ (packet_log_unit, ('---- ' || data || ' '), divide (length (data) + 6, 2, 15), code); if code ^= 0 then do; call get_error_msg (code); call ioa$ ('Unable to write to the packet log file. %v%.', 99, errmsg); call tnou ('Closing the log file.', 21); packet_log_opened = false; call clo$fu (packet_log_unit, code); end; end; end; else if session_log_opened then do; newdata = session_log_save_line || data; do while (index (newdata, lf_8bit_asc) ^= 0); tempdata = before (newdata, lf_8bit_asc); newdata = after (newdata, lf_8bit_asc); do while (index (tempdata, cr_8bit_asc) ^= 0); tempdata = before (tempdata, cr_8bit_asc) || after (tempdata, cr_8bit_asc); end; call wtlin$ (session_log_unit, (tempdata || ' '), divide (length (tempdata) + 1, 2, 15), code); if code ^= 0 then do; call get_error_msg (code); call ioa$ ('Unable to write to the session log file. %v%.', 99, errmsg); call tnou ('Closing the log file.', 21); session_log_opened = false; call clo$fu (session_log_unit, code); end; end; session_log_save_line = newdata; end; return; end; /* Log_info */ ------------------------------------------------------------------------------- /* LOG_PACKET -- Log Kermit packet to disk. */ Log_packet : proc (packet_type, seq_num, data); $Insert *>insert>common.ins.plp Dcl packet_type char (1), seq_num fixed bin, data char (max_msg) var; $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp Dcl line char (256) var, code fixed bin; /* ************************************************************************* */ if ^packet_log_opened then return; select (packet_type); when (msg_data) line = 'DATA '; when (msg_attrib) line = 'ATTR '; when (msg_ack) line = 'ACK '; when (msg_nak) line = 'NAK '; when (msg_snd_init) line = 'SNDI '; when (msg_break) line = 'BRK '; when (msg_file) line = 'FILE '; when (msg_eof) line = 'EOF '; when (msg_error) do; line = 'ERR '; if use_amlc_line then call ioa$ ('---- Error during operation : "%v"%.', 99, data); end; when (msg_rcv_init) line = 'RCVI '; when (msg_host_command) line = 'HOST '; when (msg_text) line = 'TEXT '; when (msg_init_info) line = 'INIT '; when (msg_kermit) line = 'KER '; when (msg_kermit_generic) line = 'GEN '; when (msg_timeout) line = 'TIME '; when (msg_check_err) line = 'CHK '; otherwise line = '?? ' || packet_type || space_8bit_asc; end; if seq_num < 10 then line = line || space_8bit_asc; line = line || trim (char (seq_num), '11'b); /* Append the seq. number. */ if length (data) ^= 0 then /* Append the data. */ line = line || ' "' || data || '"'; call wtlin$ (packet_log_unit, (line || ' '), divide (length (line) + 1, 2, 15), code); if code ^= 0 then do; call get_error_msg (code); call ioa$ ('Unable to log the packet. %v%/Closing the log file. %.', 99, errmsg); packet_log_opened = false; call clo$fu (packet_log_unit, code); end; return; end; /* Log_packet */ ------------------------------------------------------------------------------- /* MATCH_FILE -- Match a wildcard spec from user to determine filenames. */ Match_file : proc returns (fixed bin); $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert syscom>keys.ins.pl1 $Insert syscom>errd.ins.pl1 Dcl (dir_unit, type, sufusd, code) fixed bin, (basename, fn, wild_name) char (32) var; /* ************************************************************************* */ code = 0; num_matches = 0; /* First we convert the filename to uppercase, and translate any wildcard characters from DOS to the PRIME equivelent. Apart from the one case below we cannot fully translate the wildcards, since we don't know what the user actually means. E.g. Given the file A.B.C, if the user types *.C do they just mean the files @.C, or do they mean @@.C which would include A.B.C. */ if file_name = '*.*' then file_name = '@@'; file_name = translate (file_name, uppercase || '@+', lowercase || '*?'); if non_null_dir then path_name = dir_name || '>' || file_name; else path_name = file_name; call set_path (path_name); if search (path_name, '@+') = 0 then /* See if we have just one file name. */ do; num_matches = 1; matches(1) = path_name; return (code); end; if search (dir_name, '@+') ^= 0 then /* Wildcarded directories ? */ return (e$itre); wild_name = file_name; call srsfx$ (k$read + k$getu, dir_name, dir_unit, type, 0, '', basename, sufusd, code); if code ^= 0 then return (code); call dir$rd (k$init, dir_unit, dir_entry_ptr, dir_entry_size, code); do until (code ^= 0); call dir$rd (k$read, dir_unit, dir_entry_ptr, dir_entry_size, code); if code = 0 & dir_entry.ecw.type = '02'b4 & (dir_entry.file_inf.type < '02'b4 | dir_entry.file_inf.type = '07'b4) then do; /* It's an ordinary SAM, DAM, or CAM file. */ fn = trim (dir_entry.entryname, '11'b); if wild$ (wild_name, fn, code) then do; num_matches = num_matches + 1; if num_matches <= max_matches then matches(num_matches) = fn; else code = e$tmvv; /* Too many values for variable. */ end; end; end; call clo$fu (dir_unit, sufusd); if code = e$eof then code = 0; return (code); end; /* Match_file */ ------------------------------------------------------------------------------- /* NEXT_FILE -- Fetch next file of wildcard specification. */ Next_file : proc returns (fixed bin); $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>constants.ins.plp Dcl code fixed bin, test_flag bit (1) aligned; /* ************************************************************************* */ test_flag = false; do until (test_flag); if file_idx > num_matches | file_idx = 0 then return (ker_nomorfiles); /* Check for the end of the table. */ call set_path (matches(file_idx)); /* Get the next file name. */ code = open_input (); /* Try to open the file. */ if code ^= 0 then do; call get_error_msg (code); call log_info (packet_log, 'Error opening ' || path_name || '. ' || errmsg); file_idx = file_idx + 1; /* Try the next file. */ end; else do; test_flag = true; if packet_log_opened then do; select (file_type); when (ascii_ft) errmsg = 'as ASCII file type.'; when (binary_ft) errmsg = 'as BINARY file type.'; when (automatic_ft) errmsg = 'with AUTOMATIC file type detection.'; otherwise errmsg = 'with an ILLEGAL file type.'; end; call log_info (packet_log, 'File ' || path_name || ' opened ' || errmsg); if explicit_ft_set then call log_info (packet_log, 'The file type has been explicitly set.'); else if file_type ^= automatic_ft then call log_info (packet_log, 'The file type has been automatically set.'); end; end; end; if num_matches = 1 & length (alternate_fname) ^= 0 then do; /* Use the alternate file name if given. */ file_name = alternate_fname; if packet_log_opened then call log_info (packet_log, 'The file ' || path_name || ' will be sent using the alternate file name of ' || alternate_fname || '.'); if ^non_null_dir then path_name = file_name; else path_name = dir_name || '>' || file_name; end; file_idx = file_idx + 1; /* Point to next file name. */ return (ker_normal); end; /* Next_file */ ------------------------------------------------------------------------------- /* OPEN_INPUT -- Open input file, determine its type and length. */ Open_input : proc returns (fixed bin); $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp $Insert syscom>keys.ins.pl1 $Insert syscom>errd.ins.pl1 Dcl (type, code, rnw, code2, sufusd) fixed bin, basename char (32) var; /* ************************************************************************* */ call srsfx$ (k$read + k$getu, path_name, file_unit, type, 0, '', basename, sufusd, code); if type > 1 & type ^= 7 then do; call clo$fu (file_unit, rnw); if code = 0 then code = e$wft; end; file_opened = (code = 0); if code ^= 0 then return (code); space_count = 0; /* Initialise these just in case. */ ignore_next = false; next_is_lf = false; ibuflen = 0; /* These must be initialised. */ file_pos = 0; ibuf_ptr = 1; ibuffer = ''; code = get_len (false); if code = 0 then do; if file_len = 0 then file_type = ascii_ft; /* This takes care of empty files. */ if file_type = automatic_ft then /* AUTOMATIC file type detection. */ call ck_file_type; if file_type = binary_ft & ^explicit_pound_set then pound_conversion = false; /* Re-set this if need be. */ if file_type = ascii_ft then code = get_len (true); if code = 0 then return (code); end; file_opened = false; /* Something is wrong here, so close the file. */ call clo$fu (file_unit, code2); return (code); /* ****************************** Ck_file_type ***************************** */ Ck_file_type : proc; Dcl (character, prev_char) char (1), character_ptr ptr; Dcl 1 bit_char based, 2 high_bit bit (1), 2 rest bit (7); /* ************************************************************************* */ /* Initialize local variables for file type checking. */ code = 0; character = nul_7bit_asc; character_ptr = addr (character); call prwf$$ (k$read, file_unit, ibuffer_ptr, ibuffer_size_wds, 0, rnw, code); if code = e$eof & rnw ^= 0 then code = 0; ibuflen = 2 * rnw; file_pos = ibuflen; if code ^= 0 then return; file_type = ascii_ft; /* Assume it's ASCII to begin with. */ do ibuf_ptr = 1 to ibuflen while (file_type ^= binary_ft); prev_char = character; character = substr (ibuffer, ibuf_ptr, 1); /* If the high bit is off then check for some special characters before deciding that it IS a binary file. */ if ^character_ptr -> bit_char.high_bit then if prev_char ^= dc1_8bit_asc & /* Space compression. */ ^(prev_char = lf_8bit_asc & character = nul_7bit_asc) & /* LFNUL */ ^(character = bs_7bit_asc | /* Back Space. */ character = ff_7bit_asc) & /* Form Feed. */ ^(character = ctrl_a_7bit_asc & /* CTRL-A for FORTRAN formats. */ (prev_char = lf_8bit_asc | prev_char = nul_7bit_asc | prev_char = ctrl_a_7bit_asc)) & character ^= ctrl_z_7bit_asc then file_type = binary_ft; end; if file_type ^= binary_ft & file_len = ibuflen then do; /* ASCII files must end in LF or CTRL-Z. */ if character = nul_7bit_asc then character = prev_char; if ^(character = lf_8bit_asc | character = ctrl_z_7bit_asc) then file_type = binary_ft; end; ibuflen = 0; /* Re-initialize some of our buffer variables. */ ibuf_ptr = 1; ibuffer = ''; call prwf$$ (k$posn + k$prea, file_unit, null (), 0, 0, rnw, code); if code = 0 then file_pos = 0; return; end; /* Ck_file_type */ end; /* Open_input */ ------------------------------------------------------------------------------- /* OPEN_LOG -- Open an output log file. */ Open_log : proc (log_type, pathname) returns (fixed bin); Dcl log_type fixed bin, pathname char (128) var; $Insert *>insert>common.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp $Insert syscom>keys.ins.pl1 $Insert syscom>errd.ins.pl1 Dcl (log_unit, type, sufusd, code) fixed bin, basename char (32) var, fn char (128) var; /* ************************************************************************* */ fn = pathname; if length (fn) = 0 then if log_type = packet_log then fn = default_packet_log; else fn = default_session_log; call fil$dl (fn, code); /* Delete any old file first, if possible. */ if code = 0 | code = e$fntf | code = e$ninf then call srsfx$ (k$writ + k$getu, fn, log_unit, type, 0, '', basename, sufusd, code); if code = 0 then do; if fnchk$ (k$uprc, fn) then fn = '*>' || fn; if log_type = packet_log then do; packet_log_opened = true; packet_log_unit = log_unit; packet_log_pathname = fn; end; else do; session_log_opened = true; session_log_unit = log_unit; session_log_pathname = fn; end; end; else if log_type = packet_log then packet_log_opened = false; else session_log_opened = false; return (code); end; /* Open_log */ ------------------------------------------------------------------------------- /* OPEN_OUTPUT -- Open an output file. */ Open_output : proc returns (fixed bin); $Insert *>insert>kermit.ins.plp $Insert *>insert>common.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp $Insert syscom>keys.ins.pl1 $Insert syscom>errd.ins.pl1 Dcl (type, sufusd, code, num_len, i) fixed bin, (file_exists, new_file_name, overwrite) bit (1) aligned, new_path_ptr ptr, (treename, new_path) char (128) var, (basename, suffix) char (32) var; Dcl 1 bvs based, 2 len fixed bin, 2 chars char (128); %Replace dot by '.'; /* ************************************************************************* */ file_exists = false; file_opened = false; new_file_name = false; if non_null_dir then if ^tnchk$ (k$uprc, dir_name) then return (e$itre); /* A bad directory name given. */ if ^fnchk$ (k$uprc, file_name) then do; /* Replace a bad file name. */ new_file_name = true; file_name = 'KERMIT_FILE'; if ^non_null_dir then path_name = file_name; else path_name = dir_name || '>' || file_name; end; if filename_warning then do; call srsfx$ (k$exst, path_name, file_unit, type, 0, '', basename, sufusd, code); if code = 0 then do; file_exists = true; new_path_ptr = addr (new_path); overwrite = (length (file_name) = 32); if overwrite then /* Overwrite or append to the file name. */ num_len = 1; else do; num_len = 32 - length (file_name); if num_len > 4 then num_len = 4; end; if index (file_name, dot) ^= 0 then do; treename = before (file_name, dot); suffix = dot || after (file_name, dot); end; else do; treename = file_name; suffix = ''; end; if overwrite then treename = substr (treename, 1, length (treename) - 1); do i = 1 to 9999 until (code ^= 0); if overwrite then if i = 10 then do; num_len = 2; treename = substr (treename, 1, length (treename) - 1); end; else if i = 100 then do; num_len = 3; treename = substr (treename, 1, length (treename) - 1); end; else if i = 1000 then do; num_len = 4; treename = substr (treename, 1, length (treename) - 1); end; call ioa$rs (new_path_ptr -> bvs.chars, 128, new_path_ptr -> bvs.len, '%v%#zd%v%$', 99, treename, num_len, i, suffix); call srsfx$ (k$exst, new_path, file_unit, type, 0, '', basename, sufusd, code); end; if code = e$fntf then call set_path (new_path); else if code = 0 then code = e$ialn; end; end; else call fil$dl (path_name, code); if code = 0 | code = e$fntf | code = e$ninf then do; call srsfx$ (k$writ + k$getu, path_name, file_unit, type, 0, '', basename, sufusd, code); if code = 0 then do; ibuffer = ''; ibuf_ptr = 0; first_write = true; end; end; file_opened = (code = 0); if code = 0 then if new_file_name then code = e$bnam; /* Say that the file name was bad. */ else if file_exists then /* Say that the file already exists. */ code = e$exst; return (code); end; /* Open_output */ ------------------------------------------------------------------------------- /* PRS_SEND_INIT -- Parse SND_INIT packet from remote Kermit. */ Prs_send_init : proc; $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>constants.ins.plp Dcl (cap_len, cap_pos, cap_byte) fixed bin, cap_ptr ptr; /* ************************************************************************* */ rem_pkt_size = 80; /* Set the default values for fields not received. */ rem_npad = 0; rem_padchar = nul_7bit_asc; rem_pad_chars = copy (rem_padchar, max_rem_pad_chrs); /* Never received. */ rem_timeout = 60; /* Timeout in seconds. */ rem_eol = cr_7bit_asc; rem_quote_chr = '#'; rem_8quote_chr = 'N'; rem_chk_type = '1'; rem_rep_chr = space_8bit_asc; rem_capas1 = 0; rem_file_attrib = false; rem_windowing = false; rem_max_wsize = 1; /* Process the packet according to its length. */ select (length (rec_msg) - pkt_tot_ovr_head); when (p_si_bufsiz) goto pkt_lbl; when (p_si_timout) goto to_lbl; when (p_si_npad) goto np_lbl; when (p_si_pad) goto pc_lbl; when (p_si_eol) goto eol_lbl; when (p_si_quote) goto qc_lbl; when (p_si_8quote) goto ebqc_lbl; when (p_si_chk) goto chk_lbl; when (p_si_rep) go to rep_lbl; end; /* Longer messages drop through to check the capabilities. */ cap_ptr = addr (rem_capas1); rem_capas1 = knum (substr (rec_msg, pkt_msg + p_si_capas, 1)); rem_file_attrib = cap_ptr -> capas.file_attributes; rem_windowing = cap_ptr -> capas.windowing; /* Find the end of the variable length capabilities field. */ cap_len = 1; cap_byte = rem_capas1; cap_ptr = addr (cap_byte); do while (cap_ptr -> capas.continues); cap_len = cap_len + 1; cap_byte = knum (substr (rec_msg, pkt_msg + p_si_capas + cap_len - 1, 1)); end; cap_pos = pkt_msg + p_si_capas + cap_len; if rem_windowing then /* Get the maximum window size. */ rem_max_wsize = knum (substr (rec_msg, cap_pos, 1)); Rep_lbl : rem_rep_chr = substr (rec_msg, pkt_msg + p_si_rep, 1); Chk_lbl : rem_chk_type = substr (rec_msg, pkt_msg + p_si_chk, 1); Ebqc_lbl : rem_8quote_chr = substr (rec_msg, pkt_msg + p_si_8quote, 1); Qc_lbl : rem_quote_chr = substr (rec_msg, pkt_msg + p_si_quote, 1); Eol_lbl : char2_ptr -> fb15_based = knum (substr (rec_msg, pkt_msg + p_si_eol, 1)); rem_eol = char2(2); Pc_lbl : rem_padchar = ctl (substr (rec_msg, pkt_msg + p_si_pad, 1)); rem_pad_chars = copy (rem_padchar, max_rem_pad_chrs); Np_lbl : rem_npad = knum (substr (rec_msg, pkt_msg + p_si_npad, 1)); To_lbl : rem_timeout = knum (substr (rec_msg, pkt_msg + p_si_timout, 1)); Pkt_lbl : rem_pkt_size = knum (substr (rec_msg, pkt_msg + p_si_bufsiz, 1)); return; end; /* Prs_send_init */ ------------------------------------------------------------------------------- /* READ_INPUT -- Read input file and form data packet. */ Read_input : proc (code) returns (fixed bin); Dcl code fixed bin; $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp $Insert syscom>keys.ins.pl1 $Insert syscom>errd.ins.pl1 Dcl (rep_count, max_chars, rnw) fixed bin, new_char_ptr ptr, (packet_full, repeating) bit (1) aligned, (prev_char, new_char, rep_chr_7bit) char (1), chr char (6) var; /* ************************************************************************* */ code = 0; char2_ptr -> fb15_based = 0; chr = ''; repeating = false; packet_full = false; new_char_ptr = addr (new_char); rep_chr_7bit = clr8 (loc_rep_chr); if length (saved_msg) ^= 0 then do; snd_msg = saved_msg; saved_msg = ''; rep_count = length (saved_char); /* For EOF with 1 char left rep_count will be 0. */ if rep_count = 1 then do; prev_char = substr (saved_char, 1, 1); saved_char = ''; end; end; else do; rep_count = 0; snd_msg = ''; prev_char = nul_7bit_asc; end; max_chars = rem_pkt_size - pkt_tot_ovr_head + 1; /* Maximum packet size. */ Loop : do until (packet_full | code ^= 0); /* Main packet loop. */ call read_char; if code ^= 0 then if do_repeats then if rep_count = 0 | code ^= e$eof then leave loop; else goto store_chr; else leave loop; if do_repeats then if (new_char = prev_char & rep_count < 94) | rep_count = 0 then do; repeating = true; rep_count = rep_count + 1; end; else do; Store_chr : repeating = false; char2(2) = prev_char; chr = trans_char (char2_ptr -> fb15_based); if rep_count > 2 then do; char2_ptr -> fb15_based = rep_count + 32; chr = rep_chr_7bit || char2(2) || chr; end; else if rep_count = 2 then chr = chr || chr; rep_count = 1; end; else do; char2(2) = new_char; chr = trans_char (char2_ptr -> fb15_based); end; prev_char = new_char; if ^repeating then if length (snd_msg) + length (chr) <= max_chars then snd_msg = snd_msg || chr; else do; packet_full = true; saved_msg = chr; if code = e$eof then saved_char = ''; else saved_char = new_char; end; end; if code = e$eof then code = 0; if code ^= 0 then return (ker_internalerr); else if length (snd_msg) = 0 then return (ker_eof); else return (ker_normal); /* ******************************* Read_raw ******************************** */ Read_raw : proc; /* ************************************************************************* */ ibuf_ptr = ibuf_ptr + 1; if ibuf_ptr > ibuflen then do; call prwf$$ (k$read, file_unit, ibuffer_ptr, ibuffer_size_wds, 0, rnw, code); if code = e$eof & rnw ^= 0 then code = 0; ibuflen = 2 * rnw; if code = 0 then do; file_pos = file_pos + ibuflen; if file_pos > file_len then ibuflen = ibuflen - 1; end; else return; ibuf_ptr = 1; end; new_char = substr (ibuffer, ibuf_ptr, 1); return; end; /* Read_raw */ /* ******************************* Read_char ******************************* */ Read_char : proc; /* ************************************************************************* */ if space_count > 0 then /* Still doing space compression. */ do; new_char = space_7bit_asc; space_count = space_count - 1; end; else if next_is_lf then /* Next character must be a LF. */ do; next_is_lf = false; new_char = lf_7bit_asc; end; else do; if ignore_next then /* Ignore the next character. */ do; ignore_next = false; call read_raw; if code ^= 0 then return; end; call read_raw; if code ^= 0 then return; if file_type = ascii_ft then if new_char = dc1_8bit_asc then /* Space compression char. */ do; call read_raw; /* Get the number of spaces. */ if code ^= 0 then return; space_count = (new_char_ptr -> bit8_based) - 1; new_char = space_7bit_asc; end; else if new_char = lf_8bit_asc then /* Linefeed character. */ do; next_is_lf = true; ignore_next = (mod (ibuf_ptr, 2) ^= 0); new_char = cr_7bit_asc; /* Replace LF by CR LF. */ end; else /* For all other chars make them 7-bit ASCII. */ new_char = clr8 (new_char); end; return; end; /* Read_char */ end; /* Read_input */ ------------------------------------------------------------------------------- /* REC_AMLC -- Receive characters from an asynchronous line. */ /* This subroutine reads characters until a new line is found or the buffer size is reached. */ Rec_amlc : proc (line, buffer, maxbuffer, bufferlen) returns (fixed bin); $Insert *>insert>common.ins.plp Dcl (line, maxbuffer, bufferlen) fixed bin, buffer char (max_msg); $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp %Replace max_buff by 256; Dcl (idx1, idx2, code) fixed bin, statv (2) fixed bin, (onechar_ptr, get_buff_ptr) ptr, onechar char, getbuffer char (max_buff), (tempbuffer, tempbuff2, getbuff2) char (max_buff) var; /* ************************************************************************* */ code = 0; onechar_ptr = addr (onechar); get_buff_ptr = addr (getbuffer); tempbuffer = saved_amlc_chrs; tempbuff2 = set8str (tempbuffer); saved_amlc_chrs = ''; do while (index (tempbuff2, lf_8bit_asc) = 0 & index (tempbuff2, cr_8bit_asc) = 0 & length (tempbuffer) < maxbuffer & code = 0); call t$amlc (line, onechar_ptr, 1, 1, statv, 1, code); if code = 0 then do; tempbuffer = tempbuffer || onechar; tempbuff2 = set8 (onechar); call t$amlc (line, get_buff_ptr, maxbuffer - length (tempbuffer) -1, 6, statv, 1, code); if statv(1) > 0 & code = 0 then do; getbuff2 = substr (getbuffer, 1, statv(1)); tempbuffer = tempbuffer || getbuff2; tempbuff2 = tempbuff2 || set8str (getbuff2); end; end; end; if code ^= 0 then do; bufferlen = 1; substr (buffer, 1, 1) = nul_7bit_asc; return (code); end; tempbuff2 = set8str (tempbuffer); idx1 = index (tempbuff2, lf_8bit_asc); idx2 = index (tempbuff2, cr_8bit_asc); if idx2 = 0 | (idx1 < idx2 & idx1 ^= 0) then idx2 = idx1; if idx2 > maxbuffer | idx2 = 0 then idx2 = maxbuffer; if idx2 ^= 0 & idx2 < length (tempbuffer) then saved_amlc_chrs = substr (tempbuffer, idx2 + 1, length (tempbuffer)-idx2); buffer = substr (tempbuffer, 1, idx2); bufferlen = idx2; return (code); end; /* Rec_amlc */ ------------------------------------------------------------------------------- /* REC_PACKET -- Receive a packet from remote Kermit. */ Rec_packet : proc; $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp Dcl (code, rec_msg_len, nchr) fixed bin, chr char (1), line char (max_msg) var; /* ************************************************************************* */ code = 0; timeout = bad_return; /* Local label used for Timeout condition. */ call limit$ ('0702'b4, (rem_timeout), 0, nchr); do until (chr = ctrl_a_8bit_asc); if use_amlc_line then code = rec_amlc (amlc_line, chr, 1, nchr); else do; call c1in (char2); chr = char2(2); end; chr = set8 (chr); end; call limit$ ('0702'b4, 0, 0, nchr); /* Turn off the timer. */ call get_line; /* Get the rest of the message. */ if code ^= 0 then /* This MAY have been set in GET_LINE. */ do; rec_pkt_type = '1'; /* This will force an error condition */ return; /* to halt the transfer. */ end; rec_msg_len = length (rec_msg); if rec_msg_len < pkt_msg then /* Check that the packet length is valid. */ do; rec_pkt_type = msg_check_err; if packet_log_opened then do; call log_info (packet_log, 'Packet length of ' || trim (char (rec_msg_len), '11'b) || ' is too short.'); if rec_msg_len <= 1 then line = ''; else line = substr (rec_msg, 2); call log_packet (rec_pkt_type, 0, line); end; return; end; /* Now extract the fields from the packet. */ rec_pkt_type = set8 (substr (rec_msg, pkt_type, 1)); rec_length = knum (substr (rec_msg, pkt_count, 1)) + 2; rec_seq = knum (substr (rec_msg, pkt_seq, 1)); /* Check that the packet length is correct. */ if rec_msg_len ^= rec_length then do; rec_pkt_type = msg_check_err; if packet_log_opened then do; call log_info (packet_log, 'Packet length byte (' || trim (char (rec_length - 2), '11'b) || ') is not equal to packet size (' || trim (char (rec_msg_len - 2), '11'b) || ').'); if rec_msg_len <= 1 then line = ''; else line = substr (rec_msg, 2); call log_packet (rec_pkt_type, 0, line); end; return; end; if ^check_checksum () then /* Check the checksum. */ if packet_log_opened then do; if rec_msg_len <= 1 then line = ''; else line = substr (rec_msg, 2); call log_packet (rec_pkt_type, 0, line); end; else ; else /* A good return. */ if packet_log_opened then do; if rec_msg_len <= pkt_msg then line = ''; else line = substr (rec_msg, pkt_msg, rec_msg_len - pkt_msg); call log_packet (rec_pkt_type, rec_seq, line); end; return; Bad_return : /* If we get here then the Timeout condition has been raised. */ rec_pkt_type = msg_timeout; call log_packet (rec_pkt_type, 0, ''); return; /* ******************************* Get_line ******************************** */ Get_line : proc; Dcl rec_msg_buffer char (max_msg), last_char char (1), buflen fixed bin; /* ************************************************************************* */ if use_amlc_line then do; code = rec_amlc (amlc_line, rec_msg_buffer, max_msg_less1, buflen); if code ^= 0 then return; end; else call cnin$ (rec_msg_buffer, max_msg_less1, buflen); last_char = clr8 (substr (rec_msg_buffer, buflen, 1)); if last_char = cr_7bit_asc | last_char = lf_7bit_asc then buflen = buflen - 1; rec_msg = ctrl_a_8bit_asc || substr (rec_msg_buffer, 1, buflen); return; end; /* Get_line */ /* ***************************** Check_checksum **************************** */ Check_checksum : proc returns (bit (1) aligned); Dcl (chksum, chksum7, chksum8, key, rec_len, rec_pkt_chksum) fixed bin; /* ************************************************************************* */ rec_len = rec_length - 1; rec_pkt_chksum = knum (substr (rec_msg, rec_length, 1)); if auto_sum then /* If checksum type is undetermined, then try both. */ do; chksum7 = chks (0, substr (rec_msg, 1, rec_len)); chksum8 = chks (1, substr (rec_msg, 1, rec_len)); if (chksum7 ^= rec_pkt_chksum) & (chksum8 ^= rec_pkt_chksum) then do; rec_pkt_type = msg_check_err; call log_info (packet_log, 'Checksum error : wanted '|| trim (char (chksum7), '11'b) || ' or ' || trim (char (chksum8), '11'b) ||', but got ' || trim (char (rec_pkt_chksum), '11'b) || '.'); return (false); end; /* Determine checksum type if undetermined. */ if chksum7 ^= chksum8 then do; auto_sum = false; do_8bit_chks = (chksum8 = rec_pkt_chksum); if do_8bit_chks then call log_info (packet_log, 'Doing 8 bit checksums.'); else call log_info (packet_log, 'Doing 7 bit checksums.'); end; end; else do; /* Checksum type already determined. */ if do_8bit_chks then key = 1; else key = 0; chksum = chks (key, substr (rec_msg, 1, rec_len)); if chksum ^= rec_pkt_chksum then do; rec_pkt_type = msg_check_err; char2(1) = nul_7bit_asc; char2(2) = substr (rec_msg, rec_length, 1); rec_pkt_chksum = char2_ptr -> fb15_based - 32; call log_info (packet_log, 'Checksum error : wanted ' || trim (char (chksum), '11'b) || ', but got ' || trim (char (rec_pkt_chksum), '11'b) || '.'); return (false); end; end; return (true); end; /* Check_checksum */ end; /* Rec_packet */ ------------------------------------------------------------------------------- /* REC_SWITCH -- Handle Kermit file receive protocol. */ Rec_switch : proc; $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp $Insert syscom>errd.ins.pl1 Dcl (temp, i, fs_attr_type, rep_count, eof_rec_seq) fixed bin, new_path char (128) var, chr char (1), (single_file_rec, test_flag, discard) bit (1) aligned; /* ************************************************************************* */ do_flush = true; discard = false; num_retries = 0; /* Initialize the number of retries. */ eof_rec_seq = -1; single_file_rec = (length (path_name) ^= 0); if packet_log_opened then do; if single_file_rec then errmsg = space_8bit_asc || path_name; else errmsg = ''; call log_info (packet_log, ''); call log_info (packet_log, kversion || ' receiving' || errmsg || '.'); end; do while (true); select (state); when (state_r) state = rec_init (); when (state_rf) state = rec_file (); when (state_ra) state = rec_attrib (); when (state_rdw) state = rec_windowing (); when (state_c) do; call sleep$ (3000); return; end; otherwise /* This includes state_a. */ do; do_flush = true; call discard_output (i); if i ^= 0 then do; call get_error_msg (i); snd_msg = 'Error trying to discard the output file. ' || errmsg; call send_packet (msg_error, length (snd_msg), msg_number); end; call sleep$ (3000); return; end; end; /* select */ end; /* do while ... */ /* ******************************** Rec_init ******************************* */ Rec_init : proc returns (fixed bin); /* ************************************************************************* */ msg_number = 0; /* Initialize sequence numbering. */ if ^rec_message () then /* Get a packet. */ return (state_a); if rec_pkt_type = msg_snd_init then do; call ack_send_init; num_retries = 0; msg_number = mod (msg_number + 1, 64); return (state_rf); /* Ready to receive file info. */ end; else do; call send_packet (msg_nak, 0, rec_seq); return (state_a); end; end; /* Rec_init */ /* ******************************* Rec_file ******************************** */ Rec_file : proc returns (fixed bin); /* ************************************************************************* */ if ^rec_message () then /* Get a packet. */ return (state_a); discard = false; /* Initialise these just in case. */ eof_rec_seq = -1; do i = 0 to 63; msg_table.slot(i).acked = false; msg_table.slot(i).retries = 0; end; select (rec_pkt_type); when (msg_file) do; if rec_seq ^= msg_number then do; snd_msg = 'Protocol error detected.'; call send_packet (msg_error, length (snd_msg), msg_number); return (state_a); end; if length (path_name) = 0 then /* Get pathname from the packet. */ do; if single_file_rec then do; snd_msg = 'Error : only ONE file upload allowed.'; call send_packet (msg_error, length (snd_msg), msg_number); return (state_a); end; path_name = substr (rec_msg, pkt_msg, length (rec_msg) - pkt_msg); path_name = trim (set8str (path_name), '11'b); /* The pathname may have repeat character processing in it, so we must handle this. 8-bit quoting and control quoting are not allowed in path names, and so will be caught later on. */ if do_repeats then if index (path_name, loc_rep_chr) ^= 0 then do; new_path = ''; do i = 1 to length (path_name); chr = substr (path_name, i, 1); if chr = loc_rep_chr then do; i = i + 1; rep_count = knum (substr (path_name, i, 1)); i = i + 1; chr = substr (path_name, i, 1); end; else rep_count = 1; do temp = 1 to rep_count; new_path = new_path || chr; end; end; path_name = new_path; end; call set_path (path_name); end; i = open_output (); /* Open the file for writing. */ select (i); when (0) snd_msg = ''; when (e$exst) do; /* Acknowldege with our new file name. */ snd_msg = file_name; call log_info (packet_log, 'File already exists. New file name is ' || file_name || '.'); end; when (e$bnam) do; snd_msg = file_name; call log_info (packet_log, 'The file name is illegal, ' || file_name || ' will be used instead.'); end; when (e$ialn) do; snd_msg = 'File already exists. Unable to generate a new file name!'; call send_packet (msg_error, length (snd_msg), msg_number); return (state_a); end; otherwise do; call get_error_msg (i); snd_msg = 'Error opening file on remote system. ' || errmsg; call send_packet (msg_error, length (snd_msg), msg_number); return (state_a); end; end; if explicit_ft_set then do; rec_file_type = file_type; if packet_log_opened then do; errmsg = 'The receiving file type has been explicitly set to '; select (file_type); when (ascii_ft) errmsg = errmsg || 'ASCII.'; when (binary_ft) errmsg = errmsg || 'BINARY.'; when (automatic_ft) /* ? - This can't be! */ errmsg = errmsg || 'AUTOMATIC.'; otherwise /* And what's this ? */ errmsg = errmsg || 'ILLEGAL.'; end; call log_info (packet_log, (errmsg)); end; end; else do; rec_file_type = automatic_ft; file_type = ascii_ft; /* Assume this to start with. */ if packet_log_opened then do; call log_info (packet_log, 'The receiving file type will be automatically detected.'); call log_info (packet_log, 'But ASCII file type will initially be assumed.'); end; end; /* Acknowledge the file header packet. */ num_retries = 0; do_flush = false; msg_number = mod (msg_number + 1, 64); call send_packet (msg_ack, length (snd_msg), rec_seq); if loc_file_attrib then /* Get the file attributes if we can. */ return (state_ra); else do; tab_first = msg_number; return (state_rdw); end; end; when (msg_eof, msg_snd_init) if rec_seq = mod (msg_number - 1, 64) then do; if bump_retry () then if rec_pkt_type = msg_eof then call send_packet (msg_ack, 0, rec_seq); else call ack_send_init; return (state); end; else do; snd_msg = 'Protocol error detected.'; call send_packet (msg_error, length (snd_msg), msg_number); return (state_a); end; when (msg_break) do; call send_packet (msg_ack, 0, rec_seq); return (state_c); end; when (msg_error) return (state_a); otherwise do; snd_msg = 'Unexpected packet type "' || rec_pkt_type || '" received on remote system.'; call send_packet (msg_error, length (snd_msg), msg_number); return (state_a); end; end; /* Select */ end; /* Rec_file */ /* ****************************** Rec_attrib ******************************* */ Rec_attrib : proc returns (fixed bin); Dcl avail_disk_space fixed bin (31), code fixed bin, 1 quota_info, 2 (record_size, dir_used, max_quota, quota_used) fixed bin (31), 2 (duff1, duff2, duff3, duff4) fixed bin (31), inf_array (8) fixed bin (31) based; /* ************************************************************************* */ if ^rec_message () then /* Get a packet. */ return (state_a); select (rec_pkt_type); when (msg_attrib) do; call q$read (dir_name, addr (quota_info) -> inf_array, 4, temp, code); if code ^= 0 | temp = 1 then avail_disk_space = -1; else do; avail_disk_space = quota_info.max_quota - quota_info.quota_used; if quota_info.record_size ^= 1024 then avail_disk_space = divide ((avail_disk_space * quota_info.record_size) + 1023, 1024, 31); end; call decode_attrs; if avail_disk_space = -1 | rec_file_size <= 0 | rec_file_size <= avail_disk_space then snd_msg = 'Y'; else /* ONLY reject the file if we run out of room. */ do; call discard_output (temp); if fs_attr_type = 0 then snd_msg = 'N!'; else snd_msg = 'N1'; end; if rec_file_dtc = 0 then snd_msg = snd_msg || '#'; if file_type = illegal_ft then do; rec_file_type = automatic_ft; file_type = ascii_ft; /* Reset this, but let the */ snd_msg = snd_msg || '"'; /* other side know. */ end; num_retries = 0; msg_number = mod (msg_number + 1, 64); call send_packet (msg_ack, length (snd_msg), rec_seq); if substr (snd_msg, 1, 1) = 'N' then call log_info (packet_log, 'Unable to receive the file ' || file_name || '. File too big.'); return (state); end; when (msg_data) do; if rec_seq ^= msg_number then /* Out of sequence messages. */ if rec_seq = mod (msg_number - 1, 64) then do; if bump_retry () then call send_packet (msg_ack, 0, rec_seq); return (state); end; else do; snd_msg = 'Protocol error detected.'; call send_packet (msg_error, length (snd_msg), msg_number); return (state_a); end; temp = write_output (); if temp ^= 0 then do; call get_error_msg (temp); snd_msg = 'Unable to write to output file. ' || errmsg; call send_packet (msg_error, length (snd_msg), msg_number); return (state_a); end; num_retries = 0; msg_number = mod (msg_number + 1, 64); call send_packet (msg_ack, 0, rec_seq); tab_first = msg_number; return (state_rdw); end; when (msg_file) if rec_seq = mod (msg_number - 1, 64) then do; if bump_retry () then call send_packet (msg_ack, 0, rec_seq); return (state); end; else do; snd_msg = 'Protocol error detected.'; call send_packet (msg_error, length (snd_msg), msg_number); return (state_a); end; when (msg_eof) if rec_seq = msg_number then do; i = close_output (); call set_path (''); /* Knock out the file_name for later. */ if i ^= 0 then do; call get_error_msg (i); snd_msg = 'Unable to close output file on remote system. ' || errmsg; call send_packet (msg_error, length (snd_msg), msg_number); return (state_a); end; num_retries = 0; msg_number = mod (msg_number + 1, 64); call send_packet (msg_ack, 0, rec_seq); return (state_rf); end; else do; snd_msg = 'Protocol error detected.'; call send_packet (msg_error, length (snd_msg), msg_number); return (state_a); end; when (msg_error) return (state_a); otherwise do; snd_msg = 'Unexpected packet type "' || rec_pkt_type || '" received on remote system.'; call send_packet (msg_error, length (snd_msg), msg_number); return (state_a); end; end; /* select */ end; /* Rec_attrib */ /* ***************************** Rec_windowing ***************************** */ Rec_windowing : proc returns (fixed bin); /* ************************************************************************* */ call rec_packet; /* Get input. */ select (rec_pkt_type); when (msg_data) do; call update_table; if tab_first = eof_rec_seq then do; rec_seq = eof_rec_seq; goto eof; end; else return (state); end; when (msg_eof) do; eof_rec_seq = rec_seq; if length (rec_msg) > pkt_msg then rec_msg = substr (rec_msg, pkt_msg, 1); else rec_msg = ''; discard = (rec_msg = 'D'); if discard then call discard_output (i); else do; if tab_first ^= eof_rec_seq then do; call nak_all; return (state); end; Eof : i = close_output (); end; do_flush = true; /* Okay, we can do this now, */ call set_path (''); /* and do this for later. */ if i ^= 0 then do; call get_error_msg (i); if discard then snd_msg = 'Unable to discard the output file on remote system. ' || errmsg; else snd_msg = 'Unable to close output file on remote system. ' || errmsg; call send_packet (msg_error, length (snd_msg), msg_number); return (state_a); end; num_retries = 0; msg_number = mod (rec_seq + 1, 64); call send_packet (msg_ack, 0, rec_seq); return (state_rf); end; when (msg_error) return (state_a); when (msg_timeout) do; if bump_retry () then do; num_retries = num_retries - 1; /* Don't increase this. */ call log_info (packet_log, 'Timeout : NAK for most desired packet.'); call nak_oldest (true); end; return (state); end; when (msg_check_err) do; if bump_retry () then do; num_retries = num_retries - 1; /* Don't increase this. */ call log_info (packet_log, 'Checksum error : NAK for oldest unACKed packet.'); call nak_oldest (false); end; return (state); end; otherwise do; snd_msg = 'Unexpected packet type "' || rec_pkt_type || '" received on remote system.'; call send_packet (msg_error, length (snd_msg), msg_number); return (state_a); end; end; /* Select */ end; /* Rec_windowing */ /* ****************************** Rec_message ****************************** */ Rec_message : proc returns (bit (1) aligned); /* ************************************************************************* */ test_flag = false; do until (test_flag); call rec_packet; if rec_pkt_type = msg_timeout | rec_pkt_type = msg_check_err then if bump_retry () then call send_packet (msg_nak, 0, msg_number); else return (false); else test_flag = true; end; return (true); end; /* Rec_message */ /* ***************************** Update_table ****************************** */ Update_table : proc; /* ************************************************************************* */ if ^between (rec_seq, tab_first, mod (tab_first + window_size - 1, 64)) then do; if between (rec_seq, mod (tab_first - window_size, 64), mod (tab_first - 1, 64)) then call send_packet (msg_ack, 0, rec_seq); return; end; /* Add the new data packet to the table. */ if rec_seq ^= eof_rec_seq then /* Don't mark the EOF packet as ACKed. */ do; msg_table.slot(rec_seq).msg = rec_msg; msg_table.slot(rec_seq).acked = true; end; if msg_table.slot(tab_first).acked then do; i = tab_first; do until (^msg_table.slot(i).acked); rec_msg = msg_table.slot(i).msg; temp = write_output (); if temp ^= 0 then do; call get_error_msg (temp); snd_msg = 'Unable to write to output file. ' || errmsg; call send_packet (msg_error, length (snd_msg), msg_number); state = state_a; return; end; else msg_table.slot(i).acked = false; i = mod (i + 1, 64); end; tab_first = i; end; num_retries = 0; msg_number = mod (rec_seq + 1, 64); call send_packet (msg_ack, 0, rec_seq); /* Acknowledge the packet. */ return; end; /* Update_table */ /* ****************************** Nak_oldest ******************************* */ Nak_oldest : proc (desire); Dcl desire bit (1) aligned; /* ************************************************************************* */ i = tab_first; temp = mod (tab_first + window_size, 64); do until (i = temp); if ^msg_table.slot(i).acked then do; call send_packet (msg_nak, 0, i); return; end; i = mod (i + 1, 64); end; /* No packets to NAK, so NAK for next in hope of unblocking sender if a NAK for the most desired packet is required. */ if desire then call send_packet (msg_nak, 0, temp); return; end; /* Nak_oldest */ /* ******************************* Nak_all ********************************* */ Nak_all : proc; /* ************************************************************************* */ i = tab_first; do until (i = eof_rec_seq); if ^msg_table.slot(i).acked then call send_packet (msg_nak, 0, i); i = mod (i + 1, 64); end; return; end; /* Nak_all */ /* ******************************* Bump_retry ****************************** */ Bump_retry : proc returns (bit (1) aligned); /* ************************************************************************* */ if num_retries > max_retries then do; snd_msg = 'Retry limit exceeded on remote system.'; call send_packet (msg_error, length (snd_msg), msg_number); state = state_a; return (false); end; num_retries = num_retries + 1; return (true); end; /* Bump_retry */ /* ****************************** Decode_attrs ***************************** */ Decode_attrs : proc; Dcl (str, data) char (max_msg) var, attr char (1), (len, found, code) fixed bin; /* ************************************************************************* */ rec_file_size = -1; /* -1 = Unknown, 0 = Illegal, > 0 = Legal value. */ rec_file_dtc = -1; found = 0; str = substr (rec_msg, pkt_msg, length (rec_msg) - pkt_msg); str = set8str (str); do while (length (str) > 0 & found < 5); attr = substr (str, 1, 1); len = knum (substr (str, 2, 1)); data = substr (str, 3, len); str = substr (str, len + 3); select (attr); when ('!') /* File size in Kbytes. */ do; fs_attr_type = 0; rec_file_size = bin (trim (data, '11'b), 31); end; when ('1') /* File size in bytes. */ do; fs_attr_type = 1; rec_file_size = bin (trim (data, '11'b), 31); rec_file_size = divide (rec_file_size + 1023, 1024, 31); end; when ('#') /* Date/Time file created (DTC). */ do; if substr (data, 1, 2) = '19' then data = substr (data, 3); /* Knock off the century. */ data = substr (data, 1, 2) || '-' || substr (data, 3, 2) || '-' || substr (data, 5, 2) || '.' || after (data, space_8bit_asc); call cv$dtb (data, rec_file_dtc, code); if code ^= 0 then rec_file_dtc = 0; end; when ('.') /* Machine and OS. */ if ^explicit_pound_set & (data = 'U8' | substr (data, 1, 1) = 'K') then pound_conversion = true; /* U8 = MS-DOS, K = Atari. */ when ('"') /* Indication of file type. */ if ^explicit_ft_set then /* Might as well use this if we can. */ do; select (substr (data, 1, 1)); when ('A') do; rec_file_type = ascii_ft; /* ASCII file. */ call log_info (packet_log, 'The received file type attribute is ASCII, this file type will be used.'); end; when ('B') do; rec_file_type = binary_ft; /* BINARY file. */ call log_info (packet_log, 'The received file type attribute is BINARY, this file type will be used.'); end; when ('I') do; rec_file_type = binary_ft; /* IMAGE file (BINARY). */ call log_info (packet_log, 'The received file type attribute is IMAGE, but BINARY file type will be used.' ); end; otherwise do; rec_file_type = illegal_ft; /* ILLEGAL file type. */ call log_info (packet_log, 'The received file type attribute is ILLEGAL.'); call log_info (packet_log, 'The file type will be ' || 'automatically detected, but ASCII will initially be used.'); end; end; file_type = rec_file_type; end; otherwise found = found - 1; /* Didn't find one we wanted. */ end; found = found + 1; /* Assume that we did find one. */ end; return; end; /* Decode_attrs */ end; /* Rec_switch */ ------------------------------------------------------------------------------- /* REN_HNDLR -- On_unit for returning after a PUSH. */ Ren_hndlr : proc (dummy); Dcl dummy ptr; $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp /* ************************************************************************* */ /* We first of all get our users environment variables again, just in case he/she changed them when they were at Primos command level. "ren_lbl" is a label variable which is set to a local label in COMND. This enables us to create the on-unit once at startup yet have it return to a sub-procedure when the condition arises. */ call get_user_info; goto ren_lbl; end; /* Ren_hndlr */ ------------------------------------------------------------------------------- /* SEND_AMLC -- Send characters along an asynchronous line. */ Send_amlc : proc (line, buffer, bufferlen) returns (fixed bin); Dcl (line, bufferlen) fixed bin, buffer char (256); $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp Dcl code fixed bin, statv (2) fixed bin, tempbuff char (256) var; /* ************************************************************************* */ if ^do_transparent then do; tempbuff = set8str (substr (buffer, 1, bufferlen)); substr (buffer, 1, bufferlen) = substr (tempbuff, 1, bufferlen); end; call t$amlc (line, addr (buffer), bufferlen, 3, statv, 1, code); return (code); end; /* Send_amlc */ ------------------------------------------------------------------------------- /* SEND_PACKET -- Send Kermit packet to user. */ Send_packet : proc (type, pkt_len, seq_num); Dcl type char (1), /* Type of packet to send. */ pkt_len fixed bin, /* Length of packet to send. */ seq_num fixed bin; /* Sequence number of packet. */ $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp $Insert syscom>keys.ins.pl1 Dcl msg char (max_msg) var, (temp, msg_length, chksum, code) fixed bin, statv (2) fixed bin; /* ************************************************************************* */ if rem_npad > 0 then /* Do any packet filling required. */ if use_amlc_line then do; code = send_amlc (amlc_line, rem_padchar, rem_npad); if code ^= 0 then call tnou ('Unable to send padding characters.', 34); end; else call tnoua (rem_pad_chars, rem_npad); /* Store the header information into the message. */ char2_ptr -> fb15_based = pkt_len + pkt_ovr_head + 32; msg = ctrl_a_8bit_asc || char2(2); char2_ptr -> fb15_based = seq_num + 32; msg = msg || char2(2) || type; if pkt_len > 0 then msg = msg || snd_msg; msg_length = length (msg); if do_transparent then /* If transparent, then clear all the high bits. */ do; if type = msg_data then temp = pkt_type; else temp = msg_length; substr (msg, 1, temp) = clr8str (substr (msg, 1, temp)); end; temp = 0; /* Do the initial checksum calculation. */ if do_8bit_chks then temp = 1; chksum = chks (temp, msg); char2_ptr -> fb15_based = chksum + 32; msg = msg || char2(2) || rem_eol; msg_length = msg_length + 2; if do_flush then /* Flush the input buffer. */ if use_amlc_line then do; call t$amlc (amlc_line, addr (temp), 0, 8, statv, 1, code); if code ^= 0 then call tnou ('Unable to flush asynchronous input buffer.', 42); end; else call tty$rs (k$inb, temp); if use_amlc_line then do; code = send_amlc (amlc_line, (msg), msg_length); if code ^= 0 then call tnou ('Unable to send asynchronous data.', 33); end; else call tnoua ((msg), msg_length); /* Now send the message. */ if packet_log_opened then /* Log the packet if necessary. */ do; if pkt_len > 0 then msg = snd_msg; else msg = ''; call log_packet (type, seq_num, msg); end; return; end; /* Send_packet */ ------------------------------------------------------------------------------- /* SEND_SWITCH -- Handles Kermit file send protocol. */ Send_switch : proc; $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp Dcl (stop_xfer, stop_trans, test_flag) bit (1) aligned, (code, temp) fixed bin; /* ************************************************************************* */ num_retries = 0; /* Initialize number of retries. */ msg_number = 0; /* Initial message number. */ do_flush = true; test_flag = false; if packet_log_opened then do; call log_info (packet_log, ''); call log_info (packet_log, kversion || ' sending ' || path_name ||'.'); end; if delay ^= 0 then /* Sleep if we need to. */ call sleep$ (1000 * delay); do until (test_flag); select (state); when (state_s, state_x) state = send_init (); when (state_sf, state_xf) state = send_file (); when (state_sa) state = send_attrib (); when (state_sdw) state = send_windowing (); when (state_sz) state = send_eof (); when (state_sb) state = send_break (); when (state_c) test_flag = true; otherwise /* Includes state_a. */ do; do_flush = true; test_flag = true; if file_opened then call close_input; end; end; /* select */ end; /* loop */ return; /* ****************************** Send_init ******************************** */ Send_init : proc returns (fixed bin); Dcl eol_bin fixed bin, eol char (1); /* ************************************************************************* */ /* Setup our send_init parameters, and set the printable bit. */ char2(1) = nul_7bit_asc; char2(2) = loc_eol; char2_ptr -> fb15_based = char2_ptr -> fb15_based + 32; eol = char2(2); eol_bin = loc_pkt_size + 32; temp = loc_timeout + 32; snd_msg = substr (addr (eol_bin) -> char2_based, 2, 1) || substr (addr (temp) -> char2_based, 2, 1); eol_bin = loc_npad + 32; temp = loc_capas1 + 32; snd_msg = snd_msg || substr (addr (eol_bin) -> char2_based, 2, 1) || ctl (loc_padchar) || eol || loc_quote_chr || loc_8quote_chr || loc_chk_type || loc_rep_chr || substr (addr (temp) -> char2_based, 2, 1); temp = loc_max_wsize + 32; snd_msg = snd_msg || substr (addr (temp) -> char2_based, 2, 1); loc_file_attrib = addr (loc_capas1) -> capas.file_attributes; /* Now send the packet. */ call send_packet (msg_snd_init, length (snd_msg), msg_number); if ^get_response () then /* Get a response from the remote side. */ return (state); call prs_send_init; /* Process ACK response. */ call set_params; if state = state_x then /* Text transfer : the file is already open. */ return (state_xf); temp = match_file (); if temp ^= 0 then do; call get_error_msg (temp); snd_msg = 'Unable to match files on remote system. ' || errmsg; call send_packet (msg_error, length (snd_msg), msg_number); return (state_a); end; if num_matches = 0 then /* Check for no matching files. */ do; snd_msg = 'No matching files on remote system.'; call send_packet (msg_error, length (snd_msg), msg_number); return (state_a); end; file_idx = 1; /* Send the first file. */ return (state_sf); end; /* Send_init */ /* ******************************* Send_file ******************************* */ Send_file : proc returns (fixed bin); Dcl test_flag bit (1) aligned, rec_file_name char (32) var; /* ************************************************************************* */ stop_xfer = false; /* Initialize the file interrupt flags. */ stop_trans = false; test_flag = true; saved_msg = ''; /* Initialize any saved packet characters. */ saved_char = ''; do temp = 0 to 63; msg_table.slot(temp).acked = false; msg_table.slot(temp).retries = 0; end; if state = state_sf then /* File transfer : send the file name. */ if next_file () ^= ker_normal then return (state_sb); else snd_msg = clr8str (file_name); do while (test_flag); if state = state_sf then call send_packet (msg_file, length (file_name), msg_number); else call send_packet (msg_text, 0, msg_number); if ^get_response () then /* Get a response from the remote side. */ if state = state_a then return (state_a); else ; else test_flag = false; end; if packet_log_opened then /* See if our file name was acceptable. */ if length (trim (rec_msg, '11'b)) > pkt_msg then do; rec_file_name = trim (set8str (substr (rec_msg, pkt_msg, length (rec_msg) - pkt_msg)), '11'b); if rec_file_name ^= file_name then call log_info (packet_log, 'The file will be received as ' || rec_file_name || '.'); end; call setup_trans_char; /* Setup the character translation table. */ tab_first = msg_number; /* Initialise these just in case. */ tab_next = msg_number; do_flush = false; /* If this is a file transfer, and attributes are expected, send them. */ if (state = state_sf) & rem_file_attrib then return (state_sa); return (state_sdw); end; /* Send_file */ /* ****************************** Send_attrib ****************************** */ Send_attrib : proc returns (fixed bin); Dcl test_flag bit (1) aligned; /* ************************************************************************* */ test_flag = true; call get_attr; /* Form the attribute packet. */ do while (test_flag); /* Send the data packet. */ call send_packet (msg_attrib, length (snd_msg), msg_number); if ^get_response () then /* Get a response from the remote side. */ if state = state_a then return (state_a); else ; else test_flag = false; end; if length (rec_msg) > pkt_msg then rec_msg = substr (rec_msg, pkt_msg, 1); else rec_msg = ''; if rec_msg = 'N' then /* We cannot send this file for some reason. */ do; stop_xfer = true; return (state_sz); end; tab_first = msg_number; /* Initialise these just in case. */ tab_next = msg_number; return (state_sdw); /* Send the first data packet. */ end; /* Send_attrib */ /* ***************************** Send_windowing **************************** */ Send_windowing : proc returns (fixed bin); Dcl status fixed bin; /* ************************************************************************* */ status = read_input (code); /* Get the next buffer of data. */ select (status); when (ker_normal) ; when (ker_eof) if ^prs_input (true) then return (state_a); else return (state_sz); otherwise do; call get_error_msg (code); snd_msg = 'Error reading file on remote system. ' || errmsg; call send_packet (msg_error, length (snd_msg), msg_number); return (state_a); end; end; msg_table.slot(msg_number).msg = snd_msg; /* Update the table. */ msg_table.slot(msg_number).acked = false; msg_table.slot(msg_number).retries = 0; /* Now we can send the packet. */ call send_packet (msg_data, length (snd_msg), msg_number); msg_number = mod (msg_number + 1, 64); /* Increment the message number. */ tab_next = msg_number; if ^prs_input (false) then /* Get a response from the remote side. */ return (state_a); if stop_xfer | stop_trans then /* Check for file transfer interruption. */ return (state_sz); return (state_sdw); end; /* Send_windowing */ /* ******************************* Send_eof ******************************** */ Send_eof : proc returns (fixed bin); /* ************************************************************************* */ do_flush = true; /* Start flushing input before each output. */ call close_input; if stop_xfer | stop_trans then /* Check for file transfer interruption. */ do; call log_info (packet_log, 'File transfer interrupted.'); snd_msg = 'D'; /* Discard indication. */ call sleep$ (5000); /* Wait 5 secs to allow receiver to flush input. */ call send_packet (msg_eof, length (snd_msg), msg_number); end; else /* A normal EOF : send end-of-file indicator packet. */ call send_packet (msg_eof, 0, msg_number); if ^get_response () then /* Get a response from the remote side. */ return (state); if stop_trans then return (state_sb); return (state_sf); end; /* Send_eof */ /* ******************************* Send_break ****************************** */ Send_break : proc returns (fixed bin); /* ************************************************************************* */ /* First send end-of-file-set indicator packet. */ call send_packet (msg_break, 0, msg_number); if ^get_response () then /* Get a response from the remote side. */ return (state); return (state_c); end; /* Send_break */ /* ******************************* Prs_input ******************************* */ Prs_input : proc (eof) returns (bit (1) aligned); Dcl eof bit (1) aligned; Dcl i fixed bin; /* ************************************************************************* */ Get_pkt : if eof then /* Wait for a packet until all are acknowledged. */ if tab_first = tab_next then return (true); else goto rec_pkt; /* If the window is not blocked, make sure there is input. */ if tab_next ^= mod (tab_first + window_size, 64) then if ^tty$in () then return (true); else goto rec_pkt; /* Window is blocked : Check for special case. */ if msg_table.slot(tab_first).retries = 0 then do; i = mod (tab_first + 1, 64); /* If some later packet has been received then resend earliest one. */ do while (i ^= mod (tab_first + window_size, 64)); if msg_table.slot(i).acked then do; i = tab_first; call log_info (packet_log, 'Resend - window blocked.'); goto resend; end; i = mod (i + 1, 64); end; end; Rec_pkt : /* Receive a packet from the remote side. */ call rec_packet; select (rec_pkt_type); /* Check the packet type. */ when (msg_timeout) do; i = tab_first; /* Resend oldest unacked packet. */ do while (msg_table.slot(i).acked); i = mod (i + 1, 64); if i = tab_next then return (true); end; call log_info (packet_log, 'Resend - timeout.'); end; when (msg_check_err) do; call log_info (packet_log, 'Checksum error - ignore packet.'); goto get_pkt; end; when (msg_ack) do; /* Check for ACK/Interrupt packets. */ if length (rec_msg) > pkt_msg then rec_msg = set8 (substr (rec_msg, pkt_msg, 1)); else rec_msg = ''; stop_xfer = (rec_msg = 'X'); stop_trans = (rec_msg = 'Z'); if stop_xfer | stop_trans then return (true); /* If the ACK is within bounds, process it. */ if between (rec_seq, tab_first, mod (tab_next - 1, 64)) then do; msg_table.slot(rec_seq).acked = true; i = tab_first; do while (msg_table.slot(i).acked); i = mod (i + 1, 64); if i = tab_next then leave; end; tab_first = i; end; goto get_pkt; end; when (msg_nak) /* If the NAK is within window, resend requested packet, otherwise resend earliest, hoping for an ACK. */ if between (rec_seq, tab_first, mod (tab_next - 1, 64)) then do; call log_info (packet_log, 'NAK - resend packet.'); i = rec_seq; end; else do; call log_info (packet_log, 'NAK - resend earliest packet.'); i = tab_first; end; when (msg_error) do; /* Error type. */ state = state_a; return (false); end; otherwise do; snd_msg = 'Unexpected packet type "' || rec_pkt_type || '" received on remote system.'; call send_packet (msg_error, length (snd_msg), msg_number); state = state_a; return (false); end; end; /* Select */ Resend : /* Resend the packet. */ msg_table.slot(i).acked = false; if msg_table.slot(i).retries > max_retries then do; snd_msg = 'Retry limit exceeded on remote system.'; call send_packet (msg_error, length (snd_msg), msg_number); return (false); end; snd_msg = msg_table.slot(i).msg; msg_table.slot(i).retries = msg_table.slot(i).retries + 1; call send_packet (msg_data, length (snd_msg), i); goto get_pkt; end; /* Prs_input */ end; /* Send_switch */ ------------------------------------------------------------------------------- /* SERVER -- Kermit server process. */ Server : proc; $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>constants.ins.plp Dcl (rep_count, temp, i) fixed bin, new_path char (128) var, chr char (1); /* ************************************************************************* */ num_retries = 0; /* Initialize retry count. */ do while (true); /* Main server loop. */ msg_number = 0; /* Reinitialize sequence numbering. */ call rec_packet; /* Get input from line. */ select (rec_pkt_type); /* Process message type. */ when (msg_init_info) call ack_send_init; when (msg_snd_init) do; call ack_send_init; msg_number = mod (msg_number + 1, 64); state = state_rf; call set_path (''); call rec_switch; end; when (msg_rcv_init) do; if rec_length > pkt_msg then do; path_name = set8str (substr (rec_msg, pkt_msg, length (rec_msg) - pkt_msg)); path_name = trim (path_name, '11'b); /* The pathname may have repeat character processing in it, so we must handle this. 8-bit quoting and control quoting are not allowed in path names, and so will be caught later on. */ if do_repeats then if index (path_name, loc_rep_chr) ^= 0 then do; new_path = ''; do i = 1 to length (path_name); chr = substr (path_name, i, 1); if chr = loc_rep_chr then do; i = i + 1; rep_count = knum (substr (path_name, i, 1)); i = i + 1; chr = substr (path_name, i, 1); end; else rep_count = 1; do temp = 1 to rep_count; new_path = new_path || chr; end; end; path_name = new_path; end; call set_path (path_name); end; i = delay; /* Save this old value for later. */ delay = 0; /* No delay time for the server. */ state = state_s; call send_switch; delay = i; /* Now restore the old delay time. */ end; when (msg_kermit_generic) /* Generic kermit commands. */ if generic_cmd () = ker_exit then return; when (msg_timeout) /* Ignore timeouts. */ ; otherwise /* Capture all other commands. */ do; snd_msg = 'Unimplemented server command.'; call send_packet (msg_error, length (snd_msg), msg_number); end; end; /* select */ end; /* do while */ return; end; /* Server */ ------------------------------------------------------------------------------- /* SETUP_TRANS_CHAR -- Builds the character translation table. */ /* This routine sets up the trans_char character translation table for either ASCII or binary files. The table is used to translate each character of file data to a representation suitable for transmission. The QUOTE8_CHAR determines whether the data receives 8-bit quoting in addition to control character quoting. */ Setup_trans_char : proc; $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp Dcl (c, sq_bin, s8q_bin, rep_bin) fixed bin, c_ptr ptr, conv_chrs char (3) var, (sq, chr, quote8_chr_7bit) char (1); /* ************************************************************************* */ c_ptr = addr (c); char2(1) = nul_7bit_asc; sq = clr8 (loc_quote_chr); /* Control quote character. */ char2(2) = sq; sq_bin = char2_ptr -> fb15_based; quote8_chr_7bit = clr8 (quote8_char); /* 8-bit quote character. */ char2(2) = quote8_chr_7bit; s8q_bin = char2_ptr -> fb15_based; char2(2) = clr8 (loc_rep_chr); /* Repeat character prefix. */ rep_bin = char2_ptr -> fb15_based; do c = 0 to 255; chr = substr (c_ptr -> char2_based, 2, 1); if (c < 32) | ((c >= 127) & (c < 160)) | (c = 255) then conv_chrs = sq || ctl (chr); else if (c = sq_bin) | (c = sq_bin + 128) then /* Control prefix. */ conv_chrs = sq || chr; else if (quote8_char ^= 'N') & ((c = s8q_bin) | (c = s8q_bin + 128)) then conv_chrs = sq || chr; /* 8-bit quote prefix. */ else if do_repeats & ((c = rep_bin) | (c = rep_bin + 128)) then conv_chrs = sq || chr; /* Repeat character prefix. */ else conv_chrs = chr; /* Normal character. */ if (quote8_char ^= 'N') & (c >= 128) then /* Apply 8-bit quoting. */ trans_char(c) = quote8_chr_7bit || trans_char(c - 128); else trans_char(c) = conv_chrs; end; if pound_conversion then trans_char(28) = trans_char(156); /* Pound sign conversion for DOS. */ return; end; /* Setup_trans_char */ ------------------------------------------------------------------------------- /* SET_PARAMS -- determine the file transfer parameters. */ Set_params : proc; $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>constants.ins.plp Dcl rem_8q char (1); /* ************************************************************************* */ rem_8q = set8 (rem_8quote_chr); /* Set the top bit for local processing. */ quote8_char = 'N'; /* Assume no 8-bit quoting at first. */ if loc_8quote_chr = 'Y' then if quote8_ok (rem_8q) then /* Check on the remote side. */ quote8_char = rem_8quote_chr; else ; else if quote8_ok (loc_8quote_chr) then /* See if the remote side agrees. */ if rem_8q = 'Y' | rem_8q = loc_8quote_chr then quote8_char = loc_8quote_chr; do_repeats = (loc_rep_chr = set8 (rem_rep_chr)) & (loc_rep_chr ^= space_8bit_asc); /* Determine the window size to use. */ if loc_max_wsize <= rem_max_wsize then window_size = loc_max_wsize; else window_size = rem_max_wsize; return; /* ******************************* Quote8_ok ******************************* */ Quote8_ok : proc (c) returns (bit (1) aligned); Dcl c char (1); Dcl n fixed bin; /* ************************************************************************* */ char2(1) = nul_7bit_asc; char2(2) = c; n = char2_ptr -> fb15_based; if n > 128 then n = n - 128; if ((n >= 33) & (n <= 62)) | ((n >= 96) & (n <= 126)) then return (true); else return (false); end; /* Quote8_ok */ end; /* Set_params */ ------------------------------------------------------------------------------- /* SET_PATH -- Set the pathname, directory name, and file name variables. */ Set_path : proc (treename); Dcl treename char (128) var; $Insert *>insert>common.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp $Insert syscom>keys.ins.pl1 Dcl (funit, new_dir_len, code) fixed bin, temp_path char (128) var, new_dir_name char (128); /* ************************************************************************* */ dir_name = ''; file_name = ''; non_null_dir = false; path_name = trim (treename, '11'b); if path_name = '*' then path_name = ''; if length (path_name) = 0 then return; temp_path = reverse (path_name); file_name = reverse (before (temp_path, '>')); dir_name = reverse (after (temp_path, '>')); if dir_name = '*' then dir_name = ''; if length (dir_name) > 0 then if substr (dir_name, 1, 1) = '<' & index (dir_name, '>') = 0 then dir_name = dir_name || '>MFD'; /* Correct for MFD level files. */ non_null_dir = (length (dir_name) ^= 0); if non_null_dir then /* We need to do this to get the partition name. */ do; call at$ (k$setc, dir_name, code); if code = 0 then do; call gpath$ (k$cura, funit, new_dir_name, 128, new_dir_len, code); if code = 0 then do; dir_name = substr (new_dir_name, 1, new_dir_len); path_name = dir_name || '>' || file_name; call finfo$ (current_attach_point, file_info_ptr, code); if code ^= 0 then file_info.ldevno = -1; end; end; call at$hom (code); end; return; end; /* Set_path */ ------------------------------------------------------------------------------- /* TIMEOUT_HNDLR -- On_unit for receive timeout (ALARM$ condition). */ Timeout_hndlr : proc (dummy); Dcl dummy ptr; $Insert *>insert>common.ins.plp /* ************************************************************************* */ /* "timeout" is a label variable which is set to a local label in REC_PACKET every time that routine is called. This enables us to create the on-unit once at startup yet have it return to a sub-procedure when the condition arises. */ goto timeout; end; /* Timeout_hndlr */ ------------------------------------------------------------------------------- /* UTILITIES -- These are a collection of frequently used subroutines. */ /* ********************************* Ctl *********************************** */ /* CTL -- Toggle character's "control" bit. */ Ctl : proc (char_str) returns (char (1)); Dcl char_str char (1); $Insert *>insert>common.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>constants.ins.plp Dcl bit8 bit (8) aligned, bit8_ptr ptr, fb fixed bin; Dcl 1 b8 based, 2 high_bit bit (1), 2 ctrl_bit bit (1), 2 b6 bit (6); /* ************************************************************************* */ bit8_ptr = addr (bit8); bit8_ptr -> char1_based = char_str; bit8_ptr -> b8.ctrl_bit = ^(bit8_ptr -> b8.ctrl_bit); return (bit8_ptr -> char1_based); /* ********************************* Knum ********************************** */ /* KNUM -- Kermit function to make character a number. */ Knum : entry (char_k) returns (fixed bin); Dcl char_k char (1); /* ************************************************************************* */ fb = 0; substr (addr (fb) -> char2_based, 2, 1) = char_k; if fb >= 128 then fb = fb - 128; fb = fb - 32; /* Turn off "printable" bit. */ return (fb); /* ********************************* Set8 ********************************** */ /* SET8 -- Set high bit on a character. */ Set8 : entry (ch1) returns (char (1)); Dcl ch1 char (1); /* ************************************************************************* */ bit8_ptr = addr (bit8); bit8_ptr -> char1_based = ch1; bit8_ptr -> b8.high_bit = '1'b; return (bit8_ptr -> char1_based); /* ********************************* Clr8 ********************************** */ /* CLR8 -- Clear high bit on a character. */ Clr8 : entry (ch1) returns (char (1)); /* ************************************************************************* */ bit8_ptr = addr (bit8); bit8_ptr -> char1_based = ch1; bit8_ptr -> b8.high_bit = '0'b; return (bit8_ptr -> char1_based); /* ******************************** Set8str ******************************** */ /* SET8STR -- Set high bit on all characters in a string. */ Set8str : entry (str1) returns (char (ibuffer_size) var); Dcl str1 char (ibuffer_size) var; Dcl str2 char (ibuffer_size) var, (str_ptr, str_ptr2) ptr, (i, j) fixed bin; /* ************************************************************************* */ str2 = ''; j = length (str1); str_ptr = addrel (addr (str1), 1); str_ptr2 = addr (str2); str_ptr2 -> fb15_based = j; /* Set the string length. */ str_ptr2 = addrel (str_ptr2, 1); do i = 1 to j by 2; /* Process the string 2 characters at a time. */ str_ptr2 -> bit16_based = str_ptr -> bit16_based | '8080'b4; str_ptr = addrel (str_ptr, 1); str_ptr2 = addrel (str_ptr2, 1); end; if mod (j, 2) ^= 0 then /* We mustn't forget the last odd character. */ str_ptr2 -> bit8_based = str_ptr -> bit8_based | '80'b4; return (str2); /* ******************************** Clr8str ******************************** */ /* CLR8STR -- Clear high bit on all characters in a string. */ Clr8str : entry (str1) returns (char (ibuffer_size) var); /* ************************************************************************* */ str2 = ''; j = length (str1); str_ptr = addrel (addr (str1), 1); str_ptr2 = addr (str2); str_ptr2 -> fb15_based = j; /* Set the string length. */ str_ptr2 = addrel (str_ptr2, 1); do i = 1 to j by 2; /* Process the string 2 characters at a time. */ str_ptr2 -> bit16_based = str_ptr -> bit16_based & '7F7F'b4; str_ptr = addrel (str_ptr, 1); str_ptr2 = addrel (str_ptr2, 1); end; if mod (j, 2) ^= 0 then /* We mustn't forget the last odd character. */ str_ptr2 -> bit8_based = str_ptr -> bit8_based & '7F'b4; return (str2); /* ******************************** Between ******************************** */ Between : entry (num, lo, hi) returns (bit (1) aligned); Dcl (num, lo, hi) fixed bin; /* ************************************************************************* */ if lo <= hi then return ((num >= lo) & (num <= hi)); else return ((num <= hi) | (num >= lo)); /* ******************************* Ctl_trans ******************************* */ /* CTL_TRANS -- Translate ^n to ctl ('n'), \n to CR, and \xxx to ASCII #xxx */ Ctl_trans : entry (str_okay, str) returns (char (128) var); Dcl str_okay bit (1) aligned, str char (128) var; Dcl (tempstr, retstr) char (128) var, (idx1, idx2) fixed bin, idx1_ptr ptr, ctrl_chars char (58); /* ************************************************************************* */ retstr = ''; tempstr = trim (str, '11'b); str_okay = true; idx1_ptr = addr (idx1); ctrl_chars = uppercase || lowercase || '@[\]^_'; do while (length (tempstr) ^= 0); idx1 = index (tempstr, '/'); idx2 = index (tempstr, '^'); if idx2 = 0 | (idx1 < idx2 & idx1 ^= 0) then idx2 = idx1; if idx2 = 0 then do; retstr = retstr || tempstr; tempstr = ''; end; else do; if idx2 > 1 then do; retstr = retstr || substr (tempstr, 1, idx2 - 1); tempstr = substr (tempstr, idx2, length (tempstr) - idx2+1); end; if substr (tempstr, 1, 1) = '/' then if length (tempstr) >= 2 & substr (tempstr, 2, 1) = 'n' then do; retstr = retstr || cr_8bit_asc; tempstr = after (tempstr, '/n'); end; else if length (tempstr) >= 2 & substr (tempstr, 2, 1) = '/' then do; retstr = retstr || '/'; tempstr = after (tempstr, '//'); end; else if length (tempstr) >= 4 & verify (substr (tempstr, 2, 3), '01234567') = 0 & bin (substr (tempstr, 2, 3), 15) <= 377 then do; idx1 = bin (substr (tempstr, 2, 1), 15) * 64 + bin (substr (tempstr, 3, 1), 15) * 8 + bin (substr (tempstr, 4, 1), 15); retstr = retstr || substr ( idx1_ptr -> char2_based, 2, 1); tempstr = after (tempstr, substr (tempstr, 1, 4)); end; else do; /* Illegal '/' usage. */ retstr = ''; tempstr = ''; str_okay = false; end; else /* A control character ? */ if length (tempstr) >= 2 & verify (substr (tempstr, 2, 1), ctrl_chars) = 0 then do; retstr = retstr || ctl (translate (substr (tempstr, 2, 1), uppercase, lowercase)); tempstr = after (tempstr, substr (tempstr, 2, 1)); end; else do; /* Illegal '^' usage. */ retstr = ''; tempstr = ''; str_okay = false; end; end; end; /* Do while */ return (retstr); /* ********************************* More ********************************** */ More : entry returns (bit (1) aligned); Dcl ans char (16) var, code fixed bin; /* ************************************************************************* */ ans = ''; call tnoua ('More ? ', 7); call cl$get (ans, 16, code); if code ^= 0 then return (false); if length (ans) = 0 then return (true); ans = translate (substr (trim (ans, '10'b), 1, 1), uppercase, lowercase); return (ans = 'Y'); end; /* Utilities */ ------------------------------------------------------------------------------- /* WRITE_IBUF -- Write intermediate buffer to disk file. */ Write_ibuf : proc (key, code); Dcl (key, code) fixed bin; $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp $Insert syscom>keys.ins.pl1 Dcl rnw fixed bin; /* ************************************************************************* */ code = 0; /* Initially we try to write the file out as an ASCII file, unless the file type has been set or any 8-bit characters are seen. */ if file_type ^= binary_ft then call write_text; /* If write_text decides it's actually a binary file, then it will change FILE_TYPE. */ if file_type = binary_ft then call write_binary; return; /* ***************************** Write_binary ****************************** */ Write_binary : proc; Dcl rwl_key (2) fixed bin, odd bit (1) aligned; /* ************************************************************************* */ /* This code adds an extra CTRL-Z to ibuffer if the file length is odd, this enables us to write out an even number of characters and not lose the last character. The file read/write lock is set to NONE to show this. The file length is decremented by 1 in OPEN_INPUT (downloading) if the rwlock is set to NONE (3). Note : this scheme for preserving the exact character length of the file will only work if the uploading process has OWNER (O) or PROTECT (P) access to the file. Otherwise the lock is not changed and the extra CTRL-Z will be downloaded. The error is not reported. */ odd = (mod (ibuf_ptr, 2) ^= 0); if key = 1 then /* If key indicates this is the end of the file ... */ if odd then do; ibuf_ptr = ibuf_ptr + 1; substr (ibuffer, ibuf_ptr, 1) = ctrl_z_7bit_asc; if non_null_dir then call at$ (k$setc, dir_name, code); rwl_key(1) = k$none; rwl_key(2) = 0; if code = 0 then call satr$$ (k$rwlk, (file_name), length (file_name), addr (rwl_key) -> fb31_based, code); if non_null_dir then call at$hom (code); end; call prwf$$ (k$writ, file_unit, ibuffer_ptr, divide (ibuf_ptr, 2, 15), 0, rnw, code); if odd then do; /* Keep the last odd character. */ substr (ibuffer, 1, 1) = substr (ibuffer, ibuf_ptr, 1); ibuf_ptr = 1; end; else ibuf_ptr = 0; /* Reset position pointer to start of ibuffer. */ return; end; /* Write_binary */ /* ******************************* Write_text ****************************** */ Write_text : proc; Dcl tbuffer char (2048), (i, tbuf_ptr, save_cnt) fixed bin, (character, prev_char) char (1), char_ptr ptr, (cr_seen, crlf_seen, store_char) bit (1) aligned; Dcl 1 bit_char based, 2 high_bit bit (1), 2 next_bits bit (7); /* ************************************************************************* */ tbuf_ptr = 0; cr_seen = false; crlf_seen = false; store_char = true; prev_char = nul_7bit_asc; char_ptr = addr (character); /* Now set the top bit on all the characters, and convert the EOL sequences. */ do i = 1 to ibuf_ptr; character = substr (ibuffer, i, 1); if prev_char ^= dc1_8bit_asc then char_ptr -> bit_char.high_bit = '1'b; store_char = true; /* Assume we want to store this character. */ if character = cr_8bit_asc then do; store_char = cr_seen; /* Store CR if we had one before. */ cr_seen = true; end; else do; if character = lf_8bit_asc then do; if cr_seen then crlf_seen = true; /* So we really do have CRLF. */ if mod (tbuf_ptr, 2) = 0 then do; tbuf_ptr = tbuf_ptr + 1; substr (tbuffer, tbuf_ptr, 1) = lf_8bit_asc; character = nul_7bit_asc; /* Now store a NUL. */ end; end; else if cr_seen then /* Keep any previous CR we may have had. */ do; tbuf_ptr = tbuf_ptr + 1; substr (tbuffer, tbuf_ptr, 1) = cr_8bit_asc; end; cr_seen = false; /* We don't have a CR anymore. */ end; if store_char then do; tbuf_ptr = tbuf_ptr + 1; substr (tbuffer, tbuf_ptr, 1) = character; end; prev_char = character; end; if cr_seen then /* Keep any final CR we may have had. */ do; tbuf_ptr = tbuf_ptr + 1; substr (tbuffer, tbuf_ptr, 1) = cr_8bit_asc; end; if tbuf_ptr = 0 then return; save_cnt = 0; if key = 0 then /* Save the CTRL-Z or CR or odd character. */ do; character = substr (tbuffer, tbuf_ptr, 1); if character = ctrl_z_8bit_asc | character = cr_8bit_asc then save_cnt = 1; if mod (tbuf_ptr - save_cnt, 2) ^= 0 then do; save_cnt = save_cnt + 1; if substr (tbuffer, tbuf_ptr - save_cnt, 1) = dc1_8bit_asc then save_cnt = save_cnt + 2; end; if save_cnt > 0 then do; substr (ibuffer, 1, save_cnt) = substr (tbuffer, tbuf_ptr - save_cnt + 1, save_cnt); tbuf_ptr = tbuf_ptr - save_cnt; end; ibuf_ptr = save_cnt; end; else do; /* Last write to file. */ if rec_file_type = automatic_ft & first_write & ^crlf_seen then do; rec_file_type = binary_ft; /* If the file is read in one go, */ file_type = binary_ft; /* and doesn't end in CRLF, then it's BINARY. */ if packet_log_opened then call log_info (packet_log, 'BINARY file type has been detected, and will now be used.'); return; end; if substr (tbuffer, tbuf_ptr, 1) = ctrl_z_8bit_asc then tbuf_ptr = tbuf_ptr - 1; /* Remove the last CTRL-Z. */ if tbuf_ptr > 0 then if substr (tbuffer, tbuf_ptr, 1) ^= lf_8bit_asc then if tbuf_ptr > 1 then if substr (tbuffer, tbuf_ptr - 1, 2) ^= lf_8bit_asc || nul_7bit_asc then do; tbuf_ptr = tbuf_ptr + 1; substr (tbuffer, tbuf_ptr, 1) = lf_8bit_asc; end; else ; else do; tbuf_ptr = tbuf_ptr + 1; substr (tbuffer, tbuf_ptr, 1) = lf_8bit_asc; end; if mod (tbuf_ptr, 2) ^= 0 then do; tbuf_ptr = tbuf_ptr + 1; substr (tbuffer, tbuf_ptr, 1) = nul_7bit_asc; end; ibuf_ptr = 0; end; first_write = false; call prwf$$ (k$writ, file_unit, addr (tbuffer), divide (tbuf_ptr, 2, 15), 0, rnw, code); return; end; /* Write_text */ end; /* Write_ibuf */ ------------------------------------------------------------------------------- /* WRITE_OUTPUT -- Write data to output file. */ Write_output : proc returns (fixed bin); $Insert *>insert>kermit.ins.plp $Insert *>insert>common.ins.plp $Insert *>insert>constants.ins.plp Dcl (counter, rec_msg_len, code, rep_count, next, end) fixed bin, (character, chr) char (1), rem_pound_str char (2), (do_8bit_quoting, parity, compress_spaces) bit (1) aligned; /* ************************************************************************* */ code = 0; char2(1) = nul_7bit_asc; rec_msg_len = length (rec_msg) - 1; do_8bit_quoting = (quote8_char ^= 'N'); rem_pound_str = rem_quote_chr || '\'; do counter = pkt_msg to rec_msg_len until (code ^= 0); character = substr (rec_msg, counter, 1); rep_count = 1; parity = false; if do_repeats then /* Process repeat characters. */ if set8 (character) = loc_rep_chr then do; counter = counter + 1; rep_count = knum (substr (rec_msg, counter, 1)); counter = counter + 1; character = substr (rec_msg, counter, 1); end; if do_8bit_quoting then /* Process 8-bit quoting. */ if set8 (character) = quote8_char then do; parity = true; counter = counter + 1; character = substr (rec_msg, counter, 1); if rec_file_type = automatic_ft & (substr (rec_msg, counter, 2) ^= rem_pound_str) then do; rec_file_type = binary_ft; file_type = binary_ft; /* It's a BINARY file. */ if packet_log_opened then call log_info (packet_log, 'BINARY file type has been detected, and will now be used.'); end; end; /* Process control character quoting. */ if set8 (character) = set8 (rem_quote_chr) then do; counter = counter + 1; character = substr (rec_msg, counter, 1); chr = clr8 (character); if chr >= query_7bit_asc & chr < grave_7bit_asc then character = ctl (character); end; if do_8bit_quoting then /* Now we can add the parity. */ if parity then character = set8 (character); else character = clr8 (character); else if do_transparent then if rec_file_type = automatic_ft & character >= nul_8bit_asc then do; rec_file_type = binary_ft; file_type = binary_ft; /* It's a BINARY file. */ if packet_log_opened then call log_info (packet_log, 'BINARY file type has been detected, and will now be used.'); end; /* Store in intermediate buffer. */ if file_type = ascii_ft & character = space_7bit_asc & rep_count > 2 then do; /* Spaces are a special case, allow for 2 characters. */ next = 2; compress_spaces = true; end; else do; next = rep_count; compress_spaces = false; end; if ibuf_ptr + next > ibuffer_size then call write_ibuf (0, code); /* Make some space if necessary. */ if compress_spaces then do; ibuf_ptr = ibuf_ptr + 1; substr (ibuffer, ibuf_ptr, 1) = dc1_8bit_asc; char2_ptr -> fb15_based = rep_count; character = char2(2); rep_count = 1; end; next = ibuf_ptr + 1; end = ibuf_ptr + rep_count; do ibuf_ptr = next to end; substr (ibuffer, ibuf_ptr, 1) = character; end; ibuf_ptr = ibuf_ptr - 1; /* Adjustment for the do loop. */ if ibuf_ptr >= ibuffer_size then /* Write out the buffer if its full. */ call write_ibuf (0, code); end; /* do until */ return (code); end; /* Write_output */ ------------------------------------------------------------------------------- /* XFER_MODE -- Set or reset packet transfer mode. */ Xfer_mode : proc (key, code); Dcl (key, code) fixed bin; $Insert *>insert>common.ins.plp $Insert *>insert>kermit.ins.plp $Insert *>insert>primos.ins.plp $Insert *>insert>constants.ins.plp $Insert syscom>keys.ins.pl1 /* ************************************************************************* */ code = 0; select (key); when (0) /* Reset to interactive use. */ do; if ^do_transparent then addr (code) -> bit16_based = duplx$ (my_duplex); call erkl$$ (k$writ, my_erase, my_kill, code); call mgset$ (my_msg_state, code); end; when (1) /* Set up for packet transfer. */ do; if ^do_transparent then /* Set to half duplex. */ addr (code) -> bit16_based = duplx$ (my_half_duplex); /* Set the erase and kill characters to non-printing. */ call erkl$$ (k$writ, my_new_erase, my_new_kill, code); /* Reject any messages we may receive. */ call mgset$ (k$rjct, code); auto_sum = do_transparent; /* Set if we have no parity. */ end; otherwise code = -1; end; return; end; /* Xfer_mode */