{--file KERVERS--} const VERSION_STRING = 'HP98xx Kermit version 1.0 20-Jan-84'; {--file KERMMAIN--} $UCSD ON$ $SYSPROG$ $SEARCH '*IO.', '*INTERFACE.', 'KRMIO', 'KRMGUTS', 'KRMCMD', 'KRMWNDW', 'KRMRPT', 'KRMIO'$ { This file, KRMMAIN.TEXT, contains the Kermit main program block. It calls the appropriate procedures in the proper order to read a command line, parse it, and execute the command. } PROGRAM KERMIT (input, output, keyboard); import terminal, { for the SerialFlush error recovery } krmguts, command, err_codes, krmrpt, iodeclarations, general_3; const { Command keyword values. Each defined command has an associated value that is returned by parse when its keyword is parsed. } cmd_connect = 1; cmd_exit = 2; cmd_login = 3; cmd_receive = 4; cmd_send = 5; cmd_set = 6; cmd_show = 7; cmd_tn = 8; set_debug = 1; { options of the set command } set_half = 2; set_log = 3; set_verb = 4; var ck : keyword_table_ptr; { pointer to command keyword table } setk : keyword_table_ptr; { pointer to set option keyword table } prompt, word, report, state_msg : text_string; rpos : integer; { position within report } ior : integer; deflogfile, logfile : text_string; procedure initcmd; begin init_cmd_windows; prompt := 'HP-Kermit>'; new(ck); { Build the command keyword table } ck^[1].ks := 'CONNECT'; ck^[1].kv := cmd_connect; ck^[2].ks := 'EXIT'; ck^[2].kv := cmd_exit; ck^[3].ks := 'LOGIN'; ck^[3].kv := cmd_login; ck^[4].ks := 'RECEIVE'; ck^[4].kv := cmd_receive; ck^[5].ks := 'SEND'; ck^[5].kv := cmd_send; ck^[6].ks := 'SET'; ck^[6].kv := cmd_set; ck^[7].ks := 'SHOW'; ck^[7].kv := cmd_show; ck^[8].ks := 'TN'; ck^[8].kv := cmd_tn; ck^[9].ks := ''; { table terminated by null string } ck^[9].kv := 0; new(setk); { set up keyword table for SET options } setk^[1].ks := 'DEBUG'; setk^[1].kv := set_debug; setk^[2].ks := 'HALFDUPLEX'; setk^[2].kv := set_half; setk^[3].ks := 'LOGFILE'; setk^[3].kv := set_log; setk^[4].ks := 'VERBOSITY'; setk^[4].kv := set_verb; setk^[5].ks := ''; setk^[5].kv := 0; end; { procedure initcmd } { proc_command Process command line. Reads a command line and searches the keyword table pointed to by ck. Decodes the keyword, and reads the proper arguments, and branches to the associated action routine. Returns true if the command indicated that the program should exit (eg, EXIT command). } function proc_command : boolean; label 1000; var done : boolean; files : filename_list; setflag : integer; username, password, account : string [80]; begin done := false; parse_init(prompt); parse_keyword_table := ck; { use command keyword table } parse(p_keyword, required); state_msg := 'parsing command keyword'; if check_error( parse_result, state_msg ) then goto 1000; setstrlen(report,0); case arg_integer of cmd_connect, cmd_tn : begin TN; { connect to the host } end; { tn } cmd_exit : done := true; cmd_login : begin parse(p_text, required); if check_error( parse_result, parse_result_str) then goto 1000; username := arg_text; parse(p_password, required); if check_error( parse_result, parse_result_str) then goto 1000; password := arg_text; parse(p_text, optional); if check_error( parse_result, parse_result_str) then goto 1000; account := arg_text; end; { login } cmd_receive : begin parse(p_text, required); if check_error( parse_result, parse_result_str) then goto 1000; parse(p_eol, optional); files[1] := arg_text; { get file name to receive } setstrlen(files[2],0); state_msg := 'Receiving file'; RecvSwitch( files ); { receive the file } if odd(kermit_error) then report_error(file_rcvd_ok,state_msg) else begin report_error(kermit_error,state_msg); goto 1000; end; end; { receive } cmd_send : begin parse( p_text, required ); if check_error( parse_result, parse_result_str) then goto 1000; parse(p_eol, required); files[1] := arg_text; { get file name to send } setstrlen(files[2],0); state_msg := 'Sending file'; SendSwitch( files ); { send the file } if odd(kermit_error) then report_error(file_sent_ok,state_msg) else begin report_error(kermit_error,state_msg); goto 1000; end; end; { send } cmd_set : begin parse_keyword_table := setk; parse( p_keyword, required ); if check_error(parse_result, parse_result_str) then goto 1000; setflag := arg_integer; if setflag in [set_debug, set_half, set_verb] then begin parse(p_boolean, required); if check_error(parse_result, parse_result_str) then goto 1000; end; if setflag = set_log then begin { read log file name } arg_text := ''; parse(p_text, optional); if check_error(parse_result, parse_result_str) then goto 1000; end; { read log file name } parse(p_eol, required); case setflag of set_debug : debug := arg_boolean; set_half : {halfduplex := arg_boolean}; set_log : set_logfile(arg_text); set_verb : verbosity := arg_boolean; end; { case } end; { set } cmd_show : begin parse(p_eol,required); clear_status_window; setstrlen(report,0); strwrite(report,1,rpos,'Verbosity ',verbosity); report_status(report); setstrlen(report,0); strwrite(report,1,rpos,'Debug ',debug); report_status(report); setstrlen(report,0); get_logfile(logfile); strwrite(report,1,rpos,'Log file ',logfile); report_status(report); end; { show } end; { case } 1000: proc_command := done; end; { procedure proc_command } { Main Program } BEGIN try SYSInit; { do system dependent initialization } ParmInit; { initialize parameters to defaults } OneWayOnly := false; Verbosity := FALSE; { default to false / only valid if local } Debug := FALSE; Local := TRUE; deflogfile := ''; set_logfile( deflogfile ); initcmd; { initialize command processor } report_version; repeat KermitInit; { initialize protocol machine and } { default options} until proc_command; { parse command and dispatch to proper command action routine } SYSFinish; { do system dependent cleanup } recover begin writeln; if escapecode = ioescapecode then begin { I/O library error occurred } writeln(ioerror_message(ioe_result)); if ioe_result = 5 { if buffer overflowed } then begin writeln; write(' Serial input buffer overflow : size = '); writeln( SerialData ); writeln('Flushing input buffer'); SerialFlush; end else escape(ioescapecode); end { I/O library error occurred } else begin { not I/O library error } if escapecode = -10 then begin ior := ioresult; writeln('I/O error #',ior:4); end else escape(escapecode); end; { not I/O library error } end; { recover } END. { Program KERMIT } {--file KRMGUTS--} $Debug off$ $UCSD ON$ $SYSPROG$ $SEARCH '*INTERFACE.', '*IO.', 'KRMIO', 'KRMWNDW', 'KRMRPT'$ $PAGE$ { Module KRMGUTS contains the heart of Kermit - the procedures, variables, etc., that actually implement the Kermit protocol. } module krmguts; import ascii_defs, byte_str, byte_io, err_codes, krmrpt, terminal, iodeclarations, general_1, general_3; export const MAXFILES = 10; { maximum number of files that can be sent } type filename_list = array[1..MAXFILES] of filename; var RunType : Transfer_type; { type of transfer currently in effect } Kermit_error : integer; { Error and status conditions left here } Kermit_error_string : string [80]; { operational parameters } Local : boolean; { local/remote flag } OneWayOnly : boolean; { used for testing } Verbosity: boolean; { true to print verbose messages } Debug : boolean; { true to print really verbose debugging msgs } PROCEDURE KermitInit; { initialize various parameters & defaults } PROCEDURE SYSInit; { system dependent initialization } PROCEDURE SYSFinish; { system dependent cleanup } PROCEDURE ParmInit; { initialize operating parameters } { Command entry points } procedure RecvSwitch( files : filename_list ); { Receive file group entry point } procedure SendSwitch( files : filename_list ); { Send file group entry point } procedure TN; { invokes terminal emulator } implement CONST {-%- System Dependent -%-} DEFPARMFILE = 'KERMIT.PRM'; TEMPFILE = 'TEMP.K'; abort_file_key = #X; { ^X aborts single file send } abort_group_key = #Z; { ^Z aborts file group send } { Default transmission parameter definitions. These are assigned to } { the transmission parameter variables by ParmInit when Kermit is } { first started. } DEFTRY = 10; { default for number of retries } DEFTIMEOUT = 12; { default time out } MAXPACK = 94; { max is 94 ~ - ' ' } DEFDELAY = 5; { delay before sending first init for send } NUMPARAM = 6; { number of parameters in init packet } DEFMARK = SOH; { packet start mark } DEFQUOTE = SHARP; { default quote character } DEFPAD = 0; { default number of padding chars } DEFPADCHAR = 0; { default padding character } DEFEOL = CR; { default end of line sequence } DEFEOLTYPE = 2; { 1 = LineFeed 2 = CrLf 3 = Just Cr } NUMBUFFERS = 5; { Number of buffers } { packet types } TYPEB = 66; { ord('B') break packet } TYPEC = 67; { ord('C') Host command packet } TYPED = 68; { ord('D') data packet } TYPEE = 69; { ord('E') error packet } TYPEF = 70; { ord('F') file header packet } TYPEG = 71; { ord('G') generic kermit command packet } TYPEN = 78; { ord('N') NAK packet } TYPER = 82; { ord('R') Receive init packet } TYPES = 83; { ord('S') send init packet } TYPET = 84; { ord('T') ? } TYPEX = 88; { ord('X') Text packet } TYPEY = 89; { ord('Y') ACK packet } TYPEZ = 90; { ord('Z') EOF packet } $PAGE$ TYPE { Data Types for Kermit } Packet = RECORD mark : byte; { SOH character } count: byte; { # of bytes following this field } seq : byte; { sequence number modulo 64 } ptype: byte; { d,y,n,s,b,f,z,e,t packet type } data : ByteString; { the actual data } { chksum is last valid char in data array } { eol is added, not considered part of packet proper } END; EOLtype = (LineFeed,CrLf,JustCr); Ppack = 1..NUMBUFFERS; CType = RECORD check : integer; { checksum summation counter } PacketPtr : integer; { points to next "raw" byte in data field } i : integer; { points to next cooked byte in data field } fld : integer; { packet field counter } t : byte; { raw byte received from remote } finished : boolean; { true if packet completely received } restart : boolean; good : boolean; END; $PAGE$ VAR keyboard : text; { non-echoing standard input file } ior : integer; { error recovery routine saves ioresult } { here } breakchar : byte; { break character for TN mode } ch : char; { scratch character } report : string[120]; { status report string } rpos : integer; { status report string position } { Variables for Kermit } ParmFile : filename; { parameter file name } DiskFile : filedesc; { file being sent or received } EOLforFile : EOLtype; { EOL sequence used for Kermit data } State : kermitstates; { current state of the automaton } SaveState : kermitstates; { holds old state for retries } n,J : integer; { packet sequence number } MaxTry : integer; { maximum number of retries allowed } NumTry : integer; { times this packet retried } OldTry : integer; { times last packet retried } { packet transmission parameters } LocalMark : integer; { packet start mark } RemoteMark : integer; LocalPad : integer; { number of padding characters I need } RemotePad : integer; { number of padding chars to send } LocalPadChar : byte; { padding character I need } RemotePadChar : byte; { padding character to use } LocalTimeOut : integer; { our timeout interval in seconds } RemoteTimeOut : integer; { their timeout interval in seconds } LocalDelay : integer; { delay before sending first init } LocalEOL,LocalQuote : byte; { parms. for us } RemoteEOL, RemoteQuote : byte; { parms. the remote wants } SizeRecv, SizeSend : integer; { buffer sizes for receive and send } { statistics variables } stats : kermit_statistics; { Packet buffers. These are used to hold packets being built as } { received, or assembled for transmission. } Buf : ARRAY [1..NUMBUFFERS] OF packet; ThisPacket : Ppack; { current packet being sent } LastPacket : Ppack; { last packet sent } CurrentPacket : Ppack; { current packet received } NextPacket : Ppack; { next packet being received } DebugPacket : Ppack; { save input to do debug } TOPacket : packet; { Time_Out Packet } TimeLeft : integer; { until Time_Out } PackControl : CType; { variables for receive packet routine } $PAGE$ PROCEDURE Verbose ( c : cstring ); { Print string c if verbosity Called by Field1 Field2 Field3 Field5 SendFile SendEOF SendBreak SendOurInit GetTheirInit ReceiveData } BEGIN IF Verbosity THEN begin setstrlen(report,0); strwrite(report, 1,rpos, c); report_log( report ); end; END; { procedure verbosity } $PAGE$ PROCEDURE PutErr( c : cstring ); { Print error messages. } BEGIN IF Local THEN begin setstrlen(report,0); strwrite(report,1,rpos,c); report_status(report); report_log(report); end; END; { procedure PutErr } $PAGE$ PROCEDURE OverHead ( p , f : integer; VAR o : integer ); { Calculate OverHead as % OverHead := (p-f)*100/f Called by DisplayStatistics } BEGIN IF f <> 0 then o := trunc((p-f)*100/f) else o := 0; END; $PAGE$ PROCEDURE CalRat ( f : integer; t : integer; VAR r : integer ); { Calculate Effective Baud Rate Rate = f*10/t Called by DisplayStatistics } BEGIN r := 0; END; $PAGE$ PROCEDURE Sleep ( t : integer); { pause for t seconds } { Called by SendSwitch } BEGIN END; $PAGE$ PROCEDURE StartTimer; { Called by ReceivePacket } BEGIN TimeLeft := RemoteTimeOut; END; $PAGE$ PROCEDURE StopTimer; { Called by ReceivePacket } BEGIN TimeLeft := MaxInt; END; $PAGE$ FUNCTION MakeChar ( c : byte ) : byte; { Convert integer to printable character. } BEGIN MakeChar := c+BLANK; END; $PAGE$ FUNCTION UnChar ( c : byte ) : byte; { Reverse of MakeChar } BEGIN UnChar := c-BLANK END; $PAGE$ FUNCTION Ctl ( c : byte ) : byte; { Does c XOR 100. } BEGIN IF IsControl(c) THEN c := c+64 ELSE c := c-64; Ctl := c; END; $PAGE$ FUNCTION IsValidPType ( c : byte ) : boolean; { True if c is a valid packet type. Called by Field3 } BEGIN IsValidPType := c in [TYPEB, TYPEC, TYPED, TYPEE, TYPEF, TYPEG, TYPEN, TYPER, TYPES, TYPET, TYPEX, TYPEY, TYPEZ] END; $PAGE$ FUNCTION CheckFunction ( c : integer ) : byte; { Calculate checksum Called by SendPacket Field5 } VAR x: integer; BEGIN { CheckFunction := (c + ( c AND 300 ) /100 ) AND 77; } x := (c MOD 256 ) DIV 64; x := x+c; CheckFunction := x MOD 64; END; $PAGE$ PROCEDURE EnCodeParm ( VAR data : ByteString ); { encode parameters } { Encodes the global parameter variables and places them into the given parameter ByteString. References : SizeRecv LocalTimeOut LocalPad LocalPadChar LocalEOL LocalQuote Called by SendOurInit GetTheirInit DoInitLast } VAR i: integer; BEGIN FOR i:=1 TO NUMPARAM DO data[i] := BLANK; data[NUMPARAM+1] := ENDSTR; data[1] := MakeChar(SizeRecv); { my biggest packet } data[2] := MakeChar(LocalTimeOut); { when I want timeout} data[3] := MakeChar(LocalPad); { how much padding } data[4] := Ctl(LocalPadChar); { my padding character } data[5] := MakeChar(LocalEOL); { my EOL } data[6] := LocalQuote; { my quote char } END; $PAGE$ PROCEDURE DeCodeParm ( VAR data : ByteString ); { decode parameters } { Accepts a parameter string, decodes the values, and places them in the global parameter variables. Modifies : SizeSend RemoteTimeOut RemotePad RemotePadChar RemoteEOL RemoteQuote Called by GetTheirInit } BEGIN SizeSend := UnChar(data[1]); RemoteTimeOut := UnChar(data[2]); { when I should time out } RemotePad := UnChar(data[3]); { padding characters to send } RemotePadChar := Ctl(data[4]); { padding character } RemoteEOL := UnChar(data[5]); { EOL to send } RemoteQuote := data[6]; { quote to send } END; $PAGE$ PROCEDURE ReadParm ( VAR Parms : ByteString ; ParmFile : filename ); { Opens the parameter file, if any, and reads a single line from it into the parameter Parms. If no parameter file exists, returns a null string (i.e., just ENDSTR in the first position). Inputs : ParmFile filename of parameter file Calls Exists Sopen GetLine Called by GetParm } VAR dummy : boolean; fd : filedesc; BEGIN; Parms[1]:=ENDSTR; IF Exists(ParmFile) THEN BEGIN fd := Sopen(ParmFile,IOREAD); dummy := GetLine(Parms,fd,MAXSTR); Sclose(fd); END; END; $PAGE$ PROCEDURE GetParm( ParmFile : filename ); { get parameters from file } { Reads a line from the parameter file via ReadParm and sets the global parameter variables according to the values in the file. Inputs : ParmFile filename of parameter file Modifies SizeRecv LocalTimeOut LocalPad LocalPadChar LocalEOL LocalQuote Calls ReadParm Called by ParmInit SetParameters } VAR data : ByteString; BEGIN; ReadParm(data, ParmFile); IF (length(data) > 0) THEN { get parameters } BEGIN SizeRecv := UnChar(data[1]); LocalTimeOut := UnChar(data[2]); { when I should time out } LocalPad := UnChar(data[3]); { padding characters to send } LocalPadChar := Ctl(data[4]); { padding character } LocalEOL := UnChar(data[5]); { EOL to send } LocalQuote := data[6]; { quote to send } END; END; $PAGE$ PROCEDURE ParmInit; { Initializes transmission parameters (pad character, timeout, etc.) to their default values as defined by the default parameter constants, then reads any new values from the parameter file. Parameter file values thus override the initial 'hardwired' defaults. Calls GetParm Called by Main Program } BEGIN breakchar:=CTRLY; { Set the initial default values } RemotePad := DEFPAD; LocalPad := DEFPAD; RemotePadChar := DEFPADCHAR; LocalPadChar := DEFPADCHAR; LocalMark := DEFMARK; RemoteTimeOut := DEFTIMEOUT; LocalTimeOut := DEFTIMEOUT; LocalDelay := DEFDELAY; SizeRecv := MAXPACK; SizeSend := MAXPACK; RemoteEOL := DEFEOL; LocalEOL := DEFEOL; RemoteQuote := DEFQUOTE; LocalQuote := DEFQUOTE; MaxTry := DEFTRY; CASE DEFEOLTYPE OF 1: EOLforFile := LineFeed; 2: EOLforFile := CrLf; 3: EOLforFile := JustCR; END { case }; { Now read the new defaults from the parameter file } ParmFile := DEFPARMFILE; GetParm( ParmFile ); Local := true; { default to local } END; $PAGE$ {-%- System Dependent -%-} PROCEDURE SYSInit; { Performs system dependent initialization, for example setting the mode of the console terminal. Called once by the main program when Kermit is started. Called by Main Program } begin { procedure SYSInit } ioinitialize; initio; { initialize the byte I/O module } init_data_comm; end; { procedure SYSInit } $PAGE$ {-%- System Dependent -%-} PROCEDURE SYSFinish; { Performs any system dependent cleanup operations, for example resetting the mode of the console terminal to normal. Called once by main program just before Kermit exits. Called by Main Program } BEGIN iouninitialize; END; $PAGE$ PROCEDURE StartRun; { initialization for transaction } { Called just before a transaction is started. Modifies stats.RunTime Calls SerialFlush Called by SendSwitch RecvSwitch } BEGIN SerialFlush; stats.RunTime := 0; END; $PAGE$ { Function DoBreakchar is the break character action routine passed to the procedure emulator when in TN mode. The break character command (i.e., the character typed immediately after the break character) is passed as the argument. If it returns true, the emulator will exit back to its caller. } function DoBreakchar ( c : char ) : boolean; begin DoBreakchar := false; case c of 'c','C': DoBreakchar := true; otherwise begin writeln('Break character commands:'); writeln(' C Break connection'); writeln(' ? This message'); end; end; { case } end; { procedure DoBreakchar } PROCEDURE TN; { This procedure implements the 'terminal emulator' to connect to the host. Calls emulator Called by Main program } BEGIN { procedure TN } write(#12); writeln('Connecting to host'); emulator( chr(CTRLY), DoBreakchar ); write(#12); END; { procedure TN } $PAGE$ PROCEDURE SetParameters( arg : filename ); { Sets new parameter file name, loads new parameters via GetParm. Implicit inputs : Arg filename of file from which to read new parameters Calls GetParm Called by Main Program (invoked by load new parameters command) } var fnm : filename; BEGIN IF (strlen(Arg) > 2) THEN BEGIN ParmFile := arg; { get the new parameter file } { name from the command line } { into ParmFile } GetParm( ParmFile ); { read new parameters } END; END; $PAGE$ PROCEDURE KermitInit; { initialize various parameters & defaults } { Initializes the KERMIT protocol machine and sets the option variables to default values. Calls Called by Main program } BEGIN n := 0; stats.NumSendPacks := 0; stats.NumRecvPacks := 0; stats.NumACKsent := 0; stats.NumNAKsent := 0; stats.NumACKrecv := 0; stats.NumNAKrecv := 0; stats.NumBADrecv := 0; stats.ChInPack := 0; stats.ChInFile := 0; RunType := invalid; DiskFile := IOERROR; { to indicate not open yet } ThisPacket := 1; LastPacket := 2; CurrentPacket := 3; NextPacket := 4; DebugPacket := 5; WITH TOPacket DO BEGIN count := 3; seq := 0; ptype := TYPEN; data[1] := ENDSTR; END; { with } END; { procedure KermitInit } $PAGE$ {-%- System Dependent -%-} procedure FinishUpFile; { clean up the open file } { Called by ErrorPack BuildPacket ReceivePacket } begin Sclose(DiskFile); end; { procedure FinishUpFile } $PAGE$ PROCEDURE DisplayStatistics; { Calls OverHead CalRat Called by ErrorPack BuildPacket ReceivePacket } BEGIN IF ((RunType <> Invalid) AND Local ) THEN with stats do BEGIN OverHead(ChInPack,ChInFile,packet_overhead); CalRat(ChInFile,RunTime,effrate); report_packet_statistics( stats, runtype ); END; { with } END; { procedure DisplayStatistics } $PAGE$ PROCEDURE DisplayPacket ( mes : cstring; VAR p : Ppack ); { where mes = string to be printed preceding packet contents p = index into buf of packet to be displayed Print Debugging Info. Prints the given message on the standard error device, followed by the contents of the given packet as follows: Called by ReSendPacket SendPacket BuildPacket } BEGIN WITH Buf[p] DO BEGIN setstrlen(report,0); strwrite(report,1,rpos, mes, UnChar(count):3, UnChar(seq):3, chr(ptype):3); report_log( report ); BtoS(data, report); report_log( report ); END; { with } END; { procedure DisplayPacket } $PAGE$ PROCEDURE PutOut ( p : Ppack ); { Output Packet } { where p = index into buf of packet to be sent Outputs the given packet, preceded by RemotePad padding characters, to the serial line. Calls Putcf PutCon PutStr Called by ReSendPacket SendPacket } VAR i : integer; BEGIN IF (RemotePad > 0) THEN FOR i := 1 TO RemotePad DO Putcf(RemotePadChar,LineOut); WITH Buf[p] DO BEGIN report_send_packet(UnChar(seq)); { report which packet we're sending } Putcf(mark,LineOut); Putcf(count,LineOut); Putcf(seq,LineOut); Putcf(ptype,LineOut); PutStr(data,LineOut); END; { with } END; { procedure PutOut } $PAGE$ PROCEDURE ReSendPacket; { Re-sends previous packet, which had been renamed to Buf[LastPacket] by SendPacket just after that routine sent it. Modifies stats.ChInPack stats.NumSendPacks Calls PutOut Called by SendPacket } BEGIN stats.NumSendPacks := stats.NumSendPacks+1; stats.ChInPack := stats.ChInPack + RemotePad + UnChar(Buf[LastPacket].count) + 3; IF Debug THEN DisplayPacket('Re-Sending ... ',LastPacket); PutOut(LastPacket); END; $PAGE$ PROCEDURE SendPacket; { sends ThisPacket; leaves it in LastPacket } { Accepts "raw" packet in Buf[ThisPacket]. Encodes count (which is initially the length of the data field), sequence number, and calculates the checksum. After packet is sent, exchanges ThisPacket and LastPacket by swapping pointers, so that ReSendPacket can send it again if necessary. Modifies stats.ChInPack Calls PutOut ReSendPacket CheckFunction DisplayPacket Called by SendACK SendNAK ErrorPack SendFile SendData SendEOF SendBreak SendOurInit GetTheirInit DoInitLast } VAR i,len,chksum : integer; temp : Ppack; BEGIN IF (NumTry <> 1) AND (RunType = Transmit ) THEN ReSendPacket ELSE BEGIN { send fresh packet } WITH Buf[ThisPacket] DO BEGIN mark := LocalMark; { mark } len := count; { save length } count := MakeChar(len+3); { count = 3+length of data } seq := MakeChar(seq); { seq number } chksum := count + seq + ptype; IF ( len > 0) { is there data ? } THEN FOR i:= 1 TO len DO chksum := chksum + data[i]; { loop for data } chksum := CheckFunction(chksum); { calculate checksum } data[len+1] := MakeChar(chksum); { make printable & output } data[len+2] := RemoteEOL; { EOL } data[len+3] := ENDSTR; END; { WITH } stats.NumSendPacks := stats.NumSendPacks+1; IF Debug THEN DisplayPacket('Sending ... ',ThisPacket); PutOut(ThisPacket); IF RunType = Transmit THEN BEGIN stats.ChInPack := stats.ChInPack + RemotePad + len + 6; temp := LastPacket; LastPacket := ThisPacket; ThisPacket := temp; END; END; { send fresh packet } END; { procedure SendPacket } $PAGE$ PROCEDURE SendACK ( n : integer ); { send ACK packet } { Builds an ACK packet for the given sequence number in Buf[ThisPacket] and sends it. Modifies stats.NumACKsent Buf[ThisPacket] Calls SendPacket Called by BuildPacket DoData DoEOF DoBreak DoFile DoEOFLast } BEGIN WITH Buf[ThisPacket] DO BEGIN count := 0; seq := n; ptype := TYPEY; END; SendPacket; stats.NumACKsent := stats.NumACKsent+1; END; $PAGE$ PROCEDURE SendNAK ( n : integer ); { send NAK packet } { Builds a NAK packet for the given sequence number into Buf[ThisPacket] and sends it. Modifies stats.NumNAKsent Buf[ThisPacket] Calls SendPacket Called by GetTheirInit DoData DoFileLast DoEOF DoBreak DoFile DoEOFLast DoInitLast ReceiveFile } BEGIN WITH Buf[ThisPacket] DO BEGIN count := 0; seq := n; ptype := TYPEN; END; SendPacket; stats.NumNAKsent := stats.NumNAKsent+1; END; $PAGE$ PROCEDURE ErrorPack ( c : cstring ); { where c = Error description string to be printed or sent in data field of packet Sends an error packet to the other Kermit with the error string in the data field. Calls PutErr SendPacket Called by GetFile ReceivePacket } BEGIN WITH Buf[ThisPacket] DO BEGIN seq := n; ptype := TYPEE; CtoB(c,data); count := length(data); END; { with } SendPacket; FinishUpFile; DisplayStatistics; END; $PAGE$ PROCEDURE Field1; { Count } { Checks the count field assumed to be in PackControl.t, sets the count field in Buf[DebugPacket] to t itself, and the count field in Buf[NextPacket] to UnChar(t). If the count is not within the proper range, a message will be printed via Verbose and PackControl.good will be set FALSE; otherwise, PackControl.good will be unchanged. References SizeRecv Modifies Buf[NextPacket] Buf[DebugPacket] PackControl Calls Verbose Called by BuildPacket } VAR test: boolean; BEGIN WITH Buf[NextPacket] DO BEGIN WITH PackControl DO BEGIN Buf[DebugPacket].count := t; count := UnChar(t); test := (count >= 3) OR (count <= SizeRecv-2); IF NOT test THEN Verbose('Bad count '); good := good AND test; END; { with PackControl } END; { with NextPacket } END; { procedure Field1 } $PAGE$ PROCEDURE Field2; { Packet Number } { Checks the sequence number field assumed to be in PackControl.t, sets the sequence number field in Buf[DebugPacket] to t itself, and the sequence number field in Buf[NextPacket] to UnChar(t). If the sequence number is not within the proper range, a message will be printed via Verbose and PackControl.good will be set FALSE; otherwise, PackControl.good will be unchanged. Modifies Buf[NextPacket] Buf[DebugPacket] PackControl Calls Verbose Called by BuildPacket } VAR test : boolean; BEGIN WITH Buf[NextPacket] DO BEGIN WITH PackControl DO BEGIN Buf[DebugPacket].seq := t; seq := UnChar(t); test := (seq >= 0) OR (seq <= 63); IF NOT test THEN Verbose('Bad seq number '); good := test AND good; END; END; END; $PAGE$ PROCEDURE Field3; { Packet Type } { Checks the type field assumed to be in PackControl.t, sets the type field in Buf[DebugPacket] and in Buf[NextPacket] to PackControl.t. If the type is not a valid packet type, a message will be printed via Verbose and PackControl.good will be set FALSE; otherwise, PackControl.good will be unchanged. Modifies Buf[NextPacket] Buf[DebugPacket] PackControl Calls Verbose IsValidPType Called by BuildPacket } VAR test : boolean; BEGIN WITH Buf[NextPacket] DO BEGIN WITH PackControl DO BEGIN ptype := t; Buf[DebugPacket].ptype := t; test := IsValidPType(ptype); IF NOT test THEN Verbose('Bad Packet Type '); good := test AND good; END; END; END; $PAGE$ PROCEDURE Field4; { Data } { Places the data character, assumed to be in PackControl.t, into the next position in Buf[DebugPacket].data. This position is assumed to be in PackControl.PacketPtr. Does the proper unquoting, and leaves the unquoted character in the next position of Buf[NextPacket].data. Modifies Buf[NextPacket] Buf[DebugPacket] PackControl Calls -nothing- Called by BuildPacket } BEGIN WITH PackControl DO BEGIN PacketPtr := PacketPtr+1; Buf[DebugPacket].data[PacketPtr] := t; Buf[NextPacket].data[i] := t; i := i + 1; END; { with PackControl } END; { procedure Field4 } $PAGE$ PROCEDURE Field5; { Check Sum } { Places the checksum character, assumed to be in PackControl.t, followed by a terminator, into the next position of Buf[DebugPacket].data. Calls CheckFunction to verify the checksum; if the checksum accumulated for the data does not match the one sent, then outputs an error message via Verbose and sets Good to FALSE, otherwise Good is unchanged. Sets the PackControl.finished. Modifies Buf[NextPacket] Buf[DebugPacket] PackControl Calls Verbose CheckFunction Called by BuildPacket } VAR test : boolean; BEGIN WITH PackControl DO BEGIN PacketPtr := PacketPtr +1; Buf[DebugPacket].data[PacketPtr] := t; Buf[DebugPacket].data[PacketPtr + 1] := ENDSTR; check := CheckFunction(check); check := MakeChar(check); test := (t=check); IF NOT test THEN Verbose('Bad CheckSum '); good := test AND good; Buf[NextPacket].data[i] := ENDSTR; finished := true; { set finished } END; END; $PAGE$ PROCEDURE BuildPacket; { Process received character } { Processes received character, assumed to be in PackControl.t, and adds it to the packet in Buf[NextPacket] according to the state information in PackControl. When the packet is completely received, the packet is checked to see if it is an error packet. If the packet is an error packet, Kermit_error_string will be set to the error packet text, and kermit_error will be set to abort_errpack. FinishUpFile and DisplayStatistics will be called. Returns one of the following error codes in Kermit_error: success Character successfully processed abort_errpack Error packet received from remote Modifies PackControl Buf[NextPacket] CurrentPacket NextPacket stats.NumRecvPacks Calls Field1 Field2 Field3 Field4 Field5 SendACK DisplayPacket Called by ReceivePacket } VAR temp : Ppack; BEGIN kermit_error := success; WITH PackControl DO BEGIN WITH Buf[NextPacket] DO BEGIN IF (t<>ENDSTR) { if a character was read } THEN IF restart THEN BEGIN { read until we get SOH marker } IF (t = SOH) THEN BEGIN { is packet mark } finished := false; { set variables } good := true; seq := -1; { set return values to bad packet } ptype := QUESTION; data[1] := ENDSTR; data[MAXSTR] := ENDSTR; restart := false; fld := 0; i := 1; PacketPtr := 0; check := 0; END; { is packet mark } END { read until we get SOH marker } ELSE BEGIN { have started packet } IF (t=SOH) { check for restart or EOL } THEN restart := true ELSE IF (t=LocalEOL) THEN BEGIN finished := true; good := false; END ELSE BEGIN { not mark or EOL } CASE fld OF { increment field number } 0: fld := 1; 1: fld := 2; 2: fld := 3; 3: { no data } IF (count=3) THEN fld := 5 ELSE fld := 4; 4: { end of data } IF (PacketPtr>=count-3) THEN fld := 5; END { case }; IF (fld<>5) THEN { add into checksum } check := check+t; CASE fld OF 1: Field1; 2: Field2; 3: Field3; 4: Field4; 5: Field5; END; { case } END; { not mark or EOL } END; { have started packet } IF finished THEN BEGIN IF Debug THEN BEGIN DisplayPacket('Received ... ',DebugPacket); IF good THEN report := 'Packet is Good' ELSE report := 'Packet is BAD'; report_log(report); END; { debug } IF (ptype=TYPEE) AND good THEN BEGIN { was error packet } Kermit_error := abort_errpack; BtoS(data, Kermit_error_string); SendACK(n); { send ACK } END; { was error packet } stats.NumRecvPacks := stats.NumRecvPacks+1; temp := CurrentPacket; CurrentPacket := NextPacket; NextPacket := temp; END; { if finished } END; { with Buf[NextPacket] } END; { with PackControl } END; { procedure BuildPacket } $PAGE$ procedure ReceivePacket; { Receives a packet into Buf[NextPacket], which is then renamed to Buf[CurrentPacket] when complete. If the packet is not successfully received, then FinishUpFile will be called. Returns one of the following codes in Kermit_error : success Packet successfully received timeout Timeout while waiting for complete packet abort_file Abort file key typed by user abort_group Abort file group typed by user abort_errpack Error packet received from remote References PackControl Modifies stats.ChInPack Calls SerialIn ConsoleStatus ConsoleIn BuildPacket Called by ReceiveACK GetTheirInit ReceiveData ReceiveFile } label 1000; { go to this when error occurs } var c : char; BEGIN kermit_error := success; { assume success for now } WITH PackControl DO BEGIN StartTimer; finished := false; restart := true; REPEAT t := SerialIn; IF (RunType = Receive) AND (t <> ENDSTR) THEN stats.ChInPack := stats.ChInPack + 1; IF Local { see if character typed on console } THEN if consolestatus then begin { if a character was typed } c := consolein; { read it } if c in [abort_file_key, abort_group_key] then begin { abort file } if c = abort_file_key then kermit_error := abort_file else kermit_error := abort_group; good := false; goto 1000; end { abort file } else t := LocalEOL; END; { if a character was typed } BuildPacket; if Kermit_error <> success then goto 1000; { return this error to caller } UNTIL finished OR (TimeLeft = 0); IF (TimeLeft = 0) { if timed out waiting for packet } THEN BEGIN Buf[CurrentPacket] := TOPacket; restart := true; IF NOT ((RunType=Transmit) AND (State=RecvInit)) THEN BEGIN Kermit_error := timeout; END; END; 1000: If kermit_error <> success then FinishUpFile; if (Kermit_error = abort_file) or (Kermit_error = abort_group) then ErrorPack('Transfer aborted '); StopTimer; DisplayStatistics; END; { with PackControl } END; { procedure ReceivePacket } $PAGE$ FUNCTION ReceiveACK : boolean; { Receive ACK with correct number } { If OneWayOnly is set, then returns TRUE immediately. Receives a packet into CurrentPacket. If it is not received correctly, will return FALSE and the NumXXXRecv counters will be invalid (!?). Otherwise, if it is an ACK packet, increments stats.NumACKrecv. If it is an ACK packet, increments stats.NumNAKrecv. If it is any other type, increments stats.NumBADrecv. If it is an ACK packet and the sequence number number matches the one expected, then will return TRUE. Errors errors returned by ReceivePacket Modifies stats.NumACKrecv stats.NumNAKrecv stats.NumBADrecv Calls ReceivePacket Called by SendFile SendData SendEOF SendBreak SendOurInit } VAR Ok: boolean; BEGIN kermit_error := success; if onewayonly then ReceiveACK := true else begin { look for ACK from remote } ReceivePacket; if not odd(Kermit_error) { if ReceivePacket returned error } then ReceiveACK := false { error receiving packet } else WITH Buf[CurrentPacket] DO BEGIN { packet received ok } IF (ptype=TYPEY) THEN stats.NumACKrecv := stats.NumACKrecv+1 ELSE IF (ptype=TYPEN) THEN stats.NumNAKrecv := stats.NumNAKrecv+1 ELSE stats.NumBADrecv := stats.NumBADrecv +1; { was this packet the one we expected? } ReceiveACK := (ptype=TYPEY) AND (n=seq); END; { packet received ok } end; { look for ACK from remote } END; { function ReceiveACK } $PAGE$ PROCEDURE DataFromFile ( VAR newstate : KermitStates ); { Get data from file into ThisPacket } { Fills the data field of Buf[ThisPacket] with characters from DiskFile, which is assumed to be opened. Characters are read from file via Getcf. The field is terminated by ENDSTR, and the count, sequence and packet type fields are set. If EOF is reached, the file is closed, and newstate and SaveState are set to FileData. Otherwise, newstate is set to whatever SaveState is, and SaveState is left unchanged. References Diskfile Modifies SaveState Buf[ThisPacket] stats.ChInFile Calls Sclose Getcf Called by SendData } VAR x,c : byte; i: integer; BEGIN IF (NumTry=1) { if first time packet sent } THEN BEGIN i := 1; x := ENDSTR; WITH Buf[ThisPacket] DO BEGIN { leave room for quote & NEWLINE } WHILE (i< SizeSend - 8 ) AND (x <> ENDFILE) DO begin x := Getcf(c,DiskFile); { get character and quote if necessary } IF (x<>ENDFILE) THEN IF (IsControl(x)) OR (x=RemoteQuote) THEN BEGIN { control char -- quote } IF (x=NEWLINE) THEN CASE EOLforFile OF { use proper EOL } LineFeed: { ok as is }; CrLf: BEGIN data[i] := RemoteQuote; i := i+1; data[i] := Ctl(CR); i := i+1; { LF will be put in below } END; { CrLf } JustCR: x := CR; END { case }; data[i] := RemoteQuote; i := i+1; IF (x<>RemoteQuote) THEN data[i] := Ctl(x) ELSE data[i] := RemoteQuote; END { control char } ELSE data[i] := x; { it's regular char } IF (x<>ENDFILE) THEN BEGIN i := i+1; { increase count for next char } stats.ChInFile := stats.ChInFile + 1; END; END; { get character and quote if necessary } data[i] := ENDSTR; { terminate ByteString } count := i-1; { set data fieldlength } seq := n; { set sequence number } ptype := TYPED; { set packet type } IF (x=ENDFILE) THEN BEGIN newstate := EOFile; Sclose(DiskFile); DiskFile := ioerror; END ELSE newstate := FileData; SaveState := newstate; { save state } END { with Buf[ThisPacket] do } END { if first time packet sent } ELSE newstate := SaveState; { get old state } END; { procedure DataFromFile } $PAGE$ PROCEDURE SendFile( name : filename ); { send file name packet } { Sends file header packet for the named file. If file does not exist, returns cant_find_file. If file cannot be opened, returns cant_read_file. If attempt to send header fails, leaves state set to FileHeader. If the attempt fails more than MaxTry times, sets state to Abort and returns retry_exhausted. If the file header is succesfully sent (ACKed by other side), sets state to FileData and returns success. Errors Retry Count Exhausted cant_find_file cant_read_file References MaxTry Modifies Buf[ThisPacket] NumTry State n Calls PutErr Verbose SendPacket ReceiveACK Called by SendSwitch } var num : integer; BEGIN Kermit_error := success; IF NumTry > MaxTry THEN BEGIN { retry count exhausted } PutErr ('Send file - Too Many'); Kermit_error := retry_exhausted; State := Abort; { too many tries, abort } END { retry count exhausted } ELSE BEGIN { Open the file and send file header } IF Exists(name) THEN with Buf[ThisPacket] do begin { File already exists. Open it, set up ThisPacket with name of file in data field. Show filename in file status display, send error packet if can't open file. } DiskFile := Sopen(name,IOREAD); count := strlen(name); { set packet length } StoB(name, data); { convert name to Bytestring } { in data field of packet } report_send_file(name); stats.ChInFile := stats.ChInFile + count; seq := n; ptype := TYPEF; IF DiskFile <= IOERROR THEN Kermit_error := cant_read_file; END { file already exists (with) } ELSE begin { file does not exist } kermit_error := cant_find_file; end; { file does not exist } NumTry := NumTry+1; IF Verbosity THEN begin { report sending file header } IF (NumTry = 1) { If first time we're sending file header } THEN num := Buf[ThisPacket].seq ELSE num := Buf[LastPacket].seq; setstrlen(report,0); strwrite(report,1,rpos,'Sending file header packet #', num:1,' for ',name:1); report_log(report); end; { report sending file header } SendPacket; { send this packet } IF ReceiveACK THEN BEGIN NumTry := 0; { reset packet retry count } State := FileData; n := (n+1) MOD 64; END END; { send file header } END; { procedure SendFile } $PAGE$ PROCEDURE SendData; { send file data packets } { Errors Retry Count Exhausted References MaxTry Modifies NumTry State n Calls PutCon PutNum PutErr DataFromFile SendPacket ReceiveACK Called by SendSwitch } VAR newstate: KermitStates; BEGIN IF Verbosity THEN BEGIN setstrlen(report,0); strwrite(report,1,rpos,'Sending data packet #',n:1); report_log(report); END; IF NumTry > MaxTry THEN BEGIN State := Abort; { too many tries, abort } PutErr ('Send data - Too many'); END ELSE BEGIN { send data packet } NumTry := NumTry+1; DataFromFile(newstate); SendPacket; IF ReceiveACK THEN BEGIN { got acknowledgement } State := newstate; NumTry := 0; n := (n+1) MOD 64; END; { got acknowledgement } END; { send data packet } END; { procedure SendData } $PAGE$ PROCEDURE SendEOF; { send EOF packet } { References MaxTry Modifies Buf[ThisPacket] NumTry State n Calls Verbose SendPacket ReceiveACK Called by SendSwitch } BEGIN Verbose ('Sending EOF '); IF NumTry > MaxTry THEN BEGIN State := Abort; { too many tries, abort } PutErr('Send EOF - Too Many '); END ELSE BEGIN { send EOF packet } NumTry := NumTry+1; IF (NumTry = 1) THEN BEGIN { if first time packet sent } WITH Buf[ThisPacket] DO BEGIN ptype := TYPEZ; seq := n; count := 0; END { with } END; { if first time packet sent } SendPacket; IF ReceiveACK THEN BEGIN { got acknowledgement } State := FileHeader; NumTry := 0; n := (n+1) MOD 64; END; { got acknowledgement } END; { send EOF packet } END; { procedure SendEOF } $PAGE$ PROCEDURE SendBreak; { send break packet } { Sends a break packet. If ACKed by other side, sets state to Complete. If not, leaves state set to Break, returns success. However, if the failure exhausted the retry count, sets state to Abort and returns retry_exhausted. Errors retry_exhausted References MaxTry Modifies Buf[ThisPacket] NumTry State n Calls Verbose PutErr SendPacket ReceiveACK Called by SendSwitch } BEGIN Kermit_error := success; Verbose ('Sending break '); IF NumTry > MaxTry THEN BEGIN State := Abort; { too many tries, abort } PutErr('Send break -Too Many'); Kermit_error := retry_exhausted; END ELSE BEGIN { send break packet } NumTry := NumTry+1; { make up packet } IF NumTry = 1 THEN BEGIN WITH Buf[ThisPacket] DO BEGIN ptype := TYPEB; seq := n; count := 0; END END; { with } SendPacket; { send this packet } IF ReceiveACK THEN State := Complete; END; { send break packet } END; { procedure SendBreak } $PAGE$ PROCEDURE SendOurInit; { send init packet } { Send our init packet to the remote, get its init packet, set the remotexxxx parameters from it. References MaxTry OneWayOnly Modifies Buf[ThisPacket] Buf[CurrentPacket] NumTry State n SizeSend RemoteTimeOut RemotePad RemotePadChar RemoteEOL RemoteQuote Calls Verbose PutErr EnCodeParm SendPacket ReceiveACK Called by SendSwitch } BEGIN Verbose ('Sending init '); IF NumTry > MaxTry THEN BEGIN State := Abort; { too many tries, abort } PutErr('Cannot Initialize '); END ELSE BEGIN { send our send init packet } NumTry := NumTry+1; IF (NumTry = 1) THEN BEGIN { if first time packet sent } WITH Buf[ThisPacket] DO BEGIN EnCodeParm(data); count := NUMPARAM; seq := n; ptype := TYPES; END { with } END; { if first time packet sent } SendPacket; { send this packet } IF ReceiveACK THEN BEGIN { got acknowledgment } WITH Buf[CurrentPacket] DO BEGIN IF OneWayOnly { use same data if test mode } THEN data := Buf[LastPacket].data; SizeSend := UnChar(data[1]); RemoteTimeOut := UnChar(data[2]); RemotePad := UnChar(data[3]); RemotePadChar := Ctl(data[4]); RemoteEOL := CR; { default to CR } IF (length(data) >= 5) THEN IF (data[5] <> 0) THEN RemoteEOL := UnChar(data[5]); RemoteQuote := DEFQUOTE; IF (length(data) >= 6) THEN IF (data[6] <> 0) THEN RemoteQuote := data[6]; END; { with } State := FileHeader; NumTry := 0; n := (n+1) MOD 64; END; { got acknowledgement } END; { send our send init packet } END; { procedure SendOurInit } $PAGE$ PROCEDURE SendSwitch( files : filename_list); { Send-switch is the state table switcher for sending files. It loops until either it is finished or a fault is encountered. Routines called by SendSwitch are responsible for changing the state. If an error does occur, Kermit_error is left set to the value put there by the routine that detected the error. References OneWayOnly Modifies State NumTry Calls Sleep StartRun SendData SendFile SendEOF SendOurInit SendBreak Called by Main Program } var nf : integer; done : boolean; BEGIN RunType := Transmit; State := SendInit; { send initiate is the start state } NumTry := 0; { say no tries yet } init_packet_display(runtype); IF (NOT OneWayOnly) THEN Sleep(LocalDelay); nf := 1; { point to first filename } StartRun; done := false; while (not done) do begin CASE State OF FileData: SendData; { data-send state } FileHeader: if strlen(files[nf]) = 0 { if no more files to send } then state := Break else SendFile(files[nf]); { send file name in header } EOFile: begin nf := nf + 1; { point to next file name } SendEOF; { send end-of-file } end; SendInit: SendOurInit; { send initialize } Break: SendBreak; { send break } Complete: { nothing }; Abort: { nothing }; END { case }; done := (State = Abort) OR (State=Complete) or not odd(kermit_error); end; { while } clean_packet_display(runtype); END; $PAGE$ PROCEDURE GetFile ( data : bytestring ); { Creates file with name given by the bytestring data. Assigns it to file descriptor diskfile. References Verbosity Modifies DiskFile Calls Exists ErrorPack Called by DoFile } VAR name : FileName; npos : integer; BEGIN IF DiskFile = IOERROR { if we don't already have a file } THEN begin { create a file } BtoS(data, name); { get the filename from the given ByteString } IF Verbosity THEN begin setstrlen(report,0); strwrite(report,1,rpos,'Creating file ',name); report_log(report); end; { check Max length } IF strlen(name) > FILENAME_LENGTH THEN setstrlen(name, FILENAME_LENGTH); IF Exists(name) THEN BEGIN { if file exists already } setstrlen(report,0); strwrite(report,1,rpos,'File already exists - ',name); setstrlen(name,0); strwrite(name, 1, npos, TEMPFILE:1, n:1); strwrite(report,rpos,rpos, '. Calling new file ',name,' instead.'); report_status(report); END; { if file exists already } DiskFile := Sopen(name,IOWRITE); END; { create a file } IF (Diskfile <= IOERROR) THEN begin { could not create output file } Kermit_error := cant_create_file; ErrorPack('Couldn''t create file'); end; END; { procedure GetFile } $PAGE$ PROCEDURE GetTheirInit; { Receive init packet. Respond with ACK and our parameters. Errors retry_exhausted Retry count exhausted rcvd_bad_init Received Bad Init packet References MaxTry Debug Modifies Buf[ThisPacket] Buf[CurrentPacket] State NumTry n stats.NumACKsent OldTry Calls Verbose ReceivePacket DeCodeParm EnCodeParm SendPacket SendNAK Called by RecvSwitch } VAR rs : boolean; BEGIN IF NumTry > MaxTry THEN BEGIN State := Abort; Kermit_error := retry_exhausted; END ELSE BEGIN { Receive the Send init from remote } Verbose ( 'Receiving Init '); NumTry := NumTry+1; ReceivePacket; IF odd(kermit_error) AND (Buf[CurrentPacket].ptype = TYPES) THEN BEGIN { Good send init packet received } WITH Buf[CurrentPacket] DO BEGIN n := seq; DeCodeParm(data); END; { with } { now send mine } WITH Buf[ThisPacket] DO BEGIN count := NUMPARAM; seq := n; Ptype := TYPEY; EnCodeParm(data); END; SendPacket; stats.NumACKsent := stats.NumACKsent+1; State := FileHeader; OldTry := NumTry; NumTry := 0; n := (n+1) MOD 64 END { good send init packet received } ELSE BEGIN { ReceivePacket returned an error } if (Kermit_error <> abort_file) and (Kermit_error <> abort_group) then kermit_error := rcvd_bad_init; SendNAK(n); END; END; { Receive the Send init from remote } END; $PAGE$ PROCEDURE DataToFile; { output to file } { Writes the data field of Buf[CurrentPacket] to DiskFile, modifiying the end of line sequence (dictated by EOLforFile) to be a single NEWLINE, as required by Putcf. Updates the file character counter stats.ChInFile. Implicit Inputs Buf[CurrentPacket] References EOLForFile DiskFile Modifies stats.ChInFile Calls Putcf Called by DoData } VAR i : integer; { packet data field index } control : boolean; { TRUE if last byte was control prefix } procedure bytetofile( b : byte ); begin { Putcf wants the line terminator to be only a NEWLINE character. If the character is the current Kermit line terminator (depending on EOLforFile) then write a NEWLINE to the file. NB: Here we assume that the NEWLINE character is actually a LF. } CASE EOLforFile OF LineFeed: Putcf(b,DiskFile); { terminator is already a NEWLINE } CrLf: IF b <> CR { don't output CR } THEN Putcf(b,DiskFile); JustCR: IF b = CR { change CR to NEWLINE } THEN Putcf(NEWLINE,DiskFile) ELSE Putcf(b,DiskFile); END; { case } stats.ChInFile := stats.ChInFile + 1; end; { procedure bytetofile } BEGIN { procedure DataToFile } WITH Buf[CurrentPacket] DO BEGIN control := FALSE; for i := 1 to length(data) do begin IF data[i] = LocalQuote THEN IF control { character is quote } THEN begin { quote, quote } bytetofile(LocalQuote); control := FALSE; END { quote, quote } ELSE control := TRUE { set control on } ELSE IF control { not quote } THEN begin { convert to control } bytetofile(Ctl(data[i])); control := FALSE; END ELSE bytetofile(data[i]); end; { for } END; { with CurrentPacket } END; { procedure DataToFile } $PAGE$ PROCEDURE DoData; { Process Data packet } { Processes received data packet, assumed to be in CurrentPacket. If the packet is the expected one, writes the data to the destination file via DataToFile. If it is the previous packet (i.e. the ACK for that packet got lost), ACKs that packet again if the retry count has not reached maximum. If it is any other packet number, the a NAK will be sent for the expected packet. Implicit Inputs Buf[CurrentPacket] Errors Retry count exhausted References MaxTry OldTry Modifies OldTry NumTry n State Calls DataToFile PutErr SendACK SendNAK Called by ReceiveData } BEGIN WITH Buf[CurrentPacket] DO BEGIN IF seq = ((n + 63) MOD 64) THEN BEGIN { it's the previous data packet } IF OldTry>MaxTry { if retried too many times } THEN BEGIN State := Abort; kermit_error := retry_exhausted; END ELSE BEGIN SendACK(seq); NumTry := 0; END; END { it's the previous packet } ELSE BEGIN { it's not the previous one } IF (n<>seq) { if it's not the expected one } THEN SendNAK(n) { NAK the expected one } ELSE BEGIN SendACK(n); { ACK } DataToFile; OldTry := NumTry; NumTry := 0; n := (n+1) MOD 64; END; END; { it's not the previous one } END; { with } END; { procedure DoData } $PAGE$ PROCEDURE DoFileLast; { Process File Packet } { Called by ReceiveData when file header packet received when a data packet expected (ie the sender never got the ACK for the file header). Errors Retry count exhausted References Buf[CurrentPacket] MaxTry Modifies State OldTry NumTry Calls PutErr SendACK SendNAK Called by ReceiveData } BEGIN { File header - last one } IF OldTry > MaxTry { tries ? } THEN BEGIN State := Abort; PutErr('Old file - Too many '); END ELSE BEGIN OldTry := OldTry+1; WITH Buf[CurrentPacket] DO BEGIN IF seq = ((n + 63) MOD 64) { packet number } THEN BEGIN { send ACK } SendACK(seq); NumTry := 0 END ELSE BEGIN SendNAK(n); { NAK } END; END; { with } END; { retry not exhausted } END; { procedure DoFileLast } $PAGE$ PROCEDURE DoEOF; { Process EOF packet } { Called by ReceiveData to process received EOF packets. If not the expected sequence number, NAKs the expected packet, otherwise ACKs it and closes the file. References Buf[CurrentPacket] DiskFile Modifies DiskFile OldTry NumTry State n Calls SendNAK SendACK Sclose Called by ReceiveData } BEGIN { EOF - this one } IF Buf[CurrentPacket].seq<>n { packet number ? } THEN SendNAK(n) { NAK the expected packet } ELSE BEGIN { ACK this one } SendACK(n); Sclose(DiskFile); { close file } DiskFile := IOERROR; OldTry := NumTry; NumTry := 0; n := (n+1) MOD 64; { next packet } State := FileHeader; { change state } END; { ACK this one } END; { procedure DoEOF } $PAGE$ PROCEDURE ReceiveData; { Receive data packets } { Reads packet, dispatches to proper routine if data, EOF, or file header packet. If it is any other type, NAKs the expected data packet. Returns one of the following codes in Kermit_error: success Data packet successfully received retry_ehausted Retry Count Exhausted inv_packet_type Invalid Packet Type errors returned by ReceivePacket References MaxTry Verbosity Local Buf[CurrentPacket] Modifies NumTry Calls ReceivePacket DoData DoFileLast DoEOF Verbose SendNAK Called by RecvSwitch } VAR strend : integer; packetnum : ByteString; good : boolean; BEGIN kermit_error := success; IF NumTry > MaxTry { check number of tries } THEN BEGIN State := Abort; Kermit_error := retry_exhausted; END ELSE BEGIN { retry not exhausted } NumTry := NumTry+1; { increase number of tries } ReceivePacket; { get packet } WITH Buf[CurrentPacket] DO BEGIN IF Verbosity THEN BEGIN PutCon('Receiving (Data) ',STDERR); PutNum(seq,STDERR); END; IF (ptype in [TYPED, TYPEZ, TYPEF]) { check type } AND odd(kermit_error) { and ReceivePacket status } THEN CASE ptype OF TYPED: DoData; TYPEF: DoFileLast; TYPEZ: DoEOF; END { case } ELSE BEGIN { not a good type } Verbose('Expected data pack '); if odd(kermit_error) { if ReceivePacket was successful } then kermit_error := inv_packet_type; SendNAK(n); END; END; { with } END; { retry not exhausted } END; { procedure ReceiveData } $PAGE$ PROCEDURE DoBreak; { Process Break packet } { Called by ReceiveFile to process a break packet. Errors None References Buf[CurrentPacket] n Modifies State Calls SendNAK SendACK Called by ReceiveFile } BEGIN { Break transmission } IF Buf[CurrentPacket].seq<>n { packet number ? } THEN SendNAK(n) { NAK } ELSE BEGIN { send ACK } SendACK(n) ; State := Complete { change state } END END; $PAGE$ PROCEDURE DoFile; { Process file packet } { Called by ReceiveFile to process file header packet. Errors None References Buf[CurrentPacket] Modifies stats.ChInFile OldTry NumTry n State Calls SendNAK SendACK GetFile Called by ReceiveFile } BEGIN WITH Buf[CurrentPacket] DO BEGIN IF seq<>n { packet number ? } THEN SendNAK(n) { NAK } ELSE BEGIN { send ACK } SendACK(n); stats.ChInFile := stats.ChInFile + length(data); GetFile(data); { get file name } OldTry := NumTry; NumTry := 0; n := (n+1) MOD 64; { next packet } State := FileData; { change state } END; { send ACK } END; { with } END; { procedure DoFile } $PAGE$ PROCEDURE DoEOFLast; { Process EOF Packet } { Called by ReceiveFile to process an EOF for the last file (i.e., the ACK for the last EOF was lost). Resends the ACK for the EOF. Errors Retry count exhausted References Buf[CurrentPacket] MaxTry n Modifies State OldTry NumTry Calls PutErr SendACK SendNAK Called by ReceiveFile } BEGIN { End Of File Last One} IF OldTry > MaxTry { tries ? } THEN BEGIN State := Abort; PutErr('Old EOF - Too many '); END ELSE BEGIN { process last EOF packet } OldTry := OldTry+1; WITH Buf[CurrentPacket] DO BEGIN IF seq =((n + 63 ) MOD 64) { packet number } THEN BEGIN { send ACK } SendACK(seq); Numtry := 0; END ELSE SendNAK(n); { NAK } END; { with } END; { process last EOF packet } END; { procedure DoEOFLast } $PAGE$ PROCEDURE DoInitLast; { Called by ReceiveFile when a Send-Init packet was received (i.e. when the ACK for the last Send-Init was lost). Resends the Send-Init. Errors Retry count exhausted References MaxTry Buf[CurrentPacket] NUMPARAM Modifies Buf[ThisPacket] State OldTry NumTry stats.NumACKsent Calls PutErr EnCodeParm SendPacket SendNAK Called by ReceiveFile } BEGIN { Init Packet - last one } IF OldTry>MaxTry { number of tries? } THEN BEGIN State := Abort; PutErr('Old init - Too many '); END ELSE BEGIN { process last init packet } OldTry := OldTry+1; IF Buf[CurrentPacket].seq = ((n + 63) MOD 64) { packet number } THEN BEGIN { send ACK } WITH Buf[ThisPacket] DO BEGIN count := NUMPARAM; seq := Buf[CurrentPacket].seq; ptype := TYPEY; EnCodeParm(data); END; SendPacket; stats.NumACKsent := stats.NumACKsent+1; NumTry := 0; END { send ACK } ELSE SendNAK(n); { NAK } END; { process last init packet } END; { procedure DoInitLast } $PAGE$ PROCEDURE ReceiveFile; { receive file packet } { Receives file header packet from host. Returns one of the following codes in Kermit_error: success file header packet successfully received retry_exhausted Retry count exhausted inv_packet_type Invalid Packet Type errors returned by ReceivePacket References MaxTry Verbosity Debug Modifies Buf[CurrentPacket] NumTry Calls ReceivePacket DoInitLast DoEOFLast DoFile DoBreak SendNAK Called by RecvSwitch } VAR good: boolean; rpos : integer; report, fnm : string[80]; BEGIN kermit_error := success; IF NumTry > MaxTry { check number of tries } THEN BEGIN { retry count exhausted } State := Abort; kermit_error := retry_exhausted; END { retry count exhausted } ELSE BEGIN { get the file header packet } NumTry := NumTry+1; { increase number of tries } ReceivePacket; { get packet } WITH Buf[CurrentPacket] DO BEGIN IF VERBOSITY THEN BEGIN setstrlen(report,0); strwrite(report,1,rpos, 'Receiving file header packet #', seq:1); report_log(report); END; IF (ptype in [TYPES, TYPEZ, TYPEF, TYPEB]) AND odd(kermit_error) THEN CASE ptype OF TYPES: DoInitLast; { ACK to Init packet lost } TYPEZ: DoEOFLast; { ACK to EOF lost } TYPEF: begin { File header } BtoS(data, fnm); report_receive_file(fnm); DoFile; end; { TYPEF } TYPEB: DoBreak; { finished receiving file group } END { case } ELSE BEGIN IF Debug THEN PutErr('Expected File Packet'); if odd(Kermit_error) { if ReceivePacket successful } then kermit_error := inv_packet_type; SendNAK(n); END; END; { with } END; { get the file header packet } END; { procedure ReceiveFile } $PAGE$ procedure SendRecvInit( fnm : filename ); { Sends receive initiate packet with the given filename to the remote server. Called by RecvSwitch } begin { build the Receive Init packet in ThisPacket } with Buf[ThisPacket] do begin StoB(fnm, data); { convert filename into bytestring in data field } count := strlen(fnm); seq := n; ptype := TYPER; { type is Receive Init } end; { with } SendPacket; { send ThisPacket } end; { procedure SendRecvInit } $PAGE$ procedure RecvSwitch( files : filename_list ); { Receive file group state switcher. If filename_list is non-empty, sends receive init packet for the files in it. Modifies State NumTry Calls StartRun ReceiveData GetTheirInit ReceiveFile Called by Main program } var i : integer; fnm : filename; BEGIN RunType := Receive; State := RecvInit; init_packet_display(runtype); NumTry := 0; StartRun; i := 1; while strlen(files[i]) <> 0 do begin fnm := files[i]; i := i + 1; SendRecvInit( fnm ); REPEAT if debug or verbosity then begin { print blank line to separate packet info } report := ''; report_log(report); end; CASE State OF FileData: ReceiveData; RecvInit: GetTheirInit; Break: { nothing }; FileHeader: ReceiveFile; EOFile: { nothing }; Complete: { nothing }; Abort: { nothing }; END; { case } UNTIL (State=Abort) OR (State=Complete ) or (not odd(kermit_error)); end; { while } clean_packet_display(runtype); END; { procedure recvswitch } end. { module krmguts } {--file KRMCMD--} $Search 'KRMWNDW', 'KRMRPT'$ $ucsd on$ module command; import windowlib, err_codes, krmrpt; export const text_string_size = 255; MAXKEYWORDS = 20; required = false; { arguments for parse, tell if arg is optional } optional = true; type breakset_type = set of char; arg_type = (p_char, p_integer, p_text, p_eol, p_boolean, p_password, p_keyword); text_string = string [text_string_size]; keyword_string_type = string [20]; keyword_entry = record ks : keyword_string_type; kv : integer; end; { record } keyword_table = array[1..MAXKEYWORDS] of keyword_entry; keyword_table_ptr = ^keyword_table; var parse_keyword_table : keyword_table_ptr; parse_result : integer; { result of last parse } parse_result_str : text_string; { These are the argument buffers. There is one buffer for each type of argument. } arg_char : char; arg_integer : integer; { holds integers } arg_keyword : keyword_string_type; { holds full keyword text of last parsed keyword } arg_text : text_string; { holds text, keywords, passwords } arg_boolean : boolean; procedure parse_init ( var prompt : string ); procedure parse( arg : arg_type ; opt : boolean ); $page$ implement var eol_parsed : boolean; { cleared by parse_init, set by parse } cur_bufpos : integer; { position of next char to be put in buffer } init_bufpos : integer; { position of first char of this token } parse_buffer : string [80]; function read_kbd_char : char; { Reads a char from the keyboard (non-echoing). If a carriage return is typed, returns a control M (#M). } var c : char; begin if eoln(keyboard) then begin readln(keyboard); c := #13; { carriage return } end else read(keyboard,c); read_kbd_char := c; end; { function read_kbd_char } $page$ { read_break Reads from the terminal until one of a specified set of characters is read. The break character that terminated the read is placed in breakchar. Inputs : buffer Buffer used to accumulate actual characters typed on keyboard, including prompt and break characters init_bufpos Initial position in buffer in which to store the next character read from the keyboard. Will be updated to point to next char. after current input. atom String in which to return the token read (without break characters) breakset Set of characters which, when typed, signal that the token has been completed and that it should now be parsed breakchar Receives the break character actually read echo If true, characters read will be echoed to the screen; if false, they will not be echoed. Returns : Result code, one of the following: success The field was successfully read back_past_field The user backed up past the beginning of this field abort_line The user aborted the line by typing CTRL-U null_string The user typed only a break character } function read_break( var buffer : string; init_bufpos : integer; var cur_bufpos : integer; var atom : string; breakset : breakset_type; var breakchar : char; echo : boolean ) : integer; var c : char; done : boolean; result : integer; bufpos : integer; begin result := success; done := false; bufpos := cur_bufpos; {setstrlen(atom,0);} repeat c := read_kbd_char; case c of #H,#127: begin { backspace or delete } if bufpos > init_bufpos then begin { delete the character } bufpos := bufpos-1; setstrlen( buffer, strlen(buffer)-1); setstrlen( atom, strlen(atom)-1); write_window_char(command_window,#127); end { delete the character } else begin { backing up past beginning of field } write(#7); { beep } result := back_past_field; done := true; end; { backing up past field } end; { backspace or delete } #U: begin { control-U } done := true; result := abort_line; end; { control-U } #R: begin { control-R } end; { control-R } otherwise begin { c is not an editing char } if c >= #32 then begin { if c is printable } setstrlen(buffer,strlen(buffer)+1); buffer[bufpos] := c; bufpos := bufpos + 1; if echo then write_window_char(command_window, c); end; { if c is printable } if not (c in breakset) then if c >= #32 then begin { c is printable } setstrlen(atom,strlen(atom)+1); atom[strlen(atom)] := c; end { c is printable } else begin { c is not printable } write(#7); { beep } end { c is not printable } else begin { c is a break char } breakchar := c; if strlen(atom) <> 0 then result := success else result := null_string; done := true; end; { c is a break char } end; { c is not an editing char } end; { case } until done; read_break := result; cur_bufpos := bufpos; end; { procedure read_break } $page$ function stoi( var s : string ; var i : integer ) : integer; { Converts string to integer. Inputs : s string containing decimal digits to convert i integer to receive the converted value if successful Returns : Status code, one of the following: success Integer converted successfully non_digit Non-digit character encountered overflow Integer overflow null_string Null string given as argument } var e, j, digit : integer; c : char; result : integer; begin result := success; e := 1; i := 0; j := strlen(s); if j = 0 then result := null_string; while (j <> 0) and (result = success) do begin c := s[j]; digit := ord(c) - ord('0'); if (digit < 0) or (digit > 9) then result := non_digit else begin i := i + e*digit; e := e * 10; j := j - 1; end; end; { while } stoi := result; end; { procedure stoi } { Function match returns true if the string test is a valid abbreviation for the string keyword. } function match (var word : string; var keyword : string) : boolean; var result : boolean; j : integer; c : char; begin result := true; if strlen(word) > strlen(keyword) then result := false else begin { could still be abbreviation } j := 1; while (j <= strlen(word)) and (result = true) do begin c := word[j]; { get character from test string } if c >= 'a' then c := chr( ord(c) - ord(' ') ); { uppercase it } if c <> keyword[j] then result := false; j := j+1; end; { while } end; { could still be abbreviation } match := result; end; { function match } $page$ function lookup_key( table : keyword_table; var word : string; var value : integer; var full_word : string ) : integer; { Searches the given keyword table for an entry that matches the given keyword. Inputs : table - keyword table, which is array of records of type keyword_entry. These records consist of the keyword string itself and the integer value assigned to the keyword. word - keyword string to search for. Outputs : value - If a match for the keyword is found, value receives the integer value assigned to the keyword, found in the keyword's record. full_word - if a match for the keyword is found, full_word receives the full keyword text. For example, if the word 'FO' matched the keyword 'FORMS' then full_word would receive 'FORMS'. Returns: Result code, one of success match found for keyword, value contains the keyword's assigned integer value. ambig_keyword given keyword matched more than one table entry no_keyword No table entry matched the given keyword. } var i : integer; { keyword position in table } result : integer; begin i := 1; { point to first keyword in table } result := no_keyword; while (result <> ambig_keyword) and (strlen(table[i].ks) <> 0) do begin if match(word, table[i].ks) then begin { this keyword matches } if result = success then result := ambig_keyword { already found match } else begin { this is first match yet } value := table[i].kv; full_word := table[i].ks; result := success; end; { this is first match yet } end; { this keyword matches } i := i + 1; end; { while } lookup_key := result; end; { procedure lookup_key } $page$ procedure parse_init ( var prompt : string ); begin clear_window(command_window); clear_window(help_window); write_window_string(command_window, prompt); clear_eol_window(command_window); parse_buffer := prompt; init_bufpos := strlen(prompt) + 1; cur_bufpos := init_bufpos; eol_parsed := false; end; { procedure parse_init } $page$ { This procedure, parse, reads an argument of the given type from the command input device (usually the console) and leaves it in the buffer corresponding to that type (there is a buffer for each type of argument). If the argument is optional, as indicated by the second parameter (named optional) being true, then the argument may or may not be given by the user. If it is not, the corresponding buffer will remain unchanged. This allows default values to be set by the set_p_xxx procedures. The value in the buffer may be read by the get_p_xxx functions. Error code will be left in parse_result. A string with an parse error message and the atom causing the error will be left in parse_result_str. } procedure parse( arg : arg_type ; opt : boolean ); label 200,1000; var breakchar : char; read_result : integer; atom, report, title, kwd : string [80]; echo : boolean; added_keyword, kwd_match : boolean; breakset : breakset_type; rpos, i : integer; bk : keyword_table_ptr; { boolean TRUE/FALSE keyword table } procedure do_tab( var s : string ); var pos : integer; begin pos := strlen(s); repeat pos := pos + 1; setstrlen(s,pos); s[pos] := ' '; until pos mod 8 = 0; end; { procedure do_tab } begin parse_result := success; { assume success for now } atom := ''; cur_bufpos := init_bufpos; if arg = p_eol then begin { parsing for EOL } if not eol_parsed then parse_result := not_confirmed; goto 1000; end else { not parsing for EOL } if eol_parsed then begin if not opt then parse_result := parse_after_eol; goto 1000; end; if arg = p_password then echo := false else echo := true; 200: if arg in [p_text, p_integer, p_boolean, p_password, p_keyword] then begin { arg needs a string } if arg = p_text then breakset := ['?', #M] else breakset := ['?', ' ', ',', #M]; read_result := read_break ( parse_buffer, init_bufpos, cur_bufpos, atom, breakset, breakchar, echo ); case read_result of success: begin if breakchar = #M then eol_parsed := true; end; back_past_field: begin parse_result := back_past_field; goto 1000; end; abort_line: begin parse_result := abort_line; goto 1000; end; null_string: begin if breakchar <> '?' then begin parse_result := null_string; goto 1000; end; end; end; { case } end; { arg needs a string } case arg of p_char : begin arg_char := read_kbd_char; end; { p_char } p_integer : begin parse_result := stoi( atom, arg_integer ); end; { p_integer } p_text : begin arg_text := atom; end; { p_text } p_boolean : begin new(bk); bk^[1].ks := 'FALSE'; bk^[1].kv := 0; bk^[2].ks := 'TRUE'; bk^[2].kv := 1; bk^[3].ks := ''; bk^[3].kv := 0; parse_result := lookup_key( bk^, atom, arg_integer, arg_keyword ); arg_boolean := (arg_integer = 1); end; { p_boolean } p_password : begin arg_text := atom; end; { p_password } { Parse a keyword. See if the given string matches any of the entries in parse_keyword_table. } p_keyword : begin if breakchar = '?' then begin { help character typed } clear_window( help_window ); i := 1; setstrlen(report,0); added_keyword := false; repeat kwd := parse_keyword_table^[i].ks; if (strlen(atom) = 0) then kwd_match := true else kwd_match := match(atom,kwd); if (strlen(kwd) <> 0) and kwd_match then begin { add keyword to output string } do_tab(report); rpos := strlen(report)+1; strwrite(report,rpos,rpos,kwd); if strlen(kwd) >=7 then do_tab(report); if not added_keyword { if haven't printed title yet } then begin { print title } title := 'Keyword, one of the following:'; writeln_window_string(help_window, title); added_keyword := true; end; { print title } end; { add keyword to output string } if (strlen(report) > 64) or (strlen(kwd) = 0) then begin { print the accumulated keyword list } writeln_window_string(help_window,report); setstrlen(report,0); rpos := 1; end; { print the accumulated keyword list } i := i+1; until strlen(kwd) = 0; if not added_keyword { if no keywords in list } then begin { print no match msg } title := 'Keyword (no defined keywords match this input)'; writeln_window_string(help_window,title); end; { print no match msg } { remove the break character from the input buffer } setstrlen(parse_buffer, strlen(parse_buffer)-1); cur_bufpos := cur_bufpos - 1; clear_window(command_window); write_window_string(command_window,parse_buffer); goto 200; end { help character typed } else begin { parse the keyword } parse_result := lookup_key( parse_keyword_table^, atom, arg_integer, arg_keyword ); arg_text := atom; end; { parse the keyword } end; { p_keyword } end; { case } 1000: init_bufpos := cur_bufpos; if not (parse_result in [success, abort_line, back_past_field, null_string]) then begin { set up parse error string } setstrlen(parse_result_str,0); strwrite(parse_result_str,1,rpos,'parsing "',atom,'"' ); end; { set up parse error string } end; { procedure parse } end. { module command } {--file KRMIO--} $Debug off$ $UCSD ON$ $SYSPROG$ $SEARCH '*IO.', '*INTERFACE.'$ MODULE ascii_defs; { Defines ASCII character set as decimal numbers } export const { ASCII character set in decimal } SOH = 1; { ascii SOH character } CTRLC = 3; BACKSPACE = 8; TAB = 9; NEWLINE = 10; LF = 10; FORMFEED = 12; CR = 13; { CR } RETURN = 13; CTRLY = 25; CONTROLBAR = 28; BLANK = 32; EXCLAM = 33; { ! } DQUOTE = 34; { " } SHARP = 35; { # } DOLLAR = 36; { $ } PERCENT = 37; { % } AMPER = 38; { & } SQUOTE = 39; { ' } ACUTE = SQUOTE; LPAREN = 40; { ( } RPAREN = 41; { ) } STAR = 42; { * } PLUS = 43; { + } COMMA = 44; { , } MINUS = 45; { - } DASH = MINUS; PERIOD = 46; { . } SLASH = 47; { / } COLON = 58; { : } SEMICOL = 59; { ; } LESS = 60; { < } EQUALS = 61; { = } GREATER = 62; { > } QUESTION = 63; { ? } ATSIGN = 64; { @ } LBRACK = 91; { [ } BACKSLASH = 92; { \ } RBRACK = 93; { ] } CARET = 94; { ^ } UNDERLINE = 95; { _ } GRAVE = 96; { ` } LETA = 97; { lower case ... } LETB = 98; LETC = 99; LETD = 100; LETE = 101; LETF = 102; LETG = 103; LETH = 104; LETI = 105; LETJ = 106; LETK = 107; LETL = 108; LETM = 109; LETN = 110; LETO = 111; LETP = 112; LETQ = 113; LETR = 114; LETS = 115; LETT = 116; LETU = 117; LETV = 118; LETW = 119; LETX = 120; LETY = 121; LETZ = 122; LBRACE = 123; { left brace } BAR = 124; { | } RBRACE = 125; { right brace } TILDE = 126; { ~ } DEL = 127; { rubout } implement end; { Module ascii_defs } $PAGE$ { Module BYTE_STR defines data structures for storing 8-bit "characters", and provides routines for manipulating them. } MODULE byte_str; import ascii_defs; export const ENDSTR = 0; { null-terminated ByteStrings } MAXSTR = 100; { longest possible ByteString } CONLENGTH = 20; { length of constant string } type byte = -1..255; { byte-sized ascii + other stuff } ByteString = ARRAY [1..MAXSTR] OF byte; cstring = PACKED ARRAY [1..CONLENGTH] OF char; FUNCTION length (VAR s : ByteString) : integer; FUNCTION index (VAR s : ByteString; c : byte) : integer; PROCEDURE scopy (VAR src : ByteString; i : integer; VAR dest : ByteString; j : integer); PROCEDURE CtoB ( cs : cstring; VAR bs : ByteString ); PROCEDURE StoB ( VAR s : string; VAR bs : ByteString ); PROCEDURE BtoS ( bs : ByteString; var s : string ); FUNCTION ItoC (n : integer; VAR s : ByteString; i : integer) : integer; { returns index of end of s } FUNCTION IsUpper (c : byte) : boolean; FUNCTION IsControl (c : byte) : boolean; FUNCTION IsPrintable (c : byte) : boolean; implement $PAGE$ { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } FUNCTION length (VAR s : ByteString) : integer; { Computes length of string, not counting the end delimiter (ENDSTR). } VAR n : integer; BEGIN n := 1; WHILE (s[n] <> ENDSTR) DO n := n + 1; length := n - 1 END; $PAGE$ { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } FUNCTION index (VAR s : ByteString; c : byte) : integer; { Find position of character c in ByteString s } VAR i : integer; BEGIN i := 1; WHILE (s[i] <> c) AND (s[i] <> ENDSTR) DO i := i + 1; IF (s[i] = ENDSTR) THEN index := 0 ELSE index := i END; $PAGE$ { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } PROCEDURE scopy (VAR src : ByteString; i : integer; VAR dest : ByteString; j : integer); { Copy ByteString at src[i] to dest[j]. } BEGIN WHILE (src[i] <> ENDSTR) DO BEGIN dest[j] := src[i]; i := i + 1; j := j + 1 END; dest[j] := ENDSTR END; $PAGE$ PROCEDURE CtoB ( cs : cstring; VAR bs : ByteString ); { where cs = packed array of char (PAC) to be converted bs = packed array of byte (ByteString) to receive the converted string Convert PAC constant to ByteString. Called by PutCon ParmInit SendNAK GetFile ReceiveData Main prog } VAR i : integer; BEGIN FOR i:=1 TO CONLENGTH DO bs[i] := ord(cs[i]); bs[CONLENGTH+1] := ENDSTR; END; $PAGE$ PROCEDURE StoB ( VAR s : string; VAR bs : ByteString ); { where s = string to be converted bs = packed array of byte (ByteString) to receive the converted string Converts string to ByteString. Called by GetNextFile } VAR i : integer; BEGIN FOR i:=1 TO strlen(s) DO bs[i] := ord(s[i]); bs[strlen(s)+1] := ENDSTR; END; $PAGE$ PROCEDURE BtoS ( bs : ByteString; var s : string ); var i : integer; CH : CHAR; begin TRY i := 1; s := ''; while bs[i] <> ENDSTR do begin setstrlen(s, strlen(s)+1); s[i] := chr(bs[i]); i := i + 1; end; { while } setstrlen(s,i-1); RECOVER BEGIN if escapecode = -8 then begin { value range error } writeln('Value range error in BtoS : i = ',i:1, ' bs[i] = ',CHR(bs[i])); writeln('Type any char to continue'); READ(CH); end { value range error } else escape(escapecode); END; { RECOVER } end; { procedure BtoS } $PAGE$ { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } FUNCTION ItoC (n : integer; VAR s : ByteString; i : integer) : integer; { returns index of end of s } { where n = integer to be converted s = ByteString in which to return the converted integer i = starting index within s at which to store the first character of converted integer Converts integer n to char ByteString in s[i]. Returns index in s of the character after the last one written. Called by PutNum GetFile ReceiveData } BEGIN IF (n < 0) THEN BEGIN s[i] := ord('-'); ItoC := ItoC(-n, s, i+1) END ELSE BEGIN IF (n >= 10) THEN i := ItoC(n DIV 10, s, i); s[i] := n MOD 10 + ord('0'); s[i+1] := ENDSTR; ItoC := i + 1 END END; $PAGE$ { copyright (c) 1981 university of toronto computing services } FUNCTION IsUpper ( c : byte ) : boolean; { True if c is upper case letter. } BEGIN IsUpper := (c >= ord('A')) AND (c <= ord('Z')) END; $PAGE$ FUNCTION IsControl ( c : byte ) : boolean; { True if character is a control character (ie, if c < 32.). } BEGIN IsControl := (c=DEL ) OR (c < BLANK ); END; $PAGE$ FUNCTION IsPrintable ( c : byte ) : boolean; { True if character is not a control character (ie, if c >= 32.). } BEGIN IsPrintable := NOT IsControl(c); END; end; { module byte_str } $PAGE$ MODULE terminal; { Module terminal provides low level character i/o to the console keyboard (non-echoing), CRT screen, and the datacomm interface. A terminal emulator procedure is also provided which implements a rudimentary (glass TTY) terminal over the datacomm interface. } import ascii_defs, byte_str, iodeclarations, iocomasm, general_0, general_1, general_2, general_3, general_4, serial_0, serial_3; export var { Datacomm interface parameters } comm_bits_per_char : 5..8; comm_stop_bits : real; comm_parity : type_parity; comm_speed : integer; procedure init_data_comm; { sets up serial port } procedure check_data_comm; { maintains serial input buffer } function SerialStatus : boolean; { returns true if serial char ready } function SerialIn : byte; { returns char from serial port } procedure SerialOut( c : byte ); { sends char to serial port } procedure SerialFlush; { flushes serial input buffer } function SerialData : integer; { returns number of chars in buffer } function ConsoleStatus : boolean; { returns true if kybd char typed } function ConsoleIn : char; { returns char typed on console } procedure ConsoleOut ( c : char ); { sends character to console } procedure Emulator ( breakchar : char ; function break_func ( c : char ) : boolean ); { provides glass tty } $PAGE$ implement const comm = 20; { Datacomm select code } bufsize = 5000; { buffer size for datacomm transfers } kbdunit = 2; { Unit number for keyboard } var termbuf : buf_info_type; { buffer for serial input } { init_data_comm must be called before any of the SerialXxx routines. It sets the physical transmission parameters for the datacomm interface, initializes a transfer buffer for incoming characters (termbuf), and starts a transfer into that buffer. For some reason the serial port seems to ignore any incoming characters until it has sent one itself, so NUL is sent to the serial port. } procedure init_data_comm; procedure init_comm_parms; begin comm_bits_per_char := 8; comm_stop_bits := 1; comm_speed := 9600; comm_parity := no_parity; end; begin ioreset(comm); { reset the datacomm card } init_comm_parms; { initialize transmission parameters } iocontrol(comm,22,0); { no flow control protocol } iocontrol(comm,23,0); { no handshake } iocontrol(comm,24,127); { pass all characters } iocontrol(comm,28,0); { card EOL = none } set_baud_rate(comm,comm_speed); set_parity(comm,comm_parity); set_char_length(comm,comm_bits_per_char); set_stop_bits(comm,comm_stop_bits); iobuffer(termbuf,bufsize); { get a ring buffer for datacomm } { incoming characters } transfer(comm,overlap,to_memory,termbuf,bufsize); { initial transfer } writechar(comm, chr(0)); { send null to allow incoming chars } { don't know why... } end; { procedure init_data_comm } $PAGE$ { check_data_comm makes sure that there is an active transfer in progress from the serial port to its buffer (termbuf). It is called automatically by SerialStatus. } procedure check_data_comm; { maintains datacomm input buffers } begin if (termbuf.active_isc = no_isc) and (buffer_data(termbuf)=0) then begin { if buffer is empty and no transfer occurring } transfer(comm,overlap,to_memory,termbuf,bufsize); end; { if buffer empty and no transfer occurring } end; { procedure check_data_comm } { SerialStatus returns true if a character is ready from the serial port. It calls check_data_comm to ensure the buffer is being filled. } function SerialStatus : boolean; begin check_data_comm; { make sure buffer is being filled } SerialStatus := buffer_data (termbuf) <> 0; end; { function SerialStatus } function SerialIn : byte; var ch : char; begin if SerialStatus then begin { character ready } readbuffer(termbuf,ch); { get the character from the buffer } SerialIn := ord( ch ); end else begin { no character ready } SerialIn := ENDSTR; end; end; { function SerialIn } { SerialOut writes the given byte to the serial port. } procedure SerialOut ( c : byte ); begin writechar(comm, chr(c)); end; { procedure SerialOut } { SerialFlush empties the serial input buffer. } procedure SerialFlush; var c : char; begin while (buffer_data(termbuf) <> 0) do readbuffer(termbuf,c); end; { procedure SerialFlush } function SerialData : integer; { returns number of chars. in buffer } begin SerialData := buffer_data(termbuf); end; { function SerialData } $PAGE$ function ConsoleStatus : boolean; { returns true if char available } begin ConsoleStatus := not unitbusy(kbdunit); end; { function ConsoleStatus } function ConsoleIn : char; { returns byte read from keyboard (no echo) } var ch : char; begin if eoln(keyboard) then begin readln(keyboard); ch := chr(NEWLINE); { return NEWLINE if eoln } end else read(keyboard,ch); ConsoleIn := ch; { return of char } end; { function ConsoleIn } procedure ConsoleOut ( c : char ); var c7 : char; begin c7 := chr(binand(ord(c), 127)); { mask off bit 7 } if c7 <> #0 { if not null } then write( c7 ); end; { procedure ConsoleOut } $PAGE$ procedure Emulator ( breakchar : char ; function break_func ( c : char ) : boolean ); { implements terminal emulator } { When the user types the break character, the next character is read (but not sent to the datacomm port). If the second character is also the break character, the break character will be sent to the datacomm port. If it is not, the break_func action routine will be called with that character as the parameter. Note that break_func must be declared in a program block, as must all functions and procedures passed as parameters. If the break_func returns TRUE, the emulator will return to the caller. The datacomm interface is assumed to have been previously initialized via a previous call to init_data_comm. } var serchar : byte; kbdchar : char; done : boolean; begin { procedure Emulator } writeln( 'Entering terminal emulator' ); write ( 'Escape character is '); if breakchar < #32 then writeln('^',chr( ord(breakchar) + 64)) else writeln('''',breakchar,''''); writeln; done := false; repeat if consolestatus { if keyboard char available } then begin kbdchar := ConsoleIn; if kbdchar = breakchar { if break character typed } then begin kbdchar := ConsoleIn; if kbdchar <> breakchar then begin if break_func ( kbdchar ) { then call break_func } then done := true; end else SerialOut(ord(breakchar)); { else send breakchar } end { if break character typed } else SerialOut(ord(kbdchar)) { send char to datacomm } end; { if keyboard char available } if serialstatus { if data ready from datacomm } then begin serchar := SerialIn; ConsoleOut( chr(serchar) ); end; { if data ready from datacomm } until done; end; { procedure Emulator } end; { End MODULE terminal } $PAGE$ MODULE byte_io; import ascii_defs, byte_str, terminal; export const FLEN1 = 10; { length of file name only (without extension) } FLEN2 = 15; { length of filespec (with extension) } FILENAME_LENGTH = 30; LP = 'PRINTER: '; TTYNAME = 'CONSOLE:'; { ByteString name of console (local) terminal that can be given to RESET, REWRITE, etc. } { standard file descriptors. subscripts in open, etc. } STDIN = 1; { these are not to be changed } STDOUT = 2; STDERR = 3; LINEOUT = 4; LINEIN = 5; { other io-related stuff } IOERROR = 0; { status values for open files } IOAVAIL = 1; IOREAD = 2; IOWRITE = 3; MAXOPEN = 15; { maximum number of open files } ENDFILE = -1; type filedesc = IOERROR..MAXOPEN; { file descriptor values } filename = string [FILENAME_LENGTH]; PROCEDURE initio; FUNCTION Getcf ( VAR c: byte; fd : filedesc ) : byte; FUNCTION GetLine ( VAR s : ByteString; fd : filedesc; maxsize : integer ) : boolean; PROCEDURE Putc ( c : byte ); PROCEDURE Putcf ( c : byte; fd : filedesc ); PROCEDURE PutStr (VAR s : ByteString; fd : filedesc); FUNCTION Sopen (name : filename; mode : integer) : filedesc; PROCEDURE Sclose (fd : filedesc); FUNCTION Exists (s : filename) : boolean; PROCEDURE PutNum ( n : integer; fd : filedesc ); PROCEDURE PutCon( x : cstring; fd : filedesc ); implement type ioblock = RECORD { to keep track of open files } filevar : text; mode : IOERROR..IOWRITE; linepos : integer; { character position within line } END; var opencount : integer; openlist : ARRAY [1..MAXOPEN] OF ioblock; { open files } $PAGE$ PROCEDURE initio; { Initializes open file list. Calls Rewrite Called by Main program } VAR i : filedesc; BEGIN openlist[STDIN].mode := IOREAD; openlist[STDOUT].mode := IOWRITE; openlist[STDOUT].linepos := 0; openlist[STDERR].mode := IOWRITE; openlist[STDERR].linepos := 0; openlist[lineout].mode := IOWRITE; openlist[linein].mode := IOREAD; { connect STDERR to user's terminal } rewrite(openlist[STDERR].filevar, TTYNAME); { initialize rest of files } FOR i := linein+1 TO MAXOPEN DO openlist[i].mode := IOAVAIL; END; { procedure initio } $PAGE$ { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } FUNCTION Getcf ( VAR c: byte; fd : filedesc ) : byte; { Reads a character from the given file into the character variable c, and also returns the same character as its value. Can also return ENDFILE or NEWLINE upon end of file or end of line, respectively. If the mode of the file is not IOREAD, Getcf will print an error message on the console and exit the main program. Calls Halt Called by GetLine Exists (but commented out there) DataFromFile } VAR ch : char; BEGIN IF (openlist[fd].mode <> IOREAD) THEN begin writeln('Called Getcf without file.mode=IOREAD'); halt; end; IF (fd = STDIN) THEN IF eoln THEN begin readln; c:= NEWLINE; end ELSE begin read(ch); c := ord(ch); end ELSE IF eof(openlist[fd].filevar) THEN c := ENDFILE ELSE IF eoln(openlist[fd].filevar) THEN BEGIN readln(openlist[fd].filevar); c := NEWLINE END ELSE BEGIN read(openlist[fd].filevar, ch); c := ord(ch) END; Getcf := c END; $PAGE$ { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { GetLine (UCB) -- get a line from file } FUNCTION GetLine ( VAR s : ByteString; fd : filedesc; maxsize : integer ) : boolean; { Reads a line from the given file into the given string, up to the maximum number of characters given. Stops reading after ENDFILE or NEWLINE, or when maxsize characters have been read. NEWLINE will be included in the string, but ENDFILE will not be. String is always terminated by ENDSTR. Note that the string must be able to hold maxsize+1 characters, to accomodate the ENDSTR terminator. Calls Getcf Called by InitCmd ReadParm } VAR i : integer; c : byte; BEGIN i := 1; REPEAT s[i] := Getcf(c, fd); i := i + 1 UNTIL (c = ENDFILE) OR (c = NEWLINE) OR (i >= maxsize); IF (c = ENDFILE) THEN { went one too far } i := i - 1; s[i] := ENDSTR; GetLine := (c <> ENDFILE) END; $PAGE$ PROCEDURE Putc ( c : byte ); { Puts one Byte on standard output. Calls Write Writeln Called by Putcf } BEGIN IF c = NEWLINE THEN writeln ELSE write(chr(c)) END; $PAGE$ { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } PROCEDURE Putcf ( c : byte; fd : filedesc ); { Writes a single character to the file given by fd. Calls Putc SerialOut Writeln Write Called by PutStr PutOut DisplayStatistics DisplayPacket DataToFile } BEGIN with openlist[fd] do begin IF (fd = STDOUT) THEN Putc(c) ELSE if (fd = lineout) then SerialOut(c) else IF c = NEWLINE THEN begin writeln(filevar); linepos := 0; end ELSE begin { char not newline } if c = TAB then begin { expand tab to spaces } repeat write(filevar,' '); linepos := linepos + 1; until (linepos mod 8) = 0; end { expand tab to spaces } else if IsPrintable(c) then begin { write char to file } write(filevar, chr(c)); linepos := linepos + 1; end; { write char to file } end; { char not newline } end; { with } END; { procedure PutCf } $PAGE$ { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } PROCEDURE PutStr (VAR s : ByteString; fd : filedesc); { Put out string on file given by f. Calls Putcf Called by PutCon PutNum PutOut DisplayPacket BuildPacket GetNextFile SendFile GetFile DataToFile ReceiveData ReceiveFile Main Program } VAR i : integer; BEGIN i := 1; WHILE (s[i] <> ENDSTR) DO BEGIN Putcf(s[i], fd); i := i + 1 END END; $PAGE$ FUNCTION Sopen (name : FileName; mode : integer) : filedesc; { Opens a file for reading or writing. Calls Called by Exists ReadParm GetNextFile GetFile Main program } VAR i : integer; found : boolean; BEGIN { find a free slot in openlist } Sopen := IOERROR; found := false; i := 1; WHILE (i <= MAXOPEN) AND (NOT found) DO BEGIN IF (openlist[i].mode = IOAVAIL) THEN BEGIN openlist[i].mode := mode; IF (mode = IOREAD) THEN begin reset(openlist[i].filevar, name); end ELSE begin rewrite(openlist[i].filevar, name); openlist[i].linepos := 0; end; Sopen:=i; found := true END; i := i + 1; END; { while } END; { procedure Sopen } $PAGE$ PROCEDURE Sclose (fd : filedesc); { Called by Exists ReadParm DisplayStatistics DataFromFile DoEOF } BEGIN IF (fd > STDERR) AND (fd <= MAXOPEN) THEN BEGIN openlist[fd].mode := IOAVAIL; close(openlist[fd].filevar,'LOCK'); END END; { procedure Sclose } $PAGE$ FUNCTION Exists (s : FileName) : boolean; { Returns true if file exists. Calls Sopen Sclose Getcf Called by ReadParm GetNextFile GetFile Main prog } VAR fd : filedesc; ior : integer; { saves io result } BEGIN try Exists := false; fd := Sopen(s,IOREAD); Sclose(fd); Exists := true; recover if escapecode = -10 { if IO error occurred } then begin ior := ioresult; if not (ior in [9,10]) then writeln('Error in file operation - #',ior:4) end { if IO error occurred } else escape(escapecode); END; { procedure Exists } $PAGE$ PROCEDURE PutNum ( n : integer; fd : filedesc ); { Ouputs number n to the file given by fd preceded by a leading blank. Uses ItoC to convert the number. Calls ItoC Called by PutOut DisplayStatistics DisplayPacket SendData ReceiveData ReceiveFile } VAR s: ByteString; dummy: integer; BEGIN s[1] := BLANK; dummy := ItoC(n,s,2); PutStr(s,fd); END; $PAGE$ PROCEDURE PutCon( x : cstring; fd : filedesc); { Outputs a literal string preceded by a NEWLINE. Calls PutStr CtoB Called by InitCmd PutOut DisplayStatistics DisplayPacket ErrorPack Verbose PutErr BuildPacket SendData GetFile ReceiveInit ReceiveData ReceiveFile } VAR i: integer; s: ByteString; BEGIN s[1] := NEWLINE; s[2] := ENDSTR; PutStr(s,fd); CtoB(x,s); PutStr(s,fd); END; end. { module byte_io } {--file KRMWNDW--} $DEBUG OFF$ $ucsd on$ module windowlib; export const screen_y_max = 23; screen_x_max = 79; type window_type = record xmin_abs, xmax_abs : integer; ymin_abs, ymax_abs : integer; xsize, ysize : integer; current_x : integer; current_y : integer; end; { record } window_ptr = ^window_type; function init_window ( xmin, xmax : integer; ymin, ymax : integer ) : window_ptr; procedure gotoxy_window ( w : window_ptr; x, y : integer ); procedure window_newline ( w : window_ptr ); procedure write_window_char ( w : window_ptr; c : char ); procedure write_window_string ( w : window_ptr; var s : string ); procedure writeln_window_string ( w : window_ptr; var s : string ); procedure clear_eol_window( w : window_ptr ); procedure clear_end_window( w : window_ptr ); procedure clear_window ( w : window_ptr ); implement var cursor_x, cursor_y : integer; { screen cursor coordinates } function init_window ( xmin, xmax : integer; ymin, ymax : integer ) : window_ptr; var pw : window_ptr; begin new(pw); with pw^ do begin xmin_abs := xmin; xmax_abs := xmax; ymin_abs := ymin; ymax_abs := ymax; xsize := xmax - xmin; ysize := ymax - ymin; current_x := 0; current_y := 0; end; { with } init_window := pw; end; { function init_window } procedure pos_cursor( w : window_ptr ); begin with w^ do begin cursor_x := current_x + xmin_abs; cursor_y := current_y + ymin_abs; { special case : keep the cursor off the last position to keep the screen from scrolling } if (cursor_y = screen_y_max) and (cursor_x = screen_x_max) then cursor_x := screen_x_max - 1; gotoxy( cursor_x, cursor_y ); end; { with } end; { procedure pos_cursor } { put_screen puts the given character on the screen at the position specified by the current cursor coordinates cursor_x and cursor_y } procedure put_screen( c : char ); begin write(c); end; { procedure put_screen } procedure gotoxy_window ( w : window_ptr; x, y : integer ); begin with w^ do begin current_x := x; current_y := y; if (x < 0) then current_x := 0; if (x > xsize) then current_x := xsize; if (y < 0) then current_y := 0; if (y > ysize) then current_y := ysize; end; { with } end; { procedure gotoxy_window } procedure step_cursor ( w : window_ptr ); begin with w^ do begin current_x := current_x + 1; if current_x > xsize then begin { cursor went past x boundary } current_x := 0; current_y := current_y + 1; if current_y > ysize then current_y := 0; end; { cursor went past x boundary } end; { with } end; { procedure step_cursor } procedure back_cursor ( w : window_ptr ); begin with w^ do begin current_x := current_x -1; if current_x < 0 then begin { x went back past start of line } current_x := xsize; current_y := current_y - 1; if current_y < 0 then current_y := ysize; end; { x went back past start of line } end; { with } end; { procedure back_cursor } procedure window_newline ( w : window_ptr ); begin with w^ do begin current_x := xsize; step_cursor( w ); pos_cursor( w ); clear_eol_window( w ); end; { with } end; { procedure window_newline } procedure write_window_char ( w : window_ptr; c : char ); begin if c = #127 then begin { rubout } back_cursor( w ); pos_cursor( w ); put_screen(' '); pos_cursor( w ); end { rubout } else begin { printing character } pos_cursor( w ); put_screen(c); step_cursor ( w ); end; { printing character } end; { procedure write_window_char } procedure write_window_string ( w : window_ptr; var s : string ); var i : integer; begin for i := 1 to length(s) do write_window_char( w, s[i] ); end; { procedure write_window_string } procedure writeln_window_string ( w : window_ptr; var s : string ); begin write_window_string (w, s); window_newline( w ); end; { procedure writeln_window_string } procedure clear_eol_window( w : window_ptr ); var x, y : integer; begin with w^ do begin x := current_x; y := current_y; pos_cursor ( w ); if xmax_abs = screen_x_max then write(#9) else while current_x <= xsize do begin write(' '); current_x := current_x + 1; end; { while } end; { with } gotoxy_window( w, x, y ); { restore initial position } pos_cursor( w ); end; { procedure clear_eol_window } procedure clear_end_window( w : window_ptr ); var x, y : integer; begin with w^ do begin x := current_x; y := current_y; while current_y <= ysize do begin clear_eol_window( w ); current_x := 0; current_y := current_y + 1; end; { while } end; { with } gotoxy_window( w, x, y ); { restore initial position } end; { procedure clear_end_window } procedure clear_window ( w : window_ptr ); begin gotoxy_window(w, 0,0); { go to upper left hand corner } clear_end_window( w ); { clear to the end of the window } end; { procedure clear_window } end. { module windowlib } {--file KRMRPT} $SEARCH 'KRMWNDW', '*IO.', '*INTERFACE.'$ { This file, KRMRPT.TEXT, contains the error and status reporting modules used by all other Kermit modules. The following modules reside in this file: ERR_CODES Error code definitions KRMRPT Error and status reporting procedures The module KRMRPT includes the file KRMVERS.TEXT, which declares the version string constant VERSION_STRING. } { Module ERR_CODES defines the integer error code values that can be returned by a procedure to indicate whether it completed successfully, or, if not, what error occurred. Successful and warning error codes are odd (low order bit set), and indicate that all went reasonably well. Failing error codes are even (low order bit clear), and indicate that something happened that kept a routine from doing what it was supposed to. Function ERRSTR returns the error message string associated with the given error code. All Kermit modules have access to ERR_CODES. } module err_codes; export const error_string_length = 80; { Maximum length of error strings } { Facility code definitions. These codes identify the facility generating the error. } cmdfac = 1*128; { command interpreter } trmfac = 2*128; { terminal emulation code } iofac = 3*128; { IO error } krmfac = 4*128; { kermit protocol machine } { Status code definitions. Successful return codes are odd, those corresponding to error conditions are even. Returned by functions, etc. } success = 1; file_rcvd_ok = 3; { file received successfully } file_sent_ok = 5; { file transmitted successfully } inv_packet_type = 7; { unexpected packet type received } { Error condition status codes } { Codes returned by lookup_key in module command } ambig_keyword = 2; no_keyword = 4; { Codes returned by parse in module command } not_confirmed = 6; integer_error = 8; no_match = 10; non_digit = 12; { Non-digit character encountered } integer_overflow = 14; { Integer overflow } null_string = 16; { null string given as argument } parse_after_eol = 18; { parse called after eol parsed } { Codes returned by read_break in module command } back_past_field = 20; abort_line = 22; { Codes returned by Kermit protocol procedures in module krmguts } retry_exhausted = 24; timeout = 26; abort_file = 28; abort_group = 30; abort_errpack = 32; rcvd_bad_init = 34; cant_read_file = 36; cant_write_file = 38; cant_create_file = 40; cant_find_file = 42; type error_string = string[error_string_length]; function errstr ( errcode : integer ) : error_string; $page$ implement function errstr ( errcode : integer ) : error_string; { Returns the error string associated with each error. } var s : error_string; begin case errcode of success: s := 'Success'; inv_packet_type: s := 'Unexpected packet type received'; file_rcvd_ok: s := 'File received successfully'; file_sent_ok: s := 'File sent successfully'; { Codes returned by lookup_key } ambig_keyword: s := 'Ambiguous keyword'; no_keyword: s := 'No keywords match this input'; { Codes returned by parse } not_confirmed: s := 'Not confirmed'; integer_error: s := 'Error reading integer'; no_match: s := 'No defined keywords match this input'; non_digit: s := 'Non-digit character encountered'; integer_overflow: s := 'Integer overflow'; null_string: s := 'Null string given as argument'; parse_after_eol: s := 'Parse called after end of line parsed'; { Codes returned by read_break } back_past_field: s := 'Input deleted past beginning of field'; abort_line: s := 'Line aborted by CTRL-U'; { Codes returned by Kermit protocol procedures } retry_exhausted: s := 'Retry count exhausted'; timeout: s := 'Timeout'; abort_file: s := 'File transfer aborted by user'; abort_group: s := 'File group transfer aborted by user'; abort_errpack: s := 'Transfer aborted by error packet from remote'; cant_read_file: s := 'Cannot open file for reading'; cant_write_file: s := 'Cannot open file for writing'; cant_create_file: s := 'Cannot create file'; cant_find_file: s := 'File does not exist'; end; { case } errstr := s; end; { function errstr } end; { module err_codes } $PAGE$ { Module KRMRPT handles error and status reporting for the rest of Kermit. Basically, except for command echoing, anything that is displayed on the screen is put there by procedures in this module. These procedures do the proper text formatting, positioning, etc., and then call procedures in module WINDOWLIB (in file KRMWNDW.TEXT) to actually do the screen output. All Kermit modules have access to KRMRPT. } module krmrpt; import windowlib, err_codes; export $INCLUDE 'KRMVERS.TEXT'$ { This file has const declarations for the version variables VERSION_NUM and VERSION_DATE, which are string constants } var help_window, command_window, error_window, stat_window : window_ptr; type { Packet transfer statistics record } kermit_statistics = record NumSendPacks : integer; { number of packets sent } NumRecvPacks : integer; { number of packets received } NumACKsent : integer; { number of ACKs we've sent } NumNAKsent : integer; { number of NAKs we've sent } NumACKrecv : integer; { number of ACKs we've received } NumNAKrecv : integer; { number of NAKs we've received } NumBADrecv : integer; { number of non-ACKs we've received when } { waiting for an ACK } RunTime: integer; { elapsed time for current transaction } ChInFile : integer; { number of characters in file } ChInPack : integer; { number of characters in packets } packet_overhead : integer; { percent overhead of packetizing } effrate : integer; { effective baud rate of transfer } end; { record } KermitStates = (FileData,RecvInit,SendInit,Break, FileHeader,EOFile,Complete,Abort); Transfer_type = (Transmit, Receive, Invalid); procedure set_logfile( var fnm : string ); procedure get_logfile( var fnm : string ); procedure report_version; procedure report_status( var report : string ); procedure report_log( var report : string ); procedure report_error( code : integer; var where_msg : string ); procedure init_cmd_windows; procedure clear_status_window; procedure init_packet_display( runtype : transfer_type ); procedure clean_packet_display( runtype : transfer_type ); procedure report_send_packet( seq : integer ); procedure report_receive_file( var fnm : string ); procedure report_send_file( var fnm : string ); procedure report_packet_statistics( stats : kermit_statistics; runtype : transfer_type ); function check_error( code : integer; var where_msg : string ) : boolean; implement const send_packet_y = 2; packet_stat_x = 25; packet_stat_y = 4; stat_random_x = 0; stat_random_y = 14; file_report_x = 0; file_report_y = 0; var log_filename : string[50]; log_file : text; log_on : boolean; send_packet_x : integer; { window coords of send packet # } report : string[80]; rpos : integer; procedure set_logfile( var fnm : string ); begin if strlen(fnm) = 0 then begin log_on := false; log_filename := 'OFF'; end else begin log_on := true; log_filename := fnm; rewrite(log_file,log_filename); end; end; { procedure set_logfile } procedure get_logfile( var fnm : string ); begin fnm := log_filename; end; { procedure get_logfile } procedure report_version; var vs : string[80]; p : integer; { dummy for strwrite } begin strwrite(vs,1,p,VERSION_STRING); writeln_window_string(stat_window,vs); end; { procedure report_version } procedure report_status( var report : string ); begin writeln_window_string( stat_window, report ); end; { procedure report_status } procedure report_log( var report : string ); begin if log_on then writeln(log_file, report); end; { procedure report_status } procedure report_error( code : integer; var where_msg : string ); var report : string [80]; rpos : integer; begin setstrlen(report,0); if odd(code) then strwrite(report,1,rpos,errstr(code)) else strwrite(report,1,rpos,'?Error ',where_msg, ' - ', errstr(code)); clear_window(error_window); writeln_window_string( error_window, report ); end; { procedure report_error } $page$ procedure init_cmd_windows; begin stat_window := init_window(0,screen_x_max, 0,16); help_window := init_window(0,screen_x_max, 17,20); command_window := init_window(0,screen_x_max, 21,21); error_window := init_window(0,screen_x_max, 22,23); end; { procedure init_cmd_windows } procedure clear_status_window; begin clear_window(stat_window); end; { procedure clear_status_window } procedure init_packet_display( runtype : transfer_type ); var lab : string[80]; begin clear_window(stat_window); lab := 'Sending Packet # '; send_packet_x := strlen(lab); gotoxy_window(stat_window, 0, send_packet_y); writeln_window_string( stat_window, lab); clear_eol_window(stat_window); gotoxy_window( stat_window, 0, packet_stat_y ); setstrlen(report,0); strwrite(report,1,rpos,'Packets sent'); report_status(report); setstrlen(report,0); strwrite(report,1,rpos,'Packets received'); report_status(report); setstrlen(report,0); if runtype = transmit then strwrite(report,1,rpos,'Total chars. sent') else strwrite(report,1,rpos,'Total chars. rcvd'); report_status(report); setstrlen(report,0); if runtype = transmit then strwrite(report,1,rpos,'Data chars. sent') else strwrite(report,1,rpos,'Data chars. rcvd'); report_status(report); setstrlen(report,0); strwrite(report,1,rpos,'Overhead (%)'); report_status(report); setstrlen(report,0); strwrite(report,1,rpos,'Effective Rate'); report_status(report); setstrlen(report,0); strwrite(report,1,rpos,'Number of ACK'); report_status(report); setstrlen(report,0); strwrite(report,1,rpos,'Number of NAK'); report_status(report); IF (RunType = Transmit) THEN BEGIN setstrlen(report,0); strwrite(report,1,rpos,'Number of BAD'); report_status(report); END; gotoxy_window(stat_window, stat_random_x, stat_random_y); end; { procedure init_packet_display } procedure clean_packet_display( runtype : transfer_type ); begin gotoxy_window(stat_window, 0, send_packet_y); clear_eol_window(stat_window); end; { procedure clean_packet_display } procedure report_send_packet( seq : integer ); begin gotoxy_window(stat_window, send_packet_x, send_packet_y); setstrlen(report,0); strwrite(report,1,rpos,seq:1); write_window_string(stat_window, report); clear_eol_window(stat_window); gotoxy_window(stat_window, stat_random_x, stat_random_y); end; { report_send_packet } procedure report_send_file( var fnm : string ); begin gotoxy_window(stat_window, file_report_x, file_report_y); setstrlen(report,0); strwrite(report,1,rpos,'Sending file ',fnm); write_window_string(stat_window, report); clear_eol_window(stat_window); gotoxy_window(stat_window, stat_random_x, stat_random_y); end; { procedure report_send_file } procedure report_receive_file( var fnm : string ); begin gotoxy_window(stat_window, file_report_x, file_report_y); setstrlen(report,0); strwrite(report,1,rpos,'Receiving file ',fnm); write_window_string(stat_window, report); clear_eol_window(stat_window); gotoxy_window(stat_window, stat_random_x, stat_random_y); end; { procedure report_receive_file } procedure report_packet_statistics( stats : kermit_statistics; runtype : transfer_type ); var row : integer; procedure report_num( i : integer ); begin setstrlen(report,0); strwrite(report,1,rpos,i:5); gotoxy_window(stat_window, packet_stat_x, row); write_window_string(stat_window,report); row := row + 1; end; { procedure report_num } begin row := packet_stat_y; report_num(stats.NumSendPacks); report_num(stats.NumRecvPacks); report_num(stats.ChInPack); report_num(stats.ChInFile); report_num(stats.packet_overhead); report_num(stats.effrate); IF (RunType = Transmit) THEN BEGIN { for transmit } report_num(stats.NumACKrecv); report_num(stats.NumNAKrecv); report_num(stats.NumBADrecv); END { for transmit } ELSE BEGIN { for Receive } report_num(stats.NumACKsent); report_num(stats.NumNAKsent); END; { for Receive } gotoxy_window(stat_window, stat_random_x, stat_random_y); end; { procedure report_packet_statistics } $page$ { check_error Checks given condition code. Returns false if code is successful. If code is error code, prints associated error message and returns true. } function check_error( code : integer; var where_msg : string ) : boolean; var ret : boolean; begin ret := false; if not odd(code) { successful conditions are odd, failing (error) conditions are even } then begin report_error( code, where_msg ); ret := true; end; check_error := ret; end; { procedure check_error } end. { module krmrpt }