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 - -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 (* 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 (* 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.