home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
old
/
misc
/
prime
/
prime800.src
< prev
next >
Wrap
Text File
|
2020-01-01
|
221KB
|
7,098 lines
-------------------------------------------------------------------------------
/*
/* Build file for PRIME Kermit-R21.
/*
&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 %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 ^ [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% -b *>obj>=.+bin %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>comnd
lo *>obj>server
lo *>obj>generic_cmd
lo *>obj>rec_switch
lo *>obj>rec_packet
lo *>obj>send_switch
lo *>obj>send_packet
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>xfer_mode
lo *>obj>get_error_msg
lo *>obj>convert_file
li
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. */
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_read bit (1) aligned external, /* First read of the data. */
filename_warning bit (1) aligned external, /* File re-naming warning. */
do_repeats bit (1) aligned external, /* TRUE if repeat processing. */
do_windowing bit (1) aligned external, /* TRUE when windowing. */
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. */
log_opened bit (1) aligned external, /* Log file opened. */
log_unit fixed bin external, /* Log file unit. */
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, /* Current 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_windowing bit (1) aligned external, /* Ability to do windowing. */
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,
kprompt char (32) 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). */
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. */
eol_flag fixed bin external, /* Detector for cr lf seqs. */
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_erase char (2) external,
my_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,
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,
query_7bit_asc char (1) external,
grave_7bit_asc char (1) 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, /* <CHAR(Count)> */
pkt_seq by 3, /* <CHAR(Seq)> */
pkt_type by 4, /* <Message type> */
pkt_msg by 5, /* <MESSAGE-DEPENDENT INFORMATION> */
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"><CHAR(Bufsiz)><CHAR(Timeout)><CHAR(npad)><CTL(pad)><CHAR(Eol)><Quote>
* <8-bit-quote><Repeat><Reserved><Reserved><Reserved>
*
* 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 /* My 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. <CR> */
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 16; /* My maximum 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. */
init_delay by 5, /* Initial delay time. */
max_retries by 5, /* Maximum number of retries. */
bignum by 2147483647, /* The biggest fixed bin number. */
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,
query_8bit_asc by '?',
grave_8bit_asc by '`';
%list;
/* End of CONSTANTS.INS.PLP */
-------------------------------------------------------------------------------
/* PRIMOS.INS.PLP -- Declarations for PRIMOS subroutines and the directory entries. */
%nolist;
Dcl at$ entry (fixed bin, char (*) var, fixed bin),
at$hom entry (fixed bin),
at$or entry (fixed bin, fixed bin),
c1in entry (fixed bin),
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)),
dir$rd entry (fixed bin, fixed bin, 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),
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),
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),
rdlin$ entry (fixed bin, char (*), 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),
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);
%Replace dir_entry_size by 37; /* Correct size at PRIMOS revision 22.0.1a. */
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_info,
3 (long_rat_hdr, dumped, dos_mod, special) bit (1),
3 rwlock bit (2),
3 pad1 bit (2),
3 type bit (8),
2 dtm,
3 date,
4 year bit (7),
4 month bit (4),
4 day bit (5),
3 time fixed bin,
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);
%list;
/* End of PRIMOS.INS.PLP */
-------------------------------------------------------------------------------
/* KERMIT.INS.PLP -- Declarations for KERMIT subroutines,
Utilities, and some based variables. */
%nolist;
Dcl ack_send_init entry,
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,
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 returns (fixed bin),
log_info entry (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 (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_packet entry,
rec_switch entry,
ren_hndlr entry (ptr),
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)),
knum entry (char (1)) returns (fixed bin),
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 */
-------------------------------------------------------------------------------
/* 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;
loc_windowing = capa_ptr -> capas.windowing;
call set_params;
/* Build our ACK packet. */
char2(1) = nul_7bit_asc;
char2(2) = loc_eol;
char2_ptr -> fb15_based = char2_ptr -> fb15_based + 32; /* Set the printable bit. */
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 */
-------------------------------------------------------------------------------
/* 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$ ('0602'b4, 0, 0, code); /* Turn off watchdog timer. */
call log_info ('.BREAK. received!'); /* Log the break. */
call xfer_mode (0, code); /* Reset the user's environment. */
call tnou ('QUIT.',5);
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 syscom>keys.ins.pl1
Dcl pathlen fixed bin,
new_dir char (128);
/* ************************************************************************* */
code = 0;
if treename = '' then /* Attach to the 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, ' ') || '.';
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
total = total + str_ptr -> trans_data(word_index).a1; /* Parity NONE, 8 bit data, transparent mode. */
else
total = total + str_ptr -> non_trans_data(word_index).a1; /* 7 bit data, non-transparent mode. */
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);
if code2 = 0 then
call satr$$ (k$dtc, (file_name), length (file_name), rec_file_dtc, code2);
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, prompt_len, i, code) fixed bin,
from_comi_hndlr bit (1) aligned,
kermit_state_ptr ptr,
(reenter, comi_eof) char (10) var,
cmd_option char (128) var,
prompt char (32) var,
cmd_buf char (160) var;
%Replace kermit_len by 16,
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');
%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;
%Replace show_len by 12;
Dcl show_state (show_len) char (16) var static init (
'ALL',
'DELAY',
'PARITY',
'QUOTE',
'8QUOTE',
'REPEAT',
'WINDOW',
'STORAGE_TYPE',
'INCOMPLETE',
'POUND',
'ATTRIBUTES',
'WARNING');
%Replace show_all by 1,
show_delay by 2,
show_parity by 3,
show_quote by 4,
show_8quote by 5,
show_repeat by 6,
show_wsize by 7,
show_store by 8,
show_incomplete by 9,
show_pound by 10,
show_attributes by 11,
show_warning by 12;
/* ************************************************************************* */
code = 0;
from_comi_hndlr = false;
prompt = kprompt || '> ';
prompt_len = length (prompt);
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);
Ren_point :
do while (true);
do until (((length (cmd_buf) ^= 0) & substr (cmd_buf, 1, 1) ^= ctrl_a_8bit_asc) | (code ^= 0));
call tnoua ((prompt), prompt_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);
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 cmd_option = 'TTY' | cmd_option = 'PAUSE' |
cmd_option = substr ('CONTINUE', 1, length (cmd_option)) then
call ioa$ ('The filename "%v" is NOT allowed for the TAKE command. %.',
99, cmd_option);
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
call comi$$ ((cmd_option), length (cmd_option), i, code);
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);
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 parameter. */
if num_tok < 2 then
call tnou ('No SET option specified.', 24);
else
call comnd_set;
when (cmd_show) /* SHOW parameter. */
do;
if num_tok < 2 then
cmd_option = 'ALL';
call tonl;
call comnd_show (type (cmd_option, addr (show_state), show_len));
call tonl;
end;
when (cmd_server) /* SERVER. */
do;
call xfer_mode (1, code);
call tnou ('Kermit server started.', 22);
call server;
call xfer_mode (0, code);
return;
end;
when (cmd_send) /* SEND. */
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);
when (cmd_receive) /* RECEIVE. */
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;
when (cmd_convert) /* CONVERT a file. */
if num_tok < 2 then
call tnou ('No filename 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. */
if log_opened then
call tnou ('Log file already opened.', 24);
else
do;
code = open_log (cmd_option);
if code ^= 0 then
do;
call get_error_msg (code);
call ioa$ ('Error opening log file. %v%.', 99, errmsg);
end;
else
call tnou ('Log file opened.', 16);
end;
when (cmd_close) /* CLOSE the log file. */
if log_opened then
do;
log_opened = false;
call clo$fu (log_unit, code);
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
call tnou ('Log file closed.', 16);
end;
else
call tnou ('Log file not opened.', 20);
when (cmd_push) /* PUSH to a new command level. */
call comlv$;
when (cmd_pop)
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;
go to comi_restart;
end;
end;
when (cmd_stop)
if take_level > 0 then
do;
call comi$$ ('TTY', 3, take_unit(take_level), code); /* If this fails then the on-unit should catch EOF. */
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;
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;
Dcl ans char (16) var;
/* ************************************************************************* */
call ioa$ ('%/Interactive mode commands : %/%.', 99);
call ioa$ ('Commands may be abbreviated to those letters in uppercase.%/%.', 99);
call ioa$ (' Receive [pathname] Upload a file.%.', 99);
call ioa$ (' SENd wildcard Download file(s) using wildcards.%.', 99);
call ioa$ (' SERver Start Kermit server.%/%.', 99);
call ioa$ (' CLose Close the log file.%.', 99);
call ioa$ (' COnvert pathname Converts a file to PRIME ASCII.%.', 99);
call ioa$ (' Exit or Quit Leave Kermit.%.', 99);
call ioa$ (' Help Display this message.%.', 99);
call ioa$ (' Log [pathname] Start a log file. Default is KERMIT.LOG%.', 99);
call ioa$ (' POp Close the current TAKE file.%.', 99);
call ioa$ (' PUsh Return to PRIMOS, and may re-enter Kermit.%.', 99);
call ioa$ (' SHow [{parameter | ALL}] Display the required parameter.%.', 99);
call ioa$ (' STop Close all TAKE files, and return to Kermit.%.', 99);
call ioa$ (' Take pathname Execute commands from a file.%.', 99);
call ioa$ (' Version Display the current version number.%/%.', 99);
ans = '';
call tnoua ('More ? ', 7);
call cl$get (ans, 16, code);
if code ^= 0 then
do;
call get_error_msg (code);
call ioa$ ('Error reading the command line. %v%.', 99, errmsg);
return;
end;
if length (ans) > 0 then
ans = translate (substr (trim (ans, '11'b), 1, 1), uppercase, lowercase);
if ans ^= 'Y' & ans ^= '' then
return;
call ioa$ ('%/ SET parameter Set one of the following parameters :%.', 99);
call ioa$ (' Attributes {ON | OFF} Use the received file attributes. DTC%.', 99);
call ioa$ ('%40xand file type are used. Default is ON.%.', 99);
call ioa$ (' Delay n Delay time in seconds before sending a%.', 99);
call ioa$ ('%40xfile. Default is %d seconds.%.', 99, init_delay);
call ioa$ (' File_Type {AUTO | TEXT | BINARY} Set the type of file(s) to be sent or%.', 99);
call ioa$ ('%40xreceived. Default is AUTO.%.', 99);
call ioa$ (' Incomplete {SAVE | DELETE} Keep or delete incompletely received%.', 99);
call ioa$ ('%40xfiles. Default is DELETE.%.', 99);
call ioa$ (' PArity {MARK | NONE} Set the character parity type.%.', 99);
call ioa$ ('%40xDefault parity is MARK.%.', 99);
call ioa$ (' POUnd {ON | OFF} Sets the conversion of DOS pound%.', 99);
call ioa$ ('%40xsigns. Default is ON.%.', 99);
call ioa$ (' Quote char Control quoting character to use.%.', 99);
call ioa$ ('%40x("char" = ASCII printable character).%.', 99);
call ioa$ (' 8Quote char 8-bit quoting character to use.%.', 99);
call ioa$ ('%40x("char" = ASCII grammatical character).%.', 99);
call ioa$ (' Repeat char Repeat character prefix to use.%.', 99);
call ioa$ ('%40x("char" = ASCII printable character).%.', 99);
call ioa$ (' WArning {ON | OFF} File name collision warning. Prevents%.', 99);
call ioa$ ('%40xoverwriting of files. Default is ON.%.', 99);
call ioa$ (' WIndow n File transfer window size.%.', 99);
call ioa$ ('%40x(0 <= "n" <= 31, 0 = no windowing).%.', 99);
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_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 = ' ' 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 (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;
%Replace set_len by 11;
Dcl set_state (set_len) char (16) var static init (
'DELAY',
'PARITY',
'QUOTE',
'8QUOTE',
'WINDOW',
'FILETYPE',
'POUND',
'INCOMPLETE',
'ATTRIBUTES',
'REPEAT',
'WARNING');
%Replace set_delay by 1,
set_parity by 2,
set_quote by 3,
set_8quote by 4,
set_wsize by 5,
set_store by 6,
set_pound by 7,
set_incomplete by 8,
set_attributes by 9,
set_repeat by 10,
set_warning by 11;
/* ************************************************************************* */
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_parity)
if cmd_option = 'M' | cmd_option = 'MARK' then
do;
do_transparent = false;
do_8bit_chks = false;
if loc_8quote_chr = 'Y' | loc_8quote_chr = 'N' then
do;
call tnou ('WARNING : 8-bit quoting MUST be used with MARK parity for binary file transfers.', 80);
call comnd_show (show_8quote);
end;
call comnd_show (show_parity);
end;
else
if cmd_option = 'N' | cmd_option = 'NONE' then
do;
do_transparent = true;
do_8bit_chks = true;
call comnd_show (show_parity);
end;
else
if cmd_option = '' 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);
when (set_quote)
if length (cmd_option) > 1 then
call ioa$ ('Invalid control quoting character given "%v".%/Only one character may be specified.%.', 99, cmd_option);
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)
call ioa$ ('Invalid control quoting character given "%v".%/It is the same as the 8-bit quoting character.%.', 99, cmd_option);
when (loc_rep_chr)
call ioa$ ('Invalid control quoting character given "%v".%/It is the same as the repeat character prefix.%.', 99, cmd_option);
otherwise
if cmd_option < ' ' | cmd_option > '~' then
call tnou ('Invalid control quoting character given. It must be a printable ASCII character.', 80);
else
do;
loc_quote_chr = cmd_option;
call comnd_show (show_quote);
end;
end;
when (set_8quote)
if length (cmd_option) > 1 then
call ioa$ ('Invalid 8-bit quoting character given "%v".%/Only one character may be specified.%.', 99, cmd_option);
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)
call ioa$ ('Invalid 8-bit quoting character given "%v".%/It is the same as the control quoting character.%.', 99, cmd_option);
when (loc_rep_chr)
call ioa$ ('Invalid 8-bit quoting character given "%v".%/It is the same as the repeat character prefix.%.', 99, cmd_option);
otherwise
do;
loc_8quote_chr = cmd_option;
if ^do_transparent & (cmd_option <= ' ' | (cmd_option > '>' &
cmd_option < '`') | cmd_option > '~') then
do;
call tnou ('WARNING : 8-bit quoting MUST be used with MARK parity for binary file transfers.', 80);
call comnd_show (show_parity);
end;
call comnd_show (show_8quote);
end;
end;
when (set_repeat)
if length (cmd_option) > 1 then
call ioa$ ('Invalid repeat character prefix given "%v".%/Only one character may be specified.%.', 99, cmd_option);
else
select (cmd_option);
when (loc_quote_chr)
call ioa$ ('Invalid repeat character prefix given "%v".%/It is the same as the control quoting character.%.', 99, cmd_option);
when (loc_8quote_chr)
call ioa$ ('Invalid repeat character prefix given "%v".%/It is the same as the 8-bit quoting character.%.', 99, cmd_option);
otherwise
if (cmd_option < ' ' | (cmd_option > '>' & cmd_option < '`') | cmd_option > '~') & cmd_option ^= '' then
call tnou ('Invalid repeat character prefix given. It must be a printable ASCII character.', 78);
else
do;
if cmd_option = '' then
cmd_option = ' ';
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 0 and 31 inclusive.', 74);
else
do;
loc_max_wsize = i;
addr (loc_capas1) -> capas.windowing = (loc_max_wsize > 0);
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 set before. */
pound_conversion = true;
call comnd_show (show_store);
end;
when ('AS', '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 storage type given. The current setting will be unchanged.', 61);
call comnd_show (show_store);
end;
otherwise
call ioa$ ('Invalid storage 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 (ambiguous_cmd)
call ioa$ ('Ambiguous SET option "%v". Type HELP for a list of options.%.', 99, token(2));
otherwise
call ioa$ ('Unrecognized SET option "%v". Type HELP for a list of options.%.', 99, token(2));
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. */
do num_tok = 1 to num_tokens;
token(num_tok) = '';
end;
buff = translate (buff, uppercase || ' ', lowercase || ',');
buff = trim (buff, '11'b);
do num_tok = 1 to num_tokens while (buff ^= '');
token(num_tok) = before (buff, ' ');
buff = trim (after (buff, ' '), '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 */
-------------------------------------------------------------------------------
/* 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 (ibuffer_size) var,
(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 ptr,
character char (1);
Dcl 1 bit_char based,
2 high_bit bit (1),
2 next_bits bit (7);
/********************************************************************/
buffer = '';
snd_msg = '';
char_ptr = addr (character);
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, code);
code = e$wft;
end;
file_opened = (code = 0);
if code ^= 0 then
do;
snd_msg = 'Error opening file to convert on remote system. ';
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 file on remote system.';
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 then
code = 0;
if code = 0 then
do;
ibuflen = 2 * rnw;
call convert_to_ascii;
if code ^= 0 then
snd_msg = 'Error converting the file on the remote system.';
end;
else
if code ^= e$eof then
snd_msg = 'Error reading from the file on the remote system.';
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);
snd_msg = 'Error in processing file conversion on the remote system.';
return (code);
end;
else
do;
code = rnw;
if code ^= 0 then
do;
snd_msg = 'Unable to close the output file on the remote system.';
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 on remote system.';
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 on the remote system.';
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 on remote system.';
if non_null_dir then
call at$hom (rnw);
if code = 0 then
code = rnw;
return (code);
/* **************************** Convert_to_ascii *************************** */
Convert_to_ascii : proc;
/* ************************************************************************* */
code = 0;
do i = 1 to ibuflen;
character = substr (ibuffer, i, 1);
char_ptr -> bit_char.high_bit = '1'b;
select (character);
when (cr_8bit_asc)
eol_flag = 1;
when (lf_8bit_asc)
eol_flag = eol_flag + 1;
otherwise
eol_flag = 0;
end;
if eol_flag > 1 then
do;
sufusd = length (buffer);
substr (buffer, sufusd, 1) = ' ';
call wtlin$ (unit2, (buffer), divide (sufusd, 2, 15), code);
if code ^= 0 then
return;
buffer = '';
end;
else
buffer = buffer || character;
end;
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 then /* Possible if the unit wasn't open. */
code = 0;
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),
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 arg(2) ^= '' then /* Do we have a password ? */
treename = treename || ' ' || 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 treename = '' 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 treename ^= '' 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);
if type = 1 then
snd_msg = 'Not a quota directory. (' || basename || ' records used).';
else
snd_msg = basename || ' records used out of quota of ' ||
trim (char (quota_info.max_quota), '10'b) || '.';
call send_packet (msg_ack, length (snd_msg), rec_seq);
end;
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, code);
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 rdlin$ (file_unit, ibuffer, ibuffer_size_wds, code);
if code = 0 then
call wtlin$ (funit, ibuffer, ibuffer_size_wds, 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), ' ');
arg(1) = translate (trim (before (arg(1), ' '), '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 arg(1) = '' 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 /* User number given. */
do;
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 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 = rem_rep_chr) & (loc_rep_chr ^= ' ');
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;
/* ************************************************************************* */
call prwf$$ (k$posn + k$prea, file_unit, null (), 0, 0, rnw, code); /* Rewind the file. */
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 a_sub_pkt.data ^= '' 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 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;
call cv$fda (dir_entry.dtc, dow, formatted_date);
if dow >= 0 then
buffer = '19' || substr (formatted_date, 1, 2) || substr (formatted_date, 4, 2) ||
substr (formatted_date, 7, 2) || ' ' || 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 errmsg = '' then
errmsg = '(Code = ' || trim (char (code), '11'b) || ')';
return;
end; /* Get_error_msg */
-------------------------------------------------------------------------------
/* GET_LEN -- Determine logical length of file in bytes. */
Get_len : proc returns (fixed bin);
$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,
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;
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_info.rwlock = k$none then
file_len = file_len - 1;
call prwf$$ (k$posn + k$prea, file_unit, null (), 0, 0, rnw, code); /* Rewind the file. */
if code = 0 then
file_pos = 0;
return (code);
end; /* Get_len */
-------------------------------------------------------------------------------
/* 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 (11) 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;',
'-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 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,
(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;
explicit_pound_set = cl_struc.pound_flag;
if cl_struc.pound_flag then
select (cl_struc.pound_option);
when ('OFF', 'N', 'NO')
pound_conversion = false;
when ('', 'ON', 'Y', 'YES')
do;
pound_conversion = true;
if cl_struc.pound_option = '' 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", defaulting to ON for pound sign conversion.%.',
99, cl_struc.pound_option);
end;
end;
explicit_ft_set = cl_struc.storage_flag;
if cl_struc.storage_flag then
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 for binaries. */
pound_conversion = false;
end;
when ('', 'AU', 'AUTO', 'AUTOMATIC')
do;
file_type = automatic_ft;
explicit_ft_set = false; /* Assume we haven't set it. */
if cl_struc.storage_type = '' 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;
if cl_struc.parity_flag then
select (cl_struc.parity_type);
when ('', 'M', 'MARK')
do; /* No need to check the 8-bit quoting since it hasn't changed yet. */
do_transparent = false;
do_8bit_chks = false;
if cl_struc.parity_type = '' 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.alt_flag then
if cl_struc.alt_name = '' 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 /* No log file opened yet, so no need to check. */
call start_log_file;
if cl_struc.rec_flag then
call rec_setup;
else
if cl_struc.send_flag then
if cl_struc.send_path = '' then
do;
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 log_opened then
call clo$fu (log_unit, 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;
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;
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;
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 | -SERver}]%.', 99, com_name);
call ioa$ ('%#x[-Alternate filename] [-Log [pathname]] [-Parity {MARK | NONE}]%.', 99, bad_index);
call ioa$ ('%#x[-File_Type {AUTOMATIC | TEXT | BINARY}]%.', 99, bad_index);
call ioa$ ('%#x[-POUnd {ON | OFF}] [-Help] [-Usage]%/%.', 99, bad_index);
return;
end; /* Print_cl_usage */
/* ***************************** Print_cl_help ***************************** */
Print_cl_help : proc;
Dcl ans char (16) var;
/* ************************************************************************* */
call print_cl_usage;
call ioa$ (' The first three options are mutually exclusive, but if none are specified%.', 99);
call ioa$ (' then the user enters an interactive mode and is prompted for commands. All%.', 99);
call ioa$ (' of the options may be abbreviated to those letters in uppercase.%/%.', 99);
call ioa$ (' The options are :%/%.', 99);
call ioa$ ('%5x-Receive [pathname]%/%8xUpload ONE file with the specified name or its original filename.%.', 199);
call ioa$ ('%/%5x-Send wildcard%/%8xDownload several files. 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 sent and received, and additional%.', 99);
call ioa$ ('%8xcommands may be issued.%.', 99);
ans = '';
call tnoua ('More ? ', 7);
call cl$get (ans, 16, code);
if code ^= 0 then
do;
call get_error_msg (code);
call ioa$ ('Error reading the command line. %v%.', 99, errmsg);
return;
end;
if length (ans) > 0 then
ans = translate (substr (trim (ans, '11'b), 1, 1), uppercase, lowercase);
if ans ^= 'Y' & ans ^= '' then
return;
call ioa$ ('%/%5x-Alternate filename%/%8xAlternate file name for when ONE file is being sent.%.', 99);
call ioa$ ('%/%5x-File_Type {AUTOMATIC | TEXT | BINARY}%/%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-Parity {MARK | NONE}%/%8xSpecifies the character parity to %$', 99);
call ioa$ ('use. Default is MARK.%.', 99);
call ioa$ ('%/%5x-Log [pathname]%/%8xOpens a log file for recording the packets %$', 99);
call ioa$ ('sent and received.%/%8xDefault log file name is KERMIT.LOG%.', 99);
call ioa$ ('%/%5x-POUnd {ON | OFF}%/%8xDetermines whether to convert DOS %$', 99);
call ioa$ ('pound signs. Default is ON.%.', 99);
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 (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 (user_num, code) fixed bin,
b8 bit (8) aligned,
b8_ptr ptr,
u_name char (32);
/* ************************************************************************* */
b8_ptr = addr (b8);
kversion = 'Public domain version 8.00';
kprompt = 'Kermit-R21';
delay = init_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 user_num = 0 to 63;
msg_table.slot(user_num).msg = '';
msg_table.slot(user_num).acked = false;
msg_table.slot(user_num).retries = 0;
end;
tab_first = 0; /* Default transfer parameters. */
tab_next = 0;
state = 0;
num_retries = 0;
quote8_char = 'N';
file_type = automatic_ft; /* Unknown file type. */
explicit_ft_set = false;
first_read = true;
filename_warning = true;
do_repeats = false;
do_windowing = false;
do_transparent = false;
do_flush = true;
do_8bit_chks = false;
auto_sum = true;
log_opened = false;
log_unit = 0;
window_size = 1;
errmsg = '';
take_level = 0;
do user_num = 1 to max_take_level;
take_unit(user_num) = 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_windowing = 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;
do user_num = 1 to max_matches;
matches(user_num) = '';
end;
num_matches = 0;
file_idx = 0;
del_incomplete = true;
ibuffer = copy (' ', ibuffer_size);
ibuffer_ptr = addr (ibuffer);
ibuflen = 0;
ibuf_ptr = 0;
eol_flag = 0;
char2_ptr = addr (char2);
char2_ptr -> fb15_based = 0;
pound_conversion = true;
explicit_pound_set = false;
do user_num = 0 to 255;
trans_char(user_num) = '';
end;
dir_entry_ptr = addr (dir_entry);
call erkl$$ (k$read, my_erase, my_kill, code); /* Keep these for our user. */
if code ^= 0 then
do;
call get_error_msg (code);
call ioa$ ('Error getting erase and kill characters. %v%.', 99, errmsg);
end;
my_duplex = duplx$ ('FFFF'b4);
call user$ (user_num, code); /* Get our MESSAGE status. */
call msg$st (k$read, user_num, '', 0, u_name, 32, my_msg_state);
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 = cr_7bit_dec;
cr_7bit_asc = b8_ptr -> char1_based;
rem_eol = cr_7bit_asc; /* We need this for the FIRST packet sent. */
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 = '3F'b4;
query_7bit_asc = b8_ptr -> char1_based;
b8 = '60'b4;
grave_7bit_asc = b8_ptr -> char1_based;
return;
end; /* Kermit_init */
-------------------------------------------------------------------------------
/* LOG_INFO -- Log one line of info to log file. */
Log_info : proc (data);
Dcl 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;
/* ************************************************************************* */
if log_opened then
do;
call wtlin$ (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 log file. %v%/Closing the log file.%.',
99, errmsg);
log_opened = false;
call clo$fu (log_unit, code);
end;
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 ^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)
line = 'ERR ';
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 || ' ';
end;
if seq_num < 10 then
line = line || ' ';
line = line || trim (char (seq_num), '11'b); /* Append the seq. number. */
if data ^= '' then /* Append the data. */
line = line || ' "' || data || '"';
call wtlin$ (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);
log_opened = false;
call clo$fu (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
if non_null_dir then
path_name = dir_name || '>@@';
else
path_name = '@@';
path_name = translate (path_name, uppercase || '@+', lowercase || '*?');
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_info.type < '02'b4 | dir_entry.file_info.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 /* Check for the end of the table. */
return (ker_nomorfiles);
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 ('Error opening ' || path_name || '. ' || errmsg);
file_idx = file_idx + 1; /* Try the next file. */
end;
else
do;
test_flag = true;
if 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 ('File ' || path_name || ' opened ' || errmsg);
if explicit_ft_set then
call log_info ('The file type has been explicitly set.');
else
if file_type ^= automatic_ft then
call log_info ('The file type has been automatically set.');
end;
end;
end;
if num_matches = 1 & (alternate_fname ^= '') then /* Use alternate name if given. */
do;
file_name = alternate_fname;
if log_opened then
call log_info ('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, code);
code = e$wft;
end;
file_opened = (code = 0);
if code ^= 0 then
return (code);
code = get_len ();
if code = 0 then
do;
if file_type = automatic_ft then /* AUTOMATIC file type detection. */
call ck_file_type;
if code = 0 then
return (code);
end;
file_opened = false; /* At this point something is wrong, 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);
if file_len = 0 then
do; /* This allows for empty files. */
ibuflen = 0;
file_type = ascii_ft;
return;
end;
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); /* This is the main checking loop. */
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 /* ASCII files must end in LF or CTRL-Z. */
do;
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;
if file_type = binary_ft & ^explicit_pound_set then
pound_conversion = false;
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 (pathname) returns (fixed bin);
Dcl pathname char (128) var;
$Insert *>insert>common.ins.plp
$Insert *>insert>primos.ins.plp
$Insert syscom>keys.ins.pl1
$Insert syscom>errd.ins.pl1
Dcl (type, sufusd, code) fixed bin,
basename char (32) var,
fn char (128) var;
/* ************************************************************************* */
fn = pathname;
if fn = '' then
fn = 'kermit.log';
call fil$dl (fn, code); /* Delete any old file first, if possible. */
if code = 0 | code = e$fntf then
call srsfx$ (k$writ + k$getu, fn, log_unit, type, 0, '', basename, sufusd, code);
log_opened = (code = 0);
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 /* See if we 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 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;
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 = 1; /* Timeout in minutes. */
rem_eol = cr_7bit_asc;
rem_quote_chr = '#';
rem_8quote_chr = 'N';
rem_chk_type = '1';
rem_rep_chr = ' ';
rem_capas1 = 0;
rem_file_attrib = false;
rem_windowing = false;
rem_max_wsize = 1;
select (length (rec_msg) - pkt_tot_ovr_head); /* Process the packet according to its length. */
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;
when (0)
return;
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)) + 59;
rem_timeout = divide (rem_timeout, 60, 15); /* Set the timeout in minutes. */
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 crlf char (2),
(prev_char, new_char) char (1),
chr char (3) var,
(rep_count, i, max_chars, rnw, ibuf_wds_less1, ibuf_size_less2) fixed bin;
/* ************************************************************************* */
code = 0;
snd_msg = ''; /* Clear sending buffer. */
rep_count = 0;
prev_char = nul_7bit_asc;
char2_ptr -> fb15_based = 0;
ibuf_wds_less1 = ibuffer_size_wds - 1;
ibuf_size_less2 = ibuffer_size - 2;
crlf = cr_8bit_asc || lf_8bit_asc;
max_chars = rem_pkt_size - pkt_tot_ovr_head - 2; /* This allows for 8-bit, */
if do_repeats then /* control chars, but NOT repeats. */
max_chars = max_chars - 2; /* This now allows for repeat chars. */
Loop :
do until (length (snd_msg) >= max_chars); /* Main packet loop. */
ibuf_ptr = ibuf_ptr + 1;
if ibuf_ptr > ibuflen then
do;
call read_file;
ibuf_ptr = 1;
if code ^= 0 then
leave loop;
end;
new_char = substr (ibuffer, ibuf_ptr, 1);
if do_repeats then
if (new_char = prev_char & rep_count < 94) | first_read then
rep_count = rep_count + 1;
else
do;
char2(2) = prev_char;
chr = trans_char (char2_ptr -> fb15_based);
if rep_count > 3 then
do;
char2_ptr -> fb15_based = rep_count + 32;
rep_count = 1; /* We must do this for the do-loop. */
snd_msg = snd_msg || loc_rep_chr || char2(2);
end;
do i = 1 to rep_count;
snd_msg = snd_msg || chr;
end;
rep_count = 1;
end;
else
do;
char2(2) = new_char;
snd_msg = snd_msg || trans_char (char2_ptr -> fb15_based);
end;
first_read = false;
prev_char = new_char;
end;
if code = e$eof then
code = 0;
if code = 0 & do_repeats then
do;
char2(2) = new_char;
chr = trans_char (char2_ptr -> fb15_based);
if rep_count > 3 then
do;
char2_ptr -> fb15_based = rep_count + 32;
rep_count = 1; /* We must do this for the do-loop. */
snd_msg = snd_msg || loc_rep_chr || char2(2);
end;
do i = 1 to rep_count;
snd_msg = snd_msg || chr;
end;
end;
if code ^= 0 then
return (ker_internalerr);
else
if length (snd_msg) = 0 then
return (ker_eof);
else
return (ker_normal);
/* ******************************* Read_file ******************************* */
Read_file : proc;
/* ************************************************************************* */
if file_type = ascii_ft then
do;
call rdlin$ (file_unit, ibuffer, ibuf_wds_less1, code);
if code ^= 0 then
do;
ibuflen = 0;
return;
end;
ibuflen = length (trim (substr (ibuffer, 1, ibuf_size_less2), '01'b));
substr (ibuffer, ibuflen + 1, 2) = crlf;
ibuflen = ibuflen + 2;
ibuffer = clr8str ((ibuffer));
end;
else
do; /* BINARY files. */
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;
end;
return;
end; /* Read_file */
end; /* Read_input */
-------------------------------------------------------------------------------
/* 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 (char_in, code, rec_msg_len) fixed bin,
line char (max_msg) var;
/* ************************************************************************* */
timeout = bad_return; /* Local label used for Timeout condition. */
call limit$ ('0602'b4, (rem_timeout), 0, code);
do until (char_in = ctrl_a_8bit_dec | char_in = ctrl_a_7bit_dec);
call c1in (char_in);
end;
call get_line; /* Get the rest of the message. */
call limit$ ('0602'b4, 0, 0, code); /* Turn off the timer. */
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 log_opened then
do;
call log_info ('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;
rec_pkt_type = set8 (substr (rec_msg, pkt_type, 1)); /* Extract the fields from the packet. */
rec_length = knum (substr (rec_msg, pkt_count, 1)) + 2;
rec_seq = knum (substr (rec_msg, pkt_seq, 1));
if rec_msg_len ^= rec_length then /* Check that the packet length is correct. */
do;
rec_pkt_type = msg_check_err;
if log_opened then
do;
call log_info ('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 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 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;
/* ************************************************************************* */
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 ('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;
if chksum7 ^= chksum8 then /* Determine checksum type if undetermined. */
do;
auto_sum = false;
do_8bit_chks = (chksum8 = rec_pkt_chksum);
if do_8bit_chks then
call log_info ('Doing 8 bit checksums.');
else
call log_info ('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 ('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) fixed bin,
new_path char (128) var,
chr char (1),
(single_file_rec, test_flag) bit (1) aligned;
/* ************************************************************************* */
do_flush = true;
num_retries = 0; /* Initialize the number of retries. */
single_file_rec = (path_name ^= '');
if log_opened then
do;
if single_file_rec then
errmsg = ' ' || path_name;
else
errmsg = '';
call log_info ('');
call log_info (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_rd)
state = rec_data ();
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);
select (rec_pkt_type);
when (msg_snd_init)
if rec_seq = mod (msg_number - 1, 64) then
do;
if ^bump_retry () then
return (state_a);
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_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 path_name = '' then /* Get the 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 ('File already exists. New file name is ' || file_name || '.');
end;
when (e$bnam)
do;
snd_msg = file_name;
call log_info ('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 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 ((errmsg));
end;
end;
else
do;
rec_file_type = automatic_ft;
file_type = ascii_ft; /* Assume this to start with. */
if log_opened then
do;
call log_info ('The receiving file type will be automatically detected.');
call log_info ('But ASCII file type will initially be assumed.');
end;
end;
call send_packet (msg_ack, length (snd_msg), msg_number); /* ACK file header packet. */
num_retries = 0;
msg_number = mod (msg_number + 1, 64);
if loc_file_attrib then /* Get the file attributes if we can. */
return (state_ra);
else
if do_windowing then
do;
tab_first = msg_number;
tab_next = tab_first;
do_flush = false;
return (state_rdw);
end;
else
return (state_rd);
end;
when (msg_eof)
if rec_seq = mod (msg_number - 1, 64) then
do;
if ^bump_retry () then
return (state_a);
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_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 other side know. */
snd_msg = snd_msg || '"';
end;
call send_packet (msg_ack, length (snd_msg), rec_seq);
num_retries = 0;
msg_number = mod (msg_number + 1, 64);
if substr (snd_msg, 1, 1) = 'N' then
call log_info ('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
return (state_a);
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;
call send_packet (msg_ack, 0, rec_seq);
num_retries = 0;
msg_number = mod (msg_number + 1, 64);
if do_windowing then
do;
tab_first = msg_number;
tab_next = tab_first;
do_flush = false;
return (state_rdw);
end;
else
return (state_rd);
end;
when (msg_file)
if rec_seq = mod (msg_number - 1, 64) then
do;
if ^bump_retry () then
return (state_a);
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;
call send_packet (msg_ack, 0, rec_seq);
num_retries = 0;
msg_number = mod (msg_number + 1, 64);
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_data ******************************* */
Rec_data : proc returns (fixed bin);
/* ************************************************************************* */
if ^rec_message () then /* Get a packet. */
return (state_a);
select (rec_pkt_type);
when (msg_data)
do;
if rec_seq ^= msg_number then /* Out of sequence messages. */
do;
if rec_seq = mod (msg_number - 1, 64) then
do;
if ^bump_retry () then
return (state_a);
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;
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;
call send_packet (msg_ack, 0, rec_seq);
num_retries = 0;
msg_number = mod (msg_number + 1, 64);
return (state_rd);
end;
when (msg_file)
if rec_seq = mod (msg_number - 1, 64) then
do;
if ^bump_retry () then
return (state_a);
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)
do;
if length (rec_msg) > pkt_msg then
rec_msg = substr (rec_msg, pkt_msg, 1);
else
rec_msg = '';
if rec_msg = 'D' then
call discard_output (i);
else
i = close_output ();
call set_path (''); /* Do this for later. */
if i ^= 0 then
do;
call get_error_msg (i);
if rec_msg = 'D' 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;
call send_packet (msg_ack, 0, rec_seq);
num_retries = 0;
msg_number = mod (rec_seq + 1, 64);
return (state_rf);
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_data */
/* ***************************** Rec_windowing ***************************** */
Rec_windowing : proc returns (fixed bin);
/* ************************************************************************* */
call rec_packet; /* Get input. */
select (rec_pkt_type);
when (msg_data)
if ^between (rec_seq, tab_first, mod (tab_first + 2 * window_size - 1, 64)) then
return (state);
else
do;
call update_table;
num_retries = 0;
return (state);
end;
when (msg_check_err)
do; /* NAK for oldest unACKed entry in table. */
call log_info ('Checksum error : NAK for oldest unACKed packet.');
call nak_oldest (false);
return (state);
end;
when (msg_eof)
do;
do_flush = true;
if length (rec_msg) > pkt_msg then
rec_msg = substr (rec_msg, pkt_msg, 1);
else
rec_msg = '';
if rec_msg = 'D' then
call discard_output (i);
else
do;
if ^flush_table () then
return (state_a);
i = close_output ();
end;
call set_path (''); /* Do this for later. */
if i ^= 0 then
do;
call get_error_msg (i);
if rec_msg = 'D' 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;
call send_packet (msg_ack, 0, rec_seq);
msg_number = mod (rec_seq + 1, 64);
return (state_rf);
end;
when (msg_error)
return (state_a);
when (msg_timeout)
if num_retries > max_retries then
do;
snd_msg = 'Retry count exceeded on remote system.';
call send_packet (msg_error, length (snd_msg), msg_number);
return (state_a);
end;
else
do;
call log_info ('Timeout : NAK for most desired packet.');
call nak_oldest (true);
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
do;
if ^bump_retry () then
return (false);
call send_packet (msg_nak, 0, msg_number);
num_retries = num_retries + 1;
end;
else
test_flag = true;
end;
return (true);
end; /* Rec_message */
/* ***************************** Update_table ****************************** */
Update_table : proc;
Dcl save_msg char (max_msg) var;
/* ************************************************************************* */
/* Make room in the table if necessary. */
if between (rec_seq, mod (tab_first + window_size, 64), mod (tab_first - 1, 64)) then
do;
save_msg = rec_msg;
i = tab_first; /* Write the old table entries to the file. */
do while (mod (i + window_size - 1, 64) ^= rec_seq);
if ^msg_table.slot(i).acked then
do;
snd_msg = 'Protocol error : receive table overrun.';
call send_packet (msg_error, length (snd_msg), msg_number);
state = state_a;
return;
end;
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;
i = mod (i + 1, 64);
tab_first = i;
end;
rec_msg = save_msg; /* Restore rec_msg. */
end;
msg_table.slot(rec_seq).msg = rec_msg; /* Add the new data packet to the table. */
msg_table.slot(rec_seq).acked = true;
msg_table.slot(rec_seq).retries = 0;
/* Clear the acked bit on any skipped pkts */
if between (rec_seq, mod (tab_next + 1, 64), mod (tab_first - 1, 64)) then
do;
i = tab_next;
do while (i ^= rec_seq);
msg_table.slot(i).acked = false;
msg_table.slot(i).retries = 0;
call send_packet (msg_nak, 0, i); /* NAK for the packet. */
i = mod (i + 1, 64);
end;
end;
if between (rec_seq, tab_next, mod (tab_first - 1, 64)) then
do; /* Update TAB_NEXT to be the next packet expected. */
tab_next = mod (rec_seq + 1, 64);
msg_number = tab_next;
end;
call send_packet (msg_ack, 0, rec_seq); /* Acknowledge the packet. */
return;
end; /* Update_table */
/* ****************************** Flush_table ****************************** */
Flush_table : proc returns (bit (1) aligned);
/* ************************************************************************* */
i = tab_first; /* Write the remainder of the receive table to the file. */
do while (i ^= tab_next);
if ^msg_table.slot(i).acked then
do;
snd_msg = 'Unacknowledged data packet when flushing table.';
call send_packet (msg_error, length (snd_msg), msg_number);
state = state_a;
return (false);
end;
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 (false);
end;
i = mod (i + 1, 64);
end;
return (true);
end; /* Flush_table */
/* ****************************** Nak_oldest ******************************* */
Nak_oldest : proc (desire);
Dcl desire bit (1) aligned;
/* ************************************************************************* */
i = tab_first;
do until (i = tab_next);
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, tab_next);
return;
end; /* Nak_oldest */
/* ******************************* 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. */
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, ' ');
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 ('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 ('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 ('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 ('The received file type attribute is ILLEGAL.');
call log_info ('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
/* ************************************************************************* */
/* "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.
*/
goto ren_lbl;
end; /* Ren_hndlr */
-------------------------------------------------------------------------------
/* 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) fixed bin;
/* ************************************************************************* */
if rem_npad > 0 then /* Do any packet filling required. */
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. */
call tty$rs (k$inb, temp);
call tnoua ((msg), msg_length); /* Now send the message. */
if log_opened then /* Log the packet if necessary. */
do;
if pkt_len = 0 then
msg = '';
else
msg = snd_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 log_opened then
do;
call log_info ('');
call log_info (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_sd)
state = send_data ();
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. */
char2(1) = nul_7bit_asc;
char2(2) = loc_eol;
char2_ptr -> fb15_based = char2_ptr -> fb15_based + 32; /* Set the printable bit. */
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;
loc_windowing = addr (loc_capas1) -> capas.windowing;
call send_packet (msg_snd_init, length (snd_msg), msg_number); /* Send the packet. */
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;
/* ************************************************************************* */
stop_xfer = false; /* Initialize the file interrupt flags. */
stop_trans = false;
first_read = true; /* Say that this is the first read of the file. */
test_flag = true;
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 log_opened then /* See if our file name was acceptable. */
do;
temp = length (rec_msg);
if temp > pkt_msg then
call log_info ('The file will be received as ' || substr (rec_msg, pkt_msg, temp - pkt_msg) || '.');
end;
call setup_trans_char; /* Setup the character translation table. */
/* If this is a file transfer, and attributes are expected, send them. */
if (state = state_sf) & rem_file_attrib then
return (state_sa);
if do_windowing then /* Otherwise, transmit the data. */
do;
tab_first = msg_number;
tab_next = msg_number;
do_flush = false;
return (state_sdw);
end;
else
return (state_sd);
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;
return (state_sd); /* Send the first data packet (always non-windowing). */
end; /* Send_attrib */
/* ******************************* Send_data ******************************* */
Send_data : proc returns (fixed bin);
Dcl status fixed bin,
test_flag bit (1) aligned;
/* ************************************************************************* */
test_flag = true;
status = read_input (code); /* Get the next buffer of data. */
select (status);
when (ker_normal)
;
when (ker_eof)
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;
do while (test_flag); /* Send the data packet. */
call send_packet (msg_data, length (snd_msg), msg_number);
if ^get_response () then /* Get the 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 /* Check for file transfer interruption. */
rec_msg = 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 (state_sz);
if do_windowing then /* If we are windowing, then change to SDW state. */
do;
tab_first = msg_number;
tab_next = msg_number;
do_flush = false;
return (state_sdw);
end;
else
return (state_sd);
end; /* Send_data */
/* ***************************** 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;
call send_packet (msg_data, length (snd_msg), msg_number); /* Send the data packet. */
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 ('File transfer interrupted.');
snd_msg = 'D'; /* Discard indication. */
msg_number = mod (rec_seq + 1, 64); /* Reset sequence number. */
call sleep$ (5000); /* Wait 5 secs to allow receiver to flush input. */
call send_packet (msg_eof, length (snd_msg), msg_number);
end;
else
call send_packet (msg_eof, 0, msg_number); /* Normal EOF : send end-of-file indicator packet. */
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);
/* ************************************************************************* */
call send_packet (msg_break, 0, msg_number); /* Send end-of-file-set indicator packet. */
if ^get_response () then /* Get a response from the remote side. */
return (state);
return (state_c);
end; /* Send_break */
/* ****************************** Get_response ***************************** */
Get_response : proc returns (bit (1) aligned);
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 */
/* ******************************* 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 ('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 ('Resend - timeout.');
end;
when (msg_check_err)
do;
call log_info ('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)
do;
/* 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 ('NAK - resend packet.');
i = rec_seq;
end;
else
do;
call log_info ('NAK - resend earliest packet.');
i = tab_first;
end;
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_timeout)
call send_packet (msg_nak, 0, msg_number);
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;
end; /* select */
end; /* do while */
return;
end; /* Server */
-------------------------------------------------------------------------------
/*
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) 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;
char2(2) = clr8 (quote8_char); /* 8-bit quote character. */
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 /* Control chars. */
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_char || 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
if rem_8q = 'Y' | rem_8q = loc_8quote_chr then /* See if remote agrees. */
quote8_char = loc_8quote_chr;
do_repeats = (loc_rep_chr = rem_rep_chr) & (loc_rep_chr ^= ' ');
do_windowing = loc_windowing & rem_windowing; /* Determine window size to use. */
if do_windowing then
if loc_max_wsize <= rem_max_wsize then
window_size = loc_max_wsize;
else
window_size = rem_max_wsize;
else
window_size = 1;
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 path_name = '' 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 = '';
non_null_dir = (dir_name ^= '');
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;
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 */
-------------------------------------------------------------------------------
/* 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>kermit.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));
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, 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) = 1);
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,
crlf_seen bit (1) aligned;
Dcl 1 bit_char based,
2 high_bit bit (1),
2 next_bits bit (7);
/* ************************************************************************* */
eol_flag = 0;
tbuf_ptr = 0;
crlf_seen = false;
prev_char = nul_7bit_asc;
char_ptr = addr (character);
do i = 1 to ibuf_ptr; /* Set top bit on all chars, and convert EOL sequences. */
character = substr (ibuffer, i, 1);
if prev_char ^= dc1_8bit_asc then
char_ptr -> bit_char.high_bit = '1'b;
prev_char = character;
if character = cr_8bit_asc then
eol_flag = 1;
else
if character = lf_8bit_asc then
eol_flag = eol_flag + 1;
else
eol_flag = 0;
if eol_flag < 2 then /* Store normal characters. */
do;
tbuf_ptr = tbuf_ptr + 1;
substr (tbuffer, tbuf_ptr, 1) = character;
end;
else
do; /* Convert CRLF to LF or LFNUL. */
crlf_seen = true;
substr (tbuffer, tbuf_ptr, 1) = lf_8bit_asc;
if mod (tbuf_ptr, 2) ^= 0 then
do;
tbuf_ptr = tbuf_ptr + 1;
substr (tbuffer, tbuf_ptr, 1) = nul_7bit_asc;
end;
end;
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) = 1 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 (ibuffer, ibuf_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 & ^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 log_opened then
call log_info ('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) = 1 then
do;
tbuf_ptr = tbuf_ptr + 1;
substr (tbuffer, tbuf_ptr, 1) = nul_7bit_asc;
end;
ibuf_ptr = 0;
end;
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, space_7bit_asc) 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');
space_7bit_asc = clr8 (' ');
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 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 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 log_opened then
call log_info ('BINARY file type has been detected, and will now be used.');
end;
end;
if character = rem_quote_chr then /* Process control character quoting. */
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 log_opened then
call log_info ('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 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
addr (code) -> bit16_based = duplx$ ('A000'b4); /* Set to half duplex. */
call erkl$$ (k$writ, '
call mgset$ (k$rjct, code); /* Reject any messages we may receive. */
auto_sum = do_transparent; /* Set if we have no parity. */
end;
otherwise
code = -1;
end;
return;
end; /* Xfer_mode */
/* END OF PRIME8.SRC */