home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
cdccyber.tar.gz
/
cdccyber.tar
/
cd3ker.src
< prev
next >
Wrap
Text File
|
1988-08-16
|
193KB
|
7,283 lines
*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,
* + - * / ( ) $ = , . < [ ] <PCT>
* 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/
* <PCT> " # ! & ' ? < > @ \ ^ ;
* 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 "#<TILDE>" WILL BE CONVERTED
* TO "#", "&", AND "<TILDE>", 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 <NEL> TO <CR><LF> 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 <CR><LF>
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 <TILDE> TO #<TILDE>
* CONVERT # TO ##
BUFPTR = BUFPTR+1
BUFFER(BUFPTR) = RCQUOTE
ELSE IF (XCH .LT. BLANK .OR. XCH .EQ. DEL) THEN
* CONVERT <CC> TO #<CC>
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 @<N>D (I.E. @10D) IN WHICH THE NUMBER WILL BE BLANK
* PADDED TO THE RIGHT TO USE UP <N> 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 @<N>D (I.E. @10D) IN WHICH THE NUMBER WILL BE BLANK
* PADDED TO THE RIGHT TO USE UP <N> 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