home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
ibmtsoqueens.tar.gz
/
ibmtsoqueens.tar
/
ts2ker.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-08-16
|
114KB
|
2,801 lines
PROGRAM KERMIT;
(*********************************************************************)
(* *)
(* KERMIT - File transfer Program for MVS/TSO *)
(* ( and RACF file access control ) *)
(* Author - Fritz Buetikofer (M70B@CBEBDA3T.BITNET) *)
(* Version - 2.3 *)
(* Date - 1987 August *)
(* *)
(* This program is an adaptation of the original CMS version of *)
(* Victor Lee. Due to a big difference between CMS and TSO, most *)
(* parts of the program had to be changed. *)
(* *)
(*********************************************************************)
(* *)
(* 1985 Sept 10 Program is totally changed for use with MVS/XA TSO *)
(* without any Series/1 frontend processor. *)
(* 1985 Oct 15 Commands DISK, DIR, DELETE, TYPE and WHO added *)
(* for those users, not very experienced with TSO. *)
(* 1985 Oct 24 Correct treatment of the 'repetition' char. *)
(* 1985 Oct 29 Check of the sequence of data packets from the *)
(* micro. Old packets are skipped by an ACK. *)
(* 1985 Nov 14 Correct handling of the 8th bit quoting for text *)
(* files (according to the 2 translation tables). *)
(* 1985 Nov 22 Warning to user, if using a 327x-alike terminal- *)
(* emulator (fullscreen support not available yet). *)
(* 1986 Jan 03 New command MEMBER added for partitionned files *)
(* 1986 Jan 13 Wildcard procedure added for sending files. *)
(* 1986 Feb 03 Setup Option added, using TSO file KERMIT.SETUP *)
(* if present. *)
(* 05 Remote help file built in. *)
(* 1986 Feb 18 KERMIT may issue FINISH command to micro running *)
(* actually in server mode. *)
(* 1986 Apr 04 SET REPEATCHAR, SET SOHchar and SET option ? *)
(* facility added *)
(* 1986 May 07 TAKE command added, to execute commands from an *)
(* external file. *)
(* 1986 May 14 Display in STATUS screen, whether Init-file has *)
(* been processed or not. *)
(* 1986 May 23 SET ATOE/ETOA added to modify the ASCII<->EBCDIC *)
(* translation table on running KERMIT program. *)
(* 1986 June 16 SET INCOMPLETE added to control the disposition of *)
(* an incomplete incoming file. *)
(* 1986 Aug 28 Command SEND filename updated, so the user can spe-*)
(* cify the name going to the micro. *)
(*********************************************************************)
(* After a period of other work to be done, I found again some time *)
(* to implement a brand new feature: long packets ! *)
(* *)
(* 1987 Jan 19 Abort Remote_Help or Remote_Dir if not ACK or NAK *)
(* is received (return to server_init state). *)
(* 1987 Jan 23 Implementation of long packets done. For test use *)
(* I restricted the max. length to 1024 = 1K, which *)
(* seems to be adequate for use over LANs. *)
(* As soon as pack.length exceeds 256 bytes, the *)
(* checktype is automatically set to 3=CRC. *)
(* 1987 Jan 30 Modifications in SendPacket and RecvPacket, be- *)
(* cause they handled the checktype wrong. *)
(* 1987 Mar 25 Modification in Main Program, so that the first *)
(* packet received in SERVER-mode is handled correct. *)
(* 1987 Mar 27 Implementation of the ATTRIBUTE packets. Addition *)
(* of the command DO, which executes members taken *)
(* from the partitioned dataset KERMIT.PROFILE. *)
(* 1987 Aug 15 Corrections in routine SENDFILE, so that ACKs are *)
(* checked with the actual sequence. *)
(* *)
(*********************************************************************)
(* *)
(* 1. This version of kermit will handle binary files, *)
(* i.e. it will handle 8th bit quoting. *)
(* *)
(* 2. By default all characters 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 TEXT OFF. *)
(* *)
(* 3. This version contains a slot for all the documented *)
(* advanced server functions, however only some are implemented*)
(* *)
(*********************************************************************)
(* *)
(* Utility Procedures: *)
(* SendPacket RecvPacket ReSendit TSOService *)
(* SendACK GetToken Wait UPCase *)
(* TRead TWrite Prompt InPacket *)
(* OutPacket TermSize CheckDsn Extract *)
(* CRCheck SendChar CheckParms Micro_Finish *)
(* RecvChar SendError ParmPacket FileToPacket *)
(* Wildcard_Search Write_State *)
(* *)
(* *)
(* 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. *)
(* *)
(*********************************************************************)
%TITLE Declarations
TYPE
LString = STRING (256);
FString = PACKED ARRAY (.1..256.) OF CHAR;
LPString = STRING (1024);
PString = PACKED ARRAY (.1..1024.) OF CHAR;
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..1024.) OF CHAR );
TWO :( BYTES : PACKED ARRAY (.1..1024.) OF BYTE )
END;
STATETYPE = (S_I,S,SF,SD,SZ,SB,C,A,R,RF,RD);
ABORTTYPE = (NOSOH,BADSF,NOT_S,NOT_SFBZ,NOT_DZ);
DISPTYPE = (NEW, NEWMEM, OLD, OLDMEM, SHARE,
MODIFY, ERROR, NOACC, BADNAME, NOMEM);
COMMANDS = ($BAD, $SEND, $RECEIVE, $SERVER, $SET,
$SHOW, $STATUS, $HELP, $QUES, $DEL,
$DIR, $DISK, $MEM, $TSO, $TYPE,
$WHO, $FINISH, $QUIT, $END, $EXIT,
$DO, $LOG, $TAKE, $VERSION);
WHATFLAGS = ($ZERO, $TEXTMODE,
$EXTEND1,
$RECFM, $PACKETSIZE,
$EXTEND2, $EOLCHAR,
$CNTRL_QUOTE, $EXTEND3,
$BIT8_QUOTE, $EXTEND4,
$CHECKTYPE, $EXTEND5,
$DELAY, $DEBUG,
$REPCHAR, $EXTEND6,
$SOHCHAR, $ATOE,
$ETOA, $INCOMPLETE,
$EXTEND7, $DUMMY);
CONST
COMMTABLE = 'BAD ' ||
'SEND ' ||
'RECEIVE ' ||
'SERVER ' ||
'SET ' ||
'SHOW ' ||
'STATUS ' ||
'HELP ' ||
'? ' ||
'DELETE ' ||
'DIR ' ||
'DISK ' ||
'MEMBERS ' ||
'TSO ' ||
'TYPE ' ||
'WHO ' ||
'FINISH ' ||
'QUIT ' ||
'END ' ||
'EXIT ' ||
'DO ' ||
'LOGOUT ' ||
'TAKE ' ||
'VERSION ';
WHATTABLE = 'BAD ' ||
'TEXTMODE' ||
' ' ||
'RECFM ' ||
'PACKETSI' ||
'ZE ' ||
'EOLCHAR ' ||
'CNTRL_QU' ||
'OTE ' ||
'BIT8_QUO' ||
'TE ' ||
'CHECKTYP' ||
'E ' ||
'DELAY ' ||
'DEBUG ' ||
'REPEATCH' ||
'AR ' ||
'SOHCHAR ' ||
'ATOE ' ||
'ETOA ' ||
'INCOMPLE' ||
'TE ' ||
'DUMMY ';
SPECTABLE = '00'XC || '!"#$%&''()*+,-./:;<=>{|}~';
DCB_Fix = 'RECFM(F,B) LRECL(80) BLKSIZE(6160)'; (* Fixed *)
DCB_Var = 'RECFM(V,B) LRECL(255) BLKSIZE(3024)'; (* Variable *)
DCB_Bin = 'RECFM(U) LRECL(1024) BLKSIZE(6144)'; (* Binary *)
DCB_DEBUG = 'RECFM(V,B) LRECL(255) BLKSIZE(6200)';
DEBUGNAME = 'KERMIT.DEBUG'; (* Name of DEBUG data set *)
CMDNAME = 'KERMIT.SETUP'; (* Name of SETUP data set *)
PROFNAME = 'KERMIT.PROFILE'; (* Name of PROFILE data set *)
VAR
RUNNING,
EndKermit,
GetFile,
EOLINE,
Remote,
CmdMode,
Init_File,
GETREPLY : BOOLEAN;
COMMAND,
SETTING : ALFA;
REQUEST : STRING (9);
CINDEX,
CHECKBYTES,
I,J,K,LEN,RC,
ScreenSize : INTEGER;
Handle_Attribute,
Long_Packet,
TEXTMODE, FB : BOOLEAN;
UserID : STRING (8);
STATE : STATETYPE;
ABORT : ABORTTYPE;
DsnDisp : DISPTYPE;
INPUTSTRING, (* Command string *)
TSOCommand : LString; (* TSO command string *)
Line : LPString;
(* Packet variables *) (* format *)
(* Receive Send *) (* SOH *)
INCOUNT, OUTCOUNT, (* COUNT *)
INDATACOUNT, OUTDATACOUNT : INTEGER; (* Chr-COUNT*)
INSEQ, OUTSEQ : BYTE; (* SEQNUM *)
INPACKETTYPE, OUTPACKETTYPE : CHAR; (* TYPE *)
REPLYMSG, SENDMSG : PACKET; (* DATA... *)
CHECKSUM : INTEGER; (* CHECKSUM *)
CRC : TWOBYTES; (* CRC-CCITT*)
SENDBUFF,RECVBUFF : PACKET;
MAXLENGTH,SI,RI,RECVLENGTH,FC : TWOBYTES;
TSODS, (* File with TSO info *)
DFILE, (* DEBUG-Info file *)
CmdFile, (* SETUP file *)
SFILE : TEXT; (* SEND file *)
FileCount : INTEGER;
FileList : ARRAY (.1..100.) OF LString;
STATIC
ASCIITOEBCDIC,
EBCDICTOASCII : PACKED ARRAY (.1..255.) OF CHAR;
CAPAS,
PSIZE, ECHAR, SCHAR : INTEGER;
CNTRL_QUOTE, BIT8_QUOTE,
CHECKTYPE, REPEATCHAR,
SeqChar, LastSeq, SOH : CHAR;
Delay : REAL;
Debug, RECEIVING,
Incomplete_File : BOOLEAN;
CRLF : STRING (4);
VALUE
PSIZE := 94; (* PACKET size = 94 (maximum) *)
SOH := '01'XC ; (* Start of packet - <Ctrl>-A *)
ECHAR := 13; (* End of line char - CR *)
SCHAR := 1;
CAPAS := 0;
CNTRL_QUOTE := '#';
BIT8_QUOTE := '&';
CHECKTYPE := '1'; (* 1 BYTE checksum *)
Delay := 6.0; (* Wait-factor = 6 seconds *)
Debug := FALSE; (* No debugging first *)
REPEATCHAR := '~'; (* Repeat quote *)
CRLF := '#M#J'; (* String with CR, LF *)
SeqChar := '31'XC; (* Initial value *)
Incomplete_File := TRUE; (* Keep/Discard incomplete file *)
(* THIS IS THE EXTENDED-ASCII TO EBCDIC TABLE, TYPE SWISS *)
ASCIITOEBCDIC :=
'010203372D2E2F1605250B0C0D0E0F'XC || (* 0. *)
'100000003C3D322618193F271C1D1E1F'XC || (* 1. *)
'404F7F7B5B6C507D4D5D5C4E6B604B61'XC || (* 2. *)
'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F'XC || (* 3. *)
'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6'XC || (* 4. *)
'D7D8D9E2E3E4E5E6E7E8E94AE05A5F6D'XC || (* 5. *)
'79818283848586878889919293949596'XC || (* 6. *)
'979899A2A3A4A5A6A7A8A9C06AD0A107'XC || (* 7. *)
'48DC51424344814852535457565863C1'XC || (* 8. *)
'C50000CBCCCDDBDDA8ECFC00B1000086'XC || (* 9. *)
'455596DE49D58196005F000000000000'XC || (* A. *)
'000000FAEDEDEDBCBCEDFABCBBBBBBBC'XC || (* B. *)
'ABCECFEBBF8FEBEBABACCECFEBBF8FCE'XC || (* C. *)
'CECFCFABABACAC8F8FBBAC0000000000'XC || (* D. *)
'00000000000000000000000000000000'XC || (* E. *)
'00000000000000000000AF0000009F00'XC; (* F. *)
(* THIS IS THE EBCDIC TO EXTENDED-ASCII CONVERSION TABLE (SWISS) *)
(* CHARACTERS NOT REPRESENTABLE IN ASCII ARE REPLACED BY A NULL *)
EBCDICTOASCII :=
'0102030009007F0009000B0C0D0E0F'XC || (* 0. *)
'10202020000D0800181900001C1D1E1F'XC || (* 1. *)
'00000000000A171B0000000000050607'XC || (* 2. *)
'0000160000000004000000001415001A'XC || (* 3. *)
'2020838485A0000087A45B2E3C282B21'XC || (* 4. *)
'268288898AA18C8B8D005D242A293B5E'XC || (* 5. *)
'2D2F008E0000000000007C2C255F3E3F'XC || (* 6. *)
'000000000000000000603A2340273D22'XC || (* 7. *)
'006162636465666768690000002800C5'XC || (* 8. *)
'006A6B6C6D6E6F7071720000002900FE'XC || (* 9. *)
'007E737475767778797A00C0DA5B00FA'XC || (* A. *)
'009C000000000000000000D9BF5D00C4'XC || (* B. *)
'7B41424344454647484900939495C1C2'XC || (* C. *)
'7D4A4B4C4D4E4F50515200968197A300'XC || (* D. *)
'5C00535455565758595A00C399B40000'XC || (* E. *)
'30313233343536373839B3009A000000'XC ; (* F. *)
LABEL MAINLOOP;
%TITLE Special TSO Routines
(*==================================================================*)
(* TSOService - This procedure executes all TSO command requests. *)
(*==================================================================*)
(* The following routine resides in the LPA -> Pgm must be loaded *)
PROCEDURE IKJEFTSR (CONST P1 : INTEGER; CONST P2 : FString;
VAR P3, P4, P5, P6 : INTEGER); FORTRAN;
PROCEDURE TSOService (CONST Cmd : LString; VAR Code : INTEGER);
VAR
Command : FString;
a, b, c, d, e : INTEGER;
BEGIN
a := 257; c := 0; d := 0; e := 0;
Command := Cmd; b := LENGTH (Cmd);
IKJEFTSR (a, Command, b, c, d, e);
Code := c
END (* TSOService *);
(*==================================================================*)
(* Waiting - This procedure waits 'w' seconds before proceeding *)
(*==================================================================*)
PROCEDURE Wait (CONST i : INTEGER); FORTRAN; (* Pause i seconds *)
PROCEDURE Waiting (w : REAL);
TYPE
Convert = RECORD
CASE BOOLEAN OF
TRUE : ( Int : INTEGER);
FALSE : ( Chrs : PACKED ARRAY (.1..4.) OF CHAR);
END;
VAR
I : INTEGER;
Fact : Convert;
BEGIN
I := TRUNC (w * 100);
Fact.Chrs (.1.) := CHR (0);
Fact.Chrs (.2.) := CHR (0);
Fact.Chrs (.3.) := CHR (I DIV 256);
Fact.Chrs (.4.) := CHR (I MOD 256);
Wait (Fact.Int)
END (* Waiting *);
PROCEDURE UPCASE (VAR S : ALFA);
VAR i : INTEGER;
ch : CHAR;
BEGIN
FOR i := 1 TO LENGTH (S) DO BEGIN
ch := S (.i.);
IF ch IN (.'a'..'z'.) THEN S (.i.) := CHR ( ORD (ch) + 64)
END
END;
%PAGE
PROCEDURE TRead (CONST Prompt : FString;
CONST Prompt_Len : INTEGER;
VAR Message : PString;
VAR M_Len, RC : INTEGER); FORTRAN;
(*==================================================================*)
(* Prompt - This procedure prompts the user for input *)
(*==================================================================*)
PROCEDURE Prompt (p : LString; VAR s : LString);
VAR
m : FString;
n : PString;
i,j,k : INTEGER;
BEGIN
m := p; i := LENGTH (p);
TRead (m, i, n, j, k);
s := SUBSTR (STR (n), 1, j) || ' '
END;
(*==================================================================*)
(* InPacket - This procedure reads a packet from the terminal *)
(*==================================================================*)
PROCEDURE InPacket (VAR s : LPString);
VAR
m : FString;
n : PString;
i,j,k : INTEGER;
BEGIN
m := ''; i := 0;
TRead (m, i, n, j, k);
s := SUBSTR (STR (n), 1, j) || ' '
END;
(*==================================================================*)
(* OutPacket - This procedure writes a packet to the terminal *)
(*==================================================================*)
PROCEDURE TWrite (CONST Line : PString;
CONST Len : INTEGER;
VAR RC : INTEGER); FORTRAN;
PROCEDURE OutPacket (l : LPString);
VAR
m : PString;
i,j : INTEGER;
BEGIN
m := l; i := LENGTH (l);
TWrite (l, i, j)
END;
(*==================================================================*)
(* TermSize - This procedure reads the screen size of the other *)
(* Kermit terminal's emulator. *)
(*==================================================================*)
PROCEDURE TermSize (VAR a : INTEGER); FORTRAN;
%PAGE
FUNCTION Upper (S : LString) : LString;
VAR i : INTEGER;
ch : CHAR;
BEGIN
Upper := S;
FOR i := 1 TO LENGTH (S) DO BEGIN
ch := S (.i.);
IF ch IN (.'a'..'z'.) THEN Upper (.i.) := CHR ( ORD (ch) + 64)
END
END;
(*==================================================================*)
(* CheckDsn - This procedure verifies whether a data set exists *)
(* and if so, it prompts the user for a new name. *)
(*==================================================================*)
PROCEDURE CheckDsn (VAR KFile : LString; VAR Result : DISPTYPE);
CONST
RelId = '00000001';
VAR TSODS : TEXT;
InFile,
Line : LString;
Name : STRING (20);
Dot,Num,
Col : INTEGER;
IsPDS : BOOLEAN;
PROCEDURE NewChar (VAR L : LString; N : INTEGER);
CONST
Charset = '1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ'; (* 36 items *)
VAR
Chg : CHAR;
j : INTEGER;
BEGIN
Chg := L (.N.);
j := INDEX (Charset, STR (Chg));
j := j + 1;
IF j > 36 THEN j := 1;
Chg := Charset (.j.);
L (.N.) := Chg
END;
BEGIN
InFile := Upper (KFile);
IF InFile (.1.) <> '''' THEN
InFile := '''' || UserID || '.' || InFile || '''';
IF Debug THEN WRITELN (DFILE, 'Checking data set ', InFile);
TSOService ('PROFILE NOPROMPT', RC);
TSOService ('TSODS LISTDS ' || InFile || ' MEM', RC);
TSOService ('PROFILE PROMPT', RC);
RESET (TSODS);
READLN (TSODS, Line);
IF Debug THEN WRITELN (DFILE, Line);
(* -------------------------------------*)
(* Maybe filename is invaild *)
(* -------------------------------------*)
IF INDEX (Line, 'INVALID DATA SET') > 0 THEN
IF NOT GetFile THEN Result := BADNAME
ELSE BEGIN
(* TSO Kermit got an invalid data set name from micro *)
(* ... will try now to write data to a temporary file *)
(* called KERMIT.TEMP *)
IF Debug THEN WRITELN (DFile, KFile || ' renamed to KERMIT.TEMP');
KFile := 'KERMIT.TEMP';
CheckDsn (KFile, Result)
END
ELSE BEGIN
READLN (TSODS, Line);
IF Debug THEN WRITELN (DFILE, Line);
(* -------------------------------------*)
(* Maybe file is not in catalog *)
(* -------------------------------------*)
IF INDEX (Line, 'NOT IN CATALOG') > 0 THEN Result := NEW
ELSE BEGIN
Result := SHARE;
IsPDS := FALSE;
READLN (TSODS, Line);
IF INDEX (Line, 'PO') > 0 THEN BEGIN (* Dsn is partitioned *)
IsPDS := TRUE;
IF INDEX (KFile, '(') = 0 THEN BEGIN (* No member for PDS *)
Result := ERROR;
IF NOT GetFile THEN Result := NOMEM;
IF Debug THEN WRITELN (DFILE, 'No member specified !!');
RETURN
END;
READLN (TSODS, Line); READLN (TSODS, Line);
READLN (TSODS, Line); READLN (TSODS, Line);
IF Debug THEN WRITELN (DFILE, Line);
IF INDEX (Line, 'NOT FOUND') > 0 THEN Result := NEWMEM
ELSE Result := OLDMEM
END
END
END;
CLOSE (TSODS);
IF NOT GetFile THEN
IF (Result = SHARE) OR (Result = OLDMEM) THEN BEGIN
TSOService ('TSODS LISTCAT ENT(' || InFile || ')', RC);
IF RC <> 0 THEN BEGIN
IF Debug THEN WRITELN (DFILE, 'No access to file ' || InFile);
Result := NOACC
END
END;
IF GetFile THEN
CASE Result OF
NEW,
NEWMEM : (* New data set or member *);
ERROR : (* Do nothing yet *);
OLDMEM,
SHARE : BEGIN
IF Remote THEN Num := 3
ELSE BEGIN
WRITELN ('Data set or member already exists ...');
WRITELN (' ');
WRITELN (' (1) Overwrite it ? ');
WRITELN (' (2) Append to file ? ');
WRITELN (' or (3) create new file name ? ');
READLN (Num);
IF (Num < 1) OR (Num > 3) THEN Num := 3
END;
CASE Num OF
1 : Result := OLD;
2 : Result := MODIFY;
3 : BEGIN
InFile := KFile;
Col := INDEX (InFile, '(');
IF IsPDS THEN Col := INDEX (InFile, ')');
Num := LENGTH (InFile);
IF Col > 0 THEN NewChar (InFile, Col - 1)
ELSE NewChar (InFile, Num);
KFile := InFile;
IF Debug THEN
WRITELN (DFILE, 'Trying with ', KFile);
CheckDsn (KFile, Result)
END
END
END
END
END;
(*================================================================*)
(* Extract - This procedure constructs a KERMIT filename from *)
(* a TSO data set name. *)
(*================================================================*)
PROCEDURE Extract (Filename : LString; VAR KermName : LString);
VAR Name, Typ : String(8);
PDS,Dot,i : INTEGER;
BEGIN
Filename := LTRIM (Filename);
Dot := INDEX (Filename, '.') + 1;
IF Filename (.1.) = '''' THEN
Filename := SUBSTR (Filename, Dot , LENGTH (Filename)-Dot);
Typ := '';
PDS := INDEX (Filename, '(');
Dot := INDEX (Filename, '.');
IF PDS > 0 THEN BEGIN
i := INDEX (Filename, ')');
Name := SUBSTR (Filename, PDS+1, i-PDS-1);
Filename := DELETE (Filename, PDS)
END ELSE
IF Dot > 0 THEN BEGIN
Name := SUBSTR (Filename, 1, Dot-1);
Filename := SUBSTR (Filename, Dot+1)
END ELSE
BEGIN Name := Filename; Filename := '' END;
IF Filename <> '' THEN
REPEAT
Dot := INDEX (Filename, '.');
IF Dot > 0 THEN Filename := SUBSTR (Filename, Dot+1)
ELSE BEGIN Typ := Filename; Filename := '' END;
UNTIL Filename = '';
IF Typ = '' THEN KermName := Name
ELSE KermName := Name || '.' || Typ;
END;
%PAGE
(*==================================================================*)
(* Wildcard_Search: This procedure generates a list of filenames, *)
(* which follow a given mask. *)
(*==================================================================*)
PROCEDURE Wildcard_Search (VAR S : LString);
VAR Flag : BOOLEAN;
Line,
DSname : LString;
User : STRING (8);
Mask1,
Mask2,
Name,
FullDsn,
Level : STRING (40);
Len1, Len2,
Star, (* Position of '*' in filename *)
Dot, (* Position of '.' in filename *)
ParOp, (* Position of '(' in filename *)
ParCl : INTEGER; (* Position of ')' in filename *)
BEGIN
FileCount := 0;
S := Upper (S);
IF INDEX (S, '*') = 0 THEN BEGIN
FileCount := 1;
FileList (.1.) := S;
RETURN
END;
IF S(.1.) = '''' THEN BEGIN
Dot := INDEX (S, '.');
User := SUBSTR (S, 2, Dot-2);
S := SUBSTR (S, Dot+1, LENGTH (S)-Dot-1);
END ELSE User := UserId;
DSname := S;
Star := INDEX (S, '*');
IF Star < LENGTH (S) THEN BEGIN
Line := SUBSTR (S, Star+1);
IF INDEX (Line , '*') > 0 THEN BEGIN
WRITELN (' No double wildcard allowed ');
RETURN
END
END;
Dot := INDEX (S, '.');
ParOp := INDEX (S, '(');
IF ParOp > 0 THEN BEGIN
ParCl := INDEX (S, ')');
DSname := SUBSTR (S, 1, ParOp-1);
IF Star > ParOp THEN BEGIN (* He would like all PDS members *)
Mask1 := ' '; Mask2 := ' ';
IF Star > ParOp + 1 THEN
Mask1 := SUBSTR (S, ParOp+1, Star-ParOp-1);
IF Star < Parcl - 1 THEN BEGIN
Mask2 := SUBSTR (S, Star+1, ParCl-Star-1);
Len2 := LENGTH (Mask2)
END;
FullDsn := '''' || User || '.' || DSname || '''';
TSOService ('TSODS LISTD ' || FullDsn || ' m', RC);
RESET (TSODS);
READLN (TSODS, Line);
IF INDEX (Line, 'NOT IN CATALOG') > 0 THEN RETURN;
READLN (TSODS, Line);
READLN (TSODS, Line);
IF INDEX (Line, 'PO') = 0 THEN BEGIN
FileCount := FileCount + 1;
IF User = UserID THEN FileList (.FileCount.) := DSNAME
ELSE FileList (.FileCount.) :=
'''' || User || '.' || DSNAME || '''';
RETURN; (* File is not a PDS *)
END;
READLN (TSODS, Line);
READLN (TSODS, Line);
READLN (TSODS, Line);
WHILE NOT EOF (TSODS) DO BEGIN
READLN (TSODS, Line);
IF INDEX (Line, 'NOT USEABLE') > 1 THEN BEGIN
CLOSE (TSODS);
RETURN
END;
Line := LTRIM (Line);
Len1 := LENGTH (Line);
Flag := TRUE;
IF Mask1 <> ' ' THEN
IF INDEX (Line, Mask1) <> 1 THEN Flag := FALSE;
IF Mask2 <> ' ' THEN
IF SUBSTR (Line, Len1-Len2+1, Len2) <> Mask2 THEN
Flag := FALSE;
IF Flag THEN BEGIN
FileCount := FileCount + 1;
IF User = UserID THEN FileList (.FileCount.) :=
DSNAME || '(' || Line || ')'
ELSE FileList (.FileCount.) :=
'''' || User || '.' || DSNAME || '(' || Line || ')''';
END;
END;
CLOSE (TSODS)
END
END ELSE
IF ParOp > 0 THEN RETURN
ELSE BEGIN
Name := SUBSTR (S, 1, Dot-1);
Level := 'LEV(' || User || ')';
TSOService ('TSODS LISTCAT ' || Level, RC);
Mask1 := User; Mask2 := ' ';
IF Star > 1 THEN
Mask1 := Mask1 || '.' || SUBSTR (S, 1, Star-1);
IF LENGTH (S) > Star THEN BEGIN
Mask2 := SUBSTR (S, Star+1);
Len2 := LENGTH (Mask2)
END;
RESET (TSODS);
REPEAT
READLN (TSODS, Line);
IF INDEX (Line, 'THE NUMBER OF') <> 0 THEN LEAVE;
IF INDEX (Line, 'SECURITY VERIFICATION') <> 0 THEN
READLN (TSODS, Line)
ELSE BEGIN
Line := SUBSTR (Line, 17);
Len1 := LENGTH (Line);
Flag := TRUE;
IF Mask1 <> ' ' THEN
IF INDEX (Line, Mask1) <> 1 THEN Flag := FALSE;
IF Mask2 <> ' ' THEN
IF SUBSTR (Line, Len1-Len2+1, Len2) <> Mask2 THEN
Flag := FALSE;
IF Flag THEN BEGIN
FileCount := FileCount + 1;
IF User = UserID THEN
FileList (.FileCount.) := SUBSTR (Line, LENGTH(User)+2)
ELSE FileList (.FileCount.) := '''' || Line || ''''
END
END;
READLN (TSODS, Line)
UNTIL EOF (TSODS);
CLOSE (TSODS)
END
END; (* Wildcard_Search *)
%TITLE KERMIT Utilities
(* =============================================================== *)
(* 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; (* CRCheck *)
(*================================================================*)
(* SendChar - This procedure sends a char to the terminal. *)
(* Side Effect - none *)
(*================================================================*)
PROCEDURE SendChar (VAR L : LPString; MyChar : CHAR);
BEGIN
L := L || STR (MyChar);
IF MyChar = '0D'XC THEN OutPacket (L)
END; (* Send Char *)
(* ===============================================================*)
(* RecvChar - This procedure gets a char from string L. *)
(* Side Effect - EOLINE is set *)
(* ===============================================================*)
PROCEDURE RecvChar (VAR L : LPString; VAR MyChar : CHAR);
BEGIN
EOLINE := FALSE;
IF LENGTH (L) > 0 THEN MyChar := L (.1.);
IF LENGTH (L) > 1 THEN L := SUBSTR (L, 2)
ELSE EOLINE := TRUE;
END; (* Recv Char *)
%TITLE Procedure Write_State
(*==================================================================*)
(* WRITE_STATE - write the present state to the debug file *)
(*==================================================================*)
procedure Write_State;
var
mess : string(2);
begin
CASE STATE OF
S_I : mess := 'I ';
S : mess := 'S ';
SF : mess := 'SF';
SD : mess := 'SD';
SZ : mess := 'SZ';
SB : mess := 'SB';
C : mess := 'C ';
A : mess := 'A ';
R : mess := 'R ';
RF : mess := 'RF';
RD : mess := 'RD';
OTHERWISE mess := '??'
END ; (* CASE state *)
WRITELN (DFILE, '(State = ' || mess || ')' )
end;
%TITLE Procedure SendPacket
(* =============================================================== *)
(* 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, Len1, Len2, HCheck : INTEGER;
BEGIN
IF Debug THEN BEGIN
WRITE (DFILE, 'SEND PACKET : ');
Write_State
END;
Line := '';
SUM := 0;
CRC := 0;
CHECKBYTES := 1;
IF ( (OUTPACKETTYPE IN (.'X','F','Z','B','D','E'.) ) OR
(INPACKETTYPE IN (.'D','C','K','F','Z','B'.) ) ) THEN
IF CHECKTYPE = '2' THEN CHECKBYTES := 2
ELSE IF CHECKTYPE = '3' THEN CHECKBYTES := 3;
SendChar (Line, SOH); (* SOH *)
OUTCOUNT := OUTDATACOUNT + 2 + CHECKBYTES;
If (Long_Packet AND (OUTDATACOUNT > 90)) THEN
IF OUTPACKETTYPE = 'D' THEN OUTCOUNT := 0;
SendChar (Line, ASCIITOEBCDIC (.OUTCOUNT+32.)); (* COUNT *)
SUM := SUM + OUTCOUNT + 32;
CRCheck (OUTCOUNT + 32);
SendChar (Line, ASCIITOEBCDIC (.OUTSEQ+32.)); (* SEQ *)
IF NOT GetFile THEN SeqChar := ASCIITOEBCDIC (.OUTSEQ+32.);
SUM := SUM + OUTSEQ + 32;
CRCheck (OUTSEQ + 32);
SendChar (Line, OUTPACKETTYPE); (* TYPE *)
SUM := SUM + ORD (EBCDICTOASCII (.ORD(OUTPACKETTYPE).) );
CRCheck ( ORD (EBCDICTOASCII (.ORD (OUTPACKETTYPE).) ));
IF (Long_Packet AND (OUTDATACOUNT > 90)) THEN
IF OUTPACKETTYPE = 'D' THEN BEGIN
OUTCOUNT := OUTDATACOUNT + CHECKBYTES;
Len1 := OUTCOUNT DIV 95;
SendChar (Line, ASCIITOEBCDIC (.Len1+32.)); (* LENX1 *)
SUM := SUM + Len1 + 32;
CRCheck (Len1 + 32);
Len2 := OUTCOUNT MOD 95;
SendChar (Line, ASCIITOEBCDIC (.Len2+32.)); (* LENX2 *)
SUM := SUM + Len2 + 32;
CRCheck (Len2 + 32);
HCheck := (SUM + (SUM AND 'C0'X) DIV '40'X ) AND '3F'X ;
SendChar (Line, ASCIITOEBCDIC (.HCheck+32.)); (* HCHECK *)
SUM := SUM + HCheck + 32;
CRCheck (HCheck + 32);
END;
IF OUTDATACOUNT > 0 THEN
FOR I := 1 TO OUTDATACOUNT DO
WITH SENDMSG DO
BEGIN (* Send Data *)
SendChar (Line, CHARS(.I.));
SUM := SUM + ORD (EBCDICTOASCII (.BYTES(.I.).));
CRCheck (ORD (EBCDICTOASCII (.BYTES(.I.).)))
END;
IF CHECKBYTES = 1 THEN
BEGIN (* One char checksum *)
CHECKSUM := (SUM + (SUM AND 'C0'X) DIV '40'X ) AND '3F'X ;
SendChar (Line, ASCIITOEBCDIC (.CHECKSUM+32.));
SendChar (Line, '0D'XC)
END
ELSE IF CHECKBYTES = 2 THEN
BEGIN (* Two char checksum *)
CHECKSUM := (SUM DIV '40'X) AND '3F'X ; (* BIT 11 - 6 *)
SendChar (Line, ASCIITOEBCDIC (.CHECKSUM+32.));
CHECKSUM := (SUM ) AND '3F'X ; (* BIT 0 - 5 *)
SendChar (Line, ASCIITOEBCDIC (.CHECKSUM+32.));
SendChar (Line, '0D'XC)
END
ELSE BEGIN (* CRC-CCITT 3 character *)
SendChar (Line,ASCIITOEBCDIC(.((CRC DIV '1000'X) AND '0F'X) +32.));
SendChar (Line,ASCIITOEBCDIC(.((CRC DIV '0040'X) AND '3F'X) +32.));
SendChar (Line,ASCIITOEBCDIC(.((CRC ) AND '3F'X) +32.));
SendChar (Line, '0D'XC)
END;
IF Debug THEN WRITELN (DFILE, Line)
END; (* SendPacket procedure *)
%TITLE Function RecvPacket
(*==================================================================*)
(* 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 characters are received as EBCDIC values and *)
(* must be converted back to ASCII before using. *)
(*==================================================================*)
FUNCTION RecvPacket : BOOLEAN;
VAR
I,SUM,RESENDS,
LEN1, LEN2,
HCheck, Chk1,
Chk2, Chk3,
InCh1,
InCh2, InCh3 : INTEGER;
INCHAR,SChar : CHAR;
Ext_Length : BOOLEAN;
LABEL FINDSOH;
BEGIN
IF Debug THEN BEGIN
WRITE (DFILE, 'RECEIVE PACKET : ');
Write_State
END;
InPacket (Line);
IF LENGTH (Line) > 0 THEN
IF Line (.1.) <> SOH THEN Line := STR (SOH) || Line;
IF Debug THEN WRITELN (DFILE, Line);
FINDSOH:
RecvChar (Line, INCHAR); (* SOH *)
IF EOLINE THEN
BEGIN (* Null response *)
RecvPacket := TRUE;
INPACKETTYPE:='N';
RETURN
END; (* Null response *)
IF INCHAR <> SOH THEN GOTO FINDSOH; (* no SOH *)
SUM := 0;
CRC := 0;
Ext_Length := FALSE;
RecvChar (Line, INCHAR);
INCOUNT := ORD (EBCDICTOASCII (.ORD (INCHAR).)); (* COUNT *)
SUM := INCOUNT;
CRCheck (INCOUNT);
INCOUNT := INCOUNT - 32; (* To absolute value *)
IF INCOUNT = 0 THEN Ext_Length := TRUE;
RecvChar (Line, INCHAR);
INSEQ := ORD (EBCDICTOASCII (.ORD (INCHAR).)); (* SEQ *)
SChar := LastSeq;
LastSeq := SeqChar;
SeqChar := INCHAR;
SUM := SUM + INSEQ;
CRCheck (INSEQ);
INSEQ := INSEQ - 32;
IF Debug THEN WRITELN (DFILE,'SeqChar = ', SeqChar,LastSeq);
RecvChar (Line, INCHAR);
INPACKETTYPE := INCHAR; (* TYPE *)
SUM := SUM + ORD (EBCDICTOASCII (.ORD (INCHAR).));
CRCheck (ORD (EBCDICTOASCII (.ORD (INCHAR).)));
IF Ext_Length THEN BEGIN
RecvChar (Line, INCHAR); (* LENX1 *)
LEN1 := ORD (EBCDICTOASCII (.ORD (INCHAR).));
SUM := SUM + LEN1;
CRCheck (LEN1);
LEN1 := (LEN1 - 32) * 95;
RecvChar (Line, INCHAR); (* LENX2 *)
LEN2 := ORD (EBCDICTOASCII (.ORD (INCHAR).));
SUM := SUM + LEN2;
CRCheck (LEN2);
LEN2 := LEN2 - 32;
INCOUNT := LEN1 + LEN2;
RecvChar (Line, INCHAR); (* HCHECK *)
HCheck := ORD (EBCDICTOASCII (.ORD (INCHAR).));
CHECKSUM := (SUM + (SUM AND 192) DIV 64 ) AND 63;
IF HCheck <> CHECKSUM + 32 THEN BEGIN
RecvPacket := FALSE;
SeqChar := LastSeq;
LastSeq := SChar;
IF Debug THEN WRITELN (DFILE,'HChecksum error : ', CHECKSUM+32);
RETURN
END;
SUM := SUM + HCheck;
CRCheck (HCheck);
END;
CHECKBYTES := 1;
IF NOT ( (INPACKETTYPE IN (.'S','G','I','C','R','K','N'.) ) OR
(OUTPACKETTYPE = 'S') ) THEN
IF CHECKTYPE = '2' THEN CHECKBYTES := 2 ELSE
IF CHECKTYPE = '3' THEN CHECKBYTES := 3;
INDATACOUNT := INCOUNT - 2 - CHECKBYTES;
IF Ext_Length THEN INDATACOUNT := INCOUNT - CHECKBYTES;
IF INDATACOUNT > 0 THEN
FOR I := 1 TO INDATACOUNT DO
WITH REPLYMSG DO
BEGIN (* Receive data *)
RecvChar (Line, CHARS (.I.));
SUM := SUM + ORD (EBCDICTOASCII (.BYTES (.I.).));
CRCheck (ORD (EBCDICTOASCII (.BYTES (.I.).)) )
END;
RecvPacket := TRUE; (* ASSUME OK UNLESS CHECK FAILS *)
IF CHECKBYTES = 1 THEN
BEGIN (* One byte CHECKSUM *)
CHECKSUM := (SUM + (SUM AND 192) DIV 64 ) AND 63;
RecvChar (Line, INCHAR);
IF ORD (EBCDICTOASCII (.ORD (INCHAR).)) <> CHECKSUM + 32
THEN BEGIN
RecvPacket := FALSE;
SeqChar := LastSeq;
LastSeq := SChar;
IF Debug THEN WRITELN (DFILE, 'Checksum error : ', CHECKSUM+32)
END
END
ELSE IF CHECKBYTES = 2 THEN
BEGIN (* TWO BYTE CHECKSUM *)
Chk1 := (SUM DIV '40'X ) AND '3F'X;
Chk2 := (SUM ) AND '3F'X;
RecvChar (Line, INCHAR);
InCh1 := ORD (EBCDICTOASCII (.ORD (INCHAR).));
RecvChar (Line, INCHAR);
InCh2 := ORD (EBCDICTOASCII (.ORD (INCHAR).));
IF ((InCh1 <> Chk1 + 32) OR (InCh2 <> Chk2 + 32)) THEN BEGIN
RecvPacket := FALSE;
SeqChar := LastSeq;
LastSeq := SChar;
IF Debug THEN WRITELN (DFILE, 'Checksum-2 error : ', Chk1+32);
IF Debug THEN WRITELN (DFILE, ' ', Chk2+32)
END
END
ELSE BEGIN (* CRC-CCITT checksum*)
(* First char is bits 16-12, second is bits 11-6 and *)
(* third is bits 5-0 *)
RecvChar (Line, INCHAR);
InCh1 := ORD (EBCDICTOASCII (.ORD (INCHAR).));
RecvChar (Line, INCHAR);
InCh2 := ORD (EBCDICTOASCII (.ORD (INCHAR).));
INCHAR := '0D'XC;
RecvChar (Line, INCHAR);
InCh3 := ORD (EBCDICTOASCII (.ORD (INCHAR).));
Chk1 := ((CRC DIV '1000'X) AND '0F'X) +32;
Chk2 := ((CRC DIV '40'X) AND'3F'X) +32;
Chk3 := (CRC AND '3F'X) +32;
IF ((InCh1 <> Chk1) OR (InCh2 <> Chk2) OR (InCh3 <> Chk3))
THEN BEGIN
RecvPacket := FALSE;
SeqChar := LastSeq;
LastSeq := SChar;
IF Debug THEN BEGIN
WRITELN (DFILE, 'Checksum-3 (CRC) error : ', Chk1);
WRITELN (DFILE, ' ', Chk2);
WRITELN (DFILE, ' ', Chk3)
END
END
END
END; (* RecvPacket procedure *)
%TITLE Procedures ReSendit, SendACK & SendError
(*==================================================================*)
(* ReSendit - This procedure RESENDS the packet 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
IF RETRIES > 0 THEN
BEGIN (* Try again *)
SendPacket;
IF RecvPacket THEN
IF INPACKETTYPE = 'Y' THEN BEGIN
IF NOT GetFile AND (LastSeq<>SeqChar)
THEN ReSendit (RETRIES-1)
END
ELSE IF INPACKETTYPE = 'N' THEN ReSendit(RETRIES-1)
ELSE STATE := A
ELSE STATE := A
END
ELSE STATE := A (* Retries failed - ABORT *)
END; (* ReSendit procedure *)
(*--------------------------------------------------------------*)
(* SendACK - Procedure will send an ACK or NAK *)
(* depending on the value of the Boolean parameter *)
(* i.e. ENDACK(TRUE) sends an ACK packet *)
(* SENDACK(FALSE) sends an NAK packet *)
(*--------------------------------------------------------------*)
PROCEDURE SendACK (B : BOOLEAN);
BEGIN
OUTDATACOUNT := 0;
IF B THEN OUTSEQ := OUTSEQ + 1;
IF OUTSEQ >= 64 THEN OUTSEQ := 0;
IF B THEN OUTPACKETTYPE := 'Y'
ELSE OUTPACKETTYPE := 'N';
SendPacket
END; (* Send ACK or NAK *)
(*--------------------------------------------------------------*)
(* SendError - Sends an error packet, with a message passed *)
(* from the caller. *)
(*--------------------------------------------------------------*)
PROCEDURE SendError (ErrStr : LString);
BEGIN
OUTDATACOUNT := LENGTH (ErrStr);
SENDMSG.CHARS := ErrStr;
OUTSEQ := 0;
OUTPACKETTYPE := 'E';
SendPacket
END; (* SendError *)
%TITLE Some Send_X_Packet routines
(*-----------------------------------------------------------*)
(* SendBPacket - send break packet to terminate transmission *)
(*-----------------------------------------------------------*)
PROCEDURE SendBPacket;
BEGIN
OUTDATACOUNT := 0 ;
OUTSEQ := OUTSEQ + 1 ;
IF OUTSEQ >= 64 THEN OUTSEQ := 0 ;
OUTPACKETTYPE := 'B' ;
SendPacket;
IF RecvPacket THEN (* It's ok *)
END; (* SendBPacket *)
(*-----------------------------------------------------------*)
(* SendZPacket - send EOF packet *)
(*-----------------------------------------------------------*)
PROCEDURE SendZPacket;
BEGIN
OUTDATACOUNT := 0 ;
OUTSEQ := OUTSEQ + 1 ;
IF OUTSEQ >= 64 THEN OUTSEQ := 0; ;
OUTPACKETTYPE := 'Z' ;
SendPacket;
IF RecvPacket THEN (* Ok *)
END; (* SendZPacket *)
(*-----------------------------------------------------------*)
(* SendXPacket - send data header packet for terminal *)
(*-----------------------------------------------------------*)
PROCEDURE SendXPacket (Head : LString);
BEGIN
OUTDATACOUNT := LENGTH (Head);
OUTSEQ := OUTSEQ + 1 ;
IF OUTSEQ >= 64 THEN OUTSEQ := 0 ;
OUTPACKETTYPE := 'X';
SENDMSG.CHARS := Head;
SendPacket;
IF RecvPacket THEN
IF INPACKETTYPE='Y' THEN (* It's ok *)
ELSE IF INPACKETTYPE = 'N' THEN ReSendit (10)
END; (* SendXPacket *)
(*-----------------------------------------------------------*)
(* SendYPacket - send acknoledgement with data to micro *)
(*-----------------------------------------------------------*)
PROCEDURE SendYPacket (Head : LString);
BEGIN
OUTDATACOUNT := LENGTH (Head);
OUTPACKETTYPE := 'Y';
SENDMSG.CHARS := Head;
SendPacket
END; (* SendYPacket *)
(*-----------------------------------------------------------*)
(* SendDPacket - send data packet to micro *)
(*-----------------------------------------------------------*)
PROCEDURE SendDPacket (Head : LString; VAR Flag : BOOLEAN);
BEGIN
OUTSEQ := OUTSEQ + 1;
IF OUTSEQ >= 64 THEN OUTSEQ := 0;
OUTDATACOUNT := LENGTH (Head);
OUTPACKETTYPE := 'D';
SENDMSG.CHARS := Head;
SendPacket;
Flag := TRUE;
IF RecvPacket THEN
IF INPACKETTYPE='Y' THEN (* nothing *)
ELSE IF INPACKETTYPE='N' THEN ReSendit (10)
ELSE Flag := FALSE
END; (* SendDPacket *)
%TITLE Procedures GetToken & ParmPacket
(* =============================================================== *)
(* 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(256)) : ALFA;
VAR
BP,BPM : INTEGER ; (* Blank Pointer *)
BEGIN
IF LENGTH (INSTRING) < 1 THEN GetToken := ' '
ELSE BEGIN
BP := INDEX (INSTRING, ' ');
IF BP = 0 THEN BP := LENGTH (INSTRING) + 1;
BPM := MIN(BP,9);
GetToken := DELETE (INSTRING, BPM);
INSTRING := DELETE (INSTRING, 1, MIN (BP, LENGTH (INSTRING)))
END
END; (* GetToken *)
(*=================================================================*)
(* ParmPacket - This procedure makes the PARAMETER PACKET. *)
(*=================================================================*)
PROCEDURE ParmPacket;
VAR i, l1, l2 : BYTE;
BEGIN
OUTDATACOUNT := 13;
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 (.94+32.); (* Buffersize *)
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 *)
CHARS (.7.) := BIT8_QUOTE; (* Quote character *)
IF BIT8_QUOTE = '00'XC THEN CHARS (.7.) := 'Y';
CHARS (.8.) := CHECKTYPE; (* Check type *)
CHARS (.9.) := REPEATCHAR; (* Repeat character *)
IF REPEATCHAR = '00'XC THEN CHARS (.7.) := ' ';
l1 := 2+8; (* 2 = LONGP *)
(* 8 = ATTRIBUTE *)
CHARS (.10.) := ASCIITOEBCDIC (.l1+32.); (* CAPAS character *)
CHARS (.11.) := ASCIITOEBCDIC (.'20'X.); (* Window size = 0 *)
IF Long_Packet THEN l1 := PSIZE DIV 95 ELSE l1 := 0;
CHARS (.12.) := ASCIITOEBCDIC (.l1+32.); (* Ext.packet len1 *)
IF Long_Packet THEN l2 := PSIZE MOD 95 ELSE l2 := 94;
CHARS (.13.) := ASCIITOEBCDIC (.l2+32.); (* Ext.packet len2 *)
(* DEF:0*95+94= 94 *)
END
END; (* parameters *)
%TITLE Procedure FileToPacket
(*==================================================================*)
(* FileToPacket - This procedure files in a DATA packet D or X type *)
(* with data from the file SFILE. *)
(*==================================================================*)
PROCEDURE FileToPacket;
BEGIN
OUTDATACOUNT := 0;
OUTSEQ := OUTSEQ + 1;
IF OUTSEQ >= 64 THEN OUTSEQ := 0;
WHILE (OUTDATACOUNT < PSIZE-3-4-4) AND (NOT EOF (SFILE)) DO
BEGIN (* Read a record *)
OUTDATACOUNT := OUTDATACOUNT + 1 ;
READ (SFILE, SENDMSG.CHARS (.OUTDATACOUNT.));
WITH SENDMSG DO
IF TEXTMODE THEN
BEGIN (* translate file *)
(* 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.) > 127 THEN
BEGIN (* 8th bit quote this char *)
BYTES (.OUTDATACOUNT+1.) := BYTES (.OUTDATACOUNT.) - 128;
CHARS (.OUTDATACOUNT.) := BIT8_QUOTE;
OUTDATACOUNT := OUTDATACOUNT + 1
END;
IF BYTES (.OUTDATACOUNT.) < 32 THEN
BEGIN (* control quoting *)
BYTES (.OUTDATACOUNT+1.) :=
BYTES (.OUTDATACOUNT.) + 64;
CHARS (.OUTDATACOUNT.) := CNTRL_QUOTE;
OUTDATACOUNT := OUTDATACOUNT + 1
END;
IF BYTES (.OUTDATACOUNT.) = '7F'X THEN
BEGIN (* <DEL> quoting *)
CHARS (.OUTDATACOUNT+1.) := '3F'XC;
CHARS (.OUTDATACOUNT.) := CNTRL_QUOTE;
OUTDATACOUNT := OUTDATACOUNT + 1
END;
IF BYTES (.OUTDATACOUNT.) = '7E'X THEN
BEGIN (* Repeat quoting *)
CHARS (.OUTDATACOUNT+1.) := '7E'XC;
CHARS (.OUTDATACOUNT.) := CNTRL_QUOTE;
OUTDATACOUNT := OUTDATACOUNT + 1
END;
IF BYTES (.OUTDATACOUNT.) <> 0 THEN
CHARS (.OUTDATACOUNT.) :=
ASCIITOEBCDIC (.BYTES (.OUTDATACOUNT.).);
IF (CHARS (.OUTDATACOUNT.) = CNTRL_QUOTE) OR
(CHARS (.OUTDATACOUNT.) = BIT8_QUOTE) THEN
BEGIN (* Quote the quote *)
CHARS (.OUTDATACOUNT+1.) := CHARS (.OUTDATACOUNT.);
CHARS (.OUTDATACOUNT.) := CNTRL_QUOTE;
OUTDATACOUNT := OUTDATACOUNT + 1
END
END
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 = '00'XC 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;
IF BYTES (.OUTDATACOUNT.) < 32 THEN
BEGIN (* CONTROL QUOTING *)
BYTES (.OUTDATACOUNT+1.) := BYTES (.OUTDATACOUNT.) + 64;
CHARS (.OUTDATACOUNT.) := CNTRL_QUOTE;
OUTDATACOUNT := OUTDATACOUNT + 1
END;
IF BYTES (.OUTDATACOUNT.) = '7F'X THEN
BEGIN (* <DEL> quoting *)
CHARS (.OUTDATACOUNT+1.) := '3F'XC;
CHARS (.OUTDATACOUNT.) := CNTRL_QUOTE;
OUTDATACOUNT := OUTDATACOUNT + 1
END;
IF BYTES (.OUTDATACOUNT.) = '7E'X THEN
BEGIN (* Repeat quoting *)
CHARS (.OUTDATACOUNT+1.) := '7E'XC;
CHARS (.OUTDATACOUNT.) := CNTRL_QUOTE;
OUTDATACOUNT := OUTDATACOUNT + 1
END;
IF BYTES (.OUTDATACOUNT.) <> 0 THEN
CHARS (.OUTDATACOUNT.) :=
ASCIITOEBCDIC (.BYTES (.OUTDATACOUNT.).);
IF (CHARS (.OUTDATACOUNT.) = CNTRL_QUOTE) OR
(CHARS (.OUTDATACOUNT.) = BIT8_QUOTE) THEN
BEGIN (* Quote the quote *)
CHARS (.OUTDATACOUNT+1.) := CHARS (.OUTDATACOUNT.);
CHARS (.OUTDATACOUNT.) := CNTRL_QUOTE;
OUTDATACOUNT := OUTDATACOUNT + 1
END
END;
IF EOLN (SFILE) THEN BEGIN (* Send CR, LF *)
READLN (SFILE);
(*IF TEXTMODE AND (OUTDATACOUNT>1) THEN *)
(* Delete trailing blanks *)
(*WHILE (SENDMSG.CHARS (.OUTDATACOUNT.) = ' ') AND *)
(* (OUTDATACOUNT > 1) DO *)
(* OUTDATACOUNT := OUTDATACOUNT - 1; *)
IF TEXTMODE THEN BEGIN (* Only for text files *)
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 *)
END
END
END
END; (* FILE TO PACKET *)
%TITLE Procedure CheckParms
(********************************************************************)
(* CheckParms- This routine checks the parameters received from *)
(* the micro KERMIT. *)
(********************************************************************)
PROCEDURE CheckParms;
VAR i : INTEGER;
BEGIN
IF INDEX (SPECTABLE, STR (CNTRL_QUOTE)) = 0 THEN CNTRL_QUOTE := '#';
IF INDEX ('123', STR (CHECKTYPE)) = 0 THEN CHECKTYPE := '1';
IF INDEX (SPECTABLE, STR (BIT8_QUOTE)) = 0 THEN BIT8_QUOTE := '&';
IF BIT8_QUOTE = 'Y' THEN BIT8_QUOTE := '&';
IF BIT8_QUOTE = 'N' THEN BIT8_QUOTE := '00'XC;
IF INDEX (SPECTABLE, STR (REPEATCHAR)) = 0 THEN REPEATCHAR := '~';
i := CAPAS DIV 2;
IF ODD (i) THEN Long_Packet := TRUE ELSE Long_Packet := FALSE;
IF (NOT Long_Packet AND (PSIZE > 94)) THEN PSIZE := 94;
IF PSIZE > 1000 THEN PSIZE := 1000;
IF PSIZE < 26 THEN PSIZE := 94;
(* IF PSIZE > 256 THEN CHECKTYPE := '3'; *)
i := CAPAS DIV 8;
IF ODD (i) THEN Handle_Attribute := TRUE
ELSE Handle_Attribute := FALSE
END; (* CheckParms *)
%TITLE Procedure SendFile
(********************************************************************)
(* SendFile - This routine handles the sending of a file to *)
(* the micro computer. *)
(* If the parameter string is blank it gets the file- *)
(* name from the users. *)
(* If it is non blank it assumes the file name is in *)
(* the parameter string, which was obtained by the *)
(* remote RECEIVE file command. *)
(********************************************************************)
PROCEDURE SendFile (FNAME : LString; XHeader : BOOLEAN);
LABEL LOOP1;
VAR
Member : STRING(8);
AsName,
KermName : LString;
Closed,
SENDING,EOL : BOOLEAN;
i, j, Ix,
RETRIES : INTEGER;
DUMMY,
B8Quote : CHAR;
BEGIN
IF FNAME = ' ' THEN (* Get file name *)
REPEAT
Prompt ('Enter name of sendfile>', FNAME)
UNTIL FNAME <> ' ';
FNAME := LTRIM (FNAME);
FNAME := TRIM (FNAME);
AsName := ' ';
IF INDEX(FNAME,' ') > 1 THEN BEGIN
i := INDEX(FNAME,' ');
AsName := SUBSTR (FNAME, i+1);
FNAME := SUBSTR (FNAME, 1, i-1);
AsName := LTRIM (Upper (AsName));
IF INDEX(AsName,'AS ') > 0 THEN BEGIN
i := INDEX (AsName,'AS ') + 3;
AsName := SUBSTR(AsName, i)
END;
IF Debug THEN WRITELN (DFile, 'AsName3 = ' || AsName);
END;
Wildcard_Search (FNAME);
IF FileCount > 0 THEN FNAME := FileList (.1.)
ELSE BEGIN (* No filename meets search criteria *)
IF Remote THEN SendError ('No filename meets search criteria')
ELSE WRITELN ('No filename meets search criteria');
RETURN (* Return to calling routine *)
END;
FNAME := TRIM (FNAME);
CheckDsn (FNAME, DsnDisp);
CASE DsnDisp OF
BADNAME: BEGIN (* Invalid TSO filename specified *)
IF Remote THEN
SendError ('Bad filename ' || FNAME)
ELSE WRITELN ('Bad filename ' || FNAME);
RETURN (* Return to calling routine *)
END;
NOMEM : BEGIN (* No member for PDS specified *)
IF Remote THEN
SendError ('No member for PDS specified')
ELSE WRITELN ('No member for PDS specified');
RETURN (* Return to calling routine *)
END;
NOACC : BEGIN (* No access to dataset *)
IF Remote THEN
SendError ('No access to requested file')
ELSE WRITELN ('No access to requested file');
RETURN (* Return to calling routine *)
END;
NEW,
NEWMEM : BEGIN (* Data set or member not found *)
IF Remote THEN
SendError ('Data set ' || FNAME || ' not found')
ELSE WRITELN ('Data set ', FNAME, ' not found !');
RETURN (* Return to calling routine *)
END;
OTHERWISE (* ok, data set exists *)
END;
IF AsName = ' ' THEN Extract (FNAME, KermName)
ELSE KermName := AsName;
IF Debug THEN WRITELN (DFILE, ' Sending file ', FNAME);
IF NOT Remote THEN BEGIN
WRITELN ('ready to SEND file - Put Micro in receive mode. ');
Waiting (Delay)
END;
Ix := 1;
IF XHeader THEN BEGIN (* Type file in remote mode *)
STATE := SD;
TSOCommand := 'ALLOC F(SFILE) DA(' || FNAME || ') SHR REUSE';
TSOService (TSOCommand, RC);
IF Debug THEN WRITELN (DFILE, TSOCommand, ' RC = ', RC);
RESET (SFILE)
END ELSE STATE := S;
GETREPLY := FALSE;
SENDING := TRUE;
WHILE SENDING DO BEGIN (* Send files *)
IF GETREPLY THEN
IF RecvPacket THEN
IF (INPACKETTYPE = 'Y') AND (SeqChar=LastSeq) THEN {}
ELSE IF (INPACKETTYPE = 'Y') AND (SeqChar<>LastSeq)
THEN ReSendit (10)
ELSE IF INPACKETTYPE = 'N' THEN ReSendit(10)
ELSE IF INPACKETTYPE = 'R' THEN STATE := S
ELSE STATE := A
ELSE ReSendit(10);
GETREPLY := TRUE;
IF (INPACKETTYPE = 'Y') AND (INDATACOUNT > 0) THEN
IF REPLYMSG.CHARS (.1.) = 'X' THEN STATE := SZ
ELSE IF REPLYMSG.CHARS (.1.) = 'Z' THEN STATE := SZ;
CASE STATE OF
S : BEGIN (* Send INIT packit *)
OUTPACKETTYPE := 'S';
ParmPacket;
SendPacket;
STATE := SF
END;
SF: BEGIN (* Send file header *)
IF INDATACOUNT > 1 THEN
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 BEGIN
B8Quote := REPLYMSG.CHARS (.7.);
IF B8Quote = 'Y' THEN BIT8_QUOTE := '&';
IF NOT (B8Quote IN (.'Y', 'N'.)) THEN
BIT8_QUOTE := B8Quote
END;
IF INDATACOUNT >= 8 THEN
CHECKTYPE := REPLYMSG.CHARS (.8.)
ELSE CHECKTYPE := '1';
IF INDATACOUNT >= 9 THEN
REPEATCHAR := REPLYMSG.CHARS (.9.)
ELSE REPEATCHAR := '~';
IF INDATACOUNT >= 10 THEN
CAPAS :=
ORD (EBCDICTOASCII (.REPLYMSG.BYTES (.10.).)) - 32
ELSE CAPAS := 0;
IF INDATACOUNT >= 13 THEN BEGIN
PSIZE :=
ORD (EBCDICTOASCII (.REPLYMSG.BYTES (.12.).)) - 32;
PSIZE := PSIZE * 95 +
ORD (EBCDICTOASCII (.REPLYMSG.BYTES (.13.).)) - 32
END;
CheckParms
END;
OUTSEQ := OUTSEQ + 1;
IF OUTSEQ >= 64 THEN OUTSEQ := 0;
OUTPACKETTYPE := 'F';
SENDMSG.CHARS := KermName;
OUTDATACOUNT := LENGTH (KermName);
SendPacket;
TSOCommand := 'ALLOC F(SFILE) DA(' || FNAME ||
') SHR REUSE';
TSOService (TSOCommand, RC);
IF Debug THEN WRITELN (DFILE, TSOCommand, ' RC = ', RC);
Closed := FALSE;
RESET (SFILE);
IF Handle_Attribute THEN (* Send attributes *)
IF RecvPacket THEN
IF INPACKETTYPE = 'Y' THEN BEGIN
OUTSEQ := OUTSEQ + 1;
IF OUTSEQ >= 64 THEN OUTSEQ := 0;
OUTPACKETTYPE := 'A';
SENDMSG.CHARS := '."I2'; (*IBM/370 with MVS/TSO*)
OUTDATACOUNT := 4;
SendPacket
END;
STATE := SD
END;
SD: BEGIN (* Send data *)
OUTPACKETTYPE := 'D';
FileToPacket;
SendPacket;
IF EOF (SFILE) THEN STATE := SZ
END;
SZ: BEGIN
OUTDATACOUNT := 0;
OUTSEQ := OUTSEQ + 1;
IF OUTSEQ >= 64 THEN OUTSEQ := 0;
OUTPACKETTYPE := 'Z';
SendPacket;
LOOP1: IF Ix >= FileCount THEN STATE := SB
ELSE BEGIN
IF NOT Closed THEN BEGIN
CLOSE (SFILE);
TSOService ('FREE F(SFILE)', RC);
Closed := TRUE
END;
Ix := Ix + 1;
FNAME := FileList (.Ix.);
CheckDsn (FNAME, DsnDisp);
CASE DsnDisp OF
BADNAME: BEGIN (* Invalid TSO filename specified *)
IF DEBUG THEN WRITELN
(DFILE, 'Bad filename ' || FNAME);
GOTO LOOP1
END;
NOMEM : BEGIN (* No member specified *)
IF DEBUG THEN WRITELN
(DFILE,'No member for PDS specified');
GOTO LOOP1
END;
NOACC : BEGIN (* No access to dataset *)
IF DEBUG THEN WRITELN
(DFILE,'No access to requested file');
GOTO LOOP1
END;
NEW,
NEWMEM : BEGIN (* Data set or member not found *)
IF Debug THEN WRITELN (DFILE,
'Data set ' || FNAME || ' not found');
GOTO LOOP1
END;
OTHERWISE (* ok, data set exists *)
END;
Extract (FNAME, KermName);
STATE := SF
END;
END;
SB: BEGIN (* Last file sent *)
OUTDATACOUNT := 0;
OUTSEQ := OUTSEQ + 1;
IF OUTSEQ >= 64 THEN OUTSEQ := 0;
OUTPACKETTYPE := 'B';
SendPacket;
STATE := C
END;
C: BEGIN (* Completed Sending *)
CLOSE (SFILE);
TSOService ('FREE F(SFILE)', RC);
SENDING := FALSE
END;
A: BEGIN (* Abort Sending *)
CLOSE (SFILE);
TSOService ('FREE F(SFILE)', RC);
ABORT := BADSF;
SENDING := FALSE;
SendError ('Send file aborted')
END
END (* CASE of STATE *)
END (* Send files *)
END; (* SendFile procedure *)
%TITLE Procedure RecvFile
(* **************************************************************** *)
(* 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;
B8Quote,
Dummy : CHAR;
IN_Attr,
FILEWANTED,
OldFname : LString;
REP, K,
RETRIES,IX : INTEGER;
CRFLAG,
CRLFFLAG : BOOLEAN;
TITLE : STRING (80);
RFILE : TEXT; (* RECEIVE file *)
(*-------------------------------------------------------------*)
(* 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
IF RETRIES > 0 THEN
BEGIN
SendACK (FALSE);
RETRIES := RETRIES - 1
END
ELSE STATE := A
END; (* SEND ACK or NAK *)
(*---------------------------------------------------------------*)
(* AllocFile - Procedure of RECVFILE, will allocate a file for *)
(* receiving function. *)
(*---------------------------------------------------------------*)
PROCEDURE AllocFile (OutFile : LSTRING);
VAR
DsnDCB : STRING(40);
BEGIN
IF NOT TEXTMODE THEN DsnDCB := DCB_Bin
ELSE IF FB THEN DsnDCB := DCB_Fix
ELSE DsnDCB := DCB_Var;
TSOCommand := 'ALLOC F(RFILE) DA(' || OutFile || ') ';
CASE DsnDisp OF
NEW : BEGIN
TSOCommand :=
TSOCommand || 'NEW TR SP(5,5) ' || DsnDCB;
IF INDEX (OutFile, '(') > 0 THEN
TSOCommand := TSOCommand || ' DIR(5)';
END;
NEWMEM,
SHARE : TSOCommand := TSOCommand || 'SHR REUSE';
OLD,
OLDMEM : TSOCommand := TSOCommand || 'OLD REUSE';
MODIFY : TSOCommand := TSOCommand || 'MOD REUSE';
END;
TSOService (TSOCommand, RC);
IF Debug THEN WRITELN (DFILE, TSOCommand, ' => RetCode = ', RC);
END; (* Allocate File for Receiving *)
(*---------------------------------------------------------------*)
(* DecodeAttr - Decode incoming attribute fields. *)
(*---------------------------------------------------------------*)
PROCEDURE DecodeAttr (AttrStr : LSTRING);
VAR
K,
Len : INTEGER;
Ch1 : CHAR;
Attribute : STRING(94);
BEGIN
WHILE LENGTH (AttrStr) > 1 DO BEGIN
Ch1 := AttrStr (.1.);
Len := ORD (EBCDICTOASCII (. ORD (AttrStr(.2.)).))-32;
Attribute := SUBSTR (AttrStr, 3, Len);
AttrStr := DELETE (AttrStr, 1, Len+2);
IF DEBUG THEN WRITELN (DFILE, 'Attribute: ', Ch1,' ', Attribute)
END;
END; (* DecodeAttr *)
BEGIN
GetFile := TRUE;
IF NOT Remote THEN
IF LENGTH (INPUTSTRING) > 0 THEN BEGIN
FILEWANTED := INPUTSTRING;
IF INDEX (FILEWANTED, '*') > 0 THEN BEGIN
WRITELN ('Wildcards not allowed, yet');
RETURN
END;
CheckDsn (FILEWANTED, DsnDisp);
IF DsnDisp = ERROR THEN BEGIN
WRITELN ('An error occurred while reading DS information');
WRITELN ('Please turn DEBUG option ON, and retry operation');
RETURN
END;
AllocFile (FILEWANTED);
WRITELN (' RECEIVE mode - Issue a SEND command from micro. ')
END;
IF Remote THEN BEGIN OUTSEQ := 0; SendNAK END;
STATE := R;
RECEIVING := TRUE;
RETRIES := 10; (* Up to 10 retries allowed. *)
WHILE RECEIVING DO
CASE STATE OF
R : BEGIN (* Initial Receive State *)
IF (NOT RecvPacket) OR (INPACKETTYPE='N') THEN SendNAK
ELSE (* Get a packet *)
IF INPACKETTYPE = 'S' THEN
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 BEGIN
B8Quote := REPLYMSG.CHARS (.7.);
IF B8Quote = 'Y' THEN BIT8_QUOTE := '&';
IF NOT (B8Quote IN (.'Y', 'N'.)) THEN
BIT8_QUOTE := B8Quote
END;
IF INDATACOUNT >= 8 THEN
CHECKTYPE := REPLYMSG.CHARS (.8.)
ELSE CHECKTYPE := '1';
IF INDATACOUNT >= 9 THEN
REPEATCHAR := REPLYMSG.CHARS(.9.)
ELSE REPEATCHAR := '~';
IF INDATACOUNT >= 10 THEN
CAPAS :=
ORD (EBCDICTOASCII (.REPLYMSG.BYTES (.10.).)) - 32
ELSE CAPAS := 0;
IF INDATACOUNT >= 13 THEN BEGIN
PSIZE :=
ORD (EBCDICTOASCII (.REPLYMSG.BYTES (.12.).)) - 32;
PSIZE := PSIZE * 95 +
ORD (EBCDICTOASCII (.REPLYMSG.BYTES (.13.).)) - 32
END;
CheckParms;
OUTPACKETTYPE := 'Y';
ParmPacket;
SendPacket;
STATE := RF
END
ELSE BEGIN (* Not init packet *)
STATE := A; (* ABORT if not INIT packet *)
ABORT := NOT_S
END
END ; (* Initial Receive State *)
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 *)
FILEWANTED :=
SUBSTR (STR (REPLYMSG.CHARS), 1, INDATACOUNT);
IF INDEX (FILEWANTED, '*') > 0 THEN BEGIN
SendError ('No wildcards allowed, yet');
RETURN
END;
IX := LENGTH (FILEWANTED);
IF FILEWANTED (.IX.) = '.' THEN
FILEWANTED := SUBSTR (FILEWANTED, 1, IX-1);
IF Remote THEN BEGIN
OldFname := FILEWANTED;
CheckDsn (FILEWANTED, DsnDisp);
IF DsnDisp = ERROR THEN STATE := A
ELSE AllocFile (FILEWANTED)
END;
IF DsnDisp <> ERROR THEN BEGIN
REWRITE (RFILE);
CRFLAG := FALSE;
CRLFFLAG := FALSE;
STATE := RD;
SendACK (TRUE)
END
END
ELSE BEGIN (* Not S,F,B,Z packet *)
(* ABORT if not a S,F,B,Z type packet *)
STATE := A;
ABORT := NOT_SFBZ
END;
RD: IF (NOT RecvPacket) OR (INPACKETTYPE='N') THEN SendNAK
ELSE (* Got a good packet *)
IF INPACKETTYPE = 'A' THEN
BEGIN (* Got attributes *)
IN_Attr :=
SUBSTR (STR (REPLYMSG.CHARS), 1, INDATACOUNT);
DecodeAttr (IN_Attr);
SendACK (TRUE)
END
ELSE IF INPACKETTYPE = 'D' THEN (* Receive data *)
IF SeqChar = LastSeq THEN BEGIN (* Drop packet *)
OUTSEQ := OUTSEQ - 1;
RETRIES := 10; (* Reset RETRIES count *)
SendACK (TRUE)
END ELSE BEGIN (* Correct sequence *)
RETRIES := 10; (* Reset RETRIES count *)
I := 1;
REP := 1;
WHILE I <= INDATACOUNT DO
WITH REPLYMSG DO
IF TEXTMODE THEN BEGIN (* SCAN EBCDIC data *)
IF CHARS (.I.) = REPEATCHAR THEN
BEGIN (* Repeat character *)
REP := ORD (EBCDICTOASCII (.BYTES (.I+1.).))-32;
I := I + 2
END;
IF CHARS (.I.) = BIT8_QUOTE THEN
BEGIN (* 8 bit character *)
I := I+1 ;
BIT8 := 128
END ELSE BIT8 := 0;
IF CHARS (.I.) = CNTRL_QUOTE THEN
BEGIN (* CONTROL character *)
I := I+1;
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 *)
IF CHARS (.I.) <> '7E'XC THEN
BYTES (.I.) := BYTES (.I.) - 64;
IF BYTES (.I.) <> 0 THEN
CHARS (.I.) :=
ASCIITOEBCDIC (.BYTES (.I.) + BIT8.);
END ELSE
IF BIT8 <> 0 THEN BEGIN
CHARS (.I.) := EBCDICTOASCII (.BYTES (.I.).);
CHARS (.I.) :=
ASCIITOEBCDIC (.BYTES (.I.) + BIT8.)
END;
IF CRFLAG THEN BEGIN (* previous char was a CR *)
CRFLAG := FALSE;
IF CHARS (.I.) = '25'XC THEN WRITELN (RFILE)
ELSE BEGIN
WRITE (RFILE, '0D'XC);
FOR K := 1 TO REP DO
WRITE (RFILE, CHARS (.I.));
REP := 1
END
END ELSE
IF CHARS (.I.) = '0D'XC THEN CRFLAG := TRUE
ELSE BEGIN (* not a CR *)
CRFLAG := FALSE;
FOR K := 1 TO REP DO
WRITE (RFILE, CHARS (.I.));
REP := 1
END;
I := I + 1
END
ELSE BEGIN (* Text mode is OFF *)
(* Revert back to ASCII data record *)
IF CHARS (.I.) = REPEATCHAR THEN
BEGIN (* Repeat character *)
REP := ORD (EBCDICTOASCII (.BYTES (.I+1.).))-32;
I := I + 2
END;
IF CHARS (.I.) = BIT8_QUOTE THEN
BEGIN (* 8TH BIT QUOTING *)
I := I+1;
BIT8 := 128
END ELSE BIT8 := 0;
IF CHARS (.I.) = CNTRL_QUOTE THEN
BEGIN (* CONTROL character *)
I := I+1 ;
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 *)
IF CHARS (.I.) <> '7E'XC THEN
BYTES (.I.) := BYTES (.I.) - 64;
END (* CONTROL character *)
ELSE CHARS (.I.) := EBCDICTOASCII (.BYTES (.I.).);
BYTES (.I.) := BYTES (.I.) + BIT8;
FOR K := 1 TO REP DO
WRITE (RFILE, CHARS (.I.));
REP := 1;
I := I + 1
END ;
SendACK (TRUE)
END
ELSE IF INPACKETTYPE = 'F' THEN BEGIN (* Send ACK *)
OUTSEQ := OUTSEQ - 1;
SendACK (TRUE)
END
ELSE IF INPACKETTYPE = 'Z' THEN
BEGIN (* End of Receive File *)
CLOSE (RFILE);
TSOService ('FREE F(RFILE)', RC);
STATE := RF;
SendACK (TRUE)
END
ELSE BEGIN (* Not D,Z packet *)
STATE := A; (* ABORT - Type not D or Z, *)
ABORT := NOT_DZ
END;
C: BEGIN (* COMPLETED Receiving *)
CLOSE (RFILE);
TSOService ('FREE F(RFILE)', RC);
SendACK (TRUE);
RECEIVING := FALSE;
GetFile := FALSE
END;
A: BEGIN (* Abort Receiving *)
CLOSE (RFILE);
IF Incomplete_File THEN
TSOService ('FREE F(RFILE)', RC)
ELSE TSOService ('FREE F(RFILE) DELETE', RC);
RECEIVING := FALSE;
GetFile := FALSE;
SendError ('Receive file aborted')
END
END (* CASE of STATE *)
END; (* RecvFile *)
%TITLE Procedure ShowIT
(******************************************************************)
(* ShowIT - This routine handles the SHOW COMMAND. *)
(******************************************************************)
PROCEDURE ShowIT;
BEGIN
WRITELN ('------- Current Status -----------');
WRITELN (' ');
IF ScreenSize = 0 THEN
WRITELN (' KERMIT currently running in line mode (ASCII). ')
ELSE WRITELN (' KERMIT currently running in full-screen mode.');
WRITE (' Init file KERMIT.SETUP ... ');
IF Init_File THEN WRITELN ('already loaded')
ELSE WRITELN ('not specified');
WRITELN (' Your PROFILE data set is KERMIT.PROFILE');
WRITELN (' ');
IF TEXTMODE THEN BEGIN
WRITELN (' TEXT MODE is ON - ASCII/EBCDIC');
IF FB THEN WRITELN (' RECFM_INPUT is FB, LRECL is 80')
ELSE WRITELN (' RECFM_INPUT is VB, LRECL is 255')
END ELSE BEGIN
WRITELN (' TEXT MODE is OFF' );
WRITELN (' RECFM_INPUT is U, BLKSIZE is 1024')
END;
WRITELN (' ');
WRITE (' PACKET SIZE is ', PSIZE:3);
IF Long_Packet THEN WRITELN (' (extended packets)')
ELSE WRITELN (' (standard packets)');
WRITELN (' EOL CHAR is ', ECHAR:2,' decimal(ascii)');
WRITELN (' SOH CHAR is ', SCHAR:2,' decimal(ascii)');
WRITELN (' CNTRL_QUOTE is ', CNTRL_QUOTE);
WRITELN (' BIT8_QUOTE is ', BIT8_QUOTE, ORD (BIT8_QUOTE));
WRITELN (' CHECKTYPE is ', CHECKTYPE);
WRITELN (' REPEATCHAR is ', REPEATCHAR, ORD(REPEATCHAR));
WRITELN (' DELAY is ', Delay:3:1, ' seconds');
WRITE (' DEBUG mode is ');
IF Debug THEN WRITELN ('ON') ELSE WRITELN ('OFF');
WRITE (' INCOMPLETE is ');
IF Incomplete_File THEN WRITELN ('KEEP') ELSE WRITELN ('DELETE');
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 *)
%TITLE Procedure SetIT
(******************************************************************)
(* SetIT - This routine handles the SET COMMAND. *)
(******************************************************************)
PROCEDURE SetIT;
VAR Answer : ALFA;
Temp : STRING (1);
N1, N2 : INTEGER;
BEGIN
COMMAND := GETTOKEN (INPUTSTRING);
UPCASE (COMMAND);
REQUEST := ' ' || TRIM (STR (COMMAND));
CINDEX := INDEX (WHATTABLE, REQUEST) DIV 8 ;
IF LENGTH (INPUTSTRING) = 0 THEN INPUTSTRING := '?';
CASE WHATFLAGS (CINDEX) OF
$TEXTMODE : (* TEXT MODE FLAG *)
IF INPUTSTRING(.1.) = '?' THEN
WRITELN ('Enter ON for Textfiles, OFF for binary files')
ELSE BEGIN
SETTING := GETTOKEN (INPUTSTRING);
UPCASE (SETTING);
TEXTMODE := NOT (SETTING = 'OFF ');
IF TEXTMODE THEN WRITELN ('TEXT MODE is ON ')
ELSE WRITELN ('TEXT MODE is OFF');
END;
$RECFM : (* RECFM *)
IF INPUTSTRING(.1.) = '?' THEN BEGIN
WRITELN ('Enter FB for fixed record length, ');
WRITELN (' or VB for variable record length')
END ELSE BEGIN
SETTING := GETTOKEN (INPUTSTRING);
UPCASE (SETTING);
IF SETTING = 'FB ' THEN FB := TRUE
ELSE FB := FALSE;
IF FB THEN WRITELN ('INPUT RECFM is FB, LRECL is 80')
ELSE WRITELN ('INPUT RECFM is VB, LRECL is 255 ')
END;
$PACKETSIZE: (* SET PACKET SIZE *)
IF INPUTSTRING(.1.) = '?' THEN
WRITELN ('Enter number (range 26 .. 1000) as packetsize')
ELSE BEGIN
IF INPUTSTRING (.1.) = '-' THEN
INPUTSTRING := SUBSTR (INPUTSTRING, 2);
READSTR (INPUTSTRING, PSIZE);
IF (PSIZE > 1000) THEN BEGIN
WRITELN ('ERROR: Number too large. Will use 1000');
PSIZE := 1000
END;
IF (PSIZE < 26) THEN BEGIN
WRITELN ('ERROR: Number too small. Will use 94');
PSIZE := 94
END;
IF PSIZE > 94 THEN Long_Packet := TRUE
ELSE Long_Packet := FALSE;
(* IF PSIZE > 256 THEN CHECKTYPE := '3'; *)
WRITELN ('PACKET SIZE is ',PSIZE:4)
END;
$EOLCHAR : (* SET end of line char *)
IF INPUTSTRING(.1.) = '?' THEN
WRITELN ('Enter number (ascii) used as eol character')
ELSE BEGIN
IF INPUTSTRING (.1.) = '-' THEN
INPUTSTRING := SUBSTR (INPUTSTRING, 2);
READSTR (INPUTSTRING, ECHAR);
IF (ECHAR < 5) OR (ECHAR > 18) THEN ECHAR := 13 ;
WRITELN ('EOLCHAR is ', ECHAR, ' decimal(ascii)')
END;
$CNTRL_QUOTE: (* SET control quote *)
IF INPUTSTRING(.1.) = '?' THEN
WRITELN ('Enter character to be used as cntrl quote')
ELSE BEGIN
READSTR (INPUTSTRING, Temp);
IF INDEX (SPECTABLE, Temp) > 0 THEN
CNTRL_QUOTE := Temp (.1.) ELSE CNTRL_QUOTE := '#';
WRITELN ('CNTRL QUOTE is ', CNTRL_QUOTE)
END;
$BIT8_QUOTE: (* SET bit 8 quote *)
IF INPUTSTRING(.1.) = '?' THEN
WRITELN ('Enter character to be used as bit8 quote')
ELSE BEGIN
READSTR (INPUTSTRING, Temp);
IF INDEX (SPECTABLE, Temp) > 0 THEN
BIT8_QUOTE := Temp (.1.) ELSE BIT8_QUOTE := '&';
WRITELN ('BIT8_QUOTE is ', BIT8_QUOTE)
END;
$CHECKTYPE : (* SET CHECK TYPE *)
IF INPUTSTRING(.1.) = '?' THEN
WRITELN ('Enter number (1,2 or 3) to select check type')
ELSE BEGIN
READSTR (INPUTSTRING, CHECKTYPE);
IF INDEX ('123', STR (CHECKTYPE)) = 0 THEN
CHECKTYPE := '1';
WRITELN ('CHECKTYPE is ', CHECKTYPE )
END;
$DELAY : (* SET DELAY FACTOR *)
IF INPUTSTRING(.1.) = '?' THEN
WRITELN ('Enter send wait-time in seconds (2 .. 30)')
ELSE BEGIN
READSTR (INPUTSTRING, Delay);
IF (Delay < 2) OR (Delay > 30) THEN Delay := 6;
WRITELN ('Delay now set to ', Delay:3:1, ' seconds')
END;
$DEBUG : (* SET DEBUG option *)
IF INPUTSTRING(.1.) = '?' THEN BEGIN
WRITELN ('Enter ON to log transactions, or');
WRITELN (' OFF to finish logging')
END ELSE BEGIN
READSTR (INPUTSTRING, Answer);
UPCASE (Answer);
IF Answer = 'ON' THEN
IF Debug THEN (* DEBUG was already ON ! *)
ELSE BEGIN
Debug := TRUE;
TSOService ('FREE F(DFILE)', RC);
TSOService ('DELETE ' || DEBUGNAME, RC);
TSOCommand := 'ALLOC F(DFILE) DA(' || DEBUGNAME ||
') NEW SP(1,1) CYL ' || DCB_DEBUG;
TSOService (TSOCommand, RC);
IF RC < 8 THEN REWRITE (DFILE)
ELSE BEGIN
Debug := FALSE;
WRITELN ('Debug file could not be allocated, ',
'return code is ', RC)
END
END;
IF Answer = 'OFF' THEN
IF Debug THEN BEGIN
Debug := FALSE;
CLOSE (DFILE);
TSOService ('FREE F(DFILE)', RC)
END ELSE (* DEBUG was already OFF ! *);
WRITE ('Debug mode now set to ');
IF Debug THEN WRITELN ('ON') ELSE WRITELN ('OFF')
END;
$REPCHAR : (* SET repeat char *)
IF INPUTSTRING(.1.) = '?' THEN
WRITELN ('Enter character to be used as repeat quote')
ELSE BEGIN
READSTR (INPUTSTRING, Temp);
IF INDEX (SPECTABLE, Temp) > 0 THEN
REPEATCHAR := Temp (.1.) ELSE REPEATCHAR := '~';
WRITELN ('REPEAT CHAR is ', REPEATCHAR)
END;
$SOHCHAR : (* SET repeat char *)
IF INPUTSTRING(.1.) = '?' THEN
WRITELN ('Enter decimal value (1..18) used as soh character')
ELSE BEGIN
IF INPUTSTRING (.1.) = '-' THEN
INPUTSTRING := SUBSTR (INPUTSTRING, 2);
READSTR (INPUTSTRING, SCHAR);
IF (SCHAR < 1) OR (SCHAR > 18) THEN SCHAR := 1 ;
SOH := CHR (SCHAR);
WRITELN ('SOHCHAR is ', SCHAR, ' decimal(ascii)')
END;
$ATOE: (* SET ASCII -> EBCDIC table *)
IF INPUTSTRING(.1.) = '?' THEN BEGIN
WRITELN ('Enter two numbers, the first is the entry in');
WRITELN ('the ASCII table, the second the correspond.');
WRITELN ('EBCDIC char. The valid range is (1 .. 255) ')
END
ELSE BEGIN
READSTR (INPUTSTRING, N1, N2);
IF (N1 < 1) OR (N1 > 255) THEN RETURN;
IF (N2 < 0) OR (N2 > 255) THEN RETURN;
ASCIITOEBCDIC (.N1.) := CHR (N2);
WRITELN ('ASCII (', N1:3,') has now the value of ',
'EBCDIC (', N2:3,')')
END;
$ETOA: (* SET EBCDIC -> ASCII table *)
IF INPUTSTRING(.1.) = '?' THEN BEGIN
WRITELN ('Enter two numbers, the first is the entry in');
WRITELN ('the EBCDIC table, the second the correspon.');
WRITELN ('ASCII char. The valid range is (1 .. 255) ')
END
ELSE BEGIN
READSTR (INPUTSTRING, N1, N2);
IF (N1 < 1) OR (N1 > 255) THEN RETURN;
IF (N2 < 0) OR (N2 > 255) THEN RETURN;
EBCDICTOASCII (.N1.) := CHR (N2);
WRITELN ('EBCDIC (', N1:3,') has now the value of ',
'ASCII (', N2:3,')')
END;
$INCOMPLETE: (* SET incomplete option *)
IF INPUTSTRING(.1.) = '?' THEN BEGIN
WRITELN ('Enter options KEEP or DELETE to control the');
WRITELN ('disposition of an incomplete file.')
END
ELSE BEGIN
SETTING := GETTOKEN (INPUTSTRING);
UPCASE (SETTING);
IF (SETTING = 'DELETE ') OR (SETTING = 'DEL ') THEN
Incomplete_File := FALSE;
IF SETTING = 'KEEP ' THEN
Incomplete_File := TRUE
END;
$DUMMY: WRITELN ('NOT YET implemented ');
OTHERWISE BEGIN (* Invalid SET OPTION *)
WRITELN ('SET ', REQUEST, ' - invalid option specified.');
WRITELN ('Valid OPTIONS are : ');
WRITELN ('----------------------- ');
WRITELN (' ');
WRITELN (' BIT8_QUOTE c - Bit8 quote character');
WRITELN (' CHECK n - Block check type');
WRITELN (' CNTRL_QUOTE c - Quote character');
WRITELN (' DELAY nnn - Delay factor');
WRITELN (' DEBUG ON/OFF - Debug mode ');
WRITELN (' EOLCHAR nn - Endline char (decimal)');
WRITELN (' INCOMPLETE KEEP/DEL- Disposition of incomplete files');
WRITELN (' PACKETSIZE nn - Packet size (decimal)');
WRITELN (' RECFM VB/FB - Variable or Fixed');
WRITELN (' REPEATCHAR c - Repeat char');
WRITELN (' SOHCHAR nn - Start of packet (decimal)');
WRITELN (' TEXTMODE ON/OFF - for text / binary files');
END
END
END; (* SetIT procedure *)
%TITLE Procedure Help
(******************************************************************)
(* Help - This routine handles the HELP COMMAND. *)
(******************************************************************)
PROCEDURE Help;
BEGIN
WRITELN (' The following are the valid KERMIT-TSO commands : ');
WRITELN (' ');
WRITELN (' SEND filename - send a file to the micro');
WRITELN (' as! filename! (you may select the new name)');
WRITELN (' RECEIVE filename! - receive a file from the micro');
WRITELN (' SERVER - go into server mode');
WRITELN (' SET option value - set OPTION to VALUE');
WRITELN (' STATUS - displays current options settings');
WRITELN (' TAKE filename - execute commands from a file');
WRITELN (' DO membername - execute commands from your profile');
WRITELN (' HELP - displays this information');
WRITELN (' EXIT, END or QUIT - exit KERMIT , terminate program');
WRITELN (' LOGOUT - exit KERMIT and logoff from host');
WRITELN (' ');
WRITELN ('Additional TSO facilities:');
WRITELN (' DELETE filename - deletes cataloged data set');
WRITELN (' DIR userid! - shows user directory');
WRITELN (' DISK - displays disk usage');
WRITELN (' MEMBERS filename - shows member list of a file');
WRITELN (' TSO command - issues a TSO command');
WRITELN (' TYPE filename - displays data set at the screen');
WRITELN (' WHO - shows users logged in on the host');
END ; (* HELP procedure *)
%TITLE Procedure Micro_Finish;
(*******************************************************************)
(* Micro_Finish - This routine turns down a micro's KERMIT running *)
(* in server mode (used only with setup-files). *)
(*******************************************************************)
PROCEDURE Micro_Finish;
VAR Ok : BOOLEAN;
BEGIN
OUTSEQ := 0;
OUTPACKETTYPE := 'I';
ParmPacket;
SendPacket;
IF RecvPacket AND (INPACKETTYPE='Y') THEN (* Ok *)
ELSE ReSendit(10);
OUTDATACOUNT := 1;
OUTSEQ := 0;
OUTPACKETTYPE := 'G';
SENDMSG.CHARS := 'F';
SendPacket;
IF RecvPacket AND (INPACKETTYPE='Y') THEN (* Ok *)
ELSE ReSendit(10)
END; (* Micro_Finish *)
%TITLE Procedure RemoteCommand
(*******************************************************************)
(* RemoteCommand -This routine handles the COMMANDS from a remote *)
(* kermit. *)
(*******************************************************************)
PROCEDURE RemoteCommand;
CONST
COMMANDTABLE = 'CEGIRSYK';
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,
B8Quote : CHAR ;
Ix : INTEGER ;
Ok : BOOLEAN;
TSOUser : STRING (10);
TSOFname : STRING (80);
XLine : LString;
LABEL CHECKCOMMAND ;
(*-----------------------------------------------------------*)
(* Remote_Help - send help information to remote micro *)
(*-----------------------------------------------------------*)
PROCEDURE Remote_Help;
BEGIN
SendDPacket
('This is the KERMIT server running under MVS/XA TSO'||CRLF, Ok);
IF NOT Ok THEN RETURN;
SendDPacket (CRLF, Ok);
IF NOT Ok THEN RETURN;
SendDPacket
('The following server commands are actually supported:'||CRLF, Ok);
IF NOT Ok THEN RETURN;
SendDPacket (CRLF, Ok);
IF NOT Ok THEN RETURN;
SendDPacket
(' DELETE filename - erases a specific host file'||CRLF, Ok);
IF NOT Ok THEN RETURN;
SendDPacket
(' DIR - displays your disk directory'||CRLF, Ok);
IF NOT Ok THEN RETURN;
SendDPacket
(' DISK - displays the current disk usage'||CRLF, Ok);
IF NOT Ok THEN RETURN;
SendDPacket
(' FINISH - finishes server mode on the host'||CRLF, Ok);
IF NOT Ok THEN RETURN;
SendDPacket
(' GET filename - requests one or more files'||CRLF, Ok);
IF NOT Ok THEN RETURN;
SendDPacket
(' HELP - displays this information page'||CRLF, Ok);
IF NOT Ok THEN RETURN;
SendDPacket
(' LOGOUT - stops host KERMIT and logout'||CRLF, Ok);
IF NOT Ok THEN RETURN;
SendDPacket
(' SEND filename - sends one or more files to the host'||CRLF,Ok);
IF NOT Ok THEN RETURN;
SendDPacket
(' TYPE filename - displays a specific host file'||CRLF, Ok);
IF NOT Ok THEN RETURN
END; (* Remote_Help *)
%PAGE
BEGIN (* RemoteCommand procedure *)
INPUTSTRING := Line;
COMMANDTYPE := INPUTSTRING(.4.);
INPACKETTYPE := COMMANDTYPE;
GetFile := FALSE;
CHECKCOMMAND :
IF INDEX (COMMANDTABLE, STR (COMMANDTYPE)) = 0 THEN BEGIN
SendError ('Unknown commandtype, ' || STR (COMMANDTYPE));
RETURN
END;
IF COMMANDTYPE = 'C' THEN BEGIN (* HOST command *)
INPUTSTRING := SUBSTR (INPUTSTRING, 5);
SendYPacket ('Host Command not available')
END;
IF COMMANDTYPE = 'K' THEN BEGIN (* KERMIT command *)
INPUTSTRING := SUBSTR (INPUTSTRING, 5);
SendYPacket ('KERMIT command not executed')
END;
IF COMMANDTYPE = 'E' THEN (* Got an error message back *);
IF COMMANDTYPE = 'I' THEN BEGIN (* INITIALIZE *)
INDATACOUNT := ORD (EBCDICTOASCII (.ORD (INPUTSTRING(.2.)).))-32-3;
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 BEGIN
B8Quote := INPUTSTRING (.4+7.);
IF B8Quote = 'Y' THEN BIT8_QUOTE := '&';
IF NOT (B8Quote IN (.'Y', 'N'.)) THEN
BIT8_QUOTE := B8Quote
END;
IF INDATACOUNT>= 8 THEN CHECKTYPE := INPUTSTRING (.4+8.)
ELSE CHECKTYPE := '1';
IF INDATACOUNT>= 9 THEN REPEATCHAR := INPUTSTRING (.4+9.)
ELSE REPEATCHAR := '~';
IF INDATACOUNT >= 10 THEN
CAPAS := ORD (EBCDICTOASCII (.ORD (INPUTSTRING (.4+10.)).))-32
ELSE CAPAS := 0;
IF INDATACOUNT >= 13 THEN BEGIN
PSIZE := ORD (EBCDICTOASCII(.ORD(INPUTSTRING(.4+12.)).))-32;
PSIZE := PSIZE * 95 +
ORD (EBCDICTOASCII(.ORD(INPUTSTRING(.4+13.)).))-32
END;
OUTPACKETTYPE := 'Y';
CheckParms;
ParmPacket ;
SendPacket ;
IF RecvPacket THEN
BEGIN
COMMANDTYPE := INPACKETTYPE ;
INPUTSTRING := 'XXX'|| STR(INPACKETTYPE) ||
SUBSTR (STR (REPLYMSG.CHARS), 1, INDATACOUNT);
GOTO CHECKCOMMAND
END
END;
IF COMMANDTYPE = 'R' THEN BEGIN (* Send to micro *)
INPUTSTRING := SUBSTR (INPUTSTRING, 5);
TSOFname := LTRIM (INPUTSTRING);
IF Debug THEN WRITELN (DFILE, 'REM: Sending file(s)', TSOFname);
SendFile (TSOFname, FALSE)
END;
IF COMMANDTYPE = 'S' THEN BEGIN (* Receive from micro *)
IF Debug THEN WRITELN (DFILE, 'REM: Receiving file(s) from micro');
RecvFile
END;
IF COMMANDTYPE = 'Y' THEN (* Got an ACK for break packet *);
IF COMMANDTYPE = 'G' THEN BEGIN (* GENERAL *)
SUBCOMMAND := INPUTSTRING (.5.);
OUTSEQ := 0;
CASE SUBCOMMANDTYPE (INDEX (SUBCOMMANDTABLE, STR (SUBCOMMAND))) OF
C: (* CHANGE command *)
SendError ('No CHANGE directory available under MVS');
D: BEGIN (* DIRECTORY command *)
TSOService ('TSODS LISTCAT' , RC);
IF RC <> 0 THEN
SendYPacket ('No file(s) found for '|| UserID)
ELSE BEGIN (* GOT directory *)
OUTSEQ := 64;
SendXPacket ('DIRECTORY for ' || UserID);
RESET (TSODS);
WHILE NOT EOF (TSODS) DO BEGIN
READLN (TSODS, XLine);
XLine := XLine || CRLF;
SendDPacket (XLine, Ok);
IF NOT Ok THEN LEAVE
END;
CLOSE (TSODS);
IF INPACKETTYPE='Y' THEN SendZPacket;
IF INPACKETTYPE='Y' THEN SendBPacket
END
END;
E: BEGIN (* Erase File command *)
IF LENGTH (INPUTSTRING) > 7 THEN
TSOFname :=
SUBSTR (INPUTSTRING, 7, LENGTH (INPUTSTRING)-6);
IF Debug THEN WRITELN (DFILE, 'Delete data set ' ||
TSOFname);
TSOService ('DELETE ' || TSOFname, RC);
IF RC = 0 THEN TSOCommand := 'File deleted '
ELSE TSOCommand := 'Not deleted ';
SendYPacket (TSOCommand)
END;
F: BEGIN (* FINISH command *)
RUNNING := FALSE ;
SendACK (TRUE)
END;
H: BEGIN (* HELP command *)
OUTSEQ := 64;
SendXPacket ('');
Remote_Help;
IF INPACKETTYPE='Y' THEN SendZPacket;
IF INPACKETTYPE='Y' THEN SendBPacket
END;
I: (* LOGIN command *)
SendYPacket ('Already logged on');
J: (* Journal *)
SendYPacket ('No Journal available, use DEBUG option');
K: (* Copy file *)
SendYPacket ('No Copy function available, yet');
L: BEGIN (* LOGOUT command *)
RUNNING := FALSE ;
EndKermit := TRUE;
SendACK (TRUE)
END;
M: (* MESSAGE command *)
SendYPacket ('No Message function available, yet');
P: (* Print command *)
SendYPacket ('No Print function available, yet');
Q: (* QUERY status command *)
SendYPacket ('No Query state available');
R: (* Rename file *)
SendYPacket ('No Rename function available, yet');
S: (* Submit command *)
SendYPacket ('Submit command not implemented');
T: BEGIN (* TYPE File command *)
IF LENGTH (INPUTSTRING) > 7 THEN
TSOFname := SUBSTR (INPUTSTRING, 7,
ORD (EBCDICTOASCII (.ORD(INPUTSTRING(.6.)).))-32)
ELSE BEGIN
SendError ('No file specified');
RETURN
END;
IF INDEX (TSOFname,'*') > 0 THEN
SendError ('No * allowed for typing files')
ELSE BEGIN
OUTSEQ := 64;
SendXPacket ('Typing file : ' || TSOFname);
SendFile (TSOFname, TRUE)
END
END;
U: BEGIN (* Disk Usage command *)
TSOService ('TSODS SPACE TOTAL', RC);
IF RC <> 0 THEN SendError ('Error on Disk Space')
ELSE BEGIN
OUTSEQ := 64;
SendXPacket ('Disk usage of ' || UserID);
RESET (TSODS);
FOR Ix := 1 TO 2 DO BEGIN
READLN (TSODS, XLine);
IF LENGTH (XLine) > 35 THEN
XLine := SUBSTR (XLine, 1, 35);
SendDPacket (XLine || CRLF, Ok);
IF NOT Ok THEN LEAVE
END;
CLOSE (TSODS);
IF INPACKETTYPE='Y' THEN SendZPacket;
IF INPACKETTYPE='Y' THEN SendBPacket
END
END;
W: (* WHO command *)
SendYPacket ('Try WHO in interactive mode');
OTHERWISE SendError ('Unknown subcommand') (* ERROR *)
END
END
END ; (* REMOTECOMMAND procedure *)
%TITLE KERMIT - Main Program
(******************************************************************)
(******** OUTER BLOCK OF KERMIT ********)
(******************************************************************)
BEGIN
TERMIN (INPUT); TERMOUT (OUTPUT);
TermSize (ScreenSize);
Remote := FALSE; EndKermit := FALSE;
TEXTMODE := TRUE; Init_File := FALSE;
RUNNING := TRUE; CmdMode := FALSE;
Handle_Attribute := FALSE;
Long_Packet := FALSE;
IF INDEX (PARMS, '@INIT') = 0 THEN UserID := PARMS
ELSE BEGIN
CmdMode := TRUE;
Init_File := TRUE;
Remote := TRUE;
UserID := SUBSTR (PARMS, 1, (INDEX(PARMS,'@INIT')-1));
TSOCommand := 'ALLOC F(CMDFILE) DA(' || CMDNAME || ') SHR REUSE';
TSOService (TSOCommand, RC);
RESET (CmdFile);
END;
TSOService ('DELETE TSODS', RC);
TSOCommand := 'ALLOC F(TSODS) DA(TSODS) NEW TR SP(1,1) ' || DCB_Var;
TSOService (TSOCommand, RC);
WRITELN('Welcome to KERMIT under MVS/XA-TSO V2.3');
WRITELN(' ');
IF ScreenSize > 0 THEN BEGIN
WRITELN (' You are running Kermit-TSO from a full-screen device.');
WRITELN (' There is no filetransfer supported in this mode.');
WRITELN (' ')
END;
WHILE RUNNING DO BEGIN (* Command Loop *)
MAINLOOP: (* NORMAL IO *)
IF CmdMode THEN BEGIN
IF NOT EOF (CmdFile) THEN READLN (CmdFile, INPUTSTRING)
ELSE BEGIN
INPUTSTRING := ' ';
CmdMode := FALSE;
Remote := TRUE;
CLOSE (CmdFile)
END
END ELSE Prompt ('KERMIT-TSO>', INPUTSTRING) ;
IF (BIT8_QUOTE = '00'XC) AND (NOT TEXTMODE) THEN BEGIN
WRITELN ('**** WARNING - TEXT MODE is turned off, other');
WRITELN (' KERMIT can not handle the 8th bit.')
END ; (* Warning *)
GetFile := FALSE;
INPUTSTRING := LTRIM(INPUTSTRING);
IF INPUTSTRING = ' ' THEN GOTO MAINLOOP;
IF SUBSTR(INPUTSTRING,1,1) = STR (SOH) THEN RemoteCommand
ELSE BEGIN (* Local Command *)
INPUTSTRING := LTRIM (INPUTSTRING);
COMMAND := GETTOKEN (INPUTSTRING);
UPCASE (COMMAND);
REQUEST := ' ' || TRIM (STR (COMMAND));
CINDEX := INDEX(COMMTABLE,REQUEST) DIV 8 ;
CASE COMMANDS(CINDEX) OF
$BAD : WRITELN (COMMAND, 'is an invalid command.');
$SEND : SendFile (INPUTSTRING, FALSE);
$RECEIVE: BEGIN
INPUTSTRING := LTRIM(INPUTSTRING);
IF INPUTSTRING = ' ' THEN BEGIN
Remote := TRUE;
WRITELN ('ready to RECEIVE file - ',
'SEND file(s) from Micro. ');
Waiting (Delay)
END;
RecvFile;
Remote := FALSE
END;
$SERVER : BEGIN
WRITELN('Entering SERVER mode - ',
'Issue FINISH or LOGOUT command from',
' micro to stop SERVER');
IF Debug THEN
WRITELN (DFILE, 'Entering SERVER mode ...');
Remote := TRUE;
REPEAT
STATE := S_I; (* Server_Init state *)
IF RecvPacket THEN BEGIN
Line := ' ' || STR (INPACKETTYPE) ||
SUBSTR(STR(REPLYMSG.CHARS),1,INDATACOUNT);
IF Debug THEN WRITELN (DFILE,'>>',Line);
RemoteCommand
END;
UNTIL NOT RUNNING;
IF Debug THEN
WRITELN (DFILE, 'SERVER mode ended');
Remote := FALSE;
IF NOT EndKermit THEN RUNNING := TRUE
END;
$SET : SetIT;
$SHOW,
$STATUS : ShowIT;
$HELP,
$QUES : HELP ;
$DEL : BEGIN
TSOService ('DELETE ' || INPUTSTRING, RC);
IF RC > 0 THEN WRITELN ('Data set ' ||
INPUTSTRING || ' not deleted');
END;
$DIR : IF INPUTSTRING = ' '
THEN TSOService ('LISTCAT ', RC)
ELSE TSOService ('LISTCAT LEV(' ||
INPUTSTRING || ')', RC);
$DISK : BEGIN
WRITELN ('Total disk space in tracks:');
TSOService ('SPACE TOTAL ', RC)
END;
$MEM : IF INPUTSTRING <> ' ' THEN BEGIN
INPUTSTRING := TRIM (INPUTSTRING);
CheckDsn (INPUTSTRING, DsnDisp);
IF DsnDisp = SHARE THEN
WRITELN ('File ', INPUTSTRING,
' is sequential')
ELSE IF DsnDisp = NEW THEN
WRITELN ('File ', INPUTSTRING,
' does not exist')
ELSE BEGIN
RESET (TSODS);
FOR I := 1 TO 7 DO READLN (TSODS, Line);
IF INDEX (Line, 'NOT USEABLE') > 1 THEN
WRITELN ('No access to file: ', INPUTSTRING)
ELSE BEGIN
WRITELN ('Memberlist for: ', INPUTSTRING);
I := 1;
WHILE NOT EOF (TSODS) DO BEGIN
WRITE (Line:-12);
READLN (TSODS, Line);
I := I + 1;
IF I > 5 THEN BEGIN
WRITELN; I := 1 END;
END; WRITELN (Line:-12)
END;
CLOSE (TSODS)
END
END
ELSE WRITELN ('No file specified');
$TSO : BEGIN
TSOService (INPUTSTRING, RC);
IF RC <> 0 THEN
WRITELN (' TSO command ended with error ', RC)
END;
$TYPE : BEGIN
TSOService ('LIST ' || INPUTSTRING, RC);
IF RC > 0 THEN WRITELN ('Data set ' ||
INPUTSTRING || ' not found');
END;
$WHO : TSOService ('USERS ', RC);
$FINISH : IF NOT CmdMode THEN WRITELN ('Nothing happens ...')
ELSE Micro_Finish;
$QUIT,
$END,
$EXIT : RUNNING := FALSE;
$LOG : IF (COMMAND = 'LOG') OR (COMMAND = 'LOGOUT')
THEN BEGIN
RUNNING := FALSE ;
EndKermit := TRUE
END;
$DO,
$TAKE : IF INPUTSTRING = '' THEN
WRITELN ('No commandfile specified')
ELSE IF CmdMode THEN (* Do nothing *)
ELSE BEGIN
IF COMMANDS(CINDEX) = $DO THEN
INPUTSTRING := PROFNAME || '(' ||
TRIM(INPUTSTRING) || ')';
TSOCommand := 'ALLOC F(CMDFILE) DA(' ||
INPUTSTRING || ') SHR REUSE';
TSOService (TSOCommand, RC);
IF RC <= 4 THEN BEGIN
CmdMode := TRUE;
Remote := TRUE;
RESET (CmdFile)
END ELSE WRITELN ('Commandfile not found')
END;
$VERSION: BEGIN
WRITELN (' This is the KERMIT filetransfer ',
'program for IBM System 370 under MVS/TSO.');
WRITELN (' The actual version number is 2.3',
', featuring long packets ... Fritz B.')
END;
OTHERWISE WRITELN (COMMAND, ' is an INVALID command');
END (* Execute the Command *)
END; (* Local Command *)
INPUTSTRING := ''
END ; (* Command Loop *)
IF Debug THEN CLOSE (DFILE);
IF CmdMode THEN CLOSE (CmdFile);
TSOService ('FREE F(TSODS) DELETE', RC);
IF EndKermit THEN TSOService ('TSOEXEC LOGOFF', RC);
WRITELN('End of KERMIT ')
END.