Columbia Kermit

home *** CD-ROM | disk | FTP | other *** search

/ Columbia Kermit / kermit.zip / hp3000 / hp3000spl.txt < prev next >

Wrap

Text File | 2020-01-01 | 206KB | 5,949 lines

$PAGE $CONTROL MAIN=KERMIT, NOLIST $TITLE "KERMIT" BEGIN define VERS = ("HP 3000 KERMIT ", "VERSION: 12 JULY 1994", %(16)0D, %(16)0A, "Works best with PC Kermit V2.31 or newer.", %(16)0D, %(16)0A, "You can now use PARM= on RUN stmt ", "to specify TAKE file.")#; <<*****************************************************************>> << >> << Version 1.0 : Ed Eldridge >> << Polaris, Inc. >> << 1400 Wilson Blvd >> << suite 1100 >> << Arlington, Virginia 22209 >> << (703) 527-7333 >> << >> << Version 2.0 : Tony Appelget >> << General Mills, Inc. >> << P.O. Box 1113 >> << Minneapolis, MN 55440 >> << (612) 540-7703 >> << >> << * * * * * * * * * * * * * * * * * * * * * * * * * * * * * >> << >> << I have left General Mills, and will no longer be able >> << to maintain the HP3000 Kermits unless, by chance or good >> << fortune, I wind up in another HP3000 shop. I will be >> << available to answer questions on a call-at-your-own risk >> << basis. My home phone is (612) 559-3764. >> << Tony Appelget >> << 13 July 1994 >> << >> << * * * * * * * * * * * * * * * * * * * * * * * * * * * * * >> << >> << Added HELP function. >> << >> << Reworked input scanner. In particular, got rid of >> << IF-THEN-ELSE structure that went for pages and pages >> << and was confusing and not particularly maintainable. >> << Allow a certain amount of abbreviation for input >> << commands. This implementation could use improvement. >> << >> << Added SET SOH keyin and made default SOH to be octal >> << 02 (STX). >> << >> << Added file presence tests to RECEIVE and SET LOG >> << functions so that user will know of a duplicate file >> << situation before a file is opened rather than when >> << the attempt is made to close the file, possibly after >> << a long transmission. >> << >> << >> << SSR 91-417 FEB 85 TONY APPELGET >> << Added rudimentary file validation check. Users will be >> << restricted as to which files or groups of files they >> << will be permitted to access, and how the files may be >> << accessed. The implementation philosophy is identical >> << to that devised for LINK/125. Indeed, KERMIT and LINK/ >> << 125 use the same file. Added SPACE, DELETE, and VERIFY >> << commands. Fixed assorted bugs. >> << >> << SSR 91-??? SUMMER 1985 TONY APPELGET >> << 1) Made STATUS command SYNONYMOUS with the VERIFY >> << command. >> << >> << 2) If multiple files were were received from the remote, >> << only the first was saved. This problem has been >> << fixed. >> << >> << 3) Changed the abbreviation algorithm to allow shorter >> << user input. >> << >> << 4) After a file was sent, there was an annoying pause >> << before the user could enter a new command at the >> << remote computer. This Kermit was closing the file >> << it had just received and was not seeing the EOT packet>> << transmitted by the remote. This problem has been >> << fixed. >> << >> << 5) Lockwords may be specified for any filespec including >> << log files. >> << >> << 6) When '?' is entered for help, the command is redis- >> << played so the user may continue without having to >> << retype the entire command. >> << >> << 8) Any command may be aborted with ctrl-y. >> << >> << 9) The TYPE command has been implemented. >> << >> << 10) If the session job control word JCW is non-zero, >> << Kermit will attempt to access the take file F599KMnn, >> << where nn is the value contained in JCW. >> << >> << 11) Changed the error message produced when a file does >> << not pass the validation check. >> << >> << 12) If, when receiving a file, the same packet was >> << received twice, Kermit could not handle the situation >> << and stopped receiving. Now the duplicate packet is >> << acked and discarded. >> << >> << 13) Added the equivalent of SET RECEIVE MAXEXT 1 to the >> << SET RECEIVE PROG command. Large code files could >> << occupy more than one extent and hence be nonexe- >> << cutable. >> << >> << 14) A new receive option, SET RECEIVE EXPTAB, was >> << implemented. When set, it expands horizontal tabs >> << encountered in the data. >> << >> << 15) When in server mode and a FINISH packet was received >> << from the remote, Kermit would EOJ. Now Kermit drops >> << out of server mode and continues execution. >> << 16) Groups of files may be downloaded to the micro by >> << the use of the wildcard character in the GET statement>> << on the micro, eg GET MS@. Kermit3000 must be in >> << server mode. << >> <<*****************************************************************>> << >> << UNSCHEDULED FIX 12 FEB 86 TONY APPELGET >> << HELP function in the vicinity of SET RECEIVE PROG through >> << SET RECEIVE EXPTAB was not displaying properly and would >> << take the program down on occasion. Fixed it. >> << >> << UNSCHEDULED MODS FEB/MAR 87 TONY APPELGET >> << 1. Added capability to generate and check 3-byte CRC >> << block checking in anticipation of being able to handle >> << long packets. This Kermit will always attempt to use >> << the 3-byte CRC unless negotiated down to 1-byte simple >> << checksum by the other end. Capability to handle 2-byte>> << checksum will be deferred forever or until necessary, >> << whichever comes first. >> << >> << 2) Fixed another bug that a casual user might never >> << encounter. If a file had been sent, received, or >> << typed in non-server mode, and then the user attempted >> << to upload a file in server mode, the previously speci- >> << fied title, not the currently specified title, was >> << used to store the file. >> << >> << 3) If this Kermit was in server mode, and the user keyed >> << 'GET filename1 filename2', the protocol became very >> << confused and died a nasty death. I fixed the problem. >> << >> << UNSCHEDULED FIX 10 SEPT 87 TONY APPELGET >> << SENDSW always seemed to complain about a SEND failure >> << regardless of the success or failure of a file trans- >> << mission. STATE was never being set to 'send complete >> << state' ("C"). Fixed it. >> << >> << UNSCHEDULED FIX 4 APRIL 88 TONY APPELGET >> << A failure to complete a handshake by SINIT caused >> << subsequent attempts of send initiate to fail. This >> << fix sets the retry counter to zero before attempting >> << a send initiate. >> << The above unscheduled fixes made legal via SSR 91-557 >> << 29 APRIL 88 TONY APPELGET >> <<*****************************************************************>> << UNSCHEDULED FIX 8 SEPT 88 TONY APPELGET >> << An attempt to communicate with a Kermit that did not >> << specify any block check as part of SINIT caused this >> << Kermit to use its default 3-byte CRC block check, causing>> << the other Kermit to go bonkers over all packets. This >> << fix causes this Kermit to default to 1-byte block check >> << when the other Kermit does not specify any block check. >> <<*************************************************************** >> << >> << GENERAL UPGRADE APRIL - OCT 89 TONY APPELGET (91-608) >> << >> << Bring program up to snuff with newer releases of PC and >> << IBM Kermits. >> << >> << 1. Add QUIT as synonym for EXIT. >> << >> << 2. Changed 3-byte CRC calculation from table-lookup >> << to strictly computational. (Purloined from PC module >> << MSSCOM.ASM.) >> << >> << 2. Kermit now sets a JCW, KRMJCWnn where nn is the comm >> << ldev, to indicate what he is doing or how an xfer was >> << completed. >> << >> << 3. Procedure WRITE'LOG was added to manage the writing >> << of packets to the log file. The time is given for >> << each packet and long packets are broken up into line- >> << sized hunks. >> << >> << 4. Long packets are implemented. Maximum size now is >> << 2048 bytes. See "Kermit Protocol Manual" for the >> << long packet format, especially as to how packet length>> << is handled. >> << >> << 5. STATUS displays of logical values has been changed >> << from TRUE/FALSE to ON/OFF to correspond with keyins. >> << >> << 6. A statement: LOGNUM:=CONUM was deleted from proce- >> << dure KINIT. Presence of that statement caused the log>> << output to be written to STDLIST when Kermit was run >> << from a job. >> << >> << 7. SET LOG PURGE will now cause an open log file to be >> << closed and purged if the user has changed his mind >> << about retaining a log file. >> << >> << 8. A brief PAUSE was inserted as part of the DELETE >> << command. Apparently the COMMAND intrinsic returns >> << before a PURGE is completed, and a subsequent LISTF, >> << if initiated very rapidly from a TAKE file, finds the >> << file still present. Easy, but PAUSEs are kludges. >> << >> << >> <<*****************************************************************>> << >> << UNSCHEDULED FIX TONY APPELGET 8 DEC 89 >> << >> << After receiving a file, an SINIT packet to send a file >> << had the packet number of the BREAK packet from the previous>> << file reception. Many PC Kermits will apparently pick up >> << this packet number and procede. I encountered one that >> << didn't, though. Since the protocol manual says SINIT >> << packets be numbered zero, this Kermit now does it. >> << >> <<*****************************************************************>> << >> << SSR 91-634 Tony Appelget July-August 1990 >> << >> << Imagine a situation where this Kermit is running as a son >> << process along with other programs. Suppose that while >> << this Kermit is interrogating JCW to determine if a TAKE >> << file is to be opened, one of the other processes blows up >> << and sets JCW via a QUIT(n). Well, it happened and Kermit >> << picked up a bad value which caused the whole process struc->> << ture to grind to a halt. This patch causes this Kermit to >> << check the PARAM value first, and if it is non-zero, use it >> << to set up the TAKE file title. If PARAM=0, and JCW<>0, >> << the JCW value will be used to set the TAKE file title. This>> << procedure maintains compatability with previous versions. >> << >> << Packet receives are now nearly transparent, eg NULs may >> << be received and even used as start-of-packet chars. The >> << reason for the change is to troubleshoot the WMS link at >> << WCA. >> << >> <<*****************************************************************>> << >> << UNSCHEDULED FIX Tony Appelget 15 Oct 90 >> << >> << Modified procedure RPACK to indicate what sort of error >> << occurred: 1=Timeout 3=No SOH found 5=Length bad >> << 7=Bad checksum 9=Long packet not data type >> << The only routine using the results is RINIT, and it only >> << checks for lack of SOH(3). Perhaps that junky Unix Kermit>> << on the Compaq at West Chicago will quit giving us fits. >> << >> <<*****************************************************************>> << >> << UNSCHEDULED FIX Tony Appelget 13 Nov 90 >> << >> << Implemented the server command BYE to make this Kermit >> << compatible with IBM Kermit. The BYE command blows away the >> << program, session, connection, everything. It is devastating.>> << >> << Also fixed up the FCLOSEs on LOGNUM so that the log files >> << can be deleted by other than the creator. >> << >> <<*****************************************************************>> << >> << UNSCHEDULED FIX Tony Appelget 27 Dec 90 >> << >> << The West Chicago WMS system bombed trying to purge a file >> << that had just been sent. This program still had the file >> << open. Juggled code so that file is closed before xfer com- >> << plete JCW is set. >> << >> <<*****************************************************************>> << SSR 91-652 Tony Appelget 15 Feb 91 >> << Added a new SET option, FAST. It's syntax and operation >> << are described in the HELP function. It was implemented due >> << to compaints by users of the Warehouse Management System >> << that transaction transmissions were slow and transactions >> << were backing up badly. Only INIT and FHEADER packets are >> << affected, both send and receive. >> << >> << While I had my fingers in the works, I added a PAUSE before >> << the ABORTSESS in server's bye function so that the ack to >> << the bye could make it out of the machine and to the remote >> << Kermit (on PC) before the session was blown away. >> << >> << I also noticed that, with 2000-byte packets, that a full- >> << sized data packet could not be received at 1800 baud or >> << less. It got caught in the 10-second timeout. Made the >> << timeout for data packet reception dependent on the line >> << speed. >> << >> <<*************************************************************** >> << >> << UNSCHEDULED FIX TONY APPELGET MAY 1991 >> << >> << Changed RFILE of RECSW to echo the assigned HP file title >> << rather than the PC file title. Purely a cosmetic change >> << since PC Kermit 3.01 displays what it found in the ACK to >> << file header. >> << >> <<**************************************************************** >> << UNSCHEDULED FIX TONY APPELGET JULY 1991 >> << >> << Changed the method of line speed determination from >> << FCONTROL 10 to FCONTROL 40. FCONTROL 10 had problems on >> << XL machine. Put in sensor to determine which type of >> << machine the program is running so that default termtype >> << would be 10 on XL machine and 13 on classic machine. Moved >> << FCONTROL 13 (disable echo) from preceding the termtype set >> << statement to after it so that termtype 18, if used, does >> << echo. >> << >> << UNSCHEDULED FIX TONY APPELGET FEB 1992 >> << >> << SET RECEIVE FIXREC ? (help) did not allow subsequent setting>> << of ON or OFF. I uncovered this problem while working on the>> << C translation and suspect it has been in place for 7 years. >> << Fixed it both here and in the C translation. >> << >> equate DBUF'WORDSIZE = 1024, DBUF'BYTESIZE = DBUF'WORDSIZE*2, LBUF'WORDSIZE = 1024, LBUF'BYTESIZE = LBUF'WORDSIZE*2, MAX'RCV'SIZE = 94, MAX'LONGPACK'SIZE=2047, DFLT'MAXTRY = 10, << Normal retry count >> DFLT'TO = 10, << Normal timeout >> FAST'MAXTRY = 5, FAST'TO = 2, CR = %15, LF = %12, XON = %21, EOT = %4, SP = %40, HTAB= %11, A'DEL = %177; << Configurable Parameters >> equate P'Q'8 = %46, << Prefered 8 Bit Quote >> P'RPT'CHR = %176; << Prefered Repeat Prefix >> define LONGP'F = 14:15:1#, WINDOWS'F = 13:15:1#, ATTRS'F = 12:15:1#; logical USE'DC1 := true, QUOTE'8 := false, USE'REPEAT := false, EXP'TABS := false, IMAGE := false; integer PAUSE'CNT := 0, YOUR'PAD := 0, YOUR'PAD'COUNT := 0, MAX'SND'SIZE := MAX'RCV'SIZE, MAX'SND'DATA := MAX'RCV'SIZE, LONGPACK'SIZE, YOUR'EOL := CR, MY'EOL := CR, MY'Q'CTL := %43, YOUR'Q'CTL := %43, Q'8 := P'Q'8, RPT'CHR := P'RPT'CHR, MY'TO := DFLT'TO, YOUR'TO := 10, MAXTRY := DFLT'MAXTRY; byte MY'CAPS, YOUR'CAPS; DEFINE <<FOR USER INPUT SCANNER>> << FIRST WORD OF USER COMMAND STUFF >> NULLV = 0#, TAKEV = 1#, TAKESZ = 4#, TAKESZSZ = 7#, SENDV = 2#, SENDSZ = 4#, SENDSZSZ = 7#, RECEIVEV = 3#, RECEIVESZ = 7#, RECEIVESZSZ = 10#, SERVEV = 4#, SERVESZ = 6#, SERVESZSZ = 9#, SETV = 5#, SETSZ = 3#, SETSZSZ = 6#, EXITV = 6#, EXITSZ = 4#, EXITSZSZ = 7#, QUITV = 6#, QUITSZ = 4#, QUITSZSZ = 7#, DIRV = 7#, DIRSZ = 3#, DIRSZSZ = 6#, SPACEV = 8#, SPACESZ = 5#, SPACESZSZ = 8#, DELETEV = 9#, DELETESZ = 6#, DELETESZSZ = 9#, TYPEV = 10#, TYPESZ = 4#, TYPESZSZ = 7#, VERIFYV = 11#, VERIFYSZ = 6#, VERIFYSZSZ = 9#, STATUSV = 11#, STATUSSZ = 6#, STATUSSZSZ = 9#, << SECOND WORD OF USER COMMAND STUFF >> DEBUGV = 20#, DEBUGSZ = 5#, DEBUGSZSZ = 8#, DELAYV = 21#, DELAYSZ = 5#, DELAYSZSZ = 8#, LINEV = 22#, LINESZ = 4#, LINESZSZ = 7#, SENDV'1 = 23#, SPEEDV = 24#, SPEEDSZ = 5#, SPEEDSZSZ = 8#, HANDSHAKEV = 25#, HANDSHAKESZ = 9#, HANDSHAKESZSZ = 12#, RECEIVEV'1 = 26#, LOGV = 27#, LOGSZ = 3#, LOGSZSZ = 6#, SOHV = 28#, SOHSZ = 3#, SOHSZSZ = 6#, FASTV = 29#, FASTSZ = 4#, FASTSZSZ = 7#, << THIRD WORD OF USER COMMAND STUFF >> PAUSEV = 30#, PAUSESZ = 5#, PAUSESZSZ = 8#, BINARYV = 31#, BINARYSZ = 6#, BINARYSZSZ = 9#, DEVICEV = 32#, DEVICESZ = 6#, DEVICESZSZ = 9#, FCODEV = 33#, FCODESZ = 5#, FCODESZSZ = 8#, RECLENV = 34#, RECLENSZ = 6#, RECLENSZSZ = 9#, BLOCKFV = 35#, BLOCKFSZ = 6#, BLOCKFSZSZ = 9#, FIXRECV = 36#, FIXRECSZ = 6#, FIXRECSZSZ = 9#, MAXRECV = 37#, MAXRECSZ = 6#, MAXRECSZSZ = 9#, MAXEXTV = 38#, MAXEXTSZ = 6#, MAXEXTSZSZ = 9#, SAVESPV = 39#, SAVESPSZ = 6#, SAVESPSZSZ = 9#, PROGV = 40#, PROGSZ = 4#, PROGSZSZ = 7#, BIN128V = 41#, BIN128SZ = 6#, BIN128SZSZ = 9#, TEXTV = 42#, TEXTSZ = 4#, TEXTSZSZ = 7#, TXT80V = 43#, TXT80SZ = 5#, TXT80SZSZ = 8#, EXPTABV = 44#, EXPTABSZ = 6#, EXPTABSZSZ = 9#, PURGEV = 45#, PURGESZ = 5#, PURGESZSZ = 8#, AUTOV = 50#, AUTOSZ = 4#, AUTOSZSZ = 7#, << FOURTH WORD OF USER COMMAND STUFF >> ONV = 51#, ONSZ = 2#, ONSZSZ = 5#, OFFV = 52#, OFFSZ = 3#, OFFSZSZ = 6#, NONEV = 53#, NONESZ = 4#, NONESZSZ = 7#, XONV = 54#, XONSZ = 3#, XONSZSZ = 6#, XON2V = 55#, XON2SZ = 4#, XON2SZSZ = 7#, YESV = 56#, YESSZ = 3#, YESSZSZ = 6#, << QUESTION MARK ANYWHERE FOR HELP >> QMARKV = 60#, QMARKSZ = 1#, QMARKSZSZ = 4#, NUMBERV = 61#, NOMORE = NUTTIN#; BYTE ARRAY RESWDS(0:379):= << Should be sum of SZSZ stuff above >> 1( TAKESZSZ, TAKESZ, "TAKE", TAKEV, SERVESZSZ, SERVESZ, "SERVER", SERVEV, SENDSZSZ, SENDSZ, "SEND", SENDV, RECEIVESZSZ, RECEIVESZ, "RECEIVE", RECEIVEV, SETSZSZ, SETSZ, "SET", SETV, EXITSZSZ, EXITSZ, "EXIT", EXITV, QUITSZSZ, QUITSZ, "QUIT", EXITV, DIRSZSZ, DIRSZ, "DIR", DIRV, SPACESZSZ, SPACESZ, "SPACE", SPACEV, DELETESZSZ, DELETESZ, "DELETE", DELETEV, TYPESZSZ, TYPESZ, "TYPE", TYPEV, VERIFYSZSZ, VERIFYSZ, "VERIFY", VERIFYV, STATUSSZSZ, STATUSSZ, "STATUS", STATUSV, DEBUGSZSZ, DEBUGSZ, "DEBUG", DEBUGV, LOGSZSZ, LOGSZ, "LOG", LOGV, HANDSHAKESZSZ, HANDSHAKESZ, "HANDSHAKE", HANDSHAKEV, LINESZSZ, LINESZ, "LINE", LINEV, SPEEDSZSZ, SPEEDSZ, "SPEED", SPEEDV, DELAYSZSZ, DELAYSZ, "DELAY", DELAYV, SOHSZSZ, SOHSZ, "SOH", SOHV, SENDSZSZ, SENDSZ, "SEND", SENDV'1, RECEIVESZSZ, RECEIVESZ, "RECEIVE", RECEIVEV'1, FASTSZSZ, FASTSZ, "FAST", FASTV, PAUSESZSZ, PAUSESZ, "PAUSE", PAUSEV, BINARYSZSZ, BINARYSZ, "BINARY", BINARYV, DEVICESZSZ, DEVICESZ, "DEVICE", DEVICEV, FCODESZSZ, FCODESZ, "FCODE", FCODEV, RECLENSZSZ, RECLENSZ, "RECLEN", RECLENV, BLOCKFSZSZ, BLOCKFSZ, "BLOCKF", BLOCKFV, FIXRECSZSZ, FIXRECSZ, "FIXREC", FIXRECV, MAXRECSZSZ, MAXRECSZ, "MAXREC", MAXRECV, MAXEXTSZSZ, MAXEXTSZ, "MAXEXT", MAXEXTV, SAVESPSZSZ, SAVESPSZ, "SAVESP", SAVESPV, PROGSZSZ, PROGSZ, "PROG", PROGV, BIN128SZSZ, BIN128SZ, "BIN128", BIN128V, TEXTSZSZ, TEXTSZ, "TEXT", TEXTV, TXT80SZSZ, TXT80SZ, "TXT80", TXT80V, EXPTABSZSZ, EXPTABSZ, "EXPTAB", EXPTABV, PURGESZSZ, PURGESZ, "PURGE", PURGEV, AUTOSZSZ, AUTOSZ, "AUTO", AUTOV, ONSZSZ, ONSZ, "ON", ONV, OFFSZSZ, OFFSZ, "OFF", OFFV, NONESZSZ, NONESZ, "NONE", NONEV, XONSZSZ, XONSZ, "XON", XONV, XON2SZSZ, XON2SZ, "XON2", XON2V, YESSZSZ, YESSZ, "YES", YESV, QMARKSZSZ, QMARKSZ, "?", QMARKV, 0, 0, 0, 0 ); <<*****************************************************************>> << >> << Parameters that are changed via the SET command >> << >> <<*****************************************************************>> logical RCV'BINARY := false, << Binary if true >> RCV'FIXREC := true, << Fixed records if true >> RCV'SAVESP := true, << Release unused space >> IMPATIENT := false; << Short timeouts >> integer RCV'FCODE := 0, << File code >> RCV'RECLEN := -80, << Record Length >> RCV'BLOCKF := 16, << Blocking Factor >> RCV'MAXEXT := 32; << Max Extents >> double RCV'MAXREC := 5000d; << Max Records >> byte array RCV'DEV(0:15) := << Device Type >> "DISC "; integer SND'BINARY := 0; << Send Mode: 0 = Auto >> << 1 = Binary >> << 2 = ASCII >> integer HNDSHK := 1, << Handshake: 0 = None >> << 1 = XON >> << 2 = XON2 >> DEBUG'MODE := 0, << Debug Mode >> TSPEED := 0, << Line Speed (CPS) >> LDEV'LINE := 0; << Line LDEV >> byte SOH := %1, << Begin-packet character >> MY'BLK'CK := "3", YOUR'BLK'CK := "3"; integer array MIN'SIZE(0:59):=60(32767);<< Used by input scanner to ensure unique abbreviated keywords >> <<*****************************************************************>> << Buffers and etc. >> integer LNUM := 0, << Line File number >> DNUM := 0, << Disc file number >> CINUM := 0, << CI Input >> CONUM := 0, << CI Output >> VNUM := 0, << Validation file >> TAKENUM:= 0, << TAKE File Number >> LOGNUM := 0; << Log Output >> logical array W'DBUF(0:DBUF'WORDSIZE), W'LBUF(0:LBUF'WORDSIZE); byte array DBUF(*) = W'DBUF, LBUF(*) = W'LBUF; integer DBUFCNT, << Disc buffer byte count >> DBUF'RMAX, << Receive Max Buf size >> DBUFINX, << Disc buffer index >> LBUFCNT; << Line buffer count >> byte array PDATA(0:MAX'LONGPACK'SIZE); << Outgoing pkt data >> integer PDATACNT; byte array RP'DATA(0:MAX'LONGPACK'SIZE); << Rcv (data) buf>> byte RP; << Response type >> integer RP'LEN, << Length of response data >> RP'NUM; << Packet number of response >> logical array PBUF'W(0:79); << PRINT buffer >> byte array PBUF(*) = PBUF'W; integer PLEN; byte array L'FNAME(0:37), << Local file name >> R'FNAME(0:37), << Remote file name >> LOGNAME(0:35); << Current log file name >> integer L'FNAME'LEN, << Length of Name >> R'FNAME'LEN, << Length of Name >> LOGNAME'LEN; << Length of log file name >> logical array IB'W(0:39); << Input Buffer >> byte array IB(*) = IB'W; integer ILEN; << Length of Current IB >> << Misc >> byte STATE, << Current state >> Q8'IND; << Receive Q8 flag >> integer N := 0, << Current packet number >> NUMTRY, << Current "try" number >> OLDTRY; << Previous "try" number >> byte array KT'NAME(0:31); << Temp file name >> integer KTN'LEN; << Length of KT'NAME >> logical HAVE'KTEMP, << True if temp file exists >> DBUF'WRITTEN:=false, << Prevent LF from forcing disc write after write from full buffer >> CTLY := false; << True if CONTROL-Y >> array VALID'TITLE'W(0:11) := 17973, 14649, 22092, 18756, 12118, 16716, 18756, 16724, 17710, 20565, 16928, 0; byte array VALID'TITLE(*) = VALID'TITLE'W; byte array MYSELF(0:7); integer ERROR, << For COMMAND int >> PARM; << ditto >> byte array KERM'JCW(0:9) := 1("KRMJCW00", 0,0); integer MY'JCW'VAL, JCW'ERR; define IDLING = 0#, SENDING = 1#, RECVING = 2#, SEND'OK = 16+SENDING#, RECV'OK = 16+RECVING#, SEND'NG = 256+SENDING#, RECV'NG = 256+RECVING#; define E'ST = if LOGNUM <> 0 then begin move PBUF := #, E'EN = ,2; PLEN := TOS - @PBUF; FWRITE(LOGNUM,PBUF'W,-PLEN,0); end #, M'ST = move PBUF := #, M'EN = ,2; PLEN := TOS - @PBUF; FWRITE(CONUM,PBUF'W,-PLEN,0) #, FLUSH'DBUF = begin FWRITE(DNUM,W'DBUF,-DBUFINX,0); DBUFINX := 0; end #, KTEMP'NAME = "KMTTEMP" #, RPACK'PACK = 1#, SPACK'PACK = 2#; equate IN = 0, OUT = 1, IO = 2; <<****************************************************************>> byte pointer INFO'STR = Q - 5; integer INFO'LEN = Q - 6, PARM'VAL = Q - 4, TAKE'VAL; integer TTYPE := 13, << Terminal type >> LDEV'CI := 0, << Command ldev >> ORGL'TTYPE, << Orig TTYPE >> ORGL'TISPEED, << Orig I speed >> ORGL'TOSPEED, << Orig O speed >> ORGL'ECHO, << 0=off, 1=on >> DFLT'TTYPE; << 10=HPPA, 13=Classic machines >> integer I'DELAY := 10; << Initial Pause Duration >> <<****************************************************************>> intrinsic FOPEN, FCLOSE, FSETMODE, FREAD, FWRITE, FCONTROL, FGETINFO, PRINT, FCHECK, FERRMSG, << For debugging only >> PRINTFILEINFO, PRINT'FILE'INFO, << ditto >> FPOINT, GETJCW, PUTJCW, BINARY, DBINARY, ASCII, DASCII, WHO, JOBINFO, PAUSE, CLOCK, COMMAND, XCONTRAP, RESETCONTROL, QUIT, ABORTSESS; $PAGE "Low Level Procedures" $control segment=WORKER byte procedure TOCHAR(CHR); value CHR ; integer CHR ; begin TOCHAR := byte(CHR + SP); end; <<****************************************************************>> integer procedure UNCHAR(CHR); value CHR ; byte CHR ; begin UNCHAR := integer(CHR) - SP; end; <<****************************************************************>> integer procedure CTL(CHR); value CHR ; integer CHR ; begin CTL := integer(logical(CHR) xor %100); end; <<****************************************************************>> integer procedure NPNO(PNO); value PNO ; integer PNO ; begin NPNO := (PNO + 1) mod 64; end; <<*****************************************************************>> integer procedure PPNO(PNO); value PNO ; integer PNO ; begin if PNO = 0 then PPNO := 63 else PPNO := PNO - 1; end; <<*****************************************************************>> $control segment=CONTROLY'S procedure CONTROLY; begin logical N = Q + 1; CTLY := true; TOS := %31400 lor (N land %377); RESETCONTROL; assemble(XEQ 0); end; <<*****************************************************************>> $control segment=WORKER $PAGE "CALCULATE'CRC - Three-byte checksum" logical procedure CALCULATE'CRC(PKT, LEN); value LEN; integer LEN; byte array PKT; begin << Copied from the IBM-PC CRC calulator in module MSSCOM.ASM >> << and modified for better efficiency in this environment. AX >> << and BX were the original PC registers and the nomenclature >> << was retained for want of better identifiers. >> logical AX, DX:=0; define AH = AX.(0:8)#, AL = AX.(8:8)#, DH = DX.(0:8)#, DL = DX.(8:8)#; integer I := 1; do begin AH := PKT(I); DL := DL XOR AH; AH := (DL & LSL(4)) XOR DL; AL := 0; DX := DH LOR AX; DL := DL XOR ((AX:= AX & LSR(4)).(0:8)); DX := DX XOR (AX & LSR(1)); end until ( I := I+1 ) > LEN; CALCULATE'CRC := DX; END; <<**************************************************************>> $PAGE "Write packets to log file" $control segment=LOGGER procedure WRITE'LOG(PACKET, LEN, WHO); value LEN, WHO; integer LEN, WHO; byte array PACKET; begin double HH'MM'SS'TT; logical HH'MM = HH'MM'SS'TT, SS'TT = HH'MM'SS'TT+1; define HH = HH'MM.(0:8)#, MM = HH'MM.(8:8)#, SS = SS'TT.(0:8)#, TT = SS'TT.(8:8)#; byte pointer PB; integer PB'L; << So we don't clobber PLEN >> if WHO = RPACK'PACK then MOVE PBUF := "RPACK: ", 2 else if WHO = SPACK'PACK then MOVE PBUF := "SPACK: ", 2 else MOVE PBUF := "?????? ", 2; @PB := TOS; HH'MM'SS'TT := CLOCK; @PB := @PB( ASCII(HH, 10, PB) ); PB := ":"; @PB := @PB( 1+ASCII(MM, 10, PB(1)) ); PB := ":"; @PB := @PB( 1+ASCII(SS, 10, PB(1)) ); PB := "."; @PB := @PB( 1+ASCII(TT, 10, PB(1)) ); MOVE PB := " (", 2; @PB := TOS; @PB := @PB( ASCII(LEN, 10, PB) ); PB := ")"; PB'L := @PB-@PBUF; FWRITE(LOGNUM, PBUF'W, -(PB'L+1), 0); move PBUF := " "; @PB := @PACKET; while LEN > 72 do begin move PBUF(7) := PB, (72); @PB := @PB(72); FWRITE(LOGNUM, PBUF'W, -79, 0); LEN := LEN-72; end; if LEN > 0 then begin move PBUF(7) := PB, (LEN); FWRITE(LOGNUM, PBUF'W, -(LEN+7), 0); end; end; <<*****************************************************************>> $PAGE "VALID'FILE - File access validator" $Control segment = VALID'FILE'S logical procedure VALID'FILE(VNAME, VNAME'LEN, ACCESS); value VNAME'LEN, ACCESS; byte array VNAME; integer VNAME'LEN, ACCESS; begin array LEGAL'FILE'W(0:39); byte array LEGAL'FILE(*) = LEGAL'FILE'W; define FILE'NAME = LEGAL'FILE#, IOPART = LEGAL'FILE(28)#, USERNAME = LEGAL'FILE(32)#; integer I:=0, J; label NEXT'READ, NEXT'CHAR, TITLE'OK; VALID'FILE := false; << Prepare for the worst >> VNAME(VNAME'LEN):=" ";<< In case caller didnt do it >> do begin << Upshift so we can use caps only in validation file >> move VNAME(I) := VNAME(I) while ANS, 1; I := TOS-@VNAME+1; end until I >= VNAME'LEN; if VNUM = 0 then begin VNUM := FOPEN(VALID'TITLE, 1, 0); if VNUM = 0 then begin VALID'FILE:=true; << no file says all files are legal >> return; end; end; do begin NEXT'READ: FREAD(VNUM, LEGAL'FILE'W, -80); if <> then begin FPOINT(VNUM, 0d); << Ready for next time >> return; end; if not (MYSELF = USERNAME, (8)) then go to NEXT'READ; if not (IOPART = "IO" lor ACCESS = IN land IOPART = "I " lor ACCESS = OUT land IOPART = "O ") then go to NEXT'READ; I:=J:=0; NEXT'CHAR: if VNAME(I) = "@" then begin << No wild chars permitted in title >> FPOINT(VNUM, 0d); return; end; if VNAME(I) = FILE'NAME(J) then begin if VNAME(I) = " " then go to TITLE'OK; I := I+1; J := J+1; if I >= VNAME'LEN then go to TITLE'OK; go to NEXT'CHAR; end else if FILE'NAME(J) = "@" then begin J := J+1; << Skip '@' in legal name >> do I := I+1 << Skip chars in test name >> until VNAME(I) = " " or VNAME(I) = "." or VNAME(I) = FILE'NAME(J) or I >= VNAME'LEN; go to NEXT'CHAR; end; end until false; FPOINT(VNUM, 0d); << I bet this is never executed >> return; TITLE'OK: FPOINT(VNUM, 0d); VALID'FILE := true; end; $PAGE "SPACK - Send A Packet" $control segment=WORKER procedure SPACK(TYP,NUM,LEN,DATA); value TYP,NUM,LEN ; byte TYP ; integer NUM,LEN ; byte array DATA ; begin logical R'ERROR := false, CHKSUM := 0; integer IX, OX := 1; real P'INT; <<----------------------------------------------------------->> subroutine XCK(CHR); value CHR ; byte CHR ; begin CHKSUM := (CHKSUM + logical(CHR)).(1:15); <<No overflows>> LBUF(OX) := CHR; OX := OX + 1; end; <<----------------------------------------------------------->> subroutine REGULAR'PACK; begin LBUF(0) := SOH; << Start with SOH >> OX := 1; if (STATE = "S") or << Then length >> (STATE = "R") or (YOUR'BLK'CK = "1") then XCK(TOCHAR(LEN+3)) else XCK(TOCHAR(LEN+5)); XCK(TOCHAR(NUM)); << Block number >> XCK(TYP); << Block type >> if LEN <> 0 then << Data if needed >> for IX := 0 step 1 until LEN -1 do XCK(DATA(IX)); if STATE = "S" or STATE = "R" or YOUR'BLK'CK = "1" then begin << Kermit primative checksum >> CHKSUM := (CHKSUM.(8:2) + CHKSUM.(10:6)).(10:6); LBUF(OX) := TOCHAR(CHKSUM); << Insert checksum >> OX := OX + 1; end else begin << Fancy 3-byte CRC >> CHKSUM := CALCULATE'CRC(LBUF, OX-1); LBUF(OX) := TOCHAR(CHKSUM.(0:4)); << First byte >> LBUF(OX:=OX+1) := TOCHAR(CHKSUM.(4:6)); << Second byte >> LBUF(OX:=OX+1) := TOCHAR(CHKSUM.(10:6)); << Third byte >> OX := OX + 1; end; end; <<------------------------------------------------------------->> subroutine LONG'PACK; begin LBUF(0) := SOH; XCK(TOCHAR(0)); <<Length=0 says this is long data packet>> XCK(TOCHAR(NUM)); <<Packet number>> XCK(TYP); <<Should be "D" only>> IX := LEN + integer(YOUR'BLK'CK-"0"); XCK(TOCHAR(IX / 95)); <<Length, most significant part>> XCK(TOCHAR(IX mod 95)); <<Length, least significant part>> XCK(TOCHAR( (CHKSUM.(8:2)+CHKSUM.(10:6)).(10:6) ));<<HDR BCC>> if YOUR'BLK'CK = "1" then begin for IX := 0 step 1 until LEN-1 do XCK(DATA(IX)); CHKSUM := (CHKSUM.(8:2)+CHKSUM.(10:6)).(10:6); LBUF(OX) := TOCHAR( CHKSUM ); end else begin << Fancy 3-byte CRC >> move LBUF(OX):=DATA, (LEN); OX := OX+LEN; CHKSUM := CALCULATE'CRC(LBUF, OX-1); LBUF(OX) := TOCHAR(CHKSUM.(0:4)); << First byte >> LBUF(OX:=OX+1) := TOCHAR(CHKSUM.(4:6)); << Second byte >> LBUF(OX:=OX+1) := TOCHAR(CHKSUM.(10:6)); << Third byte >> end; OX := OX+1; end; <<----------------------------------------------------------->> if (LEN > MAX'SND'DATA) and (TYP = "D") then LONG'PACK else REGULAR'PACK; if DEBUG'MODE > 0 and LOGNUM <> 0 then begin WRITE'LOG(LBUF, OX, SPACK'PACK); end; LBUF(OX) := YOUR'EOL; << Set end of line char >> OX := OX + 1; if PAUSE'CNT <> 0 then begin P'INT := real(PAUSE'CNT)/10.; PAUSE(P'INT); << Pause for turnaround >> end; FWRITE(LNUM,W'LBUF,-OX,%320); << Write the block >> IF = THEN BEGIN E'ST "SPACK: WRITE OK" E'EN END ELSE IF DEBUG'MODE<>0 AND LOGNUM<>0 THEN BEGIN FCHECK(LNUM, R'ERROR); MOVE PBUF:="WRITE ERROR ", 2; PLEN:=TOS-@PBUF; PLEN:=PLEN+ASCII(R'ERROR, 10, PBUF(PLEN)); WRITE'LOG(PBUF, PLEN, SPACK'PACK); END; end; <<****************************************************************>> $PAGE "RPACK - Recieve Packet" logical procedure RPACK(TYP,LEN,NUM,DATA); byte TYP ; integer LEN,NUM ; byte array DATA ; begin integer IX, << General Index >> PLEN; << Packet length >> logical R'ERROR := false, << Error Flag >> CCHKSUM, << Calculated checksum >> RCHKSUM, << Received checksum >> DONE := false; << Done Flag >> byte pointer PACKET; <<----------------------------------------------------------->> LBUF(0) := 0; move LBUF(1) := LBUF(0),(LBUF'BYTESIZE -1); FCONTROL(LNUM,04,MY'TO); << Set timeout interval >> LBUFCNT := FREAD(LNUM,W'LBUF,-LBUF'BYTESIZE); << Read buffer >> if <> then begin << Timeout >> FCHECK(LNUM, R'ERROR); if LOGNUM<>0 then begin move PBUF := "RPACK: FSERROR ", 2; PLEN:=TOS-@PBUF; PLEN:=PLEN+ASCII(R'ERROR, 10, PBUF(PLEN)); FWRITE(LOGNUM, PBUF'W, -PLEN, 0); end; R'ERROR:=1; end else begin << Have a packet >> if DEBUG'MODE > 0 and LOGNUM <> 0 then begin WRITE'LOG(LBUF, LBUFCNT, RPACK'PACK); end; IX := 0; while not (DONE lor R'ERROR) do begin << Look for SOH >> if LBUF(IX) = SOH then begin DONE := true; end else begin IX := IX + 1; if IX > (LBUFCNT - 4) then begin << SOH not found >> R'ERROR := 3; E'ST "RPACK - SOH not found" E'EN; end; << No SOH >> end; << Not SOH >> end; << while >> end; << Have a packet >> if R'ERROR then begin RPACK := not(R'ERROR); return; end; << Something in the buffer that starts with SOH. >> << Let's see if everything else looks good. >> @PACKET := @LBUF(IX); << Address packet >> PLEN := UNCHAR(PACKET(1)); if PLEN > 0 then begin << Regular packets >> PLEN := PLEN+2; if (IX + PLEN > LBUFCNT) or (PLEN > MAX'RCV'SIZE + 2) or (PLEN < 5) then begin << Length is not reasonable >> R'ERROR := 5; E'ST "RPACK - Invalid length" E'EN; end else begin << Length OK >> if STATE = "S" or STATE = "R" or YOUR'BLK'CK = "1" then begin << Kermit primative checksum >> CCHKSUM := 0; for IX := PLEN-2 step -1 until 1 do CCHKSUM := CCHKSUM + logical(PACKET(IX)); CCHKSUM := (CCHKSUM.(8:2) + CCHKSUM.(10:6)).(10:6); CCHKSUM := logical(TOCHAR(CCHKSUM)); RCHKSUM := logical(PACKET(PLEN-1)); end else begin CCHKSUM := CALCULATE'CRC(PACKET, PLEN-4); RCHKSUM := UNCHAR(PACKET(PLEN-1)) << (10:10:6) >> cat UNCHAR(PACKET(PLEN-2)) (4:10:6) cat UNCHAR(PACKET(PLEN-3)) (0:12:4); PLEN := PLEN-2; end; if CCHKSUM <> RCHKSUM then begin << Bad checksum >> R'ERROR := 7; E'ST "RPACK - CHKSUM Error" E'EN; end; end; end else begin << Long packets >> PLEN := 95*UNCHAR(PACKET(4)) + UNCHAR(PACKET(5)); if (PLEN > LBUFCNT) or (PLEN > LONGPACK'SIZE+10) then begin R'ERROR := 5; E'ST "RPACK - Invalid longpack length" E'EN; end else begin if PACKET(3) <> "D" then begin R'ERROR := 9; E'ST "RPACK - Longpack not data" E'EN; end else begin << Calculate header checksum >> CCHKSUM := 0; for IX := 1 step 1 until 5 do CCHKSUM := CCHKSUM + logical(PACKET(IX)); if (CCHKSUM.(8:2)+CCHKSUM.(10:6)).(10:6) <> logical(UNCHAR(PACKET(6))) then begin R'ERROR := 7; E'ST "RPACK - Header checksum error" E'EN; end else begin if YOUR'BLK'CK = "1" then begin for IX := 6 step 1 until PLEN-2+7 do CCHKSUM:=CCHKSUM+logical(PACKET(IX)); CCHKSUM := (CCHKSUM.(8:2)+CCHKSUM.(10:6)).(10:6); RCHKSUM := UNCHAR(PACKET(PLEN-1+7)); end else begin CCHKSUM := CALCULATE'CRC(PACKET, PLEN-4+7); RCHKSUM := UNCHAR(PACKET(PLEN-1+7)) cat UNCHAR(PACKET(PLEN-2+7))(4:10:6) cat UNCHAR(PACKET(PLEN-3+7))(0:12:4); ! PLEN := PLEN-2; end; if CCHKSUM <> RCHKSUM then begin R'ERROR := 7; E'ST "RPACK - Longpack checksum error" E'EN; end; end; end; end; end; if not R'ERROR then begin << Packet OK, return the needed info >> TYP := PACKET(3); NUM := UNCHAR(PACKET(2)); if UNCHAR( PACKET(1) ) <> 0 then move DATA := PACKET(4),(LEN:=PLEN-5) else move DATA := PACKET(7), (LEN:=PLEN-integer(YOUR'BLK'CK-"0")); RPACK := true; end else RPACK := not(R'ERROR); end; $PAGE "BUFILL - Fill Transmit Buffer" procedure BUFILL(DATA,CNT,STAT); byte array DATA ; integer CNT,STAT ; begin logical DONE := false; integer T, T7, INCLEN, RPT'CNT, IX, CLEFT, BUF'MAX; logical TRY'REPEAT; byte array INCBUF(0:5); << Intermediate Char Buf >> <<----------------------------------------------------------->> logical subroutine GETCHAR(CHR); integer CHR ; begin << Extract a char from the buffer and do not increment >> << the index. False is returned if EOF or some error >> << condition occurs (STAT is set accordingly). >> << >> << If the buffer index (DBUFINX) is equal to the count >> << (DBUFCNT) the buffer is empty. If in binary mode, >> << we simply get another record. Otherwise (ASCII) >> << we return EOL. In this case DBUFINX will equal >> << DBUFCNT + 1 the next time thru. >> GETCHAR := true; if not (DBUFINX < DBUFCNT) then begin << No data in buffer >> if IMAGE lor (DBUFINX > DBUFCNT) then begin << Fill up the buffer >> DBUFCNT := FREAD(DNUM,W'DBUF,-DBUF'BYTESIZE); if < then begin << Read error >> STAT := -1; E'ST "BUFILL - Disc read error" E'EN; GETCHAR := false; end else if > then begin << End of file >> GETCHAR := false; if CNT = 0 then STAT := 1; end else begin << Read went OK >> if not IMAGE then begin << Suppress trailing blanks >> DBUFINX := DBUFCNT -1; while DBUFINX > 0 and DBUF(DBUFINX) = " " do begin DBUFINX := DBUFINX - 1; end; DBUFCNT := DBUFINX + 1; end; DBUFINX := 0; <<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++>> << >> << WARNING: Zero length binary records will not be handled >> << properly. >> << >> <<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++>> if DBUFCNT > 0 then CHR := integer(DBUF(0)) else CHR := CR; end; end else begin << Return EOL >> CHR := CR; end; end << No data in buffer >> else begin CHR := integer(DBUF(DBUFINX)); end; end; <<----------------------------------------------------------->> subroutine PUTCHR(CHR); value CHR ; integer CHR ; begin INCBUF(INCLEN) := byte(CHR); INCLEN := INCLEN + 1; end; <<----------------------------------------------------------->> CNT := 0; STAT := 0; if LONGPACK'SIZE > MAX'SND'DATA then BUF'MAX := LONGPACK'SIZE else BUF'MAX := MAX'SND'DATA; CLEFT := BUF'MAX; << Compute room >> while not DONE do begin DONE := not GETCHAR(T); if not DONE then begin << Transfer the character to an intermediate buffer >> << (INCBUF). If a multi-character sequence is >> << generated, it is placed in INCBUF in reverse >> << order. The sequence is re-inverted later. >> T7 := T.(9:7); << Get low seven bits >> INCLEN := 0; TRY'REPEAT := USE'REPEAT; if (T7 = CR) and (not IMAGE) then begin << Generate end-of-line sequence >> TRY'REPEAT := false; PUTCHR(CTL(LF)); PUTCHR(MY'Q'CTL); PUTCHR(CTL(CR)); PUTCHR(MY'Q'CTL); end else begin if T7 < SP or T7 = A'DEL then begin << Control char >> if QUOTE'8 then PUTCHR(CTL(T7)) else PUTCHR(CTL(T)); PUTCHR(MY'Q'CTL); end else if (T7 = MY'Q'CTL) lor (QUOTE'8 land T7 = Q'8) lor (USE'REPEAT land T7 = RPT'CHR) then begin << Quote a not-control char >> if QUOTE'8 then PUTCHR(T7) else PUTCHR(T); PUTCHR(MY'Q'CTL); end else begin << Regular char >> if QUOTE'8 then PUTCHR(T7) else PUTCHR(T); end; if QUOTE'8 land (T <> T7) then PUTCHR(Q'8); end; << The single char sequence has been generated. >> << Continue if it will fit in the buffer. >> if INCLEN > CLEFT then begin << It won't fit >> DONE := true; end else begin << Accepted >> DBUFINX := DBUFINX +1; if TRY'REPEAT land (CLEFT - INCLEN >= 2) then begin << OK, now we do repeat processing. >> << Count the adjacent occurences. >> IX := DBUFINX; while (IX < DBUFCNT) and (integer(DBUF(IX)) = T) do begin IX := IX +1; end; RPT'CNT := IX - DBUFINX + 1; if RPT'CNT > 94 then RPT'CNT := 94; << Use the repeat count only if it >> << saves space in the buffer. >> if (INCLEN +2) < (INCLEN * RPT'CNT) then begin << Use repeat >> PUTCHR(integer(TOCHAR(RPT'CNT))); PUTCHR(RPT'CHR); DBUFINX := DBUFINX + RPT'CNT - 1; end; end; << Transfer to the buffer >> while INCLEN > 0 do begin INCLEN := INCLEN - 1; DATA(CNT) := INCBUF(INCLEN); CNT := CNT + 1; end; CLEFT := BUF'MAX - CNT; if CLEFT <= 0 then DONE := true; end; end; end; end; $PAGE "BUFEMP - Empty Line Buffer" procedure BUFEMP(DATA,CNT); byte array DATA ; integer CNT ; begin integer I := 0, RPT'CNT, T, T'HI, T7; <<---------------------------------------------------------------->> subroutine NCHAR; begin T := integer(DATA(I)); T7 := T.(9:7); I := I + 1; end; <<---------------------------------------------------------------->> while I < CNT do begin T'HI := 0; << Hold high bit here if quote 8 >> RPT'CNT := 1; NCHAR; if USE'REPEAT land (T7 = RPT'CHR) then begin << Process repeat >> NCHAR; RPT'CNT := UNCHAR(byte(T7)); NCHAR; end; if QUOTE'8 land (T7 = Q'8) then begin T'HI := 128; NCHAR; end; if T7 = YOUR'Q'CTL then begin NCHAR; if T7 >= %77 and T7 <= %137 then T := CTL(T); T7 := T.(9:7); end; if QUOTE'8 then T := T'HI + T7; << Got the real character >> if (not IMAGE) land T7 = CR then RPT'CNT := 0; << Throw away CR >> if EXP'TABS and T7=HTAB then begin RPT'CNT:=8*RPT'CNT - (DBUFINX mod 8); T:=" "; end; << Transfer to disc buffer >> while RPT'CNT > 0 do begin RPT'CNT := RPT'CNT - 1; if (not IMAGE) land (T7 = LF) then begin if DBUF'WRITTEN then begin DBUF'WRITTEN := false; if DBUFINX > 0 then FLUSH'DBUF; end else FLUSH'DBUF; end else begin DBUF(DBUFINX) := byte(T); DBUFINX := DBUFINX + 1; if DBUFINX >= DBUF'RMAX then begin FLUSH'DBUF; DBUF'WRITTEN := true; end; end; end; end; end; $PAGE "CBUFXLT - Translate Command Buffer" $control segment=CBUFXLT'S logical procedure CBUFXLT(IDATA,ICNT,ODATA,OCNT,OMAX); value ICNT, OMAX ; byte array IDATA, ODATA ; integer ICNT, OCNT,OMAX ; begin integer I := 0, RPT'CNT, T, T'HI, T7; <<---------------------------------------------------------------->> subroutine NCHAR; begin T := integer(IDATA(I)); T7 := T.(9:7); I := I + 1; end; <<---------------------------------------------------------------->> OCNT := 0; CBUFXLT := true; while I < ICNT do begin T'HI := 0; << Hold high bit here if quote 8 >> RPT'CNT := 1; NCHAR; if USE'REPEAT land (T7 = RPT'CHR) then begin << Process repeat >> NCHAR; RPT'CNT := UNCHAR(byte(T7)); NCHAR; end; if QUOTE'8 land (T7 = Q'8) then begin T'HI := 128; NCHAR; end; if T7 = YOUR'Q'CTL then begin NCHAR; if T7 >= %77 and T7 <= %137 then T := CTL(T); T7 := T.(9:7); end; if QUOTE'8 then T := T'HI + T7; << Got the real character >> << Transfer to output buffer >> while RPT'CNT > 0 do begin RPT'CNT := RPT'CNT - 1; ODATA(OCNT) := byte(T); OCNT := OCNT + 1; if OCNT >= OMAX then begin I := 0; CBUFXLT := false; end; end; end; end; $PAGE "UNQFNAME - Check For Unique File Name" $control segment=UNQFNAME'S logical procedure UNQFNAME(FNAME,LEN); value LEN ; integer LEN ; byte array FNAME ; begin byte array BA'TEMP(0:37); integer I'ERR, I'PARM; <<---------------------------------------------------------->> move BA'TEMP := "listf "; move BA'TEMP(6) := FNAME,(LEN); move BA'TEMP(6+LEN) := ";$NULL"; BA'TEMP(12 + LEN) := %15; COMMAND(BA'TEMP,I'ERR,I'PARM); if I'ERR = 907 then UNQFNAME := true else UNQFNAME := false; end; $PAGE "MAKE'U'FNAME - Make a Unique File Name" $control segment=MAKE'U'FNAME'S logical procedure MAKE'U'FNAME(FNAME,LEN); byte array FNAME ; integer LEN ; begin integer FIX, << From Index >> TIX, << To Index >> ITEMP, << Scratch >> BLEN; << Base Length >> logical ALPH, << Char Alpha >> NUM, << Char is Num >> DONE; << Loop Flag >> <<---------------------------------------------------------->> FIX := 0; TIX := 0; while FIX < LEN do begin ITEMP := integer(FNAME(FIX)); if ITEMP >= %141 <<a>> and ITEMP <= %172 <<z>> then ITEMP := ITEMP - %40; ALPH := false; NUM := false; if ITEMP >= %101 <<A>> and ITEMP <= %132 <<Z>> then ALPH := true else if ITEMP >= %60 <<0>> and ITEMP <= %71 <<9>> then NUM := true; if (ALPH land (TIX = 0)) lor ((ALPH lor NUM) land (TIX > 0)) then begin FNAME(TIX) := byte(ITEMP); TIX := TIX + 1; end; FIX := FIX + 1; end; LEN := TIX; <<------------------------------------------------>> << File name now in native format. Adjust length. >> <<------------------------------------------------>> if LEN > 8 then LEN := 8 << Truncate >> else if LEN = 0 then begin << Nothing left, use default >> move FNAME := "KMT"; LEN := 3; end; <<---------------------------------------->> << File name is now OK , check uniqueness >> <<---------------------------------------->> if UNQFNAME(FNAME,LEN) then begin << OK, we're done >> MAKE'U'FNAME := true; end else begin << ---------------------------------------------->> << Append two numeric chars (00-99) to the name. >> <<----------------------------------------------->> BLEN := if LEN > 6 then 6 else LEN; ITEMP := 1; DONE := false; while (ITEMP < 99) land not DONE do begin FNAME(BLEN) := byte((ITEMP/10) + %60); FNAME(BLEN+1) := byte((ITEMP mod 10) + %60); LEN := BLEN + 2; if UNQFNAME(FNAME,LEN) then DONE := true else ITEMP := ITEMP + 1; end; MAKE'U'FNAME := not DONE; end; end; $PAGE "P'EPACK Print Error (E) Packet Data" $control segment=P'EPACK'S procedure P'EPACK(DATA,LEN); value LEN ; integer LEN ; byte array DATA ; begin logical pointer WUF; @WUF := @DATA & lsr(1); if LOGNUM <> 0 then FWRITE(LOGNUM,WUF,-LEN,0); end; $PAGE "SENDSW - Send Switch (Definitions)" $control segment=WORKER <<****************************************************************>> $PAGE "SBREAK - Send Break" byte procedure SBREAK; begin SBREAK := STATE; << Default is no change >> NUMTRY := NUMTRY + 1; if NUMTRY > MAXTRY then begin E'ST "SBREAK - Max retrys exceeded " E'EN; SBREAK := "A"; end else begin SPACK("B",N,0,RP'DATA); if RPACK(RP,RP'LEN,RP'NUM,RP'DATA) then begin if RP = "Y" then begin if RP'NUM = N then begin NUMTRY := 0; N := NPNO(N); SBREAK := "C"; end; end else if RP = "E" then begin E'ST "SBREAK - E packet recieved" E'EN; P'EPACK(RP'DATA,RP'LEN); SBREAK := "A"; end else if RP <> "N" then begin E'ST "SBREAK - Unknown packet type" E'EN; SBREAK := "A"; end; end; end; end; $PAGE "SENDSW - Packet Sender" logical procedure SENDSW(SFNAME,SFNLEN); value SFNLEN ; byte array SFNAME ; integer SFNLEN ; begin logical DONE := false, FOPT; integer BFSTAT, TEMP; $PAGE "SPAR - Set Up Send SI Parameters" subroutine SPAR(DATA,LEN); byte array DATA ; integer LEN ; begin DATA(0) := TOCHAR(MAX'RCV'SIZE); << Biggest to send me >> DATA(1) := TOCHAR(MY'TO); << When to time me out >> DATA(2) := TOCHAR(0); << How many pads I need >> DATA(3) := byte(CTL(0)); << Pad char to use for me >> DATA(4) := TOCHAR(CR); << End-of-line char for me >> DATA(5) := MY'Q'CTL; << Control quote I send >> DATA(6) := byte(P'Q'8); << Prefered 8 bit quote >> DATA(7) := MY'BLK'CK; << 3-char CRC default >> DATA(8) := byte(P'RPT'CHR); << Prefered repeat prefix >> DATA(9) := TOCHAR(MY'CAPS); << Extended capabilities >> DATA(10):= TOCHAR(0); << Windowing (none here) >> DATA(11):= TOCHAR(LONGPACK'SIZE / 95); << MAXL1 >> DATA(12):= TOCHAR(LONGPACK'SIZE MOD 95); << MAXL2 >> LEN := 13; end; <<----------------------------------------------------------->> $PAGE "RPAR - Set Up Send RI Parameters" subroutine RPAR(DATA,LEN); value LEN ; integer LEN ; byte array DATA ; begin MAX'SND'SIZE := UNCHAR(DATA(0)); << Max send size >> ! MAX'SND'DATA := MAX'SND'SIZE -3; << Max send data size >> YOUR'TO := UNCHAR(DATA(1)); << When I time you out >> YOUR'PAD'COUNT := UNCHAR(DATA(2));<< Number of pads to send >> YOUR'PAD := CTL(DATA(3)); << Your Pad char >> YOUR'EOL := UNCHAR(DATA(4)); << Your end-of-line >> YOUR'Q'CTL := integer(DATA(5)); << Your control quote >> QUOTE'8 := false; if LEN > 6 then begin if (DATA(6) = "Y") lor (integer(DATA(6)) = P'Q'8) then begin Q'8 := P'Q'8; QUOTE'8 := true; end; end; if LEN > 7 then YOUR'BLK'CK := DATA(7) else YOUR'BLK'CK := "1"; << No block check -> one-byte check >> if LEN > 8 and integer(DATA(8)) = P'RPT'CHR then begin RPT'CHR := P'RPT'CHR; USE'REPEAT := true; << OK for repeat prefix >> end else begin USE'REPEAT := false; << No repeat processing >> end; if LEN >= 12 then begin << Other side agrees to long packets, maybe >> YOUR'CAPS := byte( logical(UNCHAR(DATA(9))) land logical(MY'CAPS) ); << Windowing, DATA(10), is unsupported in this prog >> TEMP := 95*UNCHAR(DATA(11)) + UNCHAR(DATA(12)); if TEMP > MAX'SND'SIZE then begin if TEMP < MAX'LONGPACK'SIZE then LONGPACK'SIZE := TEMP-5-integer(YOUR'BLK'CK-"0") else LONGPACK'SIZE := MAX'LONGPACK'SIZE; end else LONGPACK'SIZE := 0; end else LONGPACK'SIZE := 0; << Long packets disallowed >> end; $PAGE "SINIT - Perform Send Init" byte subroutine SINIT; begin <<----------------------------------------------------------->> SINIT := STATE; << Default to return current state >> NUMTRY := NUMTRY + 1; if NUMTRY > MAXTRY then begin E'ST "SINIT - Max retrys exceeded" E'EN; SINIT := "A"; << Abort >> end else begin SPAR(RP'DATA,RP'LEN); << Set up SI data >> N := 0; << Start packets at zero >> SPACK("S",N,RP'LEN,RP'DATA); << And send it >> if RPACK(RP,RP'LEN,RP'NUM,RP'DATA) then begin if RP = "Y" then begin if RP'NUM = N then begin << Positive response >> RPAR(RP'DATA,RP'LEN); << Get parameters >> if YOUR'BLK'CK <> "1" and YOUR'BLK'CK <> "3" then begin << Whatever that was, I can't do it >> MY'BLK'CK := "1"; << Lets try again >> N := 0; SINIT := "S"; end else begin << OK, let's try it your way >> MY'BLK'CK := YOUR'BLK'CK; MAX'SND'DATA := MAX'SND'SIZE - 3-integer(YOUR'BLK'CK-"0"); NUMTRY := 0; N := NPNO(N); SINIT:= "F"; end; end; end else if RP = "E" then begin << Error packet >> E'ST "SINIT - E packet recieved" E'EN; P'EPACK(RP'DATA,RP'LEN); SINIT := "A"; end; end; end; end; $PAGE "SFILE - Send File Header" byte subroutine SFILE; begin <<----------------------------------------------------------->> SFILE := STATE; << Default to current state >> NUMTRY := NUMTRY + 1; if NUMTRY > MAXTRY then begin E'ST "SFILE - Max retrys exceeded" E'EN; SFILE := "A"; << Abort >> end else begin if SFNLEN = 0 then SPACK("X",N,0,SFNAME) << Header only >> else SPACK("F",N,SFNLEN,SFNAME); << Normal file >> if RPACK(RP,RP'LEN,RP'NUM,RP'DATA) then begin if RP = "Y" then begin if RP'NUM = N then begin DBUFCNT := 0; << Set disc buf empty >> DBUFINX := 1; << Index=get next >> BUFILL(PDATA,PDATACNT,BFSTAT); if BFSTAT = 0 then begin NUMTRY := 0; N := NPNO(N); SFILE := "D"; end else begin E'ST "SFILE - BUFILL error" E'EN; SFILE := "A"; end; end; end else if RP = "E" then begin P'EPACK(RP'DATA,RP'LEN); SFILE := "A"; end else if RP <> "N" then begin SFILE := "A"; E'ST "SFILE - Unknown packet type" E'EN; end; end; end; end; <<****************************************************************>> $PAGE "SDATA - Send Data Packet" byte subroutine SDATA; begin SDATA := STATE; << Default is return current state >> NUMTRY := NUMTRY + 1; if NUMTRY > MAXTRY then begin SDATA := "A"; E'ST "SDATA - Retry count exceeded" E'EN; end else begin SPACK("D",N,PDATACNT,PDATA); if RPACK(RP,RP'LEN,RP'NUM,RP'DATA) then begin if RP = "Y" then begin if RP'NUM = N then begin NUMTRY := 0; N := NPNO(N); BUFILL(PDATA,PDATACNT,BFSTAT); if BFSTAT <> 0 then begin SDATA := "Z"; FCLOSE(DNUM,0,0); DNUM := 0; end; end; end else if RP = "E" then begin E'ST "SDATA - E packet recieved" E'EN; P'EPACK(RP'DATA,RP'LEN); SDATA := "A"; end else if RP <> "N" then begin SDATA := "A"; E'ST "SDATA - Unknown Packet Type" E'EN; end; end; end; end; $PAGE "SEOF - Send EOF" byte subroutine SEOF; begin SEOF := STATE; NUMTRY := NUMTRY + 1; if NUMTRY > MAXTRY then begin E'ST "SEOF - Max retrys exceeded" E'EN; SEOF := "A"; end else begin SPACK("Z",N,0,RP'DATA); if RPACK(RP,RP'LEN,RP'NUM,RP'DATA) then begin if RP = "Y" then begin if RP'NUM = N then begin NUMTRY := 0; N := NPNO(N); SEOF := "B"; end; end else if RP = "E" then begin E'ST "SEOF - E packet recieved" E'EN; P'EPACK(RP'DATA,RP'LEN); SEOF := "A"; end else if RP <> "N" then begin SEOF := "A"; E'ST "SEOF - Unknown packet type" E'EN; end; end; end; end; $PAGE "SENDSW - Send Switch (Main Code)" <<****************************************************************>> MY'JCW'VAL := SENDING; PUTJCW(KERM'JCW, MY'JCW'VAL, JCW'ERR); if IMPATIENT then begin MY'TO := FAST'TO; MAXTRY := FAST'MAXTRY; end else begin MY'TO := DFLT'TO; MAXTRY := DFLT'MAXTRY; end; NUMTRY := 0; if SFNLEN <= 0 then begin STATE := "S"; << Normal file send >> SFNLEN := -SFNLEN; << Make positive again >> end else STATE := "F"; << Sending text, skip SI >> if SND'BINARY = 1 then begin << Always binary >> IMAGE := true; end else if SND'BINARY = 2 then begin << Always ASCII >> IMAGE := false; end else begin << Auto, check file >> FGETINFO(DNUM,,FOPT); if (FOPT land %4) <> 0 then IMAGE := false else IMAGE := true; end; while not (DONE lor CTLY) do begin if STATE = "S" then STATE := SINIT else if STATE = "F" then STATE := SFILE else if STATE = "D" then STATE := SDATA else if STATE = "Z" then STATE := SEOF else IF STATE="B" then begin STATE := "C"; DONE := true; end else begin DONE := true; end; end; if DNUM <> 0 then begin FCLOSE(DNUM,0,0); DNUM := 0; end; if STATE = "C" then begin MY'JCW'VAL:=SEND'OK; SENDSW := true end else begin MY'JCW'VAL:=SEND'NG; SENDSW := false; end; end; $PAGE "R'RPAR - Receive Read RI Parms" $control segment=R'RPAR'S procedure R'RPAR(DATA,LEN); value LEN ; integer LEN ; byte array DATA ; begin integer TEMP; MAX'SND'SIZE := UNCHAR(DATA(0)); << Max send size >> MAX'SND'DATA := MAX'SND'SIZE -3; << Max send data size >> YOUR'TO := UNCHAR(DATA(1)); << When I time you out >> YOUR'PAD'COUNT := UNCHAR(DATA(2));<< Number of pads to send >> YOUR'PAD := CTL(DATA(3)); << Your Pad char >> YOUR'EOL := UNCHAR(DATA(4)); << Your end-of-line >> YOUR'Q'CTL := integer(DATA(5)); << Your control quote >> if LEN > 6 and DATA(6) = "Y" then begin << I specify the quote >> Q8'IND := "Y"; QUOTE'8 := true; end else if LEN > 6 and DATA(6) <> "N" then begin << Quote specified for me >> Q'8 := DATA(6); Q8'IND := " "; QUOTE'8 := true; end else begin << No 8 bit quoting >> QUOTE'8 := false; end; if LEN > 7 then begin YOUR'BLK'CK := DATA(7); if YOUR'BLK'CK = "1" or YOUR'BLK'CK = "3" then MY'BLK'CK := YOUR'BLK'CK << Will do it your way >> else MY'BLK'CK := YOUR'BLK'CK := "1"; << The old way >> end else MY'BLK'CK := YOUR'BLK'CK := "1"; << No blk ck -> one-byte ck >> if LEN > 8 and DATA(8) <> " " then begin RPT'CHR := DATA(8); USE'REPEAT := true; end else begin USE'REPEAT := false; end; if LEN > 12 then << Extended packet stuff >> begin YOUR'CAPS := byte( logical(UNCHAR(DATA(9))) land logical(MY'CAPS) ); << Windowing, DATA(10), is unsupported herein >> TEMP := UNCHAR(DATA(11))*95 + UNCHAR(DATA(12)); if TEMP > MAX'LONGPACK'SIZE then TEMP := MAX'LONGPACK'SIZE; LONGPACK'SIZE := TEMP-7-integer(YOUR'BLK'CK-"1"); end else LONGPACK'SIZE := MAX'SND'SIZE-6; end; $PAGE "R'SPAR - Set up SEND Parameters" $control segment=R'SPAR'S procedure R'SPAR(DATA,LEN); byte array DATA ; integer LEN ; begin DATA(0) := TOCHAR(MAX'RCV'SIZE << Biggest to send me >> + 1 - (MY'BLK'CK-"0")); DATA(1) := TOCHAR(MY'TO); << When to time me out >> DATA(2) := TOCHAR(0); << How many pads I need >> DATA(3) := byte(CTL(0)); << Pad char to use for me >> DATA(4) := TOCHAR(CR); << End-of-line char for me >> DATA(5) := MY'Q'CTL; << Control quote I send >> if QUOTE'8 then begin if Q8'IND = "Y" then begin << I specify the char >> Q'8 := P'Q'8; DATA(6) := byte(P'Q'8); end else begin << Already specified >> DATA(6) := "Y"; end; end else begin DATA(6) := "N"; << No 8 bit quoting >> end; DATA(7) := MY'BLK'CK; if USE'REPEAT then DATA(8) := byte(RPT'CHR) else DATA(8) := " "; DATA(9) := TOCHAR(YOUR'CAPS); << We negotiated this >> DATA(10):= TOCHAR(0); << We don't do windows >> DATA(11):= TOCHAR( (LONGPACK'SIZE / 95) ); << MAXL1 >> DATA(12):= TOCHAR( (LONGPACK'SIZE MOD 95) ); << MAXL2 >> LEN := 13; end; $PAGE "RECSW - Receive Switch (Definitions)" $control segment=WORKER logical procedure RECSW(SERVE); value SERVE ; logical SERVE ; begin logical DONE := false, R'ERROR; integer FOPT, << File Options (calculated) >> FN'LEN; << File Name Length >> equate FN'MAX = 35; << Max File Name Length >> byte array FNAME(0:FN'MAX); <<----------------------------------------------------------->> $PAGE "RINIT - Recieve Initialization" byte subroutine RINIT; begin <<---------------------------------------------------------->> RINIT := STATE; NUMTRY := NUMTRY + 1; if NUMTRY > MAXTRY then begin E'ST "RINIT - Retry count exceeded" E'EN; RINIT := "A"; end else begin if ( R'ERROR := RPACK(RP,RP'LEN,RP'NUM,RP'DATA) ) then begin if RP = "S" then begin R'RPAR(RP'DATA,RP'LEN); << Read the others>> R'SPAR(RP'DATA,RP'LEN); << Generate ours >> SPACK("Y",N,RP'LEN,RP'DATA); << Send it >> OLDTRY := NUMTRY; << Save trys >> NUMTRY := 0; N := NPNO(RP'NUM); << Syncronize >> RINIT := "F"; << Switch to F mode >> end else if RP = "E" then begin E'ST "RINIT - E packet recieved" E'EN; P'EPACK(RP'DATA,RP'LEN); RINIT := "A"; end else if RP = "N" then begin E'ST "RINIT - NAK packet recieved" E'EN; P'EPACK(RP'DATA,RP'LEN); end else begin E'ST "RINIT - Unexpected packet type" E'EN; RINIT := "A"; end; end else begin if ( R'ERROR:=not(R'ERROR) ) <> 3 then <<no SOH found>> SPACK("N",N,0,RP'DATA); end; end; end; <<****************************************************************>> $PAGE "RFILE - Recieve a File Header" byte subroutine RFILE; begin RFILE := STATE; NUMTRY := NUMTRY + 1; if NUMTRY > MAXTRY then begin E'ST "RFILE - Retry count exceeded" E'EN; RFILE := "A"; end else begin if RPACK(RP,RP'LEN,RP'NUM,RP'DATA) then begin << Got a packet>> if RP = "S" then begin << Still in SI, perhaps ACK lost>> OLDTRY := OLDTRY + 1; if OLDTRY > MAXTRY then begin E'ST "RFILE - Pretry (S) exceeded" E'EN; RFILE := "A"; end else if RP'NUM <> PPNO(N) then begin << Number must match >> E'ST "RFILE - N mismatch on S packet" E'EN; RFILE := "A"; end else begin << OK, re-ACK the packet >> R'SPAR(RP'DATA,RP'LEN); SPACK("Y",RP'NUM,RP'LEN,RP'DATA); NUMTRY := 0; end; end else if RP = "Z" then begin << End of file, previous packet (?) >> OLDTRY := OLDTRY + 1; if OLDTRY > MAXTRY then begin E'ST "RFILE - Pretry (Z) exceeded" E'EN; RFILE := "A"; end else if RP'NUM <> PPNO(N) then begin << N must match >> E'ST "RFILE - N mismatch on Z packet" E'EN; RFILE := "A"; end else begin << OK, re-ACK the packet >> SPACK("Y",RP'NUM,0,RP'DATA); NUMTRY := 0; end; end else if RP = "F" then begin << File header (what we expect) >> if RP'NUM <> N then begin << Oops >> E'ST "RFILE - N mismatch" E'EN; RFILE := "A"; end else begin << OK, Open the file >> if L'FNAME'LEN <> 0 then begin move FNAME := L'FNAME,(L'FNAME'LEN); FN'LEN := L'FNAME'LEN; end else begin CBUFXLT(RP'DATA,RP'LEN, FNAME,FN'LEN,FN'MAX); if not UNQFNAME(FNAME,FN'LEN) then begin MAKE'U'FNAME(FNAME,FN'LEN); end; end; FNAME(FN'LEN) := " "; if RCV'BINARY then begin << Binary mode >> IMAGE := true; FOPT := 0; end else begin << ASCII mode >> IMAGE := false; FOPT := 4; end; if not RCV'FIXREC then FOPT := FOPT + %100; << set variable >> if RCV'RECLEN < 0 then DBUF'RMAX := -RCV'RECLEN else DBUF'RMAX := RCV'RECLEN * 2; if not VALID'FILE(FNAME, FN'LEN, IN) then begin E'ST "RFILE - file security error" E'EN; RFILE := "A"; DNUM := 0; end else begin DNUM := FOPEN(FNAME,FOPT,1, RCV'RECLEN, RCV'DEV,,, RCV'BLOCKF,, RCV'MAXREC, RCV'MAXEXT,1, RCV'FCODE); if DNUM = 0 then begin << Can't open file >> E'ST "RFILE - Can't open file" E'EN; RFILE := "A"; end else begin << OK >> MOVE RP'DATA := FNAME, (FN'LEN); RP'LEN := FN'LEN; SPACK("Y",N,RP'LEN,RP'DATA); OLDTRY := NUMTRY; NUMTRY := 0; N := NPNO(N); RFILE := "D"; DBUFCNT := 0; DBUFINX := 0; end; end; end; end else if RP = "B" then begin << Break transmission >> if RP'NUM <> N then begin << Oops >> E'ST "RFILE - (B) N mismatch" E'EN; RFILE := "A"; end else begin SPACK("Y",N,0,RP'DATA); RFILE := "C"; end; end else if RP = "E" then begin E'ST "RFILE - E packet recieved" E'EN; P'EPACK(RP'DATA,RP'LEN); RFILE := "A"; end else begin E'ST "RFILE - Unknown packet type" E'EN; RFILE := "A"; end; end << Got a packet >> else begin SPACK("N",N,0,RP'DATA); << No (readable) packet >> end; end; end; <<*****************************************************************>> $PAGE "RDATA - Recieve Data" byte subroutine RDATA; begin RDATA := STATE; NUMTRY := NUMTRY + 1; if NUMTRY > MAXTRY then begin E'ST "RDATA - Retry count exceeded" E'EN; RDATA := "A"; end else begin MY'TO := 10 + LONGPACK'SIZE/TSPEED; << Rcv timeout >> if RPACK(RP,RP'LEN,RP'NUM,RP'DATA) then begin if RP = "D" then begin << Good, what we expect >> if RP'NUM <> N then begin << Oops, not this packet >> OLDTRY := OLDTRY + 1; if OLDTRY > MAXTRY then begin E'ST "RDATA - Pretry exceeded" E'EN; RDATA := "A"; end else if RP'NUM = PPNO(N) then begin << Already have this one >> SPACK("Y",RP'NUM,0,RP'DATA); << Re-ACK >> NUMTRY := 0; end else begin E'ST "RDATA - N (D) mismatch" E'EN; RDATA := "A"; end; end << Wrong packet >> else begin << Got the one we want >> BUFEMP(RP'DATA,RP'LEN); << Process >> SPACK("Y",N,0,RP'DATA); << and ACK >> OLDTRY := NUMTRY; NUMTRY := 0; N := NPNO(N); end; end << RP = "D" >> else if RP = "F" then begin << File header >> OLDTRY := OLDTRY + 1; if OLDTRY > MAXTRY then begin E'ST "RDATA - Pretry (F) exceeded" E'EN; RDATA := "A"; end else if RP'NUM <> PPNO(N) then begin << Oops >> E'ST "RDATA - N (F) mismatch" E'EN; RDATA := "A"; end else begin << OK >> SPACK("Y",RP'NUM,0,RP'DATA); << ReACK >> NUMTRY := 0; end; end << RP = "F" >> else if RP = "Z" then begin << End of File >> if RP'NUM <> N then begin E'ST "RDATA - N (Z) mismatch" E'EN; RDATA := "A"; end else begin if DBUFINX > 0 then FLUSH'DBUF; if RCV'SAVESP then FCLOSE(DNUM,%11,0) else FCLOSE(DNUM,1,0); DNUM := 0; SPACK("Y",N,0,RP'DATA); << ACK >> L'FNAME'LEN := 0; N := NPNO(N); RDATA := "F"; end; end << RP = "Z" >> else if RP = "E" then begin E'ST "RDATA - E packet recieved" E'EN; P'EPACK(RP'DATA,RP'LEN); RDATA := "A"; end else begin E'ST "RDATA - Unknown packet type" E'EN; RDATA := "A"; end; end << Got packet >> else begin SPACK("N",N,0,RP'DATA); << NAK >> end; end; end; $PAGE "RECSW - Main Code" <<*****************************************************************>> MY'JCW'VAL := RECVING; PUTJCW(KERM'JCW, MY'JCW'VAL, JCW'ERR); if IMPATIENT then begin MY'TO := FAST'TO; MAXTRY := FAST'MAXTRY; end else begin MY'TO := DFLT'TO; MAXTRY := DFLT'MAXTRY; end; if not SERVE then begin STATE := "R"; N := 0; NUMTRY := 0; end else begin STATE := "F"; end; while not (DONE lor CTLY) do begin if STATE = "R" then STATE := RINIT else if STATE = "F" then STATE := RFILE else if STATE = "D" then STATE := RDATA else if STATE = "C" then begin DONE := true; RECSW := true; end else if STATE = "A" then begin DONE := true; RECSW := false; end; end; if DNUM <> 0 then begin FCLOSE(DNUM,0,0); DNUM := 0; end; if STATE="C" then MY'JCW'VAL:=RECV'OK else MY'JCW'VAL:=RECV'NG; MY'TO := DFLT'TO; end; <<****************************************************************>> $control segment=TYPESW'S $PAGE "TYPESW - Type a file on the terminal" logical procedure TYPESW; begin logical DONE := false; if VALID'FILE(L'FNAME, L'FNAME'LEN, OUT) then else begin M'ST ("Kermit file security error - ", "see your account manager") M'EN; TYPESW := false; return; end; DNUM := FOPEN(L'FNAME, 5, 0); if DNUM = 0 then begin M'ST "File open failure" M'EN; TYPESW := false; return; end; while not(DONE lor CTLY) do begin DBUFCNT := FREAD(DNUM, W'DBUF, -DBUF'BYTESIZE); if < then begin << Read error >> M'ST "TYPESW - read error" M'EN; TYPESW := false; DONE := true; end else if > then begin << EOF >> TYPESW := DONE := true; end else FWRITE(CONUM, W'DBUF, -DBUFCNT, 0); end; FCLOSE(DNUM, 0, 0); DNUM := 0; if CTLY then TYPESW := false; end; <<*****************************************************************>> $PAGE "OPEN'LINE - Open Communications Line" $control segment=OPEN'LINE'S logical procedure OPEN'LINE; begin logical R'ERROR := false, TEMP; integer DEV'L; byte array A'DEV(0:11); <<************************************************************>> if LNUM = 0 then begin << Line not open >> if LDEV'LINE = 0 then begin E'ST "Line not specified or defaultable" E'EN; R'ERROR := true; end else begin move PBUF := "SETMSG OFF",2; PLEN := TOS - @PBUF; PBUF(PLEN) := CR; COMMAND(PBUF,PLEN,DEV'L); move A'DEV := "000 "; ASCII(LDEV'LINE, -10, A'DEV(2)); ! LNUM := FOPEN( , %500, %4, LBUF'WORDSIZE, A'DEV); IF <> THEN IF LOGNUM<>0 THEN BEGIN FCHECK(LNUM, R'ERROR); MOVE PBUF:="OPEN'LINE: FOPEN ERROR ", 2; PLEN:=TOS-@PBUF; PLEN:=PLEN+ASCII(R'ERROR, 10, R'ERROR); WRITE'LOG(PBUF, PLEN, 0); R'ERROR:=TRUE; END; if LNUM = 0 then begin E'ST "FOPEN error on communications port" E'EN; R'ERROR := true; end else begin << Set up the line >> if HNDSHK = 0 then TTYPE := 18 else TTYPE := DFLT'TTYPE; FCONTROL(LNUM,39,ORGL'TTYPE); IF <> THEN IF LOGNUM>0 THEN BEGIN FCHECK(LNUM, TEMP); E'ST "FCONTROL 39 PROBLEM" E'EN; FERRMSG(TEMP, PBUF, PLEN); WRITE'LOG(PBUF, PLEN, -2); END; FCONTROL(LNUM,38,TTYPE); IF <> THEN IF LOGNUM>0 THEN BEGIN FCHECK(LNUM, TEMP); E'ST "FCONTROL 38 PROBLEM" E'EN; FERRMSG(TEMP, PBUF, PLEN); WRITE'LOG(PBUF, PLEN, -2); END; FCONTROL(LNUM,13,ORGL'ECHO); IF <> THEN IF LOGNUM>0 THEN BEGIN FCHECK(LNUM, TEMP); E'ST "FCONTROL 13 PROBLEM" E'EN; FERRMSG(TEMP, PBUF, PLEN); WRITE'LOG(PBUF, PLEN, -2); END; if TSPEED <> 0 then begin ORGL'TISPEED := TSPEED; FCONTROL(LNUM,10,ORGL'TISPEED); IF <> THEN IF LOGNUM>0 THEN BEGIN FCHECK(LNUM, TEMP); E'ST "FCONTROL 10 PROBLEM" E'EN; FERRMSG(TEMP, PBUF, PLEN); WRITE'LOG(PBUF, PLEN, -2); END; ORGL'TOSPEED := TSPEED; FCONTROL(LNUM,11,ORGL'TOSPEED); IF <> THEN IF LOGNUM>0 THEN BEGIN FCHECK(LNUM, TEMP); E'ST "FCONTROL 11 PROBLEM" E'EN; FERRMSG(TEMP, PBUF, PLEN); WRITE'LOG(PBUF, PLEN, -2); END; end else FCONTROL(LNUM,40,TSPEED); << Get speed >> IF <> THEN IF LOGNUM>0 THEN BEGIN FCHECK(LNUM, TEMP); E'ST "FCONTROL 40 PROBLEM" E'EN; FERRMSG(TEMP, PBUF, PLEN); WRITE'LOG(PBUF, PLEN, -2); END; FSETMODE(LNUM,4); << Inhibit LF >> IF <> THEN IF LOGNUM>0 THEN BEGIN FCHECK(LNUM, TEMP); E'ST "FSETMODE 4 PROBLEM" E'EN; FERRMSG(TEMP, PBUF, PLEN); WRITE'LOG(PBUF, PLEN, -2); END; if HNDSHK = 2 then begin << Set XON as termination char >> TEMP := XON; FCONTROL(LNUM,25,TEMP); IF <> THEN IF LOGNUM>0 THEN BEGIN FCHECK(LNUM, TEMP); E'ST "FCONTROL 25 PROBLEM" E'EN; FERRMSG(TEMP, PBUF, PLEN); WRITE'LOG(PBUF, PLEN, -2); END; end; TEMP:=MY'EOL cat CTL("Y") (0:8:8); FCONTROL(LNUM, 41, TEMP); <<Almost transparent rx>> IF <> THEN IF LOGNUM>0 THEN BEGIN FCHECK(LNUM, TEMP); E'ST "FCONTROL 41 PROBLEM" E'EN; FERRMSG(TEMP, PBUF, PLEN); WRITE'LOG(PBUF, PLEN, -2); END; if (LDEV'CI = LDEV'LINE) land (LOGNUM = CONUM) then LOGNUM := 0; end; end; end; OPEN'LINE := not R'ERROR; end; $PAGE "SHUT'LINE - Close Communications Line" $control segment=SHUT'LINE'S procedure SHUT'LINE; begin logical TEMP; <<************************************************************>> if LNUM <> 0 then begin << Line is open >> FSETMODE(LNUM,0); << Turn on linefeed >> if ORGL'TTYPE <> TTYPE then FCONTROL(LNUM,38,ORGL'TTYPE); if TSPEED <> 0 then begin if ORGL'TISPEED <> TSPEED then begin TEMP := ORGL'TISPEED; FCONTROL(LNUM,10,TEMP); end; if ORGL'TOSPEED <> TSPEED then begin TEMP := ORGL'TOSPEED; FCONTROL(LNUM,11,TEMP); end; end; ! TEMP:=0; FCONTROL(LNUM, 41, TEMP); if ORGL'ECHO = 0 then FCONTROL(LNUM,12,TEMP); if HNDSHK = 2 then begin TEMP := 0; FCONTROL(LNUM,25,TEMP); end; FCLOSE(LNUM,0,0); LNUM := 0; if LOGNUM = 0 then LOGNUM := CONUM; move PBUF := "SETMSG ON",2; PLEN := TOS - @PBUF; PBUF(PLEN) := CR; COMMAND(PBUF,PLEN,TEMP); end; end; $PAGE "Temporary File Allocation/Deletion" $control segment=KILL'TEMP'S procedure KILL'KTEMP; begin integer TNUM, << Temp file number >> X; << Temp variable >> byte array TBUF(0:79); move TBUF := "RESET ",2; move * := KTEMP'NAME,2; X := TOS - @TBUF; TBUF(X) := CR; COMMAND(TBUF,TNUM,X); << Reset file equate >> move TBUF := KTEMP'NAME,2; X := TOS - @TBUF; TBUF(X) := " "; TNUM := FOPEN(TBUF,7,4); << Try to open it >> if TNUM <> 0 then FCLOSE(TNUM,4,0); << Kill it >> HAVE'KTEMP := false; end; $PAGE $control segment=GET'TEMP'S procedure GET'KTEMP; begin integer TNUM, << Temp file number >> X; << Temp variable >> byte array TBUF(0:79); KILL'KTEMP; << Delete any old one >> TNUM := FOPEN(KT'NAME,4,4,-80,,,,16,,2048d,8,1); << Open new >> if TNUM <> 0 then begin FCLOSE(TNUM,2,0); << Save as temporary >> if = then begin move TBUF := "FILE ",2; move * := KTEMP'NAME,2; move * := ",OLDTEMP",2; X := TOS - @TBUF; TBUF(X) := CR; COMMAND(TBUF,X,TNUM); if X = 0 then HAVE'KTEMP := true; end; end; end; $PAGE "HOST'COMMAND - Process an HP 3000 Command" $control segment=HOST'COMMAND'S procedure HOST'COMMAND(CMD,CMD'LEN,LONG'REPLY); value CMD'LEN,LONG'REPLY ; byte array CMD ; integer CMD'LEN ; logical LONG'REPLY ; begin byte array CMD'BUF(0:79); logical CMD'ERR := false; integer CI'ERNO, CI'PARM; <<------------------------------------------------------------>> move CMD'BUF := CMD,(CMD'LEN); if LONG'REPLY then begin GET'KTEMP; if not HAVE'KTEMP then begin move CMD'BUF := "Unable to allocate temp file",2; CMD'LEN := TOS - @CMD'BUF; SPACK("E",N,CMD'LEN,CMD'BUF); CMD'ERR := true; end; end; if not CMD'ERR then begin CMD'BUF(CMD'LEN) := CR; COMMAND(CMD'BUF,CI'ERNO,CI'PARM); << Issue the command >> if CI'ERNO <> 0 then begin << Command Interpreter error >> move CMD'BUF := "Command Error, CIERROR = ",2; CMD'LEN := TOS - @CMD'BUF; CMD'LEN := CMD'LEN + ASCII(CI'ERNO,10,CMD'BUF(CMD'LEN)); SPACK("E",N,CMD'LEN,CMD'BUF); CMD'ERR := true; end else begin << Command OK >> if LONG'REPLY then begin DNUM := FOPEN(KT'NAME,6,0); if DNUM = 0 then begin << Temp file open error >> move CMD'BUF := "Temp file open failure",2; CMD'LEN := TOS - @CMD'BUF; SPACK("E",N,CMD'LEN,CMD'BUF); CMD'ERR := true; end else begin SENDSW(CMD'BUF,0); STATE := SBREAK; end; end else begin << Short reply >> SPACK("Y",N,0,CMD'BUF); end; end; end; end; $PAGE "KERMIT'COMMAND - Process Generic KERMIT Command" $control segment=KERMIT'COMMAND'S procedure KERMIT'COMMAND(KCMD,KCMD'LEN); value KCMD'LEN ; byte array KCMD ; integer KCMD'LEN ; begin byte array KC'BUF(0:79); array INTRINSIC'STATUS(0:2); integer KC'LEN, ERR, X; double SESSION := 0D; real WRITE'FINISH := 2.0; <<------------------------------------------------------------>> E'ST "KERMIT COMMAND KCMD=(", 2; PLEN:=(PLEN:=TOS-@PBUF)+ASCII(KCMD'LEN,10,PBUF(PLEN)); MOVE PBUF(PLEN):=")", 2; MOVE *:=KCMD,(KCMD'LEN) E'EN; if (KCMD = "D") land (KCMD'LEN > 0) then begin << Directory Command >> move KC'BUF := "LISTF ",2; KC'LEN := TOS - @KC'BUF; if KCMD'LEN > 2 then begin << Check for filespec >> X := UNCHAR(KCMD(1)); if (X > 0) land (X <= (KCMD'LEN -2)) then begin << Use filespec >> move KC'BUF(KC'LEN) := KCMD(2),(X); KC'LEN := KC'LEN + X; end; end; move KC'BUF(KC'LEN) := ",2",2; move * := ";*",2; move * := KTEMP'NAME,2; KC'LEN := TOS - @KC'BUF; HOST'COMMAND(KC'BUF,KC'LEN,true); end else if (KCMD = "U") land (KCMD'LEN > 0) then begin << File space usage >> move KC'BUF := "REPORT ",2; KC'LEN := TOS - @KC'BUF; if KCMD'LEN > 2 then begin << Check for groupspec >> X := UNCHAR(KCMD(1)); if (X > 0) land (X <= (KCMD'LEN -2)) then begin << Use groupspec >> move KC'BUF(KC'LEN) := KCMD(2),(X); KC'LEN := KC'LEN + X; end; end; move KC'BUF(KC'LEN) := ",*",2; move * := KTEMP'NAME,2; KC'LEN := TOS - @KC'BUF; HOST'COMMAND(KC'BUF,KC'LEN,true); end else if (KCMD = "E") land (KCMD'LEN > 0) then begin << Erase (delete) command >> move KC'BUF := "PURGE ",2; KC'LEN := TOS - @KC'BUF; if KCMD'LEN > 2 then begin X := UNCHAR(KCMD(1)); end else begin X := 0; end; if (X < 1) lor (X > (KCMD'LEN-2)) lor not VALID'FILE(KCMD(2), X, IN) then begin move KC'BUF := "Filespec missing or invalid",2; KC'LEN := TOS - @KC'BUF; SPACK("E",N,KC'LEN,KC'BUF); end else begin move KC'BUF(KC'LEN) := KCMD(2),(X); KC'LEN := KC'LEN + X; HOST'COMMAND(KC'BUF,KC'LEN,false); end; end else if (KCMD = "T") land (KCMD'LEN > 0) then begin << Type Command >> if KCMD'LEN > 1 then begin X := UNCHAR(KCMD(1)); end else begin X := 0; end; if (X < 1) lor (X > (KCMD'LEN -2)) then begin move KC'BUF := "Filespec missing or invalid",2; KC'LEN := TOS - @KC'BUF; SPACK("E",N,KC'LEN,KC'BUF); end else begin move KC'BUF := KCMD(2),(X); KC'BUF(X) := " "; if not VALID'FILE(KC'BUF, X, OUT) then begin move KC'BUF := ("Kermit file security error -", " see your account manager"),2; KC'LEN := TOS - @KC'BUF; SPACK("E",N,KC'LEN,KC'BUF); end else begin DNUM := FOPEN(KC'BUF,5,0); if DNUM = 0 then begin move KC'BUF := "File open error",2; KC'LEN := TOS - @KC'BUF; SPACK("E",N,KC'LEN,KC'BUF); end else begin SENDSW(KC'BUF,0); STATE := SBREAK; end; end; end; end else if KCMD = "L" then begin << Bye command >> JOBINFO(1, SESSION, INTRINSIC'STATUS, 15, SESSION, ERR); if INTRINSIC'STATUS(0) <> 0 then begin move PBUF:="Can't 'BYE'. JOBINFO status=", 2; PLEN:=(PLEN:=TOS-@PBUF) +ASCII(INTRINSIC'STATUS, 10, PBUF(PLEN)); SPACK("E",N,PLEN,PBUF); end else begin move PBUF:="Kermit session aborted by user", 2; PLEN:=TOS-@PBUF; SPACK("Y",N,PLEN,PBUF); if LOGNUM<>0 then FCLOSE(LOGNUM, %11, 0); if HAVE'KTEMP then KILL'KTEMP; PAUSE(WRITE'FINISH); << FWRITE in SPACK >> ABORTSESS(1, SESSION, INTRINSIC'STATUS); end; end else begin move KC'BUF := "Unimplementented Server Command",2; KC'LEN := TOS - @KC'BUF; SPACK("E",N,KC'LEN,KC'BUF); end; end; $PAGE "SERVER - Driver for Server Mode" $control segment=SERVER'S procedure SERVER; begin equate CB'MAX = 79; << Max command size -1 >> byte array CBUF(0:CB'MAX); << Command Buffer >> logical DONE := false, SEARCHED := false; integer CB'CNT, << Command size >> KT'NUM, << Temp file number >> IX; <<************************************************************>> logical subroutine DIRSEARCH; begin DIRSEARCH:=false; << Prepare for the worst >> if not SEARCHED then begin GET'KTEMP; if not HAVE'KTEMP then begin move PBUF:="Unable to allocate temp file", 2; PLEN:=TOS-@PBUF; SPACK("E", N, PLEN, PBUF); return; end; move PBUF:="LISTF ", 2; move *:=L'FNAME, (L'FNAME'LEN), 2; move *:=("; *", KTEMP'NAME, CR); COMMAND(PBUF, ERROR, PARM); if ERROR <> 0 then begin move PBUF:="Directory search failed. Error=", 2; PLEN:=(PLEN:=TOS-@PBUF) + ASCII(ERROR, 10, PBUF(PLEN)); SPACK("E", N, PLEN, PBUF); return; end; KT'NUM:=FOPEN(KT'NAME, 6, 0); if KT'NUM = 0 then begin move PBUF:="Temp file open failure", 2; PLEN:=TOS-@PBUF; SPACK("E", N, PLEN, PBUF); return; end; FREAD(KT'NUM, PBUF'W, -80); <<Hopefully skip over junk >> FREAD(KT'NUM, PBUF'W, -80); FREAD(KT'NUM, PBUF'W, -80); SEARCHED:=true; end; move PBUF:=20(" "); if FREAD(KT'NUM, PBUF'W, -80) <= 1 lor PBUF(0) = special then begin SEARCHED:=false; FCLOSE(KT'NUM, 4, 0); << Purge >> KT'NUM:=0; KILL'KTEMP; STATE := SBREAK; return; end; << If we survived all of that, we will return one file name >> << which could be denied by the file validator >> move L'FNAME:=PBUF(0) while an, 1; L'FNAME'LEN := TOS-@L'FNAME; L'FNAME(L'FNAME'LEN) := " "; if SEARCHED.(0:1) then begin SEARCHED.(0:1) := false; L'FNAME'LEN := -L'FNAME'LEN; end; DIRSEARCH:=true; end; <<----------------------------------------------------------->> subroutine SPLIT'CBUF(BUF, LEN); ! Handle the case where we have value LEN; ! local and remote file names integer LEN; ! specified in a remote GET byte array BUF; ! request. begin IX := 0; while BUF(IX) = " " do IX:=IX+1; L'FNAME'LEN := 0; while BUF(IX)<>" " land IX<LEN do begin L'FNAME(L'FNAME'LEN) := BUF(IX); L'FNAME'LEN := L'FNAME'LEN+1; IX := IX+1; end; L'FNAME(L'FNAME'LEN) := " "; R'FNAME'LEN := 0; while BUF(IX)=" " land IX<LEN do IX := IX+1; while BUF(IX)<>" " land IX<LEN do begin R'FNAME(R'FNAME'LEN) := BUF(IX); R'FNAME'LEN := R'FNAME'LEN+1; IX := IX+1; end; R'FNAME(R'FNAME'LEN) := " "; E'ST "SPLIT ",2; MOVE *:=L'FNAME, (L'FNAME'LEN), 2; MOVE *:=" ", 2; MOVE *:=R'FNAME, (R'FNAME'LEN) E'EN; R'FNAME'LEN := -R'FNAME'LEN; end; <<--------------------------------------------------------------->> << Set default conditions >> MAX'SND'SIZE := 80; MAX'SND'DATA := 77; YOUR'PAD'COUNT := 0; YOUR'PAD := 0; YOUR'EOL := CR; YOUR'Q'CTL := %43; QUOTE'8 := false; USE'REPEAT := false; while not (DONE lor CTLY) do begin N := 0; NUMTRY := 0; STATE := "S"; if RPACK(RP,RP'LEN,RP'NUM,RP'DATA) land (RP'NUM = 0) then begin MY'JCW'VAL := IDLING; PUTJCW(KERM'JCW, MY'JCW'VAL, JCW'ERR); if RP = "I" then begin << Exchange Parameters >> R'RPAR(RP'DATA,RP'LEN); R'SPAR(RP'DATA,RP'LEN); SPACK("Y",N,RP'LEN,RP'DATA); OLDTRY := NUMTRY; NUMTRY := 0; N := NPNO(RP'NUM); end else if RP = "S" then begin << Other side is sending >> R'RPAR(RP'DATA,RP'LEN); R'SPAR(RP'DATA,RP'LEN); SPACK("Y",N,RP'LEN,RP'DATA); OLDTRY := NUMTRY; NUMTRY := 0; N := NPNO(RP'NUM); RECSW(true); PUTJCW(KERM'JCW, MY'JCW'VAL, JCW'ERR); end else if RP = "R" then begin << Other side wants us to send >> CBUFXLT(RP'DATA,RP'LEN,CBUF,CB'CNT,CB'MAX); SPLIT'CBUF(CBUF, CB'CNT); while DIRSEARCH do begin if not VALID'FILE(L'FNAME, \L'FNAME'LEN\, OUT) then begin move RP'DATA := ("Kermit file security ", "error - see your account ", "manager"); SPACK("E",N,53,RP'DATA); MY'JCW'VAL := SEND'NG; end else begin DNUM := FOPEN(L'FNAME,5,0); if DNUM = 0 then begin << File open error >> move RP'DATA := "File open error"; SPACK("E",N,15,RP'DATA); MY'JCW'VAL := SEND'NG; end else if R'FNAME'LEN = 0 then begin SENDSW(L'FNAME, L'FNAME'LEN); L'FNAME'LEN := 0; end else begin SENDSW(R'FNAME, R'FNAME'LEN); R'FNAME'LEN := 0; end; end; PUTJCW(KERM'JCW, MY'JCW'VAL, JCW'ERR); end; end else if RP = "G" then begin << KERMIT Command >> if (RP'DATA = "F") land (RP'LEN = 1) then begin SPACK("Y",N,0,RP'DATA); DONE := true; end else begin if CBUFXLT(RP'DATA,RP'LEN, CBUF,CB'CNT,CB'MAX) then begin KERMIT'COMMAND(CBUF,CB'CNT); end else begin move CBUF := "Command too big",2; CB'CNT := TOS - @CBUF; SPACK("E",N,CB'CNT,CBUF); end; end; end else begin SPACK("N",N,0,RP'DATA); end; end else begin SPACK("N",N,0,RP'DATA); end; end; end; $PAGE "VERIFY - List assorted attributes" $control segment=VERIFY'S procedure VERIFY; begin byte pointer P; define SAY = begin move P:=#, << Better than M'ST >> ENDSAY = ,2; << Better than M'EN >> @P:=TOS; end#, SAYNUM = @P:=@P+ASCII(#, DECIMAL = ,10, P)#, SPIT = begin PLEN:=@P-@PBUF; FWRITE(CONUM, PBUF'W, -PLEN, 0); @P:=@PBUF; move P:=80(" "); end#, MIDLINE = @P:=@PBUF+30#; subroutine SAYBOOL(TRUTH); value TRUTH; logical TRUTH; begin case TRUTH.(15:1) of <<Who says we must use IF statements?>> begin SAY "OFF" ENDSAY; SAY "ON" ENDSAY; end; end; @P:=@PBUF; SAY 80(" ") ENDSAY; SPIT; SAY "RECEIVE parameters" ENDSAY; MIDLINE; SAY "Other parameters" ENDSAY; SPIT; SAY " BINARY: " ENDSAY; SAYBOOL(RCV'BINARY); MIDLINE; SAY " SEND BINARY: " ENDSAY; case SND'BINARY of begin SAY "Auto" ENDSAY; SAY "Binary" ENDSAY; SAY "ASCII" ENDSAY; end; SPIT; SAY " FIXREC: " ENDSAY; SAYBOOL(RCV'FIXREC); MIDLINE; SAY " SEND PAUSE: " ENDSAY; SAYNUM PAUSE'CNT DECIMAL; SPIT; SAY " SAVESP: " ENDSAY; SAYBOOL(RCV'SAVESP); MIDLINE; SAY " DELAY: " ENDSAY; SAYNUM I'DELAY DECIMAL; SPIT; SAY " FCODE: " ENDSAY; SAYNUM RCV'FCODE DECIMAL; MIDLINE; SAY " HANDSHAKE: " ENDSAY; case HNDSHK of begin SAY "None" ENDSAY; SAY "XON" ENDSAY; SAY "XON2" ENDSAY; end; SPIT; SAY " RECLEN: " ENDSAY; SAYNUM RCV'RECLEN DECIMAL; MIDLINE; SAY " DEBUG: " ENDSAY; SAYNUM DEBUG'MODE DECIMAL; SPIT; SAY " BLOCKF: " ENDSAY; SAYNUM RCV'BLOCKF DECIMAL; MIDLINE; SAY " LOG: " ENDSAY; if LOGNUM > 0 and LOGNUM <> CONUM then begin SAY "TRUE (" ENDSAY; SAY LOGNAME, (LOGNAME'LEN) ENDSAY; SAY ")" ENDSAY; end else SAY "FALSE" ENDSAY; SPIT; SAY " MAXEXT: " ENDSAY; SAYNUM RCV'MAXEXT DECIMAL; MIDLINE; SAY " LINE LDEV: " ENDSAY; SAYNUM LDEV'LINE DECIMAL; SPIT; SAY " MAXREC: " ENDSAY; DASCII(RCV'MAXREC, 10, P); MIDLINE; SAY " LINE SPEED: " ENDSAY; SAYNUM TSPEED DECIMAL; SPIT; SAY " DEVICE: " ENDSAY; MOVE P:=RCV'DEV while AN, 1; MIDLINE; SAY " SOH: " ENDSAY; SAYNUM SOH DECIMAL; SPIT; SAY " EXPTAB: " ENDSAY; SAYBOOL(EXP'TABS); SPIT; end; $PAGE "KINIT - Perform KERMIT Initialization" $control segment=KINIT'S logical procedure KINIT; begin logical R'ERROR := false; integer J'MODE, J'LDEV, DUM, F'LDEV; byte array TEST'CMD(0:19); <<------------------------------------------------------------>> LNUM := 0; CINUM := FOPEN(,%54,0); << Open $STDIN >> CONUM := FOPEN(,%414,1); << Open $STDLIST >> << LOGNUM := CONUM; Equates to non-STDLIST cause confusion >> if (CINUM <> 0) land (CONUM <> 0) then begin M'ST VERS M'EN; << Output current version # >> M'ST " " M'EN; XCONTRAP(@CONTROLY,DUM); move KT'NAME := KTEMP'NAME,2; KTN'LEN := TOS - @KT'NAME; KT'NAME(KTN'LEN) := " "; LDEV'CI := 0; LDEV'LINE := 0; WHO(J'MODE,,,MYSELF,,,,J'LDEV); if J'MODE.(12:2) = 1 then begin << Session >> LDEV'LINE := J'LDEV; << Default COM to session dev >> FGETINFO(CINUM,,,,,,F'LDEV); << Get CI ldev >> if F'LDEV = J'LDEV then begin << Command input uses session device >> LDEV'CI := J'LDEV; end else begin FGETINFO(CONUM,,,,,,F'LDEV); << Get CO ldev >> if F'LDEV = J'LDEV then LDEV'CI := J'LDEV; << CO uses session ldev >> end; end; MIN'SIZE(DELETEV) :=2; MIN'SIZE(DIRV) :=2; MIN'SIZE(EXITV) :=1; MIN'SIZE(NULLV) :=1; MIN'SIZE(RECEIVEV) :=1; MIN'SIZE(SENDV) :=3; MIN'SIZE(SERVEV) :=3; MIN'SIZE(SETV) :=3; MIN'SIZE(SPACEV) :=2; MIN'SIZE(STATUSV) :=2; MIN'SIZE(TAKEV) :=2; MIN'SIZE(TYPEV) :=2; MIN'SIZE(VERIFYV) :=1; MIN'SIZE(DEBUGV) :=3; MIN'SIZE(DELAYV) :=3; MIN'SIZE(HANDSHAKEV):=1; MIN'SIZE(LINEV) :=2; MIN'SIZE(LOGV) :=2; MIN'SIZE(SENDV'1) :=3; MIN'SIZE(SPEEDV) :=2; MIN'SIZE(SOHV) :=2; MIN'SIZE(RECEIVEV'1):=1; MIN'SIZE(AUTOV) :=1; MIN'SIZE(BIN128V) :=4; MIN'SIZE(BINARYV) :=4; MIN'SIZE(BLOCKFV) :=2; MIN'SIZE(DEVICEV) :=1; MIN'SIZE(FIXRECV) :=2; MIN'SIZE(FCODEV) :=2; MIN'SIZE(MAXRECV) :=4; MIN'SIZE(MAXEXTV) :=4; MIN'SIZE(PAUSEV) :=2; MIN'SIZE(PROGV) :=2; MIN'SIZE(RECLENV) :=1; MIN'SIZE(SAVESPV) :=1; MIN'SIZE(TEXTV) :=2; MIN'SIZE(TXT80V) :=2; MIN'SIZE(EXPTABV) :=1; MIN'SIZE(FASTV) :=2; MIN'SIZE(NONEV) :=1; MIN'SIZE(OFFV) :=2; MIN'SIZE(ONV) :=2; MIN'SIZE(XONV) :=3; MIN'SIZE(XON2V) :=4; MIN'SIZE(YESV) :=1; MY'CAPS := 0 CAT 1 (LONGP'F) CAT 0 (WINDOWS'F) CAT 0 (ATTRS'F); move TEST'CMD:=("SETVAR NOTHING, 0", CR); COMMAND(TEST'CMD, ERROR, PARM); if = then DFLT'TTYPE := 10 << HPPA machines >> else DFLT'TTYPE := 13; << Classic machines >> end else begin R'ERROR := true; end; if TAKE'VAL > 0 then begin move PBUF:="F599KM00 ", 2; PLEN:=TOS-@PBUF; ASCII(TAKE'VAL, -10, PBUF(PLEN-2)); TAKENUM:=FOPEN(PBUF, %5, %2000); if TAKENUM = 0 then begin move PBUF(PLEN):="take file open error", 2; PLEN:=TOS-@PBUF; FWRITE(CONUM, PBUF'W, -PLEN, 0); end; end; LONGPACK'SIZE := MAX'LONGPACK'SIZE-10; KINIT := not R'ERROR; end; $PAGE "HELP - User Help Function" $control segment=HELP'S procedure HELP(ITEM, LEVEL, RCVCASE); value ITEM, LEVEL, RCVCASE; integer ITEM, LEVEL, RCVCASE; option variable; <<*WARNING* No check is made for missing params!!!!!!!!!!!!>> begin <<----------------------------------------------------------->> M'ST " " M'EN; case ITEM of begin << COMMANDS IN GENERAL >> begin M'ST "Commands:" M'EN; M'ST " " M'EN; M'ST " TAKE" M'EN; M'ST " SERVE" M'EN; M'ST " SEND" M'EN; M'ST " RECEIVE" M'EN; M'ST " SET" M'EN; M'ST " VERIFY" M'EN; M'ST " DIR" M'EN; M'ST " SPACE" M'EN; M'ST " DELETE" M'EN; M'ST " TYPE" M'EN; M'ST " EXIT" M'EN; end; << TAKE >> begin M'ST "Syntax: TAKE filespec" M'EN; M'ST " " M'EN; M'ST "The TAKE command causes subsequent commands to be" M'EN; M'ST "taken from the specified file until EOF is reached." M'EN; M'ST "If a subsequent TAKE is encountered within the original" M'EN; M'ST "TAKE file, the first file is closed and execution" M'EN; M'ST "continues with the second. This means that if a" M'EN; M'ST "TAKE appears within a TAKE file, commands that follow" M'EN; M'ST "it (in the original TAKE file) will be ignored." M'EN; end; << SEND >> begin M'ST "Syntax: SEND filespec1 [filespec2]" M'EN; M'ST " " M'EN; M'ST "This command causes a file (indicated by filespec1)" M'EN; M'ST "to be sent from the HP to the local KERMIT. Wildcard" M'EN; M'ST "characters are not permitted. If filespec2 is speci-" M'EN; M'ST "fied, the file will be sent with that name." M'EN; end; << RECEIVE >> begin M'ST "Syntax: RECEIVE [filespec]" M'EN; M'ST " " M'EN; M'ST "The RECEIVE command causes HP KERMIT to enter receive" M'EN; M'ST "mode and wait for the local kermit to start sending" M'EN; M'ST "a file. If filespec is specified, the file will be" M'EN; M'ST "stored under that name." M'EN; end; << SERVE >> begin M'ST "Syntax: SERVE" M'EN; M'ST " " M'EN; M'ST "The SERVE command causes HP 3000 KERMIT to go into" M'EN; M'ST "server mode. Once in server mode, the only way back" M'EN; M'ST "to command mode is the Control-Y trap." M'EN; M'ST " " M'EN; M'ST "In addition to the standard KERMIT transactions for" M'EN; M'ST "file transfer, the following server functions are" M'EN; M'ST "supported:" M'EN; M'ST " " M'EN; M'ST "FUNCTION PROBABLE SYNTAX" M'EN; M'ST " (If available on local KERMIT)" M'EN; M'ST "------------------- -------------------------------" M'EN; M'ST " " M'EN; M'ST "Finish Processing FINISH" M'EN; M'ST "Type a file REMOTE TYPE filespec" M'EN; M'ST "Directory Listing REMOTE DIRECTORY [filespec]" M'EN; M'ST "File Space Listing REMOTE SPACE [filespec]" M'EN; M'ST "Delete a file REMOTE DELETE filespec" M'EN; M'ST " " M'EN; M'ST "Wildcard file specification may be used only for the" M'EN; M'ST "DIRECTORY and SPACE transactions. Wildcard specifi-" M'EN; M'ST "cations are in the native HP 3000 format. To produce" M'EN; M'ST "a DIRECTORY listing of all files starting with FOO use:" M'EN; M'ST " " M'EN; M'ST " REMOTE DIRECTORY FOO@" M'EN; end; << SET >> begin case LEVEL-DEBUGV+1 of begin << SET COMMANDS IN GNERAL >> begin M'ST "SET items:" M'EN; M'ST " " M'EN; M'ST " SET DEBUG" M'EN; M'ST " SET DELAY" M'EN; M'ST " SET LINE" M'EN; M'ST " SET SEND" M'EN; M'ST " SET SPEED" M'EN; M'ST " SET HANDSHAKE" M'EN; M'ST " SET RECEIVE" M'EN; M'ST " SET LOG" M'EN; M'ST " SET SOH" M'EN; M'ST " SET FAST" M'EN; M'ST " " M'EN; M'ST "type 'SET item ?'for explanation" M'EN; end; << SET DEBUG >> begin M'ST "Syntax: SET DEBUG number" M'EN; M'ST " " M'EN; M'ST "This sets the debug level to the indicated" M'EN; M'ST "number. Currently, only one level exists." M'EN; M'ST "This level is enabled by setting the number to" M'EN; M'ST "any non-negative, non-zero number. If DEBUG is" M'EN; M'ST "enabled, packets sent and received are written" M'EN; M'ST "to the LOG file. The LOG file defaults to the" M'EN; M'ST "job/session output file. LOG output to the " M'EN; M'ST "job/session output file is disabled when commu-" M'EN; M'ST "nications are taking place unless the communica-" M'EN; M'ST "tions line has been re-designated via the SET" M'EN; M'ST "LINE command." M'EN; end; << SET DELAY >> begin M'ST "Syntax: SET DELAY number" M'EN; M'ST " " M'EN; M'ST "Causes a pause for the indicated number of" M'EN; M'ST "seconds prior to starting a SEND command. This" M'EN; M'ST "is to allow the user to escape back to the local" M'EN; M'ST "KERMIT and enter a RECEIVE command." M'EN; end; << SET LINE >> begin M'ST "Syntax: SET LINE ldev" M'EN; M'ST " " M'EN; M'ST "This causes the indicated ldev (logical device" M'EN; M'ST "number) to be used for communications purposes." M'EN; end; << SET SEND >> begin M'ST " { PAUSE 1/10 secs}" M'EN; M'ST " { }" M'EN; M'ST "Syntax: SET SEND { { ON } }" M'EN; M'ST " { BINARY{ OFF } }" M'EN; M'ST " { { AUTO } }" M'EN; M'ST " " M'EN; M'ST "This parameter is used to alter the default" M'EN; M'ST "conditions relating to how files are sent." M'EN; end; << SET SPEED >> begin M'ST "Syntax: SET SPEED speed" M'EN; M'ST " " M'EN; M'ST "Sets the communications speed to the indicated" M'EN; M'ST "number of characters per second. Supported" M'EN; M'ST "speeds are: 30, 60, 120, 480, 960." M'EN; end; << SET HANDSHAKE >> begin M'ST "Syntax: SET HANDSHAKE option" M'EN; M'ST " " M'EN; M'ST "This specifies any handshaking that is to be" M'EN; M'ST "done on the communications line. Options are:" M'EN; M'ST " " M'EN; M'ST "XON Generate an XON character prior to each" M'EN; M'ST "read. This is the default mode and is needed" M'EN; M'ST "in most cases since the HP will ""lose"" any" M'EN; M'ST "characters that are transmitted when no read is" M'EN; M'ST "active. The local KERMIT must be capable of" M'EN; M'ST "waiting for an XON character before issuing a" M'EN; M'ST "a write to the communications line." M'EN; M'ST " " M'EN; M'ST "NONE Generate no special characters prior to a" M'EN; M'ST "read." M'EN; M'ST " " M'EN; M'ST "XON2 Same as XON except in both directions." M'EN; M'ST "This sets the read termination character to XON" M'EN; M'ST "in an attempt to synchronize with another KERMIT" M'EN; M'ST "having similar limitations." M'EN; end; << SET RECEIVE >> case RCVCASE-BINARYV+1 of begin << General stuff >> begin M'ST "The SET RECEIVE parameter is used to alter the" M'EN; M'ST "default conditions regarding file reception." M'EN; M'ST "The various options are:" M'EN; M'ST " " M'EN; M'ST " SET RECEIVE DEVICE" M'EN; M'ST " SET RECEIVE FCODE" M'EN; M'ST " SET RECEIVE BINARY" M'EN; M'ST " SET RECEIVE RECLEN" M'EN; M'ST " SET RECEIVE FIXREC" M'EN; M'ST " SET RECEIVE BLOCKF" M'EN; M'ST " SET RECEIVE MAXREC" M'EN; M'ST " SET RECEIVE MAXEXT" M'EN; M'ST " SET RECEIVE SAVESP" M'EN; M'ST " SET RECEIVE PROG" M'EN; M'ST " SET RECEIVE TEXT" M'EN; M'ST " SET RECEIVE TXT80" M'EN; M'ST " SET RECEIVE BIN128" M'EN; M'ST " SET RECEIVE EXPTAB" M'EN; end; << SET RECEIVE BINARY >> begin M'ST "Syntax: SET RECEIVE BINARY { ON }" M'EN; M'ST " { OFF }" M'EN; M'ST " " M'EN; M'ST "BINARY tells how to store received files on the" M'EN; M'ST "3000." M'EN; M'ST " ON Store files as binary." M'EN; M'ST " OFF Store files as ASCII." M'EN; end; << SET RECEIVE DEVICE >> begin M'ST "Syntax: SET RECEIVE DEVICE [ dev ]" M'EN; M'ST " " M'EN; M'ST "DEVICE specifies the device class for received" M'EN; M'ST "files. Default is DISC. This command can be" M'EN; M'ST "used to send files directly to the system line" M'EN; M'ST "printer." M'EN; M'ST " " M'EN; end; << SET RECEIVE FCODE >> begin M'ST "Syntax: SET RECEIVE FCODE n" M'EN; M'ST " " M'EN; M'ST "FCODE specifies the file code for received files." M'EN; end; << SET RECEIVE RECLEN >> begin M'ST "Syntax: SET RECEIVE RECLEN [-]n" M'EN; M'ST " " M'EN; M'ST "RECLEN specifies the maximum record length (n)" m'en; M'ST "for a received file. As with other HP file " M'EN; M'ST "system commands, n is assumed to be words if" M'EN; M'ST "positive and bytes if negative" M'EN; end; << SET RECEIVE BLOCKF >> begin M'ST "Syntax: SET RECEIVE BLOCKF n" M'EN; M'ST " " M'EN; M'ST "BLOCKF specifies the blocking factor for received" M'EN; M'ST "files. If n is 0, the file system will calculate" M'EN; M'ST "a blocking factor automatically." M'EN; end; << SET RECEIVE FIXREC >> begin M'ST "Syntax: SET RECEIVE FIXREC { ON }" M'EN; M'ST " { OFF }" M'EN; M'ST " " M'EN; M'ST "FIXREC is used to identify fixed or variable" M'EN; M'ST "length records. Options are:" M'EN; M'ST " ON Use fixed length records." M'EN; M'ST " OFF Use variable length records."M'EN; end; << SET RECEIVE MAXREC >> begin M'ST "Syntax: SET RECEIVE MAXREC n" M'EN; M'ST " " M'EN; M'ST "MAXREC specifies the maximum number of records" M'EN; M'ST "that can be stored in a received file." M'EN; end; << SET RECEIVE MAXEXT >> begin M'ST "Syntax: SET RECEIVE MAXEXT n" M'EN; M'ST " " M'EN; M'ST "MAXEXT specifies the maximum number of extents" M'EN; M'ST "for a received file. This number (n) must be in" M'EN; M'ST "the range 1 ... 32." M'EN; end; << SET RECEIVE SAVESP >> begin M'ST "Syntax: SET RECEIVE SAVESP { ON }" M'EN; M'ST " { OFF }" M'EN; M'ST " " M'EN; M'ST "SAVESP specifies if unused file space at the end" M'EN; M'ST "of the file is to be returned to the operating" M'EN; M'ST "system. Options are:" M'EN; M'ST " ON Return unused apace" M'EN; M'ST " OFF Do not return unused apace"M'EN; end; << SET RECEIVE PROG >> begin M'ST "Syntax: SET RECEIVE PROG" M'EN; M'ST " " M'EN; M'ST "PROG will set all of the other parameters needed" M'EN; M'ST "to receive an HP 3000 program (executable) file." M'EN; M'ST "It is equivalent to:" M'EN; M'ST " SET RECEIVE BINARY ON" M'EN; M'ST " SET RECEIVE FIXREC ON" M'EN; M'ST " SET RECEIVE FCODE 1029" M'EN; M'ST " SET RECEIVE RECLEN 128" M'EN; M'ST " SET RECEIVE BLOCKF 1" M'EN; M'ST " SET RECEIVE MAXEXT 1" M'EN; end; << SET RECEIVE BIN128 >> begin M'ST "Syntax: SET RECEIVE BIN128" M'EN; M'ST " " M'EN; M'ST "BIN128 sets up the needed parameters for recei-" M'EN; M'ST "ving a binary file in the ""normal"" HP repre-" M'EN; M'ST "sentation. It is equivalent to:" M'EN; M'ST " SET RECEIVE BINARY ON" M'EN; M'ST " SET RECEIVE FIXREC OFF" M'EN; M'ST " SET RECEIVE FCODE 0" M'EN; M'ST " SET RECEIVE RECLEN 128" M'EN; M'ST " SET RECEIVE BLOCKF 0" M'EN; end; << SET RECEIVE TEXT >> begin M'ST "Syntax: SET RECEIVE TEXT" M'EN; M'ST " " M'EN; M'ST "TEXT sets up the needed parameters for reciving" M'EN; M'ST """generic"" text files. It is equivalent to:" M'EN; M'ST " SET RECEIVE BINARY OFF" M'EN; M'ST " SET RECEIVE FIXREC OFF" M'EN; M'ST " SET RECEIVE FCODE 0" M'EN; M'ST " SET RECEIVE RECLEN -254" M'EN; M'ST " SET RECEIVE BLOCKF 0" M'EN; end; << SET RECEIVE TXT80 >> begin M'ST "Syntax: SET RECEIVE TXT80" M'EN; M'ST " " M'EN; M'ST "TXT80 sets up the needed parameters for recei-" M'EN; M'ST "ving 80 character text files in the manner that" M'EN; M'ST "is most convenient for the typical text editor" M'EN; M'ST "on the HP. It is equivalent to:" M'EN; M'ST " SET RECEIVE BINARY OFF" M'EN; M'ST " SET RECEIVE FIXREC ON" M'EN; M'ST " SET RECEIVE FCODE 0" M'EN; M'ST " SET RECEIVE RECLEN -80" M'EN; M'ST " SET RECEIVE BLOCKF 16" M'EN; end; << SET RECEIVE EXPTAB >> begin M'ST "Syntax: SET RECEIVE EXPTAB { ON }" M'EN; M'ST " { OFF }" M'EN; M'ST " " M'EN; M'ST "EXPTAB expands horizontal tabs found in the" M'EN; M'ST "data. Tab stops are assumed to be at columns" M'EN; M'ST "1, 9, 17, 25, etc." M'EN; end; end; << case SET RECEIVE >> << SET LOG >> begin M'ST "Syntax: SET LOG { [ filespec ] }" M'EN; M'ST " { PURGE }" M'EN; M'ST " " M'EN; M'ST "This command sets the LOG file to the indicated" M'EN; M'ST "filespec. Error and DEBUG messages (if enabled)" M'EN; M'ST "are written to the LOG file (see SET DEBUG)." M'EN; M'ST "If filespec is not specified, the current LOG" M'EN; M'ST "file, if open, is closed. If PURGE is specified," M'EN; M'ST "the file is closed and purged." M'EN; end; << SET SOH >> begin M'ST "Syntax: SET SOH [%]n" M'EN; M'ST " " M'EN; M'ST "This option sets the value of the start-of-header" M'EN; M'ST "character used to begin each packet. If the %-" M'EN; M'ST "sign is used, n is assumed to be octal. Other-" M'EN; M'ST "wise n is assumed to be decimal. Default value" M'EN; M'ST "for SOH is 1." M'EN; end; << SET FAST >> begin M'ST "Syntax: SET FAST {ON }" M'EN; M'ST " {OFF}" M'EN; M'ST " " M'EN; M'ST "FAST ON shortens both the number of timeouts " M'EN; M'ST "and the timeout time for receiving packets. " M'EN; M'ST "It is intended primarily for machine-to-machine" M'EN; M'ST "RECEIVES by this Kermit when there are also a" M'EN; M'ST "number of files stacked up to be transmitted by" M'EN; M'ST "this Kermit. The timing out may be too fast for" M'EN; M'ST "a human sitting at a PC Keyboard, and should " M'EN; M'ST "probably not be used in that case." M'EN; end; end; end; << SET (LEVEL) case >> << EXIT >> begin M'ST "Syntax: {EXIT}" M'EN; M'ST " {QUIT}" M'EN; M'ST " " M'EN; M'ST "This command causes the HP KERMIT process to" M'EN; M'ST "terminate in an orderly manner." M'EN; end; << DIR >> begin M'ST "Syntax: DIR [filespec]" M'EN; M'ST " " M'EN; M'ST "This command searches the disc directory for the" M'EN; M'ST "indicated filespec, if any. Wildcard characters" M'EN; M'ST "may be used." M'EN; end; << SPACE >> begin M'ST "Syntax: SPACE [groupspec]" M'EN; M'ST " " M'EN; M'ST "This command reports the amount of in-use and" M'EN; M'ST "available disc for the user's account and group." M'EN; M'ST "(Groupspec may not be valid if the logon user does" M'EN; M'ST "not have account manager capability.)" M'EN; end; << DELETE >> begin M'ST "Syntax: DELETE filespec" M'EN; M'ST " " M'EN; M'ST "This command causes the indicated filespec to be" M'EN; M'ST "removed from disc." M'EN; end; << TYPE >> begin M'ST "Syntax: TYPE filespec" M'EN; M'ST " " M'EN; M'ST "TYPE lists a file on your terminal." M'EN; end; << STATUS >> begin M'ST "Syntax: { STATUS }" M'EN; M'ST " { VERIFY }" M'EN; M'ST " " M'EN; M'ST "STATUS provides a listing of the current file and" M'EN; M'ST "transmission attributes." M'EN; end; end; << ITEM case >> M'ST " " M'EN; IB(ILEN-1) := " "; <<Hopefully wipe out question mark>> FWRITE(CONUM, IB'W, -ILEN, %320); end; $PAGE $PAGE "CMDINT - Command Interpreter" $control segment=CMDINT'S integer procedure SEARCH(TARGET, LENGTH, DICT, DEFN, START); value LENGTH, START; integer LENGTH, START; byte array TARGET, DICT; byte pointer DEFN; begin integer I; byte pointer P; SEARCH:=I:=0; @P:=@DICT; while P( P(0)-1 ) < byte( START ) do @P := @P + integer( P(0) ); while P(0) <> 0 do begin I:=I+1; if LENGTH <= integer( P(1) ) then if TARGET = P(2), (LENGTH) then if LENGTH >= MIN'SIZE( integer( P(P(0)-1) ) ) then begin SEARCH:=I; @DEFN:=@P + integer( P(0) )-1; return; end; @P:=@P + integer( P(0) ); end; end; <<---------------------------------------------------------------->> procedure CMDINT(ICMD,ICLEN); value ICLEN ; integer ICLEN ; byte array ICMD ; begin byte array CPARM(0:79); << Current Parameter >> byte pointer ITEMPTR, << Points to found item >> IB'PTR; << Moves along input line >> integer CPLEN, << Length of CPARM >> CPVAL, << Numeric value found >> ITEM, << Index of CPARM word >> IBX, << Index to IB >> IBYTE, << Current Character >> X; << Temp Variable >> double D'X; << Temp Double >> logical DONE := false, << Done Flag >> XFROK; << Xfer OK flag >> real P'INT, << PAUSE Interval>> BRIEFLY := 1.0;<< Give COMMAND some time >> label TAKE'EXIT, SEND'EXIT, RECEIVE'EXIT, SERVE'EXIT, SET'EXIT; <<----------------------------------------------------------->> subroutine SCANIT(START); value START; integer START; begin ITEM:=NULLV; << Default return >> CPLEN:=0; scan IB'PTR while "^ ", 1; << Skip blanks >> if CARRY then << End of input >> begin del; << Cut back stack >> return; end; @IB'PTR:=TOS; << Point at the non-blank >> if IB'PTR = ALPHA or IB'PTR = "@" then begin do begin move CPARM(CPLEN):=IB'PTR while ANS, 0; @IB'PTR:=TOS; << Points after moved entity >> CPLEN:=TOS - @CPARM; if IB'PTR = "." or IB'PTR = "@" or IB'PTR = "/" then begin CPARM(CPLEN):=IB'PTR; CPLEN:=CPLEN+1; @IB'PTR:=@IB'PTR+1; end; end until IB'PTR = SPECIAL; if SEARCH(CPARM, CPLEN, RESWDS, ITEMPTR, START) > 0 then ITEM:=integer(ITEMPTR); return; end; if "0" <= integer(IB'PTR) <= "9" or IB'PTR = "-" or IB'PTR = "%" then begin << It looks numeric. Will know for sure later. >> if IB'PTR = "-" or IB'PTR = "%" then begin move CPARM:=IB'PTR, (1), 2; @IB'PTR:=@IB'PTR+1; end else TOS:=@CPARM; if not ("0" <= integer(IB'PTR) <= "9") then begin del; << Cut back stack >> return; end; move *:=IB'PTR while N, 0; << Move numeric >> @IB'PTR:=TOS; << Points after number>> CPLEN:=TOS - @CPARM; CPVAL:=binary(CPARM, CPLEN); if = then << If this is bad then move numeric is bad >> ITEM:=NUMBERV; return; end; if IB'PTR = "?" then begin ITEM:=QMARKV; @IB'PTR:=@IB'PTR+1; return; end; << At this point the item found is not alphanumeric, >> << numeric (including optional minus sign), or question >> << mark. Pass it back for the command processor to work >> << with. >> TOS:=@CPARM; while IB'PTR <> " " and IB'PTR <> "^" do begin move *:=IB'PTR, (1), 2; CPLEN:=CPLEN+1; @IB'PTR:=@IB'PTR+1; end; del; << Cut back stack >> end; <<----------------------------------------------------------->> subroutine READ'USER(PROMPT); value PROMPT; logical PROMPT; begin IBX := 0; << Index to zero >> if ICLEN <> 0 then begin move IB := ICMD,(ICLEN); ILEN := ICLEN; ICLEN := 0; end else begin << Not initial command >> if CTLY then begin M'ST " " M'EN; M'ST "<CONTROL-Y>" M'EN; M'ST " " M'EN; if TAKENUM <> 0 then begin FCLOSE(TAKENUM,0,0); TAKENUM := 0; end; CTLY := false; end; if TAKENUM <> 0 then begin << Open TAKE file >> ILEN := FREAD(TAKENUM,IB'W,-72); if > then begin << End of file >> FCLOSE(TAKENUM,0,0); TAKENUM := 0; end else if < then begin M'ST "Read error on TAKE file" M'EN; FCLOSE(TAKENUM,0,0); TAKENUM := 0; end; end; if TAKENUM = 0 then do begin if PROMPT then begin move PBUF := "KERMIT3000>"; FWRITE(CONUM,PBUF'W,-11,%320); end; ILEN := FREAD(CINUM,IB'W,-80); if <> then begin move IB := "EXIT"; ILEN := 4; end; end until ILEN > 0 or not PROMPT; end; @IB'PTR:=@IB; IB(ILEN):="^"; << Stopper >> MY'JCW'VAL := IDLING; end; <<----------------------------------------------------------->> while not DONE do begin READ'USER(TRUE); SCANIT(NULLV); if TAKEV <= ITEM <= VERIFYV then case ITEM-1 of begin << TAKE >> begin SCANIT(QMARKV); while ITEM = QMARKV do begin HELP(TAKEV); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to TAKE'EXIT; end; if ITEM <> NULLV then << No reserved words allowed >> begin M'ST "Cannot use reserved word for filespec." M'EN; go to TAKE'EXIT; end; CPARM(CPLEN) := " "; if TAKENUM <> 0 then begin FCLOSE(TAKENUM,0,0); TAKENUM := 0; end; TAKENUM := FOPEN(CPARM,%5,%2000); if TAKENUM = 0 then begin M'ST "take error" M'EN; end; TAKE'EXIT: end; << SEND >> begin SCANIT(QMARKV); << get local file name >> while ITEM = QMARKV do begin HELP(SENDV); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to SEND'EXIT; end; MY'JCW'VAL := SEND'NG; << pessimism >> while CPLEN = 0 do begin move PBUF:="HP3000 file name?"; FWRITE(CONUM,PBUF'W,-17,%320); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to SEND'EXIT; end; move L'FNAME := CPARM,(CPLEN); L'FNAME(CPLEN) := " "; L'FNAME'LEN := CPLEN; if not VALID'FILE(L'FNAME, L'FNAME'LEN, OUT) then begin M'ST ("Kermit file security error - ", "see your account manager") M'EN; DNUM := 0; go to SEND'EXIT; end; DNUM := FOPEN(L'FNAME,5,0); if DNUM = 0 then begin M'ST "File open error" M'EN; end else begin SCANIT(QMARKV); if CPLEN <> 0 then begin move R'FNAME := CPARM,(CPLEN); end; R'FNAME'LEN := CPLEN; if not OPEN'LINE then begin M'ST "Line open failure" M'EN; end else begin M'ST ("Escape back to your local KERMIT ", "and enter the RECEIVE command") M'EN; if I'DELAY > 0 then begin P'INT := real(I'DELAY); PAUSE(P'INT); end; if R'FNAME'LEN <> 0 then XFROK := SENDSW(R'FNAME, -R'FNAME'LEN) else XFROK := SENDSW(L'FNAME, -L'FNAME'LEN); STATE := SBREAK; if LDEV'CI = LDEV'LINE then SHUT'LINE; << Echo on, etc. >> if not XFROK then begin M'ST "SEND failure" M'EN; end else begin M'ST "SEND completed" M'EN; end; end; end; SEND'EXIT: PUTJCW(KERM'JCW, MY'JCW'VAL, JCW'ERR); L'FNAME'LEN := 0; end; << RECEIVE >> begin SCANIT(QMARKV); while ITEM = QMARKV do begin HELP(RECEIVEV); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to RECEIVE'EXIT; end; MY'JCW'VAL := RECV'NG; << pessimism >> while CPLEN = 0 do begin move PBUF:="HP3000 file name?"; FWRITE(CONUM,PBUF'W,-17,%320); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to RECEIVE'EXIT; end; move L'FNAME := CPARM,(CPLEN); L'FNAME'LEN := CPLEN; if VALID'FILE(L'FNAME, L'FNAME'LEN, IN) then << Its ok. No action necessary. >> else begin M'ST ("Kermit file security error - ", "see your account manager") M'EN; go to RECEIVE'EXIT; END; move PBUF:="listf ", 2; move *:=L'FNAME, (L'FNAME'LEN), 2; move *:=(";$null", %15); COMMAND(PBUF, ERROR, PARM); if > then << OK. Its not there already. >> else begin move PBUF:= "File is already present. OK to remove? (Y/N)", 2; PLEN:=TOS-@PBUF; FWRITE(CONUM, PBUF'W, -PLEN, %320); READ'USER(FALSE); SCANIT(ONV); if ITEM=YESV then begin move PBUF:="purge ",2; move*:=L'FNAME, (L'FNAME'LEN), 2; move *:=%15; COMMAND(PBUF, ERROR, PARM); end else begin M'ST "RECEIVE attempt abandoned" M'EN; go to RECEIVE'EXIT; end; end; if not OPEN'LINE then begin M'ST "Line open error" M'en; end else begin M'ST ("Escape back to your local KERMIT ", "and enter the SEND command") M'EN; XFROK := RECSW(false); if LDEV'CI = LDEV'LINE then SHUT'LINE; << Echo on, etc. >> if not XFROK then begin M'ST "RECEIVE error" M'EN; end else begin M'ST "RECEIVE complete" M'EN; end; end; RECEIVE'EXIT: PUTJCW(KERM'JCW, MY'JCW'VAL, JCW'ERR); L'FNAME'LEN := 0; end; << SERVE >> begin SCANIT(QMARKV); if ITEM = QMARKV then begin HELP(SERVEV); READ'USER(FALSE); if CTLY then go to SERVE'EXIT; end; if not OPEN'LINE then begin M'ST "Line open failure" M'EN; end else begin M'ST ("Entering SERVER mode - ", "escape back to your local KERMIT") M'EN; SERVER; if LDEV'CI = LDEV'LINE then SHUT'LINE; <<DONE := not CTLY;>> end; SERVE'EXIT: end; << SET >> begin SCANIT(DEBUGV); if ITEM = QMARKV then begin HELP(SETV, DEBUGV-1); READ'USER(FALSE); SCANIT(DEBUGV); if CTLY then go to SET'EXIT; end; if not (DEBUGV <= ITEM <= FASTV) then begin M'ST "set error" M'EN end else case ITEM - DEBUGV of begin << SET DEBUG >> begin SCANIT(QMARKV); while ITEM = QMARKV do begin HELP(SETV, DEBUGV); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to SET'EXIT; end; if ITEM = NUMBERV then DEBUG'MODE:=CPVAL else begin M'ST "set debug error" M'EN; end; end; << SET DELAY >> begin SCANIT(QMARKV); while ITEM = QMARKV do begin HELP(SETV, DELAYV); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to SET'EXIT; end; if CPLEN = 0 then begin I'DELAY := 0; end else begin if ITEM = NUMBERV then I'DELAY:=CPVAL else begin M'ST "set delay error" M'EN; end; end; end; << SET LINE >> begin SCANIT(QMARKV); while ITEM = QMARKV do begin HELP(SETV, LINEV); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to SET'EXIT; end; if CPLEN = 0 then begin LDEV'LINE := 0; SHUT'LINE; end else begin if ITEM <> NUMBERV then begin M'ST "set line error" M'EN; end else begin LDEV'LINE:=CPVAL; SHUT'LINE; end; end; ASCII(LDEV'LINE,-10,KERM'JCW(7)); end; << SET SEND >> begin SCANIT(PAUSEV); while ITEM = QMARKV do begin HELP(SETV, SENDV'1); READ'USER(FALSE); SCANIT(PAUSEV); if CTLY then go to SET'EXIT; end; if ITEM = PAUSEV then begin SCANIT(QMARKV); if ITEM <> NUMBERV then begin M'ST "send pause error" M'EN; end else PAUSE'CNT:=CPVAL; end else if ITEM = BINARYV then begin SCANIT(AUTOV); << POTENTIAL TROUBLE >> if (AUTOV <= ITEM <= OFFV) then SND'BINARY:=ITEM-AUTOV else begin M'ST "set send binary error" M'EN; end; end else begin M'ST "set send error" M'EN; end end; << SET SPEED >> begin SCANIT(QMARKV); while ITEM = QMARKV do begin HELP(SETV, SPEEDV); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to SET'EXIT; end; X := CPVAL; if (X <> 30) land (X <> 60) land (X <> 120) land (X <> 240) land (X <> 480) land (X <> 960) then begin M'ST "Invalid SPEED, use 30,60,120,240,480,960" M'EN; end else TSPEED := X; end; << SET HANDSHAKE >> begin SCANIT(ONV); while ITEM = QMARKV do begin HELP(SETV, HANDSHAKEV); READ'USER(FALSE); SCANIT(ONV); if CTLY then go to SET'EXIT; end; if (NONEV <= ITEM <= XON2V) then HNDSHK:=ITEM-NONEV else begin M'ST "set handshake error" M'EN; end; end; << SET RECEIVE >> begin SCANIT(PAUSEV); while ITEM = QMARKV do begin HELP(SETV, RECEIVEV'1, BINARYV-1); READ'USER(FALSE); SCANIT(PAUSEV); if CTLY then go to SET'EXIT; end; if not (BINARYV <= ITEM <= EXPTABV) then begin M'ST "set receive error" M'EN; end else case ITEM-BINARYV of begin << SET RECEIVE BINARY >> begin SCANIT(ONV); while ITEM = QMARKV do begin HELP(SETV, RECEIVEV'1, BINARYV); READ'USER(FALSE); SCANIT(ONV); if CTLY then go to SET'EXIT; end; if ITEM = ONV or ITEM = OFFV then RCV'BINARY:=(ITEM=ONV) else begin M'ST "set receive binary error" M'EN; end; end; << SET RECEIVE DEVICE >> begin SCANIT(QMARKV); while ITEM = QMARKV do begin HELP(SETV, RECEIVEV'1, DEVICEV); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to SET'EXIT; end; if CPLEN <> 0 then begin move RCV'DEV := CPARM,(CPLEN); RCV'DEV(CPLEN) := CR; end else move RCV'DEV := ("DISC", CR); end; << SET RECEIVE FCODE >> begin SCANIT(QMARKV); while ITEM = QMARKV do begin HELP(SETV, RECEIVEV'1, FCODEV); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to SET'EXIT; end; if ITEM <> NUMBERV then begin M'ST "set receive fcode error" M'EN; end else begin RCV'FCODE := CPVAL; end; end; << SET RECEIVE RECLEN >> begin SCANIT(QMARKV); while ITEM = QMARKV do begin HELP(SETV, RECEIVEV'1, RECLENV); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to SET'EXIT; end; if ITEM <> NUMBERV then begin M'ST "set receive reclen error" M'EN; end else if CPVAL <> 0 then begin RCV'RECLEN := CPVAL; end else RCV'RECLEN := -254; end; << SET RECEIVE BLOCKF >> begin SCANIT(QMARKV); while ITEM = QMARKV do begin HELP(SETV, RECEIVEV'1, BLOCKFV); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to SET'EXIT; end; if ITEM <> NUMBERV then begin M'ST "set receive blockf error" M'EN; end else begin RCV'BLOCKF := CPVAL; end; end; << SET RECEIVE FIXREC >> begin SCANIT(ONV); while ITEM = QMARKV do begin HELP(SETV, RECEIVEV'1, FIXRECV); READ'USER(FALSE); SCANIT(ONV); if CTLY then go to SET'EXIT; end; if ITEM = ONV or ITEM = OFFV then RCV'FIXREC:=(ITEM=ONV) else begin M'ST "set receive fixrec error" M'EN; end; end; << SET RECEIVE MAXREC >> begin SCANIT(QMARKV); while ITEM = QMARKV do begin HELP(SETV, RECEIVEV'1, MAXRECV); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to SET'EXIT; end; D'X := DBINARY(CPARM,CPLEN); if <> then begin M'ST "set receive maxrec error" M'EN; end else begin RCV'MAXREC := D'X; end end; << SET RECEIVE MAXEXT >> begin SCANIT(QMARKV); while ITEM = QMARKV do begin HELP(SETV, RECEIVEV'1, MAXEXTV); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to SET'EXIT; end; if ITEM <> NUMBERV then begin M'ST "set receive maxext error" M'EN; end else begin RCV'MAXEXT := CPVAL; end end; << SET RECEIVE SAVESP >> begin SCANIT(ONV); while ITEM = QMARKV do begin HELP(SETV, RECEIVEV'1, SAVESPV); READ'USER(FALSE); SCANIT(ONV); if CTLY then go to SET'EXIT; end; if ITEM = ONV or ITEM = OFFV then RCV'SAVESP:=(ITEM=ONV) else begin M'ST "set receive savesp error" M'EN; end; end; << SET RECEIVE PROG >> begin SCANIT(QMARKV); while ITEM = QMARKV do if ITEM = QMARKV then begin HELP(SETV, RECEIVEV'1, PROGV); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to SET'EXIT; end; RCV'BINARY := true; RCV'FIXREC := true; RCV'FCODE := 1029; RCV'RECLEN := 128; RCV'BLOCKF := 1; RCV'MAXEXT := 1; end; << SET RECEIVE BIN128 >> begin SCANIT(QMARKV); while ITEM = QMARKV do if ITEM = QMARKV then begin HELP(SETV, RECEIVEV'1, BIN128V); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to SET'EXIT; end; RCV'BINARY := true; RCV'FIXREC := false; RCV'FCODE := 0; RCV'RECLEN := 128; RCV'BLOCKF := 0; end; << SET RECEIVE TEXT >> begin SCANIT(QMARKV); while ITEM = QMARKV do if ITEM = QMARKV then begin HELP(SETV, RECEIVEV'1, TEXTV); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to SET'EXIT; end; RCV'BINARY := false; RCV'FIXREC := false; RCV'FCODE := 0; RCV'RECLEN := -254; RCV'BLOCKF := 0; end; << SET RECEIVE TXT80 >> begin SCANIT(QMARKV); while ITEM = QMARKV do begin HELP(SETV, RECEIVEV'1, TXT80V); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to SET'EXIT; end; RCV'BINARY := false; RCV'FIXREC := true; RCV'FCODE := 0; RCV'RECLEN := -80; RCV'BLOCKF := 16; end; << SET RECEIVE EXPTAB >> begin SCANIT(ONV); while ITEM = QMARKV do begin HELP(SETV, RECEIVEV'1, EXPTABV); READ'USER(FALSE); SCANIT(ONV); if CTLY then go to SET'EXIT; end; if ITEM = ONV or ITEM = OFFV then EXP'TABS:=(ITEM=ONV) else begin M'ST "set receive exptab error" M'EN; end; end; end; << SET RECEIVE cases >> end; << SET LOG >> begin SCANIT(PAUSEV); while ITEM = QMARKV do begin HELP(SETV, LOGV); READ'USER(FALSE); SCANIT(PAUSEV); if CTLY then go to SET'EXIT; end; if LOGNUM <> 0 and LOGNUM <> CONUM then begin if ITEM = PURGEV then begin FCLOSE(LOGNUM,%4,0); CPLEN := 0; end else FCLOSE(LOGNUM,%11,0); LOGNUM := 0; end else if ITEM = PURGEV then CPLEN := 0; << SCANIT; Was done above >> if CPLEN = 0 then begin << Take no action >> end else begin move LOGNAME:=CPARM, (LOGNAME'LEN:=CPLEN); move PBUF:="listf ", 2; move *:=LOGNAME, (LOGNAME'LEN), 2; move *:=(";$null", %15); COMMAND(PBUF, ERROR, PARM); if ERROR=907 then << OK. Its not there already. >> else begin move PBUF:= ("File is already present. ", "Ok to remove? (Y/N)"), 2; PLEN:=TOS-@PBUF; FWRITE(CONUM, PBUF'W, -PLEN, %320); READ'USER(FALSE); SCANIT(ONV); if ITEM=YESV then begin move PBUF:="purge ",2; move *:=LOGNAME, (LOGNAME'LEN), 2; PLEN:=TOS-@PBUF; PBUF(PLEN):=%15; COMMAND(PBUF, ERROR, PARM); end else begin M'ST "SET LOG attempt abandoned" M'EN; go to SET'EXIT; end; end; LOGNAME(LOGNAME'LEN):=" "; LOGNUM:=FOPEN(LOGNAME,%4,%1,64,,,,2,,10016D,32); if LOGNUM = 0 then begin M'ST "File open error" M'EN; end; end; end; << SET SOH >> begin SCANIT(QMARKV); while ITEM = QMARKV do begin HELP(SETV, SOHV); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to SET'EXIT; end; if ITEM = NUMBERV then SOH:=byte(CPVAL) else begin M'ST "set soh error" M'EN; end; end; << SET FAST >> begin SCANIT(ONV); while ITEM = QMARKV do begin HELP(SETV, FASTV); READ'USER(FALSE); SCANIT(ONV); if CTLY then go to SET'EXIT; end; if ITEM = ONV or ITEM = OFFV then IMPATIENT:=(ITEM=ONV) else begin M'ST "set fast error" M'EN; end; end; end; << SET cases >> SET'EXIT: end; << EXIT >> begin SCANIT(QMARKV); while ITEM = QMARKV do begin HELP(EXITV); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to EXIT'EXIT; end; DONE := true; EXIT'EXIT: end; << DIR >> begin SCANIT(QMARKV); while ITEM = QMARKV do begin HELP(DIRV); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to DIR'EXIT; end; begin move PBUF := "LISTF ", 2; move * := CPARM, (CPLEN), 2; move * := (", 2", CR); COMMAND(PBUF, ERROR, PARM); if ERROR > 0 then begin move PBUF := "CIerror ", 2; PLEN := TOS-@PBUF; PLEN := PLEN+ASCII(ERROR, 10, PBUF(PLEN)); FWRITE(CONUM, PBUF'W, -PLEN, 0); end; end; DIR'EXIT: end; << SPACE >> begin SCANIT(QMARKV); while ITEM = QMARKV do begin HELP(SPACEV); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to SPACE'EXIT; end; begin move PBUF := "REPORT ", 2; move * := CPARM, (CPLEN), 2; move * := CR; COMMAND(PBUF, ERROR, PARM); if ERROR > 0 then begin move PBUF := "CIerror ", 2; PLEN := TOS-@PBUF; PLEN := PLEN+ASCII(ERROR, 10, PBUF(PLEN)); FWRITE(CONUM, PBUF'W, -PLEN, 0); end else begin M'ST " " M'EN; << Cosmetic output >> end; end; SPACE'EXIT: end; << DELETE >> begin SCANIT(QMARKV); while ITEM = QMARKV do begin HELP(DELETEV); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to DELETE'EXIT; end; if VALID'FILE(CPARM, CPLEN, IN) then begin move PBUF := "PURGE ", 2; move * := CPARM, (CPLEN), 2; move * := CR; COMMAND(PBUF, ERROR, PARM); if ERROR > 0 then begin move PBUF := "CIerror ", 2; PLEN := TOS-@PBUF; PLEN := PLEN+ASCII(ERROR, 10, PBUF(PLEN)); FWRITE(CONUM, PBUF'W, -PLEN, 0); end; PAUSE(BRIEFLY); << Let COMMAND finish >> end else begin M'ST "Filespec missing or invalid" M'EN; end; DELETE'EXIT: end; << TYPE >> begin SCANIT(QMARKV); << get local file name >> while ITEM = QMARKV do begin HELP(TYPEV); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to SEND'EXIT; end; while CPLEN = 0 do begin move PBUF:="HP3000 file name?"; FWRITE(CONUM,PBUF'W,-17,%320); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to SEND'EXIT; end; move L'FNAME := CPARM,(CPLEN); L'FNAME(CPLEN) := " "; L'FNAME'LEN := CPLEN; M'ST " " M'EN; if TYPESW then begin M'ST " " M'EN; M'ST "TYPE completed" M'EN; end else begin M'ST " " M'EN; M'ST "TYPE failure" M'EN; end; L'FNAME'LEN := 0; end; << VERIFY >> begin SCANIT(QMARKV); while ITEM = QMARKV do begin HELP(VERIFYV); READ'USER(FALSE); SCANIT(QMARKV); if CTLY then go to VERIFY'EXIT; end; VERIFY; VERIFY'EXIT: end; end << case >> else if ITEM = QMARKV then HELP(NULLV) else begin M'ST "command error" M'EN; end; end; end; <<*****************************************************************>> $PAGE "Outer Block" $control segment=KERMIT if (TAKE'VAL:=PARM'VAL)=0 then <<Must be in outer block to work>> TAKE'VAL:=GETJCW; if not KINIT then begin QUIT(7300+TAKE'VAL); end else begin CMDINT(INFO'STR,INFO'LEN); SHUT'LINE; if HAVE'KTEMP then KILL'KTEMP; if LOGNUM <> 0 then FCLOSE(LOGNUM, %11, 0); end; END.