*COMDECK COMCKER C$ LIST(S=COMLIS) **** COMCKER - KERMIT SYMBOL DEFINITIONS. * ** FILE I/O DEFINITIONS. * PARAMETER (STDIN =1) PARAMETER (STDOUT=2) ** ASCII CHARACTERS. * PARAMETER (SOH=1) PARAMETER (ETX=3) PARAMETER (BELL=7) PARAMETER (TAB=9) PARAMETER (LF=10) PARAMETER (CR=13) PARAMETER (DC4=20) PARAMETER (BLANK=32) PARAMETER (MINUS=45) PARAMETER (COLON=58) PARAMETER (QMARK=63) PARAMETER (DEL=127) PARAMETER (NEL=O"3777") PARAMETER (NULL=O"4000") ** MISCELLANEOUS. * PARAMETER (OK=1) PARAMETER (EOF=-1) PARAMETER (ERROR=-2) PARAMETER (ON=1, OFF=0) PARAMETER (YES=1, NO=0) ** DISK FILE CHARACTER SETS. * PARAMETER (CSNONE=0, CSDSP=1, CS812=2, CS612=3, CSBIN=4, CSTXP=5) ** PROTOCOL DEFINITIONS. * PARAMETER (UNKNOWN=0, FULLDUP=1, HALFDUP=2) PARAMETER (NORMAL=0, TXP=1) PARAMETER (MAXINIT=15) PARAMETER (MAXTRY=10) PARAMETER (IPKSIZE=94) * MAX LONG PACKET SIZE. DON'T RAISE ABOVE 4000. PARAMETER (LPKSIZE=1000) PARAMETER (ITIMOUT=10) PARAMETER (IPADCT=0) PARAMETER (IPADCH=0) PARAMETER (IEOLCH=13) PARAMETER (ICQUOTE=35) PARAMETER (I8QUOTE=38) PARAMETER (ICHKTYP=49) PARAMETER (IRPTPFX=126) * INIT CAPABILITY BIT MASKS PARAMETER (CAPAS1 = 32) PARAMETER (CAPAS2 = 16) PARAMETER (CAPAS3 = 8) PARAMETER (CAPAS4 = 4) PARAMETER (CAPAS5 = 2) PARAMETER (CAPAS6 = 1) ** PACKET TYPES. * PARAMETER (A=65) PARAMETER (B=66) PARAMETER (C=67) PARAMETER (D=68) PARAMETER (E=69) PARAMETER (F=70) PARAMETER (G=71) PARAMETER (EYE=73) PARAMETER (L=76) PARAMETER (N=78) PARAMETER (P=80) PARAMETER (R=82) PARAMETER (S=83) PARAMETER (X=88) PARAMETER (Y=89) PARAMETER (Z=90) ** PACKET ERROR DEFINITIONS. * PARAMETER (TOOMANY=O"1000") PARAMETER (INVALID=O"2000") PARAMETER (SEQERR=O"4000") PARAMETER (LCLFILE=O"10000") PARAMETER (NOTLCL=O"20000") PARAMETER (INVFN=O"40000") PARAMETER (SRVCMD=O"100000") PARAMETER (MICERR=O"200000") PARAMETER (INTRPT=O"400000") PARAMETER (SENDING=O"100") PARAMETER (READING=O"200") PARAMETER (INITERR=1) PARAMETER (FILERR=2) PARAMETER (DATAERR=4) PARAMETER (EOFERR=O"10") PARAMETER (BRKERR=O"20") *** KERMIT SAVED COMMON BLOCK HEADER. * * ALL COMMON BLOCKS TO BE SAVED WHEN EXECUTING MONITOR * COMMANDS MUST BE PLACED BETWEEN /HEADER/ AND /TRAILER/ * COMMON /HEADER/ HEADER ** KERMIT COMMAND PROCESSOR COMMON BLOCK. * PARAMETER (BINARY=0, TEXT=1) COMMON /CMD/ AUTORET COMMON /CMD/ CINDEX LOGICAL CMDLOCF COMMON /CMD/ CMDFD, CMDLOCF CHARACTER CMDLFN*10 COMMON /CMDC/ CMDLFN ** KERMIT SEND-INIT PACKETS. * * DO NOT ALLOCATE ANY STORAGE BETWEEN SPKSIZE AND DSYNC! * OUTGOING - WHAT WE WANT COMMON /PACKET/ SPKSIZE COMMON /PACKET/ STIMOUT COMMON /PACKET/ SPADCT COMMON /PACKET/ SPADCH COMMON /PACKET/ SEOLCH COMMON /PACKET/ SCQUOTE COMMON /PACKET/ S8QUOTE COMMON /PACKET/ SCHKTYP COMMON /PACKET/ SRPTPFX COMMON /PACKET/ SUNUSED(2) COMMON /PACKET/ SSYNC * INCOMING - WHAT THE OTHER KERMIT WANTS (SET BY OTHER KERMIT) COMMON /PACKET/ RPKSIZE COMMON /PACKET/ RTIMOUT COMMON /PACKET/ RPADCT COMMON /PACKET/ RPADCH COMMON /PACKET/ REOLCH COMMON /PACKET/ RCQUOTE COMMON /PACKET/ R8QUOTE COMMON /PACKET/ RCHKTYP COMMON /PACKET/ RRPTPFX COMMON /PACKET/ RUNUSED(2) COMMON /PACKET/ RSYNC * INCOMING - WHAT THE OTHER KERMIT WANTS (DEFAULTS) COMMON /PACKET/ DPKSIZE COMMON /PACKET/ DTIMOUT COMMON /PACKET/ DPADCT COMMON /PACKET/ DPADCH COMMON /PACKET/ DEOLCH COMMON /PACKET/ DCQUOTE COMMON /PACKET/ D8QUOTE COMMON /PACKET/ DCHKTYP COMMON /PACKET/ DRPTPFX COMMON /PACKET/ DUNUSED(2) COMMON /PACKET/ DSYNC ** KERMIT PROTOCOL COMMON BLOCK. * COMMON /PROTO/ PACKET(LPKSIZE+10) COMMON /PROTO/ RECPACK(LPKSIZE+10) COMMON /PROTO/ FILESTR(IPKSIZE) COMMON /PROTO/ DELAYFP COMMON /PROTO/ DUPLEX COMMON /PROTO/ FFD COMMON /PROTO/ FILMODE COMMON /PROTO/ TXTMODE COMMON /PROTO/ INITDUP COMMON /PROTO/ MAXRINI COMMON /PROTO/ MAXRTRY COMMON /PROTO/ NUMTRY COMMON /PROTO/ PACKNUM COMMON /PROTO/ PSIZE COMMON /PROTO/ REPCH COMMON /PROTO/ Q8CH COMMON /PROTO/ RDELAY COMMON /PROTO/ STATE ** STORAGE FOR STATISTICS. * COMMON /PROTO/ ABORTYP COMMON /PROTO/ ENDTIM COMMON /PROTO/ RCHCNT COMMON /PROTO/ RCHOVRH COMMON /PROTO/ SCHCNT COMMON /PROTO/ SCHOVRH COMMON /PROTO/ STARTIM ** DEBUG COMMON BLOCK. * PARAMETER (DBGOFF=0, DBGSTAT=1, DBGPACK=2, DBGALL=3) COMMON /DEBUG/ DEBUG COMMON /DEBUG/ DEBUGFD COMMON /DEBUG/ DEBUGFN(8) ** ASCII STRING MESSAGE. * INTEGER ERRMSG(IPKSIZE), MICMSG(IPKSIZE) COMMON /MSG/ ERRMSG, MICMSG *** FILE I/O COMMON BLOCK DEFINITIONS. * PARAMETER (MAXFILE=4) ** CIO RELATED PARAMETERS. * * CIOBUFL = CIO BUFFER LENGTH. * FETL = FET LENGTH IN WORDS. * MAXWD = LINE SIZE IN WORDS; MUST BE AN EVEN NUMBER. PARAMETER (CIOBUFL=LPKSIZE/5+20, FETL=6, MAXWD=LPKSIZE/5+20) PARAMETER (CLOSED=0, RD=1, WR=2, CREATE=3) CHARACTER*10 FNAME(MAXFILE) COMMON /FILEIOC/ FNAME BOOLEAN CIOBUFF(CIOBUFL,MAXFILE) BOOLEAN FCHBUF(MAXWD,MAXFILE) BOOLEAN FETS(0:FETL-1,MAXFILE) INTEGER FCSET(MAXFILE) INTEGER FMODE(MAXFILE) INTEGER FNWDS(MAXFILE) INTEGER FUNGTCH(MAXFILE) INTEGER FWPTR(MAXFILE) INTEGER FWSHFT(MAXFILE) LOGICAL CTDEV(MAXFILE) LOGICAL FEOF(MAXFILE) LOGICAL LOCFILE LOGICAL WAITPAK COMMON /FILEIO/ CIOBUFF COMMON /FILEIO/ CTDEV COMMON /FILEIO/ FCHBUF COMMON /FILEIO/ FCSET COMMON /FILEIO/ FEOF COMMON /FILEIO/ FETS COMMON /FILEIO/ FMODE COMMON /FILEIO/ FNWDS COMMON /FILEIO/ FUNGTCH COMMON /FILEIO/ FWPTR COMMON /FILEIO/ FWSHFT COMMON /FILEIO/ LOCFILE COMMON /FILEIO/ WAITPAK *** KERMIT SAVED COMMON BLOCK TRAILER. * COMMON /TRAILER/ TRAILER ** MESSAGE COMMON BLOCK. * CHARACTER*74 HLPASCH CHARACTER*37 HLPDBFN CHARACTER*42 HLPDLFP CHARACTER*29 HLPIPRC CHARACTER*34 HLPPADL CHARACTER*24 HLPPLEN CHARACTER*21 HLPPRTR CHARACTER*41 HLPRDEL CHARACTER*13 HLPSNFN CHARACTER*43 HLPTIMO CHARACTER VERSION*47 INTEGER VERSDAT, VERSSTR(11) COMMON /MESSAGE/ HLPASCH COMMON /MESSAGE/ HLPDBFN COMMON /MESSAGE/ HLPDLFP COMMON /MESSAGE/ HLPIPRC COMMON /MESSAGE/ HLPPADL COMMON /MESSAGE/ HLPPLEN COMMON /MESSAGE/ HLPPRTR COMMON /MESSAGE/ HLPRDEL COMMON /MESSAGE/ HLPSNFN COMMON /MESSAGE/ HLPTIMO COMMON /MESSAGE/ VERSION COMMON /BMESAGE/ VERSDAT, VERSSTR ** CHARACTER SET CONVERSION TABLES. * * ASC612 = ASCII TO 6/12. * DPCTBL = ASCII TO DISPLAY CODE. * LASCII = DISPLAY CODE TO LOWER CASE ASCII. * SX1274 = 6/12 "74" ESCAPE CHARACTERS TO ASCII. * SX1276 = 6/12 "76" ESCAPE CHARACTERS TO ASCII. * UASCII = DISPLAY CODE TO UPPER CASE ASCII. * * THE TABLES ARE MODIFIED FOR 63 CHARACTER SET BY ROUTINE 'FIXCTAB' * AT INITIALIZATION TIME IF REQUIRED. * BOOLEAN ASC612(0:127) BOOLEAN DPCTBL(0:127) BOOLEAN LASCII(0:63) BOOLEAN SX1274(0:63) BOOLEAN SX1276(0:63) BOOLEAN UASCII(0:63) COMMON /CHARCOM/ ASC612 COMMON /CHARCOM/ DPCTBL COMMON /CHARCOM/ LASCII COMMON /CHARCOM/ SX1274 COMMON /CHARCOM/ SX1276 COMMON /CHARCOM/ UASCII C$ LIST(S=1) *COMDECK COMXKER C$ LIST(S=1) **** COMXKER - KERMIT STATEMENT FUNCTION DEFINITIONS. * UNCHAR(ASCCH) = ASCCH - BLANK TOCHAR(ASCCH) = ASCCH + BLANK CTL(ASCCH) = XOR(ASCCH,O"100") C$ LIST(S=1) *DECK KERMIT IDENT KERMIT *IF -DEF,DEBUG,1 LCC OVERLAY(KERMIT,0,0,OV=15) *IF DEF,DEBUG,1 LCC OVERLAY(KERMIT,0,0) ENTRY KERMIT LDSET EPT=KERMIT SYSCOM B1 SST KERMIT TITLE KERMIT - MICRO COMPUTER FILE EXCHANGE/KERMIT PROTOCOL. COMMENT MICRO COMPUTER FILE EXCHANGE/KERMIT PROTOCOL. KERMIT SPACE 4,10 ***** KERMIT - MICRO COMPUTER FILE EXCHANGE/KERMIT PROTOCOL. * * KERMIT IS A FILE SHIPPING PROGRAM USED BY MICRO COMPUTERS TO * TRANSFER FILES TO/FROM ANOTHER COMPUTER. KERMIT SPACE 4,10 *** MICRO COMPUTER FILE INTERCHANGE/KERMIT PROTOCOL. * * THIS VERSION IS FOR USE UNDER NOS 2. KERMIT SPACE 4,10 ** MAIN PROGRAM. KERMIT RJ =XKERMAIN END KERMIT SUBROUTINE KERMAIN *** KERMIT - A CYBER FILE TRANSFER PROGRAM USING THE KERMIT PROTOCOL * * THIS PROGRAM MAY NOT BE SOLD FOR PROFIT. * * MODIFICATIONS: * * 3.3 05/19/87 STEPHEN G. ROSEMAN, LEHIGH UNIVERSITY * * 1. CHANGE RECEIVE FILE NAMING. INSTEAD OF FIRST 7 VALID * CHARACTERS, TAKE UP TO 3 FROM THE EXTENSION, IF FOUND. THUS * ABCEFGH.BIN > ABCDBIN. * * 2. FIX SPOTS WHERE SUBSCRIPT CHECKING FAILED. DIDN'T CAUSE ANY * PROBLEMS, BUT IT WAS ANNOYING WHEN USING FTN5,DB. * * 3. BROKE UP SERVER FUNCTIONS TO SECONDARY OVERLAYS TO REDUCE * THE SIZE OF THE SERVER. * * 4. FIXED ERROR IN SEND COMMAND, YOU COULDN'T PUT P: OR L: ON * FRONT OF 6 OR 7 CHARACTER FILENAME. * * 5. ADDED 'TAKE' COMMAND AND INITIAL READ FROM THE FILE * 'KERMINI'. ALLOWS LOCAL OR PERMANENT TAKE/KERMINI FILES. * * 6. BE SURE TO UNLOAD CORRECT FILE IF RECEIVE WAS ABORTED. * FIX VARIOUS MINOR PROBLEMS WITH INTERRUPTED TRANSFERS. * * 7. ALLOW CTRL/C TO CANCEL THE PROTOCOL IF ENTERED AS THE FIRST * CHARACTER OF AN INPUT LINE. * * 8. USE TRANSPARENT MODE FOR SEND MODE, AS WELL AS RECEIVE AND * SERVER MODES. * * 3.2 02/03/87 STEPHEN G. ROSEMAN, LEHIGH UNIVERSITY * IMPLEMENTED UNDER NOS 2.5.1, LEVEL 664. SHOULD WORK AT * PREVIOUS NOS LEVELS. * * FEATURE ADDITIONS: * * 1. ADD WAIT-FOR-INPUT CODE, PREVENTING A NEED TO SWAPOUT BEFORE * EACH TERMINAL READ IF THE PACKET INPUT ISN'T THERE YET. * * 2. ALLOW KERMIT TO TIMEOUT IF PACKET DOESN'T COME FROM THE * OTHER SIDE IN TIME. * * 3. ALLOW WILDCARD FILE SEND AND SERVER-SEND. SEARCHES FIRST * FOR MATCH IN LOCAL DISK FILES; IF NONE FOUND, IT SEARCHES * THE USER'S PERM FILE CATALOG. L: AND P: ALLOW EXPLICIT * SPECIFICATION OF LOCAL OR PERMANENT FILE. 'SEND' DISPLAYS * FILE TYPE TO USER (LOCAL OR PERMANENT). * * 4. PUT 63 CHARACTER SET SUPPORT BACK IN. CONVERSION TABLES * ARE UPDATED AT EXECUTION TIME, SO THERE ARE NO INSTALLATION * OPTIONS TO FORGET. * * 5. FIXED TRANSFER STATISTICS TO START TIMING AFTER RECEIVING * FIRST PACKET FROM THE MICRO. WHY LOOK BAD JUST BECAUSE THE * USER WAS SLOW AT ENTERING THE COMMANDS ON THE MICRO? * * 6. MADE SEVERAL CHANGES TO VERSION DISPLAY LINE. DISPLAY * VERSION LINE WHEN STARTING KERMIT. * * 7. ADDED LONG PACKET SUPPORT. CAN SEND AND RECEIVE PACKETS UP * TO 4000 CHARACTERS (RELEASE VALUE = 1000). * * 8. MODIFIED 'HELP' COMMAND TO READ TEXT FROM A PERMANENT FILE * AND DISPLAY ONLY 22 LINES/PAGE. UPDATE HELP TEXT FOR NEW * FEATURES. * * 9. ALLOWED CONTROL/T TO ABORT KERMIT SERVER OR RECEIVE MODE. * * 10. FIXED ERROR IN REPEAT-PREFIXED FILENAME RECEPTION. * * 11. ADDED DIR COMMAND AND REMOTE DIR SERVER COMMAND SUPPORT. * * 12. CHANGE TERMINAL OUTPUT TO 'WRITE', INSTEAD OF 'WRITER'. * ENSURE 0 BYTE TERMINATOR WRITTEN ON EACH TERMINAL WRITE. * * 13. MAKE AUTO CHARACTER SET RECOGNITION ACTUALLY DO SOMETHING * DIFFERENT FOR 6/12 AND DISPLAY CODE SEND. ADD 'SET * TEXT-MODE XXXX' COMMAND TO FORCE PROPER CONVERSIONS FOR * TEXT FILE SEND AND RECEIVE. * * 3.1 12/18/84 PAUL WELLS, UNIVERSITY OF WASHINGTON. * MINOR CHANGES. PUT RDELAY CODE BACK IN TO TAKE ADVANTAGE OF * IAF TYPEAHEAD MODIFICATION. * * 3.0 10/15/84 JOERG HALLBAUER CAL STATE UNIVERSITIES * MANY CHANGES FOR NOS 2.2. SOME OF THE MAJOR ONES INCLUDE: * * 1. REMOVED CONDITIONAL CODE SUPPORTING THE UT2D AND NOS/BE * OPERATING SYSTEMS (SORRY GUYS, BUT IT WAS JUST TOO HARD TO * READ/MAINTAIN THE CODE, AND I HAVE NO WAY OF TESTING MY * MODS TO BE SURE THAT I DIDNT BREAK IT FOR THOSE SYSTEMS). * * 2. USED OVERLAYS TO REDUCE FIELD LENGTH AND STILL ALLOW THE * PROGRAM TO BE INSTALLED ON THE SYSTEM. * * 3. ADDED SUPPORT FOR 8/12 DISK FILES AND AUTO CHARACTER * SET RECOGNITION. KERMIT FILE MODES ARE NOW "TEXT" OR * "BINARY". * * 4. CHANGED NEL CHARACTER TO 3777B TO AVOID CONFUSION WITH * EIGHT BIT DATA. * * 5. CHANGED CYBER BINARY FILE FORMAT TO PACKED 7.5 BYTES/WORD * (60 BIT BINARY) TO ALLOW CYBER BINARY FILES TO BE SENT TO * A MICRO, AND TO MAINTAIN COMPATABILITY WITH THE CYBER RMF * AND XMODEM UTILITIES. * * 6. ADDED #EOR AND #EOF TO PRESERVE THE STRUCTURE OF CYBER * TEXT FILES (E.G. CCL PROCFILES). * * 7. USED MULTIMESSAGE TRANSPARENT INPUT TO ALLOW RECEPTION * OF BINARY FILES WITHOUT EIGHT-BIT QUOTING (ASSUMING THAT * THE COMMUNICATION PATH IS EIGHT BITS WIDE). EIGHT BIT QUOTING * IS STILL SUPPORTED IF NEEDED. * * 8. REMOVED THE PARITY SETTING CODE IN *PUTC*. ON A CYBER * UNDER NOS, PARITY IS >NOT< THE RESPONSIBILITY OF AN APPLICATION * PROGRAM - IT IS SET BY THE OPERATING SYSTEM (I.E. CCP). IF * IT IS INCORRECT THERE, CHANCES ARE YOU WILL NEVER GET FAR * ENOUGH TO START THIS PROGRAM. IF IT IS SET CORRECTLY, THEN * THE PROGRAM DOESN*T NEED TO DO IT. IN ANY CASE, IF THE PARITY * IN THE OPERATING SYSTEM IS SET TO ANYTHING OTHER THAN *NONE*, * SETTING THE HIGH BIT WHEN WE SEND CHARACTERS IS FUTILE. * * 9. ADDED DATA COMPRESSION/REPEAT COUNTS. * * 10. FIXED THE ! (MONITOR COMMAND) COMMAND. * * 11. KERMIT WILL NOW ATTEMPT TO GET OR ATTACH A FILE TO * BE SENT IF IT IS NOT LOCAL. * * 12. IMPLEMENTED SERVER *LOGOUT* COMMAND. IT NOW WILL LOG * YOU OUT - SO BE SURE YOU DON*T HAVE ANY LOCAL FILES YOU * WANT TO KEEP. THE SERVER *FINISH* COMMAND WILL STOP THE * SERVER WITHOUT LOGGING YOU OUT. * * 13. ALL IMPLEMENTED SERVER COMMANDS (SEND, GET, FINISH, * AND LOGOUT) WORK AS ADVERTISED. * * * * X.X 8/17/84 OLAF PORS, UNIVERSITY OF VIRGINIA * KERMIT WAS ADAPTED TO NOS 2.1 (LEVEL 580 AND HOPEFULLY * LATER RELEASES). DISK FILE FORMATS ARE "ASCII" - 6/12 * DISPLAY CODE (74B AND 76B ESCAPE SEQUENCES), AND * "BINARY" - 8-BIT BINARY CHARACTERS IN 12-BIT * BYTES. 6/12 ASCII HAS UP TO 66-BIT * ZERO LINE TERMINATORS. 8/12 BINARY USES ZERO BYTES * AS FILLER (IGNORED), AND 4000B AS A ZERO. INPUT TO * THE PROGRAM FROM THE TERMINAL IS DONE IN ASCII MODE, * I.E., 6/12 ASCII. THE MODE THAT THE TERMINAL WAS IN * BEFORE KERMIT WAS EXECUTED IS RESTORED ON EXIT, * UNLESS THE USER TERMINATES KERMIT WITH THE TERMINAL * BREAK 2 SEQUENCE. JUST BEFORE FILE TRANSMISSION * TAKES PLACE, CCP IS TOLD TO TURN ECHOPLEX OFF, SO THAT * THE KERMIT ON THE OTHER END WON'T INTERPRET AN * ECHOED CARRIAGE RETURN AS A ZERO-LENGTH PACKET * FROM THE CYBER. AT THE END OF FILE TRANSMISSION, * ECHOPLEX IS RESTORED TO WHATEVER 'DUPLEX' IS SET TO. * OUTPUT TO THE TERMINAL IS DONE USING TRANSPARENT * OUTPUT (0007 CONTROL BYTE). * IN ORDER TO TRANSFER BINARY FILES ACROSS LOCAL AREA * NETWORKS WHICH MAY NOT PRESERVE PARITY BITS, * 8-BIT QUOTING IS ACCEPTED ON FILE RECEPTION, AND * REQUESTED DURING FILE SENDING. * NO EFFORT WAS MADE TO GET THE SERVER FUNCTION TO * WORK SINCE FEW OF THE KERMITS ON THE OTHER END * WOULD BE ABLE TO SEND SERVER COMMAND PACKETS. * IN FACT, THE ONLY COMMANDS SUPPORTED/ADVERTISED * TO USERS AT UVA ARE "SET FILE-MODE", "SHOW", * "SEND" AND "RECEIVE". THESE ARE ALL THE COMMANDS * NEEDED TO ACCOMPLISH FILE TRANSFERS. * * 2.0 4/17/84 JIM KNUTSON, UNIVERSITY OF TEXAS AT AUSTIN * FIX FILENAME PACKET TO SEND UPPERCASE FILE NAMES ONLY. * CLEANUP ERROR PACKET HANDLING (ADDED TO STATE TABLE HANDLERS). * FIX RETRY COUNTS TO USE PROPER NUMBER. MODIFY CHARACTER TABLES. * MERGE RIC ANDERSON'S NOS/BE CODE. TRY TO ORGANIZE THE * SOURCE A LITTLE BETTER. ADDED PUSH AND ! COMMANDS. * ADD READ DELAY FOR PERFORMANCE TUNING. CHANGED NEL BACK TO * 205B. THE BINARY DATA-MODE IGNORES NEL THOUGH. * UT2D REQUIRES THE NEL BE A 205B. CHANGED CHARACTER TABLES * TO USE OCTAL CONSTANTS FOR NON-REPRESENTABLE CHARACTERS. * * 1.1 01/21/84 RIC ANDERSON, UNIVERSITY OF ARIZONA AT TUSCON * ADD OVCAPS FOR INSTALLATION IN NUCLEUS. ADD DISPLAY CODE * SUPPORT. REMOVE GOBS AND GOBS OF FIELD LENGTH. CHANGED * NEL TO 4012B TO AVOID CONFUSION WITH DATA BYTE. UPDATED * CHARACTER TABLES FOR 63 AND 64 CHARACTER SETS. CHANGED * PERCENTS IN FPRINTFS TO AT-SIGNS SINCE 63 CHARACTER SET HAS * NO PERCENT SIGN. * * 1.0 10/14/84 JIM KNUTSON, UNIVERSITY OF TEXAS AT AUSTIN * ORIGINAL IMPLEMENTATION. * * JIM KNUTSON * COMPUTATION CENTER ROOM 1 * UNIVERISITY OF TEXAS * AUSTIN, TX 78712 * * APRPANET ADDRESS: KNUTSON@UT-NGP * * SPECIAL THANKS TO KING ABLES FOR HIS CONTRIBUTION. * * MODIFIED FOR NOS/BE BY RIC ANDERSON * UNIVERSITY OF ARIZONA * COMPUTER CENTER * TUCSON, ARIZONA 85721 * * MODIFIED FOR NOS 2.2 BY JOERG HALLBAUER * CALIFORNIA STATE UNIVERSITIES * STATE UNIVERSITIY DATA CENTER * 5670 WILSHIRE BLV. SUITE 2600 * LOS ANGELES CA. 90036 * * FUTURE ENHANCEMENTS: * MOVE HELP TEXT TO INDEXED RANDOM FILE * WILD CARD SENDS * * * BUILD SEQUENCE: * * FTN5,I,OPT=2,S=NOSTEXT,S=PSSTEXT,B=B1,CS. * FTN5,I,OPT=2,S=NOSTEXT,S=PSSTEXT,B=B2,CS. * LIBGEN(F=B2,P=KERMLIB) * LDSET,LIB=KERMLIB/SRVLIB. * LOAD,B1. * NOGO,KERMIT. * * * KERMIT I/O CONSIDERATIONS: * * KERMIT USES TWO MODES OF TERMINAL INPUT. WHEN READING COMMANDS * AND SENDING FILES (FROM COMMAND RATHER THAN SERVER MODE) IT * USES NORMAL CODED (6/12) INPUT. WHEN RECEIVING FILES, AND IN * SERVER MODE, IT USES MULTIMESSAGE TRANSPARENT INPUT IN ORDER * TO PROVIDE AN EIGHT BIT DATA PATH. * * TERMINAL OUTPUT IS ALWAYS DONE IN TRANSPARENT MODE. * * DISK I/O MAY BE IN ANY OF FOUR CHARACTER SETS: * 1. DISPLAY CODE - 6 BITS/CHARACTER. * 2. EXTENDED DISPLAY CODE (6/12) - 6 OR 12 BITS/CHARACTER. * 3. 8/12 ASCII - 8 BITS/CHARACTER IN 12 BIT BYTES. * 4. BINARY - 60 BITS/WORD (7.5 BYTES/WORD). * * TO SUPPORT CDC*S UNIQUE (READ STRANGE) SYSTEM OF FILE AND * RECORD MARKS KERMIT WILL CONVERT EOR*S IN A CYBER TEXT FILE * TO A LINE CONTAINING #EOR ON THE MICRO. LIKEWISE EOF*S ARE * CONVERTED TO #EOF. THUS MULTI-FILE AND MULTI-RECORD TEXT * FILES MAY BE STORED (OR CREATED) ON A MICRO AND THEN SENT * BACK TO A CYBER WITH THEIR STRUCTURE INTACT. * * THIS CONVENTION IS THE SAME ONE USED BY CDC*S RMF (REMOTE * MICRO FACILITY) PRODUCT. * * BINARY FILES WILL NOT HAVE THEIR RECORD STRUCTURE PRESERVED, * SO THE ONLY CYBER BINARIES THAT CAN BE SUCCESSFULLY MOVED TO * A MICRO AND THEN RESTORED TO THE CYBER ARE THOSE THAT CONSIST * OF A SINGLE RECORD (E.G. DATA FILES AND NON-OVERLAYED ABSOLUTE * EXECUTABLE PROGRAMS). IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER EXTERNAL EXITPGM * INITIALIZE *IF -DEF,DEBUG,1 CALL OVERLAY('KRM0100',1,0,'RECALL',1) IF(CMDFD .LT. 0) CALL OVERLAY('KRM1300', O"13",0,'RECALL',1) *IF DEF,DEBUG,1 CALL OVERLAY('KERMIT',1,0,'RECALL') * TRAP USER BREAKS AND TIME LIMITS CALL RECOVR(EXITPGM,O"204",0) * READ AND PARSE USER COMMANDS 5 CALL GETCMD GO TO (200, 10, 20, 30, 10, 40, 50, 60, 70, 80, 90, 100, 110), + CINDEX * - D I R E C T O R Y - 200 CALL OVERLAY('KRM1200',O"12",0,'RECALL',1) GO TO 5 * - E X I T - * - Q U I T - 10 CALL EXITPGM * - H E L P - *IF -DEF,DEBUG,1 20 CALL OVERLAY('KRM0300',3,0,'RECALL',1) *IF DEF,DEBUG,1 20 CALL OVERLAY('KERMIT',3,0,'RECALL') GO TO 5 * - P U S H - 30 AUTORET = NO *IF -DEF,DEBUG,1 CALL OVERLAY('KRM0200',2,0,'RECALL',1) *IF DEF,DEBUG,1 CALL OVERLAY('KERMIT',2,0,'RECALL') GO TO 5 * - R E C E I V E - *IF -DEF,DEBUG,1 40 CALL OVERLAY('KRM0400',4,0,'RECALL',1) *IF DEF,DEBUG,1 40 CALL OVERLAY('KERMIT',4,0,'RECALL') GO TO 5 * - S E N D - *IF -DEF,DEBUG,1 50 CALL OVERLAY('KRM0500',5,0,'RECALL',1) *IF DEF,DEBUG,1 50 CALL OVERLAY('KERMIT',5,0,'RECALL') GO TO 5 * - S E R V E R - *IF -DEF,DEBUG,1 60 CALL OVERLAY('KRM1100',O"11",0,'RECALL',1) *IF DEF,DEBUG,1 60 CALL OVERLAY('KERMIT',O"11",0,'RECALL') GO TO 5 * - S E T - *IF -DEF,DEBUG,1 70 CALL OVERLAY('KRM0600',6,0,'RECALL',1) *IF DEF,DEBUG,1 70 CALL OVERLAY('KERMIT',6,0,'RECALL') GO TO 5 * - S H O W - *IF -DEF,DEBUG,1 80 CALL OVERLAY('KRM0700',7,0,'RECALL',1) *IF DEF,DEBUG,1 80 CALL OVERLAY('KERMIT',7,0,'RECALL') GO TO 5 * - S T A T U S - *IF -DEF,DEBUG,1 90 CALL OVERLAY('KRM1000',O"10",0,'RECALL',1) *IF DEF,DEBUG,1 90 CALL OVERLAY('KERMIT',O"10",0,'RECALL') GO TO 5 * - T A K E - 100 CALL OVERLAY('KRM1300', O"13",0,'RECALL',1) GOTO 5 * - ! - 110 AUTORET = YES *IF -DEF,DEBUG,1 CALL OVERLAY('KRM0200',2,0,'RECALL',1) *IF DEF,DEBUG,1 CALL OVERLAY('KERMIT',2,0,'RECALL') GO TO 5 END BLOCK DATA *** BLOCK DATA - INITIALIZE VARIABLES IN COMMON. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 1) *CALL COMCKER DATA CMDFD / STDIN / DATA DEBUG , DEBUGFD / DBGOFF, 0 / DATA DUPLEX / FULLDUP / DATA FFD / 0 / DATA FILMODE / TEXT / DATA TXTMODE / CSNONE / DATA FMODE / MAXFILE*CLOSED / DATA FNWDS / MAXFILE*0 / DATA FUNGTCH / MAXFILE*EOF / DATA FWPTR / MAXFILE*0 / DATA INITDUP / FULLDUP / DATA MAXRINI / MAXINIT / DATA MAXRTRY / MAXTRY / DATA PACKNUM / 0 / DATA RDELAY / 0 / DATA SCHCNT , RCHCNT / 2*0 / DATA SCHOVRH, RCHOVRH / 2*0 / DATA STARTIM, ENDTIM / 2*0 / DATA STATE / C / DATA WAITPAK / .TRUE. / DATA SSYNC , DSYNC , RSYNC / 3*SOH / DATA SPKSIZE, DPKSIZE, RPKSIZE / IPKSIZE, 2*LPKSIZE / DATA STIMOUT, DTIMOUT, RTIMOUT / 3*ITIMOUT / DATA SPADCT , DPADCT , RPADCT / 3*IPADCT / DATA SPADCH , DPADCH , RPADCH / 3*IPADCH / DATA SEOLCH , DEOLCH , REOLCH / 3*IEOLCH / DATA SCQUOTE, DCQUOTE, RCQUOTE / 3*ICQUOTE / DATA S8QUOTE, D8QUOTE, R8QUOTE / Y,N,N / DATA SCHKTYP, DCHKTYP, RCHKTYP / 3*ICHKTYP / DATA SRPTPFX, DRPTPFX, RRPTPFX / IRPTPFX,2*BLANK / * IT IS UGLY TO MAKE THE SUCCESSFUL INITIATION OF FILE * TRANSMISSION DEPENDENT ON THE TIMING OF A USER TYPEIN. * HOWEVER, SUPPOSE WE TRANSMIT OUR SEND-INIT IMMEDIATELY. * THE OTHER KERMIT WON'T BE PREPARED TO RECEIVE IT * SINCE THE USER NEEDS TO ENTER SOME COMMANDS TO GET THE * OTHER KERMIT GOING, SO THE USER CAN SIMPLY FINISH * HIS TYPEINS AT HIS LEISURE, ENDING WITH 'RECEIVE', * THEN HIT ANOTHER CARRIAGE RETURN TO CAUSE US TO * RETRANSMIT THE SEND-INIT. THUS, HE NEED FEEL NO * TIME PRESSURE. WITH DELAYFP SET TO ZERO (NO DELAY), * THE FIRST SEND-INIT APPEARS AS GARBAGE ON HIS * SCREEN. DELAYFP IS SET TO 2 SECONDS, TO GIVE THE * USER A LITTLE TIME TO GET OUT OF 'CONNECT' MODE, * SO HE WON'T SEE THE TRASH, BUT 2 SECONDS IS NOT SO * LONG THAT HE HAS TO WAIT IMPATIENTLY FOR THE * TRANSFER TO START. 2 SECONDS SHOULD ALSO BE SHORT * ENOUGH SO THAT HE DOESN'T HAVE TIME ENOUGH TO * TYPE 'RECEIVE', SO THAT HE MAY EXPECT CONSISTENTLY * TO INITIATE THE TRANSFER WITH A FINAL CARRIAGE RETURN. DATA DELAYFP / 2 / DATA DEBUGFN / 75, 69, 82, 77, 76, 79, 71, 0 / * K E R M L O G DATA (ERRMSG(I),I=1,14) / 63, 75, 101, 114, 109, 105, 116, 45, 49, * ? K E R M I T - 1 + 55, 48, 58, 2*32 / * 7 0 : DATA (MICMSG(I),I=1, 15) / 40, 76, 111, 99, 97, 108, 32, 75, 101, * ( L O C A L K E + 114, 109, 105, 116, 41, 32/ * R M I T ) DATA ABORTYP / 0 / DATA VERSION / '^CYBER-170/^N^O^S ^K^E^R^M^I^T ^VER 3.3 @S\N' / DATA HLPASCH / '^DECIMAL, OCTAL (^B), OR HEXIDECIMAL (^H) CODE FOR + ^A^S^C^I^I CHARACTER \N' / DATA HLPDLFP / '^NUMBER OF SECONDS TO DELAY FIRST PACKET\N' / DATA HLPDBFN / '^DEBUG OUTPUT LOGFILE SPECIFICATION\N' / DATA HLPPLEN / '^MAXIMUM PACKET LENGTH\N' / DATA HLPPADL / '^NUMBER OF PAD CHARACTERS TO USE\N' / DATA HLPIPRC / '^INITIAL PACKET RETRY COUNT\N' / DATA HLPPRTR / '^PACKET RETRY COUNT\N' / DATA HLPTIMO / '^NUMBER OF SECONDS TO WAIT BEFORE TIMEOUT\N' / DATA HLPSNFN / '^FILE ^NAME\N' / DATA HLPRDEL / '^MILLISECONDS TO DELAY EACH ^T^T^Y READ\N' / DATA DPCTBL/R" ",31*R" ",R" ",R"!",R"""",O"60",R"$",O"63",R"&", * 63 DATA DPCTBL/R" ",31*R" ",R" ",R"!",R"""",O"60",R"$",R" ",R"&", + O"70",R"(",R")",R"*",R"+",R",",R"-",R".",R"/",R"0", + R"1",R"2",R"3",R"4",R"5",R"6",R"7",R"8",R"9",O"0", * 63 + R"1",R"2",R"3",R"4",R"5",R"6",R"7",R"8",R"9",O"63", + R";",R"<",R"=",R">",O"71",R"@",R"A",R"B",R"C",R"D", + R"E",R"F",R"G",R"H",R"I",R"J",R"K",R"L",R"M",R"N", + R"O",R"P",R"Q",R"R",R"S",R"T",R"U",R"V",R"W",R"X", + R"Y",R"Z",R"[",O"75",R"]",O"76",O"65",R"@",R"A", + R"B",R"C",R"D",R"E",R"F",R"G",R"H",R"I",R"J",R"K", + R"L",R"M",R"N",R"O",R"P",R"Q",R"R",R"S",R"T",R"U", + R"V",R"W",R"X",R"Y",R"Z",R"[",R"\",R"]",R"^",R" "/ DATA LASCII/58,97,98,99,100,101,102,103,104,105,106,107,108,109, * : A B C D E F G H I J K L M * 63 DATA LASCII/32,97,98,99,100,101,102,103,104,105,106,107,108,109, * 63 A B C D E F G H I J K L M + 110,111,112,113,114,115,116,117,118,119,120,121,122, * N O P Q R S T U V W X Y Z + 48,49,50,51,52,53,54,55,56,57, * 0 1 2 3 4 5 6 7 8 9 + 43,45,42,47,40,41,36,61,32,44,46,35,91,93,37, * + - * / ( ) $ = , . < [ ] * 63 + 43,45,42,47,40,41,36,61,32,44,46,35,91,93,58, * 63 + - * / ( ) $ = , . < [ ] : + 34,95,33,38,39,63,60,62,64,92,94,59/ * " # ! & ' ? < > @ \ ^ ; DATA UASCII/58,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80, * : A B C D E F G H I J K L M N O P * 63 DATA UASCII/32,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80, * 63 A B C D E F G H I J K L M N O P + 81,82,83,84,85,86,87,88,89,90,48,49,50,51,52,53,54, * Q R S T U V W X Y Z 0 1 2 3 4 5 6 + 55,56,57,43,45,42,47,40,41,36,61,32,44,46,35,91,93, * 7 8 9 + - * / ( ) $ = , . < [ ] + 37,34,95,33,38,39,63,60,62,64,92,94,59/ * " # ! & ' ? < > @ \ ^ ; * 63 + 58,34,95,33,38,39,63,60,62,64,92,94,59/ * 63 : " # ! & ' ? < > @ \ ^ ; DATA SX1274 / + BLANK,O"100",O"136",BLANK,O"72",BLANK,BLANK,O"140",56*BLANK/ * 63 + BLANK,O"100",O"136",BLANK,O"45",BLANK,BLANK,O"140",56*BLANK/ DATA SX1276 / + BLANK,O"141",O"142",O"143",O"144",O"145",O"146",O"147",O"150", + O"151",O"152",O"153",O"154",O"155",O"156",O"157",O"160",O"161", + O"162",O"163",O"164",O"165",O"166",O"167",O"170",O"171",O"172", + O"173",O"174",O"175",O"176",O"177",O"4000",O"1",O"2",O"3",O"4", + O"5",O"6",O"7",O"10",O"11",O"12",O"13",O"14",O"15",O"16", + O"17",O"20",O"21",O"22",O"23",O"24",O"25",O"26",O"27",O"30", + O"31",O"32",O"33",O"34",O"35",O"36",O"37"/ DATA ASC612 / + O"7640",O"7641",O"7642",O"7643",O"7644",O"7645",O"7646",O"7647", + O"7650",O"7651",O"7652",O"7653",O"7654",O"7655",O"7656",O"7657", + O"7660",O"7661",O"7662",O"7663",O"7664",O"7665",O"7666",O"7667", + O"7670",O"7671",O"7672",O"7673",O"7674",O"7675",O"7676",O"7677", + O"55",O"66",O"64",O"60",O"53",O"63",O"67",O"70",O"51",O"52", * 63 + O"55",O"66",O"64",O"60",O"53",O"7404",O"67",O"70",O"51",O"52", + O"47",O"45",O"56",O"46",O"57",O"50",O"33",O"34",O"35",O"36", + O"37",O"40",O"41",O"42",O"43",O"44",O"7404",O"77",O"72",O"54", * 63 + O"37",O"40",O"41",O"42",O"43",O"44",O"63",O"77",O"72",O"54", + O"73",O"71",O"7401",O"1",O"2",O"3",O"4",O"5",O"6",O"7",O"10", + O"11",O"12",O"13",O"14",O"15",O"16",O"17",O"20",O"21",O"22", + O"23",O"24",O"25",O"26",O"27",O"30",O"31",O"32",O"61",O"75", + O"62",O"7402",O"65",O"7407",O"7601",O"7602",O"7603",O"7604", + O"7605",O"7606",O"7607",O"7610",O"7611",O"7612",O"7613",O"7614", + O"7615",O"7616",O"7617",O"7620",O"7621",O"7622",O"7623",O"7624", + O"7625",O"7626",O"7627",O"7630",O"7631",O"7632",O"7633",O"7634", + O"7635",O"7636",O"7637"/ END SUBROUTINE GETCMD *** GETCMD - READ AND PARSE A COMMAND * * PROMPT THE USER FOR A COMMAND AND RETURN AN INTEGER * INDEX CORRESPONDING TO THE COMMAND. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER PARAMETER (TSIZE = 13) CHARACTER*10 CMD(TSIZE) DATA CMD / 'DIRECTORY', 'EXIT', 'HELP', 'PUSH', 'QUIT', 'RECEIVE', + 'SEND', 'SERVER', 'SET', 'SHOW', 'STATUS', 'TAKE', '!' / 10 CONTINUE IF(CMDFD .EQ. STDIN) THEN CALL FPRINTF(STDOUT,'^KERMIT-170>') CALL FFLUSH(STDOUT) CALL FFLUSH(STDIN) ENDIF CINDEX = MATCH(CMD,TSIZE,.TRUE.) IF (CINDEX .EQ. EOF) THEN IF(CMDFD .NE. STDIN) THEN CALL FCLOSE(CMDFD) IF(.NOT.CMDLOCF) CALL RETFILE(CMDLFN) ENDIF CMDFD = STDIN GOTO 10 ELSE IF (CINDEX .EQ. ERROR .OR. CINDEX .EQ. 0) THEN GOTO 10 ENDIF RETURN END SUBROUTINE EXITPGM *** EXITPGM - EXIT THE PROGRAM * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER * RESET TERMINAL PARAMETERS IN CASE OF ABORT IF (INITDUP .EQ. FULLDUP) THEN CALL STTY('RCV-OFF',FULLDUP) ELSE CALL STTY('RCV-OFF',HALFDUP) ENDIF * FLUSH THE DEBUG FILE IF (DEBUGFD .NE. CLOSED) CALL FCLOSE(DEBUGFD) * EXIT TO OPERATING SYSTEM CALL ENDRUN END OVERLAY(1,0) PROGRAM KRM0100 *** PRESET - INITIALIZE RUNNING ENVIRONMENT. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CHARACTER*10 FN LOGICAL CFE DIMENSION FET(6), BUFFER(1000) DATA FN / ' ' / * INSURE WE ARE AN INTERACTIVE JOB. IF (USTART().NE.0) THEN CALL REMARK(' KERMIT - INCORRECT JOB ORIGIN.') CALL ABORT ENDIF * KERMIT IS WRITTEN TO USE THE DISPLAY CODE COLLATING * SEQUENCE WITH THE CHAR AND ICHAR FUNCTIONS. CALL COLSEQ('DISPLAY') * IF 63 CHARACTER SET, FIX THE CONVERSION TABLES. IF(ICHAR(':') .EQ. O"63") CALL FIXCTAB * OPEN THE I/O FILES. IF (FOPEN('STDIN',RD,CS612) .NE. STDIN) THEN CALL REMARK(' CANNOT OPEN STANDARD INPUT') CALL ABORT ELSE IF (FOPEN('STDOUT',WR,CSTXP) .NE. STDOUT) THEN CALL REMARK(' CANNOT OPEN STANDARD OUTPUT') CALL ABORT ENDIF * READ IN ENVIRONMENT IF PRESENT IF (CFE('ZZZZKEN')) THEN CALL MAKEFET('ZZZZKEN', FET, 6, BUFFER, 1000) CALL REWIND(FET, 1) CALL READ(FET, 1) CALL READW(FET,HEADER,LOCF(TRAILER)-LOCF(HEADER),STATUS) CALL RETURN(FET, 1) ELSE CALL DPC2AS(VERSDAT, VERSSTR, 10) CALL FPRINTF(STDOUT,VERSION,VERSSTR,0,0,0) CMDFD = -1 ENDIF RETURN END SUBROUTINE FIXCTAB *** FIXCTAB - FIX CONVERSION TABLES IF RUNNING ON A 63 CHARACTER SET * NOS SYSTEM. WE NEED TO REVERSE THE COLON AND PERCENT SIGN FOR * ASCII CHARACTER SETS, AND REMOVE THE PERCENT SIGN IN DISPLAY CODE. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER DPCTBL(37) = R" " DPCTBL(58) = O"63" LASCII(0) = 32 LASCII(O"63") = 58 UASCII(0) = 32 UASCII(O"63") = 58 SX1274(4) = O"45" ASC612(37) = O"7404" ASC612(58) = O"63" RETURN END OVERLAY(2,0) PROGRAM KRM0200 *** EXECMD - EXECUTE A CONTROL STATEMENT * * EXECUTE A CONTROL STATEMENT AND RETURN TO COMMAND MODE OR * EXIT TO THE OPERATING SYSTEM. NEXT EXECUTION OF KERMIT * WILL START WITH THE CURRENT ENVIRONMENT. THIS SUBROUTINE * DOES NOT RETURN UNLESS THERE ARE ERRORS. * * WE WRITE OUT THE KERMIT ENVIRONMENT USING THE NOS *SRVLIB* * ROUTINES BECAUSE WE WRITE OUT THE KERMIT FILE/BUFFER AREAS. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER BOOLEAN STR(80) CHARACTER*80 CMD LOGICAL CONFIRM DIMENSION FET(6), BUFFER(1000) * BEFORE WE DO ANYTHING RASH IF (AUTORET .EQ. NO) THEN IF (.NOT. CONFIRM(CMDFD)) RETURN ELSE * GET THE NOS CONTROL STATEMENT FROM THE COMMAND LINE. * MUST BE DONE BEFORE WRITING OUT THE ENVIRONMENT. OPOS = 1 TERM = 46 10 IF (GETC(CMDFD,CH) .EQ. NEL) THEN STR(OPOS+0) = TERM STR(OPOS+1) = 0 ELSE IF (CH .NE. BLANK .OR. OPOS .GT. 1) THEN STR(OPOS) = CH OPOS = OPOS+1 ENDIF IF (CH .EQ. 41 .OR. CH .EQ. 46) THEN TERM = 0 ENDIF GOTO 10 ENDIF ENDIF * WRITE OUT THE CURRENT ENVIRONMENT CALL MAKEFET('ZZZZKEN', FET, 6, BUFFER, 1000) CALL RETURN(FET, 1) CALL WRITEW(FET,HEADER,LOCF(TRAILER)-LOCF(HEADER),STATUS) CALL WRITER(FET, 1) * IF ONLY EXIT TO THE OPERATING SYSTEM IF (AUTORET .EQ. NO) THEN CALL EXITPGM ENDIF * QUIT IF NO COMMAND ENTERED IF (OPOS .EQ. 1) RETURN * PACK THE COMMAND INTO A *C* FORMAT LINE DO 20 I=1,80 CMD(I:I) = ':' 20 CONTINUE CALL AS2DPC(STR,CMD) * WRITE THE CCL PROCEDURE FILE AND BEGIN IT CALL RETFILE('ZZZZKCC') CALL EXE(CMD) END OVERLAY(3,0) PROGRAM KRM0300 *** HLPCMD - PROCESS THE HELP COMMAND. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER PARAMETER (HFLAG = 45) CHARACTER WORD*20, RECWORD*20 CHARACTER HELPPFN*10, HELPLFN*10, HELPUN*10 INTEGER ASTR(21) LOGICAL CFE, SKIP DATA HELPPFN/'KERMHLP'/, HELPLFN/'ZZZZKHL'/, HELPUN/'LIBRARY'/ * FIRST, GET THE HELP FILE. CALL PF('ATTACH', HELPLFN, HELPPFN, 'UN', HELPUN, + 'RC', REPLY, 'NA', ' ') IF(REPLY .NE. 0) THEN CALL FPRINTF(STDOUT,'^SORRY, BUT THE ^KERMIT HELP FILE'// + ' IS NOT AVAILABLE\N',0,0,0,0) RETURN ENDIF HFD = FOPEN(HELPLFN, RD, CS612) * NEXT, GET THE KEYWORD AND SEARCH FOR MATCHING RECORD. LEN = GETWORD(CMDFD, ASTR, 20) IF(LEN .EQ. 0) THEN WORD = 'HELP' LEN = 4 ELSE CALL AS2DPC(ASTR, WORD) ENDIF SKIP = .TRUE. LINES = 22 * READ A LINE INTO 'PACKET' BUFFER. 10 I = 1 20 HELPEOF = GETC(HFD, CH) IF(HELPEOF .EQ. EOF) THEN GOTO 90 ELSE PACKET(I) = CH I = I + 1 IF(CH .NE. NEL) GOTO 20 PACKET(I) = 0 ENDIF * GOT FULL LINE. SKIP, DISPLAY (22 LINES/PAGE), START DISPLAY, * OR EXIT. IF(PACKET(1) .NE. HFLAG) THEN IF(SKIP) THEN ELSE CALL PUTSTR(STDOUT, PACKET) LINES = LINES - 1 IF(LINES .EQ. 0) THEN CALL FPRINTF(STDOUT, '@C\N',BELL,0,0,0) CALL FFLUSH(STDIN) 30 CALL GETC(STDIN, CH) IF(CH .NE. NEL) GOTO 30 LINES = 22 ENDIF ENDIF ELSE IF(SKIP) THEN CALL AS2DPC(PACKET(2), RECWORD) IF(WORD(1:LEN) .EQ. RECWORD(1:LEN)) THEN SKIP = .FALSE. ENDIF ELSE GOTO 90 ENDIF ENDIF GOTO 10 90 CALL FCLOSE(HFD) CALL RETFILE(HELPLFN) RETURN END OVERLAY(4,0) PROGRAM KRM0400 *** RCVFILE - TOP LEVEL SUBROUTINE TO START RECEIVE STATE. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER LOGICAL CONFIRM * CONFIRM THE COMMAND IF (.NOT. CONFIRM(CMDFD)) RETURN * ENSURE THERE IS NO JUNK IN THE FILE ARRAY. THIS KEEPS 'REMOVE' * HAPPY, IN THE EVENT WE BLOW OFF BEFORE WE GET A FILE SPEC. CALL FPRINTF(STDOUT,'[^ESCAPE BACK TO MICRO TO ^S^E^N^D FILE(S).] +\N',0,0,0,0) DO 10 I = 1, IPKSIZE FILESTR(I) = 0 10 CONTINUE * SET TERMINAL PARAMETERS CALL STTY('RCV-ON',0) * RECEIVE THE FILE IF (RECEIVE(R) .EQ. OK) THEN CALL FPRINTF(STDOUT,'^RECEIVE COMPLETE.\N',0,0,0,0) ELSE CALL FPRINTF(STDOUT,'^RECEIVE FAILED.\N',0,0,0,0) ENDIF * RESET TERMINAL PARAMETERS IF (INITDUP .EQ. FULLDUP) THEN CALL STTY('RCV-OFF',FULLDUP) ELSE CALL STTY('RCV-OFF',HALFDUP) ENDIF RETURN END OVERLAY(5,0) PROGRAM KRM0500 *** SNDFILE - SEND A FILE TO OTHER KERMIT. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER LOGICAL GETFILE LOGICAL WILDSET CHARACTER*10 LFN * PICK UP THE FILE NAME AND SAVE IT FOR OPENING LATER CALL SETVAL(FILESTR,'S',IRET,9,0,0,HLPSNFN,.TRUE.) IF (IRET .EQ. ERROR) RETURN * GET POSSIBLE FILE TYPE AND MAKE SURE THE NAME IS LEGAL. CALL GETFTY(FILESTR, FTYPE) CALL AS2DPC(FILESTR,LFN) IF(.NOT.WILDSET(LFN)) THEN CALL FPRINTF(STDOUT,'?^ILLEGAL FILE NAME: "@S".\N',FILESTR, + 0,0,0) RETURN ENDIF * CHECK TO MAKE SURE THERE IS A FILE TO SEND SOMEWHERE IF(.NOT. GETFILE(FTYPE)) THEN CALL FPRINTF(STDOUT,'?^FILE "@S" NOT FOUND.\N',FILESTR,0,0,0) RETURN ENDIF CALL FPRINTF(STDOUT,'[^ESCAPE BACK TO MICRO TO RECEIVE ',0,0,0,0) IF(LOCFILE) THEN CALL FPRINTF(STDOUT,'LOCAL FILE(S).]\N',0,0,0,0) ELSE CALL FPRINTF(STDOUT,'PERMANENT FILE(S).]\N',0,0,0,0) ENDIF * SET TERMINAL PARAMETERS CALL STTY('RCV-ON',0) * DELAY THE FIRST PACKET IF (DELAYFP .GT. 0) CALL SLEEP(DELAYFP) * SEND THE FILE PACKNUM = 0 IF (SEND(F, ' ') .EQ. OK) THEN CALL FPRINTF(STDOUT,'^SEND COMPLETE.\N',0,0,0,0) ELSE CALL FPRINTF(STDOUT,'^SEND FAILED.\N',0,0,0,0) ENDIF * RESET TERMINAL PARAMETERS IF (INITDUP .EQ. FULLDUP) THEN CALL STTY('RCV-OFF',FULLDUP) ELSE CALL STTY('RCV-OFF',HALFDUP) ENDIF RETURN END OVERLAY(6,0) PROGRAM KRM0600 *** SET - SET SOME ATTRIBUTES. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER PARAMETER (TSIZE=10) CHARACTER*10 SETTYP(TSIZE) DATA SETTYP / 'DEBUG', 'DELAY', 'DUPLEX', 'FILE-MODE', + 'INIT-RETRY', 'RECEIVE', 'RDELAY', 'RETRY', 'SEND', + 'TEXT-MODE'/ INDX = MATCH(SETTYP,TSIZE,.FALSE.) IF (INDX .LE. 0) RETURN GO TO (20, 30, 40, 10, 50, 70, 75, 80, 90, 100), INDX * SET CHARACTER SET 10 CALL DMODCMD RETURN * SET DEBUGGING MODES 20 CALL DBUGCMD RETURN * SET FIRST PACKET DELAY 30 CALL SETVAL(DELAYFP,'I',0,30,0,30,HLPDLFP,.TRUE.) RETURN * SET THE DUPLEX 40 CALL DPLXCMD RETURN * SET INTIAL PACKET RETRY COUNT 50 CALL SETVAL(MAXRINI,'I',1,50,1,50,HLPIPRC,.TRUE.) RETURN * SET ATTRIBUTES WE REQUEST OF OTHER KERMIT 70 CALL SETPACK(SPKSIZE) RETURN * SET READ DATA DELAY 75 CALL SETVAL(RDELAY,'I',0,2000,0,2000,HLPRDEL,.TRUE.) RETURN * SET PACKET RETRY COUNT 80 CALL SETVAL(MAXRTRY,'I',1,50,1,50,HLPPRTR,.TRUE.) RETURN * SET DEFAULT ATTRIBUTES USED WHEN SENDING TO OTHER KERMIT 90 CALL SETPACK(DPKSIZE) RETURN * SET TEXT MODE (AUTO, 6/12, DISPLAY, 8/12) 100 CALL TXTMCMD RETURN END OVERLAY(7,0) PROGRAM KRM0700 *** SHOW - DISPLAY THE CURRENT PROGRAM SETTINGS * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER LOGICAL CONFIRM *CALL COMXKER * CONFIRM THE COMMAND IF (.NOT. CONFIRM(CMDFD)) RETURN CALL DPC2AS(VERSDAT, VERSSTR, 10) CALL FPRINTF(STDOUT,VERSION,VERSSTR,0,0,0) * DISPLAY THE CURRENT DATE AND TIME CALL GETNOW(MM,DD,YY,HR,MIN,SEC) CALL PUTDAY(STDOUT,MM,DD,YY) CALL FPRINTF(STDOUT,', ',0,0,0,0) CALL PUTMNTH(STDOUT,MM) CALL FPRINTF(STDOUT,' @D, @D ',DD,YY,0,0) IF (HR .LT. 10) CALL PUTC(ASC('0'),STDOUT) CALL FPRINTF(STDOUT,'@D:',HR,0,0,0) IF (MIN .LT. 10) CALL PUTC(ASC('0'),STDOUT) CALL FPRINTF(STDOUT,'@D:',MIN,0,0,0) IF (SEC .LT. 10) CALL PUTC(ASC('0'),STDOUT) CALL FPRINTF(STDOUT,'@D\N\N',SEC,0,0,0) * DISPLAY DISK CHARACTER SET CALL FPRINTF(STDOUT,' ^FILE-MODE: ',0,0,0,0) IF(FILMODE .EQ. TEXT) THEN CALL FPRINTF(STDOUT,'^TEXT (',0,0,0,0) IF(TXTMODE .EQ. CSNONE) THEN CALL FPRINTF(STDOUT,'AUTO)',0,0,0,0) ELSE IF(TXTMODE .EQ. CSDSP) THEN CALL FPRINTF(STDOUT,'DISPLAY)',0,0,0,0) ELSE IF(TXTMODE .EQ. CS612) THEN CALL FPRINTF(STDOUT,'6/12-ASCII)',0,0,0,0) ELSE IF(TXTMODE .EQ. CS812) THEN CALL FPRINTF(STDOUT,'8/12-ASCII)',0,0,0,0) ENDIF ELSE CALL FPRINTF(STDOUT,'^BINARY',0,0,0,0) ENDIF * DISPLAY THE CURRENT DUPLEX CALL FPRINTF(STDOUT,' ^DUPLEX: ',0,0,0,0) IF (GTTY('DUPLEX') .EQ. FULLDUP) THEN CALL FPRINTF(STDOUT,'^FULL\N',0,0,0,0) ELSE CALL FPRINTF(STDOUT,'^HALF\N',0,0,0,0) ENDIF * DISPLAY CURRENT DEBUG MODES CALL FPRINTF(STDOUT,' ^DEBUGGING: ',0,0,0,0) IF ((DEBUG.AND.DBGSTAT).NE.0) THEN IF ((DEBUG.AND.DBGPACK).NE.0) THEN CALL FPRINTF(STDOUT,'^STATES/^PACKETS',0,0,0,0) ELSE CALL FPRINTF(STDOUT,'^STATES ',0,0,0,0) ENDIF ELSE IF ((DEBUG.AND.DBGPACK).NE.0) THEN CALL FPRINTF(STDOUT,'^PACKETS ',0,0,0,0) ELSE CALL FPRINTF(STDOUT,'^OFF ',0,0,0,0) ENDIF ENDIF IF (DEBUG .NE. DBGOFF) THEN CALL FPRINTF(STDOUT,' ^LOG FILE: @S',DEBUGFN,0,0,0) ENDIF * DISPLAY PACKET SETTINGS CALL FPRINTF(STDOUT,'\N\N^PACKET ^PARAMETERS\N',0,0,0,0) CALL FPRINTF(STDOUT, + ' ^RECEIVE ^SEND\N',0,0,0,0) CALL FPRINTF(STDOUT,' ^SIZE: @D @D\N', + SPKSIZE,DPKSIZE,0,0) CALL FPRINTF(STDOUT,' ^TIMEOUT: @D @D\N', + STIMOUT,DTIMOUT,0,0) CALL FPRINTF(STDOUT,' ^PADDING: @D',SPADCT,0,0,0) IF (SPADCT .LT. 10) CALL PUTC(BLANK,STDOUT) CALL FPRINTF(STDOUT,' @D\N',DPADCT,0,0,0) CALL FPRINTF(STDOUT,' ^PAD CHARACTER: \^@C \^@C\N', + CTL(SPADCH),CTL(DPADCH),0,0) CALL FPRINTF(STDOUT,' ^END-OF-^LINE: \^@C \^@C\N', + CTL(SEOLCH),CTL(DEOLCH),0,0) CALL FPRINTF(STDOUT,' ^CONTROL QUOTE: @C @C\N', + SCQUOTE,DCQUOTE,0,0) CALL FPRINTF(STDOUT,' ^EIGHT-BIT QUOTE: @C @C\N', + S8QUOTE,D8QUOTE,0,0) CALL FPRINTF(STDOUT,' ^REPEAT-PREFIX: @C @C\N', + SRPTPFX,DRPTPFX,0,0) CALL FPRINTF(STDOUT,' ^START-OF-^PACKET: \^@C \^@C\N', + CTL(SSYNC),CTL(DSYNC),0,0) * DISPLAY PROTOCOL STUFF CALL FPRINTF(STDOUT,'\N^DELAY BEFORE SENDING FIRST PACKET: @D (SEC +ONDS)\N',DELAYFP,0,0,0) CALL FPRINTF(STDOUT,'^DELAY BEFORE EACH ^T^T^Y READ: @D (MILLISECO +NDS)\N',RDELAY,0,0,0) CALL FPRINTF(STDOUT,'^INIT PACKET RETRY COUNT: @D\N',MAXRINI,0,0, +0) CALL FPRINTF(STDOUT,'^PACKET RETRY COUNT: @D\N\N',MAXRTRY,0,0,0) RETURN END OVERLAY(10,0) PROGRAM KRM1000 *** STATUS - TELL HOW LONG LAST TRANSFER TOOK. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER LOGICAL CONFIRM * CONFIRM THE COMMAND IF (.NOT. CONFIRM(CMDFD)) RETURN * DISPLAY STATISTICS FOR LAST TRANSFER CALL FPRINTF(STDOUT, + '^MAX CHARACTERS IN PACKET: @D RECEIVED; @D SENT\N',SPKSIZE, + RPKSIZE) IF (ENDTIM .LT. STARTIM) ENDTIM = ENDTIM + 86400 NSEC = ENDTIM - STARTIM HR = NSEC / 3600 NSEC = NSEC - (HR * 3600) MIN = NSEC / 60 NSEC = NSEC - (MIN * 60) CALL FPRINTF(STDOUT,'^NUMBER OF CHARACTERS TRANSMITTED IN ',0,0) IF (HR .GT. 0) CALL FPRINTF(STDOUT,'@D HOURS ',HR,0) IF (MIN .GT. 0) CALL FPRINTF(STDOUT,'@D MINUTES ',MIN,0) CALL FPRINTF(STDOUT,'@D SECONDS\N\N',NSEC,0) CALL FPRINTF(STDOUT,' ^SENT: @20D',SCHCNT,0) CALL FPRINTF(STDOUT,' ^OVERHEAD: @D\N',SCHOVRH,0) CALL FPRINTF(STDOUT,' ^RECEIVED: @20D',RCHCNT,0) CALL FPRINTF(STDOUT,' ^OVERHEAD: @D\N',RCHOVRH,0) CALL FPRINTF(STDOUT,'^TOTAL TRANSMITTED: @20D',SCHCNT+RCHCNT,0) CALL FPRINTF(STDOUT,' ^OVERHEAD: @D\N\N',SCHOVRH+RCHOVRH,0) CALL FPRINTF(STDOUT, + '^TOTAL CHARACTERS TRANSMITTED PER SEC: @D\N', + (SCHCNT+RCHCNT) / (ENDTIM-STARTIM),0) CALL FPRINTF(STDOUT, + '^EFFECTIVE DATA RATE: @D BAUD\N\N', ((SCHCNT+RCHCNT) - + (SCHOVRH+RCHOVRH)) / (ENDTIM-STARTIM) * 10,0) IF(ABORTYP .NE. 0) THEN CALL GETEMSG(PACKET) CALL FPRINTF(STDOUT,'?^KERMIT: @S\N',PACKET,0) ENDIF RETURN END OVERLAY(11,0) PROGRAM KRM1100 *** SERVER - START KERMIT SERVER * * THE SERVER CAN CURRENTLY RESPOND TO THE FOLLOWING PACKETS: * * S (SEND-INIT) * R (RECEIVE-INIT) * GL (GENERIC LOGOUT) * GF (GENERIC FINISH) * * OTHER PACKETS ARE REPLIED TO WITH AN E (ERROR) PACKET CONTAINING * AN "UNIMPLEMENTED SERVER COMMAND" MESSAGE. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER LOGICAL CONFIRM * CONFIRM THE COMMAND IF (.NOT. CONFIRM(CMDFD)) RETURN * SET TERMINAL PARAMETERS CALL STTY('RCV-ON',0) * INITIALIZE PACKNUM = 0 NUMTRY = 0 CALL FPRINTF(STDOUT,'[^KERMIT SERVER RUNNING ON ^CYBER HOST. ^PLE +ASE TYPE YOUR ESCAPE SEQUENCE TO\N RETURN TO YOUR LOCAL MACHINE. ^ +SHUT DOWN THE SERVER BY TYPING THE ^KERMIT ^B^Y^E \N OR ^F^I^N^I^S +^H COMMAND ON YOUR LOCAL MACHINE.]\N') * DON'T WAIT AROUND FOR SERVER PACKET; ALLOW SWAPOUT. 10 WAITPAK = .FALSE. PTYP = RDPACK(LEN, NUM, RECPACK) WAITPAK = .TRUE. PACKNUM = NUM PSIZE = LEN * S E N D - I N I T IF (PTYP .EQ. S) THEN CALL OVERLAY('KRM1101', O"11", 1, 'RECALL', 1) * I N I T I A L I Z E ELSE IF (PTYP .EQ. EYE) THEN CALL OVERLAY('KRM1102', O"11", 2, 'RECALL', 1) * R E C E I V E - I N I T ELSE IF (PTYP .EQ. R) THEN CALL OVERLAY('KRM1103', O"11", 3, 'RECALL', 1) * A B O R T ELSE IF (PTYP .EQ. A) THEN IF(INITDUP .EQ. FULLDUP) THEN CALL STTY('RCV-OFF',FULLDUP) ELSE CALL STTY('RCV-OFF',HALFDUP) ENDIF RETURN * G E N E R I C ELSE IF (PTYP .EQ. G) THEN CALL OVERLAY('KRM1104', O"11", 4, 'RECALL', 1) * U N K N O W N ELSE IF (DEBUG .NE. 0) CALL FPRINTF(DEBUGFD,'SERVER: INVALID PACKET -TYPE\N') ABORTYP = INVALID.OR.READING.OR.SRVCMD CALL GETEMSG(ERRMSG(15)) CALL SNDPACK(E,PACKNUM,SLEN(ERRMSG),ERRMSG) ENDIF GOTO 10 END OVERLAY (11,1) PROGRAM KRM1101 *** SERVER RECEIVE * * THIS OVERLAY PROCESSES THE SEND-INIT PACKET FOR THE SERVER. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CALL RDPARAM(RECPACK) CALL SNDPAR(Y,PACKET,PSIZE) CALL SNDPACK(Y,PACKNUM,PSIZE,PACKET) NUMTRY = 0 PACKNUM = AND(PACKNUM+1,O"77") RECSTAT = RECEIVE(F) IF (DEBUG .NE. 0) THEN IF (RECSTAT .EQ. ERROR) THEN CALL FPRINTF(DEBUGFD,'^R^E^C^E^I^V^E ^F^A^I^L^E^D\N') ELSE CALL FPRINTF(DEBUGFD,'^R^E^C^E^I^V^E ^C^O^M^P^L^E^T^E\N') ENDIF ENDIF RETURN END OVERLAY (11,2) PROGRAM KRM1102 *** SERVER INITIALIZE * * THIS OVERLAY PROCESSES THE INITIALIZE PACKET FOR THE SERVER. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL,COMCKER CALL RDPARAM(RECPACK) CALL SNDPAR(Y,PACKET,PSIZE) CALL SNDPACK(Y,PACKNUM,PSIZE,PACKET) RETURN END OVERLAY (11,3) PROGRAM KRM1103 *** SERVER SEND * * THIS OVERLAY PROCESSES THE RECEIVE-INIT PACKET FOR THE SERVER. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL,COMCKER CHARACTER*10 LFN LOGICAL GETFILE, WILDSET CALL EXPSTR(RECPACK, PSIZE, FILESTR) CALL GETFTY(FILESTR, FTYPE) CALL AS2DPC(FILESTR,LFN) IF(.NOT.WILDSET(LFN)) THEN ABORTYP = INVFN CALL GETEMSG(ERRMSG(15)) CALL SNDPACK(E,PACKNUM,SLEN(ERRMSG),ERRMSG) ELSE IF(.NOT.GETFILE(FTYPE)) THEN ABORTYP = NOTLCL CALL GETEMSG(ERRMSG(15)) CALL SNDPACK(E,PACKNUM,SLEN(ERRMSG),ERRMSG) ELSE SNDSTAT = SEND(F, ' ') PACKNUM = 0 IF (DEBUG .NE. 0) THEN IF (SNDSTAT .EQ. ERROR) THEN CALL FPRINTF(DEBUGFD,'^S^E^N^D ^F^A^I^L^E^D\N') ELSE CALL FPRINTF(DEBUGFD,'^S^E^N^D ^C^O^M^P^L^E^T^E\N') ENDIF ENDIF ENDIF RETURN END OVERLAY (11,4) PROGRAM KRM1104 *** SERVER GENERIC FUNCTIONS * * THIS OVERLAY PROCESSES THE GENERIC FUNCTIONS FOR THE SERVER. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL,COMCKER *CALL,COMXKER * L O G O U T IF (RECPACK(1) .EQ. L) THEN CALL SNDPACK(Y,PACKNUM,0,0) CALL LOGOUT * F I N I S H ELSE IF (RECPACK(1) .EQ. F) THEN CALL SNDPACK(Y,PACKNUM,0,0) CALL EXITPGM * D I R ELSE IF (RECPACK(1) .EQ. D) THEN IF(PSIZE .GE. 2) THEN CALL EXPSTR(RECPACK, PSIZE, FILESTR) L1 = UNCHAR(FILESTR(2)) DO 20 L2 = 1, L1+1 20 FILESTR(L2) = FILESTR(L2+2) ELSE L1 = 0 ENDIF CALL RETFILE('ZZZZKDR') FD = FOPEN('ZZZZKDR', WR, CS612) CALL DIR(FD, L1) CALL FCLOSE(FD) CALL WILDSET('ZZZZKDR') CALL GETFILE(L) CALL SEND(X, 'KERMIT-170:') CALL RETFILE('ZZZZKDR') PACKNUM = 0 * U N K N O W N ELSE ABORTYP = SRVCMD CALL GETEMSG(ERRMSG(15)) CALL SNDPACK(E,PACKNUM,SLEN(ERRMSG),ERRMSG) ENDIF RETURN END OVERLAY (12,0) PROGRAM KRM1200 *** DIR - EXECUTE THE 'DIRECTORY' COMMAND * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL,COMCKER * GET THE REQUESTED FILE STRING AND CALL THE DIR ROUTINE LEN = GETWORD(CMDFD, FILESTR, IPKSIZE) CALL DIR(STDOUT, LEN) RETURN END OVERLAY (13,0) PROGRAM KRM1300 *** TAKE - EXECUTE THE 'TAKE' COMMAND * * TAKE FILENAM (TAKE COMMANDS FROM FILENAM) * * WE WILL ACCEPT WILDCARDS, BUT WILL ONLY USE THE FIRST FILE. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL,COMCKER LOGICAL WILDSET, GETFILE * GET THE REQUESTED FILE AND START TAKING INPUT FROM THERE. * IF CMDFD = -1, THIS IS A FAKE 'TAKE KERMINI' CALL AT STARTUP * TIME. * ANY ERRORS CAUSE TAKE TO REVERT TO STDIN FOR COMMAND INPUT. IF(CMDFD .LT. 0) THEN CALL DPC2AS('KERMINI', FILESTR, 7) ELSE IF(CMDFD .NE. STDIN) THEN CALL FCLOSE(CMDFD) CMDFD = STDIN ENDIF CALL SETVAL(FILESTR,'S',IRET,9,0,0,HLPSNFN,.TRUE.) IF(IRET .EQ. ERROR) RETURN ENDIF * GET FILE TYPE AND MAKE SURE THE NAME IS LEGAL. CALL GETFTY(FILESTR, FTYPE) CALL AS2DPC(FILESTR, CMDLFN) IF(.NOT.WILDSET(CMDLFN)) THEN CALL FPRINTF(STDOUT,'?^ILLEGAL FILE NAME: "@S".\N',FILESTR, + 0,0,0) CMDFD = STDIN RETURN ENDIF * GET THE FILE AND OPEN IT. IF 'KERMINI' CALL, DON'T OUTPUT ERROR * MESSAGE. IF(.NOT. GETFILE(FTYPE)) THEN IF(CMDFD .GT. 0) THEN CALL FPRINTF(STDOUT,'?^FILE "@S" NOT FOUND.\N',FILESTR, + 0,0,0) ENDIF CMDFD = STDIN RETURN ENDIF CALL AS2DPC(FILESTR, CMDLFN) CMDFD = FOPEN(CMDLFN, RD, CS612) CMDLOCF = LOCFILE IF(CMDLOCF) THEN CALL FPRINTF(STDOUT,'[^TAKING COMMANDS FROM LOCAL FILE "@S"]\N' + ,FILESTR,0,0,0) ELSE CALL FPRINTF(STDOUT,'[^TAKING COMMANDS FROM PERM FILE "@S"]\N' + ,FILESTR,0,0,0) ENDIF RETURN END *WEOR *DECK KERMLIB SUBROUTINE AS2DPC(ASTR,DSTR) *** AS2DPC - TRANSLATE AN ASCII STRING BUFFER TO DPC CHAR STRING. * * ASCII STRING IS TERMINATED BY A ZERO BYTE. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER BOOLEAN ASTR(*) CHARACTER DSTR*(*) INTEGER CLEN I = 1 CLEN = LEN(DSTR) DSTR = ' ' 10 IF (ASTR(I) .NE. 0 .AND. I .LE. CLEN) THEN IF (ASTR(I) .GT. 127) THEN DSTR(I:I)=' ' ELSE DSTR(I:I)=CHAR(DPCTBL(ASTR(I))) ENDIF I = I + 1 GO TO 10 ENDIF RETURN END INTEGER FUNCTION ASC(DPCH) *** ASC - CONVERT A DPC CHARACTER TO LOWER CASE ASCII. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CHARACTER*1 DPCH ASC = LASCII(ICHAR(DPCH)) RETURN END SUBROUTINE BUFEMP(BUFFER,FD,LEN) *** BUFEMP - DUMP A BUFFER TO A FILE. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER BOOLEAN BUFFER(*), CH *CALL COMXKER * WRITE THE PACKET DATA TO THE FILE I = 1 10 IF (I .LE. LEN) THEN CH = BUFFER(I) * REPEAT COUNTS * * BY THE NATURE OF THE DATA PACKET (VISIBLE CHARACTERS ONLY), * CH CANNOT BE ZERO, SO IF REPEAT COUNTS ARE NOT BEING USED, * REPCH IS ZERO AND THE FOLLOWING TEST WILL ALWAYS BE FALSE. * THE TEST WILL BE TRUE IF AND ONLY IF REPEAT COUNTS ARE * BEING DONE AND CH=THE REPEAT COUNT PREFIX CHARACTER. IF (CH .EQ. REPCH) THEN REPCT = UNCHAR(BUFFER(I+1)) I = I+2 CH = BUFFER(I) ELSE REPCT = 1 ENDIF * 8-BIT QUOTING * * BY THE NATURE OF THE DATA PACKET (VISIBLE CHARACTERS ONLY), * CH CANNOT BE ZERO, SO IF 8-BIT QUOTING IS NOT BEING USED, * Q8CH IS ZERO AND THE FOLLOWING TEST WILL ALWAYS BE FALSE. * THE TEST WILL BE TRUE IF AND ONLY IF 8-BIT QUOTING IS * BEING DONE AND CH=THE 8-BIT QUOTE CHARACTER. IF (CH .EQ. Q8CH) THEN HIGHBIT = Z"80" I = I+1 CH = BUFFER(I) ELSE HIGHBIT = Z"00" ENDIF * CONTROL CHARACTER QUOTING * * THIS CODE ALSO HANDLES THE CASE OF SPECIAL CHARACTER * QUOTING. I.E. "##", "#&", AND "#" WILL BE CONVERTED * TO "#", "&", AND "", RESPECTIVELY. IF (CH .EQ. SCQUOTE) THEN I = I+1 CH = BUFFER(I) TCH = CTL(AND(CH,Z"7F")) IF (TCH .LT. BLANK .OR. TCH .EQ. DEL) CH = CTL(CH) ENDIF * SET THE HIGH BIT CH = OR(CH,HIGHBIT) * FOR TEXT FILES STRIP THE PARITY BIT AND CONVERT *CR*S TO * *NEL*S. FOR BINARY FILES JUST WRITE THE CHARACTERS ASIS. DO 20 J=1,REPCT IF(FCSET(FD) .EQ. CSBIN) THEN CALL PUTC(CH,FD) ELSE CH = AND(CH,Z"7F") IF (CH .EQ. CR) THEN CALL PUTC(NEL,FD) ELSE IF (CH .NE. LF) THEN CALL PUTC(CH,FD) ENDIF ENDIF 20 CONTINUE I = I+1 GO TO 10 ENDIF RETURN END INTEGER FUNCTION BUFFILL(FD,BUFFER) *** BUFFILL - GET SOME DATA TO SEND. * * BUFFILL READS FROM THE FILE TO SEND AND PERFORMS ALL * THE PROPER ESCAPING OF CONTROL CHARACTERS AND MAPPING * NEWLINES INTO CRLF SEQUENCES. IT ALSO GENERATES REPEAT * SEQUENCES. * * ENTRY (FD) = FILE DESCRIPTOR OF FILE TO READ FROM. * (BUFFER) = UNPACKED ASCII TRANSMISSION BUFFER. * * EXIT BUFFER FILLED WITH DATA FROM FILE IN KERMIT * TRANSMISSION FORMAT. ** NOTE: THIS ALGORITHM ASSUMES 5 OVERHEAD CHARACTERS FOR THE * PACKET AND LEAVES 4 CHARACTERS IN CASE THE LAST CHARACTER * TO BUFFER IS A REPEATED CONTROL CHARACTER WITH THE HIGH * BIT SET. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) PARAMETER (MAXREP=94) *CALL COMCKER BOOLEAN BUFFER(*) *CALL COMXKER * FETCH THE FIRST CHARACTER IF (GETC(FD,CH1) .EQ. EOF) THEN BUFFER(1) = 0 BUFFILL = EOF RETURN ENDIF * PREFETCH THE NEXT CHARACTER AND ADD THE CURRENT CHARACTER * TO THE BUFFER BUFPTR = 0 REPCT = 1 10 IF (CH1 .NE. EOF) THEN CH2 = GETC(FD,CH2) * COMPUTE BREAK-EVEN COUNT FOR REPEAT CHARACTERS IF (CH1 .LT. 32 .OR. CH1 .GT. 126) THEN MINREP = 2 ELSE MINREP = 3 ENDIF * ADD THE CHARACTER TO THE BUFFER IF (RRPTPFX .EQ. BLANK .OR. CH1 .EQ. NEL) THEN CALL BUFPACK(CH1,BUFFER,BUFPTR) ELSE IF (CH2 .EQ. CH1 .AND. REPCT .LT. MAXREP) THEN REPCT = REPCT+1 ELSE IF (REPCT .GE. MINREP) THEN BUFFER(BUFPTR+1) = RRPTPFX BUFFER(BUFPTR+2) = TOCHAR(REPCT) BUFPTR = BUFPTR+2 CALL BUFPACK(CH1,BUFFER,BUFPTR) REPCT = 1 ELSE DO 20 I=1,REPCT CALL BUFPACK(CH1,BUFFER,BUFPTR) 20 CONTINUE REPCT = 1 ENDIF IF (BUFPTR .LT. RPKSIZE-9) THEN CH1 = CH2 GOTO 10 ELSE CALL UNGETC(FD,CH2) ENDIF ENDIF BUFFILL = BUFPTR BUFFER(BUFPTR+1) = 0 RETURN END SUBROUTINE BUFPACK(TCH,BUFFER,BUFPTR) *** BUFPACK - ADD A CHARACTER TO THE TRANSMISSION BUFFER. * * THIS ROUTINE ADDS A CHARACTER TO THE OUTGOING TRANSMISSION * BUFFER, CONVERTING TO PAIRS, AND DOING SPECIAL * CHARACTER, CONTROL CHARACTER, AND EIGHT-BIT QUOTING. * * ENTRY (TCH) = CHARACTER TO BE ADDED TO BUFFER. * (BUFFER) = UNPACKED ASCII BUFFER. * (BUFPTR) = POINTER TO LAST CHARACTER IN BUFFER. * * EXIT (BUFPTR) = UPDATED POINTER. * CHARACTER(S) ADDED TO BUFFER. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER BOOLEAN BUFFER(*) *CALL COMXKER * CONVERT END OF LINE CHARACTER TO IF (TCH .EQ. NEL) THEN BUFFER(BUFPTR+1) = RCQUOTE BUFFER(BUFPTR+2) = CTL(CR) BUFPTR = BUFPTR+2 CH = LF XCH = LF ELSE CH = TCH XCH = AND(TCH,Z"7F") ENDIF * 8-TH BIT QUOTING IF (Q8CH .NE. 0) THEN * CONVERT 'A TO &A IF (CH .GT. Z"7F") THEN BUFPTR = BUFPTR+1 BUFFER(BUFPTR) = Q8CH CH = AND(CH,Z"7F") ENDIF * CONVERT & TO #& IF (CH .EQ. Q8CH) THEN BUFPTR = BUFPTR+1 BUFFER(BUFPTR) = RCQUOTE ENDIF ENDIF * SPECIAL CHARACTER AND CONTROL CHARACTER QUOTING IF ((XCH .EQ. RCQUOTE) .OR. + (XCH .EQ. RRPTPFX .AND. RRPTPFX .NE. BLANK)) THEN * CONVERT TO # * CONVERT # TO ## BUFPTR = BUFPTR+1 BUFFER(BUFPTR) = RCQUOTE ELSE IF (XCH .LT. BLANK .OR. XCH .EQ. DEL) THEN * CONVERT TO # BUFPTR = BUFPTR+1 BUFFER(BUFPTR) = RCQUOTE CH = CTL(CH) ENDIF BUFPTR = BUFPTR+1 BUFFER(BUFPTR) = CH RETURN END IDENT CFE ENTRY CFE SST SYSCOM B1 CFE TITLE CFE - CHECK FILES EXISTANCE. COMMENT CHECK FILES EXISTANCE. CFE SPACE 4,10 ** CFE - CHECK FILES EXISTANCE. * * LOGICAL CFE, RESULT * * RESULT = CFE(LFN) * * ENTRY (LFN) = IS THE CHARACTER*7 FILE NAME. * * EXIT (RESULT) = .TRUE. IF FILE EXISTS. * (RESULT) = .FALSE. OTHERWISE. CFE SUBR ENTRY/EXIT SB1 1 SA1 X1 (X1) = FILE NAME RJ =XBTZ> CONVERT BLANKS TO 00B SX1 B1 SET COMPLETE BIT BX6 X6+X1 SA6 CFEA STATUS CFEA MX6 0 ASSUME NO FILE (.FALSE.) MX1 11 LX1 12 (X1) = LOW BITS MASK SA2 CFEA BX2 X1*X2 (X2) = 0 IF FILE NOT FOUND ZR X2,CFEX IF NO FILE MX6 -1 SET FILE FOUND (.TRUE.) EQ CFEX RETURN CFEA DATA 0 FET END LOGICAL FUNCTION CONFIRM(FD) *** CONFIRM - LOOK FOR A NEWLINE. * * CONFIRM WILL EXPECT THAT THE NEXT TOKEN OF INPUT BE A * NEWLINE FOR CONFIRMATION TO BE TRUE. IF THE NEXT TOKEN * IS A QUESTION MARK, THEN CONFIRMATION IS FALSE AND * A "CONFIRM WITH A CARRIAGE RETURN" MESSAGE WILL BE DISPLAYED. * ANY OTHER TEXT WILL CAUSE A 'NOT CONFIRMED "TEXT"' MESSAGE * TO BE DISPLAYED AND CONFIRM WILL RETURN FALSE. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER * GET LEADING BLANKS TIL A TOKEN IS FOUND CONFIRM = .FALSE. 10 IF (GETC(FD,CH) .EQ. NEL) THEN CONFIRM = .TRUE. ELSE IF (CH .EQ. EOF) THEN RETURN ELSE IF (CH .EQ. BLANK .OR. CH .EQ. TAB) THEN GO TO 10 ELSE IF (CH .EQ. QMARK) THEN CALL FPRINTF(STDOUT,'^CONFIRM WITH A CARRIAGE RETURN\N') ELSE CALL FPRINTF(STDOUT,'?^NOT CONFIRMED - "') 20 CALL PUTC(CH,STDOUT) CH = GETC(FD,CH) IF (CH .NE. NEL .AND. CH .NE. EOF) GO TO 20 CALL FPRINTF(STDOUT,'"\N') ENDIF RETURN END INTEGER FUNCTION CTOI(ASTR) *** CTOI - CONVERT CHARACTER BUFFER TO INTEGER. * * CTOI CONVERTS THE NUMBER USING BASE 10 AS A DEFAULT. * A SUFFIX OF H WILL CONVERT USING BASE 16 AND A SUFFIX * OF O WILL CONVERT USING BASE 8. DEFAULT SUFFIX IS * D. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER PARAMETER (DIG0=48, DIG7=55, DIG9=57, BIGA=65, BIGB=66, BIGD=68) PARAMETER (BIGF=70, BIGH=72, BIGO=79, LETA=97, LETB=98, LETD=100) PARAMETER (LETF=102, LETH=104, LETO=111) INTEGER ASTR(*) BASE = 0 PTR = 0 * FIND LAST VALID DIGIT 10 PTR = PTR + 1 IF (ASTR(PTR) .NE. 0) GO TO 10 PTR = PTR - 1 IF (ASTR(PTR) .EQ. LETO .OR. ASTR(PTR) .EQ. BIGO .OR. + ASTR(PTR) .EQ. LETB .OR. ASTR(PTR) .EQ. BIGB .OR. + ASTR(PTR) .EQ. LETH .OR. ASTR(PTR) .EQ. BIGH) THEN EOD = PTR - 1 ELSE EOD = PTR PTR = PTR + 1 ENDIF * TRY TO FIGURE OUT THE BASE IF (ASTR(PTR) .EQ. 0) THEN BASE = 10 ELSE IF (ASTR(PTR) .EQ. LETO .OR. ASTR(PTR) .EQ. BIGO .OR. + ASTR(PTR) .EQ. LETB .OR. ASTR(PTR) .EQ. BIGB) THEN BASE = 8 ELSE IF (ASTR(PTR) .EQ. LETH .OR. ASTR(PTR) .EQ. BIGH) THEN BASE = 16 ENDIF * IF DIDN'T FIND A BASE IF (BASE .EQ. 0) THEN CALL FPRINTF(STDOUT,'CTOI - INVALID BASE @C\N',ASTR(PTR),0,0,0) CTOI = 0 RETURN ENDIF * ADD UP THE DIGITS TOTAL = 0 ISNEG = 1 DO 100 I = 1,EOD CH = ASTR(I) IF (CH .EQ. MINUS) THEN ISNEG = -1 GO TO 100 ENDIF IF (BASE .EQ. 10) THEN IF (CH .LT. DIG0 .OR. CH .GT. DIG9) THEN CALL FPRINTF(STDOUT,'CTOI - INVALID DECIMAL DIGIT @C\N', + CH,0,0,0) CTOI = 0 RETURN ELSE CH = CH - DIG0 ENDIF ELSE IF (BASE .EQ. 8) THEN IF (CH .LT. DIG0 .OR. CH .GT. DIG7) THEN CALL FPRINTF(STDOUT,'CTOI - INVALID OCTAL DIGIT @C\N', + CH,0,0,0) CTOI = 0 RETURN ELSE CH = CH - DIG0 ENDIF ELSE IF (BASE .EQ. 16) THEN IF (CH .GE. DIG0 .AND. CH .LE. DIG9) THEN CH = CH - DIG0 ELSE IF (CH .GE. LETA .AND. CH .LE. LETF) THEN CH = 10 + CH - LETA ELSE IF (CH .GE. BIGA .AND. CH .LE. BIGF) THEN CH = 10 + CH - BIGA ELSE CALL FPRINTF(STDOUT,'CTOI - INVALID HEX DIGIT @C\N', + CH,0,0,0) CTOI = 0 RETURN ENDIF ENDIF TOTAL = TOTAL*BASE + CH 100 CONTINUE CTOI = TOTAL * ISNEG RETURN END SUBROUTINE DBUGCMD *** DBUGCMD - SET THE DEBUGGING MODES. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CHARACTER*10 FN LOGICAL CONFIRM PARAMETER (TSIZE=5) CHARACTER*10 DBGTYP(TSIZE) DATA DBGTYP / 'ALL', 'LOG-FILE', 'OFF', 'PACKETS', 'STATES' / INDX = MATCH(DBGTYP,TSIZE,.FALSE.) IF (INDX .LE. 0) RETURN GO TO (10, 20, 30, 40, 50), INDX * SET ALL DEBUG MODES 10 IF (.NOT. CONFIRM(CMDFD)) RETURN DEBUG = DBGALL GO TO 100 * SET DEBUG LOGFILE 20 CALL SETVAL(DEBUGFN,'S',IRET,7,0,0,HLPDBFN,.TRUE.) IF (IRET .EQ. OK) THEN IF (DEBUGFD .NE. 0) THEN CALL FCLOSE(DEBUGFD) DEBUGFD = 0 ENDIF GO TO 100 ENDIF RETURN * TURN OFF ALL DEBUGGING 30 IF (.NOT. CONFIRM(CMDFD)) RETURN DEBUG = DBGOFF IF (DEBUGFD .NE. 0) THEN CALL FCLOSE(DEBUGFD) DEBUGFD = 0 ENDIF RETURN * TOGGLE DEBUG PACKETS 40 IF (.NOT. CONFIRM(CMDFD)) RETURN DEBUG = DEBUG .XOR. DBGPACK GO TO 100 * TOGGLE DEBUG STATES 50 IF (.NOT. CONFIRM(CMDFD)) RETURN DEBUG = DEBUG .XOR. DBGSTAT GO TO 100 * OPEN THE DEBUG FILE IF NOT DONE ALREADY 100 IF (DEBUGFD .EQ. 0) THEN FN = ' ' CALL AS2DPC(DEBUGFN,FN) DEBUGFD = FOPEN(FN,WR,CS612) ENDIF RETURN END SUBROUTINE DELAY(MSEC) *** DELAY - DELAY FOR A FEW MILLISECONDS. * * ENTRY MSEC = DELAY TIME IN MILLISECONDS. * * EXIT TIME HAS ELAPSED. * * NOTES WORKS FOR SCOPE, UT2D, AND NOS/BE SYSTEMS. NOS USERS MUST * CHANGE THE COMPUTATION TO ACCOUNT FOR THE DIFFERENCE * IN DATA RETURNED BY RTIME MACRO. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER * USE REAL TIME CLOCK TO CONTROL DELAY PERIOD. CALL RTIME(RTCL) RTCL = AND(RTCL,COMPL(MASK(24))) 10 CALL RTIME(RTCL1) RTCL1 = AND(RTCL1,COMPL(MASK(24))) * CONVERT FROM SECONDS/4096 TO MILLISECONDS. IF((RTCL1-RTCL).GT.MSEC) RETURN * SLEEP FOR 100 MILLISECONDS. CALL RECALL(0) GO TO 10 END SUBROUTINE DIR(FD, LEN) *** DIR - CREATE DIRECTORY LISTING ON SPECIFIED FILE. * * ENTRY FD - OUTPUT FILE DESCRIPTOR * LEN - LENGTH OF STRING IN 'FILESTR' ARRAY. * FILESTR CONTAINS FILE REQUEST STRING: * FILENAM * FILE* (WILDCARD LOCAL FILES) * L:* OR L: (ALL LOCAL FILES) * P:* OR P: (ALL PERMANENT FILES) * P:FILE* (WILDCARD PERMANENT FILES) * EXIT FILE CONTAINS DIRECTORY OUTPUT. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CHARACTER FILENAM*10 LOGICAL WILDSET FILESTR(LEN+1) = 0 * CHECK FOR L: OR P:, REMOVE AND FLAG IF PRESENT. * MOVE REST OF REQUEST STRING TO RIGHT PLACE. CALL GETFTY(FILESTR, FTYPE) IF(SLEN(FILESTR) .EQ. 0) THEN FILENAM = '*' ELSE CALL AS2DPC(FILESTR, FILENAM) ENDIF LOCFILE = (FTYPE .NE. P) IF(.NOT.WILDSET(FILENAM)) THEN CALL FPRINTF(FD,'? ^INVALID FILE NAME STRING. \N',0,0,0,0) RETURN ENDIF * WE KNOW WHAT TO GET A DIRECTORY OF. NOW DO IT. PACKET(1) = BLANK IF(LOCFILE) THEN CALL GETLFNI CALL FPRINTF(FD,'^DIRECTORY OF ^LOCAL FILES.\N',0,0,0,0) ELSE CALL GETPFNI CALL FPRINTF(FD,'^DIRECTORY OF ^PERMANENT FILES.\N',0,0,0,0) ENDIF I1 = 0 10 IF(LOCFILE) THEN CALL GETLFN(FILENAM) ELSE CALL GETPFN(FILENAM) ENDIF IF(FILENAM .NE. ' ') THEN CALL DPC2AS(FILENAM, PACKET(2), 9) CALL PUTSTR(FD, PACKET) I1 = I1 + 1 IF(MOD(I1, 7) .EQ. 0) THEN CALL PUTC(NEL, FD) ENDIF GOTO 10 ELSE IF(I1 .EQ. 0) THEN CALL FPRINTF(FD,'? ^NO FILES FOUND. \N',0,0,0,0) ELSE IF(I1 .EQ. 1) THEN CALL FPRINTF(FD,'\N 1 FILE FOUND.\N',0,0,0,0) ELSE CALL FPRINTF(FD,'\N @D FILES FOUND.\N',I1,0,0,0) ENDIF ENDIF RETURN END SUBROUTINE DMODCMD *** DMODCMD - PERFORM A SET FILE-MODE XXXX COMMAND. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER LOGICAL CONFIRM PARAMETER (TSIZE=2) CHARACTER*15 DATATYP(TSIZE) DATA DATATYP /'BINARY','TEXT'/ * MATCH THE PARAMETER. INDX = MATCH(DATATYP,TSIZE,.FALSE.) IF (INDX .LE. 0) RETURN IF (.NOT. CONFIRM(CMDFD)) RETURN * TAKE THE APPROPRIATE ACTION. GO TO (10,20), INDX * SET BINARY TRANSFER MODE 10 FILMODE = BINARY RETURN * SET TEXT TRANSFER MODE 20 FILMODE = TEXT RETURN END SUBROUTINE DOPRNT(FD,STRNG,PTYP,FMT,I1,I2,I3,I4) *** DOPRNT - WORKHORSE FOR FORMATTED ASCII I/O. * * CONVERSION IS SIMILAR TO FPRINTF USED IN C. SUPPORTED * CONVERSIONS ARE @D (INTEGER), @C (ASCII CHARACTER), @S (ASCII * STRING BUFFER). A \N WILL MAP TO A NEWLINE, A \T WILL * WILL MAP TO A TAB, A \0 WILL TERMINATE THE FORMAT SCANNING. * A \ FOLLOWED BY ANY OTHER CHARACTER WILL CAUSE THAT CHARACTER * TO BE OUTPUT. THE DEFAULT OUTPUT CASE WILL BE LOWERCASE. * A ^ FOLLOWED BY A LETTER WILL CAUSE THAT CHARACTER TO BE OUTPUT * AS UPPERCASE. A @D CONVERSION MAY NOW SPECIFY A MINIMUM FIELD * WIDTH AS @D (I.E. @10D) IN WHICH THE NUMBER WILL BE BLANK * PADDED TO THE RIGHT TO USE UP CHARACTERS. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CHARACTER*(*) FMT BOOLEAN STR(21), STRNG(*) CHARACTER*1 CH * CHECK FOR FILE OR STRING WRITE IF (PTYP .NE. 1 .AND. PTYP .NE. 2) THEN CALL DISPLA(' DOPRNT - INVALID WRITE FUNCTION',PTYP) CALL ABORT ENDIF * OUTPUT THE FORMATTED STRING IPTR = 1 OPTR = 1 FPTR = 1 FMTLEN = LEN(FMT) 10 IF (FPTR .LE. FMTLEN) THEN CH = FMT(FPTR:FPTR) IF (CH .NE. '\' .AND. CH .NE. '@' .AND. CH .NE. '^') THEN IF (PTYP .EQ. 1) THEN CALL PUTC(ASC(CH),FD) ELSE STRNG(OPTR) = ASC(CH) OPTR = OPTR + 1 ENDIF * IS IT A QUOTE OR SPECIAL SEQUENCE CHARACTER? ELSE IF (CH .EQ. '\') THEN FPTR = FPTR+1 CH = FMT(FPTR:FPTR) IF (CH .EQ. 'N' .AND. PTYP .EQ. 1) THEN CALL PUTC(NEL,FD) ELSE IF (CH .EQ. 'T' .AND. PTYP .EQ. 1) THEN CALL PUTC(TAB,FD) ELSE IF (CH .EQ. '0') THEN IF (PTYP .EQ. 2) STRNG(OPTR) = 0 RETURN ELSE IF (CH .EQ. 'N') THEN STRNG(OPTR) = NEL OPTR = OPTR + 1 ELSE IF (CH .EQ. 'T') THEN STRNG(OPTR) = TAB OPTR = OPTR + 1 ELSE IF (PTYP .EQ. 1) THEN CALL PUTC(ASC(CH),FD) ELSE STRNG(OPTR) = ASC(CH) OPTR = OPTR + 1 ENDIF ENDIF * IS IT AN UPPERCASE MAPPING? ELSE IF (CH .EQ. '^') THEN FPTR = FPTR + 1 CH = FMT(FPTR:FPTR) IF (CH .GE. 'A' .AND. CH .LE. 'Z') THEN ACH = ASC(CH)-32 ELSE ACH = ASC(CH) ENDIF IF (PTYP .EQ. 1) THEN CALL PUTC(ACH,FD) ELSE STRNG(OPTR) = ACH OPTR = OPTR + 1 ENDIF * MUST BE A CONVERSION (@) ELSE INTWDTH = 1 FPTR = FPTR + 1 CH = FMT(FPTR:FPTR) * IS IT AN INTEGER VALUE FORMAT SPEC? 20 IF (CH .EQ. 'D') THEN IF (IPTR .EQ. 1) THEN ACH = I1 ELSE IF (IPTR .EQ. 2) THEN ACH = I2 ELSE IF (IPTR .EQ. 3) THEN ACH = I3 ELSE ACH = I4 ENDIF IF (PTYP .EQ. 1) THEN CALL PUTINT(FD,ACH,INTWDTH) ELSE TLEN = ITOS(ACH,STRNG(OPTR),INTWDTH) OPTR = OPTR + TLEN ENDIF IPTR = IPTR + 1 * IS IT A CHARACTER VALUE OUTPUT SPEC? ELSE IF (CH .EQ. 'C') THEN IF (IPTR .EQ. 1) THEN ACH = I1 ELSE IF (IPTR .EQ. 2) THEN ACH = I2 ELSE IF (IPTR .EQ. 3) THEN ACH = I3 ELSE ACH = I4 ENDIF IF (PTYP .EQ. 1) THEN CALL PUTC(ACH,FD) ELSE STRNG(OPTR) = ACH OPTR = OPTR + 1 ENDIF IPTR = IPTR + 1 * IS IT A STRING VALUE OUTPUT SPEC? ELSE IF (CH .EQ. 'S') THEN IF (IPTR .EQ. 1) THEN IF (PTYP .EQ. 1) THEN CALL PUTSTR(FD,I1) ELSE CALL STRCPY(I1,STRNG(OPTR)) OPTR = OPTR + SLEN(I1) ENDIF ELSE IF (IPTR .EQ. 2) THEN IF (PTYP .EQ. 1) THEN CALL PUTSTR(FD,I2) ELSE CALL STRCPY(I2,STRNG(OPTR)) OPTR = OPTR + SLEN(I2) ENDIF ELSE IF (IPTR .EQ. 3) THEN IF (PTYP .EQ. 1) THEN CALL PUTSTR(FD,I3) ELSE CALL STRCPY(I3,STRNG(OPTR)) OPTR = OPTR + SLEN(I3) ENDIF ELSE IF (PTYP .EQ. 1) THEN CALL PUTSTR(FD,I4) ELSE CALL STRCPY(I4,STRNG(OPTR)) OPTR = OPTR + SLEN(I4) ENDIF ENDIF IPTR = IPTR + 1 * IS IT A FIELD WIDTH SPECIFIER? ELSE IF (CH .GE. '0' .AND. CH .LE. '9') THEN SPTR = 0 30 SPTR = SPTR + 1 STR(SPTR) = ASC(CH) FPTR = FPTR + 1 CH = FMT(FPTR:FPTR) IF (CH .GE. '0' .AND. CH .LE. '9') GO TO 30 STR(SPTR+1) = 0 INTWDTH = CTOI(STR) GO TO 20 * UNKNOWN CONVERSION SO OUTPUT THE @ AND CONVERSION CHAR ELSE IF (PTYP .EQ. 1) THEN CALL PUTC(ASC('@'),FD) CALL PUTC(ASC(CH),FD) ELSE STRNG(OPTR) = ASC('@') STRNG(OPTR+1) = ASC(CH) OPTR = OPTR + 2 ENDIF ENDIF ENDIF FPTR = FPTR + 1 GO TO 10 ENDIF IF (PTYP .EQ. 2) STRNG(OPTR) = 0 RETURN END SUBROUTINE DPC2AS(DSTR,ASTR,NWORDS) *** DPC2AS - CONVERT A DPC CHARACTER STRING TO UPPERCASE ASCII. * * TRANSLATE STRING OF DISPLAY CODE CHARACTERS TO UPPERCASE ASCII. * STRING IS NWORDS CHARACTERS (WORDS) LONG, WITH A ZERO TERMINATION * AT NWORDS+1. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CHARACTER*(*) DSTR BOOLEAN ASTR(*) DO 1 I=1,NWORDS ASTR(I) = UASCII((ICHAR(DSTR(I:I)))) 1 CONTINUE * SET ASCII END-OF-STRING-BUFFER ASTR(NWORDS+1) = 0 RETURN END SUBROUTINE DPLXCMD *** DPLXCMD - PERFORM A SET DUPLEX XXXX COMMAND * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER LOGICAL CONFIRM PARAMETER (TSIZE=2) CHARACTER*10 DUPTYP(TSIZE) DATA DUPTYP / 'FULL', 'HALF' / * MATCH THE PARAMETER INDX = MATCH(DUPTYP,TSIZE,.FALSE.) IF (INDX .LE. 0) RETURN IF (.NOT. CONFIRM(CMDFD)) RETURN * TAKE THE APPROPRIATE ACTION GO TO (10, 20), INDX * SET FULL DUPLEX 10 CALL STTY('DUPLEX',FULLDUP) INITDUP = FULLDUP RETURN * SET HALF DUPLEX 20 CALL STTY('DUPLEX',HALFDUP) INITDUP = HALFDUP RETURN END IDENT EXE ENTRY EXE B1=1 TITLE EXE - WRITE AND BEGIN A CCL PROC. COMMENT EXE - WRITE AND BEGIN A CCL PROC. EXE SPACE 4,10 *** EXE - WRITE AND BEGIN A CCL PROC. * * ENTRY (X1) = ADDRESS OF *C* FORMAT NOS COMMAND. * * EXIT NONE. EXE SUBR ENTRY SB1 1 WRITEC ZZZZKCC,X1 WRITEC ZZZZKCC,(=C*$REVERT,EX.KERMIT.*) WRITEC ZZZZKCC,(=C*$EXIT.*) WRITEC ZZZZKCC,(=C*$REVERT,EX.KERMIT.*) WRITER ZZZZKCC,R EXCST (=C*$BEGIN,,ZZZZKCC.*) * FET AND BUFFER ZZZZKCC FILEB BUF,101B BUF EQU * ORG ZZZZKCC+2 VFD 42/0,18/CEND ORG BUF DATA C*.PROC,X.* DATA C*$RETURN,ZZZZKCC.* CEND EQU * BSS 101B-CEND+BUF END SUBROUTINE EXPSTR(ISTR, LEN, OSTR) *** EXPSTR - EXPAND STRING * * EXPSTR EXPANDS AN INPUT STRING, DUPLICATING REPEAT-PREFIXED * CHARACTERS AND REMOVING CONTROL-QUOTE CHARACTERS AS REQUIRED. * THIS ROUTINE DOESN'T HANDLE 8TH BIT QUOTED CONVERSIONS. * * ENTRY ISTR - INPUT STRING * LEN - INPUT STRING LENGTH * OSTR - OUTPUT STRING (WILL BE ZERO-TERMINATED) * * NOTE THAT IF THERE IS NO REPEAT PREFIXING, REPCT = 0, BUT SINCE CH * CAN NEVER BE ZERO, EVERYTHING SHOULD BE OK. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) INTEGER ISTR(*), OSTR(*) *CALL COMCKER *CALL,COMXKER I1 = 1 I2 = 1 10 CH = ISTR(I1) IF((CH.EQ.REPCH) .AND. (CH.NE.0) .AND. (I1+2.LE.LEN)) THEN CH = ISTR(I1+2) DO 20 I3 = 1, UNCHAR(ISTR(I1+1)) OSTR(I2) = CH 20 I2 = I2 + 1 I1 = I1 + 2 ELSE IF(CH .EQ. SCQUOTE) THEN I1 = I1 + 1 OSTR(I2) = ISTR(I1) I2 = I2 + 1 ELSE OSTR(I2) = CH I2 = I2 + 1 ENDIF I1 = I1 + 1 IF(I1 .LE. LEN) GOTO 10 OSTR(I2) = 0 RETURN END SUBROUTINE FCLOSE(FD) *** FCLOSE - REMOVE AN FD FROM THE ACTIVE LIST. * * FCLOSE WILL REMOVE THE FD FROM THE ACTIVE LIST FOR * ALLOCATION AT A LATER DATE. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN CALL DISPLA(' FCLOSE - INVALID FD ',FD) CALL ABORT ELSE IF (FMODE(FD) .EQ. 0) THEN CALL DISPLA(' FCLOSE - FD NOT OPEN.',FD) RETURN ENDIF * FORCE EMPTYING OF THE BUFFER CALL FFLUSH(FD) * WRITE A FILE MARK IF(FMODE(FD) .EQ. WR .AND. .NOT. CTDEV(FD)) THEN CALL WRITER(FETS(0,FD),1) ENDIF FMODE(FD) = CLOSED RETURN END SUBROUTINE FFLUSH(FD) *** FFLUSH - FLUSH AN I/O BUFFER. * * FFLUSH WILL FLUSH THE ASCII STRING BUFFER FOR A PARTICULAR * FILE DESCRIPTOR. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) * # E O R \N PARAMETER (EORLINE = O"0043 0105 0117 0122 0000") * # E O F \N PARAMETER (EOFLINE = O"0043 0105 0117 0106 0000") *CALL COMCKER PARAMETER (FIRST = 1, IN = 2, OUT = 3, LIMIT = 4) * IS THE FD VALID? IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN CALL DISPLA(' FFLUSH - INVALID FILE DESCRIPTOR',FD) CALL ABORT ELSE IF (FMODE(FD) .EQ. 0) THEN CALL DISPLA(' FFLUSH - FILE DESCRIPTOR NOT OPEN',FD) CALL ABORT ENDIF * IF FD WAS OPENED FOR WRITE FLUSH TO THE FILE IF (FMODE(FD) .EQ. WR) THEN IF (FCSET(FD) .EQ. CSBIN) THEN CALL WRITEW(FETS(0,FD),FCHBUF(1,FD),FNWDS(FD),STATUS) ELSE IF (CTDEV(FD)) THEN IF (FCSET(FD) .EQ. CSDSP .OR. FCSET(FD) .EQ. CS612) THEN CALL A8SX12(FCHBUF(1,FD),FNWDS(FD)) FNWDS(FD) = FINDEOL(FCHBUF(1,FD),FNWDS(FD),.FALSE.) ENDIF CALL WRITEW(FETS(0,FD),FCHBUF(1,FD),FNWDS(FD),STATUS) * ENSURE ZERO EOL BYTE IF((FCHBUF(FNWDS(FD),FD).AND.O"7777").NE.0) THEN CALL WRITEW(FETS(0,FD), 0, 1, STATUS) ENDIF CALL WRITE(FETS(0,FD), 0) ELSE IF (FCHBUF(1,FD) .EQ. EORLINE) THEN CALL WRITER(FETS(0,FD),1) ELSE IF (FCHBUF(1,FD) .EQ. EOFLINE) THEN CALL WRITEF(FETS(0,FD),1) ELSE IF (FCSET(FD) .EQ. CSDSP) THEN CALL A8DPC(FCHBUF(1,FD),FNWDS(FD)) FNWDS(FD) = FINDEOL(FCHBUF(1,FD),FNWDS(FD),.FALSE.) ELSE IF (FCSET(FD) .EQ. CS612) THEN CALL A8SX12(FCHBUF(1,FD),FNWDS(FD)) FNWDS(FD) = FINDEOL(FCHBUF(1,FD),FNWDS(FD),.FALSE.) ENDIF CALL WRITEW(FETS(0,FD),FCHBUF(1,FD),FNWDS(FD),STATUS) ENDIF ENDIF * IF FD WAS OPENED FOR READ CLEAR THE BUFFERS ELSE CALL RECALL(FETS(0,FD)) FETS(IN,FD) = FETS(OUT,FD) = AND(FETS(FIRST,FD),O"777777") FUNGTCH(FD) = EOF ENDIF * RESET THE BUFFER POINTERS FWPTR(FD) = 1 FNWDS(FD) = 0 FWSHFT(FD) = 0 RETURN END SUBROUTINE FILCHK(FN) *** FILCHK - CHECK AND FIX FILENAME VALIDITY. * * CHECK VALIDITY OF FILENAME. INVALID CHARACTERS ARE DROPPED. * IF A PERIOD IS FOUND (FILENAME.EXT), KEEP PART OF THE FILENAME * AND PART OF THE EXTENSION (NORMALLY 4 AND 3 CHARACTERS, * RESPECTIVELY). USE UP TO 7 CHARACTERS OF THE INPUT NAME. * IF THERE IS NO VALID FILENAME (NO CHARACTERS WERE ALPHANUMERIC), * THEN RETURN THE NAME 'KERMDAT'. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CHARACTER CH*1 CHARACTER FN*(*) LENGTH = LEN(FN) L1 = 0 EXTP = 0 * REMOVE INVALID CHARACTERS, DETERMINE LENGTH OF STRING * AND START OF EXTENSION. DO 10 I1 = 1, LENGTH CH = FN(I1:I1) IF((CH.GE.'A'.AND.CH.LE.'Z') .OR. (CH.GE.'0'.AND.CH.LE.'9')) THEN L1 = L1 + 1 FN(L1:L1) = CH ELSE IF((CH.EQ.'.') .AND. (EXTP.EQ.0)) THEN EXTP = L1 + 1 ENDIF 10 CONTINUE * IF STRING CONTAINS ALL ILLEGAL CHARACTERS, USE DEFAULT FILE NAME. * IF EMPTY EXTENSION OR NO EXTENSION, TRUNCATE STRING AT 7. * IF STRING > 7 CHARACTERS, TRUNCATE EXTENSION TO 3 CHARACTERS * (UNLESS THE FILENAME PART IS SHORT) AND THE ENTIRE STRING * TO 7, MOVE THE EXTENSION DOWN. IF(L1 .EQ. 0) THEN FN = 'KERMDAT' L1 = 7 ELSE IF((EXTP.EQ.0) .OR. (EXTP.GT.L1)) THEN L1 = MIN0(L1, 7) ELSE * (IF FILENAME > 4 CHARACTERS, RETAIN UP TO 3 CHARACTERS OF THE * EXTENSION; ELSE, KEEP AS MANY AS POSSIBLE.) MAXEL = MAX0(3,7-(EXTP-1)) L1 = MIN0(L1, EXTP+MAXEL-1) IF(L1 .GT. 7) THEN REMOVE = L1 - 7 DO 20 I1 = EXTP, L1 CH = FN(I1:I1) FN(I1-REMOVE:I1-REMOVE) = CH 20 CONTINUE L1 = 7 ENDIF ENDIF DO 30 I1 = L1+1, LENGTH FN(I1:I1) = ' ' 30 CONTINUE RETURN END IDENT FILECS ENTRY FILECS B1=1 TITLE FILECS - RETURN THE CHARACTER SET OF A CIO BUFFER COMMENT RETURN THE CHARACTER SET OF A CIO BUFFER FILECS SPACE 4,10 *** INTEGER FUNCTION FILECS(FET) * * RETURN THE CHARACTER SET OF A CIO BUFFER. * * ENTRY (X1) = FWA OF FET OF FILE TO BE CHECKED. THE CIRCULAR * BUFFER SHOULD HAVE BEEN FILLED BY A PREVIOUS * READ FUNCTION. * * EXIT (X6) = -1 IF THE BUFFER IS EMPTY. * = 1 FOR DISPLAY CODE. * = 2 FOR 8/12 ASCII. * = 3 FOR 6/12 ASCII. * * USES X - 0, 1, 2, 3, 4, 5, 6. * A - 1, 2, 3, 4, 5. * B - 1, 2, 3, 4, 5, 6. * * * PAUL WELLS 82/11/12 FILECS SUBR ENTRY/EXIT SB1 1 SA1 X1+B1 (X1) = FET+1 SB2 X1 (B2) = *FIRST* SA1 A1+B1 SB3 X1 (B3) = *IN* SA1 A1+B1 SB4 X1 (B4) = *OUT* SA1 A1+B1 SB5 X1 (B5) = *LIMIT* MX0 0 CLEAR ASCII HIGH BITS ACCUMULATOR SX6 -B1 PRESET EMPTY BUFFER STATUS EQ B3,B4,FILECSX IF BUFFER EMPTY SA2 GCSA (X2) = 8/12 MASK SA3 A2+B1 (X3) = CARETS SA4 A3+B1 (X4) = 6/12 MASK SX6 B1+ PRESET DISPLAY CODE STATUS GCS1 SA1 B4+ (X1) = WORD FROM BUFFER BX5 X2*X1 (X5) = HIGH BITS OF EACH BYTE BX0 X0+X5 ACCUMULATE HIGH BITS SB6 8 (B6) = 6/12 SHIFT COUNTER GCS2 BX5 X4*X1 (X5) = FIRST AND THIRD CHARACTERS BX5 X5-X3 NZ X5,GCS3 IF NOT TWO CARETS SX6 3 SET 6/12 STATUS GCS3 LX1 6 LOOK AT NEXT CHARACTER POSITION SB6 B6-B1 DECREMENT SHIFT COUNT NZ B6,GCS2 LOOP ON THIS WORD SB4 B4+B1 ADVANCE BUFFER POINTER NE B4,B5,GCS4 IF NO WRAP AROUND SB4 B2 WRAP GCS4 NE B4,B3,GCS1 IF NOT END OF DATA * HERE WHEN THE TEST LOOP IS COMPLETE NZ X0,FILECSX RETURN IF NOT 8/12 SX6 2 RETURN 8/12 STATUS EQ FILECSX RETURN * MASKS GCSA DATA 74007400740074007400B DATA 76007600000000000000B DATA 77007700000000000000B END INTEGER FUNCTION FINDEOL(WSA,WSAL,ADDNEL) *** FINDEOL - FIND EOL BYTE IN WORKING BUFFER. * * ENTRY (WSA) = LINE IMAGE. * (WSAL) = LENGTH OF WSA. * (ADDNEL) = .TRUE. IF A NEL SHOULD BE APPENDED TO BUFFER. * * EXIT (FINDEOL) = LENGTH OF DATA LINE IN WORDS. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER BOOLEAN WSA(WSAL) LOGICAL ADDNEL * IF THE LINE LENGTH IS ZERO, RETURN ZERO LENGTH IF(WSAL .LE. 0) THEN FINDEOL = 0 RETURN ENDIF * FIND ZERO BYTE EOL AND REPLACE WITH NEL IF REQUESTED DO 20 I = 1, WSAL IF (AND(WSA(I),O"7777") .EQ. 0) THEN IF (ADDNEL) THEN WSA(I) = OR(WSA(I),NEL) ENDIF FINDEOL = I RETURN ENDIF 20 CONTINUE * NO EOL FOUND - REPLACE LAST BYTE WITH NEL IF(ADDNEL) WSA(WSAL) = OR(AND(WSA(WSAL),MASK(48)),NEL) FINDEOL = WSAL RETURN END INTEGER FUNCTION FOPEN(FN,MODE,CSET) *** FOPEN - OPEN A FILE FOR I/O. * * FOPEN ASSIGNS A FILE DESCIPTOR (INTEGER INDEX) TO A FILE NAME. * * ENTRY (FN) = FILE NAME. * (MODE) = FILE MODE. * = *RD* FOR READ MODE. * = *WR* FOR WRITE MODE. * = *CREATE* FOR NEW FILE / WRITE MODE. * (CSET) = CHARACTER SET OF THE FILE. * = *CSNONE* FOR NONE SPECIFIED (CHECK IT). * = *CSDSP* FOR DISPLAY CODE. * = *CS812* FOR 8/12 ASCII. * = *CS612* FOR 6/12 ASCII. * = *CSBIN* FOR BINARY (60 BIT). * = *CSTXP* FOR INTERACTIVE TRANSPARENT. * * EXIT (FOPEN) = FILE DESCRIPTOR OR ERROR CODE. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CHARACTER*10 FN LOGICAL CFE * CHECK FOR VALID PARAMETERS IF (MODE .LT. RD .OR. MODE .GT. CREATE) THEN CALL DISPLA(' FOPEN - INVALID MODE ',MODE) CALL ABORT ENDIF * FIND THE NEXT UNUSED ENTRY DO 100 I = 1, MAXFILE * SET THE FILE NAME, DEVICE TYPE, AND MODE IF (FMODE(I) .EQ. CLOSED) THEN IF (FN .EQ. 'STDIN') THEN FNAME(I) = 'INPUT' CTDEV(I) = .TRUE. ELSE IF (FN .EQ. 'STDOUT') THEN FNAME(I) = 'OUTPUT' CTDEV(I) = .TRUE. ELSE FNAME(I) = FN CTDEV(I) = .FALSE. ENDIF IF (MODE .EQ. CREATE) THEN IF (.NOT.CTDEV(I) .AND. CFE(FNAME(I))) THEN FMODE(I) = CLOSED FOPEN = ERROR RETURN ENDIF FMODE(I) = WR ELSE FMODE(I) = MODE ENDIF * INITIALIZE THE FILE CALL MAKEFET(FNAME(I),FETS(0,I),FETL,CIOBUFF(1,I),CIOBUFL) FCSET(I) = CSET IF (.NOT.CTDEV(I)) THEN CALL NODROP(FETS(0,I)) CALL REWIND(FETS(0,I),1) IF (FMODE(I) .EQ. RD) THEN CALL READ(FETS(0,I),1) IF (CSET .EQ. CSNONE) THEN FCSET(I) = MAX(FILECS(FETS(0,I)),CSDSP) ENDIF ELSE IF (CSET .EQ. CSNONE) THEN FCSET(I) = CS612 ENDIF ENDIF ENDIF * INITIALIZE THE BUFFER POINTERS FWPTR(I) = 1 FNWDS(I) = 0 FWSHFT(I) = 0 FEOF(I) = .FALSE. FOPEN = I RETURN * IF TABLE ENTRY FILE NAME MATCHES FN ELSE IF (FNAME(I) .EQ. FN) THEN CALL REMARK(' FOPEN - FILE ' // FN // ' ALREADY OPEN.') CALL ABORT ENDIF 100 CONTINUE * NO UNUSED ENTRY FOUND CALL REMARK(' FOPEN - TOO MANY FILES OPEN.') CALL ABORT END SUBROUTINE FPRINTF(FD,FMT,I1,I2,I3,I4) *** FPRINTF - POOR ATTEMPT AT FORMATTED ASCII OUTPUT. * * CONVERSION IS SIMILAR TO FPRINTF USED IN C. SUPPORTED * CONVERSIONS ARE @D (INTEGER), @C (ASCII CHARACTER), @S (ASCII * STRING BUFFER). A \N WILL MAP TO A NEWLINE, A \T WILL * WILL MAP TO A TAB, A \0 WILL TERMINATE THE FORMAT SCANNING. * A \ FOLLOWED BY ANY OTHER CHARACTER WILL CAUSE THAT CHARACTER * TO BE OUTPUT. THE DEFAULT OUTPUT CASE WILL BE LOWERCASE. * A ^ FOLLOWED BY A LETTER WILL CAUSE THAT CHARACTER TO BE OUTPUT * AS UPPERCASE. A @D CONVERSION MAY NOW SPECIFY A MINIMUM FIELD * WIDTH AS @D (I.E. @10D) IN WHICH THE NUMBER WILL BE BLANK * PADDED TO THE RIGHT TO USE UP CHARACTERS. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CHARACTER*(*) FMT * IS THE FD VALID? IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN CALL DISPLA(' FPRINTF - INVALID FD ',FD) CALL ABORT ELSE IF (FMODE(FD) .EQ. CLOSED) THEN CALL DISPLA(' FPRINTF - FD NOT OPEN.',FD) RETURN ENDIF * IS IT OK TO WRITE ON THIS STREAM? IF ((FMODE(FD).AND.WR) .NE. WR) THEN CALL DISPLA(' FPRINTF - WRITE ON READ-ONLY FILE ',FD) CALL ABORT ENDIF * NOW CALL THE REAL FPRINTF WORKHORSE CALL DOPRNT(FD,0,1,FMT,I1,I2,I3,I4) RETURN END SUBROUTINE FREAD(FD,BUF,NWD) *** FREAD - READ SOME WORDS FROM A FILE. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER BOOLEAN BUF(NWD) * IS THE FD VALID? IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN CALL DISPLA(' FREAD - INVALID FILE DESCRIPTOR',FD) CALL ABORT ELSE IF (FMODE(FD) .EQ. CLOSED) THEN CALL DISPLA(' FREAD - FILE DESCRIPTOR NOT OPEN',FD) CALL ABORT ENDIF * CHECK IF OK TO READ IF ((FMODE(FD).AND.RD) .NE. RD) THEN CALL DISPLA(' FREAD - READ ON WRITE-ONLY FILE ',FD) CALL ABORT ENDIF * TRANSFER WORDS FROM THE FILE CALL READW(FETS(0,FD),BUF,NWD,STATUS) RETURN END SUBROUTINE FWRITE(FD,BUF,NWD) *** FWRITE - WRITE SOME WORDS TO A FILE. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER BOOLEAN BUF(NWD) * IS THE FD VALID? IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN CALL DISPLA(' FWRITE - INVALID FD ',FD) CALL ABORT ELSE IF (FMODE(FD) .EQ. CLOSED) THEN CALL DISPLA(' FWRITE - FD NOT OPEN.',FD) RETURN ENDIF * IS IT OK TO WRITE ON THIS STREAM? IF ((FMODE(FD).AND.WR) .NE. WR) THEN CALL DISPLA(' FWRITE - WRITE ON READ-ONLY FILE ',FD) CALL ABORT ENDIF * WRITE THE WORDS TO THE FILE CALL WRITEW(FETS(0,FD),BUF,NWD,STATUS) RETURN END INTEGER FUNCTION GETC(FD,CH) *** GETC - RETURN NEXT CHARACTER FROM THE INPUT STREAM. * * GETC WILL RETURN THE NEXT BYTE READ FROM THE FILE DESCRIPTOR FD. * EOF (-1) IS RETURNED WHEN EOF IS READ ON A DISK FILE. CONNECTED * FILES NEVER RETURN EOF. * * ZERO BYTES IN NON-BINARY FILES ARE IGNORED. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER * IS THE FD VALID? IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN CALL DISPLA(' GETC - INVALID FILE DESCRIPTOR',FD) CALL ABORT ELSE IF (FMODE(FD) .EQ. CLOSED) THEN CALL DISPLA(' GETC - FILE DESCRIPTOR NOT OPEN',FD) CALL ABORT ENDIF * CHECK IF OK TO READ IF ((FMODE(FD).AND.RD) .NE. RD) THEN CALL DISPLA(' GETC - READ ON WRITE-ONLY FILE ',FD) CALL ABORT ENDIF * CHECK FOR A PUSHED-BACK CHARACTER IF (FUNGTCH(FD) .NE. EOF) THEN GETC = CH = FUNGTCH(FD) FUNGTCH(FD) = EOF RETURN ENDIF * GET MORE DATA IF NEEDED 10 IF (FWPTR(FD) .GT. FNWDS(FD)) THEN IF (FEOF(FD)) THEN GETC = CH = EOF RETURN ELSE FNWDS(FD) = GETREC(FD,FCHBUF(1,FD),MAXWD,FEOF(FD)) FWPTR(FD) = 1 IF (FCSET(FD) .EQ. CSBIN) THEN FWSHFT(FD) = 8 ELSE IF (FCSET(FD) .EQ. CSTXP) THEN FWSHFT(FD) = 24 ELSE FWSHFT(FD) = 12 ENDIF GOTO 10 ENDIF ENDIF * BREAK OUT THE NEXT BYTE FROM THE BUFFER IF (FCSET(FD) .EQ. CSBIN) THEN IF (FWSHFT(FD) .EQ. 64) THEN CH = OR( AND(SHIFT(FCHBUF(FWPTR(FD)+0,FD),4),Z"F0"), - AND(SHIFT(FCHBUF(FWPTR(FD)+1,FD),4),Z"0F") ) FWSHFT(FD) = 4+8 FWPTR(FD) = FWPTR(FD)+1 ELSE IF (FWSHFT(FD) .EQ. 60) THEN CH = AND(FCHBUF(FWPTR(FD),FD),Z"FF") FWSHFT(FD) = 8 FWPTR(FD) = FWPTR(FD)+1 ELSE CH = AND(SHIFT(FCHBUF(FWPTR(FD),FD),FWSHFT(FD)),Z"FF") FWSHFT(FD) = FWSHFT(FD)+8 ENDIF ELSE IF (FWSHFT(FD) .EQ. 60) THEN CH = AND(FCHBUF(FWPTR(FD),FD),Z"FFF") FWSHFT(FD) = 12 FWPTR(FD) = FWPTR(FD)+1 ELSE CH = AND(SHIFT(FCHBUF(FWPTR(FD),FD),FWSHFT(FD)),Z"FFF") FWSHFT(FD) = FWSHFT(FD)+12 ENDIF IF (CH .EQ. 0) THEN GOTO 10 ELSE IF (CH .NE. NEL) THEN CH = AND(CH,Z"FF") ENDIF ENDIF GETC = CH RETURN END SUBROUTINE GETEMSG(STRNG) *** GETEMSG - GET AN ERROR MESSAGE STRING FOR THE CURRENT ERROR. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER INTEGER DIREC(8,2) INTEGER PACKNAM(9,0:6) DATA DIREC / 115, 101, 110, 100, 4*0, * S E N D + 114, 101, 99, 101, 105, 118, 101, 0 / * R E C E I V E DATA PACKNAM / 85, 78, 75, 78, 79, 87, 78, 2*0, * U N K N O W N + 73, 110, 105, 116, 5*0, * I N I T + 70, 105, 108, 101, 110, 97, 109, 101, 0, * F I L E N A M E + 68, 97, 116, 97, 5*0, * D A T A + 69, 79, 70, 6*0, * E O F + 66, 114, 101, 97, 107, 4*0, * B R E A K + 83, 101, 114, 118, 101, 114, 3*0 / * S E R V E R IF ((ABORTYP.AND.INITERR) .NE. 0) THEN PTYP = 1 ELSE IF ((ABORTYP.AND.FILERR) .NE. 0) THEN PTYP = 2 ELSE IF ((ABORTYP.AND.DATAERR) .NE. 0) THEN PTYP = 3 ELSE IF ((ABORTYP.AND.EOFERR) .NE. 0) THEN PTYP = 4 ELSE IF ((ABORTYP.AND.BRKERR) .NE. 0) THEN PTYP = 5 ELSE IF ((ABORTYP.AND.SRVCMD) .NE. 0) THEN PTYP = 6 ELSE PTYP = 0 ENDIF DTYP = SHIFT(ABORTYP.AND.O"300",-6) IF ((ABORTYP.AND.TOOMANY) .NE. 0) THEN CALL SPRINTF(STRNG,'^CANNOT @S @S PACKET',DIREC(1, + DTYP),PACKNAM(1,PTYP)) ELSE IF ((ABORTYP.AND.INVALID) .NE. 0) THEN CALL SPRINTF(STRNG, + '^RECEIVED AN INVALID PACKET WHILE TRYING TO @S @S PACKET', + DIREC(1,DTYP),PACKNAM(1,PTYP)) ELSE IF ((ABORTYP.AND.SEQERR) .NE. 0) THEN CALL SPRINTF(STRNG, + '^PACKET SEQUENCE ERROR WHILE TRYING TO @S @S PACKET', + DIREC(1,DTYP),PACKNAM(1,PTYP)) ELSE IF ((ABORTYP.AND.LCLFILE) .NE. 0) THEN CALL SPRINTF(STRNG,'^FILE ALREADY EXISTS',0,0) ELSE IF ((ABORTYP.AND.NOTLCL) .NE. 0) THEN CALL SPRINTF(STRNG,'^FILE NOT FOUND',0,0) ELSE IF ((ABORTYP.AND.INVFN) .NE. 0) THEN CALL SPRINTF(STRNG,'^INVALID FILENAME',0,0) ELSE IF ((ABORTYP.AND.SRVCMD) .NE. 0) THEN CALL SPRINTF(STRNG,'^UNIMPLEMENTED SERVER COMMAND',0,0) ELSE IF ((ABORTYP.AND.INTRPT) .NE. 0) THEN CALL SPRINTF(STRNG, '^TRANSFER INTERRUPTED DURING @S.', + DIREC(1, DTYP), 0, 0) ELSE IF ((ABORTYP.AND.MICERR) .NE. 0) THEN CALL STRCPY(MICMSG, STRNG) ENDIF RETURN END LOGICAL FUNCTION GETFILE(FTYPE) *** GETFILE - CHECK IF THE REQUESTED FILE (OR WILDCARD FILES) * EXIST SOMEWHERE IN THE SYSTEM. IF FTYPE = B, CHECK FIRST FOR A * MATCH IN THE USER'S LOCAL FILES. IF NOT FOUND, TRY THE USER'S PERM FILE * CATALOG. IF FTYPE = L OR P, CHECK ONLY THE SPECIFIED LOCATION. * * ENTRY FTYPE = B TO ALLOW LOCAL OR PERMANENT FILE(S) * L TO ALLOW LOCAL ONLY * P TO ALLOW PERMANENT ONLY * WILDSET HAS BEEN CALLED W/ FILE NAME STRING. * * EXIT (GETFILE) = .TRUE. IF FILE HAS BEEN FOUND SOMEWHERE. * (FILESTR) HAS FIRST FILE NAME STRING. * (LOCFILE) = .TRUE. IF TRANSFER IS FROM LOCAL FILES, * .FALSE. IF TRANSFER IF FROM PERM FILES. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CHARACTER LFN*10 * CHECK TO SEE IF WE CAN FIND A MATCHING FILE. LOOK IN LOCAL FILE * LIST AND/OR THE PERMANENT FILE CATALOG. IF((FTYPE.EQ.L) .OR. (FTYPE.EQ.B)) THEN CALL GETLFNI CALL GETLFN(LFN) LOCFILE = (LFN .NE. ' ') ENDIF IF((FTYPE.EQ.P) .OR. ((FTYPE.EQ.B).AND..NOT.LOCFILE)) THEN CALL GETPFNI CALL GETPFN(LFN) LOCFILE = .FALSE. ENDIF IF(LFN.EQ.' ') THEN GETFILE = .FALSE. RETURN ELSE GETFILE = .TRUE. IF(.NOT.LOCFILE) THEN CALL GETPFIL(LFN) ENDIF ENDIF * MOVE ACTUAL FILE NAME OF FIRST FILE TO STRING CALL DPC2AS(LFN, FILESTR, INDEX(LFN,' ')-1) RETURN END SUBROUTINE GETFTY(STR, FTYPE) *** GETFTY - GET AND REMOVE FILE TYPE SPECIFIER FROM STRING. * * CHECKS THE STRING, AND IF THERE IS A FILE TYPE SPECIFIER, REMOVE * IT FROM THE STRING AND RETURN THE VALUE OF THE SPECIFIER. VALID * SPECIFIERS ARE: * L: FOR LOCAL FILES ONLY * P: FOR PERMANENT FILES ONLY * B: FOR LOCAL OR PERMANENT FILES. * ANY OTHER FILE TYPE OR NONE IS RETURNED AS B * * ENTRY STR ASCII STRING ARRAY * EXIT FTYPE L, P, OR B. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER DIMENSION STR(*) IF(STR(2) .EQ. COLON) THEN IF((STR(1).AND.O"137") .EQ. L) THEN FTYPE = L ELSE IF((STR(1).AND.O"137") .EQ. P) THEN FTYPE = P ELSE FTYPE = B ENDIF CALL STRCPY(STR(3), STR(1)) ELSE FTYPE = B ENDIF RETURN END LOGICAL FUNCTION GETPFIL(LFN) *** GETPFIL - GET/ATTACH A PERMANENT FILE. * * ENTRY (LFN) = FILE NAME. * * EXIT (GETFILE) = .TRUE. IF FILE IS NOW LOCAL. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CHARACTER*(*) LFN CALL PF('GET',LFN,LFN,'RC',REPLY,'NA',' ') IF (REPLY .NE. 0) CALL PF('ATTACH',LFN,LFN,'RC',REPLY,'NA',' ') GETPFIL = (REPLY .EQ. 0) RETURN END SUBROUTINE GETLFN(NAME) *** GETLFN - GET THE NAME OF NEXT LOCAL FILE IN THE JOB WHICH * MATCHES THE WILDCARD CRITERIA. * * BE SURE TO CALL 'GETLFNI' AND 'WILDSET' FIRST! * * CALL GETLFN(NAME) * * ENTRY GETLFNI AND WILDSET SHOULD HAVE BEEN CALLED * EXIT NAME*7 CONTAINS THE NEXT LOCAL FILE, OR ' ' IF NO MORE * MATCHING FILES. * CHARACTER NAME*(*) LOGICAL WILDMAT 10 I = NEXTLF(1) IF(I .EQ. 0) THEN NAME = ' ' RETURN ENDIF CALL MOVETOC(I, NAME) IF(.NOT.WILDMAT(NAME)) GOTO 10 RETURN ENTRY GETLFNI *** GETLFNI - INITIALIZE FOR SEQUENCE OF 'GETLFN' CALLS. * * HAS 'NEXTLF' RESET FOR BEGINNING OF LOCAL FILE LIST. * I = NEXTLF(0) RETURN END SUBROUTINE GETNOW(MM,DD,YY,HR,MIN,SEC) *** GET THE CURRENT DATE AND TIME. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CHARACTER*10 DATE, TIME, STRING STRING = DATE() OFFSET = ICHAR('0') YY = (ICHAR(STRING(2:2))-OFFSET)*10 + ICHAR(STRING(3:3))-OFFSET MM = (ICHAR(STRING(5:5))-OFFSET)*10 + ICHAR(STRING(6:6))-OFFSET DD = (ICHAR(STRING(8:8))-OFFSET)*10 + ICHAR(STRING(9:9))-OFFSET YY = YY + 1900 STRING = TIME() HR = (ICHAR(STRING(2:2))-OFFSET)*10 + ICHAR(STRING(3:3))-OFFSET MIN = (ICHAR(STRING(5:5))-OFFSET)*10 + ICHAR(STRING(6:6))-OFFSET SEC = (ICHAR(STRING(8:8))-OFFSET)*10 + ICHAR(STRING(9:9))-OFFSET RETURN END SUBROUTINE GETPFN(NAME) *** GETPFN - GET THE NAME OF NEXT PERM FILE IN THE CATALOG WHICH * MATCHES THE WILDCARD CRITERIA. * * BE SURE TO CALL 'GETPFNI' AND 'WILDSET' FIRST! * * CALL GETPFN(NAME) * * ENTRY GETPFNI AND WILDMAT SHOULD HAVE BEEN CALLED * EXIT NAME*7 CONTAINS THE NEXT PERM FILE, OR ' ' IF NO MORE * MATCHING FILES. * CHARACTER NAME*(*) LOGICAL WILDMAT 10 I = NEXTPF(1) IF(I .EQ. 0) THEN NAME = ' ' RETURN ENDIF CALL MOVETOC(I, NAME) IF(.NOT.WILDMAT(NAME)) GOTO 10 RETURN ENTRY GETPFNI *** GETPFNI - INITIALIZE FOR SEQUENCE OF 'GETPFN' CALLS. * * HAS 'NEXTPF' RESET FOR BEGINNING OF CATALOG. * I = NEXTPF(0) RETURN END INTEGER FUNCTION GETREC(FD,WSA,WSAL,EOFFLAG) *** GETREC - READ A LINE FROM A FILE. * * ENTRY (FD) = FILE DESCRIPTOR. * (WSAL) = LENGTH OF WSA. * * EXIT (WSA) = DATA FROM FILE. * (GETREC) = NUMBER OF WORDS ACTUALLY PLACED IN WSA. * (EOFFLAG) = .TRUE. IF END OF FILE HIT. * * NOTES: PERFORMS DISPLAY TO ASCII CONVERSION IF NEEDED. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) * # E O R \N PARAMETER (EORLINE = O"0043 0105 0117 0122 3777") * # E O F \N PARAMETER (EOFLINE = O"0043 0105 0117 0106 3777") *CALL COMCKER BOOLEAN WSA(WSAL) BOOLEAN SWSA(MAXWD), STATUS LOGICAL EOFFLAG EOFFLAG = .FALSE. IF(CTDEV(FD)) THEN * PROCESS CONNECTED FILES. IF (RDELAY .GT. 0) CALL DELAY(RDELAY) CALL READ(FETS(0,FD),1) IF (FCSET(FD) .EQ. CSTXP) THEN CALL READC(FETS(0,FD),WSA,WSAL,STATUS) GETREC = FINDEOL(WSA,WSAL,.TRUE.) ELSE CALL READC(FETS(0,FD),SWSA,WSAL,STATUS) IF(STATUS .GE. 0) THEN CALL SX12A8(SWSA,WSA,WSAL,STATUS) GETREC = FINDEOL(WSA,WSAL,.TRUE.) ELSE WSA(1) = NEL GETREC = 1 ENDIF ENDIF ELSE * PROCESS DISK FILES. IF(FCSET(FD) .EQ. CSBIN) THEN CALL READW(FETS(0,FD),WSA,WSAL,STATUS) ELSE IF (FCSET(FD) .EQ. CS812) THEN CALL READC(FETS(0,FD),WSA,WSAL,STATUS) ELSE CALL READC(FETS(0,FD),SWSA,MAXWD,STATUS) IF(STATUS .GE. 0) THEN IF(FCSET(FD) .EQ. CSDSP) THEN CALL DPCA8(SWSA,WSA,WSAL,STATUS) ELSE CALL SX12A8(SWSA,WSA,WSAL,STATUS) ENDIF ENDIF ENDIF IF (FCSET(FD) .EQ. CSBIN) THEN IF (STATUS .EQ. 0) THEN NWDS = WSAL ELSE IF (STATUS .GT. 0) THEN NWDS = STATUS-LOCF(WSA) CALL READ(FETS(0,FD),1) ELSE IF (STATUS .EQ. -1) THEN NWDS = 0 CALL READ(FETS(0,FD),1) ELSE NWDS = 0 EOFFLAG = .TRUE. ENDIF ELSE IF (STATUS .EQ. 0) THEN NWDS = FINDEOL(WSA,WSAL,.TRUE.) ELSE IF (STATUS .GT. 0) THEN NWDS = STATUS-LOCF(WSA) IF (NWDS .GT. 0) THEN NWDS = FINDEOL(WSA,NWDS,.TRUE.) ENDIF CALL READ(FETS(0,FD),1) IF (AND(FETS(0,FD),O"7770") .EQ. O"0030") THEN NWDS = NWDS+1 WSA(NWDS) = EOFLINE CALL READ(FETS(0,FD),1) ELSE IF (AND(FETS(0,FD),O"7770") .EQ. O"1030") THEN EOFFLAG = .TRUE. ELSE NWDS = NWDS+1 WSA(NWDS) = EORLINE ENDIF ELSE IF (STATUS .EQ. -1) THEN CALL READ(FETS(0,FD),1) NWDS = 1 WSA(NWDS) = EOFLINE ELSE NWDS = 0 EOFFLAG = .TRUE. ENDIF ENDIF GETREC = NWDS ENDIF RETURN END INTEGER FUNCTION GETWORD(FD,STR,MAXLEN) *** GETWORD - GET A WORD FROM AN INPUT STREAM. * * GETWORD CONSIDERS A WORD TO BE DELIMITED BY BLANKS. * IT WILL RETURN THE LENGTH OF THE WORD AS ITS VALUE. * NOTE THAT THE STRING IS TERMINATED BY A ZERO WORD AT LEN+1. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER INTEGER STR(*) LEN = 0 * SKIP LEADING WHITE SPACES 10 IF (GETC(FD,CH) .EQ. EOF) THEN GETWORD = EOF RETURN ELSE IF (CH .EQ. NEL) THEN GETWORD = 0 RETURN ELSE IF (CH .EQ. BLANK .OR. CH .EQ. TAB) THEN GO TO 10 ENDIF * ACCUMULATE CHARACTERS 20 IF (LEN .LT. MAXLEN) THEN LEN = LEN + 1 STR(LEN) = CH ENDIF CH = GETC(FD,CH) IF (CH .NE. EOF .AND. CH .NE. BLANK .AND. CH .NE. TAB .AND. + CH .NE. NEL) GO TO 20 * SAVE EOLS FOR NEXT GETWORD OR CONFIRM IF (CH .EQ. NEL) CALL UNGETC(FD,CH) STR(LEN+1) = 0 GETWORD = LEN RETURN END INTEGER FUNCTION GTTY(MODE) *** GTTY - GET A TTY MODE. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CHARACTER*(*) MODE IF (MODE .EQ. 'DUPLEX') THEN GTTY = DUPLEX ELSE CALL DISPLA(' GTTY - INVALID MODE ',BOOL(MODE)) CALL ABORT ENDIF RETURN END INTEGER FUNCTION ITOS(INT,STR,MINWID) *** ITOS - CONVERT AN INTEGER TO STRING FORMAT. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER INTEGER STR(*) WIDTH = 0 IF (INT .LT. 0) THEN WIDTH = 1 STR(WIDTH) = ASC('-') ENDIF VAL = IABS(INT) ASCII0 = ASC('0') 10 WIDTH = WIDTH + 1 STR(WIDTH) = MOD(VAL,10) + ASCII0 VAL = VAL / 10 IF (VAL .NE. 0) GO TO 10 STR(WIDTH+1) = 0 * NOW REVERSE THE DIGITS IPTR = 1 ENDPTR = WIDTH IF (STR(IPTR) .EQ. ASC('-')) IPTR = IPTR + 1 20 IF (IPTR .LT. ENDPTR) THEN TCH = STR(IPTR) STR(IPTR) = STR(ENDPTR) STR(ENDPTR) = TCH IPTR = IPTR + 1 ENDPTR = ENDPTR - 1 GO TO 20 ENDIF ITOS = WIDTH RETURN END SUBROUTINE LOGOUT *** LOGOUT - LOG OUT THE TERMINAL. * * ENTRY NONE. * * EXIT CONTROL BYTE SENT. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER IF (INITDUP .EQ. FULLDUP) THEN CALL STTY('RCV-OFF',FULLDUP) ELSE CALL STTY('RCV-OFF',HALFDUP) ENDIF FCHBUF(1,STDOUT) = O"0004 0000 0000 0000 0000" FNWDS(STDOUT) = 1 CALL FFLUSH(STDOUT) RETURN END IDENT MAKEFET ENTRY MAKEFET SST SYSCOM B1 MAKEFET TITLE MAKEFET - MAKE A FILE ENVIRONMENT TABLE. COMMENT MAKE A FILE ENVIRONMENT TABLE. MAKEFET SPACE 4,10 ** MAKEFET - MAKE A FILE ENVIRONMENT TABLE. * * CALL MAKEFET(LFN,FET,FETL,CIOBUF,CIOBUFL) * * ENTRY (LFN) = IS THE CHARACTER*7 FILE NAME. * (FET) = AN ARRAY TO RECEIVE THE FET. * (FETL) = LENGTH OF FET IN WORDS (MINIMUM OF 5). * (CIOBUF) = AN ARRAY TO BE USED AS THE CIO BUFFER. * (CIOBUFL) = THE LENGTH OF CIOBUF. * * EXIT FET BUILT. MAKEFET SUBR ENTRY/EXIT SB1 1 SA2 A1+B1 SB6 X2 (B6) = FET ADDRESS SA2 A2+B1 SA3 X2 (X3) = FET LENGTH SA2 A2+B1 SX6 X2 (X6) = FWA OF CIO BUFFER SA2 A2+B1 SA2 X2 (X2) = BUFFER LENGTH IX7 X6+X2 (X7) = LIMIT POINTER SA6 B6+2 SET IN AND OUT SA6 A6+B1 SA7 A6+B1 SET LIMIT SX7 X3-5 (X7) = FET LENGTH - 5 SB7 X7 LX7 18 BX6 X6+X7 ADD (FET LENGTH - 5) TO FIRST SA6 B6+B1 SET FIRST MX7 0 MAKEFET1 GT B7,B0,MAKEFET2 IF NO MORE WORDS TO SET SA7 A7+B1 SB7 B7-B1 EQ MAKEFET1 LOOP TILL DONE MAKEFET2 SB7 B1 LENGTH OF TRANSFER RJ =XMFS> MOVE LFN INTO FET SA1 B6-B1 RJ =XBTZ> CONVERT BLANKS TO 00B SX1 B1 ADD COMPLETE BIT TO LFN BX6 X6+X1 SA6 A1 EQ MAKEFETX RETURN END INTEGER FUNCTION MATCH(TABLE,TABLEN,NELOK) *** MATCH - MATCH INPUT WITH A TABLE OF POSSIBILITIES. * * TABLE SHOULD BE AN ARRAY OF CHARACTER STRINGS DEFINING WHAT * IS REASONABLE INPUT. MATCH WILL READ INPUT AND RETURN THE * INDEX OF THE TABLE ENTRY THAT MATCHES OR "ERROR" IF A PROPER * MATCH COULDN'T BE MADE. MATCHS WILL FAIL IF THE INPUT MATCH * IS AMBIGUOUS OR DOESN'T MATCH AT ALL. A QUESTION MARK IN THE * INPUT WILL OUTPUT THE POSSIBLE MATCHES ACCORDING TO THE INPUT * PREVIOUSLY READ AND THEN RETURN AS IF NO MATCH WAS MADE. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CHARACTER*(*) TABLE(TABLEN) LOGICAL NELOK CHARACTER*40 WORD INTEGER ASTR(41) * GET THE WORD TO MATCH LEN = GETWORD(CMDFD,ASTR,40) IF (LEN .EQ. 0) THEN MATCH = LEN IF (.NOT. NELOK) THEN MATCH = ERROR CALL FPRINTF(STDOUT,'?^NULL SWITCH OR KEYWORD GIVEN\N') ENDIF RETURN ELSE IF (LEN .EQ. EOF) THEN MATCH = EOF RETURN ENDIF CALL AS2DPC(ASTR,WORD) IF(WORD(1:3) .EQ. '#EO') THEN MATCH = EOF RETURN ENDIF * BEGIN THE MATCHING HERE; TABLES MUST BE IN ALPHABETICAL ORDER T1 = 1 T2 = TABLEN CHP = 1 10 IF (CHP .LE. LEN) THEN * IF WE FIND A "?", THEN GIVE THE POSSIBILITIES IF (WORD(CHP:CHP) .EQ. '?') THEN CALL FPRINTF(STDOUT,'^ONE OF THE FOLLOWING:\N') CALL OUTTBL(TABLE,T1,T2) MATCH = ERROR RETURN ENDIF * WHILE WORD IS LESS THAN LOWER TABLE ENTRY 20 IF (T1 .LE. T2) THEN IF (WORD(CHP:CHP) .GT. TABLE(T1)(CHP:CHP)) THEN T1 = T1+1 GOTO 20 ENDIF ENDIF * WHILE WORD IS GREATER THAN UPPER TABLE ENTRY 30 IF (T2 .GE. T1) THEN IF (WORD(CHP:CHP) .LT. TABLE(T2)(CHP:CHP)) THEN T2 = T2-1 GOTO 30 ENDIF ENDIF * IF WE KNOW WE HAVE A MISMATCH IF (T2 .LT. T1) THEN CALL FPRINTF(STDOUT,'?^DOES NOT MATCH KEYWORD - "') CALL PUTSTR(STDOUT,ASTR) CALL FPRINTF(STDOUT,'"\N') MATCH = ERROR RETURN ENDIF CHP = CHP+1 GOTO 10 ENDIF * AFTER LOOKING AT THE WHOLE WORD, IS IT STILL AMBIGUOUS? IF (T1 .NE. T2) THEN CALL FPRINTF(STDOUT,'?^AMBIGUOUS - "') CALL PUTSTR(STDOUT,ASTR) CALL FPRINTF(STDOUT,'"\N') MATCH = ERROR ELSE MATCH = T1 ENDIF RETURN END SUBROUTINE MOVETOC(I, J) * * SUBROUTINE MOVETOC - MOVE BOOLEAN WORD TO CHARACTER VARIABLE. * THIS ROUTINE MUST BE USED ONLY FOR A *10 WORD-ALIGNED CHARACTER * VARIABLE; ELSE, ALL HADES MAY BREAK LOOSE. * J = I RETURN END IDENT NEXTFN *** NEXTFN - RETURN THE NEXT FILE NAME * * THIS ROUTINE CONSISTS OF 2 SUBROUTINES, ONE TO RETURN LOCAL * FILE NAMES AND ONE FOR PERMANENT FILE NAMES. * NXTBUFL = 400B BUFFER LENGTH NXTBUF BSS NXTBUFL SHARED BUFFER NEXTPF SPACE 4,8 *** NEXTPF - RETURN THE NEXT PERM FILE NAME * * INTEGER FUNCTION NEXTPF RETURNS THE NEXT PERM FILE NAME FROM * THE USER'S CATALOG. * * PFN = NEXTPF(IFLAG) * * ENTRY IFLAG = 0 TO RESET POINTERS, DON'T RETURN PF. * .NE. 0 TO RETURN NEXT PF. * EXIT PFN = NEXT PERM FILE NAME (L FORMAT), OR 0 IF NO * MORE PERM FILES. UNDEFINED IF IFLAG=0. * PFET FILEB NXTBUF,NXTBUFL,FET=10 NWCE = 16 NUMBER OF WORDS IN CATALOG ENTRY PWSA BSS NWCE ENTRY NEXTPF NEXTPF EQ *+40000B SB1 1 SA2 X1 X2 = IFLAG NZ,X2 PFN1 CONTINUATION CALL MX6 0 SA6 PFET+6 CLEAR CONTINUATION DATA SX6 NXTBUF RESET BUFFER POINTERS SA6 PFET+2 IN SA6 A6+B1 OUT CATLIST PFET START CATLIST EQ NEXTPF PFN1 READW PFET,PWSA,NWCE READ CATALOG ENTRY NG,X1 PFN2 BUFFER EMPTY SA1 PWSA MX0 42 BX1 X0*X1 RETURN PFN RJ =XZTB= CONVERT 00 TO BLANKS EQ NEXTPF PFN2 SX1 X1+B1 NG,X1 PFN3 EOI - COMPLETE SX6 NXTBUF RESET BUFFER POINTERS SA6 PFET+2 IN SA6 A6+B1 OUT CATLIST PFET FILL UP BUFFER AGAIN EQ PFN1 CONTINUE PFN3 MX6 0 RETURN COMPLETE EQ NEXTPF NEXTLF SPACE 4,8 *** NEXTLF - RETURN THE NEXT LOCAL FILE NAME * * INTEGER FUNCTION NEXTLF RETURNS THE NEXT LOCAL FILE NAME FROM * THE USER'S JOB. * * LFN = NEXTLF(IFLAG) * * ENTRY IFLAG = 0 TO RESET POINTERS, DON'T RETURN LF. * .NE. 0 TO RETURN NEXT LF. * EXIT LFN = NEXT LOCAL FILE NAME (L FORMAT), OR 0 IF NO * MORE LOCAL FILES. UNDEFINED IF IFLAG=0. * LFET FILEB NXTBUF,NXTBUFL,FET=13 NLFE = 2 NUMBER OF WORDS IN FILE ENTRY LFPW VFD 12/NXTBUFL/2-2,24/0,6/10B,18/NXTBUF LPTR BSS 1 ENTRY NEXTLF NEXTLF EQ *+40000B SB1 1 SA2 X1 X2 = IFLAG NZ,X2 LFN1 CONTINUATION CALL MX6 0 SA6 NXTBUF CLEAR CONTINUATION ADDRESS SX6 NXTBUF+1 FIRST ENTRY POINTER SA6 LPTR POINTER TO NEXT ENTRY SA1 LFPW POINTER WORD FOR GETFNT BX6 X1 SA6 LFET+10B GETFNT LFET GET FIRST BUFFER LOAD EQ NEXTLF LFN1 SA1 LPTR POINTER TO NEXT ENTRY SX6 X1+NLFE INCREMENT POINTER SA6 A1 SA1 X1 ENTRY WORD ZR,X1 LFN2 BUFFER EMPTY MX0 2 CHECK FILE RESIDENCE LX0 14-59 BX2 X0*X1 NZ,X2 LFN1 NOT MASS STORAGE. GET NEXT FILE. MX0 42 BX1 X0*X1 RETURN LFN RJ =XZTB= CONVERT 00 TO BLANKS EQ NEXTLF LFN2 SA1 NXTBUF IF TABLE HEADER NON-ZERO, MORE TO DO. ZR,X1 LFN3 COMPLETE SX6 NXTBUF+1 FIRST ENTRY POINTER SA6 LPTR POINTER TO NEXT ENTRY GETFNT LFET FILL UP BUFFER AGAIN EQ LFN1 CONTINUE LFN3 MX6 0 RETURN COMPLETE EQ NEXTLF END SUBROUTINE OUTTBL(TABLE,START,FIN) *** OUTTBL - OUTPUT A STRING ARRAY IN TABULAR FORMAT. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CHARACTER*(*) TABLE(FIN) INTEGER START, FIN CHARACTER*80 LINE INTEGER ASTR(81) INTEGER COLWID, NCOLS COLWID = LEN(TABLE(1)) + 2 NCOLS = 80 / COLWID LINE = ' ' ICOL = 1 DO 100 I = START,FIN IPOS = (ICOL-1)*COLWID + 1 LINE(IPOS:) = TABLE(I) ICOL = ICOL + 1 IF (ICOL .GT. NCOLS .OR. I .EQ. FIN) THEN CALL DPC2AS(LINE,ASTR,LEN(LINE)) * DELETE TRAILING BLANKS J = LEN(LINE) 10 IF (LINE(J:J) .EQ. ' ') THEN ASTR(J) = 0 J = J - 1 GO TO 10 ENDIF CALL PUTSTR(STDOUT,ASTR) CALL PUTC(NEL,STDOUT) LINE = ' ' ICOL = 1 ENDIF 100 CONTINUE RETURN END SUBROUTINE PUTC(TCH,FD) *** PUTC - PUT A CHARACTER INTO AN OUTPUT STREAM * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER * IS THE FD VALID? IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN CALL DISPLA(' PUTC - INVALID FILE DESCRIPTOR',FD) CALL ABORT ELSE IF (FMODE(FD) .EQ. CLOSED) THEN CALL DISPLA(' PUTC - FILE DESCRIPTOR NOT OPEN',FD) CALL ABORT ENDIF * IS IT OK TO WRITE ON THIS STREAM? IF ((FMODE(FD).AND.WR) .NE. WR) THEN CALL DISPLA(' PUTC - WRITE ON READ-ONLY FILE ',FD) CALL ABORT ENDIF * TRANSLATE EOLS AND NULLS AND SET THE HIGH BIT FOR CONNECTED FILES CH = TCH 10 IF (FCSET(FD) .EQ. CSTXP) THEN IF (CH .EQ. NEL) THEN CH = CR+O"4000" ELSE CH = XOR(CH,O"4000") ENDIF ELSE IF (FCSET(FD) .NE. CSBIN) THEN IF (CH .EQ. NEL) THEN CH = 0 ELSE IF (CH .EQ. 0) THEN CH = NULL ELSE CH = AND(CH,Z"7F") ENDIF ENDIF * PACK THE CHARACTER INTO THE OUTPUT BUFFER - FLUSH IF FULL IF (FCSET(FD) .EQ. CSBIN) THEN IF (FWSHFT(FD) .EQ. 0) THEN IF (FNWDS(FD) .EQ. MAXWD) CALL FFLUSH(FD) FWSHFT(FD) = 52 FNWDS(FD) = FNWDS(FD)+1 FCHBUF(FNWDS(FD),FD) = SHIFT(CH,52) ELSE IF (FWSHFT(FD) .EQ. 4) THEN FWSHFT(FD) = 56 FCHBUF(FNWDS(FD),FD) = OR(FCHBUF(FNWDS(FD),FD),SHIFT(CH,-4)) FNWDS(FD) = FNWDS(FD)+1 FCHBUF(FNWDS(FD),FD) = SHIFT(AND(CH,Z"0F"),56) ELSE FWSHFT(FD) = FWSHFT(FD)-8 FCHBUF(FNWDS(FD),FD) = OR(FCHBUF(FNWDS(FD),FD), - SHIFT(CH,FWSHFT(FD)) ) ENDIF ELSE IF (FCSET(FD) .EQ. CSTXP) THEN IF (FWSHFT(FD) .EQ. 0) THEN IF (FNWDS(FD) .EQ. MAXWD) CALL FFLUSH(FD) FNWDS(FD) = FNWDS(FD)+1 IF (FNWDS(FD) .EQ. 1) THEN IF (FCSET(STDIN) .EQ. CSTXP) THEN FCHBUF(FNWDS(FD),FD) = O"0016 4064 4001 0000 0000" FNWDS(FD) = FNWDS(FD)+1 ENDIF FWSHFT(FD) = 36 FCHBUF(FNWDS(FD),FD) = O"0007 0000 0000 0000 0000" ELSE FWSHFT(FD) = 48 FCHBUF(FNWDS(FD),FD) = O"0000 0000 0000 0000 0000" ENDIF ELSE FWSHFT(FD) = FWSHFT(FD)-12 ENDIF FCHBUF(FNWDS(FD),FD) = OR(FCHBUF(FNWDS(FD),FD), - SHIFT(CH,FWSHFT(FD)) ) ELSE IF (FWSHFT(FD) .EQ. 0) THEN IF (FNWDS(FD) .EQ. MAXWD) CALL FFLUSH(FD) FNWDS(FD) = FNWDS(FD)+1 FCHBUF(FNWDS(FD),FD) = O"0000 0000 0000 0000 0000" FWSHFT(FD) = 48 ELSE FWSHFT(FD) = FWSHFT(FD)-12 ENDIF FCHBUF(FNWDS(FD),FD) = OR(FCHBUF(FNWDS(FD),FD), - SHIFT(CH,FWSHFT(FD)) ) ENDIF * FOR CONNECTED FILES ADD A LF AFTER A CR * FOR ALL FILES FLUSH THE BUFFER ON A NEL IF (TCH .EQ. NEL) THEN IF (CH .EQ. CR+O"4000") THEN CH = LF GO TO 10 ENDIF CALL FFLUSH(FD) ENDIF RETURN END SUBROUTINE PUTDAY(FD,MM,DD,YY) *** OUTPUT DAY OF WEEK. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER IZLR(IYR,M,IDY)=MOD((13*(M+10-(M+10)/13*12)-1)/5+IDY+77 1 +5*(IYR+(M-14)/12-(IYR+(M-14)/12)/100*100)/4 2 +(IYR+(M-14)/12)/400-(IYR+(M-14)/12)/100*2,7)+1 WKDAY = IZLR(YY,MM,DD) IF (WKDAY .EQ. 1) THEN CALL FPRINTF(FD,'^SUNDAY') ELSE IF (WKDAY .EQ. 2) THEN CALL FPRINTF(FD,'^MONDAY') ELSE IF (WKDAY .EQ. 3) THEN CALL FPRINTF(FD,'^TUESDAY') ELSE IF (WKDAY .EQ. 4) THEN CALL FPRINTF(FD,'^WEDNESDAY') ELSE IF (WKDAY .EQ. 5) THEN CALL FPRINTF(FD,'^THURSDAY') ELSE IF (WKDAY .EQ. 6) THEN CALL FPRINTF(FD,'^FRIDAY') ELSE CALL FPRINTF(FD,'^SATURDAY') ENDIF RETURN END SUBROUTINE PUTINT(FD,INT,MINWID) *** PUTINT - OUTPUT AN INTEGER. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER INTEGER STRING(21) WIDTH = 0 IF (INT .LT. 0) THEN CALL PUTC(ASC('-'),FD) WIDTH = 1 ENDIF VAL = IABS(INT) ASCII0 = ASC('0') NCH = 0 10 NCH = NCH + 1 STRING(NCH) = MOD(VAL,10) + ASCII0 VAL = VAL / 10 IF (VAL .NE. 0 .AND. NCH .LT. 20) GO TO 10 WIDTH = WIDTH + NCH * NOW OUTPUT THE DIGITS 20 CALL PUTC(STRING(NCH),FD) NCH = NCH - 1 IF (NCH .GT. 0) GO TO 20 30 IF (WIDTH .LT. MINWID) THEN CALL PUTC(BLANK,FD) WIDTH = WIDTH + 1 GO TO 30 ENDIF RETURN END SUBROUTINE PUTMNTH(FD,MM) *** PUTMNTH - OUTPUT THE MONTH NAME. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER IF (MM .EQ. 1) THEN CALL FPRINTF(FD,'^JANUARY',0) ELSE IF (MM .EQ. 2) THEN CALL FPRINTF(FD,'^FEBRUARY',0) ELSE IF (MM .EQ. 3) THEN CALL FPRINTF(FD,'^MARCH',0) ELSE IF (MM .EQ. 4) THEN CALL FPRINTF(FD,'^APRIL',0) ELSE IF (MM .EQ. 5) THEN CALL FPRINTF(FD,'^MAY',0) ELSE IF (MM .EQ. 6) THEN CALL FPRINTF(FD,'^JUNE',0) ELSE IF (MM .EQ. 7) THEN CALL FPRINTF(FD,'^JULY',0) ELSE IF (MM .EQ. 8) THEN CALL FPRINTF(FD,'^AUGUST',0) ELSE IF (MM .EQ. 9) THEN CALL FPRINTF(FD,'^SEPTEMBER',0) ELSE IF (MM .EQ. 10) THEN CALL FPRINTF(FD,'^OCTOBER',0) ELSE IF (MM .EQ. 11) THEN CALL FPRINTF(FD,'^NOVEMBER',0) ELSE IF (MM .EQ. 12) THEN CALL FPRINTF(FD,'^DECEMBER',0) ELSE CALL FPRINTF(FD,'PUTMNTH - NO SUCH MONTH AS @D\N',MM) ENDIF RETURN END SUBROUTINE PUTSTR(FD,STR) *** PUTSTR - OUTPUT A STRING TO AN OUTPUT STREAM. * * PUTSTR WILL ADD CHARACTERS FROM THE NULL TERMINATED CHARACTER * BUFFER STR TO THE SPECIFIED OUTPUT STREAM. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER INTEGER STR(*) * IS THE FD VALID? IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN CALL DISPLA(' PUTC - INVALID FD ',FD) CALL ABORT ELSE IF (FMODE(FD) .EQ. 0) THEN CALL DISPLA(' PUTC - FD NOT OPEN.',FD) RETURN ENDIF * IS IT OK TO WRITE ON THIS STREAM? IF ((FMODE(FD).AND.WR) .NE. WR) THEN CALL DISPLA(' PUTC - WRITE ON READ-ONLY FILE ',FD) CALL ABORT ENDIF * PUT CHARS IN THE OUTPUT BUFFER I = 1 10 IF (STR(I) .NE. 0) THEN CALL PUTC(STR(I),FD) I = I+1 GOTO 10 ENDIF RETURN END INTEGER FUNCTION RDATA() *** RDATA - READ A DATA PACKET. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER * CHECK RETRY COUNT IF (NUMTRY .GT. MAXRTRY) THEN RDATA = A ABORTYP = TOOMANY.OR.READING.OR.DATAERR RETURN ENDIF NUMTRY = NUMTRY + 1 * READ A PACKET PTYP = RDPACK(LEN,NUM,PACKET) * D A T A IF (PTYP .EQ. D) THEN IF (NUM .NE. PACKNUM) THEN IF (MOD(NUM+1,64) .EQ. PACKNUM) THEN CALL SNDPACK(Y,NUM,0,0) RDATA = STATE ELSE RDATA = A ABORTYP = SEQERR.OR.READING.OR.DATAERR ENDIF ELSE CALL BUFEMP(PACKET,FFD,LEN) CALL SNDPACK(Y,PACKNUM,0,0) NUMTRY = 0 PACKNUM = MOD(PACKNUM+1,64) RDATA = STATE ENDIF * F I L E N A M E ELSE IF (PTYP .EQ. F) THEN IF (MOD(NUM+1,64) .EQ. PACKNUM) THEN CALL SNDPACK(Y,NUM,0,0) NUMTRY = 0 RDATA = STATE ELSE RDATA = A ABORTYP = SEQERR.OR.READING.OR.FILERR ENDIF * E O F ELSE IF (PTYP .EQ. Z) THEN IF (NUM .NE. PACKNUM) THEN RDATA = A ABORTYP = SEQERR.OR.READING.OR.EOFERR ELSE CALL SNDPACK(Y,PACKNUM,0,0) CALL FCLOSE(FFD) FFD = 0 IF(LEN.GT.0 .AND. PACKET(1).EQ.D) THEN * INTERRUPTED FILE TRANSFER, UNLOAD INCOMPLETE FILE. CALL REMOVE(FILESTR) ABORTYP = INTRPT .OR. READING ENDIF PACKNUM = MOD(PACKNUM+1,64) RDATA = F ENDIF * E R R O R ELSE IF (PTYP .EQ. E) THEN RDATA = E CALL EXPSTR(PACKET, LEN, MICMSG(16)) ABORTYP = READING .OR. MICERR RETURN * B A D C H E C K S U M ELSE IF (PTYP .EQ. ERROR) THEN RDATA = STATE CALL SNDPACK(N,PACKNUM,0,0) * B A D T Y P E ELSE RDATA = A ABORTYP = INVALID.OR.READING.OR.DATAERR ENDIF RETURN END INTEGER FUNCTION RDPACK(LEN,NUM,DATA) *** RDPACK - READ A PACKET OF INFORMATION. * * RDPACK WILL READ A PACKET OF DATA AND RETURN THE PACKET TYPE * AS A RESULT. IF THE PACKET CONTAINS AN ERROR (CHECKSUM) THEN * ERROR WILL BE RETURNED. LEN, NUM, AND DATA WILL BE SET ACCORDING * TO THE FIELDS OF THE PACKET. * * IT MAY WELL BE THAT CHARACTERS ARE LOST IN TRANSMISSION, MAKING * A PACKET SHORTER THAN EXPECTED. THIS SHOULD CAUSE A REQUEST FOR * RETRANSMISSION (NAK). RDPACK LOOKS FOR AN NEL RETURNED BY * GETC TO TELL IT WHERE THE END OF THE DATA IS. * * IF THE USER ENTERS A CTRL/C OR CTRL/T AS THE FIRST CHARACTER OF * A LINE, RETURN AN ABORT. THIS ALLOWS THE PROTOCOL TO BE ABORTED * IF NECESSARY. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER INTEGER DATA(*) LOGICAL TYPE0 LOGICAL WAITINP *CALL COMXKER * LOG INCOMING PACKETS IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN CALL FPRINTF(DEBUGFD,'^R^E^A^D^I^N^G:\N',0) ENDIF NCH = 0 * HUNT FOR THE START OF THE PACKET 10 CONTINUE * WAIT 'STIMOUT' SECONDS TO RECEIVE PACKET IF 'WAITPAK' IS TRUE. IF(WAITPAK .AND. .NOT.WAITINP(STIMOUT)) THEN RDPACK = ERROR CALL FFLUSH(STDIN) RETURN ENDIF CH = GETC(STDIN, CH) IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN CALL PUTC(CH,DEBUGFD) ENDIF IF(CH .NE. SSYNC) THEN IF(CH .EQ. NEL) THEN IF (DEBUG .NE. 0) THEN CALL FPRINTF(DEBUGFD,'\N<^N^U^L^L ^P^A^C^K^E^T>\N',0) ENDIF CALL FFLUSH(STDIN) RDPACK = ERROR RETURN ELSE IF(CH.EQ.DC4 .OR. CH.EQ.ETX) THEN CALL FFLUSH(STDIN) RDPACK = A RETURN ENDIF NCH = NCH+1 GOTO 10 ENDIF CHKSUM = LEN = 0 * PARSE EACH FIELD OF THE PACKET * FIELD IS PACKET FIELD, 'LEN' TO 'CHECK'. * XFIELD IS EXT-LENGTH PACKET INTERNAL FIELD, 'LENX1' TO 'HCHECK'. FIELD = 1 XFIELD = 1 20 IF (FIELD .LE. 5) THEN * A CHARACTER READ IN FIELD 4 HERE IS THE FIRST CHAR OF THE * DATA FIELD OR THE CHECKSUM CHARACTER IF THE DATA FIELD IS EMPTY * * *LEN* IS THE >DATA< LENGTH IF (FIELD .LE. 4 .OR. LEN .GT. 0) THEN IF(GETC(STDIN,CH) .EQ. NEL) THEN IF (DEBUG .NE. 0) THEN CALL FPRINTF(DEBUGFD,'\N<^S^H^O^R^T ^P^A^C^K^E^T>\N',0) ENDIF CALL FFLUSH(STDIN) RDPACK = ERROR RETURN ENDIF IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN CALL PUTC(CH,DEBUGFD) ENDIF IF (CH .EQ. SSYNC) FIELD = 0 NCH = NCH+1 ENDIF IF (FIELD .LE. 3) CHKSUM = CHKSUM+CH * R E S Y N C ( 0 ) IF (FIELD .EQ. 0) THEN CHKSUM = 0 IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN CALL FPRINTF(DEBUGFD,'\N<^R^E^S^Y^N^C>\N',0) CALL FPRINTF(DEBUGFD,'^R^E^A^D^I^N^G:\N@C',SSYNC) ENDIF * L E N G T H ( 1 ) ELSE IF (FIELD .EQ. 1) THEN LEN = UNCHAR(CH-3) TYPE0 = (LEN .EQ. -3) * P A C K E T N U M B E R ( 2 ) ELSE IF (FIELD .EQ. 2) THEN NUM = UNCHAR(CH) * P A C K E T T Y P E ( 3 ) ELSE IF (FIELD .EQ. 3) THEN TYPE = CH * D A T A ( 4 ) ELSE IF (FIELD .EQ. 4 .AND. LEN .GT. 0) THEN CHKSUM = CHKSUM+CH DATA(1) = CH * READ 2ND-LEN CHARS OF DATA DO 100 I=2,LEN IF(GETC(STDIN,CH) .EQ. NEL) THEN IF (DEBUG .NE. 0) THEN CALL FPRINTF(DEBUGFD, + '\N<^S^H^O^R^T ^P^A^C^K^E^T>\N',0) ENDIF CALL FFLUSH(STDIN) RDPACK = ERROR RETURN ENDIF NCH = NCH+1 IF (CH .EQ. SSYNC) THEN FIELD = 0 GO TO 20 ENDIF IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN CALL PUTC(CH,DEBUGFD) ENDIF CHKSUM = CHKSUM+CH DATA(I) = CH 100 CONTINUE * LENX1, LENX2, HCHECK ELSE IF(FIELD.EQ.4 .AND. TYPE0 .AND. LEN.LT.0) THEN FIELD = 3 CHKSUM = CHKSUM + CH IF(XFIELD .EQ. 1) THEN EXLEN = UNCHAR(CH)*95 ELSE IF(XFIELD .EQ. 2) THEN EXLEN = EXLEN + UNCHAR(CH) ELSE IF(XFIELD .EQ. 3) THEN LEN = EXLEN - 1 HCH = CHKSUM - CH HCH = AND(HCH+(AND(HCH,O"300")/O"100"),O"77") IF(HCH .NE. UNCHAR(CH)) THEN FIELD = 6 CHKSUM = HCH IF(DEBUG.NE.0) CALL FPRINTF(DEBUGFD,'\NHEADER CHKSUM', + 0,0,0,0) ENDIF ENDIF XFIELD = XFIELD + 1 * C H E C K S U M ( 5 ) ELSE IF (FIELD .EQ. 5) THEN DATA(LEN+1) = 0 CHKSUM = AND(CHKSUM+(AND(CHKSUM,O"300")/O"100"),O"77") ENDIF * PROCESS NEXT PACKET FIELD FIELD = FIELD+1 GOTO 20 ENDIF * DOES THE CHECKSUM MATCH? IF (CHKSUM .NE. UNCHAR(CH)) THEN RDPACK = ERROR RCHOVRH = RCHOVRH+NCH IF (DEBUG .NE. 0) THEN CALL FPRINTF(DEBUGFD,'\NCKSUM ERROR, FOUND @D ',UNCHAR(CH)) CALL FPRINTF(DEBUGFD,'NEEDED @D\N',CHKSUM) ENDIF ELSE RDPACK = TYPE RCHOVRH = RCHOVRH+NCH-LEN IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN CALL PUTC(NEL,DEBUGFD) ENDIF ENDIF RCHCNT = RCHCNT+NCH * FLUSH ANY END-OF-LINE CHARACTERS AND OTHER GARBAGE CALL FFLUSH(STDIN) RETURN END SUBROUTINE RDPARAM(PDATA) *** RDPARAM - GET THE PACKET PARAMETERS FROM THE OTHER KERMIT. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER BOOLEAN PDATA(*) INTEGER DPARAMS(12), RPARAMS(12) EQUIVALENCE (RPARAMS,RPKSIZE) EQUIVALENCE (DPARAMS,DPKSIZE) *CALL COMXKER * INITIALIZE DEFAULT PACKET PARAMETERS. DO 10 I=1,12 RPARAMS(I) = DPARAMS(I) 10 CONTINUE * MOVE THE FIRST (UP TO 9) RECEIVED PARAMETERS TO RPARAMS BLOCK. * THEN COMPLETE SIZE NEGOTIATIONS AND CHECK CAPABILITIES. PDATAL = SLEN(PDATA) DO 20 I=1, MIN0(PDATAL, 9) * PAD CHARACTER IF (I .EQ. 4) THEN RPARAMS(I) = CTL(PDATA(I)) * CONTROL, EIGHT-BIT, OR REPEAT PREFIX CHARACTER ELSE IF (I.EQ.6 .OR. I.EQ.7 .OR. I.EQ.9) THEN IF ( (PDATA(I).GE.33 .AND. PDATA(I).LE.62) .OR. + (PDATA(I).GE.96 .AND. PDATA(I).LE.126) ) THEN RPARAMS(I) = PDATA(I) ENDIF * OTHER FIELDS - SET WITH *UNCHAR* UNLESS DEFAULTED ELSE IF (UNCHAR(PDATA(I)) .NE. 0) THEN RPARAMS(I) = UNCHAR(PDATA(I)) ENDIF 20 CONTINUE * DETERMINE SIZE OF PACKETS TO SEND. CHECK FOR LONG-PACKET * CAPABILITIES OF OTHER END. RPKSIZE = MIN0(DPKSIZE, RPKSIZE) IF(PDATAL.GE.10 .AND. (UNCHAR(PDATA(10)).AND.CAPAS5).NE.0) THEN I = 10 30 J = UNCHAR(PDATA(I)) IF((J .AND. CAPAS6) .NE. 0) GOTO 30 RMAXLX = 0 IF(PDATAL .GE. I+3) THEN RMAXLX = UNCHAR(PDATA(I+2))*95 + + UNCHAR(PDATA(I+3)) ENDIF IF(RMAXLX .EQ. 0) RMAXLX = 500 RPKSIZE = RMAXLX ENDIF RPKSIZE = MIN0(DPKSIZE, RPKSIZE) RETURN END INTEGER FUNCTION RECEIVE(ISTATE) *** RECEIVE - RECEIVE FILE STATE SWITCHING ROUTINE. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER * INITIALIZE STATISTICS VARIABLES ABORTYP = 0 SCHCNT = 0 RCHCNT = 0 SCHOVRH = 0 RCHOVRH = 0 * SET PACKET RETRY COUNT & CURRENT STATE NUMTRY = 0 STATE = ISTATE * TAKE APPROPRIATE ACTION FOR THE CURRENT STATE 10 IF ((DEBUG.AND.DBGSTAT).NE.0) THEN CALL FPRINTF(DEBUGFD,'\N^S^T^A^T^E=@C ^P^A^C^K^E^T=@2D\N', + STATE,PACKNUM) ENDIF IF (STATE .EQ. D) THEN STATE = RDATA() GOTO 10 ELSE IF (STATE .EQ. F) THEN STATE = RFILE() GOTO 10 ELSE IF (STATE .EQ. R) THEN STATE = RINIT() CALL GETNOW(MM,DD,YY,HR,MIN,SEC) STARTIM = HR * 3600 + MIN * 60 + SEC GOTO 10 ELSE IF (STATE .EQ. C) THEN CALL GETNOW(MM,DD,YY,HR,MIN,SEC) ENDTIM = HR * 3600 + MIN * 60 + SEC RECEIVE = OK ELSE IF (STATE .EQ. E) THEN IF (FFD .NE. CLOSED) THEN CALL FCLOSE(FFD) CALL REMOVE(FILESTR) ENDIF RECEIVE = ERROR ELSE IF (STATE .EQ. A) THEN CALL GETNOW(MM,DD,YY,HR,MIN,SEC) ENDTIM = HR * 3600 + MIN * 60 + SEC IF (FFD .NE. CLOSED) THEN CALL FCLOSE(FFD) CALL REMOVE(FILESTR) ENDIF CALL GETEMSG(ERRMSG(15)) CALL SNDPACK(E,PACKNUM,SLEN(ERRMSG),ERRMSG) RECEIVE = ERROR ELSE CALL DISPLA(' RECEIVE - STATE ERROR = ',STATE) IF (FFD .NE. CLOSED) CALL FCLOSE(FFD) RECEIVE = ERROR ENDIF RETURN END SUBROUTINE REMOVE(FN) *** REMOVE - REMOVE A FILE FROM THE LOCAL FILE LIST. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER BOOLEAN FN(*) CHARACTER*10 LFN * QUIT IF NOTHING USEFUL IN THE FILE NAME ARRAY. IF(FN(1) .EQ. 0) RETURN * CONVERT THE FILE NAME TO DISPLAY CODE. CALL AS2DPC(FN,LFN) * GET RID OF THE FILE. CALL RETFILE(LFN) RETURN END INTEGER FUNCTION RFILE() *** RFILE - READ A FILENAME PACKET. * * RFILE EXPECTS TO SEE A FILENAME (TYPE F) PACKET. HOWEVER, IT MAY * FIND A SEND-INIT RETRY, END-OF-FILE RETRY OR BREAK PACKET. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CHARACTER*20 FILENAM IF (NUMTRY .GT. MAXRTRY) THEN RFILE = A ABORTYP = TOOMANY.OR.READING.OR.FILERR RETURN ENDIF NUMTRY = NUMTRY + 1 * READ A PACKET PTYP = RDPACK(LEN,NUM,PACKET) * F I L E N A M E IF (PTYP .EQ. F) THEN IF (NUM .NE. PACKNUM) THEN RFILE = A ABORTYP = SEQERR.OR.READING.OR.FILERR RETURN ENDIF CALL EXPSTR(PACKET, LEN, FILESTR) CALL AS2DPC(FILESTR, FILENAM) CALL FILCHK(FILENAM) CALL DPC2AS(FILENAM, FILESTR, 7) IF (FILMODE .EQ. TEXT) THEN FFD = FOPEN(FILENAM, CREATE, TXTMODE) ELSE FFD = FOPEN(FILENAM, CREATE, CSBIN) ENDIF IF (FFD .EQ. ERROR) THEN FFD = CLOSED RFILE = A ABORTYP = LCLFILE.OR.READING.OR.FILERR ELSE IF (DEBUG .NE. 0) CALL FPRINTF(DEBUGFD, + '^R^E^C^E^I^V^I^N^G ^F^I^L^E: @S\N',FILESTR,0,0,0) * SEND FILE NAME USED BACK TO MICRO. CALL SNDPACK(Y, NUM, LEN, FILESTR) NUMTRY = 0 PACKNUM = MOD(PACKNUM+1,64) RFILE = D ENDIF * S E N D - I N I T ELSE IF (PTYP .EQ. S) THEN IF (MOD(NUM+1,64) .EQ. PACKNUM) THEN CALL SNDPAR(Y,PACKET,LEN) CALL SNDPACK(Y,NUM,LEN,PACKET) NUMTRY = 0 RFILE = STATE ELSE RFILE = A ABORTYP = SEQERR.OR.READING.OR.INITERR ENDIF * E O F ELSE IF (PTYP .EQ. Z) THEN IF (MOD(NUM+1,64) .EQ. PACKNUM) THEN CALL SNDPACK(Y,NUM,0,0) NUMTRY = 0 RFILE = STATE ELSE RFILE = A ABORTYP = SEQERR.OR.READING.OR.EOFERR ENDIF * B R E A K ELSE IF (PTYP .EQ. B) THEN IF (NUM .NE. PACKNUM) THEN RFILE = A ABORTYP = SEQERR.OR.READING.OR.BRKERR ELSE CALL SNDPACK(Y,PACKNUM,0,0) RFILE = C ENDIF * E R R O R ELSE IF (PTYP .EQ. E) THEN RFILE = E RETURN * B A D C H E C K S U M ELSE IF (PTYP .EQ. ERROR) THEN RFILE = STATE CALL SNDPACK(N,PACKNUM,0,0) * B A D T Y P E ELSE RFILE = A ABORTYP = INVALID.OR.READING.OR.FILERR ENDIF RETURN END INTEGER FUNCTION RINIT() *** RINIT - RECEIVE A SEND-INIT PACKET. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER * CLEAN OUT FILESTR ARRAY SO REMOVE DOES NOT DO DIRE THINGS * TO THE PREVIOUSLY RECEIVED FILE IF WE DIE BEFORE WE GET * THE NEW FILE SPECIFICATION. DO 10 I=1, IPKSIZE 10 FILESTR(I) = 0 * CHECK RETRY COUNT IF (NUMTRY .GT. MAXRINI) THEN RINIT = A ABORTYP = TOOMANY.OR.READING.OR.INITERR RETURN ENDIF NUMTRY = NUMTRY+1 * IF AN TRASH PACKET IS READ, THE SEQUENCE NUMBER IN THE PACKET * MAY BE INVALID, SO THAT WHEN A NAK IS SENT (BELOW), WE * USE PACKNUM AS THE NAK SEQUENCE NUMBER. SET PACKNUM * TO A VALID STARTING VALUE. PACKNUM = 0 * READ A PACKET (SHOULD BE INIT). ALLOW SWAPOUT WHILE WAITING. WAITPAK = .FALSE. PTYP = RDPACK(LEN, NUM, PACKET) WAITPAK = .TRUE. * S E N D - I N I T IF (PTYP .EQ. S) THEN PACKNUM = NUM CALL RDPARAM(PACKET) CALL SNDPAR(Y,PACKET,LEN) CALL SNDPACK(Y,NUM,LEN,PACKET) NUMTRY = 0 PACKNUM = MOD(PACKNUM+1,64) RINIT = F * B A D C H E C K S U M ELSE IF (PTYP .EQ. ERROR) THEN RINIT = STATE CALL SNDPACK(N,PACKNUM,0,0) * B A D T Y P E ELSE RINIT = A ABORTYP = INVALID.OR.READING.OR.INITERR ENDIF RETURN END INTEGER FUNCTION SBREAK() *** SBREAK - SEND THE BREAK PACKET AND WAIT FOR REPLY. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER * HAVE WE TRIED THIS TOO MANY TIMES? IF (NUMTRY .GT. MAXRTRY) THEN SBREAK = A ABORTYP = TOOMANY.OR.SENDING.OR.BRKERR RETURN ENDIF NUMTRY = NUMTRY + 1 * SEND THE BREAK PACKET CALL SNDPACK(B,PACKNUM,0,0) * READ THE REPLY PTYP = RDPACK(LEN,NUM,RECPACK) * N A K IF (PTYP .EQ. N) THEN IF (MOD(PACKNUM+1,64) .NE. NUM) THEN SBREAK = STATE RETURN ELSE PTYP = Y NUM = NUM-1 ENDIF ENDIF * A C K IF (PTYP .EQ. Y) THEN IF (PACKNUM .NE. NUM) THEN SBREAK = STATE RETURN ENDIF NUMTRY = 0 PACKNUM = MOD(PACKNUM+1,64) SBREAK = C * E R R O R ELSE IF (PTYP .EQ. E) THEN SBREAK = E RETURN * B A D C H E C K S U M ELSE IF (PTYP .EQ. ERROR) THEN SBREAK = STATE * B A D T Y P E ELSE SBREAK = A ABORTYP = INVALID.OR.SENDING.OR.BRKERR ENDIF RETURN END INTEGER FUNCTION SDATA() *** SDATA - SEND A DATA PACKET AND WAIT FOR REPLY. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CHARACTER LFN*10 * HAVE WE TRIED THIS TOO MANY TIMES? IF (NUMTRY .GT. MAXRTRY) THEN SDATA = A ABORTYP = TOOMANY.OR.SENDING.OR.DATAERR RETURN ENDIF NUMTRY = NUMTRY + 1 * SEND THE CURRENT DATA BUFFER IF (PSIZE .EQ. EOF) THEN SDATA = Z RETURN ENDIF CALL SNDPACK(D,PACKNUM,PSIZE,PACKET) * READ THE REPLY PTYP = RDPACK(LEN,NUM,RECPACK) * N A K IF (PTYP .EQ. N) THEN IF (MOD(PACKNUM+1,64) .NE. NUM) THEN SDATA = STATE RETURN ELSE PTYP = Y NUM = NUM-1 ENDIF ENDIF * A C K IF (PTYP .EQ. Y) THEN IF (PACKNUM .NE. NUM) THEN SDATA = STATE RETURN ENDIF NUMTRY = 0 PACKNUM = MOD(PACKNUM+1,64) PSIZE = BUFFILL(FFD,PACKET) IF (PSIZE .EQ. EOF) THEN SDATA = Z ELSE IF(LEN.GT.0 .AND. RECPACK(1).EQ.X) THEN * INTERRUPT FILE TRANSFER ABORTYP = INTRPT .OR. SENDING SDATA = Z ELSE IF(LEN.GT.0 .AND. RECPACK(1).EQ.Z) THEN * INTERRUPT GROUP TRANSFER * EAT UP REST OF FILE-SEND LIST ABORTYP = INTRPT .OR. SENDING SDATA = Z 10 IF(LOCFILE) THEN CALL GETLFN(LFN) ELSE CALL GETPFN(LFN) ENDIF IF(LFN .NE. ' ') GOTO 10 ELSE SDATA = STATE ENDIF * E R R O R ELSE IF (PTYP .EQ. E) THEN SDATA = E CALL EXPSTR(RECPACK, LEN, MICMSG(16)) ABORTYP = SENDING .OR. MICERR RETURN * B A D C H E C K S U M ELSE IF (PTYP .EQ. ERROR) THEN SDATA = STATE * B A D T Y P E ELSE SDATA = A ABORTYP = INVALID.OR.SENDING.OR.DATAERR ENDIF RETURN END INTEGER FUNCTION SEND(SENDTYP, STR) *** SEND - SEND FILE STATE SWITCHING ROUTINE * * THE FILENAME TO SEND IS ASSUMED TO HAVE ALREADY BEEN * OBTAINED AND SET IN ASCII STRING BUFFER FILESTR. * * ENTRY: SENDTYP - F OR X SEND TYPE FOR 'SFILE' * STR - CHARACTER MESSAGE STRING IF X TYPE SEND * * F TYPE SEND IS FOR NORMAL FILE TRANSFER. * X TYPE SEND ALLOWS TEXT TRANSFER TO THE REMOTE KERMIT WITH A * HEADER TEXT STRING. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CHARACTER STR*(*) * INITIALIZE STATICS VARIABLES ABORTYP = 0 SCHCNT = 0 RCHCNT = 0 SCHOVRH = 0 RCHOVRH = 0 STATE = S NUMTRY = 0 * TAKE APPROPRIATE ACTION FOR THE CURRENT STATE 10 IF ((DEBUG.AND.DBGSTAT).NE.0) THEN CALL FPRINTF(DEBUGFD,'\N^S^T^A^T^E=@C ^P^A^C^K^E^T=@2D\N', + STATE,PACKNUM) ENDIF IF (STATE .EQ. D) THEN STATE = SDATA() GOTO 10 ELSE IF (STATE .EQ. F) THEN STATE = SFILE(SENDTYP, STR) GOTO 10 ELSE IF (STATE .EQ. Z) THEN STATE = SEOF() GOTO 10 ELSE IF (STATE .EQ. S) THEN STATE = SINIT() CALL GETNOW(MM,DD,YY,HR,MIN,SEC) STARTIM = HR * 3600 + MIN * 60 + SEC GOTO 10 ELSE IF (STATE .EQ. B) THEN STATE = SBREAK() GOTO 10 ELSE IF (STATE .EQ. C) THEN CALL GETNOW(MM,DD,YY,HR,MIN,SEC) ENDTIM = HR * 3600 + MIN * 60 + SEC SEND = OK ELSE IF (STATE .EQ. E) THEN CALL GETNOW(MM,DD,YY,HR,MIN,SEC) ENDTIM = HR * 3600 + MIN * 60 + SEC SEND = ERROR IF (FFD .NE. CLOSED) CALL FCLOSE(FFD) ELSE IF (STATE .EQ. A) THEN CALL GETNOW(MM,DD,YY,HR,MIN,SEC) ENDTIM = HR * 3600 + MIN * 60 + SEC SEND = ERROR IF (FFD .NE. CLOSED) CALL FCLOSE(FFD) CALL GETEMSG(ERRMSG(15)) CALL SNDPACK(E,PACKNUM,SLEN(ERRMSG),ERRMSG) ELSE CALL DISPLA(' SEND - STATE ERROR = ',STATE) SEND = ERROR IF (FFD .NE. CLOSED) CALL FCLOSE(FFD) ENDIF RETURN END INTEGER FUNCTION SEOF() *** SEOF - SEND AN EOF PACKET AND WAIT FOR THE REPLY. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CHARACTER LFN*10 * HAVE WE TRIED THIS TOO MANY TIMES? IF (NUMTRY .GT. MAXRTRY) THEN SEOF = A ABORTYP = TOOMANY.OR.SENDING.OR.EOFERR RETURN ENDIF NUMTRY = NUMTRY + 1 * SEND THE EOF PACKET CALL SNDPACK(Z,PACKNUM,0,0) * READ THE REPLY PTYP = RDPACK(LEN,NUM,RECPACK) * N A K IF (PTYP .EQ. N) THEN IF (MOD(PACKNUM+1,64) .NE. NUM) THEN SEOF = STATE RETURN ELSE PTYP = Y NUM = NUM-1 ENDIF ENDIF * A C K IF (PTYP .EQ. Y) THEN IF (PACKNUM .NE. NUM) THEN SEOF = STATE RETURN ENDIF NUMTRY = 0 PACKNUM = MOD(PACKNUM+1,64) CALL FCLOSE(FFD) * GET NEXT FILE TO SEND, IF ANY. IF(LOCFILE) THEN CALL GETLFN(LFN) ELSE CALL REMOVE(FILESTR) CALL GETPFN(LFN) ENDIF IF(LFN .NE. ' ') THEN IF(.NOT.LOCFILE) CALL GETPFIL(LFN) CALL DPC2AS(LFN, FILESTR, INDEX(LFN,' ')-1) SEOF = F ELSE SEOF = B ENDIF * E R R O R ELSE IF (PTYP .EQ. E) THEN SEOF = E RETURN * B A D C H E C K S U M ELSE IF (PTYP .EQ. ERROR) THEN SEOF = STATE * B A D T Y P E ELSE SEOF = A ABORTYP = INVALID.OR.SENDING.OR.EOFERR ENDIF RETURN END IDENT SETF ENTRY SETF B1=1 TITLE SETF - SET SPECIAL HANDLING FOR TERMINAL OUTPUT FILE. COMMENT SETF - SET SPECIAL HANDLING FOR TERMINAL OUTPUT FILE. SPACE 4 *** SETF - SET SPECIAL HANDLING FOR TERMINAL OUTPUT FILE. * * FORTRAN CALL - * * CALL SETF(FET) * * ENTRY (FET) = FET OF TERMINAL OUTPUT FILE. * * EXIT NONE. SETF SUBR ENTRY/EXIT SA2 X1+B1 (X2) = FET+1 SX6 B1 LX6 36 BX6 X6+X2 SET FLUSH BIT SA6 A2 SA2 X1 (X2) = FET+0 MX6 42 BX6 X6*X2 (X6) = FILE NAME BX6 X6+X1 COMBINE WITH FET ADDRESS SA6 2 MX6 0 SA6 A6+B1 EQ SETFX RETURN END SUBROUTINE SETPACK(ATTR) *** SETPACK - SET PACKET SEND OR RECEIVE ATTRIBUTES. * * SETPACK WILL WET THE ATTRIBUTES OF THE PASSED ATTRIBUTE * LIST. THIS SUBROUTINE WILL SET THE APPROPRIATE PACKET * PARAMETER. THE PARAMETER TO SET IS PASSED IN AN ARRAY * AND IS VERY ORDER DEPENDENT. SEE COMMON BLOCK /PACKET/ * FOR THE ORDERING. NOTE THAT SEND AND RECEIVE PARAMETER * ORDERING AND STORAGE SIZE IN THE COMMON BLOCK ARE * IDENTICAL. KEEP IT THAT WAY! IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER INTEGER ATTR(12) PARAMETER (TSIZE=9) CHARACTER*15 ATTRTYP(TSIZE) DATA ATTRTYP / 'END-OF-LINE', 'PACKET-LENGTH', 'PAD-CHARACTER', + 'PAD-LENGTH', 'QUOTE-CHARACTER', 'Q8-CHARACTER', + 'REPEAT-PREFIX','SYNC-CHARACTER', 'TIME-OUT' / INDX = MATCH(ATTRTYP,TSIZE,.FALSE.) IF (INDX .LE. 0) RETURN GO TO (10, 20, 30, 40, 50, 55, 56, 60, 70), INDX * SET EOL CHARACTER 10 CALL SETVAL(ATTR(5),'I',1,31,127,127,HLPASCH,.TRUE.) RETURN * SET MAXIMUM PACKET LENGTH 20 CALL SETVAL(ATTR(1),'I',20,LPKSIZE,20,LPKSIZE,HLPPLEN,.TRUE.) RETURN * SET PAD CHARACTER 30 CALL SETVAL(ATTR(4),'I',0,31,127,127,HLPASCH,.TRUE.) RETURN * SET PAD LENGTH 40 CALL SETVAL(ATTR(3),'I',0,94,0,94,HLPPADL,.TRUE.) RETURN * SET CONTROL QUOTE CHARACTER 50 CALL SETVAL(ATTR(6),'I',33,62,96,126,HLPASCH,.TRUE.) RETURN * SET EIGHT BIT QUOTE CHARACTER 55 CALL SETVAL(ATTR(7),'I',33,62,96,126,HLPASCH,.TRUE.) RETURN * SET REPEAT PREFIX CHARACTER 56 CALL SETVAL(ATTR(9),'I',33,62,96,126,HLPASCH,.TRUE.) RETURN * SET SYNC CHARACTER 60 CALL SETVAL(ATTR(12),'I',0,127,0,127,HLPASCH,.TRUE.) RETURN * SET TIMEOUT VALUE 70 CALL SETVAL(ATTR(2),'I',0,94,0,94,HLPTIMO,.TRUE.) RETURN END SUBROUTINE SETVAL(VAR,VTYP,MN1,MX1,MN2,MX2,HLPMSG,CONFRM) *** SETVAL - SET A VARIABLE VALUE. * * SETVAL WILL READ A TOKEN FROM INPUT AND SET A VARIABLE TO * THAT VALUE. IF THE TOKEN IS A QUESTION MARK THEN THE * HELP MESSAGE WILL BE DISPLAYED AND SETVAL WILL RETURN * WITHOUT SETTING A VALUE. * * ENTRY: (VTYP) = CHARACTER 'S' FOR STRING VARIABLE. * = CHARACTER 'I' FOR INTEGER VARIABLE. * (MN1-MX1) = RANGE #1 FOR VAR TO FIT IN IF INTEGER. * = MN1 IS RETURN CODE FOR ERROR AND MX1 IS * MAX SIZE OF STRING IF STRING VAR. * (MN2-MX2) = SECONDARY RANGE FOR VAR TO FIT IN IF * INTEGER VAR. * = UNUSED FOR STRING VAR. * (HLPMSG) = FPRINTF MESSAGE FORMAT TO DISPLAY IF * A QUESTION MARK IS READ. * * EXIT: (VAR) = INT VALUE READ IF INTEGER VAR. OR STRING * VALUE READ IF STRING VAR. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CHARACTER*(*) VTYP, HLPMSG INTEGER VAR(41), STR(41) LOGICAL CONFRM, CONFIRM * CHECK VAR TYPE IF (VTYP .NE. 'S' .AND. VTYP .NE. 'I') THEN CALL DISPLA('SETVAL - INVALID VAR TYPE ',ASC(VTYP)) CALL ABORT ENDIF IF (VTYP .EQ. 'S' .AND. MX1 .GT. 40) THEN CALL DISPLA('SETVAL - STRING MAX IS TOO LARGE ',MX1) CALL ABORT ENDIF LEN = GETWORD(CMDFD,STR,MX1) IF (LEN .EQ. 0 .OR. LEN .EQ. EOF) THEN IF (VTYP .EQ. 'I') THEN CALL FPRINTF(STDOUT,'?^INVALID, ^FIRST NONSPACE CHARACTER IS - NOT A DIGIT\N',0,0) ELSE CALL FPRINTF(STDOUT,'?^INVALID, ^MISSING PARAMETER\N',0,0) MN1 = ERROR ENDIF RETURN ENDIF IF (STR(1) .EQ. QMARK) THEN CALL FPRINTF(STDOUT,HLPMSG,0,0) CALL FFLUSH(CMDFD) IF (VTYP .EQ. 'S') MN1 = ERROR RETURN ENDIF * CONFIRM THE REQUEST IF NECESSARY IF (CONFRM) THEN IF (.NOT. CONFIRM(CMDFD)) THEN IF (VTYP .EQ. 'S') MN1 = ERROR RETURN ENDIF ENDIF * GO AHEAD AND SET THE VARIABLE IF (VTYP .EQ. 'I') THEN I = CTOI(STR) IF (I .GE. MN1 .AND. I .LE. MX1) THEN VAR(1) = I ELSE IF (I .GE. MN2 .AND. I .LE. MX2) THEN VAR(2) = I ELSE CALL FPRINTF(STDOUT,'?^VALUE IS NOT WITHIN RANGE OF @D - @D' + ,MN1,MX1) IF (MN1 .NE. MN2 .OR. MX1 .NE. MX2) THEN CALL FPRINTF(STDOUT,' OR @D - @D',MN2,MX2) ENDIF CALL PUTC(NEL,STDOUT) ENDIF ELSE DO 100 I = 1,LEN VAR(I) = STR(I) 100 CONTINUE VAR(LEN+1) = 0 MN1 = OK ENDIF RETURN END INTEGER FUNCTION SFILE(SENDTYP, STR) *** SFILE - SEND A FILENAME PACKET AND WAIT FOR REPLY. * * THE FILENAME IS ASSUMED TO HAVE BEEN PREVIOUSLY OBTAINED * AND STORED IN THE ASCII STRING BUFFER FILESTR IN UPPER CASE. * * ENTRY: SENDTYP - F OR X SEND TYPE FOR 'SFILE' * STR - CHARACTER MESSAGE STRING IF X TYPE SEND * * F TYPE SEND IS FOR NORMAL FILE TRANSFER. * X TYPE SEND ALLOWS TEXT TRANSFER TO THE REMOTE KERMIT WITH A * HEADER TEXT STRING. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CHARACTER STR*(*) CHARACTER FILENAM*10 * HAVE WE TRIED THIS TOO MANY TIMES? IF (NUMTRY .GT. MAXRTRY) THEN SFILE = A ABORTYP = TOOMANY.OR.SENDING.OR.FILERR RETURN ENDIF NUMTRY = NUMTRY + 1 * SEND THE FILENAME PACKET * OPEN FILE ON FIRST TRY OF 'F' PACKET SEND. IF(NUMTRY .EQ. 1) THEN CALL AS2DPC(FILESTR,FILENAM) IF (FILMODE .EQ. TEXT) THEN FFD = FOPEN(FILENAM,RD,TXTMODE) ELSE FFD = FOPEN(FILENAM,RD,CSBIN) ENDIF IF (FFD .EQ. ERROR) THEN SINIT = A FFD = CLOSED RETURN ENDIF ENDIF IF(SENDTYP .EQ. F) THEN CALL SNDPACK(F,PACKNUM,SLEN(FILESTR),FILESTR) ELSE CALL DPC2AS(STR, RECPACK, LEN(STR)) CALL SNDPACK(X, PACKNUM, LEN(STR), RECPACK) ENDIF * READ THE REPLY PTYP = RDPACK(I, NUM, RECPACK) * N A K IF (PTYP .EQ. N) THEN IF (MOD(PACKNUM+1,64) .NE. NUM) THEN SFILE = STATE RETURN ELSE PTYP = Y NUM = NUM-1 ENDIF ENDIF * A C K IF (PTYP .EQ. Y) THEN IF (PACKNUM .NE. NUM) THEN SFILE = STATE RETURN ENDIF NUMTRY = 0 PACKNUM = MOD(PACKNUM+1,64) * GET FIRST PACKET OF DATA FROM THE FILE PSIZE = BUFFILL(FFD,PACKET) SFILE = D * E R R O R ELSE IF (PTYP .EQ. E) THEN SFILE = E RETURN * B A D C H E C K S U M ELSE IF (PTYP .EQ. ERROR) THEN SFILE = STATE * B A D T Y P E ELSE SFILE = A ABORTYP = INVALID.OR.SENDING.OR.FILERR ENDIF RETURN END INTEGER FUNCTION SINIT() *** SINIT - SEND THE SEND-INIT PACKET AND WAIT FOR REPLY. * * ASSUMES FILESTR HAS ALREADY BEEN CHECKED FOR LEGAL FILENAME * AND BEING LOCAL. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER * CHECK NUMBER OF RETRIES IF (NUMTRY .GT. MAXRINI) THEN SINIT = A ABORTYP = TOOMANY.OR.SENDING.OR.INITERR RETURN ELSE NUMTRY = NUMTRY + 1 ENDIF * SEND THE SEND-INIT PACKET CALL SNDPAR(S,PACKET,LEN) CALL SNDPACK(S,PACKNUM,LEN,PACKET) * READ AND PROCESS THE REPLY PTYP = RDPACK(LEN,NUM,RECPACK) * N A K IF (PTYP .EQ. N) THEN SINIT = STATE RETURN * A C K ELSE IF (PTYP .EQ. Y) THEN IF (PACKNUM .NE. NUM) THEN SINIT = STATE RETURN ENDIF CALL RDPARAM(RECPACK) * CONVERT Q8CH FOR EASIER USE LATER ON IN ENCODING FILE DATA. * ANY RESPONSE TO OUR "Y" THAT IS NOT A VALID EIGHT-BIT QUOTE * CHARACTER WILL CAUSE EIGHT-BIT QUOTING TO BE SUPPRESSED. IF ((R8QUOTE .LT. 33 .OR. R8QUOTE .GT. 126) .OR. - (R8QUOTE .GT. 62 .AND. R8QUOTE .LT. 96)) THEN Q8CH = 0 ELSE Q8CH = R8QUOTE ENDIF NUMTRY = 0 PACKNUM = MOD(PACKNUM+1,64) SINIT = F * E R R O R ELSE IF (PTYP .EQ. E) THEN SINIT = E RETURN * B A D C E C K S U M ELSE IF (PTYP .EQ. ERROR) THEN SINIT = STATE * B A D T Y P E ELSE SINIT = A ABORTYP = INVALID.OR.SENDING.OR.INITERR ENDIF RETURN END SUBROUTINE SLEEP(SECONDS) *** SLEEP - DELAY A NUMBER OF SECONDS * * ENTRY SECONDS = INTEGER NUMBER OF SECONDS TO SLEEP. * * EXIT INDICATED NUMBER OF SECONDS HAS ELAPSED. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CALL ROLLOUT(O"0200 00 0000"+SECONDS) RETURN END INTEGER FUNCTION SLEN(STR) *** SLEN - RETURN THE LENGTH OF A ZERO TERMINATED ASCII STRING BUFFER. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER BOOLEAN STR(*) I = 0 10 IF (STR(I+1) .NE. 0) THEN I = I+1 GOTO 10 ENDIF SLEN = I RETURN END SUBROUTINE SNDPACK(TYPE,NUM,LEN,DATA) *** SNDPACK - SEND A PACKET DOWN AN OUTPUT STREAM * * SNDPACK WILL SEND A PACKET OF INFORMATION AND LOG IT * IF DEBUG IS TURNED ON. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER INTEGER DATA(*) LOGICAL LONGPAK *CALL COMXKER * LOG THE PACKET IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN CALL FPRINTF(DEBUGFD,'^S^E^N^D^I^N^G:\N') ENDIF * PUT OUT PAD CHARS DO 100 I = 1,RPADCT CALL PUTC(RPADCH,STDOUT) IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN CALL PUTC(RPADCH,DEBUGFD) ENDIF 100 CONTINUE * PACKET LEN ASSUMES ONE CHARACTER CHECKSUMS CALL PUTC(RSYNC,STDOUT) * DETERMINE IF WE NEED EXTENDED PACKET. * OUTPUT PROPER LENGTH FIELD, 0 IF EXTENDED PACKET LONGPAK = ((RPKSIZE.GT.IPKSIZE) .AND. (LEN.GT.91)) IF(LONGPAK) THEN CHKSUM = TOCHAR(0) ELSE CHKSUM = TOCHAR(LEN+3) ENDIF CALL PUTC(CHKSUM,STDOUT) TMP = TOCHAR(NUM) CHKSUM = CHKSUM + TMP CALL PUTC(TMP,STDOUT) CHKSUM = CHKSUM + TYPE CALL PUTC(TYPE,STDOUT) * IF EXTENDED PACKET, OUTPUT EXTENDED HEADER BEFORE DATA IF(LONGPAK) THEN LENX1 = TOCHAR((LEN+1)/95) CHKSUM = CHKSUM + LENX1 CALL PUTC(LENX1, STDOUT) LENX2 = TOCHAR(MOD(LEN+1, 95)) CHKSUM = CHKSUM + LENX2 CALL PUTC(LENX2, STDOUT) HCHKSUM = TOCHAR((CHKSUM + (CHKSUM.AND.O"300") / O"100") + .AND. O"77") CHKSUM = CHKSUM + HCHKSUM CALL PUTC(HCHKSUM, STDOUT) ENDIF DO 110 I = 1,LEN CHKSUM = CHKSUM + (DATA(I) .AND. O"377") CALL PUTC(DATA(I),STDOUT) 110 CONTINUE CHKSUM = (CHKSUM + (CHKSUM.AND.O"300") / O"100") .AND. O"77" CALL PUTC(TOCHAR(CHKSUM),STDOUT) CALL PUTC(REOLCH,STDOUT) IF ((DEBUG.AND.DBGPACK) .NE. 0) THEN CALL PUTC(RSYNC,DEBUGFD) IF(LONGPAK) THEN CALL PUTC(TOCHAR(0), DEBUGFD) ELSE CALL PUTC(TOCHAR(LEN+3), DEBUGFD) ENDIF CALL PUTC(TOCHAR(NUM),DEBUGFD) CALL PUTC(TYPE,DEBUGFD) IF(LONGPAK) THEN CALL PUTC(LENX1, DEBUGFD) CALL PUTC(LENX2, DEBUGFD) CALL PUTC(HCHKSUM, DEBUGFD) ENDIF IF (LEN .GT. 0) CALL PUTSTR(DEBUGFD,DATA) CALL PUTC(TOCHAR(CHKSUM),DEBUGFD) CALL PUTC(REOLCH,DEBUGFD) CALL PUTC(NEL,DEBUGFD) ENDIF * ADD A NOS ZERO BYTE EOL AND FLUSH THE BUFFER * (NOTE: PUTC XORS THE HIGH BIT OF EACH 12 BIT BYTE FOR CONNECTED * FILES, SO TO GET A ZERO BYTE WE PUTC 4000B) CALL PUTC(O"4000",STDOUT) CALL FFLUSH(STDOUT) * UPDATE THE STATISTICS NCH = RPADCT+5+LEN+1 IF(LONGPAK) THEN NCH = NCH + 3 ENDIF SCHCNT = SCHCNT+NCH SCHOVRH = SCHOVRH+NCH-LEN RETURN END SUBROUTINE SNDPAR(TYPE,PDATA,LEN) *** SNDPAR - SET UP PARAMETERS TO SEND TO OTHER KERMIT. * * ENTRY (TYPE) = TYPE OF BLOCK WE ARE GENERATING PARAMETERS FOR. * = *Y* IF AN ACK (REPLY) PACKET. * = *S* IF A SEND-INIT (INITIAL) PACKET. * * EXIT (PDATA) = UNPACKED ASCII BUFFER WITH IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER BOOLEAN PDATA(*) *CALL COMXKER * SEND WHAT WE WANT PDATA(1) = TOCHAR(MIN0(IPKSIZE, SPKSIZE)) PDATA(2) = TOCHAR(STIMOUT) PDATA(3) = TOCHAR(SPADCT) PDATA(4) = CTL(SPADCH) PDATA(5) = TOCHAR(SEOLCH) PDATA(6) = SCQUOTE PDATA(7) = S8QUOTE PDATA(8) = SCHKTYP IF (TYPE .EQ. Y) THEN * R8QUOTE HAS BEEN SET TO THE 8-BIT QUOTE CHARACTER FROM THE * THE SENDER'S SEND-INIT PACKET, OR IS *N* BY DEFAULT. * THE FOLLOWING DECISION IS MADE IN ORDER TO SET *Q8CH* * FOR LATER USE IN *BUFEMP* - * * IF A Y, WE WILL SEND BACK THE CHARACTER WE WANT HIM TO USE * (I8QUOTE) AND PUT THAT CHARACTER IN Q8CH. * * IF AN N, NO QUOTING WILL BE DONE, SO SET Q8CH = 0. * * OTHERWISE, HE SENT US HIS QUOTE CHARACTER, SO AGREE TO IT * AND PUT THAT CHARACTER IN Q8CH. IF (R8QUOTE .EQ. Y) THEN PDATA(7) = I8QUOTE Q8CH = I8QUOTE ELSE IF (R8QUOTE .EQ. N) THEN PDATA(7) = N Q8CH = 0 ELSE PDATA(7) = Y Q8CH = R8QUOTE ENDIF * SET THE REPEAT PREFIX AND ECHO WHAT THE SENDER REQUESTED * * WE ALSO SET REPCH FOR LATER USE IN ROUTINE *BUFEMP*. PDATA(9) = RRPTPFX IF (RRPTPFX .EQ. BLANK) THEN REPCH = 0 ELSE REPCH = RRPTPFX ENDIF * WE CAN TAKE EXTENDED PACKETS IF *SPKSIZE* ALLOWS. IF(SPKSIZE .GT. IPKSIZE) THEN PDATA(10) = TOCHAR(CAPAS5) PDATA(11) = TOCHAR(0) PDATA(12) = TOCHAR(SPKSIZE/95) PDATA(13) = TOCHAR(MOD(SPKSIZE,95)) PDATA(14) = 0 LEN = 13 ELSE PDATA(10) = 0 LEN = 9 ENDIF ELSE PDATA(7) = S8QUOTE PDATA(9) = SRPTPFX * WE CAN SEND EXTENDED PACKETS IF *DPKSIZE* ALLOWS. IF(DPKSIZE .GT. IPKSIZE) THEN PDATA(10) = TOCHAR(CAPAS5) PDATA(11) = TOCHAR(0) PDATA(12) = TOCHAR(DPKSIZE/95) PDATA(13) = TOCHAR(MOD(DPKSIZE,95)) PDATA(14) = 0 LEN = 13 ELSE PDATA(10) = 0 LEN = 9 ENDIF ENDIF RETURN END SUBROUTINE SPRINTF(STR,FMT,I1,I2,I3,I4) *** SPRINTF - POOR ATTEMPT AT DOING INTERNAL FORMATTED I/O. * * SPRINTF IS THE SAME AS FPRINTF EXCEPT THAT IT WRITES TO * AND ASCII STRING BUFFER INSTEAD. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CHARACTER*(*) FMT BOOLEAN STR(*) CALL DOPRNT(0,STR,2,FMT,I1,I2,I3,I4) RETURN END SUBROUTINE STRCPY(S1,S2) *** STRCPY - COPY ONE ASCII STRING TO ANOTHER * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER BOOLEAN S1(*),S2(*) I1 = 1 10 S2(I1) = S1(I1) IF (S1(I1) .NE. 0) THEN I1 = I1+1 GOTO 10 ENDIF RETURN END SUBROUTINE STTY(MODE,VALUE) *** STTY - SET A TERMINAL MODE. * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER CHARACTER*(*) MODE INTEGER VALUE * DUPLEX (ECHOPLEX) IF (MODE .EQ. 'DUPLEX') THEN IF (VALUE .EQ. HALFDUP) THEN DUPLEX = HALFDUP FCHBUF(1,STDOUT) = O"0016 4061 4000 0000 0000" ELSE DUPLEX = FULLDUP FCHBUF(1,STDOUT) = O"0016 4061 4001 0000 0000" ENDIF FNWDS(STDOUT) = 1 CALL FFLUSH(STDOUT) * RECEIVE-FILE-CONFIGURATION = ON ELSE IF (MODE .EQ. 'RCV-ON') THEN FCSET(STDIN) = CSTXP FCHBUF(1,STDOUT) = O"0016 4070 4001 4071 4017" FCHBUF(2,STDOUT) = O"4072 4376 4073 4015 4074" FCHBUF(3,STDOUT) = O"4000 4106 4001 4061 4000" FCHBUF(4,STDOUT) = O"4064 4001 4036 4007 4037" FCHBUF(5,STDOUT) = O"4370 0000 0000 0000 0000" FNWDS(STDOUT) = 5 CALL FFLUSH(STDOUT) * RECEIVE-FILE-CONFIGURATION = OFF ELSE IF (MODE .EQ. 'RCV-OFF') THEN FCSET(STDIN) = CS612 IF (VALUE .EQ. HALFDUP) THEN FCHBUF(1,STDOUT) = O"0016 4064 4000 0000 0000" FNWDS(STDOUT) = 1 ELSE FCHBUF(1,STDOUT) = O"0016 4061 4001 4064 4000" FCHBUF(2,STDOUT) = O"0000 0000 0000 0000 0000" FNWDS(STDOUT) = 2 ENDIF CALL FFLUSH(STDOUT) * INVALID MODE ELSE CALL DISPLA(' STTY - INVALID MODE ',BOOL(MODE)) CALL ABORT ENDIF RETURN END SUBROUTINE TXTMCMD *** TXTMCMD - PERFORM A SET TEXT-MODE XXXX COMMAND * IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER LOGICAL CONFIRM PARAMETER (TSIZE=4) CHARACTER*10 MODETYP(TSIZE) DATA MODETYP / 'AUTO', 'DISPLAY', '6/12-ASCII', '8/12-ASCII'/ * MATCH THE PARAMETER INDX = MATCH(MODETYP,TSIZE,.FALSE.) IF (INDX .LE. 0) RETURN IF (.NOT. CONFIRM(CMDFD)) RETURN * TAKE THE APPROPRIATE ACTION GO TO (10, 20, 30, 40), INDX * SET AUTO 10 TXTMODE = CSNONE RETURN * SET DISPLAY CODE 20 TXTMODE = CSDSP RETURN * SET 6/12 ASCII 30 TXTMODE = CS612 RETURN * SET 8/12 ASCII 40 TXTMODE = CS812 RETURN END SUBROUTINE UNGETC(FD,CH) *** UNGETC - PUT A CHARACTER BACK INTO THE INPUT STREAM. * * UNGETC CAN ONLY PUT BACK A SINGLE CHARACTER. IMPLICIT INTEGER (A-Z) PARAMETER (COMLIS = 0) *CALL COMCKER FUNGTCH(FD) = CH RETURN END IDENT UVAMISC TITLE UVAMISC - MISCELANEOUS NOS HELPER ROUTINES COMMENT UVAMISC - MISCELANEOUS NOS HELPER ROUTINES B1=1 SST UVAMISC SPACE 4,10 *** UVAMISC - MISCELANEOUS NOS HELPER ROUTINES. * * MISCELLANEOUS ROUTINES REQUIRED FOR USE OF KERMIT UNDER NOS. SPACE 3 USE /BMESAGE/ BOOLEAN MESSAGE TEXT COMMON BLOCK DATE8 MICRO 2,8,$"DATE"$ VERSDAT DATA 10H("DATE8") VERSION ASSEMBLE DATE VERSSTR BSS 11 STRING VERSION OF ABOVE USE * USTART SPACE 4,10 ENTRY USTART *** USTART - INITIALIZE TERMINAL PARAMETERS. * * ENTRY NONE. * * EXIT (X6) = 0 IF JOB IS *IAOT*. USTART SUBR ENTRY/EXIT CSET ASCII PROMPT OFF GETJO EXITFLG SA1 EXITFLG SX6 X1-IAOT EQ USTARTX RETURN NODROP SPACE 4,10 ENTRY NODROP *** NODROP - SET FILE STATUS TO AUTO-DROP. * * SET AUTO-DROP STATUS ON A FILE. THIS CLEARS SSST STATUS * WHICH IS SET FOR EVERY FILE CREATED BY AN SSJ= BLOCK PROGRAM. * SSST CAUSES FILES TO BE DROPPED AT END OF JOB STEP. * * ENTRY (X1) = FWA OF FET. * * EXIT NONE. NODROP SUBR ENTRY/EXIT BX5 X1 SETFS X5,AD EQ NODROPX RETURN MFS> SPACE 4,10 ENTRY MFS> *** MFS> - MAKEFET HELPER. * * ENTRY (X1) = SOURCE ADDRESS. * (B6) = DESTINATION ADDRESS. * * EXIT NONE. MFS> SUBR ENTRY/EXIT SA1 X1 BX6 X1 SA6 B6 SB6 B6+1 REQUIRED BY MAKEFET EQ MFS>X RETURN BTZ> SPACE 4,10 ENTRY BTZ> *** BTZ> - CONVERT BLANKS TO ZEROS. * * ENTRY (X1) = WORD TO CONVERT. * * EXIT (X6) = CONVERTED WORD. BTZ> SUBR ENTRY/EXIT SB1 1 SA2 =10H BX4 X1 SAVE INPUT WORD SA2 =10H BX1 X1-X2 CONVERT BANKS TO ZEROS RJ =XZTB= (X7) = MASK WITH 77B IN NON-BLANKS BX6 X7*X4 EQ BTZ>X RETURN RETFILE SPACE 4,10 ENTRY RETFILE *** RETFILE - RETURN A FILE. * * ENTRY (X1) = FWA OF FILE NAME. * * EXIT NONE. RETFILE SUBR ENTRY/EXIT SA1 X1 LFN RJ BTZ> SX1 B1 BX6 X6+X1 SA6 FET RETURN FET,R EQ RETFILEX RETURN FET FILEB RETFILE,1 DUMMY FET WAITINP SPACE 4,8 *** LOGICAL FUNCTION WAITINP(ITIME) * * ROUTINE WAITS FOR UP TO *ITIME* SECONDS FOR INPUT TO BE * ENTERED AT THE TERMINAL. RETURNS .FALSE. IF ROUTINE TIMES OUT. * ENTRY WAITINP WAITMS = 25 WAIT INCREMENT, IN MILLISECONDS. NOSLVL = "NOSLVL" OPERATING SYSTEM LEVEL, FROM NOSTEXT. WAITINP EQ *+40000B SB1 1 SX2 1000 CONVERT TO MILLISECONDS SA1 X1 GET TIMER VALUE IX1 X1*X2 SX2 WAITMS IX5 X1/X2 CHECK/WAIT LOOP COUNTER WAIT1 WAIT WAITMS WAIT A BIT BEFORE CHECKING IFGE NOSLVL,602,1 OLD SYSTEMS DON'T HAVE THIS. SYSTEM TLX,R,WAITA,1600B CHECK TYPE-AHEAD BUFFER SA1 WAITA SX5 X5-1 MX6 59 FLAG TRUE NZ,X1 WAITINP GOT INPUT, RETURN PL,X5 WAIT1 TRY AGAIN MX6 0 EQ WAITINP TIMED OUT WAITA CON 1 TYPE-AHEAD PRESENT FLAG (TRUE FOR PRE-602) SX12A8 SPACE 4,10 ENTRY SX12A8 ENTRY DPCA8 *** SX12A8 - CONVERT 6/12 TO 8/12. * DPCA8 - CONVERT DISPLAY CODE TO 8/12. * * CONVERT THE 6/12 ASCII DATA IN THE SOURCE WSA (SWSA) TO * 8/12 ASCII IN THE DESTINATION WSA (DWSA), STOPPING AT * AN EOL OR THE END OF SWSA OR END OF DWSA. * IT IS ASSUMED THAT SWSA AND DWSA ARE THE SAME LENGTH, * FOR SIMPLICITY. IN FACT, THE CALLER MUST INSURE THIS. * TWO WORDS FROM THE WSA ARE MANIPULATED AT ONCE. * WD1 IS READ FIRST, FOLLOWED BY WD2. IF WD2 IS ZERO, * THEN A COLON AS THE LAST CHARACTER OF WD1 INDICATES A 66-BIT E * WHEN WD1 HAS BEEN PROCESSED, WD2 REPLACES IT AND A NEW WD2 * IS READ FROM THE WSA. * ON ENTRY, STATUS CONTAINS A READC * RETURN CODE - 0 FOR TRANSFER COMPLETE (1 LINE READ * OR, APPARENTLY, WSA FULL), NEGATIVE IF EOF/EOI, LWA+1 * OF DATA IF EOR. READC GUARANTEES AN EOL BYTE EVEN * IF DATA IN THE LAST BYTE OF THE WSA MUST BE CLOBBERED. * ON EXIT, STATUS=0 IF IT WAS ZERO ON ENTRY, OTHERWISE * LWA+1 OF DATA IN DWSA. IF DWSA IS FILLED COMPLETELY, * AN EOL BYTE IS NOT GUARANTEED. * * CALL SX12A8(SWSA,DWSA,WSAL,STATUS) * * THE CALLING SEQUENCE FOR *DPCA8* IS THE SAME, BUT A DIFFERENT * CONVERSION TABLE IS USED. * * REGISTER ASSIGNMENTS - * * B2 ESCFLAG (74 OR 76 ESCAPE TABLE ADDRESS) * B3 CT (CHARACTER COUNTER) * B4 OUT12 BYTE SHIFT COUNT * B5 ADDRESS FOR NEXT WORD IN DWSA * B6 LWA+1 OF DWSA * X1 WD1 * X2 WD2 * A2 ADDRESS OF WD2 * X4 OUT12 WORD UNDER CONSTRUCTION * * * * CHARACTER TRANSLATION TABLES. * USE /CHARCOM/ ASC612 BSS 128 DPCTBL BSS 128 LASCII BSS 64 SX1274 BSS 64 SX1276 BSS 64 UASCII BSS 64 USE * SX12A8 SUBR ENTRY/EXIT SB2 B0 PRESET ESCFLAG FOR 6/12 CONVERSION RJ SXXXA8 PERFORM CONVERSION EQ SX12A8X RETURN DPCA8 SUBR ENTRY/EXIT SB2 UASCII PRESET ESCFLAG FOR DPC CONVERSION RJ SXXXA8 PERFORM CONVERSION EQ DPCA8 RETURN SXXXA8 PS INTERNAL ENTRY/EXIT SB1 1 MX6 0 SA6 EXITFLG BX7 X1 SAVE FWA OF SWSA FOR A MOMENT SA1 A1+B1 SB5 X1 FWA OF DWSA SA1 A1+B1 SA2 X1 LENGTH OF SWSA/DWSA BX6 X2 SX6 X6-1 SA6 SWSAREM INITIALIZE WORDS REMAINING -1 SB6 X2+B5 SET LWA+1 OF DWSA SA1 A1+B1 BX6 X1 SA6 STATADR ADDRESS OF STATUS PARAMETER SA2 X7 A2=SOURCE WORD ADDRESS BX1 X2 X1=FIRST WD1 SB4 48 OUT12 SHIFT COUNT MX4 0 OUT12 ACCUMULATOR SA3 X6 STATUS ZR X3,S1 IF STATUS=0 ON ENTRY IX3 X7-X3 - (STATUS-LOCF(SWSA)) SX6 B5 FWA DWSA PL X3,S16 IF .GE. 0, RETURN STATUS=LOCF(DWSA) BX6 -X3 WORD COUNT OF VALID DATA SX6 X6-1 ACCOUNT FOR WORD ALREADY PICKED UP SA6 SWSAREM BX2 X1 S15 BX1 X2 WD1=WD2 S1 SA3 SWSAREM ZR X3,S2 IF NO MORE IN SWSA SX6 X3-1 SA6 A3 SA2 A2+B1 READ NEXT WD2 NG X2,S4 IF COULD BE ALL ONES ZR X2,S3 IF WD2=0 S4 MX0 -12 BX3 -X0*X1 BYTE 4 OF WD1 ZR X3,S3 IF Z-BYTE TERMINATOR IN WD1 SB3 10 DO 10 CHARACTERS * WHETHER WD1 CONTAINS AN EOL OR NOT, CT (B3) IS * NOW THE NUMBER OF LEFTMOST CHARACTERS IN WD1 * TO CONVERT. IF THIS IS THE LAST WORD IN * SWSA (NO WD2), OR IF WD1 CONTAINS AN EOL, THE * EXIT FLAG HAS BEEN SET TO CAUSE AN EXIT * AS SOON AS WD1 IS FINISHED. S8 LX1 6 MX0 -6 BX3 -X0*X1 NEXT WD1 CHAR NE B2,S9 IF ESCFLAG<>0 SX5 X3-76B ZR X5,S10 IF 76B ESCAPE LEADIN SX5 X3-74B ZR X5,S11 IF 74B ESCAPE LEADIN SA3 UASCII+X3 CONVERT TO 8/12 * X3 IS THE 8/12 ASCII BYTE TO OUTPUT. THE FOLLOWING * CODE (CALLED OUT12 JUST TO IDENTIFY IT AS A LOGICAL * UNIT) PUTS THE BYTE INTO DWSA. S13 LX3 X3,B4 BX4 X4+X3 PUT INTO WORD UNDER CONSTRUCTION SB4 B4-12 PL B4,S14 IF OUT12 WORD NOT FULL BX6 X4 SA6 B5 STORE IN DWSA SB5 B5+B1 EQ B5,B6,S12 IF DWSA NOW FULL MX4 0 SB4 48 START OVER WITH NEXT WORD S14 SB3 B3-B1 S7 NE B3,S8 SA3 EXITFLG ZR X3,S15 IF NOT TIME TO QUIT BX6 X4 SA6 B5 FINISH LAST WORD S12 SA1 STATADR SA1 X1 ZR X1,SXXXA8 IF ZERO ON ENTRY SX6 B5 S16 SA1 STATADR SA6 X1 EQ SXXXA8 * ESCFLAG CONTAINS THE ADDRESS OF THE 74 OR 76 TRANSLATION * TABLE, SO LOOK UP THE TRANSLATED CHARACTER AND * INDICATE THAT THE ESCAPE SEQUENCE IS DONE BY * SETTING ESCFLAG BACK TO ZERO, UNLESS WE ARE DOING DPC * CONVERSION. S9 SA3 B2+X3 SB7 UASCII CHECK FOR DPC CONVERSION EQ B2,B7,S13 DPC CONVERSION. DON'T RESET ESCFLAG SB2 B0 ESCFLAG=0 EQ S13 * IF A 74B IS FOUND, SET ESCFLAG TO THE 74 TRANSLATION TABLE * FWA. SIMILARLY FOR 76B. S10 SB2 SX1276 EQ S14 S11 SB2 SX1274 EQ S14 S2 SX6 B1 SA6 EXITFLG EQ S4 * WE HAVE FOUND AN EOL. COUNT THE NUMBER OF * LEADING NON-ZERO CHARACTERS IN WD1. S3 SX6 B1 SA6 EXITFLG BX5 X1 WD1 SB7 10 MAX LOOP COUNT SB3 B7 INITIALIZE COUNT MX0 -6 S6 BX3 -X0*X5 RIGHTMOST WD1 CHAR NZ X3,S7 IF NON-ZERO CHAR SB3 B3-B1 COUNT A ZERO CHAR (NEGATIVELY) LX5 -6 SB7 B7-B1 NE B7,S6 EQ S7 EXITFLG BSS 1 NZ IF TO QUIT AFTER DOING THIS WD1 SWSAREM BSS 1 WORDS REMAINING TO BE DONE IN SWSA STATADR BSS 1 ADDRESS OF STATUS PARAMETER A8SX12 SPACE 4,10 ENTRY A8SX12 ENTRY A8DPC *** A8SX12 - CONVERT 8/12 TO 6/12. * A8DPC - CONVERT 8/12 TO DISPLAY CODE * * CONVERT THE 8/12 ASCII DATA IN SRC TO 6/12 ASCII * OR DISPLAY CODE IN THE SAME BUFFER. * * REGISTER ASSIGNMENTS - * X0 - MASK(-7) * A1/X1 - CURRENT SOURCE WORD * X5 - LAST CHARACTER OUTPUT * X6 - CURRENT DESTINATION WORD * B2 - NUMBER OF BYTES LEFT IN X1 * B3 - NUMBER OF WORDS REMAINING IN SRC * B5 - OUTPUT WORD BYTE SHIFT COUNT * B6 - DESTINATION ADDRESS * B7 - CONVERSION TABLE ADDRESS A8SX12 SUBR ENTRY/EXIT SB7 ASC612 CONVERT TO 6/12 RJ A8XXXX EQ A8SX12 RETURN A8DPC SUBR SB7 DPCTBL CONVERT TO DISPLAY CODE RJ A8XXXX EQ A8DPC RETURN A8XXXX PS INTERNAL ENTRY/EXIT SB1 1 SB6 X1 SRC SA1 A1+B1 SA1 X1 SB3 X1 N EQ B3,A8XXXX IF NOTHING TO DO SA1 B6 A1=SRC SB5 54 MX6 0 INITIALIZE DESTINATION WORD MX0 -7 L2 SB2 5 L1 LX1 12 BX2 -X0*X1 ZR X2,L5 L11 SA3 B7+X2 CONVERT CHARACTER SB4 X3-100B PL B4,L3 L4 RJ OUT6 SB2 B2-B1 NE B2,L1 L9 SB3 B3-B1 EQ B3,EXIT SA1 A1+B1 EQ L2 * THE TABLE ENTRY INDICATES THE NEED FOR AN * ESCAPE SEQUENCE. L3 BX4 X3 SAVE TABLE ENTRY AX3 6 SX3 X3 LEADING CHARACTER (74B OR 76B) RJ OUT6 MX3 -6 BX3 -X3*X4 SECOND CHARACTER EQ L4 * CHECK FOR A POSSIBLE EOL BYTE. L5 MX4 -12 BX4 -X4*X1 ALL 12 BITS OF BYTE NZ X4,L11 IF NOT A 12-BIT ZERO RJ EOL EQ L9 EXIT RJ EOL EQ A8XXXX * PUT AN EOL IN THE OUTPUT. EOL BSS 1 NZ X5,EOL1 * THE LAST CHARACTER OUTPUT WAS A COLON. PROTECT IT * BY OUTPUTTING A BLANK AFTER IT. SX3 1R RJ OUT6 EOL1 EQ B5,L6 IF 66-BIT EOL NEEDED SB5 B5-54 EQ B5,L7 IF 60-BIT EOL NEEDED * THE EOL IS OK AS IS IN THE OUTPUT WORD. EQ L10 L6 SA6 B6 SB6 B6+B1 L7 MX6 0 L10 SA6 B6 SB6 B6+B1 SB5 54 EQ EOL * PUT A 6-BIT CHAR INTO THE OUTPUT WORD OUT6 BSS 1 BX5 X3 LX3 X3,B5 BX6 X6+X3 SB5 B5-6 PL B5,OUT6 SA6 B6 SB6 B6+B1 SB5 54 MX6 0 EQ OUT6 END LOGICAL FUNCTION WILDMAT(NAME) CHARACTER NAME*(*) INTEGER SEGM(7) * START OF COMMON BLOCK FOR WILDCARD ROUTINES COMMON /WILD/ WSEGC, WSEGL(1:7), WFFIX, WLFIX, WCOM INTEGER WSEGC, WSEGL LOGICAL WFFIX, WLFIX, WCOM COMMON /WILDC/ WSEG(1:7) CHARACTER WSEG*7 * END OF COMMON BLOCK FOR WILDCARD ROUTINES * * DETERMINE FILE NAME STRING LENGTH, CHECK FOR ALL BLANK STRING. * L = INDEX(NAME, ' ')-1 IF(L .EQ. 0) THEN WILDMAT = WCOM RETURN ELSE IF(L .EQ. -1) THEN L = LEN(NAME) ENDIF IPOS = 1 * * LOOK FOR FIRST MATCH OF SEGMENT 'ISEG' IN 'NAME'. * DO 10 ISEG = 1, WSEGC 20 CONTINUE * * LOOK FOR MATCH IN 'NAME' FOLLOWING THIS POINT. IF FAILURE, BUT * WE HAVEN'T RUN OUT OF 'NAME' YET, BUMP STARTING POINT AND * TRY AGAIN. * SEGM(ISEG) = IPOS DO 30 I = 1, WSEGL(ISEG) IF((WSEG(ISEG)(I:I).EQ. '?') .OR. + (WSEG(ISEG)(I:I).EQ.NAME(IPOS:IPOS))) THEN * PRINT *, 'OK',ISEG, I, IPOS IPOS = IPOS + 1 IF((IPOS.GT.L) .AND. ((ISEG.NE.WSEGC) .OR. + (I.NE.WSEGL(ISEG)))) THEN WILDMAT = WCOM RETURN ENDIF ELSE * PRINT *, 'NO',ISEG, I, IPOS IPOS = SEGM(ISEG)+1 IF(IPOS .GT. L) THEN WILDMAT = WCOM RETURN ENDIF GO TO 20 ENDIF 30 CONTINUE * * AT THIS POINT, SEGMENT 'ISEG' MATCHES. * IF WFFIX, ENSURE FIRST SEGMENT MATCH IS AT START OF NAME. * IF WLFIX, ENSURE LAST SEGMENT IS AT END; IF NOT TRY IT. * IF((ISEG.EQ.1) .AND. WFFIX .AND. (SEGM(1).NE.1)) THEN WILDMAT = WCOM RETURN ENDIF IF((ISEG.EQ.WSEGC) .AND. WLFIX .AND. (IPOS.NE.L+1)) THEN IPOS = L-WSEGL(WSEGC)+1 * PRINT *, 'LAST SEG RESTART.' GOTO 20 ENDIF 10 CONTINUE WILDMAT = (.NOT.WCOM) * * WE HAVE A MATCH. RETURN. * * PRINT *,WILDMAT,' MATCH ',(SEGM(I),I=1, WSEGC) RETURN END LOGICAL FUNCTION WILDSET(WILDNAM) CHARACTER *(*) WILDNAM, C*1 LOGICAL BREAK INTEGER SEGS(1:7), SEGE(1:7) * START OF COMMON BLOCK FOR WILDCARD ROUTINES COMMON /WILD/ WSEGC, WSEGL(1:7), WFFIX, WLFIX, WCOM INTEGER WSEGC, WSEGL LOGICAL WFFIX, WLFIX, WCOM COMMON /WILDC/ WSEG(1:7) CHARACTER WSEG*7 * END OF COMMON BLOCK FOR WILDCARD ROUTINES WSEGC = 0 BREAK = .TRUE. WFFIX = .FALSE. WLFIX = .FALSE. * * DETERMINE WILDCARD STRING LENGTH, CHECK FOR ALL BLANK STRING * L = INDEX(WILDNAM, ' ')-1 IF(L .EQ. -1) L = LEN(WILDNAM) WCOM = (WILDNAM(L:L) .EQ. '-') IF(WCOM) L = L - 1 IF(L .EQ. 0) THEN WILDSET = .FALSE. RETURN ENDIF * * EXAMINE WILDCARD STRING. BREAK INTO SEGMENTS CONSISTING OF * A-Z,0-9,? STRINGS, TERMINATING WITH *. * IF FIRST PIECE OF STRING IS SEGMENT (NO LEADING *), SET WFFIX. * IF LAST PIECE IS SEGMENT, SET WLFIX. * DO 10 I=1, L C = WILDNAM(I:I) IF(C .EQ. '*') THEN BREAK = .TRUE. ELSE IF((C.GE.'A'.AND.C.LE.'Z').OR.(C.GE.'0'.AND.C.LE.'9') + .OR. C.EQ.'?') THEN IF(I .EQ. 1) WFFIX = .TRUE. IF(I .EQ. L) WLFIX = .TRUE. IF(BREAK) THEN BREAK = .FALSE. IF(WSEGC.LT.7) WSEGC = WSEGC+1 SEGS(WSEGC) = I SEGE(WSEGC) = I ELSE SEGE(WSEGC) = I ENDIF ELSE WILDSET = .FALSE. RETURN ENDIF 10 CONTINUE * PRINT *,WSEGC, WFFIX, WLFIX * * KEEP SEGMENTS AND THEIR LENGTHS FOR ROUTINE 'WILDMAT'. * DO 20 I=1, WSEGC WSEG(I) = WILDNAM(SEGS(I):SEGE(I)) WSEGL(I) = SEGE(I)-SEGS(I)+1 * PRINT '(2I5,2X,A,I5)', SEGS(I), SEGE(I), WSEG(I), WSEGL(I) 20 CONTINUE WILDSET = .TRUE. RETURN END INTEGER FUNCTION XVFN(LFN) CHARACTER LFN*(*) *** XVFN - VERIFY CORRECT FORMAT FOR FILE NAME. * * ON ENTRY, LFN CONTAINS THE FILE NAME LEFT-JUSTIFIED * IN DISPLAY CODE AND BLANK-FILLED. * * CALLED ONLY BY SNDFILE AND SERVER. XVFN=0 RETURN END