/* Program: Lee Hallin (Honeywell Bull, Los Angeles Development Center) with testing and suggestions from J. T. Anderson (Honeywell Bull, Los Angeles Developement Center), and Mike Iglesias and others (University California at Irvine). Many thanks to John Stewart of Carleton University, Tom Erskine of CRC, Mike Iglesias of UC Irvine and Mike Schmidt of Honeywell Bull, Canada, for their help and supplied code for version 1.00. Language: PL-6 Version: 1.00 Date: January, 1988 Please send any questions, bugs and/or suggestions to any of the following: U.S. Mail: Honeywell Bull 5250 West Century Blvd Los Angeles, CA 90045 Attn: Lee Hallin CP-6 Mail on the LADC support machine (aka L66A): Lee Hallin ARPANET Address: Lee-Hallin%LADC@BCO-MULTICS.ARPA 13.1 Introduction This version of Kermit is written in PL-6; a PL/1-like implementation language available on the Honeywell CP-6 operating system. This Kermit contains all of the "basic" Kermit features and several optional/advanced features. Some of the optional features are suggested in the Kermit User's Guide and/or Kermit Protocol Manual, while others where implemented to provide added flexibility on CP-6. The following table briefly summarizes the capabilities of this version of Kermit. Features this Kermit has or can do: Transfers text files Transfers binary files Sends file groups (wildcarding) File overwrite protection Timeouts 8th-bit prefixing Repeat count prefixing Transaction logging Debugging facility Acts as a server Talks to a server (limited) Automatically reads default commands from a file Read commands from a file Help for each of the commands Graceful handling of interrupted group transfers Features not included in this version: Advanced server commands Extended block checks (2 and 3 byte checks) Handling file attributes */ %EJECT; /* The following changes were made to this version of KERMIT to support file transfers through a comgroup rather than the regular terminal mode. 1. This version is minimum CP-6 C01, so the dcbs used with M$EOM (TIMEOUT), M$TRMCTL (ORIG_TRMCTL, STRMCTL) and M$TRMATTR (GTRMATTR) were changed from M$UC to F$PACKET_IN. 2. Commands were added to the parse code to add two new options: CG= comgroup_name, and STATION= station_name. Both these options must be specified for the comgroup stuff to work. This implies changes to three files: HC6KERMIT_PAR, the partrge source file, HC6KERMIT_C61, the include file for both partrge and PL6, and this source file. 3. A bunch of code was added to support comgroup output, and, although this required usually minimal changes to the code, the way timeouts were handled had to modified slightly, since comgroup reads only start to count the timeout after the first character has been received. In this case, timeouts had to be set both via M$EOM and also by EOFTIME. 4. Code has to be added to give some feedback during comgroup based transfers, but this hasn't been done yet. 5. In order to support some communication with other programs, some code was added to set the stepcc. This code is really only useful if the KERMIT invocation only transfers one file. The stepcc only reflects the last 'send' command (and the last file sent if there was more than one). It sets the stepcc as follows: 0: The last file sent made it fine (if there was any request). 2: The last file started but didn't complete. 3: The last file couldn't be found. The stepcc can't be guaranteed to be accurate if a wild- carded send command was used. Bug fixes: Fixed bug in Receive_Pack where inter-packet characters were being considered as a nak; which caused Kermit to go into convulsions, trying to get things straightened out. Fixed bug in server mode: Packet numbers weren't being reset after a Break or Abort in Receive mode. The generic commands Finish and Bye were responding with the current seq number, instead of 0. The Bye command tries to do a bye on the local end, when it's specified that it just does that to the remote end. Neither the Finish nor the Bye command go through the parameter exchange, although there is no guarantee that they aren't the first command ever issued. Oops, I've taken this back out temporarily because it's not working too well. The Bye command (when received by the server) doesn't close the dcbs and exit gracefully, it simply does a !BYE. Of course, if you're debugging OVER a debug file, it doesn't get closed properly, so no debugging info... Fixed by closing F$DEBUG and M$LO before executing !BYE. */ %EJECT; KERMIT: PROC MAIN; %EQU OS_VERSION = 'D00'; /* This is B03, C00, C01, D00 or E00 */ %INCLUDE B_ERRORS_C; %INCLUDE B$JIT; %INCLUDE CP_6; %B$ALT; %B$TCB; %F$DCB; %INCLUDE CP_6_SUBS; /* CLUDE KERMIT_C61; */ %INCLUDE KV_GLBCNS_E; %KV_PRTTYP_E; /* PARITY values */ %INCLUDE XS_MACRO_C; %XSA_PARAM (FPTN=XSA_PARAM); %XSA_ENTRIES; %INCLUDE XU_FORMAT_C; %INCLUDE XU_MACRO_C; %INCLUDE XU_PERR_C; %IF OS_VERSION~='B03'; %INCLUDE XU_SUBS_C; /* For NEVER_ECHO# */ %ENDIF; %INCLUDE XUH_MACRO_C; %XUH_PARAM; %IF OS_VERSION='B03'; %INCLUDE XU_WILDCARD_C; /* In B03 this is in .X */ %ELSE; %INCLUDE XUW_MACRO_C; /* In C00 this is in .:LIBRARY */ %ENDIF; %EJECT; %LIST; %INCLUDE HC6KERMIT_C61; %PLIST; %EJECT; /**/ /* EQUs used to access the PCB */ /**/ %EQU BLK1_NSUBLKS = %CHARTEXT('BLK1$->P_OUT.NSUBLKS'); %EQU BLK1_SUBLK$ = %CHARTEXT('BLK1$->P_OUT.SUBLK$'); %EQU BLK2_NSUBLKS = %CHARTEXT('BLK2$->P_OUT.NSUBLKS'); %EQU BLK2_SUBLK$ = %CHARTEXT('BLK2$->P_OUT.SUBLK$'); %EQU BLK2_CODE = %CHARTEXT('BLK2$->P_SYM.CODE'); %EQU BLK2_COUNT = %CHARTEXT('BLK2$->P_SYM.COUNT'); %EQU BLK2_TEXT = %CHARTEXT('SUBSTR(BLK2$->P_SYM.TEXT,0,BLK2$->P_SYM.COUNT)'); %EQU BLK3_NSUBLKS = %CHARTEXT('BLK3$->P_OUT.NSUBLKS'); %EQU BLK3_SUBLK$ = %CHARTEXT('BLK3$->P_OUT.SUBLK$'); %EQU BLK3_CODE = %CHARTEXT('BLK3$->P_SYM.CODE'); %EQU BLK3_CPOS = %CHARTEXT('BLK3$->P_SYM.CPOS'); %EQU BLK3_COUNT = %CHARTEXT('BLK3$->P_SYM.COUNT'); %EQU BLK3_TEXT = %CHARTEXT('SUBSTR(BLK3$->P_SYM.TEXT,0,BLK3$->P_SYM.COUNT)'); %EQU BLK4_NSUBLKS = %CHARTEXT('BLK4$->P_OUT.NSUBLKS'); %EQU BLK4_SUBLK$ = %CHARTEXT('BLK4$->P_OUT.SUBLK$'); %EQU BLK4_CODE = %CHARTEXT('BLK4$->P_SYM.CODE'); %EQU BLK4_COUNT = %CHARTEXT('BLK4$->P_SYM.COUNT'); %EQU BLK4_TEXT = %CHARTEXT('SUBSTR(BLK4$->P_SYM.TEXT,0,BLK4$->P_SYM.COUNT)'); %EQU BLK5_NSUBLKS = %CHARTEXT('BLK5$->P_OUT.NSUBLKS'); %EQU BLK5_SUBLK$ = %CHARTEXT('BLK5$->P_OUT.SUBLK$'); %EQU BLK5_CODE = %CHARTEXT('BLK5$->P_SYM.CODE'); %EQU BLK5_COUNT = %CHARTEXT('BLK5$->P_SYM.COUNT'); %EQU BLK5_TEXT = %CHARTEXT('SUBSTR(BLK5$->P_SYM.TEXT,0,BLK5$->P_SYM.COUNT)'); %EQU MONERR = %CHARTEXT('B$TCB$->B$TCB.ALT$->B$ALT.ERR'); %EQU ERRDCB = %CHARTEXT('B$TCB$->B$TCB.ALT$->B$ALT.DCB#'); %EJECT; /**/ /* KERMIT type and state EQUs */ /**/ %EQU A_ABORT = 'A'; %EQU B_BREAK = 'B'; %EQU C_COMPLETE = 'C'; %EQU D_DATA = 'D'; %EQU E_ERROR = 'E'; %EQU F_FILE = 'F'; %EQU G_GENERIC = 'G'; %EQU I_INIT = 'I'; %EQU K_KERMIT = 'K'; %EQU N_NAK = 'N'; %EQU R_RINIT = 'R'; %EQU S_SINIT = 'S'; %EQU T_RESERVED = 'T'; %EQU Y_ACK = 'Y'; %EQU Z_EOF = 'Z'; /**/ /* KERMIT subcommand EQUs */ /**/ %EQU C_CWD = 'C'; %EQU D_DIRECTORY = 'D'; %EQU E_ERASE = 'E'; %EQU F_FINISH = 'F'; %EQU H_HELP = 'H'; %EQU I_LOGIN = 'I'; %EQU J_JOURNAL = 'J'; %EQU K_COPY = 'K'; %EQU L_BYE = 'L'; %EQU M_SHORT_MESSAGE = 'M'; %EQU P_PROG_INVOCATION = 'P'; %EQU Q_SERVER_STAT_QUERY = 'Q'; %EQU R_RENAME = 'R'; %EQU T_TYPE = 'T'; %EQU V_VARIABLE_SET_QUERY = 'V'; %EQU W_WHOS_LOGGED_IN = 'W'; %EQU TAB = BINASC(9); %EQU LF = BINASC(10); %EQU CR = BINASC(13); %EQU SUB = BINASC(26); %EQU DEL = BINASC(127); /**/ /* EQUs for LOG file keys (fractional portion of EDIT key) */ /**/ %EQU LOG_HEADER# = 000; %EQU LOG_STRT_SEND# = 101; %EQU LOG_END_SEND# = 102; %EQU LOG_STRT_RECEIVE# = 103; %EQU LOG_END_RECEIVE# = 104; %EQU LOG_MAX_PACKET_SIZES# = 200; %EQU LOG_NUM_DATA_PACKETS# = 300; %EQU LOG_NUM_BYTES_SENT# = 400; %EQU LOG_NUM_BYTES_RCVD# = 500; %EQU LOG_ELAPSED_TIME# = 600; %EQU LOG_ERRMSG# = 700; /**/ /* Miscellaneous EQUs */ /**/ %EQU MAX_EXTENSIONS# = 30; %EQU NOTHING# = 0; %EQU BUILD_SEQUENCE# = 1; %EQU PUT_CHAR_IN_PACKET# = 2; %EQU STUFF_CHAR_IN_PACKET# = 3; %EJECT; /**/ /* Miscellaneous FPTs */ /**/ %FPT_INT (FPTN = BREAK_CNTRL, UENTRY=KERMIT$BREAK ); %FPT_EXIT (FPTN = SET_STEPCC, STEPCC=OK ); %VLP_ERRCODE (FPTN = ERRCODE ); %FPT_WRITE (FPTN = FPT_WRITE, DCB=M$LO ); %IF OS_VERSION='B03'; %FPT_YC (FPTN = FPT_YC, CMD=CMD_BUF ); %ELSE; %FPT_YC (FPTN = FPT_YC, CMD=CMD_BUF, LINK=YES ); %ENDIF; %FPT_FID (FPTN = FID_IO, ACCT=IO_ACCT, ASN=MERGE_IN.V.ASN#, NAME=TARGET, PASS=IO_PASS, RES=MERGE_IN.V.RES#, SN=IO_SN, TEXTFID=SRCE_FID ); %VLP_ACCT (FPTN = IO_ACCT ); %VLP_NAME (FPTN = IO_NAME ); %VLP_PASS (FPTN = IO_PASS ); %VLP_SN (FPTN = IO_SN ); %FPT_FID (FPTN = FID_CG, ACCT=CG_ACCT, ASN=CG_ASN, NAME=CG_NAME, PASS=CG_PASS, TEXTFID=CG_FID); %VLP_ACCT (FPTN = CG_ACCT ); %VLP_NAME (FPTN = CG_NAME ); %VLP_PASS (FPTN = CG_PASS ); %VLP_SN (FPTN = CG_SN ); %FPT_OPEN (FPTN = OPEN_CG_OUT, DCB=F$PACKET_OUT, FUN=UPDATE, SHARE=ALL, ORG=TERMINAL, NAME=CG_NAME, ACCT=CG_ACCT, PASS=CG_PASS, ASN=COMGROUP, SETSTA=CG_STATION); %FPT_OPEN (FPTN = OPEN_CG_IN, DCB=F$PACKET_IN, FUN=UPDATE, SHARE=ALL, ORG=TERMINAL, NAME=CG_NAME, ACCT=CG_ACCT, PASS=CG_PASS, ASN=COMGROUP, SETSTA=CG_STATION); %VLP_SETSTA (FPTN = CG_STATION); /* ILOCK=YES, */ /* OLOCK=YES */ %VLP_STATION (FPTN = MY_STATION); %FPT_OPEN (FPTN = MERGE_IN, ACCT=IO_ACCT, DCB=F$IN, FUN=IN, NAME=IO_NAME, PASS=IO_PASS, SETDCB=YES, SN=IO_SN ); %FPT_OPEN (FPTN = OPEN_IO, DCB=F$IN ); %FPT_OPEN (FPTN = TEST_OPEN_IO, DCB=F$IN ); %FPT_CLOSE (FPTN = FPT_CLOSE, DISP=SAVE, RELG=YES ); %FPT_TIME (FPTN = GET_UTS, DEST=UTS, SOURCE=CLOCK, TSTAMP=UTS ); %FPT_TIME (FPTN = GET_TIME, DEST=LOCAL, SOURCE=CLOCK, TIME=HHMMSSSS ); %FPT_TIME (FPTN = CONVERT_UTS, DATE=MMMDDYY, DAY=DAY, DEST=EXT, SOURCE=UTS, TIME=HHMMSSSS, TSTAMP=UTS ); %FPT_WAIT (FPTN = FPT_WAIT ); %FPT_READ (FPTN = READ_IN, /* BUF=IO_BUF, */ DCB=F$IN ); %FPT_READ (FPTN = READ_PACKET, /* BUF=PACKET, */ DCB=F$PACKET_IN, STATION = MY_STATION, TRANS=YES ); %FPT_WRITE (FPTN = WRITE_PACKET, /* BUF=PACKET, */ DCB=F$PACKET_OUT, STATION = MY_STATION, TRANS=YES, VFC=NO ); %FPT_EOM (FPTN = TIMEOUT, DCB=F$PACKET_IN, STATION = MY_STATION, EOMTABLE=VLP_EOMTABLE, TIMEOUT=123, UTYPE=SEC ); %VLP_EOMTABLE(FPTN = VLP_EOMTABLE, VALUES="008,044,000,047,000,000,000,000,000,000,000,000,000,000,000,000"); /* */ /* */ /* LF DC2 */ /* */ /* EOT FF DC4 */ /* CR NAK */ /* SYN */ /* ETB */ %FPT_TRMCTL (FPTN = ORIG_TRMCTL, DCB=F$PACKET_IN, STATION = MY_STATION, STCLASS="STATIC SYMDEF", TRMCTL=VLP_GTRMCTL ); %VLP_TRMCTL (FPTN = VLP_GTRMCTL ); %FPT_TRMCTL (FPTN = STRMCTL, DCB=F$PACKET_IN, STATION = MY_STATION, TRMCTL=VLP_STRMCTL ); %VLP_TRMCTL (FPTN = VLP_STRMCTL, ACTONTRN=YES ); %FPT_TRMATTR (FPTN = FPT_GTRMATTR, DCB=F$PACKET_IN, STATION = MY_STATION, TRMATTR=VLP_GTRMATTR); %VLP_TRMATTR (FPTN = VLP_GTRMATTR ); %FPT_WRITE (FPTN = WRITE_DEBUG, DCB=F$DEBUG, KEY=DEBUG_KEY ); %FPT_WRITE (FPTN = WRITE_LOG, DCB=F$LOG, KEY=LOG_KEY ); %FPT_WRITE (FPTN = WRITE_OUT, /* BUF=IO_BUF, */ DCB=F$OUT ); %FPT_GDS (FPTN = GDS ); %VLP_VECTOR (FPTN = IO_ ); %VLP_VECTOR (FPTN = PACKET_ ); %VLP_VECTOR (FPTN = DATA_ ); %FPT_ERRMSG (FPTN = FPT_ERRMSG, BUF=ERR_BUF, INCLCODE=NO, CODE=ERRCODE, RESULTS=VLR_ERRMSG ); %VLR_ERRMSG (FPTN = VLR_ERRMSG ); %FPT_UNFID (FPTN = FPT_UNFID ); %FPT_OPEN (FPTN = DEFAULT_OPEN ); %FPT_OPEN (FPTN = FPT_OPEN, ACCT=A_ACCT, NAME=A_NAME, PASS=A_PASS, SN=A_SN, WSN=A_WSN ); %VLP_ACCT (FPTN = A_ACCT ); %VLP_NAME (FPTN = A_NAME ); %VLP_PASS (FPTN = A_PASS ); %VLP_SN (FPTN = A_SN ); %VLP_WSN (FPTN = A_WSN ); %FPT_FID (FPTN = FPT_FID, ACCT=A_ACCT, ASN=FPT_OPEN.V.ASN#, NAME=A_NAME, PASS=A_PASS, RES=FPT_OPEN.V.RES#, SN=A_SN, TEXTFID=FID_STRING, RESULTS=VLR_FID, WSN=A_WSN ); %VLR_FID (FPTN = VLR_FID ); %FPT_READ (FPTN = READ_DEFAULTS, BUF=ME_BUF, DCB=F$DEFAULTS ); %FPT_PFIL (FPTN = PFIL_EOF, BOF=NO ); %FPT_PRECORD (FPTN = BACKUP1, KEYR=YES, N=-1 ); %IF OS_VERSION='B03'; %FPT_TRMATTR (FPTN = FPT_TRMATTR, DCB=M$UC, TRMATTR=VLP_TRMATTR ); %VLP_TRMATTR (FPTN = VLP_TRMATTR ); %ENDIF; %FPT_TRMPRG (FPTN = PURGE_TYPEAHEAD, DCB=F$PACKET_IN, STATION = MY_STATION, PURGEINPUT=YES ); %FPT_GLINEATTR(FPTN = FPT_GLINEATTR, DCB=F$PACKET_IN, STATION = MY_STATION, LINEATTR=VLP_LINEATTR ); %VLP_LINEATTR(FPTN = VLP_LINEATTR ); %EJECT; /**/ /* XUR$GETCMD, X$PARSE,XUF$FORMAT & XUW$WLDCMP stuff */ /**/ %XUR_INIT (NAME = XUR_INIT, PCB=P_PCB, STCLASS=STATIC ); %F_FDS (NAME = F_FDS, BUF=LO_BUF, DCB=M$LO, STCLASS=STATIC ); %P$PCB (NAME = P_PCB, STCLASS=STATIC ); %PARSE$OUT (NAME = P_OUT, STCLASS=BASED ); %PARSE$SYM (NAME = P_SYM, STCLASS=BASED ); %IF OS_VERSION='B03'; %FPT_WILDCARD(FPTN = WILD_COMPARE ); %ELSE; %XUW_WILDCARD(FPTN = WILD_COMPARE ); %ENDIF; %IF OS_VERSION='B03'; %FPT_WILDCARD(FPTN = COMPARE_EXT ); %ELSE; %XUW_WILDCARD(FPTN = COMPARE_EXT ); %ENDIF; %EJECT; /**/ /* BASED items, listed alphabetically */ /**/ DCL IO_BUF CHAR(IO_BUF_SIZE) BASED(IO_.PTR$); DCL IO_BYTE(0:0) CHAR(1) BASED(IO_.PTR$); DCL STRNG CHAR(LEN) BASED(P_PCB.TEXT$); %EJECT; /**/ /* BIT items, listed alphabetically */ /**/ DCL AT_EOF BIT(1); DCL BINARY_QUOTING BIT(1); DCL BIN_MASK BIT(9); DCL CCBUF_CMD BIT(1); DCL CG_MODE BIT(1); DCL CG_SPECIFIED BIT(1); DCL CHARMASK BIT(9); DCL DEBUG_OPTS(0:35) BIT(1); DCL DONE BIT(1); DCL DONE_PARSING BIT(1); DCL DONE_SENDING BIT(1); DCL GOT_TRMCTL BIT(1) STATIC INIT(%NO#); DCL GREETING BIT(1); DCL IM_A_SERVER BIT(1); DCL NO_DEFAULTS BIT(1); DCL OK_TO_SEND BIT(1); DCL PROMPTING BIT(1); DCL REPEATING BIT(1); DCL SILENT_MODE BIT(1); DCL STATION_SPECIFIED BIT(1); DCL TRANSFER_INTERRUPTED BIT(1); DCL WORDMASK BIT(36) ALIGNED; %EJECT; /**/ /* CHARacter items, listed alphabetically */ /**/ DCL CG_FID CHAR(80) STATIC INIT(' '); DCL CHR CHAR(1) CALIGNED; DCL CHR_BIT REDEF CHR BIT(9) CALIGNED; DCL CHR7 CHAR(1) CALIGNED; DCL CHR7_BIT REDEF CHR7 BIT(9) CALIGNED; DCL CMD_BUF CHAR(256) STATIC; DCL 1 LINK_CMD REDEF CMD_BUF, 2 LEN UBIN(9) CALIGNED, 2 BUF CHAR(255) CALIGNED; DCL CP6_FID CHAR(80); DCL CUR_CHR CHAR(1); DCL DAY CHAR(3) STATIC; DCL DAYU(0:2) REDEF DAY UBIN(9) CALIGNED; DCL DEBUG_LABEL(0:12) CHAR(4) STATIC INIT( ' ','All ','Cmnd','Erro','Info','Mcro', 'Off ','On ','Read','Rcvd','Sent', 'Timo','Writ'); DCL EOR_BYTE(0:1) CHAR(1); DCL EOR_CHARS CHAR(10) STATIC INIT('#M#J'); DCL ERR_BUF CHAR(120) STATIC INIT('OOPS'); DCL FID_STRING CHAR(80) STATIC INIT(' '); DCL GREETING_MSG CHAR(0) STATIC INIT( 'CP-6 KERMIT 1.00 Here (01/25/88)\'); DCL HEX(0:15) CHAR(1) STATIC INIT( '0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'); DCL HHMMSSSS CHAR(11) STATIC; DCL INT5 CHAR(5); DCL LO_BUF CHAR(132) STATIC INIT(' '); DCL LOG_FID CHAR(80) STATIC INIT( '*KERMIT_LOG' ); DCL ME_BUF CHAR(132) STATIC INIT(' '); DCL MMMDDYY CHAR(10) STATIC INIT('MMM DD ''YY'); DCL MMMDDYYU(0:9) REDEF MMMDDYY UBIN(9) CALIGNED; DCL MODE CHAR(7) STATIC INIT('TEXT'); DCL NO_MEM_FOR_IO_BUF CHAR(0) STATIC INIT( 'CP-6 KERMIT can''t get big enough buffer for READ' ); DCL PACKET_FID CHAR(80); DCL PARITY_TBL(0:%KV_PRTTYP_ZERO) CHAR(4) STATIC INIT( 'NONE','ODD ','EVEN','ONE ','ZERO' ); DCL PREV_CHR CHAR(1); DCL PREV_CHR_BIT REDEF PREV_CHR BIT(9) CALIGNED; DCL PREV_CHR7 CHAR(1) CALIGNED; DCL PREV_CHR7_BIT REDEF PREV_CHR7 BIT(9) CALIGNED; DCL SET_FILE_REPLACEMENT CHAR(1) STATIC INIT('_'); DCL SET_FILE_SUBDIRECTORY_CHAR CHAR(1) STATIC INIT(':'); DCL SPEED(0:15) CHAR(5) STATIC INIT( /* 0 1 2 3 4 5 6 7 */ '50 ','75 ','110 ','134 ','150 ','200 ','300 ','600 ', /* 8 9 10 11 12 13 14 15 */ '1050 ','1200 ','1800 ','2000 ','2400 ','4800 ','9600 ','19200'); DCL SRCE_FID CHAR(80) STATIC INIT(' '); DCL STATE CHAR(1); DCL STR1 CHAR(80); DCL STR2 CHAR(80); DCL TYPE CHAR(1); DCL UNIMPLEMENTED_CMD CHAR(0) STATIC INIT( '.. Unimplemented command.\'); DCL WHAT CHAR(80) STATIC; %EJECT; /**/ /* DCBs */ /**/ DCL F$DEFAULTS DCB; DCL F$IN DCB; DCL M$LO DCB; DCL M$SI DCB; DCL M$SI2 DCB; %M$DCB (DCBN = F$DEBUG, ACS=DIRECT, ASN=FILE, FUN=CREATE, NAME='*DEBUG', ORG=KEYED ); %M$DCB (DCBN = F$LOG, ASN=FILE, CTG=YES, FUN=CREATE, NAME='*KERMIT_LOG', ORG=KEYED ); %M$DCB (DCBN = F$OUT, ASN=FILE, CTG=YES, FUN=CREATE, NAME='*OUT', ORG=CONSEC ); %M$DCB (DCBN = F$PACKET_IN, ASN=DEVICE, FUN=IN, ORG=TERMINAL, RES='UC' ); %M$DCB (DCBN = F$PACKET_OUT, ASN=DEVICE, FUN=CREATE, ORG=TERMINAL, RES='UC' ); %EJECT; /**/ /* ENTRYs, listed alphabetically */ /**/ DCL KERMIT$BREAK ENTRY ASYNC; DCL XUR$ALLMSG ENTRY(1) ALTRET; %IF OS_VERSION='B03'; DCL XUR$CLOSE_DCBS ENTRY; %ELSE; DCL XUR$CLOSE_DCBS ENTRY(2); %ENDIF; DCL XUR$ECHO ENTRY(1) ALTRET; DCL XUR$ECHOIF ENTRY(1) ALTRET; DCL XUR$ERRMSG ENTRY(7) ALTRET; DCL XUR$ERRPTR ENTRY(2) ALTRET; DCL XUR$GETCMD ENTRY(6) ALTRET; DCL XUR$HELP ENTRY(1) ALTRET; DCL XUR$INIT ENTRY(3) ALTRET; DCL XUR$MOREMSG ENTRY(1) ALTRET; %IF OS_VERSION='B03'; DCL XUR$SETDCBS ENTRY(2) ALTRET; %ELSE; DCL XUR$SETDCBS ENTRY(4) ALTRET; %ENDIF; DCL X$WILDCMP ENTRY(1) ALTRET; DCL X$WRITE ENTRY(22); %EJECT; /**/ /* PTRs, listed alphabetcally */ /**/ DCL B$JIT$ PTR SYMREF; DCL B$TCB$ PTR SYMREF; DCL BLK1$ PTR; DCL PERRCODE REDEF BLK1$ BIT(36); DCL BLK2$ PTR; DCL BLK3$ PTR; DCL BLK4$ PTR; DCL BLK5$ PTR; DCL F$DEFAULTS$ PTR; DCL F$DEBUG$ PTR; DCL F$IN$ PTR; DCL F$LOG$ PTR; DCL F$OUT$ PTR; DCL F$PACKET_IN$ PTR; DCL F$PACKET_OUT$ PTR; DCL M$LO$ PTR; DCL M$SI$ PTR; %EJECT; /**/ /* SBIN/UBIN items, listed alphabetically */ /**/ DCL ABORT_REASON UBIN; DCL ARS SBIN; DCL BBUF(0:1023) UBIN; DCL BINARY_RECL SBIN STATIC INIT(128); DCL BLOCK_CHECK SBIN STATIC INIT(%ONE_CHAR_CHECKSUM##); DCL BRK_CNT SBIN STATIC SYMDEF INIT(0); DCL CG_ASN UBIN(9) STATIC INIT(%FILE#); DCL CHECKSUM UBIN; DCL CMD# SBIN; DCL CMD_LEN SBIN; DCL CMD_NUM SBIN; DCL CP6_FID_LEN UBIN STATIC; DCL CUR_MODE UBIN; DCL CUR_TAB_EXPANSION UBIN; DCL DATA(0:0) UBIN(9) CALIGNED BASED(DATA_.PTR$); DCL DATA_BIT(0:0) BIT(9) CALIGNED BASED(DATA_.PTR$); DCL DATA_BUF CHAR(DATA_MAX_SIZE) CALIGNED BASED(DATA_.PTR$); DCL DATA_MAX_SIZE UBIN; DCL DEFAULT_DCB# SBIN STATIC INIT(DCBNUM(M$LO)); DCL DELAY SBIN STATIC SYMDEF INIT(10); DCL END_UTS UBIN; DCL EOR_BYTE_LEN UBIN; DCL EOR_CHARS_LEN UBIN STATIC INIT(LENGTHC('#M#J')); DCL ERRDCB# SBIN; DCL F$DEBUG# SBIN STATIC INIT(DCBNUM(F$DEBUG)); DCL F$DEFAULTS# SBIN STATIC INIT(DCBNUM(F$DEFAULTS)); DCL F$LOG# SBIN STATIC INIT(DCBNUM(F$LOG)); DCL F$OUT# SBIN STATIC INIT(DCBNUM(F$OUT)); DCL FILE_BYTE_CNT SBIN STATIC INIT(0); DCL FILE_CNT SBIN; DCL HOW_DEBUG SBIN STATIC INIT(%OLDFILE#); DCL HOW_LOG SBIN STATIC INIT(%OLDFILE#); DCL HOW_RECEIVE SBIN STATIC INIT(%ERROR#); DCL I SBIN; DCL IO_BUF_SIZE SBIN; DCL IO_CNT SBIN; DCL IO_INDX SBIN; DCL IO_LEN SBIN; DCL J SBIN; DCL K SBIN; DCL KBUF(0:1023) UBIN; DCL L SBIN; DCL LEN UBIN; DCL KERMIT_NODES SBIN SYMREF; DCL M$LO# SBIN STATIC INIT(DCBNUM(M$LO)); DCL NEXT_CALL SBIN; DCL NUM_BYTES_RCVD SBIN STATIC INIT(0); DCL NUM_BYTES_SENT SBIN STATIC INIT(0); DCL NUM_CMDS SBIN; DCL NUM_DATA_PACKETS SBIN STATIC INIT(0); DCL NUM_EXTENSIONS SBIN; DCL NUM_TABS SBIN STATIC INIT(40); DCL NUM_TRIES SBIN; DCL OFFSET SBIN; DCL OUT_INDX SBIN; DCL PACKET_MAX_SIZE UBIN; DCL PACKLEN UBIN; DCL PACKNUM UBIN; DCL RCVD_CHECKSUM UBIN; DCL RCVD_PACKNUM UBIN; DCL REC_CNT UBIN; DCL REPEAT_CNT UBIN; DCL REPEAT_LEN UBIN; DCL SEQUENCE_LEN UBIN; DCL SET_FILE_CP6_FIDS UBIN STATIC INIT(%SET_FILE_CP6_FIDS_NO##); DCL SET_FILE_EDIT UBIN STATIC INIT(%SET_FILE_EDIT_NO##); DCL SET_FILE_INCOMPLETE UBIN STATIC INIT(%SET_FILE_INCOMPLETE_DISCARD##); DCL SET_FILE_MODE UBIN STATIC INIT(%SET_FILE_MODE_AUTO##); DCL SET_FILE_NAMES UBIN STATIC INIT(%SET_FILE_NAMES_ASIS##); DCL SET_FILE_PC_EXTENSIONS UBIN STATIC INIT(%SET_FILE_PC_EXTENSIONS_YES##); DCL SET_FILE_SUBDIRECTORY UBIN STATIC INIT(%SET_FILE_SUBDIRECTORY_OFF##); DCL SET_FILE_SUBDIRECTORY_INDEX UBIN; DCL SET_FILE_WARNING UBIN STATIC INIT(%SET_FILE_WARNING_ON##); DCL SET_TAB_EXPANSION UBIN STATIC INIT(%SET_TAB_EXPANSION_ON##); DCL SI_DCB# UBIN STATIC INIT(DCBNUM(M$SI)); DCL SIZE UBIN; DCL SKIP_BLANKS(0:511) UBIN(9) CALIGNED CONSTANT SYMDEF INIT ( 1 * %ASCBIN(' '), 0, 1 * 0 ); DCL START_UTS UBIN; DCL TABS(0:39) UBIN(9) STATIC INIT( 009,017,025,033,041,049,057,065,073,081, 089,097,105,113,121,129,137,145,153,161, 169,177,185,193,201,209,217,225,233,241, 249,257,265,273,281,289,297,305,313,321); DCL TARGET_WILD_POS SBIN; DCL TMP1 UBIN; DCL TMP1_BIT REDEF TMP1 BIT(36); DCL TX UBIN; DCL UBIN9 UBIN(9) CALIGNED; DCL UTS UBIN STATIC; DCL X UBIN; %EJECT; /**/ /* Structures */ /**/ DCL 1 TARGET STATIC, 2 L# UBIN(9) CALIGNED, 2 NAME# CHAR(31) CALIGNED; DCL 1 CUR_FILE, 2 L# UBIN(9) CALIGNED, 2 NAME# CHAR(31) CALIGNED; DCL 1 MY_DEFAULT STATIC SYMDEF, 2 PACKET_LENGTH UBIN(9) CALIGNED INIT(94), /* MAXL */ 2 TIMEOUT UBIN(9) CALIGNED INIT( 8), /* TIME */ 2 PADDING UBIN(9) CALIGNED INIT( 0), /* NPAD */ 2 PADCHAR CHAR(1) CALIGNED INIT(BINASC(0)), /* PADC */ 2 END_OF_LINE CHAR(1) CALIGNED INIT(BINASC(13)), /* EOL */ 2 QUOTE CHAR(1) CALIGNED INIT('#'), /* QCTL */ 2 QBIN CHAR(1) CALIGNED INIT('Y'), /* QBIN */ 2 BLOCK_CHECK UBIN(9) CALIGNED INIT(%ASCBIN('1')), /* CHKT */ 2 REPT CHAR(1) CALIGNED INIT('~'), /* REPT */ 2 CAPAS UBIN(9) CALIGNED INIT(0), /* MASK */ 2 PAUSE UBIN(9) CALIGNED, 2 START_OF_PACKET CHAR(1) CALIGNED INIT(BINASC( 1)); DCL 1 MY, 2 PACKET_LENGTH UBIN(9) CALIGNED, /* MAXL */ 2 TIMEOUT UBIN(9) CALIGNED, /* TIME */ 2 PADDING UBIN(9) CALIGNED, /* NPAD */ 2 PADCHAR CHAR(1) CALIGNED, /* PADC */ 2 END_OF_LINE CHAR(1) CALIGNED, /* EOL */ 2 QUOTE CHAR(1) CALIGNED, /* QCTL */ 2 QBIN CHAR(1) CALIGNED, /* QBIN */ 2 BLOCK_CHECK UBIN(9) CALIGNED, /* CHKT */ 2 REPT CHAR(1) CALIGNED, /* REPT */ 2 CAPAS UBIN(9) CALIGNED, /* MASK */ 2 PAUSE UBIN(9) CALIGNED, 2 START_OF_PACKET CHAR(1) CALIGNED; DCL 1 THEIR STATIC SYMDEF, 2 PACKET_LENGTH UBIN(9) CALIGNED INIT(94), /* MAXL */ 2 TIMEOUT UBIN(9) CALIGNED INIT( 8), /* TIME */ 2 PADDING UBIN(9) CALIGNED INIT( 0), /* NPAD */ 2 PADCHAR CHAR(1) CALIGNED INIT(BINASC(00)), /* PADC */ 2 END_OF_LINE CHAR(1) CALIGNED INIT(BINASC(13)), /* EOL */ 2 QUOTE CHAR(1) CALIGNED INIT('#'), /* QCTL */ 2 QBIN CHAR(1) CALIGNED INIT('N'), /* QBIN */ 2 BLOCK_CHECK UBIN(9) CALIGNED INIT(%ASCBIN('1')), /* CHKT */ 2 REPT CHAR(1) CALIGNED INIT(' '), /* REPT */ 2 CAPAS UBIN(9) CALIGNED INIT(0), /* MASK */ 2 PAUSE UBIN(9) CALIGNED, 2 START_OF_PACKET CHAR(1) CALIGNED INIT(BINASC( 1)); DCL 1 PACKET BASED(PACKET_.PTR$), 2 MARK CHAR(1) CALIGNED, 2 LEN UBIN(9) CALIGNED, 2 SEQ UBIN(9) CALIGNED, 2 TYPE UBIN(9) CALIGNED, 2 DATA(0:0) UBIN(9) CALIGNED, 2 DATA_BIT(0:0) REDEF DATA BIT(9), 2 DATA_BUF REDEF DATA CHAR(1); DCL PACKET_BUF CHAR(PACKET_MAX_SIZE) CALIGNED BASED(PACKET_.PTR$); DCL PACKET_BIT(0:0) BIT(9) CALIGNED BASED(PACKET_.PTR$); DCL PACKET_WORD(0:0) BIT(36) BASED(PACKET_.PTR$); DCL 1 PROTOCOL STATIC SYMDEF, 2 MAX_INITIAL_RETRIES UBIN INIT(10), 2 MAX_PACKET_RETRIES UBIN INIT(10), 2 SYNCHR CHAR(1) INIT(%BITASC('001'O)); DCL 1 DEFAULT STATIC SYMDEF, 2 LEN UBIN CALIGNED INIT(LENGTHC(':KERMIT_INI')), 2 NAME CHAR(76) CALIGNED INIT(':KERMIT_INI'); DCL 1 DEBUG_FILE STATIC, 2 LEN UBIN INIT(LENGTHC('*DEBUG')), 2 NAME# CHAR(76) INIT('*DEBUG'); DCL 1 LOG_FILE STATIC, 2 LEN UBIN INIT(LENGTHC('*KERMIT_LOG')), 2 NAME# CHAR(76) INIT('*KERMIT_LOG'); DCL 1 DEST, 2 L# UBIN, 2 NAME# CHAR(76); DCL 1 OUT_KEY, 2 LEN UBIN(9) CALIGNED, 2 EDIT UBIN(27) CALIGNED; DCL 1 DEBUG_KEY STATIC, 2 LEN UBIN(9) CALIGNED, 2 EDIT UBIN(27) CALIGNED, 2 * CHAR(252) CALIGNED; DCL 1 LOG_KEY STATIC, 2 LEN UBIN(9) CALIGNED, 2 EDIT UBIN(27) CALIGNED, 2 * CHAR(252) CALIGNED; DCL 1 EXTEN(0:%(MAX_EXTENSIONS#-1)), 2 LEN UBIN(9) CALIGNED, 2 TEXT CHAR(11) CALIGNED; DCL 1 PROMPT, 2 VFC# BIT(1) UNAL, 2 L# UBIN(8) UNAL, 2 NAME# CHAR(31) CALIGNED; DCL 1 SET_FILE_PREFIX STATIC, 2 LEN UBIN(9) CALIGNED INIT(0), 2 TEXT CHAR(19) CALIGNED; %EJECT; DCL 1 BAD_FID_CHARS STATIC, 2 *(0:127) UBIN(9) UNAL INIT( /* DECIMAL OCTAL */ /* 0- 7 .000-.007 */ 001,001,002,003,004,005,006,007, /* 8- 15 .010-.017 */ 008,009,010,011,012,013,014,015, /* 16- 23 .020-.027 */ 016,017,018,019,020,021,022,023, /* 24- 31 .030-.037 */ 024,025,026,027,028,029,030,031, /* 32- 39 .040-.047 */ 032,033,034,035,000,037,038,039, /* 40- 47 .050-.057 */ 040,041,000,043,044,000,046,047, /* 48- 55 .060-.067 */ 000,000,000,000,000,000,000,000, /* 56- 63 .070-.077 */ 000,000,000,059,060,061,062,000, /* 64- 71 .100-.107 */ 064,000,000,000,000,000,000,000, /* 72- 79 .110-.117 */ 000,000,000,000,000,000,000,000, /* 80- 87 .120-.127 */ 000,000,000,000,000,000,000,000, /* 88- 95 .130-.137 */ 000,000,000,091,092,093,094,000, /* 96-103 .140-.147 */ 096,000,000,000,000,000,000,000, /* 104-111 .150-.157 */ 000,000,000,000,000,000,000,000, /* 112-119 .160-.167 */ 000,000,000,000,000,000,000,000, /* 120-127 .170-.177 */ 000,000,000,123,124,125,126,127); %EJECT; /**/ /* VECTORs, listed alphabetically */ /**/ DCL VEC1_ BIT(72) DALIGNED; DCL VEC2_ BIT(72) DALIGNED; DCL VEC3_ BIT(72) DALIGNED; DCL VEC4_ BIT(72) DALIGNED; DCL VEC5_ BIT(72) DALIGNED; DCL VEC6_ BIT(72) DALIGNED; %EJECT; /**/ /* X$WRITE formats */ /**/ DCL FMT CHAR(0) STATIC INIT('%>A'); DCL FMT1 CHAR(0) STATIC INIT( 'Send cntrl char prefix: %>A%42-Receive cntrl char prefix: %>A'); DCL FMT2 CHAR(0) STATIC INIT( 'Receive start-of-packet char: %>A%42-Send start-of-packet char: %>A'); DCL FMT3 CHAR(0) STATIC INIT( 'Receive timeout (seconds): %D%42-Send timeout (seconds): %D'); DCL FMT4 CHAR(0) STATIC INIT( 'Receive packet size: %D%42-Send packet size: %D'); DCL FMT5 CHAR(0) STATIC INIT( '# of send pad characters: %D%42-# of Receive pad characters: %D'); DCL FMT6 CHAR(0) STATIC INIT( 'End-of-line character: %>A%42-Block check used: 1-CHARACTER-CHECKSUM'); DCL FMT7 CHAR(0) STATIC INIT( 'Accepting CP-6 fids: %>A%42-%>A'); DCL FMT8 CHAR(0) STATIC INIT( 'Illegal fid chars replaced with: %>A%42-%>A'); DCL FMT9 CHAR(0) STATIC INIT( '%>A%42-Delay %D seconds before first packet'); DCL FMT10 CHAR(0) STATIC INIT( 'Initial packet retry count: %D%42-Packet retry count: %D'); DCL FMT11 CHAR(0) STATIC INIT( 'Tab expansion: %>A%42-Log file:%>A %>A'); DCL FMT12 CHAR(0) STATIC INIT( '.. Key of next record in %>A will be %D.000.'); DCL FMT13 CHAR(0) STATIC INIT( '.. %>A currently has %D records.'); DCL FMT14 CHAR(0) STATIC INIT( '.. Creating %>A'); DCL FMT15 CHAR(0) STATIC INIT( '.. Can''t DEBUG .. %>A is NOT EDIT keyed.'); DCL FMT16 CHAR(0) STATIC INIT( '.. No room to add new integral EDIT key in %>A.'); DCL FMT17 CHAR(0) STATIC INIT( '%A %A, 19%A at %A logged on as %>A,%>A'); DCL FMT18 CHAR(0) STATIC INIT( ' %>A %>A as %>A (%D records) in %>A mode'); DCL FMT19 CHAR(0) STATIC INIT( ' %>A %>A (%D records) in %>A mode'); DCL FMT20 CHAR(0) STATIC INIT( ' %>A %>A%Q (%D records) in %>A mode'); DCL FMT21 CHAR(0) STATIC INIT( ' %>A %>A as %>A%Q (%D records) in %>A mode'); DCL FMT22 CHAR(0) STATIC INIT( ' Maximum packet sizes: Sent: %D Received: %D'); DCL FMT23 CHAR(0) STATIC INIT( ' %D Data packets used to send the files %D bytes'); DCL FMT24 CHAR(0) STATIC INIT( ' %D Data packets used to receive the files %D bytes'); DCL FMT25 CHAR(0) STATIC INIT( ' %D bytes sent accross the communications line'); DCL FMT26 CHAR(0) STATIC INIT( ' %D bytes received accross the communications line'); DCL FMT27 CHAR(0) STATIC INIT( ' %>A at %>A baud, Parity=%>A'); DCL FMT28 CHAR(0) STATIC INIT( ' Error packet: %>A'); DCL FMT29 CHAR(0) STATIC INIT( ' %>A %>A in %>A mode'); DCL FMT30 CHAR(0) STATIC INIT( ' %>A %>A as %>A in %>A mode'); DCL FMT31 CHAR(0) STATIC INIT( '.. %D is an invalid TAB value; value must be 1-255; default tabs restored.'); DCL FMT32 CHAR(0) STATIC INIT( '.. Tabs must be specified in ascending order; the value %D wasn''t'); DCL FMT33 CHAR(0) STATIC INIT( 'Mode determined by file extension: %>A%42-Mode: %>A' ); DCL FMT34 CHAR(0) STATIC INIT( 'File warning: %>A%42-Debug file:%>A %>A' ); DCL FMT35 CHAR(0) STATIC INIT( '.. Sorry, too many characters specified; maximum allowed is 2.'); DCL FMT36 CHAR(0) STATIC INIT( '.. %D is an invalid value; value must be 0-255.'); DCL FMT37 CHAR(0) STATIC INIT( 'Subdirectories enabled: %>A%42-Subdirectory character: %>A'); DCL FMT38 CHAR(0) STATIC INIT( 'CP-6 file prefix is: %>A'); %EJECT; /**/ /* X$WRITE vectors */ /**/ DCL FMT_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT)); DCL FMT1_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT1)); DCL FMT2_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT2)); DCL FMT3_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT3)); DCL FMT4_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT4)); DCL FMT5_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT5)); DCL FMT6_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT6)); DCL FMT7_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT7)); DCL FMT8_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT8)); DCL FMT9_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT9)); DCL FMT10_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT10)); DCL FMT11_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT11)); DCL FMT12_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT12)); DCL FMT13_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT13)); DCL FMT14_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT14)); DCL FMT15_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT15)); DCL FMT16_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT16)); DCL FMT17_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT17)); DCL FMT18_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT18)); DCL FMT19_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT19)); DCL FMT20_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT20)); DCL FMT21_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT21)); DCL FMT22_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT22)); DCL FMT23_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT23)); DCL FMT24_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT24)); DCL FMT25_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT25)); DCL FMT26_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT26)); DCL FMT27_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT27)); DCL FMT28_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT28)); DCL FMT29_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT29)); DCL FMT30_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT30)); DCL FMT31_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT31)); DCL FMT32_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT32)); DCL FMT33_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT33)); DCL FMT34_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT34)); DCL FMT35_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT35)); DCL FMT36_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT36)); DCL FMT37_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT37)); DCL FMT38_ BIT(72) STATIC DALIGNED INIT(VECTOR(FMT38)); %EJECT; /**** * * The main program is fairly trivial. First INITIALIZE gets called to * initialize various items, most of which are in auto. Next, we call * PARSE_CCBUF. It kind of does what it says; it parses the options, if any, * specified on the invocation line. If the NO DEFAULTS option was NOT * specified on the invocation line then any commands in the default file * (:KERMIT_INI) are read and executed. After the defaults are executed any * options on the invocation line are executed. If there were any options on * the invocation line besides DONT GREET, DONT PROMPT, NO DEFAULTS and/or * SILENT MODE then KERMIT will exit after the last such command is executed. * Otherwise, KERMIT will prompt the user for additional commands (or read * from the file specified through DCB1 on the invocation line). * ****/ START_KERMIT: CALL INITIALIZE ALTRET( PUT_ERR ); CALL PARSE_CCBUF ALTRET( PUT_ERR ); DO WHILE( NOT DONE ); CALL DO_1_LINE_OF_OPTIONS ALTRET( DONE_YET ); DONE_YET: END; EOJ: CALL CLOSE_A_FILE( F$DEBUG# ); CALL CLOSE_A_FILE( M$LO#,%SAVE# ); %IF OS_VERSION='B03'; CALL XUR$CLOSE_DCBS; /* Close all files */ %ELSE; CALL XUR$CLOSE_DCBS( ,ERRCODE); /* Close all files */ %ENDIF; GOTO QUIT; PUT_ERR: ERRDCB#= %ERRDCB; IF NOT DONE THEN /* If we had unexpected error */ CALL XUR$ERRMSG( %MONERR,ERRDCB# ); /* print an appropriate error. */ SET_THE_STEPCC: SET_STEPCC.V.STEPCC#= 4; QUIT: IF VLP_GTRMCTL.SINPUTSZ# ~= 255 THEN /* Did we change anything? */ CALL M$STRMCTL( ORIG_TRMCTL ); /* Yep, change things back */ CALL M$EXIT( SET_STEPCC ); /* Set STEPCC upon exit */ %EJECT; /**** * * B L O C K _ M O V E * * Move LEN bytes from SOURCE to DESTINATION. This routine can only be used * in cases where the destination is not a packet buffer that could have * repeating done in it. * ****/ BLOCK_MOVE: PROC( DESTINATION,SOURCE,LEN ); DCL DESTINATION CHAR(LEN); DCL SOURCE CHAR(LEN); DCL LEN UBIN; DESTINATION= SOURCE; RE_TURN: RETURN; END BLOCK_MOVE; %EJECT; /**** * * B U F E M P * * This routine basically just repeatedly gets a byte(s) from the incoming * data packet and then deposits it in the CP-6 file being created. If the * transfer in progress is a TEXT transfer, TABs will be expanded if * SET TAB EXPANSION = ON. * ****/ BUFEMP: PROC( DATA_BUF,LEN ) ALTRET; DCL DATA_BUF CHAR(LEN); DCL LEN SBIN; DCL I SBIN; DCL TMP_CHR CHAR(1); I= 0; DO WHILE( (I < LEN OR REPEAT_CNT > 0) AND NOT AT_EOF ); CALL GET_PACKET_CHAR( DATA_BUF,I );/*Get Ith char; I+1th char if quoted*/ IF CUR_MODE = %SET_FILE_MODE_BINARY## THEN DO; CALL STUFF( IO_BUF,IO_LEN ) ALTRET( ALT_RETURN ); IF IO_LEN >= BINARY_RECL THEN CALL WRITE_RECORD( IO_BUF,IO_LEN ) ALTRET( ALT_RETURN ); END; ELSE IF (CHR = EOR_BYTE(1) AND PREV_CHR = EOR_BYTE(0)) OR (CHR = EOR_BYTE(0) AND EOR_BYTE_LEN = 1) THEN DO; CALL WRITE_RECORD( IO_BUF,IO_LEN ) ALTRET( ALT_RETURN ); END; ELSE DO; IF (PREV_CHR = EOR_BYTE(0)) AND (EOR_BYTE_LEN > 1) THEN DO; TMP_CHR= CHR; CHR= PREV_CHR; CALL STUFF( IO_BUF,IO_LEN ) ALTRET( ALT_RETURN ); CHR= TMP_CHR; END; IF CHR ~= EOR_BYTE(0) THEN DO; IF CHR = %TAB AND CUR_MODE=%SET_FILE_MODE_TEXT## AND SET_TAB_EXPANSION = %SET_TAB_EXPANSION_ON## THEN DO; DO X=TX TO NUM_TABS-1; IF IO_LEN+1 < TABS(X) THEN GOTO SPACE_INSERT; END; IO_LEN= IO_LEN + LENGTHC(' '); DO WHILE( '0'B ); SPACE_INSERT: IO_LEN= TABS(X) - 1; TX= X + 1; END; IF IO_LEN >= IO_BUF_SIZE THEN CALL EXPAND( IO_,IO_BUF_SIZE,IO_BUF_SIZE ) ALTRET( ALT_RETURN ); END; ELSE IF CHR=%SUB AND CUR_MODE=%SET_FILE_MODE_TEXT## THEN DO; AT_EOF= %YES#; GOTO RE_TURN; END; ELSE DO; CALL STUFF( IO_BUF,IO_LEN ) ALTRET( ALT_RETURN ); END; END; END; PREV_CHR= CHR; END; RE_TURN: RETURN; ALT_RETURN: ALTRETURN; END BUFEMP; %EJECT; /**** * * B U F I L L * * Get a buffer full of data from the file that's being sent. * ****/ BUFILL: PROC ALTRET; IF AT_EOF THEN DO; /* Are we at EOF? */ STATE= %Z_EOF; /* Yep, change states */ GOTO ALT_RETURN; END; SIZE= 0; /**** * * Continue where we left off last time we were here. NEXT_CALL contains * a code that will take care of this. * ****/ DO CASE( NEXT_CALL ); CASE( %NOTHING# ); CASE( %BUILD_SEQUENCE# ); CALL BUILD_REPEAT_SEQUENCE; CASE( %PUT_CHAR_IN_PACKET# ); CALL BUILD_REPEAT_SEQUENCE; CALL PUT_CHAR_IN_PACKET( CUR_CHR ); CASE( %STUFF_CHAR_IN_PACKET# ); CALL STUFF_CHAR_IN_PACKET( CUR_CHR ); END; NEXT_CALL= %NOTHING#; CALL GET_CHAR_FROM_FILE ALTRET( WAS_EOF_HIT ); DO WHILE( '1'B ); CALL PUT_CHAR_IN_PACKET( IO_BYTE(IO_INDX) ) ALTRET( NO_ROOM ); CALL GET_CHAR_FROM_FILE ALTRET( WAS_EOF_HIT ); END; DO WHILE( '0'B ); WAS_EOF_HIT: IF STATE = %A_ABORT THEN ALT_RETURN: ALTRETURN; END; NO_ROOM: ; RE_TURN: RETURN; END BUFILL; %EJECT; /**** * * B U I L D _ R E P E A T _ S E Q U E N C E * * It is time to put PREV_CHR in the out going packet. If repeating is * allowed, we may have to build a repeat sequence for that character. * ****/ BUILD_REPEAT_SEQUENCE: PROC ALTRET; CALL CALC_SEQUENCE_LEN( PREV_CHR ); IF SIZE+MINIMUM(REPEAT_CNT*SEQUENCE_LEN,REPEAT_LEN+SEQUENCE_LEN) > THEIR.PACKET_LENGTH-3 THEN GOTO ALT_RETURN; /* Won't fit in this packet */ IF REPEAT_CNT*SEQUENCE_LEN >= REPEAT_LEN+SEQUENCE_LEN THEN DO; SUBSTR(DATA_BUF,SIZE,1)= THEIR.REPT;/* Stuff their repeat character */ DATA(SIZE+1)= REPEAT_CNT; CALL TOCHAR( DATA(SIZE+1),DATA(SIZE+1) ); /* and REPEAT_CNT */ SIZE= SIZE + LENGTHC(THEIR.REPT) + LENGTHC(DATA(SIZE+1)); CALL STUFF_CHAR_IN_PACKET( PREV_CHR ); END; ELSE DO; DO SEQUENCE_LEN=1 TO REPEAT_CNT; CALL STUFF_CHAR_IN_PACKET( PREV_CHR ); END; END; REPEAT_CNT= 0; RE_TURN: RETURN; ALT_RETURN: ALTRETURN; END BUILD_REPEAT_SEQUENCE; %EJECT; /**** * * C A L C _ C H E C K S U M * * Calculate the checksum for the current packet and return it in CHECKSUM * ****/ CALC_CHECKSUM: PROC( CHECKSUM ); DCL CHECKSUM UBIN; DCL CHECKSUM_BITS REDEF CHECKSUM BIT(36); DCL TMP UBIN; DCL TMP_BITS REDEF TMP BIT(36); CHECKSUM= PACKET.LEN; /* CHECKSUM= PACKET.LEN + 3 */ CHECKSUM= CHECKSUM + PACKET.SEQ; /* CHECKSUM += PACKET.SEQ */ CHECKSUM= CHECKSUM + PACKET.TYPE; /* CHECKSUM + PACKET.TYPE */ IF CHARMASK = '377'O THEN DO I=0 TO PACKET.LEN-1-3-ASCBIN(' '); /* CHECKSUM all the data bytes */ CHECKSUM= CHECKSUM + PACKET.DATA(I); END; ELSE DO I=0 TO PACKET.LEN-1-3-ASCBIN(' '); /* CHECKSUM all the data bytes */ CHECKSUM= CHECKSUM + MOD(PACKET.DATA(I),128); END; CHECKSUM_BITS= CHECKSUM_BITS & '000000000377'O; CHECKSUM= CHECKSUM + (CHECKSUM/64); CHECKSUM_BITS= CHECKSUM_BITS & '000000000077'O; RE_TURN: RETURN; END CALC_CHECKSUM; %EJECT; /**** * * C A L C _ S E Q U E N C E _ L E N * * Determine how many bytes CHR will occupy in the out going packet after any * necessary encoding is done. * ****/ CALC_SEQUENCE_LEN: PROC( CHR ); DCL CHR CHAR(1); DCL CHR_BIT REDEF CHR BIT(9); DCL CHR7 CHAR(1); DCL CHR7_BIT REDEF CHR7 BIT(9); SEQUENCE_LEN= LENGTHC(CHR); CHR7_BIT= CHR_BIT & '177'O; IF BINARY_QUOTING AND CHR ~= CHR7 THEN SEQUENCE_LEN= SEQUENCE_LEN + LENGTHC(MY.QBIN); IF CHR7 < ' ' OR CHR7 = MY.QUOTE OR CHR7 = %DEL OR (REPEATING AND CHR7=MY.REPT) OR (BINARY_QUOTING AND CHR7=MY.QBIN) THEN SEQUENCE_LEN= SEQUENCE_LEN + LENGTHC(MY.QUOTE); RE_TURN: RETURN; END CALC_SEQUENCE_LEN; %EJECT; /**** * * C H A R C T L * * Convert VALUE into a printable string. If VALUE is already printable * (ASCII 32-126) then just move it to STR. If VALUE < a blank (ASCII 32) * then STR will equal '^x' where x equals VALUE + 64 (eg. if VALUE = 1, then * STR would be '^A'). If VALUE > '~' (ASCII 126) then STR will be set to * the hex representation of VALUE (eg. X'7F'). * ****/ CHARCTL: PROC( STR,VALUE ); DCL STR CHAR(6); DCL VALUE UBIN; IF VALUE>0 AND VALUE<%ASCBIN(' ') THEN CALL CONCAT( STR,'^',BINASC(VALUE+%ASCBIN('A')-1) ); ELSE IF VALUE>%ASCBIN(' ') AND VALUE<=%ASCBIN('~') THEN STR= BINASC(VALUE); ELSE DO; STR= 'X''000'''; SUBSTR(STR,2,1)= HEX(VALUE/256); X= MOD(VALUE,256); SUBSTR(STR,3,1)= HEX(X/16); X= MOD(X,16); SUBSTR(STR,4,1)= HEX(X); END; RE_TURN: RETURN; END CHARCTL; %EJECT; /**** * * C H E C K _ E X T E N S I O N S * * Check to see if the file name in SRCE matches any of the extensions in the * EXTEN table. If it matches at least one in EXTEN then a normal RETURN is * executed else an ALTRETURN. * ****/ CHECK_EXTENSIONS: PROC( SRCE ) ALTRET; DCL 1 SRCE, 2 LEN UBIN(9) CALIGNED, 2 TEXT CHAR(11) CALIGNED; DCL I UBIN; %IF OS_VERSION='B03'; COMPARE_EXT.INPUT$= ADDR(SRCE); %ELSE; COMPARE_EXT.INPUT_= VECTOR(SUBSTR(SRCE.TEXT,0,SRCE.LEN)); %ENDIF; IF NUM_EXTENSIONS>0 THEN DO I=0 TO NUM_EXTENSIONS-1; %IF OS_VERSION='B03'; COMPARE_EXT.PATTERN$= ADDR(EXTEN(I)); %ELSE; COMPARE_EXT.PATTERN_= VECTOR(SUBSTR(EXTEN.TEXT(I),0,EXTEN.LEN(I))); %ENDIF; CALL X$WILDCMP( COMPARE_EXT ) ALTRET( TRY_NEXT_EXT ); RE_TURN: RETURN; TRY_NEXT_EXT: END; ALT_RETURN: ALTRETURN; END CHECK_EXTENSIONS; %EJECT; /**** * * C L O S E _ A _ F I L E * * CLOSE the DCB number DCB# with a disposition of DISP. If DISP is not * passed, assume SAVE. * ****/ CLOSE_A_FILE: PROC( DCB#,DISP ); DCL DCB# SBIN; DCL DISP SBIN; FPT_CLOSE.V.DCB#= DCB#; /* Use their DCB# */ IF ADDR(DISP) ~= ADDR(NIL) AND /* If they specified a DISP */ DISP = %RELEASE# THEN /* and it was RELEASE */ FPT_CLOSE.V.DISP#= %RELEASE#; /* then RELEASE the file */ ELSE FPT_CLOSE.V.DISP#= %SAVE#; /* else, SAVE it. */ IF DCB# = DCBNUM(F$IN) OR DCB# = DCBNUM(F$OUT) THEN CALL XSA$CLOSE( FPT_CLOSE,XSA_PARAM ); ELSE CALL M$CLOSE( FPT_CLOSE ); RE_TURN: RETURN; END CLOSE_A_FILE; %EJECT; /**** * * C T L * * Make the SRCE byte printable and put the result in DEST. This basically * means do an exclusive OR on SRCE with 64. * ****/ CTL: PROC( DEST,SRCE ); DCL DEST BIT(9) CALIGNED; DCL SRCE BIT(9) CALIGNED; IF SRCE & '100'O THEN DEST= SRCE & '677'O; ELSE DEST= SRCE \ '100'O; RE_TURN: RETURN; END CTL; %EJECT; /**** * * D E T E R M I N E _ R C V D _ M O D E * * Attempt to determine the MODE (BINARY or TEXT) of the file being received * by checking the list of BINARY EXTENSIONS (if SET PC EXTENSIONS = ON). If * the file name has a suffix in the EXTEN table then the transfer will be in * BINARY mode; else it will be in text mode. * ****/ DETERMINE_RCVD_MODE: PROC; IF SET_FILE_MODE = %SET_FILE_MODE_AUTO## THEN DO; CUR_MODE= %SET_FILE_MODE_BINARY##; /* Assume BINARY mode for now */ CALL CHECK_EXTENSIONS( TARGET ) WHENALTRETURN DO; CUR_MODE= %SET_FILE_MODE_TEXT##; END; END; ELSE CUR_MODE= SET_FILE_MODE; IF CUR_MODE = %SET_FILE_MODE_BINARY## THEN DO; MODE= 'BINARY'; OPEN_IO.V.TYPE#= 'BI'; END; ELSE DO; MODE= 'TEXT'; OPEN_IO.V.TYPE#= ' '; END; RE_TURN: RETURN; END DETERMINE_RCVD_MODE; %EJECT; /**** * * D E T E R M I N E _ S E N D _ M O D E * * Determine the mode (BINARY or TEXT) of the file being sent. It will be * BINARY if the TYpe of the CP-6 file is BI or if the suffix of the file * name matches one or more of those suffixes in the EXTEN table and SET PC * EXTENSIONS = ON is true. * ****/ DETERMINE_SEND_MODE: PROC; IF SET_FILE_MODE = %SET_FILE_MODE_AUTO## THEN IF F$IN$->F$DCB.TYPE# = 'BI' THEN CUR_MODE= %SET_FILE_MODE_BINARY##; ELSE IF F$IN$->F$DCB.NAME#.L < LENGTHC('-xxx') THEN CUR_MODE= %SET_FILE_MODE_TEXT##; ELSE DO; CUR_MODE= %SET_FILE_MODE_BINARY##; CALL CHECK_EXTENSIONS( F$IN$->F$DCB.NAME# ) WHENALTRETURN DO; CUR_MODE= %SET_FILE_MODE_TEXT##; END; END; ELSE CUR_MODE= SET_FILE_MODE; IF CUR_MODE = %SET_FILE_MODE_BINARY## THEN MODE= 'BINARY'; ELSE MODE= 'TEXT'; RE_TURN: RETURN; END DETERMINE_SEND_MODE; %EJECT; /**** * * D O _ 1 _ L I N E _ O F _ O P T I O N S * * The desire is to parse a line of commands and pick off one token at a * time. This can be done in one of two ways. 1) the line of options is * passed in BUF and is BUF_LEN bytes long or 2) BUF = ADDR(NIL) (ie. no * argument was passed) in which case the first time GET_A_CMD is called, it * will read a record of command(s) from the current command stream, usually * M$SI which is normally set to ME. * ****/ DO_1_LINE_OF_OPTIONS: PROC( BUF,BUF_LEN ) ALTRET; DCL BUF CHAR(BUF_LEN); DCL BUF_LEN SBIN; CONTINUE: DONE_PARSING= %NO#; DO UNTIL( DONE_PARSING ); CALL GET_A_CMD( BUF,BUF_LEN ) ALTRET( END_OF_RECORD ); /* Get a cmd */ IF NOT DONE_PARSING THEN /* If they didn't say to quit, */ CALL DO_A_CMD; /* execute their command. */ END; END_OF_RECORD: IF NOT DONE_PARSING THEN IF ERRCODE.ERR# = %E$EOF THEN /* Did we hit EOF? */ IF SI_DCB# = DCBNUM(M$SI) THEN /* If we're reading from M$SI */ DONE= %YES#; /* then we're DONE now */ ELSE /* We're READing from M$SI2; */ IF SI_DCB# ~= F$DEFAULTS# THEN DO; CALL CLOSE_A_FILE( SI_DCB# ); /* CLOSE M$SI2 */ SI_DCB#= DCBNUM(M$SI); /* Change DCBs */ CALL XUR$SETDCBS( SI_DCB# ); /* Tell XUR we changed DCBs */ GOTO CONTINUE; /* Go read another line of cmds */ END; ELSE ; ELSE DO; CALL PUT_ERROR; /* Otherwise, put the finger. */ IF (ERRCODE.ERR# = %E$NOFILE) AND (SI_DCB# = DCBNUM(M$SI)) THEN DONE= %YES#; END; IF (CCBUF_CMD) AND (SI_DCB# ~= F$DEFAULTS#) THEN/*If command was in CCBUF,*/ DONE= %YES#; /* we're done. */ ALT_RETURN: ALTRETURN; END DO_1_LINE_OF_OPTIONS; %EJECT; /**** * * D O _ A _ C M D * * A command has already been parsed and the code of same is in CMD#. All we * do here is a large DO CASE on CMD#. * ****/ DO_A_CMD: PROC ALTRET; DO CASE( CMD# ); CASE( %ALL_HELP## ); CALL XUR$ALLMSG( XUH_PARAM ) ALTRET( HELP_ERR ); CASE( %BYE## ); PACKNUM= 0; NUM_TRIES = 0; X = MY_DEFAULT.TIMEOUT; CALL SET_TIMEOUT(X); /* CALL SEND_INIT; */ CALL SEND_PACKET('G',0,1,'L'); CALL RECEIVE_PACK( TYPE,RCVD_PACKNUM,LEN,DATA ); CALL SET_TIMEOUT(0); IF TYPE = 'Y' THEN GOTO XIT; CASE( %CG## ); CG_FID = %BLK3_TEXT; CG_SPECIFIED = %YES#; IF STATION_SPECIFIED THEN CALL OPEN_TO_CG; CASE( %DEBUG## ); CALL DO_DEBUG; CASE( %DONT_GREET## ); CASE( %DONT_PROMPT## ); CASE( %FINISH## ); PACKNUM= 0; NUM_TRIES = 0; X = MY_DEFAULT.TIMEOUT; CALL SET_TIMEOUT(X); /* CALL SEND_INIT; */ CALL SEND_PACKET('G',0,1,'F'); CALL RECEIVE_PACK( TYPE,RCVD_PACKNUM,LEN,DATA ); CALL SET_TIMEOUT(0); IF TYPE = 'Y' THEN GOTO XIT; CASE( %HELP## ); XUH_PARAM.HELP$= BLK3$->P_SYM.TEXTC$; CALL XUR$HELP( XUH_PARAM ) ALTRET( HELP_ERR ); DO WHILE('0'B); HELP_ERR: IF XUH_PARAM.ERR.ERR# ~= %E$NOHPROC AND XUH_PARAM.ERR.ERR# ~= %E$BDTOPIC THEN CALL XUR$ERRMSG( XUH_PARAM.ERR ); END; CASE( %LIST## ); IF %BLK2_NSUBLKS = 0 THEN CMD_BUF= 'L'; ELSE CALL CONCAT( CMD_BUF,'L ',%BLK3_TEXT ); CALL M$YC( FPT_YC ) ALTRET( YC_ERR ); DO WHILE('0'B); YC_ERR: ERRDCB#= %ERRDCB; CALL XUR$ERRMSG( %MONERR,ERRDCB# ); END; CASE( %LOCAL## ); CALL DO_LOCAL_COMMAND ALTRET( RE_TURN ); CASE( %LOG## ); CALL DO_LOG; CASE( %MORE_HELP## ); GET_MORE_HELP: CALL XUR$MOREMSG( XUH_PARAM ) ALTRET( HELP_ERR ); CASE( %NULL## ); IF M$SI$->F$DCB.EOMVAL#.VALUE# = BITBIN('012'O) THEN DO; CMD#= %MORE_HELP##; /* Pretend they entered '?' */ GOTO GET_MORE_HELP; END; CASE( %NO_DEFAULTS## ); CASE( %PROMPT## ); IF %BLK3_COUNT > 0 THEN DO; PROMPT.VFC#= %NO#; PROMPT.L#= %BLK3_COUNT; PROMPT.NAME#= %BLK3_TEXT; END; ELSE DO; PROMPT.VFC#= %YES#; PROMPT.L#= LENGTHC('@'); PROMPT.NAME#= '@'; END; CALL XUR$INIT( XUR_INIT ); CASE( %READ## ); CALL DO_READ; CASE( %RECEIVE## ); FILE_CNT= 0; MY= MY_DEFAULT; PACKNUM= 0; TX= 0; OPEN_IO= DEFAULT_OPEN; OPEN_IO.V_= VECTOR(OPEN_IO.V); HOW_RECEIVE= SET_FILE_WARNING - %SET_FILE_WARNING_ON## + 1; OPEN_IO.V.FUN#= %CREATE#; IF %BLK2_NSUBLKS = 0 THEN SRCE_FID= ' '; /* Only 'RECEIVE' was specified */ ELSE IF %BLK2_NSUBLKS = 1 THEN /* Was 'RECEIVE fid" specified? */ SRCE_FID= %BLK3_TEXT; /* Yep, Remember it. */ ELSE DO; SRCE_FID= %BLK2_SUBLK$(2)->P_SYM.TEXT; HOW_RECEIVE= %BLK2_SUBLK$(1)->P_SYM.CODE - %ON## + 1; END; CALL RECEIVE_A_FILE( %R_RINIT ); CALL SNOOZE( DELAY ); /* Wait before we prompt again */ CASE( %SEND## ); IF NOT IM_A_SERVER THEN DO; SRCE_FID= %BLK3_TEXT; CALL SEND; END; CASE( %SERVER## ); CALL SERVER ALTRET( XIT ); CASE( %SET## ); CALL SET; CASE( %SHOW## ); CALL SHOW; CASE( %SILENT## ); SILENT_MODE= %YES#; /* Shut up! */ CASE( %STATION## ); CG_STATION.ISTA.ISTATION# = %BLK3_TEXT; CG_STATION.OSTA.OSTATION# = %BLK3_TEXT; STATION_SPECIFIED = %YES#; IF CG_SPECIFIED THEN CALL OPEN_TO_CG; CASE( %STATISTICS## ); CALL PUT( UNIMPLEMENTED_CMD ); CASE( %TRANSMIT## ); CALL SNOOZE( DELAY ); /* Give them time to go to micro*/ CALL CONCAT( CMD_BUF,'C ',%BLK3_TEXT ); CALL M$YC( FPT_YC ) ALTRET( YC_ERR ); CASE( %XIT## ); XIT: IF SI_DCB# = DCBNUM(M$SI2) THEN DO; /* Are we READing thru M$SI2? */ CALL CLOSE_A_FILE( SI_DCB# ); /* CLOSE M$SI2 */ SI_DCB#= DCBNUM(M$SI); /* Revert back to M$SI */ CALL XUR$SETDCBS( SI_DCB# ); /* Tell XUR that we changed DCBs*/ END; /* Since we were in M$SI2 ignore the fact we got an END cmd */ ELSE DO; /* Guess it's time to quit */ DONE= %YES#; DONE_PARSING= %YES#; END; CASE( ELSE ); CALL PUT( '.. Oops! Unknown option encountered by CP-6 Kermit.\' ); END; RE_TURN: RETURN; END DO_A_CMD; %EJECT; /**** * * D O _ D E B U G * * Do all the various things that need to be done based on what they said on * the DEBUG command. * ****/ DO_DEBUG: PROC ALTRET; FPT_OPEN= DEFAULT_OPEN; FPT_OPEN.V.FUN#= %CREATE#; FPT_OPEN.V.EXIST#= %OLDFILE#; DEBUG_OPTS= '0'B; DO J=0 TO %BLK2_NSUBLKS-1; BLK3$= %BLK2_SUBLK$(J); DEBUG_OPTS(%BLK3_CODE-%DEBUG_FID##)= %YES#; DO CASE( %BLK3_CODE ); CASE( %DEBUG_FID## ); IF %BLK4_CODE>=%ON## AND %BLK4_CODE<=%OVER## THEN DO; FPT_OPEN.V.EXIST#= %BLK4_CODE - %ON## + 1; BLK4$= %BLK3_SUBLK$(1); END; ELSE FPT_OPEN.V.EXIST#= %OLDFILE#; /* Extend (or create) the file */ DEBUG_FILE.LEN= %BLK4_COUNT; DEBUG_FILE.NAME#= %BLK4_TEXT; CASE( %DEBUG_ALL## ); DO K=1 TO %DEBUG_WRITE##-%DEBUG_FID##; DEBUG_OPTS(K)= %YES#; END; CASE( %DEBUG_ERROR## ); CASE( %DEBUG_MICRO## ); CASE( %DEBUG_OFF## ); CALL CLOSE_A_FILE( F$DEBUG# ); GOTO RE_TURN; CASE( %DEBUG_ON## ); CASE( %DEBUG_READ## ); CASE( %DEBUG_RECEIVE## ); CASE( %DEBUG_SEND## ); CASE( %DEBUG_TIMEOUT## ); CASE( %DEBUG_WRITE## ); END; END; IF NOT F$DEBUG$->F$DCB.FCD# THEN DO; CALL OPEN_FID( F$DEBUG#,DEBUG_FILE.NAME#,DEBUG_FILE.LEN,FPT_OPEN ) WHENALTRETURN DO; DEBUG_FILE.LEN= LENGTHC('*DEBUG'); DEBUG_FILE.NAME#= '*DEBUG'; VEC1_= VECTOR(SUBSTR(DEBUG_FILE.NAME#,0,DEBUG_FILE.LEN)); GOTO OOPS; END; END; DO_DEBUG_SET_DEFAULTS: ENTRY; DEBUG_OPTS(0)= %NO#; IF DEBUG_OPTS = '0'B THEN DEBUG_OPTS(%DEBUG_MICRO##-%DEBUG_FID##)= %YES#; IF DEBUG_OPTS(%DEBUG_MICRO##-%DEBUG_FID##) THEN DO; DEBUG_OPTS(%DEBUG_ERROR##-%DEBUG_FID##)= %YES#; DEBUG_OPTS(%DEBUG_RECEIVE##-%DEBUG_FID##)= %YES#; DEBUG_OPTS(%DEBUG_SEND##-%DEBUG_FID##)= %YES#; DEBUG_OPTS(%DEBUG_TIMEOUT##-%DEBUG_FID##)= %YES#; END; VEC1_= VECTOR(SUBSTR(DEBUG_FILE.NAME#,0,DEBUG_FILE.LEN)); IF F$DEBUG$->F$DCB.FCD# THEN /* Is F$DEBUG OPEN? */ CALL POSITION_FILE( F$DEBUG#,DEBUG_KEY,DEBUG_FILE,WRITE_DEBUG ) ALTRET( OOPS ); CALL CONCAT( LO_BUF,'!',B$JIT.CCBUF ); LEN= LENGTHC('!') + B$JIT.CCARS; CALL LOG( %DEBUG_INFO##,LO_BUF,LEN ); RE_TURN: RETURN; OOPS: ERRDCB#= %ERRDCB; CALL XUR$ERRMSG( %MONERR,ERRDCB# ); ALT_RETURN: ALTRETURN; END DO_DEBUG; %EJECT; /**** * * D O _ L O C A L _ C O M M A N D * * Do whatever is needed to execute one of the LOCAL commands. This usually * just means set up a command buffer to pass to PCL and let him do the work! * ****/ DO_LOCAL_COMMAND: PROC ALTRET; DO CASE( %BLK3_CODE ); CASE( %LOCAL_COPY## ); CALL CONCAT( CMD_BUF,'COPY ',%BLK4_TEXT ); CASE( %LOCAL_CWD## ); IF %BLK3_NSUBLKS > 0 THEN CALL CONCAT( CMD_BUF,'DIR .',%BLK4_TEXT ); ELSE CALL CONCAT( CMD_BUF,'DIR' ); CASE( %LOCAL_DELETE## ); CALL CONCAT( CMD_BUF,'DEL ',%BLK4_TEXT ); CASE( %LOCAL_DIR## ); CALL CONCAT( CMD_BUF,'L ',%BLK4_TEXT ); CASE( ELSE ); GOTO RE_TURN; END; CALL M$YC( FPT_YC ) ALTRET( ALT_RETURN ); RE_TURN: RETURN; ALT_RETURN: ALTRETURN; END DO_LOCAL_COMMAND; %EJECT; /**** * * D O _ L O G * * Do whatever is needed to take care of the new, possibly first, LOG command * they just issued. If a previous LOG was in progress, CLOSE and SAVE it * and then process the latest one. * ****/ DO_LOG: PROC ALTRET; CALL CLOSE_A_FILE( F$LOG# ); FPT_OPEN= DEFAULT_OPEN; FPT_OPEN.V.ACS#= %DIRECT#; FPT_OPEN.V.FUN#= %CREATE#; FPT_OPEN.V.EXIST#= %OLDFILE#; FPT_OPEN.V.ORG#= %KEYED#; IF %BLK2_NSUBLKS = 2 THEN DO; /* Was {ON|TO|OVER|INTO} specified? */ FPT_OPEN.V.EXIST#= %BLK3_CODE - %ON## + 1; /* Yep, use it! */ BLK3$= %BLK2_SUBLK$(1); END; IF %BLK3_TEXT = 'OFF' OR %BLK3_TEXT = 'off' THEN GOTO RE_TURN; LOG_FILE.LEN= %BLK3_COUNT; LOG_FILE.NAME#= %BLK3_TEXT; VEC1_= VECTOR(SUBSTR(LOG_FILE.NAME#,0,LOG_FILE.LEN)); CALL OPEN_FID( F$LOG#,LOG_FILE.NAME#,LOG_FILE.LEN,FPT_OPEN ) WHENALTRETURN DO; LOG_FILE.LEN= LENGTHC('*KERMIT_LOG'); LOG_FILE.NAME#= '*KERMIT_LOG'; VEC1_= VECTOR(SUBSTR(LOG_FILE.NAME#,0,LOG_FILE.LEN)); GOTO OOPS; END; CALL POSITION_FILE( F$LOG#,LOG_KEY,LOG_FILE,WRITE_LOG ) ALTRET( OOPS ); WRITE_LOG.V.ONEWKEY#= %YES#; WRITE_LOG.V.NEWKEY#= %NO#; RE_TURN: RETURN; OOPS: ERRDCB#= %ERRDCB; CALL XUR$ERRMSG( %MONERR,ERRDCB# ); ALT_RETURN: ALTRETURN; END DO_LOG; %EJECT; /**** * * D O _ R E A D * * They issued a READ command (READ subsequent KERMIT commands from another * file). Check to make sure they aren't issuing the READ from within a READ * file. If so, bitch and ignore it. Otherwise, OPEN the READ file and then * tell XUR$GETCMD that we switched DCBs. * ****/ DO_READ: PROC ALTRET; IF SI_DCB# = DCBNUM(M$SI2) THEN DO; /* Are we already READing? */ CALL PUT( '.. Sorry, you can''t nest READ commands; this one ignored.\'); END; ELSE DO; X= %BLK3_COUNT; CALL OPEN_FID( DCBNUM(M$SI2),%BLK3_TEXT,X ) ALTRET( OOPS ); SI_DCB#= DCBNUM(M$SI2); /* Remember where we're READing */ CALL XUR$SETDCBS( SI_DCB# ); /* Tell XUR too */ END; RE_TURN: RETURN; OOPS: ERRDCB#= %ERRDCB; CALL XUR$ERRMSG( %MONERR,ERRDCB# ); ALT_RETURN: ALTRETURN; END DO_READ; %EJECT; /**** * * D O _ W E _ W A N T _ T H I S _ F I L E * * See if the file name in CUR_FILE matches the one in TARGET. If it does, * then RETURN else ALTRETURN. * ****/ DO_WE_WANT_THIS_FILE: PROC ALTRET; IF NOT TEST_OPEN_IO.V.OPER.NXTF# THEN OK_TO_SEND= %NO#; IF ERRCODE = '0'B THEN DO; %IF OS_VERSION='B03'; WILD_COMPARE.INPUT$= ADDR(CUR_FILE); %ELSE; WILD_COMPARE.INPUT_= VECTOR(SUBSTR(CUR_FILE.NAME#,0,CUR_FILE.L#)); %ENDIF; CALL X$WILDCMP( WILD_COMPARE ) ALTRET( TIME_TO_QUIT ); DO WHILE('0'B); TIME_TO_QUIT: IF TARGET_WILD_POS > 0 AND SUBSTR(TARGET.NAME#,0,TARGET_WILD_POS) ~= SUBSTR(CUR_FILE.NAME#,0,TARGET_WILD_POS) THEN DO; OK_TO_SEND= %NO#; END; GOTO ALT_RETURN; END; END; ELSE DO; IF NOT IM_A_SERVER THEN CALL XUR$ERRMSG( ERRCODE,ERRDCB# ); ELSE DO; CALL WRITE_LOG_REC( %LOG_HEADER# ); CALL SEND_ERROR_PACKET; END; OK_TO_SEND= %NO#; GOTO ALT_RETURN; END; RE_TURN: RETURN; ALT_RETURN: ALTRETURN; END DO_WE_WANT_THIS_FILE; %EJECT; /**** * * E X P A N D * * Expand a data segment. VEC_ is a vector framing the segment that is to be * expanded by NUM_BYTES bytes. If VEC_ = VECTOR(NIL) then the next * available data segment will be used. * ****/ EXPAND: PROC( VEC_,NUM_BYTES,BUFSIZ ) ALTRET; %VLP_VECTOR (FPTN = VEC_, STCLASS=); DCL NUM_BYTES UBIN; DCL BUFSIZ UBIN; GDS.V.SEGSIZE#= NUM_BYTES/4; GDS.RESULTS_= VECTOR(VEC_); CALL M$GDS( GDS ) ALTRET( ALT_RETURN ); SUBSTR(VEC_.PTR$->IO_BUF,VEC_.W1.VSIZE#+1-NUM_BYTES,NUM_BYTES)= ' '; BUFSIZ= VEC_.W1.VSIZE#+1; RE_TURN: RETURN; ALT_RETURN: ALTRETURN; END EXPAND; %EJECT; /**** * * F I X _ C P 6 _ F I L E _ N A M E * * Fix up any file names based upon the settings of SET FILE NAMES and SET * FILE CP6 FIDS. * ****/ FIX_CP6_FILE_NAME: PROC( NAME,LEN,DIRECTION ); DCL NAME CHAR(LEN); DCL LEN UBIN; DCL DIRECTION UBIN; IF SET_FILE_NAMES = %SET_FILE_NAMES_LC## THEN DO X=0 TO LEN-1; CHR= SUBSTR(NAME,X,1); IF CHR>='A' AND CHR<='Z' THEN SUBSTR(NAME,X,1)= BINASC(ASCBIN(CHR)+32); /* Make it LC */ END; ELSE IF SET_FILE_NAMES = %SET_FILE_NAMES_UC## THEN DO X=0 TO LEN-1; CHR= SUBSTR(NAME,X,1); IF CHR>='a' AND CHR<='z' THEN SUBSTR(NAME,X,1)= BINASC(ASCBIN(CHR)-32); /* Make it UC */ END; IF SET_FILE_CP6_FIDS = %SET_FILE_CP6_FIDS_NO## THEN DO; X= 0; IF LEN>1 AND SUBSTR(NAME,LEN-1,1)='.' THEN LEN= LEN - 1; /* Ignore trailing period */ DO WHILE( '1'B ); CALL SEARCH( X,TMP1,BAD_FID_CHARS,NAME,X ) ALTRET( FID_IS_OK_NOW ); SUBSTR(NAME,X,1)= SET_FILE_REPLACEMENT; /* Change character */ X= X + 1; /* Skip to next character */ END; FID_IS_OK_NOW: END; IF DIRECTION ~= %SEND## AND SET_FILE_PREFIX.LEN > 0 THEN DO;/* Should we add a prefix? */ STR1= NAME; CALL INDEX( X,'/',NAME ); IF X = LENGTHC(NAME) THEN DO; CALL CONCAT( STR1,SUBSTR(SET_FILE_PREFIX.TEXT,0,SET_FILE_PREFIX.LEN), NAME ); LEN= LEN + SET_FILE_PREFIX.LEN; NAME= STR1; END; ELSE DO; CALL CONCAT( STR1,SUBSTR(NAME,0,X+1), SUBSTR(SET_FILE_PREFIX.TEXT,0,SET_FILE_PREFIX.LEN), SUBSTR(NAME,X+1) ); LEN= LEN + SET_FILE_PREFIX.LEN; NAME= STR1; END; END; RE_TURN: RETURN; END FIX_CP6_FILE_NAME; %EJECT; /**** * * F I X _ P C _ F I L E _ N A M E * * Attempt to determine if the file name being passed to the PC has an * extension in it and if so, change the delimiter that separates the file * name from the extension to a period. * ****/ FIX_PC_FILE_NAME: PROC( NAME,LEN ); DCL NAME CHAR(LEN); DCL LEN UBIN; DCL I SBIN; /* If the SET FILE PREFIX has been specified, look for it on the file name. If found, remove it and continue. */ IF SET_FILE_PREFIX.LEN > 0 AND LEN > SET_FILE_PREFIX.LEN AND SUBSTR(NAME,0,SET_FILE_PREFIX.LEN) = SUBSTR(SET_FILE_PREFIX.TEXT,0,SET_FILE_PREFIX.LEN) THEN DO; NAME= SUBSTR(NAME,SET_FILE_PREFIX.LEN); LEN= LEN - SET_FILE_PREFIX.LEN; END; ELSE /* Strip off pseudo subdirectory names if they requested it. */ IF SET_FILE_SUBDIRECTORY = %SET_FILE_SUBDIRECTORY_ON## THEN DO; CALL INDEX1R(SET_FILE_SUBDIRECTORY_INDEX,SET_FILE_SUBDIRECTORY_CHAR,NAME,1) ALTRET( NO_SUBDIRECTORY_FOUND ); NAME= SUBSTR(NAME,SET_FILE_SUBDIRECTORY_INDEX+1); LEN= LEN - SET_FILE_SUBDIRECTORY_INDEX - 1; NO_SUBDIRECTORY_FOUND: END; /* Check for subdirectory */ IF SET_FILE_PC_EXTENSIONS = %SET_FILE_PC_EXTENSIONS_YES## THEN DO; DO I=LEN-1 DOWNTO MAXIMUM(0,LEN-4) BY -1; IF SUBSTR(NAME,I,1) = SET_FILE_REPLACEMENT OR SUBSTR(NAME,I,1) = '-' THEN DO; SUBSTR(NAME,I,1)= '.'; EXIT; END; END; END; RE_TURN: RETURN; END FIX_PC_FILE_NAME; %EJECT; /**** * * F L U S H _ I N P U T ( aka FLUSHINPUT ) * * Dump all pending input to clear stacked up NACK's. * ****/ FLUSH_INPUT: PROC; CALL M$TRMPRG( PURGE_TYPEAHEAD ); RE_TURN: RETURN; END FLUSH_INPUT; %EJECT; /**** * * G E T _ A _ C M D * * Get a command. If we have previously parsed a line of them, then just * pick up the next one to be processed. If none are left to process then * get another line/record of commands. * ****/ GET_A_CMD: PROC( CMD,CMD_LEN ) ALTRET; DCL CMD CHAR(CMD_LEN); DCL CMD_LEN UBIN; CMD_NUM= CMD_NUM + 1; /* Point to next command */ IF CMD_NUM >= NUM_CMDS THEN /* Anything left? */ IF CMD_NUM >= 9999 OR ADDR(CMD) = ADDR(NIL) THEN DO;/* Nope. Get more. */ CMD_NUM= 0; /* Set number of commands to 0 */ CALL SET_TIMEOUT( 0 ); IF ADDR(CMD) = ADDR(NIL) THEN DO; /* Get commands from user? */ CALL XUR$GETCMD( KERMIT_NODES,BLK1$,PROMPT ) ALTRET( OOPS ); END; ELSE /* Else: parse what was passed */ CALL XUR$GETCMD( KERMIT_NODES,BLK1$, ,CMD,CMD_LEN ) ALTRET( OOPS ); LEN= P_PCB.NCHARS; CALL LOG( %DEBUG_COMMAND##,STRNG,LEN ); IF (NOT SILENT_MODE) AND (ADDR(CMD) = ADDR(NIL)) THEN CALL XUR$ECHOIF( M$LO# ); IF BLK1$ = ADDR(NIL) THEN /* Was command done by XUR$GETCMD? */ GOTO DONE_FOR_NOW; ELSE NUM_CMDS= %BLK1_NSUBLKS; /* Remember number of commands */ END; ELSE DO; DONE_FOR_NOW: DONE_PARSING= %YES#; /* Indicate we are done parsing */ GOTO RE_TURN; END; BLK2$= %BLK1_SUBLK$(CMD_NUM); /* Set up some PTRs to the PCB */ IF %BLK2_NSUBLKS > 0 THEN DO; BLK3$= %BLK2_SUBLK$(0); IF %BLK3_NSUBLKS > 0 THEN BLK4$= %BLK3_SUBLK$(0); END; CMD#= %BLK2_CODE; /* Remember the command we're on*/ RE_TURN: RETURN; OOPS: /* The label says it all! */ NUM_CMDS= 0; ERRCODE= PERRCODE; /* Load the error code returned */ ERRDCB#= SI_DCB#; ALT_RETURN: ALTRETURN; /* by XUR$GETCMD, then ALTRETURN*/ END GET_A_CMD; %EJECT; /**** * * G E T _ C H A R _ F R O M _ F I L E * * Get another byte from the file that we are sending to the other computer. * The handling of repeated characters is also taken care of in here (kind * of). * ****/ GET_CHAR_FROM_FILE: PROC ALTRET; GET_NEXT_CHAR: IO_INDX= IO_INDX + 1; /* Point to next input byte */ IF IO_INDX >= ARS THEN DO; /* Past end of record? */ IF REC_CNT > 0 AND /* Any records already been read*/ CUR_MODE = %SET_FILE_MODE_TEXT## THEN DO; IF REPEAT_CNT > 0 THEN DO; /* Any repeated sequence in progress? */ CALL BUILD_REPEAT_SEQUENCE WHENALTRETURN DO; NEXT_CALL= %BUILD_SEQUENCE#; GOTO ALT_RETURN; END; END; CALL INSERT_EOR_CHARS( DATA_BUF,SIZE ) ALTRET( ALT_RETURN ); END; READ_AGAIN: CALL XSA$READ( READ_IN,XSA_PARAM ) ALTRET( EOF_HIT ); REC_CNT= REC_CNT + 1; ARS= XSA_PARAM.ARS#; FILE_BYTE_CNT= FILE_BYTE_CNT + ARS + 2; CALL LOG( %DEBUG_READ##,IO_BUF,ARS ); IO_INDX= 0; IF ARS <= 0 THEN /* If null record, go insert */ GOTO GET_NEXT_CHAR; /* EOR characters and read agn */ END; DO WHILE('0'B); EOF_HIT: ERRCODE= XSA_PARAM.ERR; IF ERRCODE.ERR# = %E$EOF THEN DO; IF REPEAT_CNT > 0 THEN CALL BUILD_REPEAT_SEQUENCE WHENALTRETURN DO; NEXT_CALL= %BUILD_SEQUENCE#; GOTO ALT_RETURN; END; AT_EOF= %YES#; GOTO ALT_RETURN; END; ELSE IF ERRCODE.ERR# = %E$LD THEN DO; /* Lost Data? */ CALL EXPAND( IO_,IO_BUF_SIZE,IO_BUF_SIZE ) ALTRET( NO_MEM ); READ_IN.BUF_= IO_; BACKUP1.KEY_= VECTOR(NIL); BACKUP1.V.DCB#= DCBNUM(F$IN); BACKUP1.V.KEYR#= %NO#; CALL XSA$PRECORD( BACKUP1,XSA_PARAM ) WHENALTRETURN DO; ERRCODE= XSA_PARAM.ERR; IF ERRCODE.ERR# ~= %E$BOF THEN/*Did we try to BACKUP past BOF?*/ GOTO OH_DEAR; /* Nope, go report the error. */ END; GOTO READ_AGAIN; END; ELSE DO; OH_DEAR: CALL SEND_ERROR_PACKET; DO WHILE('0'B); NO_MEM: CALL SEND_ERROR_PACKET( NO_MEM_FOR_IO_BUF,LENGTHC(NO_MEM_FOR_IO_BUF) ); END; STATE= %A_ABORT; ALT_RETURN: ALTRETURN; END; END; RE_TURN: RETURN; END GET_CHAR_FROM_FILE; %EJECT; /**** * * G E T _ D E F A U L T S * * Read any default commands from the default file, :KERMIT_INI. If no such * file exists, just RETURN. * ****/ GET_DEFAULTS: PROC ALTRET; FILE_CNT= 1; /* Start with current FMA */ DO WHILE( '0'B ); GET_ERR: ERRCODE= %MONERR; ERRDCB#= %ERRDCB; CALL INDEX( L,'.',DEFAULT.NAME ); IF (ERRCODE.ERR# = %E$NOFILE) AND NOT F$DEFAULTS$->F$DCB.AMR# THEN DO; FILE_CNT= FILE_CNT + 1; CALL INDEX( L,'.',DEFAULT.NAME ); IF L >= LENGTHC(DEFAULT.NAME) THEN CALL INDEX( L,' ',DEFAULT.NAME ); DO CASE( FILE_CNT ); CASE( 1 ); /* Current File Management Acct */ CASE( 2 ); /* Try logon account */ IF B$JIT.FACCN = B$JIT.ACCN THEN GOTO TRY_LIBRARY_ACCT; CALL INSERT( DEFAULT.NAME,L,,'.',B$JIT.ACCN ); CASE( 3 ); /* As last resort, try :LIBRARY */ TRY_LIBRARY_ACCT: CALL INSERT( DEFAULT.NAME,L,,'.:LIBRARY' ); CASE( ELSE ); GOTO CHECK_ERR; END; CALL INDEX( DEFAULT.LEN,' ',DEFAULT.NAME ); END; END; OPEN_IT: IF F$DEFAULTS$->F$DCB.AMR# AND F$DEFAULTS$->F$DCB.ASN# ~= %DEVICE# THEN DO; CALL OPEN_FID( F$DEFAULTS#,' ',0 ) ALTRET( GET_ERR ); DEFAULT.LEN= LENGTHC(DEFAULT.NAME); CALL UNFID( F$DEFAULTS#,DEFAULT.NAME,DEFAULT.LEN ) ALTRET( GET_ERR ); END; ELSE CALL OPEN_FID( F$DEFAULTS#,DEFAULT.NAME,DEFAULT.LEN ) ALTRET( GET_ERR ); CALL PUT( ' \' ); OFFSET= 0; IF PROMPTING THEN DO; CALL CONCAT( PROMPT.NAME#,SUBSTR(DEFAULT.NAME,0,DEFAULT.LEN),' Cmd> ' ); PROMPT.VFC#= %NO#; PROMPT.L#= DEFAULT.LEN + LENGTHC(' Cmd> '); END; CALL XUR$INIT( XUR_INIT ) ALTRET( GET_ERR ); SI_DCB#= F$DEFAULTS#; CALL XUR$SETDCBS( SI_DCB# ); NUM_CMDS= 0; /* Force a READ from default file */ DO WHILE( NOT DONE ); CALL DO_1_LINE_OF_OPTIONS ALTRET( RESET_DCBS ); END; RESET_DCBS: CALL PUT( ' \' ); CALL CLOSE_A_FILE( F$DEFAULTS# ); IF PROMPTING THEN DO; PROMPT.VFC#= %NO#; PROMPT.L#= LENGTHC('CP-6 Kermit> '); PROMPT.NAME#= 'CP-6 Kermit> '; END; ELSE DO; PROMPT.VFC#= %YES#; PROMPT.L#= LENGTHC('@'); PROMPT.NAME#= '@'; END; CALL XUR$INIT( XUR_INIT ) ALTRET( GET_ERR ); SI_DCB#= DCBNUM(M$SI); CALL XUR$SETDCBS( SI_DCB#,M$LO# ); CHECK_ERR: IF (ERRCODE.ERR# = %E$NOFILE AND NOT F$DEFAULTS$->F$DCB.AMR#) OR (ERRCODE.ERR# = %E$EOF) OR (DONE) THEN RE_TURN: RETURN; ELSE CALL XUR$ERRMSG( ERRCODE,ERRDCB# ); ALT_RETURN: ALTRETURN; END GET_DEFAULTS; %EJECT; /**** * * G E T _ F I D _ F R O M _ P A C K E T * * Get a fid from the packet. The main reason this is a separate subroutine * is to handle repeated characters that may be in the fid. Sigh! * ****/ GET_FID_FROM_PACKET: PROC( SRCE_FID,SRCE_LEN,DEST_FID,DEST_LEN ); DCL SRCE_FID CHAR(SRCE_LEN); DCL SRCE_LEN UBIN; DCL DEST_FID CHAR(80); DCL DEST_LEN UBIN; PACKET_FID= ' '; DEST_LEN= 0; I= 0; DO WHILE( I < SRCE_LEN OR REPEAT_CNT > 0 ); CALL GET_PACKET_CHAR( SRCE_FID,I ); CALL STUFF( DEST_FID,DEST_LEN ) ALTRET( RE_TURN ); END; RE_TURN: RETURN; END GET_FID_FROM_PACKET; %EJECT; /**** * * G E T _ P A C K E T _ C H A R * * Get another character from the packet. If a repeated sequence is in * progress, simply decrement the repeat count and return the repeated * character. Otherwise, point to the next byte in the packet and return it. * ****/ GET_PACKET_CHAR: PROC( BUF,INDX ); DCL BUF CHAR(INDX); DCL INDX UBIN; IF REPEAT_CNT > 0 THEN DO; /* Any repeat in progress? */ REPEAT_CNT= REPEAT_CNT - 1; /* Just decrement count and return */ GOTO RE_TURN; END; CHR= SUBSTR(BUF,INDX,1); /* Get next character */ CHR7_BIT= CHR_BIT & '177'O; /* Leave only low order 7 bits */ INDX= INDX + 1; IF REPEATING AND CHR7 = MY.REPT THEN DO; /* Is it a REPeaT character? */ CHR= SUBSTR(BUF,INDX,1); /* Yep, get next byte */ CHR7_BIT= CHR_BIT & '177'O; INDX= INDX + 1; /* Point to next byte */ CALL UNCHAR( ,CHR7,REPEAT_CNT ); /* Make repeat count useable */ REPEAT_CNT= REPEAT_CNT - 1; /* Don't count the first time */ CHR= SUBSTR(BUF,INDX,1); /* Get byte after repeat count */ CHR7_BIT= CHR_BIT & '177'O; INDX= INDX + 1; END; BIN_MASK= '000'O; /* Assume binary mask of zero */ IF BINARY_QUOTING AND CHR7 = MY.QBIN THEN DO; /* Is IT qbin? */ BIN_MASK= '200'O; /* Remember the 8th bit */ CHR= SUBSTR(BUF,INDX,1); /* Get byte after QBIN */ CHR7_BIT= CHR_BIT & '177'O; INDX= INDX + 1; /* Point to next byte */ END; IF CHR7 = MY.QUOTE THEN DO; /* Is it the QUOTE character? */ CHR= SUBSTR(BUF,INDX,1); /* get byte after the QUOTE char*/ CHR7_BIT= CHR_BIT & '177'O; INDX= INDX + 1; /* Point to next byte */ IF (CHR7 = MY.QUOTE) OR /* If it's the QUOTE */ (BINARY_QUOTING AND CHR7 = MY.QBIN) OR (REPEATING AND CHR7 = MY.REPT) THEN /* or the .REPT char */ ; /* Don't CTL it */ ELSE CALL CTL( CHR,CHR ); /* else, CTL it */ END; CHR_BIT= CHR_BIT | BIN_MASK; /* OR in the 8th bit */ RE_TURN: RETURN; END GET_PACKET_CHAR; %EJECT; /**** * * * Set the activation character set and timeout. * ****/ INIT_ACTIVATION: PROC ALTRET; IF NOT GOT_TRMCTL THEN DO; CALL M$GTRMCTL( ORIG_TRMCTL ) ALTRET( ALT_RETURN ); CALL M$STRMCTL( STRMCTL ) ALTRET( ALT_RETURN ); CALL SET_PARITY_MASK('Y'); GOT_TRMCTL = %YES#; END; RETURN; ALT_RETURN: ALTRETURN; END INIT_ACTIVATION; %EJECT; /**** * * I N I T I A L I Z E * * Initialize various things that can't be at compile time. * ****/ INITIALIZE: PROC ALTRET; F$DEFAULTS$= DCBADDR(DCBNUM(F$DEFAULTS)); /* Set up pointers to some DCBs */ F$DEBUG$= DCBADDR(F$DEBUG#); F$LOG$= DCBADDR(DCBNUM(F$LOG)); F$IN$= DCBADDR(DCBNUM(F$IN)); F$OUT$= DCBADDR(DCBNUM(F$OUT)); F$PACKET_IN$= DCBADDR(DCBNUM(F$PACKET_IN)); F$PACKET_OUT$= DCBADDR(DCBNUM(F$PACKET_OUT)); M$LO$= DCBADDR(DCBNUM(M$LO)); M$SI$= DCBADDR(DCBNUM(M$SI)); PROMPT.VFC#= %NO#; PROMPT.L#= LENGTHC('CP-6 Kermit> '); PROMPT.NAME#= 'CP-6 Kermit> '; CALL XUR$INIT( XUR_INIT ) ALTRET( ALT_RETURN ); CALL XUR$SETDCBS( SI_DCB#,M$LO# ); /* CALL M$INT( BREAK_CNTRL ) ALTRET( ALT_RETURN ); */ /**/ /* Initialize various limits and constants */ /**/ PROTOCOL.MAX_INITIAL_RETRIES= 10; PROTOCOL.MAX_PACKET_RETRIES= 10; PROTOCOL.SYNCHR= BITASC('001'O); /* SOH */ DONE= %NO#; /* Assume we aren't DONE yet! */ GREETING= %YES#; /* Assume we will greet them */ NO_DEFAULTS= %NO#; /* Assume they want defaults */ PROMPTING= %YES#; /* Assume we will prompt also */ SILENT_MODE= %NO#; /* Assume we'll "tell all"! */ CG_MODE = %NO#; CG_SPECIFIED = %NO#; STATION_SPECIFIED = %NO#; /**/ /* Initialize various things in auto */ /**/ DEBUG_OPTS= '0'B; IF F$DEBUG$->F$DCB.AMR# THEN DO; /* Is F$DEBUG SET externally? */ DEBUG_OPTS(%DEBUG_INFO##-%DEBUG_FID##)= %YES#; /* Turn INFO on */ FPT_OPEN= DEFAULT_OPEN; FPT_OPEN.V.ASN#= %FILE#; /* Assume it's a FILE */ FPT_OPEN.V.FUN#= %CREATE#; /* FUNction of CREATE */ CALL OPEN_FID( F$DEBUG#,' ',0,FPT_OPEN ) ALTRET( ALT_RETURN ); CALL UNFID( F$DEBUG#,DEBUG_FILE.NAME#,DEBUG_FILE.LEN ) ALTRET( ALT_RETURN ); END; CALL DO_DEBUG_SET_DEFAULTS; /**/ /* Get buffer for reading/writing the transferred file. */ /**/ IO_= VECTOR(NIL); CALL EXPAND( IO_,4096,IO_BUF_SIZE ) ALTRET( ALT_RETURN ); /* 1 K */ WRITE_OUT.BUF_= IO_; READ_IN.BUF_= IO_; XSA_PARAM.BBUF_= VECTOR(BBUF); XSA_PARAM.KBUF_= VECTOR(KBUF); PACKET_= VECTOR(NIL); CALL EXPAND( PACKET_,4096,PACKET_MAX_SIZE ) ALTRET( ALT_RETURN ); DATA_= VECTOR(NIL); CALL EXPAND( DATA_,4096,DATA_MAX_SIZE ) ALTRET( ALT_RETURN ); READ_PACKET.BUF_= PACKET_; WRITE_PACKET.BUF_= PACKET_; SIZE= 0; EOR_BYTE(0) = %CR; EOR_BYTE(1) = %LF; EOR_BYTE_LEN= LENGTHC(EOR_BYTE(0)) + LENGTHC(EOR_BYTE(1)); CALL STUFF_CHAR_IN_PACKET( EOR_BYTE(0) ); CALL STUFF_CHAR_IN_PACKET( EOR_BYTE(1) ); EOR_CHARS= SUBSTR(DATA_BUF,0,SIZE); EOR_CHARS_LEN= SIZE; REPEAT_CNT= 0; /**/ /* Initialize SET FILE BINARY EXTENSIONS */ /**/ EXTEN.LEN(0) = LENGTHC('?_ARC'); EXTEN.TEXT(0)= '?_ARC'; EXTEN.LEN(1) = LENGTHC('?-ARC'); EXTEN.TEXT(1)= '?-ARC'; EXTEN.LEN(2) = LENGTHC('?_COM'); EXTEN.TEXT(2)= '?_COM'; EXTEN.LEN(3) = LENGTHC('?-COM'); EXTEN.TEXT(3)= '?-COM'; EXTEN.LEN(4) = LENGTHC('?_EXE'); EXTEN.TEXT(4)= '?_EXE'; EXTEN.LEN(5) = LENGTHC('?-EXE'); EXTEN.TEXT(5)= '?-EXE'; EXTEN.LEN(6) = LENGTHC('?_LIB'); EXTEN.TEXT(6)= '?_LIB'; EXTEN.LEN(7) = LENGTHC('?-LIB'); EXTEN.TEXT(7)= '?-LIB'; NUM_EXTENSIONS= 8; RE_TURN: RETURN; ALT_RETURN: ALTRETURN; END INITIALIZE; %EJECT; /**** * * I N S E R T _ E O R _ C H A R S * * Insert the End Of Record sequence needed for the packet. This is * currently always #M#J which is a CR,LF. * ****/ INSERT_EOR_CHARS: PROC(BUF,SIZE) ALTRET; DCL BUF CHAR(SIZE); DCL SIZE UBIN; IF SIZE + EOR_CHARS_LEN > THEIR.PACKET_LENGTH-3 THEN/* Is there room? */ GOTO ALT_RETURN; /* Nope, don't bother */ IF CUR_MODE = %SET_FILE_MODE_TEXT## THEN /* Are we in TEXT mode? */ DO X=0 TO EOR_CHARS_LEN-1; /* Yep, send end of line character(s) */ SUBSTR(BUF,SIZE,1)= SUBSTR(EOR_CHARS,X,1); SIZE= SIZE + 1; END; RE_TURN: RETURN; ALT_RETURN: ALTRETURN; END INSERT_EOR_CHARS; %EJECT; /**** * * L O G * * Write a record to the DEBUG file. REC_TYPE indicates which type of record * it is. * ****/ LOG: PROC( REC_TYPE,BUF,LEN ); DCL REC_TYPE SBIN; DCL BUF CHAR(LEN); DCL LEN UBIN; DCL 1 REC, 2 TYPE CHAR(4) CALIGNED, 2 HH_MM_SS_SS CHAR(11) CALIGNED, 2 DATA CHAR(497) CALIGNED; IF DEBUG_OPTS(REC_TYPE-%DEBUG_FID##) AND F$DEBUG$->F$DCB.FCD# THEN DO; DEBUG_KEY.EDIT= DEBUG_KEY.EDIT + 1000; REC.TYPE= DEBUG_LABEL(REC_TYPE-%DEBUG_FID##); CALL M$TIME( GET_TIME ); REC.HH_MM_SS_SS= HHMMSSSS; REC.DATA= SUBSTR(BUF,0,LEN); WRITE_DEBUG.BUF_= VECTOR(SUBSTR(REC.TYPE,0,LENGTHC(REC.TYPE)+LEN+ LENGTHC(REC.HH_MM_SS_SS)) ); CALL M$WRITE( WRITE_DEBUG ); END; RE_TURN: RETURN; END LOG; %EJECT; /**** * * M E R G E _ F I L E _ N A M E _ I N T O _ D C B * * Merge the name in TARGET into the F$IN DCB for use on a subsequent "real" * OPEN (this is just a TEST OPEN). * ****/ MERGE_FILE_NAME_INTO_DCB: PROC ALTRET; TEST_OPEN_IO= DEFAULT_OPEN; TEST_OPEN_IO.V_= VECTOR(TEST_OPEN_IO.V); TEST_OPEN_IO.V.DCB#= DCBNUM(F$IN); TEST_OPEN_IO.V.FUN#= %IN#; /* Make sure we open it input */ TEST_OPEN_IO.V.OPER.NXTF#= %YES#; /* Assume more than one file */ TEST_OPEN_IO.V.OPER.TEST#= %YES#; TEST_OPEN_IO.V.ACS# = %SEQUEN#; TEST_OPEN_IO.V.SHARE# = %IN#; TEST_OPEN_IO.V.OPER.THISF#= %YES#; /* Start with name in DCB */ CALL M$FID( FID_IO ) ALTRET( BAD_FID ); /* SRCE_FID -> TARGET */ IF TARGET.NAME# = ' ' THEN DO; TARGET.L#= LENGTHC('?'); TARGET.NAME#= '?'; END; CALL INDEX( TARGET_WILD_POS,'?',TARGET.NAME# ); IO_NAME= TARGET; IF TARGET_WILD_POS = 0 THEN DO; /* If leading ? then */ IO_NAME.L#= 0; /* we must search entire account */ IO_NAME.NAME#= ' '; END; ELSE IF TARGET_WILD_POS < LENGTHC(IO_NAME.NAME#) THEN DO;/* If wildcarded */ IO_NAME.L#= TARGET_WILD_POS; /* and ? is NOT first character */ SUBSTR(IO_NAME.NAME#,TARGET_WILD_POS)= ' '; END; /* then use characters up to ? as beginning prefix */ ELSE TEST_OPEN_IO.V.OPER.NXTF#= %NO#; /* Just one file */ CALL M$OPEN( MERGE_IN ) ALTRET( MERGE_ERR );/* Merge file name into F$IN */ RE_TURN: RETURN; BAD_FID: CALL SEARCHR( L,X,SKIP_BLANKS,SRCE_FID ) WHENALTRETURN DO; L= LENGTHC(' '); END; CALL CONCAT( ERR_BUF,'File name passed to CP-6 (', SUBSTR(SRCE_FID,0,L+1), ') was not a valid CP-6 fid.' ); CALL SEARCHR( L,X,SKIP_BLANKS,ERR_BUF ); CALL SEND_ERROR_PACKET( ERR_BUF,L+1 ); GOTO ALT_RETURN; MERGE_ERR: CALL SEND_ERROR_PACKET; ALT_RETURN: ALTRETURN; END MERGE_FILE_NAME_INTO_DCB; %EJECT; /**** * * O P E N _ D E S T _ F I L E * * OPEN the destination file; the one being RECEIVED by CP-6. A record is * written to the LOG file (if one is OPEN) indicating that the transfer has * started. If an error occurs, that too is recorded in the LOG file. * ****/ OPEN_DEST_FILE: PROC ALTRET; CALL WRITE_LOG_REC( %LOG_HEADER# ); CP6_FID= ' '; CALL GET_FID_FROM_PACKET( PACKET.DATA_BUF,LEN,PACKET_FID,J ); FILE_CNT= FILE_CNT + 1; IF FILE_CNT > 1 OR SRCE_FID = ' ' OR IM_A_SERVER THEN DO; SRCE_FID= PACKET_FID; CALL FIX_CP6_FILE_NAME( SRCE_FID,J,%RECEIVE## ); END; OPEN_IO.V.FUN#= %CREATE#; OPEN_IO.V.EXIST#= HOW_RECEIVE; OPEN_IO.V.DCB#= DCBNUM(F$OUT); CALL M$FID( FID_IO ) ALTRET( OOPS ); IF SET_FILE_EDIT = %SET_FILE_EDIT_YES## THEN DO;/* Create EDIT keyed file?*/ OPEN_IO.V.ORG#= %KEYED#; /* yep. */ WRITE_OUT.KEY_= VECTOR(OUT_KEY); OUT_KEY.LEN= LENGTHC(OUT_KEY.EDIT); OUT_KEY.EDIT= 0; END; ELSE DO; /* Create a CONSEC file */ OPEN_IO.V.ORG#= %CONSEC#; WRITE_OUT.KEY_= VECTOR(NIL); END; CALL DETERMINE_RCVD_MODE; OPEN_IO.V.ACS#= %SEQUEN#; OPEN_IO.V.ASN#= %FILE#; OPEN_IO.V.CTG#= %NO#; OPEN_IO.V.RES#= MERGE_IN.V.RES#; OPEN_IO.V.SHARE#= %NONE#; OPEN_IO.ACCT_= VECTOR(IO_ACCT); OPEN_IO.NAME_= VECTOR(TARGET); OPEN_IO.PASS_= VECTOR(IO_PASS); OPEN_IO.SN_= VECTOR(IO_SN); CALL XSA$OPEN( OPEN_IO,XSA_PARAM ) ALTRET( OOPS ); IF TARGET.NAME# = PACKET_FID THEN /* Does CP-6 NAME = one in the packet? */ PACKET_FID= ' '; /* Yep, use CP-6 fid in LOG msgs*/ CP6_FID_LEN= LENGTHC(CP6_FID); CALL UNFID( F$OUT#,CP6_FID,CP6_FID_LEN ); CALL WRITE_LOG_REC( %LOG_STRT_RECEIVE# ); CALL WRITE_LOG_REC( %LOG_MAX_PACKET_SIZES# ); IO_CNT= 0; IO_LEN= 0; IO_BUF= ' '; RE_TURN: RETURN; OOPS: CALL SEND_ERROR_PACKET; ALT_RETURN: ALTRETURN; END OPEN_DEST_FILE; %EJECT; /**** * * O P E N _ F I D * * Utility routine to OPEN DCB number DCB# to the file FID whose name is * FID_LEN bytes and the FPT to use on the OPEN is FPT_OPEN. IF FID was * not passed, use the name currently in the DCB. If FPT_OPEN was not * passed, use the DEFAULT_OPEN fpt. * ****/ OPEN_FID: PROC( DCB#,FID,FID_LEN,OPEN_FPT ) ALTRET; DCL DCB# UBIN; DCL FID CHAR(FIDLEN); DCL FID_LEN SBIN; %FPT_OPEN (FPTN = OPEN_FPT, STCLASS=" " ); DCL FIDLEN SBIN; IF ADDR(OPEN_FPT) = ADDR(NIL) THEN /* Was an FPT passed? */ FPT_OPEN= DEFAULT_OPEN; /* Nope, use default OPEN */ ELSE FPT_OPEN= OPEN_FPT; /* Yep, use it */ FPT_OPEN.V_= VECTOR(FPT_OPEN.V); /* Frame the V area in the FPT */ FPT_OPEN.V.DCB#= DCB#; /* Use their DCB# */ IF FID_LEN < 0 THEN DO; /* Should we find FID length? */ FIDLEN= -FID_LEN; /* Yep. */ CALL SEARCHR( FIDLEN,X,SKIP_BLANKS,FID ) ALTRET( JUST_OPEN_IT ); FIDLEN= FIDLEN + 1; END; ELSE FIDLEN= FID_LEN; /* Nope. They passed the FID_LEN */ IF FID_LEN ~= 0 THEN DO; FPT_FID.V.SCRUB= '111111'B; FPT_FID.TEXTFID_= VECTOR(FID); CALL M$FID( FPT_FID ) ALTRET( ALT_RETURN ); IF VLR_FID.NAME THEN /* Was NAME in FID? */ FPT_OPEN.NAME_= FPT_FID.NAME_; /* Yep, use it on OPEN. */ ELSE FPT_OPEN.NAME_= VECTOR(NIL); /* Nope. */ IF VLR_FID.ACCT THEN /* Was ACCT in FID? */ FPT_OPEN.ACCT_= FPT_FID.ACCT_; /* Yep, use it on the OPEN. */ ELSE FPT_OPEN.ACCT_= VECTOR(NIL); /* Nope. */ IF VLR_FID.PASS THEN /* Was PASSword in FID? */ FPT_OPEN.PASS_= FPT_FID.PASS_; /* Yep, use it on the OPEN. */ ELSE FPT_OPEN.PASS_= VECTOR(NIL); /* Nope. */ IF VLR_FID.SN THEN /* Was an SN in the FID? */ FPT_OPEN.SN_= FPT_FID.SN_; /* Yep, use it on the OPEN. */ ELSE FPT_OPEN.SN_= VECTOR(NIL); /* Nope. */ END; JUST_OPEN_IT: CALL CLOSE_A_FILE( DCB# ); /* CLOSE the DCB, if it's OPEN */ IF DCB# = DCBNUM(F$IN) OR DCB# = DCBNUM(F$OUT) THEN CALL XSA$OPEN( FPT_OPEN,XSA_PARAM ) ALTRET( ALT_RETURN ); ELSE CALL M$OPEN( FPT_OPEN ) ALTRET( ALT_RETURN ); RE_TURN: RETURN; ALT_RETURN: ALTRETURN; END OPEN_FID; %EJECT; /**** * * O P E N _ N E X T _ F I L E * * OPEN the next file. If we can't, so indicate by ALTRETURNing. * ****/ OPEN_NEXT_FILE: PROC ALTRET; CALL M$OPEN( TEST_OPEN_IO ) ALTRET( NOT_OPENED ); /* OPEN [nxtf] */ CUR_FILE= F$IN$->F$DCB.NAME#; /* Remember filename OPENed */ ERRCODE= '0'B; /* No error detected */ GOTO RE_TURN; NOT_OPENED: CUR_FILE= F$IN$->F$DCB.NAME#; /* Remember filename we tried */ ERRCODE= %MONERR; /* remember error code */ ERRDCB#= %ERRDCB; /* remember what DCB it was on */ IF ERRCODE.ERR# = %E$FDEOF THEN /* End of File Directory? */ ALT_RETURN: ALTRETURN; /* Yep! */ RE_TURN: RETURN; END OPEN_NEXT_FILE; %EJECT; /**** * * OPEN the F$PACKET_IN and F$PACKET_OUT dcbs to the comgroup specified * in CG_FID. If either open fails, we close both dcbs and hope that * everything is still ok. * ****/ OPEN_TO_CG: PROC; CALL CLOSE_A_FILE(DCBNUM(F$PACKET_IN)); CALL M$FID(FID_CG); IF (CG_ASN=%FILE#) OR (CG_ASN=%COMGROUP#) THEN DO; CALL M$OPEN(OPEN_CG_IN) ALTRET(ALT_RETURN); CALL M$OPEN(OPEN_CG_OUT) ALTRET(ALT_RETURN); IF NOT GOT_TRMCTL THEN CALL INIT_ACTIVATION ALTRET(ALT_RETURN); CG_MODE = %YES#; END; ELSE DO; ALT_RETURN: CALL PUT('Sorry, that comgroup is not currently available\'); CG_MODE = %NO#; CALL CLOSE_A_FILE(DCBNUM(F$PACKET_IN)); CALL CLOSE_A_FILE(DCBNUM(F$PACKET_OUT)); END; END OPEN_TO_CG; %EJECT; /**** * * P A R S E _ C C B U F * * See if any commands were passed in CCBUF (ie. on the invocation line). If * so, parse them. Then, note any options that are only legal on the * invocation line. Then, read any commands from the default file * (:KERMIT_INI) unless the specified NO DEFAULTS. Then perform any left * over options on the invocation line that have not already been taken care * of. * ****/ PARSE_CCBUF: PROC ALTRET; CCBUF_CMD= %NO#; IF B$JIT.CCDISP < B$JIT.CCARS AND /* Anything in CCBUF? */ SUBSTR(B$JIT.CCBUF,B$JIT.CCDISP) ~= '(' AND SUBSTR(B$JIT.CCBUF,B$JIT.CCDISP) ~= '()' THEN DO; OFFSET= LENGTHC('!') + B$JIT.CCDISP; CMD_BUF= SUBSTR(B$JIT.CCBUF,B$JIT.CCDISP+1); CMD_LEN= B$JIT.CCARS - B$JIT.CCDISP - 1; CMD_NUM= 9999; /* Force GET_A_CMD to look at CMD */ NUM_CMDS= -1; CALL GET_A_CMD( CMD_BUF,CMD_LEN ) ALTRET(OOPS);/* Parse CCBUF commands */ DO I=0 TO %BLK1_NSUBLKS-1; /* Did they specify NO DEFAULTS in CCBUF? */ IF %BLK1_SUBLK$(I)->P_SYM.CODE = %NO_DEFAULTS## THEN DO; IF %BLK1_NSUBLKS = 1 THEN /* If ND is only CCBUF option, */ CCBUF_CMD= %NO#; /* Get additional options from user */ NO_DEFAULTS= %YES#; /* They did, remember they did. */ END; ELSE IF %BLK1_SUBLK$(I)->P_SYM.CODE = %DONT_GREET## THEN GREETING= %NO#; /* Remember not to greet them */ ELSE IF %BLK1_SUBLK$(I)->P_SYM.CODE = %DONT_PROMPT## THEN DO; PROMPT.VFC#= %YES#; PROMPT.L#= LENGTHC('@'); PROMPT.NAME#= '@'; PROMPTING= %NO#; CALL XUR$INIT( XUR_INIT ); END; ELSE IF %BLK1_SUBLK$(I)->P_SYM.CODE = %SILENT## THEN DO; SILENT_MODE= %YES#; %IF OS_VERSION~='B03'; XUR_INIT.ECHO#= %NEVER_ECHO#; %ENDIF; END; ELSE CCBUF_CMD= %YES#; END; IF GREETING THEN /* Did they want a greeting? */ CALL PUT( GREETING_MSG ); /* Yep, looks that way. */ IF NO_DEFAULTS THEN /* Did they say No DEFAULTS? */ GOTO SKIP_DEFAULTS; /* Yep, don't read them! */ CALL GET_DEFAULTS; /* Go read :KERMIT_INI file */ CMD_NUM= 9999; /* Force GET_A_CMD to look at CMD */ NUM_CMDS= 0; CALL GET_A_CMD( CMD_BUF,CMD_LEN ) ALTRET( OOPS ); SKIP_DEFAULTS: CMD_NUM= -1; IF NOT DONE THEN /* If they aren't DONE already */ CALL DO_1_LINE_OF_OPTIONS( CMD_BUF,CMD_LEN ); END; ELSE DO; CMD_NUM= 0; NUM_CMDS= 0; IF GREETING THEN /* Did they want a greeting? */ CALL PUT( GREETING_MSG ); /* Yep, looks that way! */ CALL GET_DEFAULTS; /* Go read :KERMIT_INI file */ END; OFFSET= 0; /* Set OFFSET for PUT_ERROR's finger */ GOTO ARE_WE_DONE; OOPS: CALL PUT_ERROR; /* Go give user the finger! */ ARE_WE_DONE: IF CCBUF_CMD THEN DONE= %YES#; /* Quit now if cmd was in CCBUF */ RE_TURN: RETURN; END PARSE_CCBUF; %EJECT; /**** * * P O S I T I O N _ F I L E * * Position ourselves at the end of the indicated file (via DCB#). If the * file is KEYED, return the KEY of the next record that will be written. * ****/ POSITION_FILE: PROC( DCB#,KEY,NAME,FPT_WRITE ) ALTRET; DCL DCB# UBIN; DCL 1 KEY, 2 LEN UBIN(9) CALIGNED, 2 EDIT UBIN(27) CALIGNED, 2 * CHAR(252) CALIGNED; DCL 1 NAME, 2 LEN UBIN, 2 NAME# CHAR(76); %FPT_WRITE (FPTN = FPT_WRITE, STCLASS=); F_FDS.DCB#= 0; /* Convince X$WRITE NOT to WRITE*/ KEY.LEN= LENGTHC(KEY.EDIT); KEY.EDIT= 0; IF DCBADDR(DCB#)->F$DCB.ORG# = %KEYED# THEN DO; FPT_WRITE.KEY_= VECTOR(KEY); IF DCBADDR(DCB#)->F$DCB.FEXT THEN DO; IF DCBADDR(DCB#)->F$DCB.NRECS# > 0 THEN DO; PFIL_EOF.V.DCB#= DCB#; CALL M$PFIL( PFIL_EOF ) ALTRET( ALT_RETURN ); BACKUP1.V.DCB#= DCB#; BACKUP1.V.KEYR#= %YES#; BACKUP1.KEY_= VECTOR(KEY); CALL M$PRECORD( BACKUP1 ) ALTRET( ALT_RETURN ); IF KEY.LEN ~= LENGTHC(KEY.EDIT) THEN DO; CALL X$WRITE( F_FDS,FMT15_,VEC1_ ); ME_BUF= LO_BUF; CALL PUT( SUBSTR(ME_BUF,1,F_FDS.BUFX-1),F_FDS.BUFX-1 ); CALL CLOSE_A_FILE( DCB# ); GOTO RE_TURN; END; ELSE IF KEY.EDIT >= 99999000 THEN DO; CALL X$WRITE( F_FDS,FMT16_,VEC1_ ); ME_BUF= LO_BUF; CALL PUT( SUBSTR(ME_BUF,1,F_FDS.BUFX-1),F_FDS.BUFX-1 ); CALL CLOSE_A_FILE( DCB# ); GOTO RE_TURN; END; END; X= (KEY.EDIT/1000) + 1; CALL X$WRITE( F_FDS,FMT12_,VEC1_,VECTOR(X) ); ME_BUF= LO_BUF; CALL PUT( SUBSTR(ME_BUF,1,F_FDS.BUFX-1),F_FDS.BUFX-1 ); END; ELSE DO; CALL X$WRITE( F_FDS,FMT14_,VEC1_ ); ME_BUF= LO_BUF; CALL PUT( SUBSTR(ME_BUF,1,F_FDS.BUFX-1),F_FDS.BUFX-1 ); END; END; ELSE DO; FPT_WRITE.KEY_= VECTOR(NIL); CALL X$WRITE( F_FDS,FMT13_,VEC1_,VECTOR(DCBADDR(DCB#)->F$DCB.NRECS#) ); ME_BUF= LO_BUF; CALL PUT( SUBSTR(ME_BUF,1,F_FDS.BUFX-1),F_FDS.BUFX-1 ); END; F_FDS.DCB#= M$LO#; RE_TURN: RETURN; ALT_RETURN: ALTRETURN; END POSITION_FILE; %EJECT; /**** * * P R I N T _ E R R O R _ P A C K E T ( aka PRERRPKT ) * * Print contents of error packet received from remote host. * ****/ PRINT_ERROR_PACKET: PROC; CALL PUT('CP-6 KERMIT aborting with following error from remote KERMIT:\'); CALL PUT( PACKET.DATA,LEN ); STATE= %A_ABORT; RE_TURN: RETURN; END PRINT_ERROR_PACKET; %EJECT; /**** * * P U T * * Output the passed message (the one in BUF) through DCB number DCB#. If * LEN was not passed, then everything in BUF up to the first \ will be * printed. If LEN is positive, it indicates the length of BUF. If LEN is * negative then it indicates the maximum length of BUF. In this case, BUF * is scanned from right to left (starting at the -LEN'th byte and working * left until a non blank is hit. Everything from BUF upto and including the * non blank found will be printed. * ****/ PUT: PROC( BUF,LEN,DCB#,WE_SHOULD_ECHO ); DCL BUF CHAR(BUFLEN); DCL LEN SBIN; DCL DCB# UBIN; DCL WE_SHOULD_ECHO BIT(1); DCL BUFLEN SBIN; IF ADDR(LEN) = ADDR(NIL) THEN DO; /* Is BUF message delimited by a '\'? */ BUFLEN= 132; CALL INDEX1( BUFLEN,'\',BUF ); END; ELSE IF LEN < 0 THEN DO; /* Should we find BUF length? */ BUFLEN= -LEN; /* Yep. */ CALL SEARCHR( BUFLEN,X,SKIP_BLANKS,BUF ) ALTRET( BLANK_LINE ); BUFLEN= BUFLEN + 1; END; ELSE IF LEN = 0 THEN /* Empty buffer (blank line)? */ BLANK_LINE: BUFLEN= LENGTHC(' '); /* Just print a blank */ ELSE BUFLEN= LEN; /* Use the length they passed */ IF ADDR(DCB#) = ADDR(NIL) THEN DO; F_FDS.DCB#= DEFAULT_DCB#; END; ELSE DO; F_FDS.DCB#= DCB#; END; IF ADDR(WE_SHOULD_ECHO) ~= ADDR(NIL) AND WE_SHOULD_ECHO THEN DO; CALL X$WRITE( F_FDS,FMT_,VECTOR(BUF) ); F_FDS.DCB#= DEFAULT_DCB#; /* ECHO it to M$ME too. */ END; IF (NOT SILENT_MODE) OR (ADDR(DCB#) ~= ADDR(NIL)) THEN CALL X$WRITE( F_FDS,FMT_,VECTOR(BUF) ); RE_TURN: RETURN; END PUT; %EJECT; /**** * * P U T _ C H A R _ I N _ P A C K E T * * Insert CHR into the packet. If CHR equals the previous character passed * to this routine then the REPEAT_CNT is just incremented. Otherwise, the * previous character is put in the packet and CHR is put in PREV_CHR for the * next call. * ****/ PUT_CHAR_IN_PACKET: PROC( CHR ) ALTRET; DCL CHR CHAR(1); IF REPEATING THEN DO; /* Is repeating allowed? */ IF REPEAT_CNT > 0 THEN DO; /* Anything in progress? */ IF CHR = PREV_CHR AND REPEAT_CNT < 94 THEN DO; REPEAT_CNT= REPEAT_CNT + 1; GOTO RE_TURN; END; CALL BUILD_REPEAT_SEQUENCE WHENALTRETURN DO; NEXT_CALL= %PUT_CHAR_IN_PACKET#; CUR_CHR= CHR; GOTO ALT_RETURN; END; END; PREV_CHR= CHR; REPEAT_CNT= 1; END; ELSE DO; CALL CALC_SEQUENCE_LEN( CHR ); IF SIZE+SEQUENCE_LEN > THEIR.PACKET_LENGTH-3 THEN DO; NEXT_CALL= %STUFF_CHAR_IN_PACKET#; CUR_CHR= CHR; GOTO ALT_RETURN; END; ELSE CALL STUFF_CHAR_IN_PACKET( CHR ); END; RE_TURN: RETURN; ALT_RETURN: ALTRETURN; END PUT_CHAR_IN_PACKET; %EJECT; /**** * * P U T _ E R R O R * * Print out an error message. * ****/ PUT_ERROR: PROC( FINGER_POS ); DCL FINGER_POS SBIN; IF ERRCODE.ERR# = %E$SYNERR THEN DO; IF (ADDR(FINGER_POS) = ADDR(NIL)) AND (NOT SILENT_MODE) THEN CALL XUR$ECHOIF( M$LO# ); CALL XUR$ERRPTR( OFFSET+P_PCB.HI_CHAR,M$LO# ); /* CALL PUT( '.. Syntax error; parsing stopped where indicated\' ); */ END; ELSE CALL XUR$ERRMSG( ERRCODE,ERRDCB# ); RE_TURN: RETURN; END PUT_ERROR; %EJECT; /**** * * R E C E I V E _ A _ F I L E ( aka RECSW ) * * This is the state table switcher for receiving files. * ****/ RECEIVE_A_FILE: PROC( INIT_STATE ) ALTRET; DCL INIT_STATE CHAR(1); NUM_TRIES= 0; STATE= INIT_STATE; DO WHILE( '1'B ); DO SELECT( STATE ); SELECT( %R_RINIT ); CALL RECEIVE_INIT; SELECT( %F_FILE ); CALL RECEIVE_FILE ALTRET( RE_TURN ); SELECT( %D_DATA ); CALL RECEIVE_DATA; SELECT( %C_COMPLETE ); GOTO RE_TURN; SELECT( %S_SINIT ); GOTO RE_TURN; SELECT( %A_ABORT ); GOTO RE_TURN; SELECT( ELSE ); END; END; RE_TURN: RETURN; END RECEIVE_A_FILE; %EJECT; /**** * * R E C E I V E _ D A T A ( aka RDATA ) * * Receive data * ****/ RECEIVE_DATA: PROC ALTRET; NUM_TRIES= NUM_TRIES + 1; IF NUM_TRIES > PROTOCOL.MAX_PACKET_RETRIES THEN DO; STATE= %A_ABORT; GOTO RE_TURN; END; CALL RECEIVE_PACK( TYPE,RCVD_PACKNUM,LEN,DATA ); DO SELECT( TYPE ); SELECT( %D_DATA ); IF RCVD_PACKNUM = PACKNUM THEN DO; CALL BUFEMP( DATA,LEN ); NUM_DATA_PACKETS= NUM_DATA_PACKETS + 1; END; ELSE IF RCVD_PACKNUM ~= MOD(PACKNUM+63,64) THEN DO; GOTO NAK_THIS_PACKET; END; CALL SEND_PACKET( 'Y',RCVD_PACKNUM,0,' ' ); NUM_TRIES= 0; PACKNUM= MOD(RCVD_PACKNUM+1,64); SELECT( %F_FILE ); IF RCVD_PACKNUM = MOD(PACKNUM+63,64) THEN DO; CALL SEND_PACKET( 'Y',RCVD_PACKNUM,0,' ' ); NUM_TRIES= 0; END; ELSE STATE= %A_ABORT; SELECT( %Z_EOF ); IF RCVD_PACKNUM = PACKNUM THEN DO; CALL SEND_PACKET( 'Y',RCVD_PACKNUM,0,' ' ); IF IO_LEN > 0 THEN /* Anything left to write? */ IF CUR_MODE = %SET_FILE_MODE_TEXT## THEN DO; DO L=IO_LEN-1 DOWNTO 0 BY -1; IF SUBSTR(IO_BUF,L,1) ~= %BINASC(0) THEN GOTO IS_IT_CTL_Z; END; L= IO_LEN; GOTO KEEP_IT; IS_IT_CTL_Z: IF SUBSTR(IO_BUF,L,1) = %SUB THEN IF L>0 THEN KEEP_IT: CALL WRITE_RECORD( IO_BUF,L ); ELSE; ELSE CALL WRITE_RECORD( IO_BUF,L+1 ); END; ELSE CALL WRITE_RECORD( IO_BUF,IO_LEN ); IF LEN > 0 AND SUBSTR(DATA_BUF,0,1) = 'D' THEN /* Sender requested the transfer to be stopped */ CALL CLOSE_A_FILE( DCBNUM(F$OUT),%RELEASE# ); ELSE CALL CLOSE_A_FILE( DCBNUM(F$OUT) ); CALL WRITE_LOG_REC( %LOG_NUM_DATA_PACKETS# ); CALL WRITE_LOG_REC( %LOG_END_RECEIVE# ); CALL WRITE_LOG_REC( %LOG_ELAPSED_TIME# ); PACKNUM= MOD(RCVD_PACKNUM+1,64); STATE= %F_FILE; END; ELSE STATE= %A_ABORT; SELECT( %S_SINIT ); STATE= %S_SINIT; CALL CLOSE_A_FILE( F$OUT#,SET_FILE_INCOMPLETE - %SET_FILE_INCOMPLETE_DISCARD##+1 ); SELECT( %E_ERROR ); STATE= %A_ABORT; CALL CLOSE_A_FILE( F$OUT#,SET_FILE_INCOMPLETE - %SET_FILE_INCOMPLETE_DISCARD##+1 ); SELECT( ELSE ); NAK_THIS_PACKET: CALL SEND_PACKET( 'N',PACKNUM,0,' ' ); END; RE_TURN: RETURN; END RECEIVE_DATA; %EJECT; /**** * * R E C E I V E _ F I L E ( aka RFILE ) * * Receive File Header * ****/ RECEIVE_FILE: PROC ALTRET; NUM_TRIES= NUM_TRIES + 1; IF NUM_TRIES > PROTOCOL.MAX_PACKET_RETRIES THEN DO; STATE= %A_ABORT; GOTO RE_TURN; END; CALL RECEIVE_PACK( TYPE,RCVD_PACKNUM,LEN,DATA ); DO SELECT( TYPE ); SELECT( %S_SINIT ); IF RCVD_PACKNUM = MOD(PACKNUM+63,64) THEN DO; CALL SEND_OUR_PARAMS( %RECEIVE## ); CALL SEND_PACKET( 'Y',PACKNUM,PACKLEN,DATA ); NUM_TRIES= 0; END; ELSE STATE= %A_ABORT; SELECT( %Z_EOF ); IF RCVD_PACKNUM = MOD(PACKNUM+63,64) THEN DO; CALL SEND_PACKET( 'Y',RCVD_PACKNUM,0,' ' ); NUM_TRIES= 0; END; ELSE STATE= %A_ABORT; SELECT( %F_FILE ); IF RCVD_PACKNUM ~= PACKNUM THEN DO; STATE= %A_ABORT; GOTO RE_TURN; END; REPEAT_CNT= 0; CALL OPEN_DEST_FILE ALTRET( ALT_RETURN ); CALL SEND_PACKET( 'Y',PACKNUM,0,' ' ); AT_EOF= %NO#; /* We haven't seen a SUB yet! */ NUM_TRIES= 0; FILE_BYTE_CNT= 0; NEXT_CALL= %NOTHING#; NUM_DATA_PACKETS= 0; REC_CNT= 0; PACKNUM= MOD(PACKNUM+1,64); STATE= %D_DATA; SELECT( %B_BREAK ); IF RCVD_PACKNUM = PACKNUM THEN DO; CALL SEND_PACKET( 'Y',PACKNUM,0,' ' ); STATE= %C_COMPLETE; END; ELSE STATE= %A_ABORT; SELECT( ELSE ); STATE= %A_ABORT; END; RE_TURN: RETURN; ALT_RETURN: ALTRETURN; END RECEIVE_FILE; %EJECT; /**** * * R E C E I V E _ I N I T ( aka RINIT ) * * Receive Initialization * ****/ RECEIVE_INIT: PROC ALTRET; NUM_TRIES= NUM_TRIES + 1; IF NUM_TRIES > PROTOCOL.MAX_INITIAL_RETRIES THEN DO; STATE= %A_ABORT; GOTO RE_TURN; END; X= MY.TIMEOUT; CALL SET_TIMEOUT( X ); /* Set packet read timeout */ CALL RECEIVE_PACK( TYPE,RCVD_PACKNUM,LEN,DATA ); DO SELECT( TYPE ); SELECT( %S_SINIT ); CALL RECEIVE_THEIR_PARAMS( LEN,%RECEIVE## ); CALL SEND_OUR_PARAMS( %RECEIVE## ); CALL SEND_PACKET( 'Y',PACKNUM,PACKLEN,DATA ); NUM_TRIES= 0; PACKNUM= MOD(RCVD_PACKNUM+1,64); STATE= %F_FILE; SELECT( %E_ERROR ); STATE= %A_ABORT; SELECT( ELSE ); CALL SEND_PACKET( 'N',PACKNUM,0,' ' ); END; RE_TURN: RETURN; END RECEIVE_INIT; %EJECT; /**** * * R E C E I V E _ P A C K * * Read a packet. Check to see if it is the special case where the user is * trying to exit out of SERVER mode. If so, remember that and RETURN. * Otherwise, log a record in the DEBUG file (if we're DEBUGging), calculate * the checksum and check it. * ****/ RECEIVE_PACK: PROC( TYPE,NUM,LEN,DATA ) ALTRET; DCL TYPE UBIN(9) CALIGNED; DCL NUM UBIN; DCL LEN UBIN; DCL DATA(0:93) UBIN(9) CALIGNED; DCL DATA_BIT(0:93) REDEF DATA BIT(9); DCL IX SBIN; DCL PACKET_ARS UBIN; IF NOT GOT_TRMCTL THEN CALL INIT_ACTIVATION ALTRET(ALT_RETURN); READ_AGAIN: PACKET= '0'B; CALL M$READ( READ_PACKET ) ALTRET( TIMED_OUT ); PACKET_ARS= F$PACKET_IN$ -> F$DCB.ARS#; CONTINUE: SUBSTR(PACKET_BUF,PACKET_ARS,1)= F$PACKET_IN$ -> F$DCB.EOMCHAR#; CALL LOG( %DEBUG_RECEIVE##,PACKET,PACKET_ARS+LENGTHC(F$DCB.EOMCHAR#) ); IF CHARMASK ~= '377'O THEN DO J=0 TO (PACKET_ARS+3)/4; PACKET_WORD(J) = PACKET_WORD(J) & WORDMASK; END; /* Do they just want out of SERVER mode? */ IF IM_A_SERVER AND (PACKET_ARS = 0 OR SUBSTR(PACKET_BUF,0,PACKET_ARS) = ' ' OR SUBSTR(PACKET_BUF,0,PACKET_ARS) = 'END') THEN DO; PACKET_BUF= 'END'; TRANSFER_INTERRUPTED= %YES#; GOTO RE_TURN; END; /* We have to flush the characters found between packets, so we look for a 'start_of_packet', and ignore anything that comes before that. */ IF PACKET_ARS < 4 THEN GOTO READ_AGAIN; IF PACKET.MARK ~= MY.START_OF_PACKET THEN DO; CALL INDEX(IX,MY.START_OF_PACKET,SUBSTR(PACKET_BUF,0,PACKET_ARS)) ALTRET(READ_AGAIN); PACKET_BUF = SUBSTR(PACKET_BUF,IX,PACKET_ARS-IX); PACKET_ARS = PACKET_ARS-IX; IF PACKET_ARS < 4 THEN GOTO READ_AGAIN; END; LEN= PACKET.LEN - 3 - ASCBIN(' '); CALL UNCHAR( ,PACKET.SEQ,NUM ); TYPE= PACKET.TYPE; CALL BLOCK_MOVE( DATA,PACKET.DATA,LEN ); CALL UNCHAR( ,PACKET.DATA(LEN),RCVD_CHECKSUM ); CALL CALC_CHECKSUM( CHECKSUM ); IF RCVD_CHECKSUM ~= CHECKSUM THEN /* Bad checksum? */ NAK_THIS_PACKET: TYPE= ASCBIN(%N_NAK); /* yep, NAK this packet */ RE_TURN: RETURN; TIMED_OUT: PACKET_ARS= F$PACKET_IN$ -> F$DCB.ARS#; IF (B$TCB$->B$TCB.ALT$->B$ALT.ERR.CODE = %E$TIMO) OR /* Did READ timeout?*/ (B$TCB$->B$TCB.ALT$->B$ALT.ERR.CODE = %E$EOF) THEN IF PACKET_ARS > 0 THEN /* Yep, anything read? */ GOTO CONTINUE; /* Yep, go use it */ ELSE DO; CALL LOG( %DEBUG_TIMEOUT##,' Timeout in RECEIVE_PACK.',25 ); TYPE= ASCBIN(%N_NAK); END; ELSE IF B$TCB$->B$TCB.ALT$->B$ALT.ERR.CODE = %E$DI THEN /* Noisy line? */ GOTO READ_AGAIN; /* Yep, try again */ ELSE CALL M$MERC; ALT_RETURN: ALTRETURN; END RECEIVE_PACK; %EJECT; /**** * * R E C E I V E _ T H E I R _ P A R A M S ( aka rpar ) * * Get the other host's send-init parameters. * ****/ RECEIVE_THEIR_PARAMS: PROC( LEN,DIRECTION ); DCL LEN UBIN; DCL DIRECTION UBIN; CALL UNCHAR( THEIR.PACKET_LENGTH,DATA(0) ); /* MAXL */ CALL UNCHAR( THEIR.TIMEOUT, DATA(1) ); /* TIME */ CALL UNCHAR( THEIR.PADDING, DATA(2) ); /* NPAD */ CALL CTL( THEIR.PADCHAR, DATA(3) ); /* PADC */ CALL UNCHAR( THEIR.END_OF_LINE, DATA(4) ); /* EOL */ THEIR.QUOTE= BINASC(DATA(5)); /* QCTL */ IF LEN > 6 THEN THEIR.QBIN= BINASC(DATA(6)); /* QBIN */ ELSE THEIR.QBIN= 'N'; IF LEN > 7 THEN THEIR.BLOCK_CHECK= %ASCBIN('1'); /* CHKT */ ELSE THEIR.BLOCK_CHECK= %ASCBIN('1'); /* CHKT */ IF LEN > 8 THEN THEIR.REPT= BINASC(DATA(8)); /* REPT */ ELSE THEIR.REPT= ' '; IF LEN > 9 THEN CALL UNCHAR( THEIR.CAPAS,DATA(9) ); /* MASK */ ELSE CALL UNCHAR( THEIR.CAPAS,DATA(9) ); /* MASK */ CALL SET_PARITY_MASK( THEIR.QBIN ); IF DIRECTION = %RECEIVE## THEN DO; IF THEIR.QBIN = 'Y' THEN IF CHARMASK = '177'O THEN DO; /* Do we need to do 8-bit quoting? */ BINARY_QUOTING= %YES#; /* Yep. */ IF MY_DEFAULT.QBIN = 'Y' THEN /* If my default is a Y, */ MY.QBIN= '&'; /* send them an & */ ELSE MY.QBIN= MY_DEFAULT.QBIN; /* Otherwise, use what user said */ THEIR.QBIN= MY.QBIN; /* Make theirs the same */ END; ELSE DO; BINARY_QUOTING= %NO#; /* Don't do 8-bit quoting */ MY.QBIN= 'N'; THEIR.QBIN= 'N'; END; ELSE IF (THEIR.QBIN >= '!' AND THEIR.QBIN <= '>') OR (THEIR.QBIN >= '`' AND THEIR.QBIN <= '~') THEN DO; MY.QBIN= THEIR.QBIN; /* Use their QBIN */ BINARY_QUOTING= %YES#; END; ELSE DO; /* Strange character */ MY.QBIN= 'N'; /* Don't do 8-bit quoting */ BINARY_QUOTING= %NO#; END; IF (THEIR.REPT >= '!' AND THEIR.REPT <= '>') OR (THEIR.REPT >= '`' AND THEIR.REPT <= '~') THEN DO; MY.REPT= THEIR.REPT; REPEATING= %YES#; REPEAT_LEN= LENGTHC(THEIR.REPT) + 1; END; ELSE DO; REPEATING= %NO#; REPEAT_LEN= 0; MY.REPT= ' '; END; END; ELSE DO; /* DIRECTION = %SEND## */ IF (THEIR.QBIN >= '!' AND THEIR.QBIN <= '>') OR (THEIR.QBIN >= '`' AND THEIR.QBIN <= '~') THEN DO; MY.QBIN= THEIR.QBIN; /* Use their quote character */ BINARY_QUOTING= %YES#; END; ELSE DO; MY.QBIN= 'N'; /* Don't do 8-bit quoting */ BINARY_QUOTING= %NO#; END; IF ((THEIR.REPT >= '!' AND THEIR.REPT <= '>') OR (THEIR.REPT >= '`' AND THEIR.REPT <= '~')) AND MY.REPT = THEIR.REPT THEN DO; REPEATING= %YES#; REPEAT_LEN= LENGTHC(THEIR.REPT) + 1; END; ELSE DO; REPEATING= %NO#; REPEAT_LEN= 0; END; END; RE_TURN: RETURN; END RECEIVE_THEIR_PARAMS; %EJECT; /**** * * S E N D * * SEND a file(s). * ****/ SEND: PROC ALTRET; SET_STEPCC.V.STEPCC# = 3; /* default stepcc= can't find file */ CALL MERGE_FILE_NAME_INTO_DCB ALTRET( ALT_RETURN ); %IF OS_VERSION='B03'; WILD_COMPARE.PATTERN$= ADDR(TARGET); %ELSE; WILD_COMPARE.PATTERN_= VECTOR(SUBSTR(TARGET.NAME#,0,TARGET.L#)); %ENDIF; IF DELAY > 0 AND /* Should we pause before initial packet? */ NOT IM_A_SERVER THEN DO; CALL SNOOZE( DELAY ); END; FILE_CNT= 0; /* No files sent yet... */ OK_TO_SEND= %YES#; PACKNUM= 0; /* Zero packet number */ TRANSFER_INTERRUPTED= %NO#; DO WHILE( OK_TO_SEND AND (NOT TRANSFER_INTERRUPTED) ); CALL OPEN_NEXT_FILE ALTRET( PUT_SUM ); CALL DO_WE_WANT_THIS_FILE ALTRET( CLOSE_F$IN ); CALL SEND_A_FILE ALTRET( CLOSE_F$IN ); CLOSE_F$IN: CALL CLOSE_A_FILE( DCBNUM(F$IN) ); TEST_OPEN_IO.V.OPER.THISF#= %NO#; END; PUT_SUM: ; IF FILE_CNT > 0 AND /* Were any file sent? */ (NOT TRANSFER_INTERRUPTED) THEN DO; STATE= %B_BREAK; /* Send BREAK to stop transfer */ DO WHILE( STATE = %B_BREAK ); CALL SEND_BREAK; END; END; RE_TURN: RETURN; ALT_RETURN: ALTRETURN; END SEND; %EJECT; /**** * * S E N D _ A _ F I L E ( aka sendsw ) * * SENDSW is the state table switcher for sending files. It loops until * either it finishes, or an error is encountered. The routines called * by SENDSW are responsible for changing the state. * ****/ SEND_A_FILE: PROC ALTRET; CALL OPEN_FID( DCBNUM(F$IN),' ',0 ) ALTRET( OPEN_ERR ); CALL DETERMINE_SEND_MODE; /* Determine MODE */ CP6_FID= SUBSTR(CUR_FILE.NAME#,0,CUR_FILE.L#); PACKET_FID= CP6_FID; X= CUR_FILE.L#; CALL FIX_PC_FILE_NAME( PACKET_FID,X ); IF TARGET_WILD_POS = LENGTHC(TARGET.NAME#) THEN /* Just one file? */ IF NOT IM_A_SERVER THEN IF %BLK2_NSUBLKS > 1 THEN DO; /* Was "AS" name specified? */ BLK3$= %BLK2_SUBLK$(1); /* Yep, point to it. */ PACKET_FID= %BLK3_TEXT; END; CALL WRITE_LOG_REC( %LOG_HEADER# ); CALL WRITE_LOG_REC( %LOG_STRT_SEND# ); CALL WRITE_LOG_REC( %LOG_MAX_PACKET_SIZES# ); SET_STEPCC.V.STEPCC# = 2; /* stepcc= starting to send */ X= MY.TIMEOUT; CALL SET_TIMEOUT( X ); AT_EOF= %NO#; /* Assume we haven't hit EOF yet*/ DONE_SENDING= %NO#; /* We aren't done yet */ FILE_BYTE_CNT= 0; /* Zero # bytes in file count */ NEXT_CALL= %NOTHING#; /* Zero this to start with */ NUM_TRIES= 0; /* Zero retry count */ NUM_DATA_PACKETS= 0; /* Zero count of Data packets */ REPEAT_CNT= 0; /* Zero the REPEAT count */ FILE_CNT= FILE_CNT + 1; /* Count this file */ IF FILE_CNT < 2 THEN STATE= %S_SINIT; ELSE STATE= %F_FILE; DO UNTIL( DONE_SENDING OR TRANSFER_INTERRUPTED ); DO SELECT( STATE ); SELECT( %D_DATA ); CALL SEND_DATA; SELECT( %F_FILE ); CALL SEND_FILE; SELECT( %Z_EOF ); CALL SEND_EOF; SELECT( %S_SINIT ); CALL SEND_INIT; SELECT( %B_BREAK ); CALL SEND_BREAK; SELECT( %C_COMPLETE ); DONE_SENDING= %YES#; SELECT( %A_ABORT ); DONE_SENDING= %YES#; SELECT( ELSE ); CALL CONCAT( ERR_BUF,'>> Unexpected SEND state of ''', STATE, ''' in SEND_A_FILE\' ); CALL SEND_ERROR_PACKET( ERR_BUF,46 ); END; END; RE_TURN: RETURN; OPEN_ERR: IF IM_A_SERVER THEN DO; CALL SEND_ERROR_PACKET; END; ELSE DO; ERRCODE= %MONERR; ERRDCB#= %ERRDCB; CALL XUR$ERRMSG( ERRCODE,ERRDCB# ); END; OK_TO_SEND= %NO#; ALT_RETURN: SET_STEPCC.V.STEPCC# = 3; /* stepcc= can't find file */ ALTRETURN; END SEND_A_FILE; %EJECT; /**** * * S E N D _ B R E A K ( aka SBREAK ) * * Send Break (EOT) * ****/ SEND_BREAK: PROC ALTRET; NUM_TRIES= NUM_TRIES + 1; IF NUM_TRIES > PROTOCOL.MAX_PACKET_RETRIES THEN DO; STATE= %A_ABORT; GOTO RE_TURN; END; CALL SEND_PACKET( 'B',PACKNUM,0,DATA ); CALL RECEIVE_PACK( TYPE,RCVD_PACKNUM,LEN,DATA ); DO SELECT( TYPE ); SELECT( %N_NAK ); IF RCVD_PACKNUM = MOD(PACKNUM+1,64) THEN GOTO ACKUALLY_ITS_OK; SELECT( %Y_ACK ); IF RCVD_PACKNUM = PACKNUM THEN DO; ACKUALLY_ITS_OK: NUM_TRIES= 0; /* Reset number of tries */ PACKNUM= MOD(PACKNUM+1,64); STATE= %C_COMPLETE; CALL SET_TIMEOUT( 0 ); END; SELECT( %E_ERROR ); CALL PRINT_ERROR_PACKET; SELECT( ELSE ); STATE= %A_ABORT; END; RE_TURN: RETURN; END SEND_BREAK; %EJECT; /**** * * S E N D _ D A T A ( aka SDATA ) * * Send File Data * ****/ SEND_DATA: PROC ALTRET; NUM_TRIES= NUM_TRIES + 1; IF NUM_TRIES > PROTOCOL.MAX_PACKET_RETRIES THEN DO; STATE= %A_ABORT; GOTO RE_TURN; END; CALL SEND_PACKET( 'D',PACKNUM,SIZE,DATA ); CALL RECEIVE_PACK( TYPE,RCVD_PACKNUM,LEN,DATA ); DO SELECT( TYPE ); SELECT( %N_NAK ); IF RCVD_PACKNUM = MOD(PACKNUM+1,64) THEN GOTO ACKUALLY_ITS_OK; SELECT( %Y_ACK ); IF RCVD_PACKNUM = PACKNUM THEN DO; ACKUALLY_ITS_OK: NUM_DATA_PACKETS= NUM_DATA_PACKETS + 1; NUM_TRIES= 0; /* Reset number of tries */ PACKNUM= MOD(PACKNUM+1,64); IF LEN > 0 AND (SUBSTR(DATA_BUF,0,1) = 'X' OR SUBSTR(DATA_BUF,0,1) = 'Z') THEN DO; STATE= %Z_EOF; IF SUBSTR(DATA_BUF,0,1) = 'Z' THEN TRANSFER_INTERRUPTED= %YES#; /* Stop multi file transfer */ END; ELSE DO; CALL BUFILL ALTRET( RE_TURN ); STATE= %D_DATA; END; END; SELECT( %E_ERROR ); CALL PRINT_ERROR_PACKET; SELECT( ELSE ); STATE= %A_ABORT; END; RE_TURN: RETURN; END SEND_DATA; %EJECT; /**** * * S E N D _ E O F ( aka SEOF ) * * Send End-Of-File. * ****/ SEND_EOF: PROC ALTRET; NUM_TRIES= NUM_TRIES + 1; IF NUM_TRIES > PROTOCOL.MAX_PACKET_RETRIES THEN DO; STATE= %A_ABORT; GOTO RE_TURN; END; IF TRANSFER_INTERRUPTED THEN DO; LEN= LENGTHC('D'); SUBSTR(DATA_BUF,0,1)= 'D'; END; ELSE LEN= 0; CALL SEND_PACKET( 'Z',PACKNUM,0,DATA ); CALL RECEIVE_PACK( TYPE,RCVD_PACKNUM,LEN,DATA ); DO SELECT( TYPE ); SELECT( %N_NAK ); IF RCVD_PACKNUM = MOD(PACKNUM+1,64) THEN GOTO ACKUALLY_ITS_OK; SELECT( %Y_ACK ); IF RCVD_PACKNUM = PACKNUM THEN DO; ACKUALLY_ITS_OK: CALL WRITE_LOG_REC( %LOG_END_SEND# ); CALL WRITE_LOG_REC( %LOG_NUM_DATA_PACKETS# ); CALL WRITE_LOG_REC( %LOG_ELAPSED_TIME# ); SET_STEPCC.V.STEPCC# = 0; /* stepcc = successful send */ NUM_TRIES= 0; /* Reset number of tries */ PACKNUM= MOD(PACKNUM+1,64); STATE= %C_COMPLETE; END; SELECT( %E_ERROR ); CALL PRINT_ERROR_PACKET; SELECT( ELSE ); STATE= %A_ABORT; END; RE_TURN: RETURN; END SEND_EOF; %EJECT; /**** * * S E N D _ E R R O R _ P A C K E T * * Send an error packet to the "other computer". * ****/ SEND_ERROR_PACKET: PROC( BUF,LEN ); DCL BUF CHAR(LEN); DCL LEN UBIN; IF ADDR(BUF)=ADDR(NIL) THEN DO; FPT_ERRMSG.V.DCB#= %ERRDCB; ERRCODE= %MONERR; CALL M$ERRMSG( FPT_ERRMSG ); CALL SEARCHR( I,X,SKIP_BLANKS,ERR_BUF ) WHENALTRETURN DO; I= LENGTHC(ERR_BUF) - 1; END; I= I + 1; END; ELSE DO; I= LEN; ERR_BUF= BUF; END; CALL SEND_PACKET( 'E',PACKNUM,I,ERR_BUF ); CALL WRITE_LOG_REC( %LOG_ERRMSG#,I ); RE_TURN: RETURN; END SEND_ERROR_PACKET; %EJECT; /**** * * S E N D _ F I L E ( aka SFILE ) * * Send File Header. * ****/ SEND_FILE: PROC ALTRET; ARS= 0; IO_INDX= 999; REC_CNT= 0; /* Zero number record read */ OUT_INDX= 0; NUM_TRIES= NUM_TRIES + 1; IF NUM_TRIES > PROTOCOL.MAX_PACKET_RETRIES THEN DO; STATE= %A_ABORT; GOTO RE_TURN; END; CALL SEARCHR( LEN,X,SKIP_BLANKS,PACKET_FID ); CALL SEND_PACKET( 'F',PACKNUM,LEN+1,PACKET_FID ); CALL RECEIVE_PACK( TYPE,RCVD_PACKNUM,LEN,DATA ); DO SELECT( TYPE ); SELECT( %N_NAK ); IF RCVD_PACKNUM = MOD(PACKNUM+1,64) THEN GOTO ACK_UALLY_ITS_OK; SELECT( %Y_ACK ); IF RCVD_PACKNUM = PACKNUM THEN DO; ACK_UALLY_ITS_OK: NUM_TRIES= 0; PACKNUM= MOD(PACKNUM+1,64); CALL BUFILL ALTRET( RE_TURN ); STATE= %D_DATA; END; SELECT( %E_ERROR ); CALL PRINT_ERROR_PACKET; SELECT( ELSE ); STATE= %A_ABORT; END; RE_TURN: RETURN; END SEND_FILE; %EJECT; /**** * * S E N D _ I N I T ( aka SINIT ) * * Send Initiate: send this host's parameters and get other sides back. * ****/ SEND_INIT: PROC ALTRET; NUM_TRIES= NUM_TRIES + 1; IF NUM_TRIES > PROTOCOL.MAX_INITIAL_RETRIES THEN DO; STATE= %A_ABORT; GOTO RE_TURN; END; CALL SEND_OUR_PARAMS( %SEND## ); /* Fill in our init info packet */ CALL FLUSH_INPUT; /* Flush any pending input */ CALL SEND_PACKET( 'S',PACKNUM,PACKLEN,DATA ); /* Send our S packet */ CALL RECEIVE_PACK( TYPE,RCVD_PACKNUM,LEN,DATA );/* Get a reply */ DO SELECT( TYPE ); /* What did they send? */ SELECT( %N_NAK ); SELECT( %Y_ACK ); IF RCVD_PACKNUM ~= PACKNUM THEN /* Wrong packet number? */ EXIT; /* Yep, ignore it and try agn */ CALL RECEIVE_THEIR_PARAMS( LEN,%SEND## ); NUM_TRIES= 0; PACKNUM= MOD(PACKNUM+1,64); STATE= %F_FILE; SELECT( %E_ERROR ); CALL PRINT_ERROR_PACKET; SELECT( ELSE ); STATE= %A_ABORT; END; RE_TURN: RETURN; END SEND_INIT; %EJECT; /**** * * S E N D _ O U R _ P A R A M S ( aka SPAR ) * * Fill the data array with my send-init parameters * ****/ SEND_OUR_PARAMS: PROC( DIRECTION ); DCL DIRECTION UBIN; IF DIRECTION = %SEND## THEN /* If we're SENDing, init MY */ MY= MY_DEFAULT; CALL TOCHAR( DATA(0),MY.PACKET_LENGTH ); /* MAXL */ CALL TOCHAR( DATA(1),MY.TIMEOUT ); /* TIME */ CALL TOCHAR( DATA(2),MY.PADDING ); /* NPAD */ CALL CTL( DATA(3),MY.PADCHAR ); /* PADC */ CALL TOCHAR( DATA(4),MY.END_OF_LINE ); /* EOL */ SUBSTR(DATA_BUF,5,1)= MY.QUOTE; /* QCTL */ SUBSTR(DATA_BUF,6,1)= MY.QBIN; /* QBIN */ SUBSTR(DATA_BUF,7,1)= '1'; /* CHKT */ SUBSTR(DATA_BUF,8,1)= MY.REPT; /* REPT */ PACKLEN= 9; RE_TURN: RETURN; END SEND_OUR_PARAMS; %EJECT; /**** * * S E N D _ P A C K E T * * Send off the packet in progress. If a LOG file is OPEN, write the packet * to the LOG file too. * ****/ SEND_PACKET: PROC( TYPE,NUM,LEN,DATA ) ALTRET; DCL TYPE CHAR(1); DCL NUM UBIN; DCL LEN UBIN; DCL DATA(0:93) UBIN(9) CALIGNED; IF NOT GOT_TRMCTL THEN CALL INIT_ACTIVATION ALTRET(ALT_RETURN); IF THEIR.PADDING > 0 THEN /* Any padding needed? */ CALL SEND_PADCHARS( THEIR.PADDING ); /* Yep, go do it. */ PACKET.MARK= PROTOCOL.SYNCHR; /* Usually SOH */ UBIN9= LEN + 3; CALL TOCHAR( PACKET.LEN,UBIN9 ); UBIN9= NUM; CALL TOCHAR( PACKET.SEQ,UBIN9 ); PACKET.TYPE= ASCBIN(TYPE); CALL BLOCK_MOVE( PACKET.DATA,DATA,LEN ); CALL CALC_CHECKSUM( CHECKSUM ); UBIN9= CHECKSUM; CALL TOCHAR( PACKET.DATA(LEN),UBIN9 ); PACKET.DATA(LEN+1)= ASCBIN(THEIR.END_OF_LINE); WRITE_PACKET.BUF_.BOUND= LEN + 4 + 1; CALL M$WRITE( WRITE_PACKET ) ALTRET( ALT_RETURN ); CALL LOG( %DEBUG_SEND##,PACKET,WRITE_PACKET.BUF_.BOUND+1 ); RE_TURN: RETURN; ALT_RETURN: ALTRETURN; END SEND_PACKET; %EJECT; /**** * * S E N D _ P A D C H A R S * * This currently does nothing! * ****/ SEND_PADCHARS: PROC( COUNT ); DCL COUNT UBIN(9) CALIGNED; RE_TURN: RETURN; END SEND_PADCHARS; %EJECT; /**** * * S E R V E R * * This takes care of the SERVER mode. * ****/ SERVER: PROC ALTRET; NEXT_CALL= %NOTHING#; NUM_TRIES= 0; MY= MY_DEFAULT; PACKNUM= 0; REPEAT_CNT= 0; CALL PUT('CP-6 Kermit SERVER at your service\'); CALL PUT('To shut me (the SERVER) down, enter BYE or FINISH on your local machine.\'); IM_A_SERVER= %YES#; /* Remember I'm in SERVER mode */ IF GOT_TRMCTL THEN CALL M$STRMCTL( STRMCTL ) ALTRET( ALT_RETURN ); /* Set ACTONTRN AGAIN */ ELSE CALL INIT_ACTIVATION ALTRET( ALT_RETURN ); DO WHILE('1'B); CALL RECEIVE_PACK( TYPE,RCVD_PACKNUM,LEN,DATA ); IF PACKET_BUF = 'END' THEN DO; IM_A_SERVER= %NO#; /* I won't be a SERVER any more */ GOTO RE_TURN; END; DO SELECT( TYPE ); SELECT( %N_NAK ); CALL SEND_PACKET( 'N',PACKNUM,0,' ' ); SELECT( %I_INIT, %S_SINIT ); /* RECEIVE a file(s) */ PACKNUM= RCVD_PACKNUM; CALL RECEIVE_THEIR_PARAMS( LEN,%RECEIVE## ); CALL SEND_OUR_PARAMS( %RECEIVE## ); CALL SEND_PACKET( 'Y',PACKNUM,PACKLEN,DATA ); FILE_CNT= 0; NUM_TRIES= 0; SRCE_FID= ' '; TX= 0; OPEN_IO= DEFAULT_OPEN; OPEN_IO.V_= VECTOR(OPEN_IO.V); HOW_RECEIVE= SET_FILE_WARNING - %SET_FILE_WARNING_ON## + 1; IF TYPE = %S_SINIT THEN DO; PACKNUM= MOD(PACKNUM+1,64); CALL RECEIVE_A_FILE( %F_FILE ); PACKNUM = 0; NUM_TRIES = 0; END; SELECT( %R_RINIT ); /* SEND file(s) */ CALL GET_FID_FROM_PACKET( PACKET.DATA_BUF,LEN,SRCE_FID,K ); IF K < LENGTHC(SRCE_FID) THEN SUBSTR(SRCE_FID,K)= ' '; CALL FIX_CP6_FILE_NAME( SRCE_FID,K,%SEND## ); CALL SEND WHENALTRETURN DO; END; IF FILE_CNT = 0 THEN DO; CALL CONCAT( LO_BUF,'.. Sorry, no files matching "', SUBSTR(TARGET.NAME#,0,TARGET.L#), '" were found on CP-6.' ); CALL SEARCHR( L,X,SKIP_BLANKS,LO_BUF ); CALL SEND_ERROR_PACKET( LO_BUF,L+1 ); END; ELSE PACKNUM= 0; SELECT( %G_GENERIC ); DO SELECT( SUBSTR(PACKET.DATA_BUF,0,1) ); SELECT( %F_FINISH ); CALL SEND_PACKET( 'Y',RCVD_PACKNUM,0,' ' ); IM_A_SERVER= %NO#; /* I won't be a SERVER any more */ GOTO ALT_RETURN; SELECT( %L_BYE ); CALL SEND_PACKET( 'Y',RCVD_PACKNUM,0,' ' ); CALL CLOSE_A_FILE ( F$DEBUG# ); CALL CLOSE_A_FILE ( M$LO#, %SAVE# ); CMD_BUF= 'BYE'; %IF OS_VERSION~='B03'; FPT_YC.V.LINK#= %NO#; %ENDIF; CALL M$YC( FPT_YC ); SELECT( ELSE ); CALL CONCAT( LO_BUF,'> GENERIC subcommand ', SUBSTR(PACKET.DATA_BUF,0,1), ' has NOT been implemented by CP-6 KERMIT <\' ); CALL INDEX( K,'\',LO_BUF ); CALL SEND_ERROR_PACKET( LO_BUF,K ); CALL SEND_PACKET( 'Y',PACKNUM,0,' ' ); END; /* SELECT( %K_KERMIT ); */ SELECT( ELSE ); CALL CONCAT( LO_BUF,'> CP-6 KERMIT SERVER got a type ', TYPE, ' packet and didn''t know what to do!\' ); CALL INDEX( K,'\',LO_BUF ); CALL SEND_ERROR_PACKET( LO_BUF,K ); END; END; RE_TURN: RETURN; ALT_RETURN: ALTRETURN; END SERVER; %EJECT; /**** * * S E T * * Do any and all SET commands. * ****/ SET: PROC ALTRET; DO J=0 TO %BLK2_NSUBLKS-1; BLK3$= %BLK2_SUBLK$(J); IF %BLK3_NSUBLKS > 0 THEN DO; BLK4$= %BLK3_SUBLK$(0); IF %BLK4_NSUBLKS > 0 THEN BLK5$= %BLK4_SUBLK$(0); END; DO CASE( %BLK3_CODE ); CASE( %SET_BLOCK_CHECK## ); DO CASE( %BLK4_CODE ); CASE( %ONE_CHAR_CHECKSUM## ); BLOCK_CHECK= 1; CASE( %TWO_CHAR_CHECKSUM## ); CALL PUT( '.. Sorry, I only do 1 character checksums\' ); CASE( %THREE_CHAR_CHECKSUM## ); CALL PUT( '.. Sorry, I only do 1 character checksums\' ); END; CASE( %SET_DELAY## ); CALL CHARBIN( DELAY,%BLK4_TEXT ); CASE( %SET_FILE## ); DO CASE( %BLK4_CODE ); CASE( %SET_FILE_BINARY_EXTENSIONS## ); IF %BLK4_NSUBLKS <= %MAX_EXTENSIONS# THEN DO; DO K=0 TO %BLK4_NSUBLKS-1; BLK5$= %BLK4_SUBLK$(K); EXTEN.LEN(K)= LENGTHC('?') + %BLK5_COUNT; CALL CONCAT( EXTEN.TEXT(K),'?',%BLK5_TEXT ); END; IF %BLK4_NSUBLKS = 1 AND EXTEN.TEXT(0)='?NONE' THEN NUM_EXTENSIONS= 0; ELSE NUM_EXTENSIONS= %BLK4_NSUBLKS; END; ELSE CALL PUT('.. Too many extensions specified; max is 30.\'); CASE( %SET_FILE_CP6_FIDS_YES## ); SET_FILE_CP6_FIDS= %SET_FILE_CP6_FIDS_YES##; CASE( %SET_FILE_CP6_FIDS_NO## ); SET_FILE_CP6_FIDS= %SET_FILE_CP6_FIDS_NO##; CASE( %SET_FILE_EDIT_YES## ); SET_FILE_EDIT= %SET_FILE_EDIT_YES##; CASE( %SET_FILE_EDIT_NO## ); SET_FILE_EDIT= %SET_FILE_EDIT_NO##; CASE( %SET_FILE_END_OF_RECORD## ); IF %BLK4_NSUBLKS > 2 THEN DO; CALL X$WRITE( F_FDS,FMT35_ ); GOTO NEXT_J; END; ELSE DO; SIZE= 0; EOR_BYTE_LEN= 0; DO K = 0 TO %BLK4_NSUBLKS-1; BLK5$= %BLK4_SUBLK$(K); CALL CHARBIN( L,%BLK5_TEXT ); IF L > 255 THEN DO; CALL X$WRITE( F_FDS,FMT36_,VECTOR(L) ); GOTO NEXT_J; END; ELSE DO; CALL STUFF_CHAR_IN_PACKET( BINASC(L) ); EOR_BYTE(K) = BINASC(L); EOR_BYTE_LEN= EOR_BYTE_LEN + 1; END; END; EOR_CHARS= SUBSTR(DATA_BUF,0,SIZE); EOR_CHARS_LEN= SIZE; END; CASE( %SET_FILE_INCOMPLETE_DISCARD## ); SET_FILE_INCOMPLETE= %SET_FILE_INCOMPLETE_DISCARD##; CASE( %SET_FILE_INCOMPLETE_KEEP## ); SET_FILE_INCOMPLETE= %SET_FILE_INCOMPLETE_KEEP##; CASE( %SET_FILE_MODE_AUTO## ); SET_FILE_MODE= %SET_FILE_MODE_AUTO##; CASE( %SET_FILE_MODE_BINARY## ); SET_FILE_MODE= %SET_FILE_MODE_BINARY##; CASE( %SET_FILE_MODE_TEXT## ); SET_FILE_MODE= %SET_FILE_MODE_TEXT##; CASE( %SET_FILE_NAMES_ASIS## ); SET_FILE_NAMES= %SET_FILE_NAMES_ASIS##; CASE( %SET_FILE_NAMES_LC## ); SET_FILE_NAMES= %SET_FILE_NAMES_LC##; CASE( %SET_FILE_NAMES_UC## ); SET_FILE_NAMES= %SET_FILE_NAMES_UC##; CASE( %SET_FILE_PC_EXTENSIONS_YES## ); SET_FILE_PC_EXTENSIONS= %SET_FILE_PC_EXTENSIONS_YES##; CASE( %SET_FILE_PC_EXTENSIONS_NO## ); SET_FILE_PC_EXTENSIONS= %SET_FILE_PC_EXTENSIONS_NO##; CASE( %SET_FILE_PREFIX## ); SET_FILE_PREFIX.LEN= %BLK5_COUNT; SET_FILE_PREFIX.TEXT= %BLK5_TEXT; CASE( %SET_FILE_REPLACEMENT## ); SET_FILE_REPLACEMENT= %BLK5_TEXT; CASE( %SET_FILE_SUBDIRECTORY_CHAR## ); SET_FILE_SUBDIRECTORY= %SET_FILE_SUBDIRECTORY_ON##; SET_FILE_SUBDIRECTORY_CHAR= %BLK5_TEXT; CASE( %SET_FILE_SUBDIRECTORY_OFF## ); SET_FILE_SUBDIRECTORY= %SET_FILE_SUBDIRECTORY_OFF##; CASE( %SET_FILE_SUBDIRECTORY_ON## ); SET_FILE_SUBDIRECTORY= %SET_FILE_SUBDIRECTORY_ON##; CASE( %SET_FILE_WARNING_ON## ); SET_FILE_WARNING= %SET_FILE_WARNING_ON##; CASE( %SET_FILE_WARNING_INTO## ); SET_FILE_WARNING= %SET_FILE_WARNING_INTO##; CASE( %SET_FILE_WARNING_OFF## ); SET_FILE_WARNING= %SET_FILE_WARNING_OFF##; CASE( ELSE ); CALL PUT( '.. Oops, X$PARSE knows of an option I don''t!\' ); END; CASE( %SET_SEND## ); DO K=0 TO %BLK3_NSUBLKS-1; BLK4$= %BLK3_SUBLK$(K); IF %BLK4_NSUBLKS > 0 THEN BLK5$= %BLK4_SUBLK$(0); DO CASE( %BLK4_CODE ); CASE( %SEND_EIGHT_BIT_QUOTE## ); MY_DEFAULT.QBIN= %BLK5_TEXT; CASE( %SEND_END_OF_LINE## ); CALL CHARBIN( L,%BLK5_TEXT ); MY_DEFAULT.END_OF_LINE= BINASC(L); CASE( %SEND_PACKET_LENGTH## ); CALL CHARBIN( L,%BLK5_TEXT ); MY_DEFAULT.PACKET_LENGTH= L; CASE( %SEND_PAUSE## ); CALL CHARBIN( L,%BLK5_TEXT ); MY_DEFAULT.PAUSE= L; CASE( %SEND_PADDING## ); CALL CHARBIN( L,%BLK5_TEXT ); MY_DEFAULT.PADDING= L; CASE( %SEND_PADCHAR## ); CALL CHARBIN( L,%BLK5_TEXT ); MY_DEFAULT.PADCHAR= BINASC(L); CASE( %SEND_QUOTE## ); MY_DEFAULT.QUOTE= %BLK5_TEXT; CASE( %SEND_REPT## ); MY_DEFAULT.REPT= %BLK5_TEXT; CASE( %SEND_START_OF_PACKET## ); CALL CHARBIN( L,%BLK5_TEXT ); MY_DEFAULT.START_OF_PACKET= BINASC(L); CASE( %SEND_TIMEOUT## ); CALL CHARBIN( L,%BLK5_TEXT ); MY_DEFAULT.TIMEOUT= L; END; END; CASE( %SET_RETRY## ); BLK5$= %BLK4_SUBLK$(0); DO CASE( %BLK4_CODE ); CASE( %RETRY_INITIAL## ); CALL CHARBIN( PROTOCOL.MAX_INITIAL_RETRIES,%BLK5_TEXT ); CASE( %RETRY_PACKETS## ); CALL CHARBIN( PROTOCOL.MAX_PACKET_RETRIES,%BLK5_TEXT ); END; CASE( %SET_TAB_EXPANSION## ); SET_TAB_EXPANSION= %BLK4_CODE; CASE( %SET_TABS## ); DO K=0 TO %BLK3_NSUBLKS-1; BLK4$= %BLK3_SUBLK$(K); CALL CHARBIN( L,%BLK4_TEXT ); TABS(K)= L; IF K > 0 AND TABS(K) <= TABS(K-1) THEN DO; VEC1_= VECTOR(L); CALL X$WRITE( F_FDS,FMT32_,VEC1_ ); GOTO SET_DEFAULT_TABS; END; IF TABS(K) > 255 THEN DO; /* Tab value to large? */ VEC1_= VECTOR(L); CALL X$WRITE( F_FDS,FMT31_,VEC1_ ); GOTO SET_DEFAULT_TABS; END; END; NUM_TABS= %BLK3_NSUBLKS; IF NUM_TABS = 1 AND TABS(0)=0 THEN /* Reset TABs to defaults? */ GOTO SET_DEFAULT_TABS; IF TABS(0) = 0 THEN /* No tabs? */ NUM_TABS= 0; /* Yep. */ DO WHILE('0'B); SET_DEFAULT_TABS: L= 9; /* Start TABs at 9 */ DO K=0 TO 39; TABS(K)= L; L= L + 8; /* and increment by 8 */ END; NUM_TABS= 40; END; CASE( ELSE ); CALL PUT( '.. Oops, X$PARSE knows of an option I don''t!\' ); END; NEXT_J: END; RE_TURN: RETURN; END SET; %EJECT; /**** * * S E T _ P A R I T Y _ M A S K * * Based upon the 8-bit quoting character passed (QBIN) and/or the parity * currently in use, setup CHARMASK and WORDMASK for use later to mask off * the parity bit. * ****/ SET_PARITY_MASK: PROC( QBIN ); DCL QBIN CHAR(1); IF QBIN = 'Y' THEN DO; CALL M$GTRMATTR(FPT_GTRMATTR); IF (VLP_GTRMATTR.PARITY# = %KV_PRTTYP_NONE) OR (VLP_GTRMATTR.PARITY# = %KV_PRTTYP_ZERO) THEN DO; CHARMASK = '377'O; WORDMASK = '377377377377'O; END; ELSE DO; CHARMASK = '177'O; WORDMASK = '177177177177'O; END; END; ELSE IF (QBIN >= '!' AND QBIN <= '>') OR (QBIN >= '^' AND QBIN <= '~') THEN DO; CHARMASK = '177'O; WORDMASK = '177177177177'O; END; ELSE DO; CHARMASK = '377'O; WORDMASK = '377377377377'O; END; RE_TURN: RETURN; END SET_PARITY_MASK; %EJECT; /**** * * S E T _ T I M E O U T * * Set the timeout for READs. This is generally done before a transfer * starts and after one is finished. * ****/ SET_TIMEOUT: PROC( TIMEOUT_VALUE ) ALTRET; DCL TIMEOUT_VALUE UBIN; IF TIMEOUT.V.TIMEOUT# ~= TIMEOUT_VALUE THEN DO; TIMEOUT.V.TIMEOUT#= TIMEOUT_VALUE; CALL BINCHAR( INT5,TIMEOUT_VALUE ); CALL CONCAT( LO_BUF,'Timeout value set to ',INT5 ); CALL LOG( %DEBUG_TIMEOUT##,LO_BUF,26 ); MY_STATION.EOFTIME# = TIMEOUT_VALUE; CALL M$EOM( TIMEOUT ) ALTRET( ALT_RETURN ); END; IF TIMEOUT_VALUE > 0 THEN DO; CALL M$STRMCTL( STRMCTL ); END; RE_TURN: RETURN; ALT_RETURN: ALTRETURN; END SET_TIMEOUT; %EJECT; /**** * * S H O W * * Show the current settings of most SETable values. * ****/ SHOW: PROC; MY= MY_DEFAULT; F_FDS.DCB#= DEFAULT_DCB#; CALL X$WRITE( F_FDS,FMT1_,VECTOR(MY.QUOTE),VECTOR(THEIR.QUOTE) ); K= ASCBIN(THEIR.START_OF_PACKET); L= ASCBIN(MY.START_OF_PACKET); CALL CHARCTL( STR1,K ); CALL CHARCTL( STR2,L ); CALL X$WRITE( F_FDS,FMT2_,VECTOR(SUBSTR(STR1,0,6)), VECTOR(SUBSTR(STR2,0,6)) ); CALL X$WRITE( F_FDS,FMT3_,VECTOR(THEIR.TIMEOUT),VECTOR(MY.TIMEOUT) ); CALL X$WRITE( F_FDS,FMT4_,VECTOR(THEIR.PACKET_LENGTH), VECTOR(MY.PACKET_LENGTH) ); CALL X$WRITE( F_FDS,FMT5_,VECTOR(THEIR.PADDING),VECTOR(MY.PADDING) ); K= ASCBIN(MY.END_OF_LINE); CALL CHARCTL( STR1,K ); CALL X$WRITE( F_FDS,FMT6_,VECTOR(SUBSTR(STR1,0,6)) ); IF SET_FILE_CP6_FIDS = %SET_FILE_CP6_FIDS_NO## THEN STR1= 'No'; ELSE STR1= 'Yes'; IF SET_FILE_INCOMPLETE = %SET_FILE_INCOMPLETE_DISCARD## THEN STR2= 'Incomplete files will be discarded'; ELSE STR2= 'Incomplete files will be kept'; CALL X$WRITE( F_FDS,FMT7_,VECTOR(SUBSTR(STR1,0,3)),VECTOR(STR2) ); IF SET_FILE_EDIT = %SET_FILE_EDIT_NO## THEN STR1= 'Received files will not be EDIT keyed'; ELSE STR1= 'Received files will be EDIT keyed'; CALL X$WRITE( F_FDS,FMT8_,VECTOR(SET_FILE_REPLACEMENT),VECTOR(STR1) ); IF SET_FILE_NAMES = %SET_FILE_NAMES_ASIS## THEN STR1= 'Packet file names used ASIS'; ELSE IF SET_FILE_NAMES = %SET_FILE_NAMES_LC## THEN STR1= 'Packet file names converted to LowerCase'; ELSE STR1= 'Packet file names converted to UpperCase'; CALL X$WRITE( F_FDS,FMT9_,VECTOR(STR1),VECTOR(DELAY) ); CALL X$WRITE( F_FDS,FMT10_,VECTOR(PROTOCOL.MAX_INITIAL_RETRIES), VECTOR(PROTOCOL.MAX_PACKET_RETRIES) ); IF SET_TAB_EXPANSION = %SET_TAB_EXPANSION_ON## THEN STR1= 'On'; ELSE IF SET_TAB_EXPANSION = %SET_TAB_EXPANSION_OFF## THEN STR1= 'Off'; ELSE STR1= 'Lee blew it!'; IF F$LOG$->F$DCB.FCD# THEN STR2= ' '; ELSE STR2= ' Was '; CALL X$WRITE( F_FDS,FMT11_,VECTOR(STR1),VECTOR(STR2), VECTOR(LOG_FILE.NAME#) ); IF NUM_TABS = 0 THEN STR1= 'Tabs: None'; ELSE IF NUM_TABS = 40 AND TABS(0) = 9 AND TABS(39) = 321 THEN STR1= 'Tabs: Every 8 columns between 9 and 321'; ELSE DO; STR1= 'Tabs: '; OUT_INDX= LENGTHC('Tabs: '); DO K=0 TO NUM_TABS-1; CALL BINCHAR( INT5,TABS(K) ); L= 0; DO WHILE( L<4 AND SUBSTR(INT5,L,1)='0' ); L= L + 1; END; IF OUT_INDX + 5-L + LENGTHC(', ') >= LENGTHC(STR1) THEN DO; CALL X$WRITE( F_FDS,FMT_,VECTOR(STR1) ); STR1= ' '; OUT_INDX= LENGTHC('Tabs: '); END; CALL INSERT( STR1,OUT_INDX,,SUBSTR(INT5,L),', ' ); OUT_INDX= OUT_INDX + 5-L + LENGTHC(', '); END; IF OUT_INDX > LENGTHC('Tabs: ') THEN SUBSTR(STR1,OUT_INDX-2,1)= ' '; /* Blank out the trailing comma */ END; CALL X$WRITE( F_FDS,FMT_,VECTOR(STR1) ); IF SET_FILE_PC_EXTENSIONS = %SET_FILE_PC_EXTENSIONS_YES## THEN STR1= 'Yes'; ELSE STR1= 'No'; IF SET_FILE_MODE = %SET_FILE_MODE_AUTO## THEN STR2= 'Automatic'; ELSE IF SET_FILE_MODE = %SET_FILE_MODE_BINARY## THEN STR2= 'Binary'; ELSE STR2= 'Text'; CALL X$WRITE( F_FDS,FMT33_,VECTOR(STR1),VECTOR(STR2) ); IF SET_FILE_WARNING = %SET_FILE_WARNING_ON## THEN STR1= 'On (TO)'; ELSE IF SET_FILE_WARNING = %SET_FILE_WARNING_INTO## THEN STR1= 'INTO'; ELSE STR1= 'Off (OVER)'; IF F$DEBUG$->F$DCB.FCD# THEN STR2= ' '; ELSE STR2= ' Was '; CALL X$WRITE( F_FDS,FMT34_,VECTOR(STR1),VECTOR(STR2), VECTOR(DEBUG_FILE.NAME#) ); IF SET_FILE_SUBDIRECTORY = %SET_FILE_SUBDIRECTORY_ON## THEN STR1= 'Yes'; ELSE STR1= 'No'; CALL X$WRITE( F_FDS,FMT37_,VECTOR(STR1), VECTOR(SET_FILE_SUBDIRECTORY_CHAR) ); IF SET_FILE_PREFIX.LEN = 0 THEN STR1= 'Disabled'; ELSE STR1= SET_FILE_PREFIX.TEXT; CALL X$WRITE( F_FDS,FMT38_,VECTOR(STR1) ); IF NUM_EXTENSIONS = 0 THEN STR1= 'Binary extensions: None'; ELSE DO; STR1= 'Binary extensions: '; OUT_INDX= LENGTHC('Binary extensions: '); DO K = 0 TO NUM_EXTENSIONS-1; L= EXTEN.LEN(K); IF K < NUM_EXTENSIONS-1 THEN /* If not the last extension, put comma*/ L= L + LENGTHC(', '); IF OUT_INDX + L >= LENGTHC(STR1) THEN DO; CALL X$WRITE( F_FDS,FMT_,VECTOR(STR1) ); STR1= ' '; OUT_INDX= LENGTHC('Binary extensions: '); END; CALL INSERT( STR1,OUT_INDX,L,SUBSTR(EXTEN.TEXT(K),0,EXTEN.LEN(K)), ', ' ); OUT_INDX= OUT_INDX + L; END; CALL X$WRITE( F_FDS,FMT_,VECTOR(STR1) ); END; RE_TURN: RETURN; END SHOW; %EJECT; /**** * * S N O O Z E * * Go to sleep for SECONDS seconds. * ****/ SNOOZE: PROC( SECONDS ); DCL SECONDS UBIN; IF ~CG_MODE THEN DO; FPT_WAIT.V.UNITS# = SECONDS; CALL M$WAIT( FPT_WAIT ) ALTRET( RE_TURN ); END; RE_TURN: RETURN; END SNOOZE; %EJECT; /**** * * S T U F F * * Stuff CHR into BUF at byte LEN. If need be, expand BUF first. * ****/ STUFF: PROC( BUF,LEN ) ALTRET; DCL BUF CHAR(LEN); DCL LEN UBIN; IF LEN >= IO_BUF_SIZE THEN DO; CALL EXPAND( IO_,4096,IO_BUF_SIZE ) ALTRET( ALT_RETURN ); END; SUBSTR(BUF,LEN,LENGTHC(CHR))= CHR; LEN= LEN + LENGTHC(CHR); RE_TURN: RETURN; ALT_RETURN: ALTRETURN; END STUFF; %EJECT; /**** * * S T U F F _ C H A R _ I N _ P A C K E T * * Stuff CHR into the out going data packet. * ****/ STUFF_CHAR_IN_PACKET: PROC( CHR ); DCL CHR CHAR(1); DCL CHR_BIT REDEF CHR BIT(9) CALIGNED; DCL CHR7 CHAR(1) CALIGNED; DCL CHR7_BIT REDEF CHR7 BIT(9) CALIGNED; CHR7_BIT= CHR_BIT & '177'O; /* Mask off parity bit */ IF BINARY_QUOTING AND (CHR ~= CHR7) THEN DO; SUBSTR(DATA_BUF,SIZE,1)= THEIR.QBIN; SIZE= SIZE + LENGTHC(THEIR.QBIN); END; IF CHR7 < ' ' OR CHR7 = MY.QUOTE OR CHR7 = %DEL OR (BINARY_QUOTING AND CHR7=MY.QBIN) OR (REPEATING AND CHR7=MY.REPT) THEN DO; SUBSTR(DATA_BUF,SIZE,1)= THEIR.QUOTE; SIZE= SIZE + LENGTHC(THEIR.QUOTE); IF (CHR7 = MY.QUOTE) OR (BINARY_QUOTING AND CHR7=MY.QBIN) OR (REPEATING AND CHR7=MY.REPT) THEN CHR7= CHR; ELSE CALL CTL( CHR7,CHR ); END; ELSE CHR7= CHR; SUBSTR(DATA_BUF,SIZE,1)= CHR7; SIZE= SIZE + LENGTHC(CHR7); RE_TURN: RETURN; END STUFF_CHAR_IN_PACKET; %EJECT; /**** * * T O C H A R * * Make SRCE printable by adding a space (ASCII 32) to it and return the * result in DEST_UBIN if it was passed or DEST if it wasn't. The UNCHAR * subroutine does the reverse of this. * ****/ TOCHAR: PROC( DEST,SRCE,DEST_UBIN ); DCL DEST UBIN(9) CALIGNED; DCL SRCE UBIN(9) CALIGNED; DCL DEST_UBIN UBIN; IF ADDR(DEST_UBIN) = ADDR(NIL) THEN DEST= SRCE + ASCBIN(' '); ELSE DEST_UBIN= SRCE + ASCBIN(' '); RE_TURN: RETURN; END TOCHAR; %EJECT; /**** * * U N C H A R * * Restore SRCE back to its original value by subtracting a space (ASCII 32) * from it and return the result in DEST_UBIN if it was passed or DEST if it * wasn't. The TOCHAR subroutine does the reverse of this one. * ****/ UNCHAR: PROC( DEST,SRCE,DEST_UBIN ); DCL DEST UBIN(9) CALIGNED; DCL SRCE UBIN(9) CALIGNED; DCL DEST_UBIN UBIN; IF ADDR(DEST_UBIN) = ADDR(NIL) THEN DEST= SRCE - ASCBIN(' '); ELSE DEST_UBIN= SRCE - ASCBIN(' '); RE_TURN: RETURN; END UNCHAR; %EJECT; /**** * * U N F I D * * Get the file name that DCB number DCB# is OPEN to and return the name in * FID and the length of the name in FID_LEN. * ****/ UNFID: PROC( DCB#,FID,FID_LEN ) ALTRET; DCL DCB# UBIN; DCL FID CHAR(FIDLEN); DCL FID_LEN SBIN; DCL FIDLEN SBIN; IF NOT DCBADDR(DCB#)->F$DCB.FCD# THEN /* If the DCB is not OPEN */ CALL OPEN_FID( DCB#,' ',0 ) ALTRET( PUT_ERR ); /* OPEN it. */ FIDLEN= FID_LEN; FPT_UNFID.V.DCB#= DCB#; FPT_UNFID.LEN_= VECTOR(FID_LEN); FPT_UNFID.TEXTFID_= VECTOR(FID); CALL M$UNFID( FPT_UNFID ) ALTRET( PUT_ERR ); RE_TURN: RETURN; PUT_ERR: ERRDCB#= %ERRDCB; CALL XUR$ERRMSG( %MONERR,ERRDCB# ); /* Output error message */ ALT_RETURN: ALTRETURN; END UNFID; %EJECT; /**** * * W R I T E _ L O G _ R E C * * Write a record into the LOG file (if one is OPEN). * ****/ WRITE_LOG_REC: PROC( REC_KEY,MSG_LEN ); DCL REC_KEY UBIN; DCL MSG_LEN UBIN; IF NOT F$LOG$->F$DCB.FCD# THEN /* Is F$LOG OPEN? */ GOTO RE_TURN; /* Nope, Don't bother logging! */ LOG_KEY.EDIT= ((LOG_KEY.EDIT/1000)*1000) + ((REC_KEY/10)*10); F_FDS.DCB#= 0; DO SELECT( REC_KEY ); SELECT( %LOG_HEADER# ); CALL M$TIME( GET_UTS ); CALL M$TIME( CONVERT_UTS ); LOG_KEY.EDIT= LOG_KEY.EDIT + 1000; DAYU(1)= DAYU(1) + (ASCBIN('a')-ASCBIN('A')); DAYU(2)= DAYU(2) + (ASCBIN('a')-ASCBIN('A')); MMMDDYYU(1)= MMMDDYYU(1) + (ASCBIN('a')-ASCBIN('A')); MMMDDYYU(2)= MMMDDYYU(2) + (ASCBIN('a')-ASCBIN('A')); CALL X$WRITE( F_FDS,FMT17_,VECTOR(DAY), VECTOR(SUBSTR(MMMDDYY,0,6)), VECTOR(SUBSTR(MMMDDYY,8,2)), VECTOR(SUBSTR(HHMMSSSS,0,8)), VECTOR(B$JIT.ACCN), VECTOR(B$JIT.UNAME) ); WRITE_LOG.BUF_= VECTOR(SUBSTR(LO_BUF,1,F_FDS.BUFX-1)); CALL M$WRITE( WRITE_LOG ); START_UTS= UTS; SELECT( %LOG_STRT_SEND# ); WHAT= 'Started but didn''t finish sending'; GOTO TELL_ABOUT_SEND; SELECT( %LOG_END_SEND# ); WHAT= 'Sent '; TELL_ABOUT_SEND: IF PACKET_FID = CP6_FID THEN CALL X$WRITE( F_FDS,FMT19_,VECTOR(WHAT), VECTOR(CP6_FID), VECTOR(F$IN$->F$DCB.NRECS#), VECTOR(MODE) ); ELSE CALL X$WRITE( F_FDS,FMT18_,VECTOR(WHAT), VECTOR(CP6_FID), VECTOR(PACKET_FID), VECTOR(F$IN$->F$DCB.NRECS#), VECTOR(MODE) ); WRITE_LOG.BUF_= VECTOR(SUBSTR(LO_BUF,1,F_FDS.BUFX-1)); CALL M$WRITE( WRITE_LOG ); SELECT( %LOG_STRT_RECEIVE# ); WHAT= 'Started but DIDN''T finish receiving'; IF PACKET_FID = CP6_FID THEN CALL X$WRITE( F_FDS,FMT29_,VECTOR(WHAT), VECTOR(CP6_FID), VECTOR(MODE) ); ELSE CALL X$WRITE( F_FDS,FMT30_,VECTOR(WHAT), VECTOR(PACKET_FID), VECTOR(CP6_FID), VECTOR(MODE) ); GOTO TELL_ABOUT_RECEIVE; SELECT( %LOG_END_RECEIVE# ); WHAT= 'Received'; IF PACKET_FID = ' ' THEN CALL X$WRITE( F_FDS,FMT20_,VECTOR(WHAT), VECTOR(CP6_FID), VECTOR(IO_CNT), VECTOR(MODE) ); ELSE CALL X$WRITE( F_FDS,FMT21_,VECTOR(WHAT), VECTOR(PACKET_FID), VECTOR(CP6_FID), VECTOR(IO_CNT), VECTOR(MODE) ); TELL_ABOUT_RECEIVE: WRITE_LOG.BUF_= VECTOR(SUBSTR(LO_BUF,1,F_FDS.BUFX-1)); CALL M$WRITE( WRITE_LOG ); SELECT( %LOG_MAX_PACKET_SIZES# ); CALL X$WRITE( F_FDS,FMT22_,VECTOR(THEIR.PACKET_LENGTH), VECTOR(MY.PACKET_LENGTH) ); WRITE_LOG.BUF_= VECTOR(SUBSTR(LO_BUF,1,F_FDS.BUFX-1)); CALL M$WRITE( WRITE_LOG ); SELECT( %LOG_NUM_DATA_PACKETS# ); CALL X$WRITE( F_FDS,FMT23_,VECTOR(NUM_DATA_PACKETS), VECTOR(FILE_BYTE_CNT) ); WRITE_LOG.BUF_= VECTOR(SUBSTR(LO_BUF,1,F_FDS.BUFX-1)); CALL M$WRITE( WRITE_LOG ); SELECT( %LOG_NUM_BYTES_SENT# ); SELECT( %LOG_NUM_BYTES_RCVD# ); SELECT( %LOG_ELAPSED_TIME# ); CALL M$TIME( GET_UTS ); END_UTS= UTS; UTS= END_UTS - START_UTS; CALL M$TIME( CONVERT_UTS ); I= 0; DO UNTIL( (I>=LENGTHC(HHMMSSSS)-5) OR (SUBSTR(HHMMSSSS,I,1) ~= '0' AND SUBSTR(HHMMSSSS,I,1) ~= ':') ); I= I + 1; END; ME_BUF= 'Elapsed time: '; L= LENGTHC('Elapsed time: '); IF I < 3 THEN DO; /* Did it take hours? */ IF SUBSTR(HHMMSSSS,0,2) = '01' THEN /* Yep, just one? */ SUBSTR(ME_BUF,L)= 'One'; /* Yep, spell it */ ELSE IF SUBSTR(HHMMSSSS,0,1) = '0' THEN /* < 10 hours? */ SUBSTR(ME_BUF,L)= SUBSTR(HHMMSSSS,1,1); /* Yep, 1 digit */ ELSE SUBSTR(ME_BUF,L)= SUBSTR(HHMMSSSS,0,2); /* Rediculous! */ CALL INDEX( L,' ',ME_BUF ); IF SUBSTR(HHMMSSSS,0,2) = '01' THEN /* Just one hour? */ SUBSTR(ME_BUF,L)= ' Hour, '; /* Yep, proper grammar counts! */ ELSE SUBSTR(ME_BUF,L)= ' Hours, '; /* Plural */ CALL INDEX( L,', ',ME_BUF ); L= L + LENGTHC(', '); END; IF I < 6 THEN DO; /* Any minutes? */ IF SUBSTR(HHMMSSSS,3,2) = '00' THEN /* Zero minutes? */ SUBSTR(ME_BUF,L)= 'No'; /* Nope, spell it */ ELSE IF SUBSTR(HHMMSSSS,3,2) = '01' THEN /* Just one minute? */ SUBSTR(ME_BUF,L)= 'One'; /* Yep, spell it */ ELSE IF SUBSTR(HHMMSSSS,3,1) = '0' THEN /* < 10 minutes? */ SUBSTR(ME_BUF,L)= SUBSTR(HHMMSSSS,4,1); /* One digit */ ELSE SUBSTR(ME_BUF,L)= SUBSTR(HHMMSSSS,3,2); CALL INDEX( L,' ',ME_BUF ); IF SUBSTR(HHMMSSSS,3,2) = '01' THEN /* Just one minute? */ SUBSTR(ME_BUF,L)= ' Minute and'; /* Again, grammar counts! */ ELSE SUBSTR(ME_BUF,L)= ' Minutes and'; CALL INDEX( L,' ',ME_BUF ); L= L + LENGTHC(' '); END; IF SUBSTR(HHMMSSSS,6,5) = '00.00' THEN /* Zero seconds? */ SUBSTR(ME_BUF,L)= 'No'; /* Yep, spell it */ ELSE IF SUBSTR(HHMMSSSS,6,1) = '0' THEN /* less than 10 seconds? */ SUBSTR(ME_BUF,L)= SUBSTR(HHMMSSSS,7,4); /* Yep */ ELSE SUBSTR(ME_BUF,L)= SUBSTR(HHMMSSSS,6,5); CALL INDEX( L,' ',ME_BUF ); SUBSTR(ME_BUF,L)= ' Seconds'; CALL M$GLINEATTR( FPT_GLINEATTR ); CALL X$WRITE( F_FDS,FMT27_,VECTOR(ME_BUF), VECTOR(SPEED(VLP_LINEATTR.LINESPEED#)), VECTOR(PARITY_TBL(VLP_GTRMATTR.PARITY#)) ); WRITE_LOG.BUF_= VECTOR(SUBSTR(LO_BUF,1,F_FDS.BUFX-1)); CALL M$WRITE( WRITE_LOG ); SELECT( %LOG_ERRMSG# ); CALL X$WRITE( F_FDS,FMT28_,VECTOR(SUBSTR(ERR_BUF,0,MSG_LEN)) ); WRITE_LOG.BUF_= VECTOR(SUBSTR(LO_BUF,1,F_FDS.BUFX-1)); CALL M$WRITE( WRITE_LOG ); SELECT( ELSE ); END; RE_TURN: RETURN; END WRITE_LOG_REC; %EJECT; /**** * * W R I T E _ R E C O R D * * Write a record to the file being RECEIVEd. * ****/ WRITE_RECORD: PROC( BUF,LEN ) ALTRET; DCL BUF CHAR(LEN); DCL LEN SBIN; OUT_KEY.EDIT= OUT_KEY.EDIT + 1000; IF LEN <= 0 THEN WRITE_OUT.BUF_= VECTOR(NIL); ELSE WRITE_OUT.BUF_= VECTOR(SUBSTR(BUF,0,LEN)); CALL XSA$WRITE( WRITE_OUT,XSA_PARAM ) ALTRET( CANT_WRITE ); IO_CNT= IO_CNT + 1; FILE_BYTE_CNT= FILE_BYTE_CNT + LEN + EOR_BYTE_LEN; CALL LOG( %DEBUG_WRITE##,BUF,LEN ); IO_BUF= ' '; IO_LEN= 0; TX= 0; RE_TURN: RETURN; CANT_WRITE: CALL SEND_ERROR_PACKET; ALT_RETURN: ALTRETURN; END WRITE_RECORD; END KERMIT; %EOD; KERMIT$BREAK: PROC ASYNC; DCL BRK_CNT SBIN SYMREF; BRK_CNT= BRK_CNT + 1; RE_TURN: RETURN; END KERMIT$BREAK;