home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
hp3000.tar.gz
/
hp3000.tar
/
hp3000spl.txt
< prev
next >
Wrap
Text File
|
1994-09-03
|
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.