home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
cmsqueens
/
cm2ker.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
2020-01-01
|
110KB
|
2,510 lines
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<MAXDATASIZE) AND (NOT EOF(FILETOSEND)) DO
WITH SENDMSG DO
BEGIN (* Process character *)
OUTDATACOUNT := OUTDATACOUNT + 1 ;
READ(FILETOSEND,ACHAR) ;
CHARS[OUTDATACOUNT] := ACHAR ;
IF (PREVCHAR = ACHAR) AND (REPEATCHAR>' ')
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.
