20-May-88 14:33:11-EDT,112639;000000000001 Return-Path: <@CUVMA.COLUMBIA.EDU:VIC@QUCDN.BITNET> Received: from CUVMA.COLUMBIA.EDU by CU20B.COLUMBIA.EDU with TCP; Fri 20 May 88 14:32:38-EDT Received: from CUVMA.COLUMBIA.EDU(MAILER) by CUVMA.COLUMBIA.EDU(SMTP) ; Fri, 20 May 88 14:24:17 EDT Received: from QUCDN.NETNORTH by CUVMA.COLUMBIA.EDU (Mailer X1.25) with BSMTP id 1343; Fri, 20 May 88 14:24:06 EDT Received: by QUCDN (Mailer X1.24) id 2511; Fri, 20 May 88 14:08:09 EDT Date: Fri, 20 May 88 14:04 EDT From: VIC%QUCDN.BITNET@CUVMA.COLUMBIA.EDU To: sy.fdc@cu20b.columbia.edu Subject: pascalvs kermit-cms Well if you are going stash away a copy of the pascalvs kermit some where, you might as well stash the latest version of it. I have attached our latest version of kermit-cms below. Victor Lee. ------------cut here ------------------------------------------------------- PROGRAM KERMIT ; (* ***************************************************************** *) (* KERMIT - File transfer Program. *) (* Author - Victor Lee, Queen's University, Kingston, Canada *) (* VIC at QUCDN *) (* Date - 1983 December *) (* 1984 January - added KERMIT server code. *) (* 1984 April - new linemode facility for series1. *) (* - fix DEL char recognition. *) (* - If the 8th bit is set for a ASCII char *) (* the 8th bit quote char will be store *) (* in the file as 80 hex char and not an"&" *) (* which is the default bit8 quote char. *) (* 1984 August - send nak if we get a N type packet *) (* instead of aborting immediately. *) (* *) (* 1984 September- when sending a file to the micro a 80hex *) (* character will be treated as an 8th bit *) (* flag for the character to follow. This *) (* will permit WORDSTAR file to be sent *) (* back to the micro without distortion. *) (* 1985 January - assume all non-KERMIT commands to be *) (* CMS commands. *) (* 1985 February - Eliminate leading blanks in commands. *) (* 1985 February - Add an initial 'Receive Packet' to the *) (* receive command just incase the other *) (* Kermit can act as a SERVER. Also *) (* Kermit to be fired off with parameters *) (* which is usefull if the other kermit *) (* is a server kermit. *) (* Include send and receive "AS" function. *) (* Implement other server functions such *) (* as TYPE and ERASE. *) (* Implement break on sending files.i.e. *) (* Control X,Z,C,and E. *) (* 1985 April 3 - Add two byte Checksum and CRC checksum. *) (* 1985 April 15 - Add some advance server functions such *) (* DIRECTORY, ERASE, and TYPE. *) (* 1985 May 22 - New Series/1 I/O . LINEMODE not needed *) (* 1985 July 25 - Fix multiple Receive file bug. *) (* - Save and Restore current term settings *) (* and turn MSG back ON. *) (* - Look at PARMS for first command *) (* 1985 Sept 6 - Add Rename command and fix commands *) (* to accept d:fn.ft format. *) (* 1985 Sept 27 - Fix RECVCHAR bug caused by a garbage *) (* null char . *) (* - Fix FILETOPACKET which prevents creation *) (* of a too large of a packet. *) (* - Add ONERROR procedure. *) (* 1985 Nov 1 - Fix RECEIVE file with parameter bug *) (* due to stricter pascal checking. *) (* 1985 Dec 5 - Non CR EOL char bug fixed. *) (* 1985 Dec 6 - Ignore NUL chars in RECVCHAR. *) (* 1986 Feb 11 - Fix repeat char bug in RECVFILE procedure*) (* 1986 April 25 - Allow setting translate via remote *) (* Kermit command . *) (* 1986 April 30 - Add DATE and TIME setting via the *) (* VARIABLE command . *) (* 1986 May 8 - Allow large binary files to be transfer- *) (* red by using RECFM = F which will not *) (* use CR LF as EOL marker. *) (* 1986 May 16 - Do not use CR LF to produce and EOLine *) (* for all binary files (TRANSLATION OFF). *) (* In order to retreive files which uses *) (* EOLine for CRLF , set LRECL = OLD other- *) (* wise LRECL should be a numeric value. *) (* 1986 July 2 - If no DOT separator between filename and *) (* filetype, look for a blank separator. *) (* - Quote the REPEATCHAR if it is found in *) (* the file to be sent. *) (* 1986 July 24 - Fix bug in REMOTECOMMAND type 'R' which *) (* could get an improper filename length. *) (* - Fix to throw away grabbage at the begin- *) (* ing of the packet (before the SOH). *) (* - Fix REPEATCHAR bug in RECVFILE. *) (* 1987 Jan 7 - Check for seq number to prevent duplicate*) (* packets. *) (* *) (* 1988 March 2 - Long Packet code and minor bug fixes. *) (* 1988 March 29 - Repeat character compression . *) (* 1988 April 13 - Eliminate special characters from file *) (* name and type,replace with $. *) (* 1988 April 18 - Handle a Null Buffer. *) (* - Stay in server mode except for valid *) (* kermit commands. *) (* 1988 April 20 - Fix bug is sending file after BREAK. *) (* *) (* *) (* 1. This version of kermit will handle binary files, *) (* i.e. it will handle 8th bit quoting. *) (* *) (* 2. By default all characters are received are converted from *) (* ASCII and stored as EBCDIC. Also all characters send are *) (* converted from EBCDIC to ASCII. To avoid the translation *) (* for non-text file you must set TRANSLATION OFF. *) (* *) (* 3. This version of kermit will work through the Series/1- *) (* Yale ASCII IUP. *) (* *) (* 4. This version contains a slot for all the documented *) (* advanced server functions, however only some are implemented*) (* *) (* ***************************************************************** *) (* Utility Procedures *) (* SENDPACKET *) (* RECVPACKET *) (* RESENDIT *) (* SENDACK *) (* GETTOKEN *) (* *) (* Command Procedures *) (* SENDFILE - Sends a file to another computer. *) (* RECVFILE - Receive a file from another computer. *) (* SHOWIT - Display the options and status of last tranfer. *) (* SETIT - Set the options. *) (* HELP - Displays the commands available. *) (* REMOTECOMMAND - handle commands initiated by micro. *) (* *) (* ***************************************************************** *) %PRINT OFF %INCLUDE CMS %PRINT ON CONST MAXINPUT = 1920 ; (* 80 X 24 screen *) TYPE BYTE = PACKED 0..255 ; TWOBYTES = PACKED 0..65535 ; OVERLAY = (ONE,TWO,THREE,FOUR,FIVE,SIX,SEVEN,EIGHT,NINE); PACKET = RECORD CASE OVERLAY OF ONE :( CHARS : PACKED ARRAY [1..MAXINPUT] OF CHAR ); TWO :( BYTES : PACKED ARRAY [1..MAXINPUT] OF BYTE ); END ; STATETYPE = (S,SF,SD,SZ,SB,C,A,R,RF,RD) ; ABORTTYPE = (NOSOH,BADSF,NOT_S,NOT_SFBZ,NOT_DZ); COMMANDS = ($BAD, $SEND, $RECEIVE, $SERVER, $SET , $SHOW, $STATUS, $HELP, $QUES, $CMS, $CP, $QUIT, $EXIT ); WHATFLAGS= ($ZERO, $TRANSLATION, $EXTEND1, $RECFM, $LRECL, $PACKETSIZE, $EXTEND2, $EOLCHAR, $CNTRL_QUOTE, $EXTEND3, $BIT8_QUOTE, $EXTEND4, $REPEATCHAR, $EXTEND4A, $CHECKTYPE, $EXTEND5, $DUMMY); CONST COMMTABLE = 'BAD ' || 'SEND ' || 'RECEIVE ' || 'SERVER ' || 'SET ' || 'SHOW ' || 'STATUS ' || 'HELP ' || '? ' || 'CMS ' || 'CP ' || 'QUIT ' || 'EXIT ' ; WHATTABLE = 'BAD ' || 'TRANSLAT' || 'ION ' || 'RECFM ' || 'LRECL ' || 'PACKETSI' || 'ZE ' || 'EOLCHAR ' || 'CNTRL_QU' || 'OTE ' || 'BIT8_QUO' || 'TE ' || 'REPEATCH' || 'AR ' || 'CHECKTYP' || 'E ' || 'DUMMY ' ; (* THIS IS THE ASCII TO EBCDIC TABLE *) ASCIITOEBCDIC = '010203372D2E2F1605250B0C0D0E0F'XC || '101112133C3D322618193F271C1D1E1F'XC || '405A7F7B5B6C507D4D5D5C4E6B604B61'XC || 'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F'XC || '7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6'XC || 'D7D8D9E2E3E4E5E6E7E8E9ADE0BD5F6D'XC || '79818283848586878889919293949596'XC || '979899A2A3A4A5A6A7A8A9C04FD0A107'XC ; (* THIS IS THE EBCDIC TO ASCII CONVERSION TABLE *) (* CHARACTERS NOT REPRESENTABLE IN ASCII ARE REPLACED BY A NULL *) EBCDICTOASCII = '0102030009007F0009000B0C0D0E0F'XC || '1011121300000800181900001C1D1E1F'XC || '00000000000A171B0000000000050607'XC || '0000160000000004000000001415001A'XC || '200000000000000000005C2E3C282B7C'XC || '2600000000000000000021242A293B5E'XC || '2D2F00000000000000007C2C255F3E3F'XC || '000000000000000000603A2340273D22'XC || '00616263646566676869007B00000000'XC || '006A6B6C6D6E6F707172007D00000000'XC || '007E737475767778797A0000005B0000'XC || '000000000000000000000000005D0000'XC || '7B414243444546474849000000000000'XC || '7D4A4B4C4D4E4F505152000000000000'XC || '5C00535455565758595A000000000000'XC || '303132333435363738397C0000000000'XC ; (* The backslash character is translated by the SERIES/1 as '4A'hex *) (* The comten however translates it as a 'E0'hex *) (* Therefore we will translate both to a '5C'ASCII *) SOH = '01'XC ; VAR RUNNING,GETREPLY : BOOLEAN ; INPUTSTRING : STRING (MAXINPUT); (* COMMAND STRING *) OLDSETTINGS : STRING (100); (* TERMINAL SETTINGS *) COMMAND : ALFA ; SETTING : ALFA ; REQUEST : STRING(9) ; CINDEX : INTEGER; CHECKBYTES : INTEGER ; I,J,K,LEN,RC,RET : INTEGER; FULLSCREENDEVICE : BOOLEAN ; FULLSCREENIO : BOOLEAN ; TRANSLATION,FB : BOOLEAN ; FIXBLOCK : BOOLEAN ; LRECL : STRING(8) ; STATE : STATETYPE ; ABORT : ABORTTYPE ; (* Packet variables *) (* format *) (* Receive Send *) (* SOH *) INCOUNT, OUTCOUNT : BYTE ; (* COUNT *) INSEQ, OUTSEQ : BYTE ; (* SEQNUM *) INPACKETTYPE, OUTPACKETTYPE : CHAR ; (* TYPE *) LENX1,LENX2,HCHECK : BYTE ; (* LENX1,LENX2,HCHECK *) REPLYMSG, SENDMSG : PACKET ; (* DATA... *) CHECKSUM : INTEGER ; (* CHECKSUM *) CRC : TWOBYTES; (* CRC-CCITT*) INDATACOUNT, OUTDATACOUNT : INTEGER ; (* COUNT *) SENDBUFF,RECVBUFF : PACKET ; MAXLENGTH,SI,RI,RECVLENGTH,FC : TWOBYTES ; EOLINE : BOOLEAN ; FILETOSEND : TEXT ; STATIC RPACKETSIZE,SPACKETSIZE : INTEGER ; PSIZE,ECHAR : BYTE ; CNTRL_QUOTE, BIT8_QUOTE : CHAR ; CHECKTYPE,REPEATCHAR : CHAR ; CAPAS,WINDO : BYTE ; VALUE RPACKETSIZE := 94 ; SPACKETSIZE := 94 ; PSIZE := 94 ; (* PACKET size 94 maximum *) ECHAR := 13 ; (* End of line char - CR *) CNTRL_QUOTE := '#' ; BIT8_QUOTE := '&' ; CHECKTYPE := '1' ; (* 1 BYTE checksum *) REPEATCHAR := ' ' ; CAPAS := '00'X ; WINDO := 0 ; LABEL PROMPT ; PROCEDURE UPCASE (TOKEN : ALFA) ; EXTERNAL ; PROCEDURE FULLSERV(VAR FUNCTIONCODE : TWOBYTES ; VAR ABUFFER : PACKET ; VAR MAXLENGTH : TWOBYTES ; VAR RECVLENGTH : TWOBYTES) ; EXTERNAL ; %PAGE (* **************************************************************** *) (* ******* U T I L I T Y - P R O C E D U R E S ******** *) (* **************************************************************** *) (* =============================================================== *) (* CRCHECK - This procedure generates a CRC (CCITT) . *) (* The generator polynomial is X^16+X^12+X^5+1 *) (* which is 1021 hex or the reverse 8408 hex *) (* Side Effect - The global variable CRC is updated. The CRC should *) (* be zero at the start of each CRC calculation and *) (* should be called once for each byte to checked. *) (* no other call to this procedure is necessary. *) (* The CRC is done on all 8 bits in the byte. *) (* =============================================================== *) PROCEDURE CRCHECK(MYBYTE : BYTE); var j,c,t : integer; begin c := MYBYTE ; for j := 0 to 7 do begin t := CRC && c ; CRC := CRC >> 1; if odd(t) then CRC := CRC && '8408'x; c := c >> 1; end; end; (* =============================================================== *) (* INITSCREEN - Initializes the terminal for transparent I/O. *) (* Side Effect - *) (* =============================================================== *) PROCEDURE INITSCREEN ; BEGIN (* INIT SCREEN *) FC := 0 ; (* INIT SCREEN *) FULLSERV(FC,SENDBUFF,SI,RI); SI := 8 ; SENDBUFF.CHARS := 'C3115D7F110001'XC ; END ; (* INIT SCREEN *) (* =============================================================== *) (* FINISCREEN - terminates transparent I/O to terminal. *) (* Side Effect - The global variable SENDSTRING is sent as data. *) (* =============================================================== *) PROCEDURE FINISCREEN ; BEGIN (* FINI SCREEN *) FC := 5 ; (* FINISCREEN *) FULLSERV(FC,SENDBUFF,MAXLENGTH,RECVLENGTH); END ; (* FINI SCREEN *) (* =============================================================== *) (* RITESCREEN - sends a packet to the terminal. *) (* Side Effect - The global variable SENDSTRING is sent as data. *) (* =============================================================== *) PROCEDURE RITESCREEN ; BEGIN (* WRITE SCREEN *) FC := 2 ; (* WRITE SCREEN *) FULLSERV(FC,SENDBUFF,SI,RI); IF FC <> 0 THEN BEGIN FINISCREEN ;writeln('HALT'); HALT ; END; END ; (* WRITE SCREEN *) (* =============================================================== *) (* READSCREEN - get a packet from the terminal. *) (* Side Effect - The global variable SENDSTRING is sent as data. *) (* =============================================================== *) PROCEDURE READSCREEN ; BEGIN (* READ SCREEN *) FC := 3 ; (* READ SCREEN *) MAXLENGTH := MAXINPUT + 10 ; FULLSERV(FC,RECVBUFF,MAXLENGTH,RECVLENGTH); IF FC <> 0 THEN BEGIN (* FAILED *) FINISCREEN ; writeln('readscreen halt'); halt ; END ; (* FAILED *) ; RI := 4 ; (* POINT TO BEGINING OF DATA *) SI := 8 ; (* RESET FOR NEXT PACKET *) END ; (* READ SCREEN *) (* =============================================================== *) (* ONERROR - *) (* =============================================================== *) Procedure ONERROR; Begin (* On Error Procedure *) IF FULLSCREENIO THEN BEGIN FINISCREEN; FULLSCREENIO := FALSE; END; Writeln(' Unexpected Error '); End ; (* On Error Procedure *) (* =============================================================== *) (* SENDCHAR - This procedure sends a char to the terminal. *) (* It does simple pascal WRITE unless it is going via *) (* the series/1 which is flagged by boolean *) (* FULLSCREENDEVICE. *) (* Side Effect - The global variable SENDBUFF and SI are updated. *) (* =============================================================== *) PROCEDURE SENDCHAR(MYCHAR : CHAR); BEGIN (* Send Char *) IF MYCHAR <> CHAR(13) THEN (* Not End of Packet *) IF FULLSCREENDEVICE THEN BEGIN (* Put char into buffer *) IF ORD(MYCHAR) <> 0 THEN SENDBUFF.BYTES[SI]:= ORD(EBCDICTOASCII[ORD(MYCHAR)]) |'80'X ; SI := SI + 1 ; END (* Put char into buffer *) ELSE WRITE(MYCHAR) ELSE (* End of Packet *) IF FULLSCREENDEVICE THEN BEGIN (* end of line *) SENDBUFF.BYTES[SI] := '8D'X ; RITESCREEN ; END (* end of line *) ELSE WRITELN(''); END ; (* Send Char *) (* =============================================================== *) (* RECVCHAR - This procedure gets a char from the terminal. *) (* It does simple pascal READ unless it is going via *) (* the series/1 which is flagged by FULLSCREENDEVICE. *) (* Side Effect - The global variable RECVBUFF and RI are updated. *) (* EOLINE is set *) (* =============================================================== *) PROCEDURE RECVCHAR(VAR MYCHAR : CHAR); BEGIN (* Recv Char *) If FULLSCREENDEVICE THEN BEGIN (* Get char from buffer *) IF RECVBUFF.BYTES[RI]=0 THEN MYCHAR:='00'XC ELSE MYCHAR := ASCIITOEBCDIC[RECVBUFF.BYTES[RI] & '7F'X] ; RI := RI + 1 ; END (* Get char from buffer *) (* ELSE IF MYCHAR = '0D'XC THEN READLN(MYCHAR) *) ELSE READ(MYCHAR) ; IF FULLSCREENDEVICE THEN IF (MYCHAR='0D'XC) OR (RI>=RECVLENGTH) THEN EOLINE := TRUE ELSE EOLINE := FALSE ELSE EOLINE := EOLN(INPUT); IF (MYCHAR = '00'XC) THEN IF (RI < RECVLENGTH) THEN RECVCHAR(MYCHAR) (* ignore nulls *) ELSE BEGIN MYCHAR := '0D'XC ; EOLINE := TRUE ; END ; END ; (* Recv Char *) (* =============================================================== *) (* SENDPACKET -This procedure sends the SENDMSG packet . *) (* 1. The COUNT sent includes SEQ,PACKETTYPE,and CHECKSUM *) (* i.e. it is 3 larger than the DATACOUNT. *) (* 2. The COUNT and SEQ and CHECKSUM values are offset by *) (* 32 decimal (20hex) to make it a printable ASCII char.*) (* 3. The CHECKSUM are calculated on the ASCII value of *) (* the printable characters. *) (* 4. All character sent must be converted to EBCDIC *) (* which get translated back to ASCII by the hardware. *) (* The DATA and PACKETTYPE are stored in this program *) (* as EBCDIC. The other char are assumed ASCII. *) (* Assumptions: *) (* The following Global variables must be correctly set *) (* before calling this procedure . *) (* 1. OUTDATACOUNT - an integer-byte count of data characters.*) (* 2. OUTSEQ - an integer-byte count of sequence number. *) (* 3. OUTPACKETTYPE - an EBCDIC char of type . *) (* 4. SENDMSG - an EBCDIC array of data to be sent. *) (* =============================================================== *) PROCEDURE SENDPACKET ; VAR I,SUM : INTEGER ; BEGIN (* SENDPACKET procedure *) SENDCHAR(SOH) ; (* SOH *) SUM := 0 ; CRC := 0 ; CHECKBYTES := 1 ; IF NOT((OUTPACKETTYPE = 'S') OR (INPACKETTYPE = 'S') OR (INPACKETTYPE = 'R')) THEN IF CHECKTYPE = '2' THEN CHECKBYTES := 2 ELSE IF CHECKTYPE = '3' THEN CHECKBYTES := 3 ; IF OUTDATACOUNT > 91 THEN OUTCOUNT := 0 ELSE OUTCOUNT := OUTDATACOUNT+2+CHECKBYTES ; SENDCHAR(ASCIITOEBCDIC[OUTCOUNT+32]) ; (* COUNT *) SUM := SUM + OUTCOUNT + 32; CRCHECK(OUTCOUNT + 32); SENDCHAR(ASCIITOEBCDIC[OUTSEQ+32]) ; (* SEQ *) SUM := SUM + OUTSEQ + 32; CRCHECK(OUTSEQ + 32); SENDCHAR(OUTPACKETTYPE) ; (* TYPE *) SUM := SUM + ORD( EBCDICTOASCII[ORD(OUTPACKETTYPE)] ) ; CRCHECK( ORD( EBCDICTOASCII[ORD(OUTPACKETTYPE)] )) ; IF OUTCOUNT = 0 THEN (* Long Packets format *) BEGIN (* send LENX1 LENX2 and HCHECK *) LENX1 := TRUNC((OUTDATACOUNT + CHECKBYTES)/95) ; SENDCHAR(ASCIITOEBCDIC[LENX1+32]) ; (* LENX1 *) SUM := SUM + LENX1 + 32 ; CRCHECK(LENX1 + 32) ; LENX2 := (OUTDATACOUNT + CHECKBYTES) MOD 95 ; SENDCHAR(ASCIITOEBCDIC[LENX2+32]) ; (* LENX2 *) SUM := SUM + LENX2 + 32 ; CRCHECK(LENX2 + 32) ; HCHECK := (SUM + (SUM AND 'C0'X) DIV '40'X ) AND '3F'X ; SENDCHAR(ASCIITOEBCDIC[HCHECK+32]) ; (* HCHECK *) SUM := SUM + HCHECK + 32 ; CRCHECK(HCHECK + 32) ; END ; (* send LENX1 LENX2 and HCHECK *) IF OUTDATACOUNT > 0 THEN FOR I := 1 TO OUTDATACOUNT DO WITH SENDMSG DO BEGIN (* Send Data *) SENDCHAR(CHARS[I]) ; (* DATA *) IF BYTES[I] <> 0 THEN SUM := SUM + ORD(EBCDICTOASCII[BYTES[I]]) ; CRCHECK(ORD(EBCDICTOASCII[BYTES[I]])); END ; (* Send Data *) IF CHECKBYTES = 1 THEN BEGIN (* One char checksum *) CHECKSUM := (SUM + (SUM AND 'C0'X) DIV '40'X ) AND '3F'X ; SENDCHAR(ASCIITOEBCDIC[CHECKSUM+32]); (* CHECKSUM *) SENDCHAR('0D'XC) ; END (* One char checksum *) ELSE IF CHECKBYTES = 2 THEN BEGIN (* Two char checksum *) CHECKSUM := (SUM DIV '40'X) AND '3F'X ; (* BIT 11 - 6 *) SENDCHAR(ASCIITOEBCDIC[CHECKSUM+32]); (* CHECKSUM1 *) CHECKSUM := (SUM ) AND '3F'X ; (* BIT 0 - 5 *) SENDCHAR(ASCIITOEBCDIC[CHECKSUM+32]); (* CHECKSUM2 *) SENDCHAR('0D'XC) ; END (* Two char checksum *) ELSE BEGIN (* CRC-CCITT 3 character *) SENDCHAR(ASCIITOEBCDIC[((CRC DIV '1000'X) AND '0F'X) +32]); SENDCHAR(ASCIITOEBCDIC[((CRC DIV '0040'X) AND '3F'X) +32]); SENDCHAR(ASCIITOEBCDIC[((CRC ) AND '3F'X) +32]); SENDCHAR('0D'XC) ; END ; (* CRC-CCITT 3 character *) END ; (* SENDPACKET procedure *) (* =============================================================== *) (* RECVPACKET -This Function returns TRUE if it successfully *) (* recieved a packet and FALSE if it had an error. *) (* Side Effects: *) (* The following global variables will be set. *) (* 1. INCOUNT - an integer value of the msg char count . *) (* 2. INSEQ - an integer value of the sequence count. *) (* 3. TYPE - an EBCDIC character of message type(Y,N,D,F,etc)*) (* 4. REPLYMSG - an EBCDIC array of the data sent. *) (* *) (* a) All characaters are received as EBCDIC values and *) (* must be converted back to ASCII before using. *) (* =============================================================== *) FUNCTION RECVPACKET : BOOLEAN ; VAR I,SUM,RESENDS : INTEGER ; INCHAR : CHAR ; LABEL FINDSOH ; BEGIN (* RECVPACKET procedure *) IF FULLSCREENDEVICE THEN READSCREEN ; FINDSOH: RECVCHAR(INCHAR) ; (* SOH *) IF EOLINE THEN BEGIN (* Null response *) RECVPACKET := TRUE; INPACKETTYPE:='N'; RETURN; END; (* Null response *) IF INCHAR <> SOH THEN GOTO FINDSOH; (* SOH *) SUM := 0 ; CRC := 0 ; RECVCHAR (INCHAR) ; INCOUNT := ORD(EBCDICTOASCII[ORD(INCHAR)]) ; (* COUNT *) SUM := SUM + INCOUNT ; CRCHECK(INCOUNT) ; INCOUNT := INCOUNT - 32 ; (* To absolute value *) RECVCHAR (INCHAR) ; INSEQ := ORD(EBCDICTOASCII[ORD(INCHAR)]); (* SEQ *) SUM := SUM + INSEQ ; CRCHECK(INSEQ) ; INSEQ := INSEQ - 32 ; RECVCHAR (INCHAR) ; INPACKETTYPE := INCHAR ; (* TYPE *) SUM := SUM +ORD(EBCDICTOASCII[ORD(INCHAR)]) ; CRCHECK(ORD(EBCDICTOASCII[ORD(INCHAR)])); CHECKBYTES := 1 ; IF NOT ((INPACKETTYPE = 'S') OR (OUTPACKETTYPE = 'S') OR (INPACKETTYPE = 'R') ) THEN IF CHECKTYPE = '2' THEN CHECKBYTES := 2 ELSE IF CHECKTYPE = '3' THEN CHECKBYTES := 3 ; IF INCOUNT = 0 THEN BEGIN (* Long Packet Format *) RECVCHAR (INCHAR) ; LENX1 := ORD(EBCDICTOASCII[ORD(INCHAR)]); (* LENX1 *) SUM := SUM + LENX1 ; CRCHECK(LENX1) ; LENX1 := LENX1 - 32 ; RECVCHAR (INCHAR) ; LENX2 := ORD(EBCDICTOASCII[ORD(INCHAR)]); (* LENX2 *) SUM := SUM + LENX2 ; CRCHECK(LENX2) ; LENX2 := LENX2 - 32 ; CHECKSUM := (SUM + (SUM AND 192) DIV 64 ) AND 63 ; RECVCHAR (INCHAR) ; HCHECK := ORD(EBCDICTOASCII[ORD(INCHAR)]); (* HCHECK *) IF HCHECK <> CHECKSUM + 32 THEN RECVPACKET := FALSE ; SUM := SUM + HCHECK ; CRCHECK(HCHECK) ; INDATACOUNT := (95*LENX1) + LENX2 - CHECKBYTES ; END (* Long Packet Format *) ELSE INDATACOUNT := INCOUNT - (2 + CHECKBYTES) ; IF INDATACOUNT > 0 THEN FOR I := 1 TO INDATACOUNT DO WITH REPLYMSG DO BEGIN (* Send Data *) RECVCHAR (CHARS[I]) ; (* DATA *) SUM := (SUM AND '0FFFF'X) + ORD(EBCDICTOASCII[BYTES[I]]) ; CRCHECK(ORD(EBCDICTOASCII[BYTES[I]]) ) ; END ; (* Send Data *) RECVPACKET := TRUE ; (* ASSUME OK UNLESS CHECK FAILS *) IF CHECKBYTES = 1 THEN BEGIN (* CHECKSUM *) CHECKSUM := (SUM + (SUM AND 192) DIV 64 ) AND 63 ; RECVCHAR (INCHAR) ; IF ORD(EBCDICTOASCII[ORD(INCHAR)]) <> CHECKSUM+32 THEN RECVPACKET := FALSE ; END (* CHECKSUM *) ELSE IF CHECKBYTES = 2 THEN BEGIN (* TWO BYTE CHECKSUM *) CHECKSUM := (SUM DIV '40'X ) AND '3F'X ; RECVCHAR (INCHAR) ; IF ORD(EBCDICTOASCII[ORD(INCHAR)]) <> CHECKSUM+32 THEN RECVPACKET := FALSE ; CHECKSUM := (SUM ) AND '3F'X ; RECVCHAR (INCHAR) ; IF ORD(EBCDICTOASCII[ORD(INCHAR)]) <> CHECKSUM+32 THEN RECVPACKET := FALSE ; END (* TWO BYTE CHECKSUM *) ELSE BEGIN (* CRC-CCITT *) (* First char is bits 16-12, second is bits 11-6 and *) (* third is bits 5-0 *) RECVCHAR (INCHAR) ; IF ORD(EBCDICTOASCII[ORD(INCHAR)]) <> ((CRC DIV '1000'X) AND '0F'X) +32 THEN RECVPACKET:=FALSE; RECVCHAR (INCHAR ) ; IF ORD(EBCDICTOASCII[ORD(INCHAR)]) <> ((CRC DIV '40'X) AND'3F'X) +32 THEN RECVPACKET:=FALSE; INCHAR := '0D'XC ; RECVCHAR (INCHAR) ; IF ORD(EBCDICTOASCII[ORD(INCHAR)]) <> (CRC AND '3F'X) +32 THEN RECVPACKET := FALSE ; END ; (* CRC-CCITT *) END ; (* RECVPACKET procedure *) (* =============================================================== *) (* RESENDIT - This procedure RESENDS the packit if it gets a nak *) (* It calls itself recursively upto the number of times *) (* specified in the intial parameter list. *) (* Side Effects - If it fails then the STATE in the message is set *) (* to 'A' which means ABORT . *) (* =============================================================== *) PROCEDURE RESENDIT ( RETRIES : INTEGER ) ; BEGIN (* RESENDIT procedure *) IF RETRIES > 0 THEN BEGIN (* Try again *) SENDPACKET ; IF RECVPACKET THEN IF INPACKETTYPE = 'Y' THEN ELSE IF INPACKETTYPE = 'N' THEN RESENDIT(RETRIES-1) ELSE STATE := A ELSE STATE := A ; END (* Try again *) ELSE STATE := A ; (* Retries failed - ABORT *) END ; (* RESENDIT procedure *) (* ------------------------------------------------------------ *) (* SENDACK - Procedure will send a ACK or NAK *) (* depending on the value of the Boolean parameter *) (* i.e. SENDACK(TRUE) sends an ACK packet *) (* SENDACK(FALSE) sends an NAK packet *) (* ------------------------------------------------------------ *) PROCEDURE SENDACK (B : BOOLEAN); BEGIN (* SEND ACK or NAK *) OUTDATACOUNT := 0 ; OUTSEQ := OUTSEQ + 1 ; IF OUTSEQ >= 64 THEN OUTSEQ := 0; IF B THEN OUTPACKETTYPE := 'Y' ELSE OUTPACKETTYPE := 'N' ; SENDPACKET ; IF B THEN ELSE OUTSEQ := OUTSEQ - 1 ; END ; (* SEND ACK or NAK *) (* =============================================================== *) (* GETTOKEN - This procedure extracts a token from a string and *) (* the function returns a 8 character token value. *) (* the string is update with the portion that is left. *) (* =============================================================== *) FUNCTION GETTOKEN ( VAR INSTRING : STRING(1920)) : ALFA ; VAR BP,BPM : INTEGER ; (* Blank Pointer *) BEGIN (* GETTOKEN *) IF LENGTH(INSTRING) < 1 THEN GETTOKEN := ' ' ELSE BEGIN BP := INDEX(INSTRING,' '); IF BP = 0 THEN BP := LENGTH(INSTRING)+1; BPM := MIN(BP,9); IF BPM > LENGTH(INSTRING) THEN GETTOKEN := INSTRING ELSE GETTOKEN := DELETE(INSTRING,BPM); INSTRING := DELETE(INSTRING,1,MIN(BP,LENGTH(INSTRING))); END; END; (* GETTOKEN *) (* ---------------------------------------------------------------- *) (* =============================================================== *) (* PUTINITPACKET - This procedure make the PARAMETER PACKET. *) (* =============================================================== *) PROCEDURE PUTINITPACKET ; BEGIN (* parameters *) OUTDATACOUNT := 9 ; OUTSEQ := 0 ; WITH SENDMSG DO BEGIN (* Setup PARM packet *) (* The values are tranformed by adding hex 20 to *) (* the true value, making the value a printable char *) CHARS[1] := ASCIITOEBCDIC[PSIZE+32];(* Buffsize = 94 *) CHARS[2] := ASCIITOEBCDIC['28'X] ; (* Time out 8 sec *) CHARS[3] := ASCIITOEBCDIC['20'X] ; (* Num padchars=0 *) CHARS[4] := ASCIITOEBCDIC['40'X] ; (* Pad char=blank *) CHARS[5] := ASCIITOEBCDIC[ECHAR+32];(* EOL char = CR *) CHARS[6] := CNTRL_QUOTE ; (* Quote character *) (* OPTIONAL PARAMETERS *) CHARS[7] := BIT8_QUOTE ; (* Quote character *) CHARS[8] := CHECKTYPE ; (* Check type *) CHARS[9] := REPEATCHAR ; (* Repeatcharacter *) IF BIT8_QUOTE <= ' ' THEN CHARS[7] := 'Y' ; IF CHECKTYPE <= ' ' THEN CHARS[8] := '1' ; IF REPEATCHAR <= ' ' THEN CHARS[9] := ' ' ; IF RPACKETSIZE > 94 THEN BEGIN (* Long Packet Size *) CHARS[10] := ASCIITOEBCDIC[02+32]; CHARS[11] := ASCIITOEBCDIC[0+32]; CHARS[12] := ASCIITOEBCDIC[TRUNC(RPACKETSIZE/95)+32]; CHARS[13] := ASCIITOEBCDIC[(RPACKETSIZE MOD 95)+32]; OUTDATACOUNT := 13 ; END ; (* Long Packet Size *) END ; (* Setup PARAMETER packet *) END ; (* parameters *) (* ------------------------------------------------------------ *) PROCEDURE GETINITPACKET ; BEGIN (* Get init parameters *) IF INDATACOUNT >= 1 THEN PSIZE := ORD(EBCDICTOASCII[REPLYMSG.BYTES[1]])-32 ; IF INDATACOUNT >= 5 THEN ECHAR := ORD(EBCDICTOASCII[REPLYMSG.BYTES[5]])-32 ; IF INDATACOUNT >= 6 THEN CNTRL_QUOTE := REPLYMSG.CHARS[6] ; IF INDATACOUNT >= 7 THEN IF REPLYMSG.CHARS[7] = 'Y' THEN BIT8_QUOTE := '&' ELSE IF REPLYMSG.CHARS[7] = 'N' THEN BIT8_QUOTE := ' ' ELSE BIT8_QUOTE := REPLYMSG.CHARS[7] ; IF INDATACOUNT >= 8 THEN IF REPLYMSG.CHARS[8] <> CHECKTYPE THEN CHECKTYPE := '1' ; (* One char checksum DEFAULT *) IF INDATACOUNT >= 9 THEN IF REPLYMSG.CHARS[9] <> REPEATCHAR THEN REPEATCHAR := ' ' ; (* No repeat char *) IF INDATACOUNT >= 10 THEN CAPAS := ORD(EBCDICTOASCII[REPLYMSG.BYTES[10]])-32 ELSE CAPAS := 0 ; IF INDATACOUNT >= 11 THEN WINDO := ORD(EBCDICTOASCII[REPLYMSG.BYTES[11]])-32 ELSE WINDO := 0 ; IF (CAPAS and '02'X) = '02'X THEN (* long blocks *) If INDATACOUNT >= 13 THEN SPACKETSIZE := 0) (ORD(EBCDICTOASCII[REPLYMSG.BYTES[12]])-32) *95 + (ORD(EBCDICTOASCII[REPLYMSG.BYTES[13]])-32) ELSE SPACKETSIZE := 500 ELSE SPACKETSIZE := PSIZE ; END ; (* Get init parameters *) (* ------------------------------------------------------------ *) (* =============================================================== *) (* FILETOPACKET - This procedure files in a DATA packet D or X type *) (* with data from the file FILETOSEND. *) (* =============================================================== *) PROCEDURE FILETOPACKET ; VAR PREVCHAR,ACHAR : CHAR ; MARKOUTCOUNT,REPCOUNT,MAXDATASIZE : INTEGER ; REPEATING : BOOLEAN ; LABEL TRANS,NEXT ; BEGIN (* FILE TO PACKET *) (* WRITELN ('SEND DATA '); *) OUTSEQ := OUTSEQ + 1 ; IF OUTSEQ >= 64 THEN OUTSEQ := 0 ; OUTDATACOUNT := 0 ; REPEATING := FALSE ; REPCOUNT := -1 ; (* -1 to indicate start of new line or packet *) MAXDATASIZE := MIN(1900,SPACKETSIZE) -3 -5 ; WHILE (OUTDATACOUNT' ') AND (REPCOUNT>=0) AND (REPCOUNT<94) THEN BEGIN (* Repeated char *) REPCOUNT := REPCOUNT + 1 ; IF REPCOUNT > 1 THEN BEGIN (* multiple chars *) OUTDATACOUNT := OUTDATACOUNT - 1 ; IF NOT EOLN(FILETOSEND) THEN GOTO NEXT ; END ; (* multiple chars *) END ; (* Repeated char *) IF ((PREVCHAR<>ACHAR) OR (REPCOUNT>94) OR EOLN(FILETOSEND) OR (REPCOUNT<0)) AND (REPEATCHAR>' ') THEN BEGIN (* Different Char *) IF REPCOUNT > 1 THEN BEGIN (* add repeat count sequence *) OUTDATACOUNT := MARKOUTCOUNT ; CHARS[OUTDATACOUNT] := REPEATCHAR ; BYTES[OUTDATACOUNT+1] := REPCOUNT + 1 + 32 ; CHARS[OUTDATACOUNT+1] := ASCIITOEBCDIC[REPCOUNT+1+32] ; CHARS[OUTDATACOUNT+2] := PREVCHAR ; OUTDATACOUNT := OUTDATACOUNT + 2 ; REPEATING := TRUE ; IF PREVCHAR = ACHAR THEN REPCOUNT := 0 ; END ; (* add repeat count sequence *) PREVCHAR := ACHAR ; MARKOUTCOUNT := OUTDATACOUNT ; IF REPCOUNT <= 1 THEN REPCOUNT := 0 ; END ; (* Different Char *) TRANS: IF TRANSLATION THEN BEGIN (* translate char *) IF BYTES[OUTDATACOUNT]=128 THEN (* 8bit quote next char*) CHARS[OUTDATACOUNT] := BIT8_QUOTE ELSE BEGIN (* double trans *) (* The following double translation is used to *) (* filter out meaningless EBCDIC characters into *) (* something more consistent. *) IF BYTES[OUTDATACOUNT] <> 0 THEN CHARS[OUTDATACOUNT] := EBCDICTOASCII[BYTES[OUTDATACOUNT]]; IF BYTES[OUTDATACOUNT] < 32 THEN BEGIN (* CONTROL QUOTING *) BYTES[OUTDATACOUNT+1] := BYTES[OUTDATACOUNT] + 64 ; CHARS[OUTDATACOUNT] := CNTRL_QUOTE ; OUTDATACOUNT := OUTDATACOUNT + 1 ; END ; (* CONTROL QUOTING *) IF BYTES[OUTDATACOUNT] = '7F'X THEN BEGIN (* DEL QUOTING *) CHARS[OUTDATACOUNT+1] := '3F'XC ; CHARS[OUTDATACOUNT] := CNTRL_QUOTE ; OUTDATACOUNT := OUTDATACOUNT + 1 ; END ; (* DEL QUOTING *) IF BYTES[OUTDATACOUNT] <> 0 THEN CHARS[OUTDATACOUNT] := ASCIITOEBCDIC[BYTES[OUTDATACOUNT]] ; IF (CHARS[OUTDATACOUNT]<> ' ') AND ((CHARS[OUTDATACOUNT] = CNTRL_QUOTE) OR (CHARS[OUTDATACOUNT] = BIT8_QUOTE) OR (CHARS[OUTDATACOUNT] = REPEATCHAR)) THEN BEGIN (* Quote the quote *) CHARS[OUTDATACOUNT+1] := CHARS[OUTDATACOUNT] ; CHARS[OUTDATACOUNT] := CNTRL_QUOTE ; OUTDATACOUNT := OUTDATACOUNT + 1 ; END ; (* Quote the quote *) END ; (* double trans *) IF EOLN(FILETOSEND) THEN BEGIN (* End of Line *) IF (ACHAR=' ') THEN (* Delete trailing blanks *) IF REPEATING AND (CHARS[OUTDATACOUNT]=' ') THEN BEGIN (* delete repeated blanks *) OUTDATACOUNT := OUTDATACOUNT - 3 ; REPCOUNT := -1 ; END (* delete repeated blanks *) ELSE IF REPEATCHAR <= ' ' THEN WHILE (SENDMSG.CHARS[OUTDATACOUNT] = ' ') AND (OUTDATACOUNT>1) DO OUTDATACOUNT := OUTDATACOUNT - 1 ; IF REPCOUNT > 1 THEN BEGIN (* Reset repeat count *) REPCOUNT := -1 ; OUTDATACOUNT := OUTDATACOUNT + 1 ; CHARS[OUTDATACOUNT] := ACHAR ; MARKOUTCOUNT := OUTDATACOUNT ; GOTO TRANS ; END ; (* Reset repeat count *) (* Add CR and LF *) OUTDATACOUNT := OUTDATACOUNT + 1 ; SENDMSG.CHARS[OUTDATACOUNT] := CNTRL_QUOTE ; OUTDATACOUNT := OUTDATACOUNT + 1 ; SENDMSG.CHARS[OUTDATACOUNT]:='M'; (* Carriage Ret *) OUTDATACOUNT := OUTDATACOUNT + 1 ; SENDMSG.CHARS[OUTDATACOUNT] := CNTRL_QUOTE ; OUTDATACOUNT := OUTDATACOUNT + 1 ; SENDMSG.CHARS[OUTDATACOUNT] := 'J' ; (* Line Feed *) REPCOUNT := -1 ; READLN(FILETOSEND) ; (* Point to next line *) END ; (* End of Line *) END (* translate char *) ELSE BEGIN (* Untranslated file *) (* Untranslated file means the file is stored as *) (* 8 bit ASCII. However it must be translated into*) (* EBCDIC so that the comten software will trans- *) (* late it back into ASCII. *) IF BYTES[OUTDATACOUNT] >= 128 THEN IF BIT8_QUOTE <= ' ' THEN (* No bit8 quoting *) (* Just drop the 8th bit *) BYTES[OUTDATACOUNT]:=BYTES[OUTDATACOUNT]-128 ELSE BEGIN (* BIT8 QUOTING *) BYTES[OUTDATACOUNT+1]:=BYTES[OUTDATACOUNT]-128; CHARS[OUTDATACOUNT] := BIT8_QUOTE ; OUTDATACOUNT := OUTDATACOUNT + 1 ; END ; (* BIT8 QUOTING *) IF BYTES[OUTDATACOUNT] < 32 THEN BEGIN (* CONTROL QUOTING *) BYTES[OUTDATACOUNT+1]:=BYTES[OUTDATACOUNT]+64; CHARS[OUTDATACOUNT] := CNTRL_QUOTE ; OUTDATACOUNT := OUTDATACOUNT + 1 ; END ; (* CONTROL QUOTING *) IF BYTES[OUTDATACOUNT] = '7F'X THEN BEGIN (* DEL QUOTING *) CHARS[OUTDATACOUNT+1] := '3F'XC ; CHARS[OUTDATACOUNT] := CNTRL_QUOTE ; OUTDATACOUNT := OUTDATACOUNT + 1 ; END ; (* DEL QUOTING *) IF BYTES[OUTDATACOUNT] <> 0 THEN CHARS[OUTDATACOUNT] := ASCIITOEBCDIC[BYTES[OUTDATACOUNT]] ; IF CHARS[OUTDATACOUNT] > ' ' THEN IF (CHARS[OUTDATACOUNT] = CNTRL_QUOTE) OR (CHARS[OUTDATACOUNT] = REPEATCHAR) OR (CHARS[OUTDATACOUNT] = BIT8_QUOTE) THEN BEGIN (* Quote the quote *) CHARS[OUTDATACOUNT+1] := CHARS[OUTDATACOUNT] ; CHARS[OUTDATACOUNT] := CNTRL_QUOTE ; OUTDATACOUNT := OUTDATACOUNT + 1 ; END ; (* Quote the quote *) IF EOLN(FILETOSEND) THEN READLN(FILETOSEND) ; END ; (* Untranslated file *) IF REPCOUNT > 1 THEN BEGIN (* Reset repeat count *) REPCOUNT := 0 ; OUTDATACOUNT := OUTDATACOUNT + 1 ; CHARS[OUTDATACOUNT] := ACHAR ; MARKOUTCOUNT := OUTDATACOUNT ; GOTO TRANS ; END ; (* Reset repeat count *) NEXT: REPEATING := FALSE ; END ; (* Process Character *) END ; (* FILE TO PACKET *) %PAGE (* **************************************************************** *) (* ---------------------------------------------------------------- *) (* ------ C O M M A N D - P R O C E D U R E S --------- *) (* ---------------------------------------------------------------- *) (* **************************************************************** *) (* **************************************************************** *) (* SENDFILE - This routine handles the sending of a file to * *) (* the micro computer. * *) (* If the parameter string is blank it gets the file * *) (* name and type from the INPUTSTRING. * *) (* If it is non blank it assumes the file name is in * *) (* the parameter string, which was obtained by the * *) (* remote RECEIVE fn ft command. * *) (* **************************************************************** *) PROCEDURE SENDFILE ( FNFTFM : STRING(80)); VAR FNAME,FTYPE,FMODE : ALFA ; TITLE,FILENAME : STRING(26); CMSCOMMAND : STRING (80); SENDING,EOL: BOOLEAN ; DIRECTORY : PACKED ARRAY [0..255] OF STRING(20) ; RECFM : PACKED ARRAY [0..255] OF CHAR ; BLOCKSIZE : PACKED ARRAY [0..255] OF INTEGER ; RET,FILEINDEX,IX,CSI,RETRIES : INTEGER ; DUMMY : CHAR ; LABEL EXITSEND; BEGIN (* SENDFILE procedure *) (* WRITELN ('ready to SEND file - Put Micro in receive mode. '); *) IF FULLSCREENDEVICE AND NOT FULLSCREENIO THEN INITSCREEN ; IF FNFTFM = ' ' THEN BEGIN (* Look for file name in INPUTSTRING *) FNAME := GETTOKEN(INPUTSTRING); FTYPE := GETTOKEN(INPUTSTRING); FMODE := GETTOKEN(INPUTSTRING); TITLE := STR(FNAME) || ' ' ||STR(FTYPE) || ' ' || STR(FMODE); END (* Look for file name in INPUTSTRING *) ELSE TITLE := FNFTFM ; CMSCOMMAND := 'LISTFILE ' || TITLE || ' (STACK FORMAT)' ; CMS( CMSCOMMAND,RET); (* TRY UPCASING IT *) (* IF RET <> 0 THEN BEGIN UPCASE(FNAME); UPCASE(FTYPE); UPCASE(FMODE); TITLE := STR(FNAME) || ' ' ||STR(FTYPE) || ' ' || STR(FMODE) ; CMSCOMMAND := 'LISTFILE ' || TITLE || ' (STACK FORMAT)' ; CMS( CMSCOMMAND,RET); *) IF RET <> 0 THEN BEGIN (* No file *) IF NOT FULLSCREENIO THEN WRITELN ('No file ',TITLE,' found ',RET); (* SEND ERROR packet *) OUTDATACOUNT := 15 ; OUTSEQ := 0 ; SENDMSG.CHARS := 'No file found. ' ; OUTPACKETTYPE := 'E'; SENDPACKET ; GOTO EXITSEND ; END ; (* No file *) (* END ; TRY UPCASING IT *) CMS('SENTRIES',RET); FILEINDEX := RET ; (* WRITELN('FILE INDEX IS ',FILEINDEX); *) FOR IX := 1 TO FILEINDEX DO READLN (DIRECTORY[IX]:21,RECFM[IX],BLOCKSIZE[IX]); IX := 1 ; STATE := S ; GETREPLY := FALSE ; SENDING := TRUE ; WHILE SENDING DO BEGIN (* Send files *) IF GETREPLY THEN BEGIN (* Look at Packet Received *) IF RECVPACKET THEN IF INPACKETTYPE = 'Y' THEN ELSE IF INPACKETTYPE = 'N' THEN RESENDIT(10) ELSE IF INPACKETTYPE = 'R' THEN STATE := S ELSE STATE := A ELSE RESENDIT(10) ; IF (INPACKETTYPE = 'Y') AND (INDATACOUNT > 0) THEN IF REPLYMSG.CHARS[1] = 'X' THEN STATE := SZ ELSE IF REPLYMSG.CHARS[1] = 'Z' THEN BEGIN IX := FILEINDEX ; STATE := SZ ; END ; END ; (* Look at Packet Received *) GETREPLY := TRUE ; CASE STATE OF S : BEGIN (* Send INIT packit *) OUTPACKETTYPE := 'S' ; PUTINITPACKET ; IF FNFTFM = ' ' THEN CMS('CP SLEEP 10 SEC',RET); SENDPACKET ; STATE := SF ; END ; (* Send INIT packit *) SF: BEGIN (* Send file header *) IF INDATACOUNT > 1 THEN GETINITPACKET ; (* WRITELN ('file ',DIRECTORY[IX],' ',RECFM[IX],BLOCKSIZE[IX]); *) OUTSEQ := OUTSEQ + 1 ; IF OUTSEQ >= 64 THEN OUTSEQ := 0 ; OUTPACKETTYPE := 'F' ; FIXBLOCK := RECFM[IX] = 'F' ; FILENAME := TRIM(SUBSTR(DIRECTORY[IX],1,8)) || '.' || TRIM(SUBSTR(DIRECTORY[IX],10,8)) ; SENDMSG.CHARS := FILENAME ; OUTDATACOUNT := LENGTH(FILENAME); SENDPACKET ; IF BLOCKSIZE[IX] > 32756 THEN BEGIN (* Blocksize too large *) (* WRITELN('BLOCKSIZE of',BLOCKSIZE[IX],' is too large.');*) STATE := SZ ; END (* Blocksize too large *) ELSE BEGIN (* Open file *) CMSCOMMAND:='FILEDEF FILETOSEND DISK ' || STR(DIRECTORY[IX]); CMS(CMSCOMMAND,RET); RESET(FILETOSEND); STATE := SD ; END ; (* Open file *) END ; (* Send file header *) SD: BEGIN (* Send data *) OUTPACKETTYPE := 'D' ; FILETOPACKET ; SENDPACKET ; IF EOF(FILETOSEND) THEN STATE := SZ ; END ; (* Send data *) SZ: BEGIN (* End of File *) (* WRITELN ('end of file'); *) OUTDATACOUNT := 0 ; OUTSEQ := OUTSEQ + 1 ; IF OUTSEQ >= 64 THEN OUTSEQ := 0; ; OUTPACKETTYPE := 'Z' ; SENDPACKET ; IX := IX + 1 ; IF IX <= FILEINDEX THEN STATE := SF ELSE STATE := SB ; END ; (* End of File *) SB: BEGIN (* Last file sent *) (* WRITELN ('SENT last file completed'); *) OUTDATACOUNT := 0 ; OUTSEQ := OUTSEQ + 1 ; IF OUTSEQ >= 64 THEN OUTSEQ := 0 ; OUTPACKETTYPE := 'B' ; SENDPACKET ; STATE := C ; END ; (* Last file sent *) C: BEGIN (* Completed Sending *) (* WRITELN ('SENDing of files completed'); *) SENDING := FALSE ; END ; (* Completed Sending *) A: BEGIN (* Abort Sending *) (* WRITELN ('SENDing files ABORTED'); *) ABORT := BADSF ; SENDING := FALSE ; (* SEND ERROR packet *) OUTDATACOUNT := 15 ; OUTSEQ := 0 ; SENDMSG.CHARS := 'Send file abort' ; OUTPACKETTYPE := 'E'; SENDPACKET ; END ; (* Abort Sending *) END ; (* CASE of STATE *) END ; (* Send files *) EXITSEND: IF FULLSCREENDEVICE THEN IF NOT FULLSCREENIO THEN FINISCREEN ELSE (* SEND A PROMPT *) BEGIN SI := 8 ; SENDBUFF.CHARS := 'C3115D7F110001BE'XC ; RITESCREEN ; (* SEND SERVER PROMPT *) SI := 8 ; (* Reset data pointer *) END ; END ; (* SENDFILE procedure *) %PAGE (* **************************************************************** *) (* RECVFILE - This routine handles the Receiving of a file from *) (* the micro computer. *) (* *) (* Note : whenever a CR,LF pair is received it assumes it is the *) (* an EOLN indicator and are not stored in the file. *) (* However if we get two CR,LF in a row we can not write *) (* an empty record so we must store the next CR,LF in the *) (* next record . *) (* **************************************************************** *) PROCEDURE RECVFILE ; VAR BIT8 : BYTE ; LASTSEQNUM : INTEGER ; RECEIVING : BOOLEAN ; FNAME,FTYPE,FMODE : ALFA ; FILENAME,FILETYPE : STRING (16) ; FILEWANTED : STRING(80); TEMPSTR : STRING (94); RET,RETRIES,COLON,DOT,IX,CNT,J : INTEGER ; CRFLAG,CRLFFLAG : BOOLEAN ; TITLE,OPEN_OPTIONS : STRING (80); FILEINCOMING : TEXT ; (* ------------------------------------------------------------ *) (* SENDNAK - Procedure of RECVFILE, will check the number of *) (* RETRIES , if it is greater than 0 it will send a *) (* call SENDACK(FALSE) which send a NAK packet and *) (* decrements the RETRIES by 1. *) (* Side Effect - RETRIES is decremented by 1. *) (* STATE is set to A if no more retries. *) (* ------------------------------------------------------------ *) PROCEDURE SENDNAK ; BEGIN (* SEND NAK *) IF RETRIES > 0 THEN BEGIN (* Ask for a retransmission *) SENDACK(FALSE); RETRIES := RETRIES - 1 ; END (* Ask for a retransmission *) ELSE STATE := A ; END ; (* SEND ACK or NAK *) BEGIN (* ------- RECVFILE procedure ------- *) (* WRITELN (' RECEIVE mode - Issue a SEND command from micro. '); *) IF FULLSCREENDEVICE AND NOT FULLSCREENIO THEN INITSCREEN ; IF LENGTH(INPUTSTRING) > 0 THEN BEGIN (* GET name of file *) IX := INDEX(INPUTSTRING,' '); IF IX = 0 THEN BEGIN (* One parm only *) IX := LENGTH(INPUTSTRING) ; FILEWANTED := INPUTSTRING ; END (* One parm only *) ELSE FILEWANTED := DELETE(INPUTSTRING,IX+1); INPUTSTRING := LTRIM(DELETE(INPUTSTRING,1,IX)); END ; (* GET name of file *) FNAME := GETTOKEN(INPUTSTRING); UPCASE(FNAME); IF FNAME = 'AS ' THEN FNAME := GETTOKEN(INPUTSTRING); FTYPE := GETTOKEN(INPUTSTRING); FMODE := GETTOKEN(INPUTSTRING); IF FNAME = '' THEN FNAME := '=' ; IF FTYPE = '' THEN FTYPE := '=' ; IF FMODE = '' THEN FMODE := '=' ; IF (LENGTH(FILEWANTED) > 1) AND ((FILEWANTED<>'AS') OR (FILEWANTED<>'as')) THEN BEGIN (* Send R packet requesting the file *) OUTSEQ := 0 ; OUTPACKETTYPE := 'R' ; SENDMSG.CHARS := FILEWANTED ; OUTDATACOUNT := LENGTH(FILEWANTED) ; SENDPACKET ; END (* Send R packet requesting the file *) ELSE SENDACK(FALSE) ; (* may not need it but won't hurt *) STATE := R ; RECEIVING := TRUE ; RETRIES := 10 ; (* Up to 10 retries allowed. *) WHILE RECEIVING DO CASE STATE OF (* R ------ Initial receive State ------- *) (* Valid received msg type : S *) R : BEGIN (* Initial Receive State *) IF (NOT RECVPACKET) OR (INPACKETTYPE='N') THEN SENDNAK ELSE (* Get a packet *) IF INPACKETTYPE = 'S' THEN BEGIN (* Got INIT packit *) GETINITPACKET ; OUTPACKETTYPE := 'Y' ; PUTINITPACKET ; SENDPACKET ; STATE := RF ; END (* Got INIT packet *) ELSE BEGIN (* Not init packet *) STATE := A ; (* ABORT if not INIT packet *) ABORT := NOT_S ; END ; (* Not init packet *) END ; (* Initial Receive State *) (* RF ----- Receive Filename State ------- *) (* Valid received msg type : S,Z,F,B *) RF: IF (NOT RECVPACKET) OR (INPACKETTYPE='N') THEN SENDNAK ELSE (* Get a packet *) IF INPACKETTYPE = 'S' THEN STATE:=R ELSE IF INPACKETTYPE = 'Z' THEN SENDACK(TRUE) ELSE IF INPACKETTYPE = 'B' THEN STATE:=C ELSE IF INPACKETTYPE = 'F' THEN BEGIN (* Got file header *) TEMPSTR := SUBSTR(STR(REPLYMSG.CHARS),1,INDATACOUNT) ; COLON := INDEX(TEMPSTR,':'); IF COLON > 0 THEN TEMPSTR := SUBSTR(TEMPSTR,COLON+1, LENGTH(TEMPSTR)-COLON); DOT := INDEX(TEMPSTR,'.'); IF DOT = 0 THEN DOT := INDEX(TEMPSTR,' '); FOR J:=1 TO LENGTH(TEMPSTR) DO IF ORD(TEMPSTR[J]) < 128 THEN TEMPSTR[J] := '$' ; FILENAME:=SUBSTR(TEMPSTR,1,DOT-1) ; FILETYPE:=SUBSTR(TEMPSTR,DOT+1,LENGTH(TEMPSTR)-DOT); IF FNAME <> '=' THEN FILENAME := STR(FNAME) ; IF FTYPE <> '=' THEN FILETYPE := STR(FTYPE) ; IF FMODE = '=' THEN FMODE := 'A' ; TITLE := TRIM(FILENAME) || '.' || TRIM(FILETYPE) || '.' || STR(FMODE) ; IF FB THEN OPEN_OPTIONS:='NAME=' || TITLE || ',RECFM=F'|| ',LRECL=' || LRECL ELSE OPEN_OPTIONS:='NAME=' || TITLE || ',LRECL=32756'; REWRITE(FILEINCOMING,OPEN_OPTIONS); CRFLAG := FALSE ; CRLFFLAG := FALSE ; STATE := RD ; SENDACK(TRUE); END (* Got file header *) ELSE BEGIN (* Not S,F,B,Z packet *) STATE := A ; (* ABORT if not a S,F,B,Z type packet *) ABORT := NOT_SFBZ ; END ; (* Not S,F,B,Z packet *) (* RD ----- Receive Data State ------- *) (* Valid received msg type : D,Z *) RD: IF (NOT RECVPACKET) OR (INPACKETTYPE='N') THEN SENDNAK ELSE IF LASTSEQNUM = INSEQ THEN BEGIN (* repeated packet *) OUTSEQ := OUTSEQ - 1 ; SENDACK(TRUE) END (* repeated packet *) ELSE (* Got a good packet *) IF INPACKETTYPE = 'D' THEN BEGIN (* Receive data *) LASTSEQNUM := INSEQ ; (* WRITELN ('RECEIVE data '); *) I := 1 ; WHILE I <= INDATACOUNT DO WITH REPLYMSG DO IF TRANSLATION THEN BEGIN (* SCAN EBCDIC data record *) IF (CHARS[I]=REPEATCHAR) AND (REPEATCHAR<>' ') THEN BEGIN (* Get number of repeated chars *) I := I + 1 ; CNT := ORD(EBCDICTOASCII[BYTES[I]])- 32 ; I:= I + 1 ; END (* Get number of repeated chars *) ELSE CNT := 1 ; IF CHARS[I] = BIT8_QUOTE THEN BEGIN (* BIT8 character *) CHARS[I] := '80'XC ; IF CRFLAG THEN (* previous char was a CR *) WRITE(FILEINCOMING,'0D'XC,CHARS[I]) ELSE WRITE (FILEINCOMING,CHARS[I]); I := I + 1 ; CRFLAG := FALSE ; END ; (* BIT8 character *) IF CHARS[I] = CNTRL_QUOTE THEN BEGIN (* CONTROL character *) I := I+1 ; IF (CHARS[I] <> ' ') AND ((CHARS[I] = CNTRL_QUOTE) OR (CHARS[I] = BIT8_QUOTE) OR (CHARS[I] = REPEATCHAR)) THEN ELSE BEGIN (* control char *) CHARS[I] := EBCDICTOASCII[BYTES[I]] ; IF CHARS[I] = '3F'XC THEN (* Make it a del *) BYTES[I] := '7F'X ELSE IF BYTES[I] >= 64 THEN (* Make it a control *) BYTES[I] := BYTES[I] - 64 ; IF BYTES[I] <> 0 THEN CHARS[I] := ASCIITOEBCDIC[BYTES[I]] ; END ; (* control char *) END ; (* CONTROL character *) IF CRFLAG THEN BEGIN (* previous char was a CR *) CRFLAG := FALSE ; IF CHARS[I] = '25'XC THEN (*LF*) WRITELN(FILEINCOMING) ELSE WRITE(FILEINCOMING,'0D'XC,CHARS[I]) END (* previous char was a CR *) ELSE IF CHARS[I] = '0D'XC THEN BEGIN (* CR *) CRFLAG := TRUE ; IF CNT > 1 THEN FOR J := 2 TO CNT DO WRITE (FILEINCOMING,CHARS[I]); END (* CR *) ELSE BEGIN (* not a CR *) CRFLAG := FALSE ; FOR J := 1 TO CNT DO WRITE (FILEINCOMING,CHARS[I]); END ; (* not a CR *) I := I + 1 ; END (* SCAN EBCDIC data record *) ELSE BEGIN (* Revert back to ASCII data record *) IF (CHARS[I]=REPEATCHAR) AND (REPEATCHAR<>' ') THEN BEGIN (* Get number of repeated chars *) I := I + 1 ; CNT := ORD(EBCDICTOASCII[BYTES[I]]) - 32 ; I:= I + 1 ; END (* Get number of repeated chars *) ELSE CNT := 1 ; IF (CHARS[I]=BIT8_QUOTE) AND (BIT8_QUOTE<>' ') THEN BEGIN (* 8TH BIT QUOTING *) I := I+1 ; BIT8 := 128 ; END (* 8TH BIT QUOTING *) ELSE BIT8 := 0 ; IF CHARS[I] = CNTRL_QUOTE THEN BEGIN (* CONTROL character *) I := I+1 ; IF (CHARS[I] <> ' ') AND ((CHARS[I] = CNTRL_QUOTE) OR (CHARS[I] = BIT8_QUOTE) OR (CHARS[I] = REPEATCHAR)) THEN CHARS[I] := EBCDICTOASCII[BYTES[I]] ELSE BEGIN (* control char *) CHARS[I] := EBCDICTOASCII[BYTES[I]] ; IF CHARS[I] = '3F'XC THEN (* Make it a del *) BYTES[I] := '7F'X ELSE IF BYTES[I] >= 64 THEN (* Make it a control *) BYTES[I] := BYTES[I] - 64 ; END ; (* control char *) END (* CONTROL character *) ELSE CHARS[I] := EBCDICTOASCII[BYTES[I]] ; BYTES[I] := BYTES[I] + BIT8 ; FOR J := 1 TO CNT DO WRITE (FILEINCOMING,CHARS[I]); (* no special check for CR an LF *) I := I + 1 ; END ; (* Revert back to ASCII data record *) OUTSEQ := INSEQ - 1 ; SENDACK(TRUE); END (* Receive data *) ELSE IF INPACKETTYPE = 'F' THEN BEGIN (* repeat *) OUTSEQ := OUTSEQ - 1 ; SENDACK(TRUE) ; END (* repeat *) ELSE IF INPACKETTYPE = 'Z' THEN BEGIN (* End of Incoming File *) CLOSE(FILEINCOMING); STATE := RF ; SENDACK(TRUE); END (* End of Incoming File *) ELSE BEGIN (* Not D,Z packet *) STATE := A; (* ABORT - Type not D,Z, *) ABORT := NOT_DZ ; END ; (* Not D,Z packet *) (* C ----- COMPLETED State ------- *) C: BEGIN (* COMPLETED Receiving *) SENDACK(TRUE); (* WRITELN ('RECEIVEing files completed.'); *) RECEIVING := FALSE ; END ; (* COMPLETED Receiving *) (* A ----- A B O R T State ------- *) A: BEGIN (* Abort Sending *) (* WRITELN ('RECEIVEing files ABORTED'); *) RECEIVING := FALSE ; (* SEND ERROR packet *) OUTDATACOUNT := 15 ; OUTSEQ := 0 ; SENDMSG.CHARS := 'Send file abort' ; OUTPACKETTYPE := 'E'; SENDPACKET ; END ; (* Abort Sending *) END ; (* CASE of STATE *) IF FULLSCREENDEVICE THEN IF NOT FULLSCREENIO THEN BEGIN READSCREEN; FINISCREEN; END ; END ; (* ------- RECVFILE procedure -------*) %PAGE (* **************************************************************** *) (* SHOWIT - This routine handles the SHOW COMMAND. * *) (* * *) (* **************************************************************** *) PROCEDURE SHOWIT ; BEGIN (* SHOWIT procedure *) IF FULLSCREENDEVICE THEN CMS('CLRSCRN ',RC ); WRITELN (' ------- Current Status -----------'); WRITELN(' '); IF TRANSLATION THEN WRITELN (' TRANSLATION is ON - ASCII/EBCDIC') ELSE WRITELN (' TRANSLATION is OFF' ); IF FB THEN WRITELN (' RECFM_INPUT is F LRECL is ',LRECL) ELSE WRITELN (' RECFM_INPUT is V '); WRITELN(' '); WRITELN(' PACKET SIZE is ',RPACKETSIZE:4, ' (RECEIVE PACKET SIZE)'); WRITELN(' EOL CHAR is ',ECHAR:2,' decimal(ascii)'); WRITELN(' CNTRL_QUOTE is ',CNTRL_QUOTE); WRITELN(' BIT8_QUOTE is ',BIT8_QUOTE); WRITELN(' CHECKTYPE is ',CHECKTYPE); WRITELN(' REPEATCHAR is ',REPEATCHAR); WRITELN(' '); WRITELN(' SEND PACKET SIZE is ',SPACKETSIZE:4, ' to accommodate the other KERMIT.'); WRITELN(' '); IF STATE = C THEN WRITELN('Last File transferred completed OK. '); IF STATE = A THEN BEGIN (* ABORTED file transfer *) WRITE ('Last File transfer Aborted while '); CASE ABORT OF BADSF: WRITELN('attempting to send file to micro.'); NOT_S: WRITELN('waiting for Init Packet.'); NOT_SFBZ: WRITELN('waiting for File header packet.'); NOT_DZ: WRITELN('waiting for a DATA packet.'); OTHERWISE WRITELN (' being completely confused '); END ; (* CASE ABORT *) WRITELN(' '); END ; (* ABORTED file transfer *) END ; (* SHOWIT procedure *) %PAGE (* **************************************************************** *) (* SETIT - This routine handles the SET COMMAND. * *) (* * *) (* **************************************************************** *) PROCEDURE SETIT ; BEGIN (* SETIT procedure *) IF FULLSCREENDEVICE THEN CMS('CLRSCRN ',RC ); (* WRITELN (' -------SET ROUTINE ------- '); *) COMMAND := GETTOKEN (INPUTSTRING); UPCASE(COMMAND); REQUEST := ' ' || TRIM(STR(COMMAND)); CINDEX := INDEX(WHATTABLE,REQUEST) DIV 8 ; CASE WHATFLAGS(CINDEX) OF (* BEGIN Set WHAT command *) $TRANSLATION : BEGIN (* TRANSLATION FLAG *) SETTING := GETTOKEN (INPUTSTRING); UPCASE(SETTING) ; TRANSLATION := NOT(SETTING = 'OFF ') ; IF TRANSLATION THEN WRITELN ('TRANSLATION is ON ') ELSE WRITELN ('TRANSLATION is OFF'); END ; (* TRANSLATION FLAG *) $RECFM : BEGIN (* RECFM *) SETTING := GETTOKEN (INPUTSTRING); UPCASE(SETTING) ; IF SETTING = 'F ' THEN FB := TRUE ELSE FB := FALSE; IF FB THEN WRITELN (' INPUT RECFM is F LRECL is ',LRECL) ELSE WRITELN (' INPUT RECFM is V '); END ; (* RECFM *) $LRECL: BEGIN (* LOGICAL RECORD LENGTH *) LRECL := STR(GETTOKEN (INPUTSTRING)); END ; (* LOGICAL RECORD LENGTH *) $PACKETSIZE: BEGIN (* SET PACKET SIZE *) READSTR(INPUTSTRING,RPACKETSIZE); IF RPACKETSIZE > (MAXINPUT-5) THEN BEGIN RPACKETSIZE := MAXINPUT-5 ; WRITELN ('Number too large. Will use ',RPACKETSIZE); END ; IF RPACKETSIZE < 26 THEN BEGIN WRITELN (' ERROR- Number too small. Will use 94.'); RPACKETSIZE := 94 ; END ; WRITELN(' PACKET SIZE is ',RPACKETSIZE:4); END ; (* SET PACKET SIZE *) $EOLCHAR : BEGIN (* SET end of line char *) READSTR(INPUTSTRING,ECHAR); WRITELN(' EOLCHAR is ',ECHAR,' decimal(ascii)'); END ; (* SET end of line char *) $CNTRL_QUOTE: BEGIN (* SET control quote *) READSTR(INPUTSTRING,CNTRL_QUOTE); WRITELN(' CNTRL QUOTE is ',CNTRL_QUOTE); END ; (* SET control quote *) $BIT8_QUOTE: BEGIN (* SET bit 8 quote *) READSTR(INPUTSTRING,BIT8_QUOTE); WRITELN(' BIT8_QUOTE is ',BIT8_QUOTE); END ; (* SET bit 8 quote *) $REPEATCHAR: BEGIN (* SET repeat char *) READSTR(INPUTSTRING,REPEATCHAR); WRITELN(' REPEATCHAR is ',REPEATCHAR); END ; (* SET repeat char *) $CHECKTYPE : BEGIN (* SET CHECK TYPE *) READSTR(INPUTSTRING,CHECKTYPE); WRITELN(' CHECKTYPE is ',CHECKTYPE ); END ; (* SET CHECK TYPE *) $DUMMY: WRITELN (' NOT YET implemented '); OTHERWISE BEGIN (* Invalid SET OPTION *) IF FULLSCREENDEVICE THEN CMS('CLRSCRN ',RC ); WRITELN (' SET ',REQUEST,' - invalid option specified.'); WRITELN (' Valid OPTIONS are : '); WRITELN (' ----------------------- '); WRITELN (' TRANSLATION ON/OFF - for ascii-ebcdic '); WRITELN (' RECFM V/F - Variable or Fixed'); WRITELN (' LRECL nnn - Record length(decimal)'); WRITELN (' EOLCHAR nn - Endline char(decimal)'); WRITELN (' PACKETSIZE nn - Packet size (decimal)'); WRITELN (' CNTRL_QUOTE c - Quote character '); WRITELN (' BIT8_QUOTE c - Bit8 quote character'); END ; (* Invalid SET OPTION *) END ; (* Execute the Command *) END ; (* SETIT procedure *) %PAGE (* **************************************************************** *) (* HELP - This routine handles the HELP COMMAND. * *) (* * *) (* **************************************************************** *) PROCEDURE HELP ; BEGIN (* HELP procedure *) IF FULLSCREENDEVICE THEN CMS('CLRSCRN ',RC ); WRITELN (' The following are the valid KERMIT-CMS commands : '); WRITELN ('-------------------------------------------------- '); WRITELN (' SEND fn ft fm '); WRITELN (' - send a file, IBM to micro '); WRITELN (' RECEIVE fm:fn.ft AS fn ft fm '); WRITELN (' - receive a file, micro to IBM'); WRITELN (' SERVER - go into server mode '); WRITELN (' '); WRITELN (' SET option value - set OPTION to VALUE '); WRITELN (' STATUS - displays current options settings'); WRITELN (' '); WRITELN (' CMS command - issues a CMS command.'); WRITELN (' CP command - issues a CP command.'); WRITELN (' '); WRITELN (' HELP - displays this information '); WRITELN (' EXIT - exit KERMIT , terminate program.'); WRITELN (' '); END ; (* HELP procedure *) %PAGE (* **************************************************************** *) (* REMOTECOMMAND -This routine handle the COMMANDS from a remote * *) (* kermit. * *) (* **************************************************************** *) PROCEDURE REMOTECOMMAND ; CONST SUBCOMMANDTABLE = 'ICLFDUETRKSPWMHQJV' ; TYPE SUBCOMMANDTYPE = (ZERO,I,C,L,F,D,U,E,T,R,K,S,P,W,M,H,Q,J,V); VAR COMMANDTYPE,SUBCOMMAND,DUMMY : CHAR ; DOT,COLON : INTEGER ; RET,FILEINDEX,IX,LEN1 : INTEGER ; FN,FT,FM : STRING(16) ; CMSFNAME : STRING(80); VARCOMM : STRING(80); VARNAME : STRING(80); VARVALUE: STRING(80); CMSCOMMAND : STRING(80) ; DATE,TIME : ALFA ; DIRECTORY : PACKED ARRAY[0..255] OF STRING(80); LABEL CHECKCOMMAND ; (* ----------------------------------------------------------------- *) PROCEDURE SENDBPACKET; BEGIN (* send break packet to terminate transmission *) OUTDATACOUNT := 0 ; OUTSEQ := OUTSEQ + 1 ; IF OUTSEQ >= 64 THEN OUTSEQ := 0 ; OUTPACKETTYPE := 'B' ; SENDPACKET ; END; (* send break packet to terminate transmission *) (* ----------------------------------------------------------------- *) PROCEDURE SENDZPACKET; BEGIN (* End of File *) OUTDATACOUNT := 0 ; OUTSEQ := OUTSEQ + 1 ; IF OUTSEQ >= 64 THEN OUTSEQ := 0; ; OUTPACKETTYPE := 'Z' ; SENDPACKET ; END ; (* End of File *) (* ----------------------------------------------------------------- *) PROCEDURE REMSETIT ; VAR TEMPSTR : STRING(256) ; BEGIN (* REMSETIT procedure *) COMMAND := GETTOKEN (INPUTSTRING); UPCASE(COMMAND); REQUEST := ' ' || TRIM(STR(COMMAND)); CINDEX := INDEX(WHATTABLE,REQUEST) DIV 8 ; CASE WHATFLAGS(CINDEX) OF (* BEGIN Set WHAT command *) $TRANSLATION : BEGIN (* TRANSLATION FLAG *) SETTING := GETTOKEN (INPUTSTRING); UPCASE(SETTING) ; TRANSLATION := NOT(SETTING = 'OFF') ; IF TRANSLATION THEN SENDMSG.CHARS := 'Translation is ON ' ELSE SENDMSG.CHARS := 'Translation is OFF '; END ; (* TRANSLATION FLAG *) $RECFM : BEGIN (* RECFM *) SETTING := GETTOKEN (INPUTSTRING); UPCASE(SETTING) ; IF SETTING[1] ='F' THEN FB := TRUE ELSE FB := FALSE; IF FB THEN SENDMSG.CHARS := 'INPUT RECFM is F ' ' ELSE SENDMSG.CHARS := 'INPUT RECFM is V '; END ; (* RECFM *) $LRECL: BEGIN (* LOGICAL RECORD LENGTH *) LRECL := STR(GETTOKEN (INPUTSTRING)); SENDMSG.CHARS := 'INPUT LRECL is ' || LRECL ; ' END ; (* LOGICAL RECORD LENGTH *) $PACKETSIZE: BEGIN (* SET PACKET SIZE *) READSTR(INPUTSTRING,RPACKETSIZE); IF RPACKETSIZE > (MAXINPUT-5) THEN BEGIN RPACKETSIZE := MAXINPUT-5 ; WRITESTR(TEMPSTR,RPACKETSIZE:-10); SENDMSG.CHARS:='Number too large. Use '|| TEMPSTR ; END ; IF RPACKETSIZE < 26 THEN BEGIN SENDMSG.CHARS :=' Number too small. Will use 94.'; RPACKETSIZE := 94 ; END ; WRITESTR(TEMPSTR,RPACKETSIZE:-10); SENDMSG.CHARS:=' PACKET SIZE is '|| TEMPSTR ; END ; (* SET PACKET SIZE *) $REPEATCHAR: BEGIN (* SET repeat char *) READSTR(INPUTSTRING,REPEATCHAR); SENDMSG.CHARS:=' REPEATCHAR is '|| STR(REPEATCHAR) ; END ; (* SET repeat char *) OTHERWISE SENDMSG.CHARS := 'Unavailable SET specs. '; END ; (*case*) OUTDATACOUNT := 25 ; OUTSEQ := 0 ; OUTPACKETTYPE := 'Y' ; SENDPACKET ; END ; (* REMSETIT procedure *) (* ---------------------------------------------------------------- *) (* REMSHOWIT - This routine handles the REMOTE SHOW COMMAND. *) PROCEDURE REMSHOWIT ; BEGIN (* REMSHOWIT procedure *) OUTDATACOUNT := 35 ; OUTSEQ := 0 ; OUTPACKETTYPE := 'X' ; IF TRANSLATION THEN SENDMSG.CHARS := 'TRANSLATION is ON - EBCDIC / ASCII ' ELSE SENDMSG.CHARS := 'TRANSLATION is OFF '; SENDPACKET ; IF RECVPACKET AND (INPACKETTYPE='Y') THEN ELSE RESENDIT(10); OUTPACKETTYPE := 'D' ; OUTSEQ := OUTSEQ + 1 ; IF FB THEN SENDMSG.CHARS := 'INPUT RECFM is F. LRECL = ' || LRECL ELSE SENDMSG.CHARS := 'INPUT RECFM is V '; SENDPACKET ; IF RECVPACKET AND (INPACKETTYPE='Y') THEN ELSE RESENDIT(10); OUTSEQ := OUTSEQ + 1 ; OUTDATACOUNT := 4 ; OUTPACKETTYPE := 'D' ; SENDMSG.CHARS := '#M#J'; SENDPACKET ; IF RECVPACKET AND (INPACKETTYPE='Y') THEN ELSE RESENDIT(10); SENDZPACKET ; IF RECVPACKET AND (INPACKETTYPE='Y') THEN ELSE RESENDIT(10); SENDBPACKET ; END ; (* REMSHOWIT procedure *) (* ----------------------------------------------------------------- *) FUNCTION CMSFILENAME (TEMPNAME : STRING(80) ): STRING(80) ; (* Converts name into a CMS name *) BEGIN (* CMS FILE NAME *) TEMPNAME := COMPRESS(TEMPNAME); COLON := INDEX(TEMPNAME,':'); IF COLON > 0 THEN TEMPNAME:=SUBSTR(TEMPNAME,COLON+1,LENGTH(TEMPNAME)-COLON) || ' ' || SUBSTR(TEMPNAME,1,COLON-1) ; DOT := INDEX(TEMPNAME,'.'); IF DOT > 0 THEN TEMPNAME[DOT] := ' ' ; CMSFILENAME := TEMPNAME ; END ; (* CMS FILE NAME *) (* ----------------------------------------------------------------- *) BEGIN (* REMOTECOMMAND procedure *) (* WRITELN (' GOT a REMOTE COMMAND. '); *) INDATACOUNT := ORD(EBCDICTOASCII[Ord(INPUTSTRING[2])])-32-3; COMMANDTYPE := INPUTSTRING[4]; CHECKCOMMAND : IF COMMANDTYPE = 'S' THEN (* SEND *) BEGIN (* SEND command *) INPUTSTRING := ' ' ; (* SENDACK(TRUE); *) RECVFILE ; END (* SEND command *) ELSE IF COMMANDTYPE = 'R' THEN (* RECEIVE *) BEGIN (* RECEIVE command *) INPUTSTRING := SUBSTR(INPUTSTRING,5,INDATACOUNT); COLON := INDEX(INPUTSTRING,':'); IF COLON > 1 THEN BEGIN (* Extract FM *) FM := SUBSTR(INPUTSTRING,1,COLON-1) ; INPUTSTRING := SUBSTR(INPUTSTRING,COLON+1, LENGTH(INPUTSTRING)-COLON); END (* Extract FM *) ELSE FM := ' ' ; DOT := INDEX(INPUTSTRING,'.'); IF DOT > 1 THEN BEGIN (* file name and type *) FN := SUBSTR(INPUTSTRING,1,DOT-1) ; FT := SUBSTR(INPUTSTRING,DOT+1,LENGTH(INPUTSTRING)-DOT); END (* file name and type *) ELSE BEGIN (* no file type *) FN := INPUTSTRING; FT := ' ' ; END ; (*no file type *) SENDFILE( FN || ' ' || FT || ' ' || FM ); END (* RECEIVE command *) ELSE IF COMMANDTYPE = 'C' THEN (* HOST COMMAND *) BEGIN (* HOST command *) INPUTSTRING := SUBSTR(INPUTSTRING,6,INDATACOUNT-1); CMS(INPUTSTRING,RC); OUTDATACOUNT := 25 ; OUTSEQ := 0 ; OUTPACKETTYPE := 'Y' ; SENDMSG.CHARS := 'Host Command submitted '; SENDPACKET ; END (* HOST command *) ELSE IF COMMANDTYPE = 'K' THEN (* KERMIT COMMAND *) BEGIN (* KERMIT command *) INPUTSTRING := SUBSTR(INPUTSTRING,6,INDATACOUNT-1); INPUTSTRING := LTRIM(COMPRESS(INPUTSTRING)); COMMAND := GETTOKEN (INPUTSTRING); UPCASE(COMMAND); IF COMMAND = 'SET' THEN REMSETIT ELSE IF COMMAND = 'SHOW' THEN REMSHOWIT ELSE BEGIN (* not set command *) OUTDATACOUNT := 25 ; OUTSEQ := 0 ; OUTPACKETTYPE := 'Y' ; SENDMSG.CHARS := STR(COMMAND) || ' not allowed . '; SENDPACKET ; END ; (* not set command *) END (* KERMIT command *) ELSE IF COMMANDTYPE = 'I' THEN (* INITIALIZE *) BEGIN (* INITIALIZE command *) INDATACOUNT := ORD(EBCDICTOASCII[Ord(INPUTSTRING[2])])-32-3; (* Writeln('Remote I Packet '); *) (* Get init parameters *) IF INDATACOUNT>= 1 THEN PSIZE := ORD(EBCDICTOASCII[Ord(INPUTSTRING[4+1])])-32 ; IF INDATACOUNT>= 5 THEN ECHAR := ORD(EBCDICTOASCII[Ord(INPUTSTRING[4+5])])-32 ; IF INDATACOUNT>= 6 THEN CNTRL_QUOTE := INPUTSTRING[4+6] ; IF INDATACOUNT>= 7 THEN BIT8_QUOTE := INPUTSTRING[4+7] ELSE BIT8_QUOTE := '00'XC ; (* No 8th bit quoting *) IF INDATACOUNT>= 8 THEN CHECKTYPE := INPUTSTRING[4+8] ELSE CHECKTYPE := '00'XC ; (* One char checksum DEFAULT *) IF INDATACOUNT>= 9 THEN REPEATCHAR := INPUTSTRING[4+9] ELSE REPEATCHAR := '00'XC ; (* No repeat char *) OUTPACKETTYPE := 'Y'; PUTINITPACKET ; SENDPACKET ; IF RECVPACKET THEN BEGIN COMMANDTYPE := INPACKETTYPE ; INPUTSTRING := 'XXX'|| STR(INPACKETTYPE) || SUBSTR(STR(REPLYMSG.CHARS),1,INDATACOUNT); GOTO CHECKCOMMAND ; END ; END (* INITIALIZE command *) ELSE IF COMMANDTYPE = 'G' THEN (* GENERAL *) BEGIN (* General command *) SUBCOMMAND := INPUTSTRING[5]; (* Writeln('Subcommand ',SUBCOMMAND); *) CASE SUBCOMMANDTYPE(INDEX(SUBCOMMANDTABLE,STR(SUBCOMMAND))) OF I: BEGIN (* LOGIN command *) (* LOGIN *) OUTDATACOUNT := 19 ; OUTSEQ := 0 ; OUTPACKETTYPE := 'X' ; SENDMSG.CHARS := 'Login to KERMIT-CMS'; SENDPACKET ; IF RECVPACKET AND (INPACKETTYPE='Y') THEN ELSE RESENDIT(10); SENDBPACKET ; END; (* LOGIN command *) C: BEGIN (* CHANGE command *) (* CHANGE *) OUTDATACOUNT := 35 ; OUTSEQ := 0 ; OUTPACKETTYPE := 'X' ; SENDMSG.CHARS := 'Change directory - Not Implemented '; SENDPACKET ; IF RECVPACKET AND (INPACKETTYPE='Y') THEN ELSE RESENDIT(10); SENDBPACKET ; END; (* CHANGE command *) L: BEGIN (* LOGOUT command *) (* LOGOUT *) RUNNING := FALSE ; SENDACK(TRUE); CMS('CP LOG ',RC); END; (* LOGOUT command *) F: BEGIN (* FINISH command *) (* FINISH *) RUNNING := FALSE ; SENDACK(TRUE); END; (* FINISH command *) D: BEGIN (* DIRECTORY command *) (* DIRECTORY *) IF LENGTH(INPUTSTRING)>7 THEN CMSFNAME:=SUBSTR(INPUTSTRING,7, ORD(EBCDICTOASCII[ORD(INPUTSTRING[6])])-32) ELSE CMSFNAME := '*' ; CMSCOMMAND := 'LISTFILE '|| CMSFILENAME(CMSFNAME) || ' (STACK LABEL )' ; CMS(CMSCOMMAND,RET); IF RET <> 0 THEN BEGIN (* No file *) OUTDATACOUNT := 15 ; OUTSEQ := 0 ; SENDMSG.CHARS := 'No file found. ' ; OUTPACKETTYPE := 'E'; SENDPACKET ; (* IF RECVPACKET AND (INPACKETTYPE='Y') THEN ELSE RESENDIT(10); *) END (* No file *) ELSE BEGIN (* GOT directory *) CMS('SENTRIES',RET); FILEINDEX := RET ; FOR IX := 1 TO FILEINDEX DO READLN (DIRECTORY[IX]:80); OUTSEQ := 0 ; (* SEND X HEADER *) SENDMSG.CHARS := CMSFNAME ; OUTDATACOUNT := LENGTH(CMSFNAME); OUTPACKETTYPE := 'X' ; SENDPACKET ; IF RECVPACKET AND (INPACKETTYPE='Y') THEN ELSE RESENDIT(10); STATE := SF ; FOR IX := 1 TO FILEINDEX DO IF STATE <> A THEN BEGIN (* SEND DIRECTORY *) CMSFNAME := DIRECTORY[IX] ; SENDMSG.CHARS := CMSFNAME ; OUTDATACOUNT := LENGTH(CMSFNAME); OUTPACKETTYPE := 'D' ; OUTSEQ := OUTSEQ + 1 ; IF OUTSEQ >= 64 THEN OUTSEQ := 0; ; SENDPACKET ; IF RECVPACKET THEN IF INPACKETTYPE = 'Y' THEN ELSE RESENDIT(10) ELSE RESENDIT(10); END ; (* SEND DIRECTORY *) SENDZPACKET ; (* EOF PACKET *) IF RECVPACKET AND (INPACKETTYPE='Y') THEN ELSE RESENDIT(10); SENDBPACKET ; END ; (* GOT directory *) END; (* DIRECTORY command *) U: BEGIN (* disk Usage command *) (* Disk Usage *) OUTDATACOUNT := 30 ; OUTSEQ := 0 ; OUTPACKETTYPE := 'Y' ; SENDMSG.CHARS := 'Disk usage - Not Implemented '; SENDPACKET ; (* IF RECVPACKET AND (INPACKETTYPE='Y') THEN ELSE RESENDIT(10); SENDBPACKET ; *) END; (* Disk Usage command *) E: BEGIN (* Erase File command *) (* Erase File *) IF LENGTH(INPUTSTRING)>7 THEN CMSFNAME:=SUBSTR(INPUTSTRING,7, ORD(EBCDICTOASCII[ORD(INPUTSTRING[6])])-32) ELSE CMSFNAME := '*' ; CMSCOMMAND := 'ERASE ' || CMSFILENAME (CMSFNAME); CMS(CMSCOMMAND,RET) ; OUTDATACOUNT := LENGTH(CMSFNAME) + 15 ; OUTSEQ := 0 ; OUTPACKETTYPE := 'Y' ; IF RET = 0 THEN SENDMSG.CHARS := 'file erased ' || CMSFNAME ELSE SENDMSG.CHARS := 'not erased - ' || CMSFNAME ; SENDPACKET ; (* IF RECVPACKET AND (INPACKETTYPE='Y') THEN ELSE RESENDIT(10); SENDBPACKET ; *) END; (* Erase File command *) T: BEGIN (* TYPE File command *) (* TYPE File *) IF LENGTH(INPUTSTRING)>7 THEN CMSFNAME:=SUBSTR(INPUTSTRING,7, ORD(EBCDICTOASCII[ORD(INPUTSTRING[6])])-32) ELSE CMSFNAME := '*' ; CMSFNAME := CMSFILENAME(CMSFNAME); DOT := INDEX(CMSFNAME,' '); IF DOT = 0 THEN CMSFNAME := CMSFNAME || ' *' ; CMSCOMMAND := 'STATE ' || CMSFNAME ; CMS(CMSCOMMAND,RET); IF RET <> 0 THEN BEGIN (* No file *) OUTDATACOUNT := 15 ; OUTSEQ := 0 ; SENDMSG.CHARS := 'No file found. ' ; OUTPACKETTYPE := 'E'; SENDPACKET ; END (* No file *) ELSE BEGIN (* GOT FILE *) DOT := INDEX(CMSFNAME,' '); IF DOT <> 0 THEN CMSFNAME[DOT] := '.' ; DOT := INDEX(CMSFNAME,' '); IF DOT <> 0 THEN CMSFNAME[DOT] := '.' ; RESET(FILETOSEND,'NAME='||CMSFNAME); OUTSEQ := 0 ; OUTPACKETTYPE := 'X' ; SENDMSG.CHARS := CMSFNAME ; OUTDATACOUNT := LENGTH(CMSFNAME); SENDPACKET; (* SENDACK(TRUE); *) IF RECVPACKET AND (INPACKETTYPE='Y') THEN ELSE RESENDIT(10); STATE := SF ; WHILE NOT ( EOF(FILETOSEND) OR (STATE=A) ) DO BEGIN (* SEND FILE *) OUTPACKETTYPE := 'D' ; FILETOPACKET ; SENDPACKET ; IF RECVPACKET AND (INPACKETTYPE='Y') THEN ELSE RESENDIT(10); IF EOLN(FILETOSEND) THEN READ(FILETOSEND,DUMMY); (* RESET *) END ; (* SEND FILE *) SENDZPACKET ; (* EOF PACKET *) IF RECVPACKET AND (INPACKETTYPE='Y') THEN ELSE RESENDIT(10); SENDBPACKET ; END ; (* GOT FILE *) END; (* TYPE File command *) R: BEGIN (* Rename file *) (* RENAME *) OUTDATACOUNT := 30 ; IF LENGTH(INPUTSTRING)>7 THEN BEGIN (* GOT PARM *) LEN1 := ORD(EBCDICTOASCII[ORD(INPUTSTRING[6])])-32; CMSFNAME:=SUBSTR(INPUTSTRING,7,LEN1); END ELSE CMSFNAME := '*' ; CMSFNAME := CMSFILENAME (CMSFNAME); DOT := INDEX(CMSFNAME,' '); IF DOT > 0 THEN BEGIN (* Check for FM *) DOT := INDEX(SUBSTR(CMSFNAME,DOT+1),' ' ) ; IF DOT = 0 THEN CMSFNAME := CMSFNAME || ' A' ; END (* Check for FM *) ELSE CMSFNAME := CMSFNAME || '*' ; CMSCOMMAND := 'RENAME ' || CMSFNAME ; IF LENGTH(INPUTSTRING)> (7+ LEN1) THEN CMSFNAME:=SUBSTR(INPUTSTRING,8+LEN1, ORD(EBCDICTOASCII[ORD(INPUTSTRING[7+LEN1])])-32) ELSE CMSFNAME := '*' ; CMSFNAME := CMSFILENAME (CMSFNAME); DOT := INDEX(CMSFNAME,' '); IF DOT > 0 THEN BEGIN (* Check for FM *) DOT := INDEX(SUBSTR(CMSFNAME,DOT+1),' ' ) ; IF DOT = 0 THEN CMSFNAME := CMSFNAME || ' =' ; END (* Check for FM *) ELSE CMSFNAME := CMSFNAME || '*' ; IF INDEX(CMSFNAME,'*') > 0 THEN BEGIN (* Invalid file *) OUTDATACOUNT := 25 ; OUTSEQ := 0 ; SENDMSG.CHARS := 'Invalid File Specfication ' ; OUTPACKETTYPE := 'E'; SENDPACKET ; END (* Invalid File *) ELSE BEGIN (* RENAME IT *) CMSCOMMAND := CMSCOMMAND ||' '|| CMSFNAME ; CMS(CMSCOMMAND,RET) ; OUTDATACOUNT := LENGTH(CMSFNAME) + 16 ; OUTSEQ := 0 ; OUTPACKETTYPE := 'Y' ; IF RET = 0 THEN SENDMSG.CHARS := 'File renamed - ' || CMSFNAME ELSE SENDMSG.CHARS := 'Not renamed to ' || CMSFNAME ; SENDPACKET ; END ; (* RENAME IT *) END; (* Rename file *) K: BEGIN (* Copy file *) (* COPY *) OUTDATACOUNT := 30 ; OUTSEQ := 0 ; OUTPACKETTYPE := 'Y' ; SENDMSG.CHARS := 'Copy file - Not Implemented '; SENDPACKET ; END; (* Copy file *) S: BEGIN (* Submit command *) (* SUBMIT *) OUTDATACOUNT := 30 ; OUTSEQ := 0 ; OUTPACKETTYPE := 'X' ; SENDMSG.CHARS := 'SUMIT COMMAND NOT IMPLEMENTED '; SENDPACKET ; IF RECVPACKET AND (INPACKETTYPE='Y') THEN ELSE RESENDIT(10); SENDBPACKET ; END; (* Submit command *) P: BEGIN (* Program command *) (* PROGRAM *) OUTDATACOUNT := 30 ; OUTSEQ := 0 ; OUTPACKETTYPE := 'X' ; SENDMSG.CHARS := 'PROGRAM - Not Implemented '; SENDPACKET ; IF RECVPACKET AND (INPACKETTYPE='Y') THEN ELSE RESENDIT(10); SENDBPACKET ; END; (* PROGRAM command *) W: BEGIN (* WHO command *) (* WHO *) OUTDATACOUNT := 30 ; OUTSEQ := 0 ; OUTPACKETTYPE := 'X' ; SENDMSG.CHARS := 'WHO - Not Implemented '; SENDPACKET ; IF RECVPACKET AND (INPACKETTYPE='Y') THEN ELSE RESENDIT(10); SENDBPACKET ; END; (* WHO command *) M: BEGIN (* MESSAGE command *) (* MESSAGE *) OUTDATACOUNT := 30 ; OUTSEQ := 0 ; OUTPACKETTYPE := 'X' ; SENDMSG.CHARS := 'MESSAGE - not implemented '; SENDPACKET ; IF RECVPACKET AND (INPACKETTYPE='Y') THEN ELSE RESENDIT(10); SENDBPACKET ; END; (* MESSAGE command *) H: BEGIN (* HELP command *) (* HELP *) OUTDATACOUNT := 15 ; OUTSEQ := 0 ; OUTPACKETTYPE := 'X' ; SENDMSG.CHARS := 'See KERMIT DOC '; SENDPACKET ; IF RECVPACKET AND (INPACKETTYPE='Y') THEN ELSE RESENDIT(10); SENDBPACKET ; END; (* HELP command *) Q: BEGIN (* QUERY status command *) (* QUERY *) OUTDATACOUNT := 15 ; OUTSEQ := 0 ; OUTPACKETTYPE := 'X' ; SENDMSG.CHARS := 'Your ok '; SENDPACKET ; IF RECVPACKET AND (INPACKETTYPE='Y') THEN ELSE RESENDIT(10); SENDBPACKET ; END; (* QUERY Status command *) J: BEGIN (* Journal *) (* JOURNAL *) OUTDATACOUNT := 15 ; OUTSEQ := 0 ; OUTPACKETTYPE := 'Y' ; SENDMSG.CHARS := 'No Journal '; SENDPACKET ; END; (* Journal *) V: BEGIN (* Variable *) (* VARIABLE *) INPUTSTRING:=SUBSTR(INPUTSTRING,6,INDATACOUNT-1); LEN1 := ORD(EBCDICTOASCII[ORD(INPUTSTRING[1])])-32; IF LENGTH(INPUTSTRING)>2 THEN BEGIN (* VAR COMMAND *) VARCOMM:=SUBSTR(INPUTSTRING,2,LEN1); INPUTSTRING := SUBSTR(INPUTSTRING,LEN1+2, LENGTH(INPUTSTRING)-(LEN1+1)); END (* VAR COMMAND *) ELSE VARCOMM:='X' ; VARCOMM[1] := CHR(ORD(VARCOMM[1]) | '40'X) ; IF LENGTH(INPUTSTRING)>2 THEN BEGIN (* Got a variable name *) LEN1 := ORD(EBCDICTOASCII[ORD(INPUTSTRING[1])])-32; VARNAME:=SUBSTR(INPUTSTRING,2,LEN1); INPUTSTRING := SUBSTR(INPUTSTRING,LEN1+2, LENGTH(INPUTSTRING)-(LEN1+1)); FOR IX:=1 TO LEN1 DO (* Upcase it *) VARNAME[IX] := CHR(ORD(VARNAME[IX]) | '40'X) ; END (* Got a variable name *) ELSE VARNAME:=' '; IF LENGTH(INPUTSTRING)>2 THEN BEGIN (* Got a variable value *) LEN1 := ORD(EBCDICTOASCII[ORD(INPUTSTRING[1])])-32; VARVALUE :=SUBSTR(INPUTSTRING,2,LEN1); END (* Got a variable value *) ELSE VARVALUE :=' ' ; IF (VARCOMM[1] = 'S') OR (VARCOMM[1] = 'Q') THEN IF VARNAME = 'DATE' THEN BEGIN (* Set Date *) DATETIME(DATE,TIME); SENDMSG.CHARS := 'DATE ' || STR(DATE) || ' '; END (* Set Date *) ELSE IF VARNAME = 'TIME' THEN BEGIN (* Set Time *) DATETIME(DATE,TIME); SENDMSG.CHARS := 'TIME ' || STR(TIME) || ' '; END (* Set Time *) ELSE SENDMSG.CHARS := 'Variable not implemented ' ELSE SENDMSG.CHARS := 'Not SET or QUERY variable.'; OUTDATACOUNT := 25 ; OUTSEQ := 0 ; OUTPACKETTYPE := 'Y' ; SENDPACKET ; END; (* Variable *) OTHERWISE BEGIN (* ERROR command *) OUTDATACOUNT := 15 ; OUTSEQ := 0 ; OUTPACKETTYPE := 'E' ; SENDMSG.CHARS := 'Unknown Command'; SENDPACKET ; END ; (* ERROR command *) END ; (* CASE OF SUBCOMMAND *) END (* General command *) ELSE BEGIN (* ERROR command *) OUTDATACOUNT := 15 ; OUTSEQ := 0 ; OUTPACKETTYPE := 'E' ; SENDMSG.CHARS := 'Unknown Command'; SENDPACKET ; END ; (* ERROR command *) END ; (* REMOTECOMMAND procedure *) %PAGE (* **************************************************************** *) (* ******* OUTTER BLOCK OF KERMIT ******* *) (* **************************************************************** *) BEGIN TERMOUT(OUTPUT,'NOCC,RECFM=V'); TERMIN (INPUT); CMS('Q TERM (STACK) ',RC ); (* GET CURRENT TERMINAL SETTINGS *) READLN(OLDSETTINGS) ; (* line 1 *) OLDSETTINGS := DELETE(OLDSETTINGS,INDEX(OLDSETTINGS,','),1); OLDSETTINGS := DELETE(OLDSETTINGS,INDEX(OLDSETTINGS,','),1); OLDSETTINGS := DELETE(OLDSETTINGS,INDEX(OLDSETTINGS,','),1); OLDSETTINGS := DELETE(OLDSETTINGS,INDEX(OLDSETTINGS,','),1); READLN(INPUTSTRING) ; (* line 2 *) OLDSETTINGS := OLDSETTINGS || ' ' ||SUBSTR(INPUTSTRING,1,12); READLN(INPUTSTRING) ; (* line 3 *) CMS('DEVTYPE (STK) ',RC ); READLN(INPUTSTRING) ; FULLSCREENDEVICE := INDEX(INPUTSTRING,'GRAPHICS') = 1 ; (* true if via series/1 *) IF FULLSCREENDEVICE THEN CMS('CP TERM CHARDEL OFF',RC) ELSE CMS('CP TERM CHARDEL ' || '16'XC,RC) ; CMS('CP TERM LINEND OFF LINEDEL OFF ESCAPE OFF ',RC ); CMS('CP TERM LINESIZE 132 ',RC); CMS('CP SET MSG OFF ',RC); (* set intial default values *) TRANSLATION := TRUE ; LRECL := '80' ; FULLSCREENIO := FALSE ; WRITELN(' Begin KERMIT Program '); INPUTSTRING := PARMS ; RUNNING := TRUE ; WHILE RUNNING DO BEGIN (* Command Loop *) PROMPT: IF FULLSCREENIO THEN BEGIN (* FULL SCREEN IO *) READSCREEN ; FOR RI := 4 TO RECVLENGTH DO IF RECVBUFF.BYTES[RI] <> '00'X THEN RECVBUFF.CHARS[RI] := ASCIITOEBCDIC[RECVBUFF.BYTES[RI] & '7F'X] ; INPUTSTRING:=SUBSTR(STR(RECVBUFF.CHARS),4,RECVLENGTH-4); END (* FULL SCREEN IO *) ELSE BEGIN (* NORMAL IO *) WRITELN ('KERMIT-CMS>') ; IF (BIT8_QUOTE = ' ') AND (NOT TRANSLATION) THEN BEGIN (* Warning *) WRITELN('**** WARNING - TRANSLATION is turned off,'); WRITELN ('other kermit can not handle the 8th bit.'); END ; (* Warning *) IF CNTRL_QUOTE = '#' THEN (* default value ok *) ELSE BEGIN (* Warning *) WRITELN ('*** WARNING - Non standard CNTRL_QUOTE is ', CNTRL_QUOTE); WRITELN (' Standard CNTRL_QUOTE is # '); END ; (* Warning *) IF LENGTH(INPUTSTRING) < 1 THEN READLN (INPUTSTRING); END ; (* NORMAL IO *) INPUTSTRING := LTRIM(INPUTSTRING); IF INPUTSTRING = ' ' THEN BEGIN IF FULLSCREENIO THEN BEGIN SI := 8 ; SENDBUFF.CHARS := (* SERVER MODE> *) 'C3115D7F110001BE'XC ; RITESCREEN ; (* SEND SERVER PROMPT *) SI := 8 ; (* Reset data pointer *) END ; GOTO PROMPT; END ; J := INDEX(INPUTSTRING,SOH) ; IF J>0 THEN BEGIN (* REMOTE COMMAND *) IF J>1 THEN INPUTSTRING := DELETE(INPUTSTRING,1,J-1); IF FULLSCREENDEVICE AND NOT FULLSCREENIO THEN BEGIN (* INIT SCREEN IO *) FULLSCREENIO := TRUE ; INITSCREEN ; SI := 19 ; SENDBUFF.CHARS := (* SERVER MODE> *) 'C3115D7F110001534552564552204D4F4445BE'XC ; RITESCREEN ; (* SEND SERVER PROMPT *) SI := 8 ; (* Reset data pointer *) SENDACK(FALSE); GOTO PROMPT ; END ; (* INIT SCREEN IO *) REMOTECOMMAND ; END (* REMOTE COMMAND *) ELSE BEGIN (* Local Command *) INPUTSTRING := LTRIM(COMPRESS(INPUTSTRING)); COMMAND := GETTOKEN (INPUTSTRING); UPCASE(COMMAND); REQUEST := ' ' || TRIM(STR(COMMAND)); CINDEX := INDEX(COMMTABLE,REQUEST) DIV 8 ; IF CINDEX = 0 THEN BEGIN SI := 8 ; SENDBUFF.CHARS := (* SERVER MODE> *) 'C3115D7F110001BE'XC ; RITESCREEN ; (* SEND SERVER PROMPT *) SI := 8 ; (* Reset data pointer *) GOTO PROMPT; END ; IF FULLSCREENIO THEN BEGIN FINISCREEN; FULLSCREENIO := FALSE; END; CASE COMMANDS(CINDEX) OF (* BEGIN Execute the Command *) $BAD : BEGIN (* bad command *) WRITELN(COMMAND,' is an bad command. '); END ; (* bad command *) $SEND : SENDFILE (' ') ; $RECEIVE: RECVFILE ; $SERVER : IF FULLSCREENDEVICE THEN IF NOT FULLSCREENIO THEN BEGIN (* INIT SCREEN IO *) FULLSCREENIO := TRUE ; INITSCREEN ; SI := 20 ; SENDBUFF.CHARS := (* SERVER MODE> *) 'C3115D7F110001534552564552204D4F4445BE84'XC ; RITESCREEN ; (* SEND SERVER PROMPT *) SI := 8 ; (* Reset data pointer *) END (* INIT SCREEN IO *) ELSE ELSE WRITELN(' SERVER MODE ','37'XC); $SET : SETIT ; $SHOW : SHOWIT ; $STATUS: SHOWIT ; $HELP : HELP ; $QUES : HELP ; $CMS : CMS(INPUTSTRING,RC); $CP : CMS('CP ' || INPUTSTRING,RC); $QUIT, $EXIT : RUNNING := FALSE ; OTHERWISE IF FULLSCREENIO THEN BEGIN SI := 8 ; SENDBUFF.CHARS := (* SERVER MODE> *) 'C3115D7F110001BE'XC ; RITESCREEN ; (* SEND SERVER PROMPT *) SI := 8 ; (* Reset data pointer *) GOTO PROMPT; END ELSE WRITELN(COMMAND,' is an INVALID command') ; END ; (* Execute the Command *) END ; (* Local Command *) INPUTSTRING := ''; END ; (* Command Loop *) IF FULLSCREENIO THEN BEGIN READSCREEN ; FINISCREEN; FULLSCREENIO := FALSE; END; CMS('CP TERM ' || OLDSETTINGS,RC); CMS('CP SET MSG ON ',RC); WRITELN('Terminal settings restored and MSG is ON '); WRITELN(' End of KERMIT '); END.