home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
kermit.columbia.edu
/
kermit.columbia.edu.tar
/
kermit.columbia.edu
/
archives
/
harris100.zip
/
h100ker.f77
< prev
next >
Wrap
Text File
|
1988-08-16
|
82KB
|
2,835 lines
C S E R V E R O N L Y K E R M I T
C
C written in January, 1986 by Skip Russell using Harris Fortran 77
C
C
C This program implements the "server" portion of the "Kermit"
C protocol, as described in version 3 of the protocol manual (see
C reference below). It is intended to facilitate the tranfer
C of files between a Harris computer and other machines. It
C incorporates mechanisms to maintain the integrity of data, even
C over noisy phone lines, etc. Only the basic server functions
C have been implemented in this initial version, i.e. send and
C receive of text (7 bit ascii) files, and the "Finish" command.
C Other functions/enhancements may be added to future versions
C and will be documented under "revision history" below.
C
C I wrote this program especially for use on Harris computers
C which are configured with a "MUX" as opposed to the more recent
C CNP or DMACP I/O processors. As such, I have not taken advantage
C of many of the special features offered by those devices (notably
C timeouts and buffered I/O via "hot read"), but have opted instead
C for simpler, albeit less efficient, modes of communication. In
C any case, this program should work properly on a Harris machine
C in any configuration.
C
C This program was written using Harris Fortran on a Harris
C H100-1 computer (VOS 4.1.1 operating system). It was tested
C at up to 9600 baud against Columbia University's "MSKERMIT"
C version 2.27 (see below) on an IBM PC/AT running DOS 3.0.
C
C
C -- REFERENCES --
C
C For a complete discussion of the Kermit design philosophy and
C detailed descriptions of Kermit commands, see the "KERMIT USER'S
C GUIDE" by Frank da Cruz, Daphne Tzoar, and Bill Catchings.
C
C For a detailed description of the Kermit protocol, see the
C "KERMIT PROTOCOL MANUAL" by Frank da Cruz and Bill Catchings.
C
C These two documents, as well as general information about Kermit,
C MSKERMIT and other implementations of Kermit, are available for
C the cost of distribution, from:
C
C KERMIT Distribution
C Columbia University Center for Computing Activities
C 612 West 115th Street
C 7th Floor
C New York, NY 10025
C
C or send electronic mail to: Info-Kermit-Request@CU20B.ARPA
C
C
C Address questions, fixes, comments about this implementation to:
C
C Skip Russell
C Washington University School of Medicine
C Division of Biostatistics
C Box 8087, 660 South Euclid Avenue
C St. Louis, Missouri 63110
C
C electronic mail address: c04689sr@WUVMD.BITNET
C
C
C -- REVISION HISTORY --
C
C (change version number and date in header line if changes are made)
C
C version 1.00 Jan, 1986, by S.R. : initial release
C
C version 1.01 Feb, 1986, by S.R. :
C brought up to version 5 of the protocol manual (dated April 1984)
C and tested using MSKERMIT version 2.28; also implemented the
C following remote commands:
C -- HELP command to issue summary of available remote commands
C -- LOGOUT ("bye") command to log off the Harris job
C -- DIRECTORY command to issue information about a single disk
C area (for now; plan to add wildcard match in future)
C
C version 1.02 Sept, 1986, by S.R. :
C -- implemented full DIRECTORY command (wildcard character "?")
C -- tested using MSKERMIT version 2.29 (dated 26 May 86)
C -- moved to non-SAU Fortran 77 compiler for portablity
C
C version 1.03 Nov, 1986, by S.R. :
C -- brought up to VOS 5.1.0 (required changes in interpretation of
C file access bits in "REMOTE DIRECTORY" command handler)
C -- fixed logic in RECVSW to correctly respond to error packets
C
C version 1.04 April, 1987, by S.R. :
C -- added code to allow GETs of file groups using the "?" wildcard
C character.
C
C version 1.05 May, 1987, by S.R. :
C -- Corrected error in SWOPEN. GETs of file groups failed in
C cases where the qualifier contained trailing blanks. The fix
C consisted of enclosing the file name in quotes.
C
C version 1.06 June, 1987, by S.R. :
C -- Added code in RDISK to distinguish between EOF and EOT. Harris
C disk areas containing embedded EOFs can now be sent without
C truncating trailing records. The EOF is sent as a record
C containing the string "<EOF>".
C
C
C ---------------------------------------------------------------------
C COMMON BLOCKS USED:
LOGICAL DEBUG
COMMON /DBGCOM/ DEBUG
INTEGER MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
COMMON /SNDCOM/ MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
INTEGER MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME
COMMON /RCVCOM/ MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME
INTEGER MXDATA
PARAMETER (MXDATA=89)
INTEGER DATA(MXDATA),NDATA,NSEQ,ISTAT,MAXTRY
CHARACTER TYPE*1
WRITE (3,*) 'HARRIS KERMIT SERVER -- version 1.06 (June 87) SR'
WRITE (3,*)
C DEFINE DEFAULT SEND AND RECEIVE SPECS
CALL KSTART
MAXTRY = 10
C WAIT FOR A PACKET TO COME IN, THEN RESPOND
100 CALL RCVPKT(MXDATA,DATA,NDATA,NSEQ,TYPE,ISTAT)
C WE GOT GARBAGE, NAK IT AND TRY AGAIN
IF (ISTAT .NE. 0) THEN
NDATA = 0
CALL SNDNAK(NSEQ)
C WE GOT INIT IN ADVANCE OF SOME FUTURE COMMAND, JUST EXCHANGE INFO
ELSE IF (TYPE .EQ. 'I') THEN
CALL INIT(MXDATA,DATA,NDATA,NSEQ)
C LOCAL "SEND" COMMAND (THEY WANT TO SEND A FILE TO US)
ELSE IF (TYPE .EQ. 'S') THEN
CALL RECVSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY)
C LOCAL "GET" COMMAND (THEY WANT A FILE FROM US)
ELSE IF (TYPE .EQ. 'R') THEN
CALL SENDSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY)
C 'GENERIC' COMMAND (THEY WANT US TO LOG OFF OR SOMETHING)
ELSE IF (TYPE .EQ. 'G') THEN
CALL COMMND(MXDATA,DATA,NDATA,NSEQ,MAXTRY,ISTAT)
IF (ISTAT .NE. 0) GO TO 999
C WE GOT AN ERROR PACKET, JUST ACKNOWLEDGE IT
ELSE IF (TYPE .EQ. 'E') THEN
NDATA = 0
CALL SNDACK(DATA,NDATA,NSEQ)
C ANYTHING ELSE IS AN ERROR, AS FAR AS WE'RE CONCERNED
ELSE
CALL SNDERR('server command not implemented',MXDATA,DATA,NSEQ)
END IF
GO TO 100
999 CALL KFINSH
END
SUBROUTINE KSTART
C---
C--- DEFINE DEFAULT SEND AND RECEIVE SPECS
C---
LOGICAL DEBUG
COMMON /DBGCOM/ DEBUG
INTEGER MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
COMMON /SNDCOM/ MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
INTEGER MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME
COMMON /RCVCOM/ MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME
INTEGER IOPT
C HANDLE DEBUG MODE (SPECIFIED USING "KERMIT.D")
CALL OPTION(IOPT)
IF ((IOPT.AND.2**3) .GT. 0) THEN ! OPTION "D" SPECIFIED
DEBUG = .TRUE.
IOPT = IOPT .XOR. 2**3
ELSE ! NOT SPECIFIED
DEBUG = .FALSE.
END IF
IF (IOPT.NE.0) STOP "*ERROR* valid option is 'D' for debug mode"
IF (DEBUG) THEN
WRITE (3,*) '[writing packet contents to LO for debugging]'
ELSE
WRITE (3,*) '[logging names of send/receive files to LO]'
END IF
WRITE (3,*)
C DEFAULT SEND SPECS
MSPSIZ = 94 ! BIGGEST PACKET THEY CAN RECEIVE
NSTIME = 0 ! WHEN THEY WANT TIMEOUT
NSPAD = 0 ! HOW MUCH PADDING TO SEND THEM
NSPCHR = 0 ! PAD CHARACTER TO USE
NSEOL = 13 ! EOL TO SEND THEM (CR)
NSQUOT = ICHAR('#') ! INCOMING DATA QUOTE CHARACTER
C DEFAULT RECEIVE SPECS
MRPSIZ = 78 ! BIGGEST PACKET I CAN RECEIVE
MYTIME = 13 ! WHEN I WANT TIMEOUT
MYPAD = 0 ! HOW MUCH PADDING TO SEND ME
MYPCHR = 10 ! PAD CHARACTER TO USE (LINEFEED)
MYEOL = 13 ! EOL TO SEND ME (CR)
MYQUOT = ICHAR('#') ! QUOTE CHARACTER I WILL SEND THEM
CCCC WARN ABOUT XON/XOFF IF CONTROL/S IS AN ABORT CHAR ON THIS
CCCC MACHINE
CCC
CCC WRITE (3,*) 'DO NOT USE XON/XOFF (SET FLOW NONE)'
WRITE (3,*)
WRITE (3,*) 'SERVER MODE ENABLED -- type the appropriate key'
WRITE (3,*) 'sequence to escape back to your local Kermit...'
END
SUBROUTINE KFINSH
C---
C--- CLOSE UP
C---
INTEGER MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
COMMON /SNDCOM/ MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
CALL PUT1CW(NSEOL,1)
CLOSE (UNIT=6)
CLOSE (UNIT=7)
CLOSE (UNIT=50)
END
SUBROUTINE INIT(MXDATA,DATA,NDATA,NSEQ)
C---
C--- HANDLE INITIAL PACKET, RESPOND WITH ACK AND OUR PARAMETERS
C---
INTEGER MXDATA,DATA(*),NDATA,NSEQ
C READ THEIR PACKET
CALL RPAR(DATA,NDATA)
C ACK WITH OUR INIT PACKET
CALL SPAR(MXDATA,DATA,NDATA)
CALL SNDACK(DATA,NDATA,NSEQ)
END
C TRANSMIT SUBROUTINES
C
C SENDSW -- STATE TABLE SWITCHER FOR SENDING FILES
C SOPEN -- OPENS FILE TO SEND TO RECEIVING KERMIT
C SINIT -- EXCHANGE SEND/RECEIVE INFO WITH RECEIVING KERMIT
C SFILE -- SENDS FILE NAME TO RECEIVING KERMIT
C SDATA -- SENDS FILE CONTENTS TO RECEIVING KERMIT
C SEOF -- SENDS "END-OF-FILE" PACKET TO RECEIVING KERMIT
C SBREAK -- SENDS "BREAK" PACKET TO RECEIVING KERMIT
C RDISK -- READS A SINGLE CHARACTER FROM A DISK FILE
C SWINIT -- EXPANDS LIST OF WILDCARD FILE NAMES
C SWOPEN -- OPENS THE NEXT FILE IN A LIST OF WILDCARD FILENAMES
C SWCLOS -- CLOSES THE LIST OF WILDCARD FILE NAMES
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
SUBROUTINE SENDSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY)
C---
C--- THIS IS THE STATE TABLE SWITCHER FOR SENDING FILES.
C--- IT LOOPS UNTIL EITHER IT IS FINISHED OR A FAULT IS ENCOUNTERED.
C---
INTEGER MXDATA,DATA(*),NDATA,NSEQ,MAXTRY
LOGICAL DEBUG
COMMON /DBGCOM/ DEBUG
CHARACTER STATE*1
INTEGER NUMTRY,ISTAT
C ASSIGN THE FILE
CALL SOPEN(MXDATA,DATA,NDATA,NSEQ,ISTAT)
IF (ISTAT .NE. 0) GO TO 800
STATE = 'S'
NSEQ = 0
100 CONTINUE
FOR NUMTRY=1,MAXTRY
IF (STATE .EQ. 'S') THEN ! SEND INIT PACKET
CALL SINIT(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
ELSE IF (STATE .EQ. 'F') THEN ! SEND FILE-HEADER PACKET
CALL SFILE(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
ELSE IF (STATE .EQ. 'D') THEN ! SEND FILE-DATA PACKET
CALL SDATA(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
ELSE IF (STATE .EQ. 'Z') THEN ! SEND EOF PACKET
CALL SEOF(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
ELSE IF (STATE .EQ. 'B') THEN ! SEND BREAK (EOT) PACKET
CALL SBREAK(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
ELSE IF (STATE .EQ. 'C') THEN ! COMPLETE
GO TO 900
ELSE IF (STATE .EQ. 'A') THEN ! ABORT
GO TO 800
ELSE
WRITE (*,*) 'FATAL ERROR: INVALID STATE IN "SENDSW"'
STOP
END IF
IF (ISTAT .EQ. 0) GO TO 500
END FOR
CALL SNDERR('too many retries',MXDATA,DATA,NSEQ)
GO TO 800
500 NSEQ = MOD( NSEQ+1, 64 )
GO TO 100
800 IF (DEBUG) WRITE (*,*) '--- ABORT ---'
RETURN
900 IF (DEBUG) WRITE (*,*) '=== SEND COMPLETE ==='
RETURN
END
SUBROUTINE SOPEN(MXDATA,DATA,NDATA,NSEQ,ISTAT)
C---
C--- OPEN FILE TO SEND THEM
C---
INTEGER MXDATA,DATA(*),NDATA,NSEQ,ISTAT
LOGICAL DEBUG
COMMON /DBGCOM/ DEBUG
CHARACTER FILNAM*19
LOGICAL QMARK
INTEGER I
FILNAM = ' '
QMARK = .FALSE.
FOR I=1,MIN( NDATA, LEN(FILNAM) )
FILNAM(I:I) = CHAR( DATA(I) )
IF ( DATA(I) .EQ. ICHAR('?') ) QMARK = .TRUE.
END FOR
C CHECK FOR VALID WILDCARD FILE NAME AND OPEN THE FIRST FILE
IF (QMARK) THEN
CALL SWINIT(FILNAM,MXDATA,DATA,NDATA,NSEQ,ISTAT)
ELSE
CALL SWCLOS()
C CHECK FOR VALID FILE NAME AND OPEN THE FILE
WRITE (*,*) 'OPENING ', FILNAM(1:NDATA), ' FOR SEND'
OPEN (UNIT=50, FILE=FILNAM, STATUS='OLD', IOSTAT=ISTAT)
IF (ISTAT .NE. 0) THEN
CALL SNDERR('can''t find specified file',MXDATA,DATA,NSEQ)
END IF
END IF
END
SUBROUTINE SINIT(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
C---
C--- SEND INIT PACKET AND GET THEIRS IN RESPONSE
C---
CHARACTER STATE*1
INTEGER NUMTRY,MXDATA,DATA(*),NSEQ,ISTAT
INTEGER NDATA,RSEQ
C SEND OUR INIT PACKET
CALL SPAR(MXDATA,DATA,NDATA)
CALL SNDPKT(DATA,NDATA,NSEQ,'S')
C GET THEIR INIT PACKET IN RESPONSE
CALL RCVACK(MXDATA,DATA,NDATA,NSEQ,ISTAT)
IF (ISTAT .LT. 0) GO TO 800 ! RECEIVED ERR
IF (ISTAT .NE. 0) GO TO 810 ! RECEIVED NAK
100 CALL RPAR(DATA,NDATA)
GO TO 900
800 ISTAT = -1 ! ABORT
STATE = 'A'
RETURN
810 ISTAT = 1 ! UNSUCCESSFUL
RETURN
900 ISTAT = 0 ! SUCCESSFUL
STATE = 'F'
RETURN
END
SUBROUTINE SFILE(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
C---
C--- SEND FILE HEADER PACKET
C---
CHARACTER STATE*1
INTEGER NUMTRY,MXDATA,DATA(*),NSEQ,ISTAT
LOGICAL DEBUG
COMMON /DBGCOM/ DEBUG
CHARACTER FILNAM*17
LOGICAL OPENED,NAMED
INTEGER NDATA,MXRCV,C,I
C SEND FILE NAME
IF (NUMTRY .EQ. 1) THEN
INQUIRE (UNIT=50, OPENED=OPENED, NAMED=NAMED, NAME=FILNAM)
IF (.NOT. (OPENED .AND. NAMED) ) THEN
CALL SNDERR('read file error',MXDATA,DATA,NSEQ)
GO TO 800
END IF
NDATA = 0
FOR I=9,16 ! AREANAME
C = ICHAR( FILNAM(I:I) )
DATA(I-8) = C
IF (C .NE. ICHAR(' ')) NDATA = I-8
END FOR
CCC
CCC THE FOLLOWING LINES ARE COMMENTED OUT. THEY CAN BE RESTORED
CCC IF ONE DESIRES TO USE THE FIRST THREE ALPHABETIC CHARACTERS
CCC OF THE QUALIFIER AS THE FILENAME EXTENSION, E.G. FOR DOS MACHINES.
CCC
CCC NDATA = NDATA + 1
CCC DATA(NDATA) = ICHAR('.')
CCC FOR I=5,7 ! PART OF QUALIFIER
CCC C = ICHAR( FILNAM(I:I) )
CCC IF (C .NE. ICHAR(' ')) THEN
CCC NDATA = NDATA + 1
CCC DATA(NDATA) = C
CCC END IF
CCC END FOR
CALL SNDPKT(DATA,NDATA,NSEQ,'F')
ELSE
CALL RESEND
END IF
C GET THEIR RESPONSE
MXRCV = 0
CALL RCVACK(MXRCV,DATA,NDATA,NSEQ,ISTAT)
IF (ISTAT .LT. 0) GO TO 800 ! RECEIVED ERR
IF (ISTAT .NE. 0) GO TO 810 ! RECEIVED NAK
C PREPARE TO READ FILE
CALL RDINIT(ISTAT)
IF (ISTAT .NE. 0) GO TO 910
GO TO 900
800 ISTAT = -1 ! ABORT
STATE = 'A'
RETURN
810 ISTAT = 1 ! UNSUCCESSFUL
RETURN
900 ISTAT = 0 ! SUCCESSFUL
STATE = 'D'
RETURN
910 ISTAT = 0 ! SUCCESSFUL BUT EMPTY FILE
STATE = 'Z'
RETURN
END
SUBROUTINE SDATA(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
C---
C--- SEND FILE DATA PACKET
C---
CHARACTER STATE*1
INTEGER NUMTRY,MXDATA,DATA(*),NSEQ,ISTAT
INTEGER MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME
COMMON /RCVCOM/ MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME
LOGICAL ISCTRL
INTEGER CTL
LOGICAL EOF
INTEGER NDATA,NEWCHR,MXRCV
C GET NEXT PACKETFULL OF DATA AND SEND IT
IF (NUMTRY .EQ. 1) THEN
NDATA = 0
EOF = .FALSE.
C GET NEXT CHARACTER FROM THE DISK FILE
100 IF (EOF .OR. NDATA+2 .GT. MXDATA) GO TO 200
CALL RDISK(NEWCHR,ISTAT)
IF (ISTAT .NE. 0) EOF = .TRUE.
C QUOTE IF SPECIAL CHARACTER, THEN COPY TO THE PACKET BUFFER
IF ( ISCTRL(NEWCHR) .OR. (NEWCHR .EQ. MYQUOT) ) THEN
NDATA = NDATA + 1
DATA(NDATA) = MYQUOT
IF ( NEWCHR .NE. MYQUOT ) NEWCHR = CTL(NEWCHR) SR 9/86
END IF
NDATA = NDATA + 1
DATA(NDATA) = NEWCHR
GO TO 100
200 CALL SNDPKT(DATA,NDATA,NSEQ,'D')
ELSE
CALL RESEND
END IF
C GET THEIR RESPONSE
MXRCV = 0
CALL RCVACK(MXRCV,DATA,NDATA,NSEQ,ISTAT)
IF (ISTAT .LT. 0) GO TO 800 ! RECEIVED ERR
IF (ISTAT .NE. 0) GO TO 810 ! RECEIVED NAK
IF (EOF) GO TO 910
GO TO 900
800 ISTAT = -1 ! ABORT
STATE = 'A'
RETURN
810 ISTAT = 1 ! UNSUCCESSFUL
RETURN
900 ISTAT = 0 ! SUCCESSFUL
RETURN
910 ISTAT = 0 ! SUCCESSFUL AND AT END-OF-FILE
STATE = 'Z'
RETURN
END
SUBROUTINE SEOF(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
C---
C--- SEND END-OF-FILE PACKET
C---
CHARACTER STATE*1
INTEGER NUMTRY,MXDATA,DATA(*),NSEQ,ISTAT
LOGICAL WLDSND
COMMON /SWCOM/ WLDSND
INTEGER NDATA
C CLOSE FILE AND SEND EMPTY "Z" PACKET
IF (NUMTRY .EQ. 1) THEN
CALL RDCLOS
NDATA = 0
CALL SNDPKT(DATA,NDATA,NSEQ,'Z')
ELSE
CALL RESEND
END IF
C GET THEIR RESPONSE
CALL RCVACK(MXDATA,DATA,NDATA,NSEQ,ISTAT)
IF (ISTAT .LT. 0) GO TO 800 ! RECEIVED ERR
IF (ISTAT .NE. 0) GO TO 810 ! RECEIVED NAK
WRITE (*,*) '=SEND OF CURRENT FILE COMPLETE='
C IF THERE ARE MORE FILES TO SEND, OPEN THE NEXT FILE
IF (WLDSND) THEN
CALL SWOPEN(ISTAT)
IF (ISTAT .LT. 0) THEN
CALL SNDERR('can''t find specified file',MXDATA,DATA,NSEQ)
GO TO 800
END IF
END IF
GO TO 900
800 ISTAT = -1 ! ABORT
STATE = 'A'
RETURN
810 ISTAT = 1 ! UNSUCCESSFUL
RETURN
900 ISTAT = 0 ! SUCCESSFUL
IF (WLDSND) THEN
STATE = 'F'
ELSE
STATE = 'B'
END IF
RETURN
END
SUBROUTINE SBREAK(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
C---
C--- SEND END-OF-FILE PACKET
C---
CHARACTER STATE*1
INTEGER NUMTRY,MXDATA,DATA(*),NSEQ,ISTAT
INTEGER NDATA
C SEND EMPTY "B" PACKET
NDATA = 0
CALL SNDPKT(DATA,NDATA,NSEQ,'B')
C GET THEIR RESPONSE
CALL RCVACK(MXDATA,DATA,NDATA,NSEQ,ISTAT)
IF (ISTAT .LT. 0) GO TO 800 ! RECEIVED ERR
IF (ISTAT .NE. 0) GO TO 810 ! RECEIVED NAK
GO TO 900
800 ISTAT = -1 ! ABORT
STATE = 'A'
RETURN
810 ISTAT = 1 ! UNSUCCESSFUL
RETURN
900 ISTAT = 0 ! SUCCESSFUL
STATE = 'C'
RETURN
END
SUBROUTINE RDISK(NEWCHR,ISTAT)
C---
C--- READS A SINGLE CHARACTER FROM A DISK FILE
C---
C--- ENTRY POINT "RDINIT" INITIALIZES
C--- ENTRY POINT "RDCLOS" FINISHES
C---
INTEGER NEWCHR,ISTAT
LOGICAL DEBUG
COMMON /DBGCOM/ DEBUG
INTEGER MAXW,MAXC
PARAMETER (MAXW=100, MAXC=3*MAXW)
INTEGER BUFW(MAXW)
INTEGER*1 BUFC(MAXC+9)
EQUIVALENCE (BUFW,BUFC)
LOGICAL EOF
INTEGER IBUF,NBUF,NBUFW,CR,LF,I
SAVE EOF,BUFW,IBUF,NBUF
DATA EOF /.TRUE./
DATA CR, LF /13, 10/
IF (EOF) THEN
IF (DEBUG) WRITE (*,*) '*FATAL ERROR* RDISK NOT INITIALIZED'
STOP
END IF
C GET NEXT CHARACTER FROM BUFFER
IBUF = IBUF + 1
NEWCHR = BUFC(IBUF)
C SEE IF WE HAVE JUST EMPTIED THE BUFFER
100 IF (IBUF .GE. NBUF) THEN
IBUF = 0
NBUF = 0
C READ NEXT RECORD FROM DISK
BUFFER IN(50,BUFW,S,MAXW,ISTAT,NBUFW)
CALL STATUS(50)
IF (ISTAT .NE. 2 .AND. ISTAT .NE. 3) THEN
IF (DEBUG .AND. ISTAT .NE. 4)
+ WRITE (*,*) 'RDISK: DISK READ ERROR ON BUFFER IN', ISTAT
EOF = .TRUE.
GO TO 800
END IF
C FIND LENGTH TO LAST NON-BLANK
FOR I=NBUFW*3,1,-1
IF (BUFC(I) .NE. ICHAR(' ')) THEN
NBUF = I
EXIT FOR
END IF
END FOR
C APPEND "<EOF>" IF AN EMBEDDED EOF WAS FOUND
IF (ISTAT .EQ. 3) THEN
IF (DEBUG) WRITE (*,*) '(FOUND EMBEDDED EOF)'
IF (NBUF .GT. 0) THEN
NBUF = NBUF + 1
BUFC(NBUF) = CR
NBUF = NBUF + 1
BUFC(NBUF) = LF
END IF
NBUF = NBUF + 1
BUFC(NBUF) = '<'
NBUF = NBUF + 1
BUFC(NBUF) = 'E'
NBUF = NBUF + 1
BUFC(NBUF) = 'O'
NBUF = NBUF + 1
BUFC(NBUF) = 'F'
NBUF = NBUF + 1
BUFC(NBUF) = '>'
END IF
C APPEND CR/LF
NBUF = NBUF + 1
BUFC(NBUF) = CR
NBUF = NBUF + 1
BUFC(NBUF) = LF
END IF
GO TO 900
800 ISTAT = 1 ! EOF OR ERROR (CURRENT CHARACTER IS THE LAST ONE)
RETURN
900 ISTAT = 0 ! SUCCESSFUL
RETURN
C---
C--- INITIALIZE AND READ FIRST RECORD
C---
ENTRY RDINIT(ISTAT)
IBUF = 0
NBUF = 0
EOF = .FALSE.
GO TO 100
C---
C--- CLOSE FILE
C---
ENTRY RDCLOS
IF (.NOT. EOF) THEN
IF (DEBUG) WRITE (*,*) '*WARNING* SENT INCOMPLETE FILE'
NBUF = 0
END IF
CLOSE (UNIT=50)
RETURN
END
SUBROUTINE SWINIT(AREANM,MXDATA,DATA,NDATA,NSEQ,ISTAT)
C---
C--- ASSEMBLE A LIST OF NAMES OF FILES TO SEND IN RESPONSE TO A
C--- "GET" COMMAND CONTAINING WILDCARD CHARACTERS
C---
CHARACTER AREANM*(*)
INTEGER MXDATA,DATA(*),NDATA,NSEQ,ISTAT
CHARACTER DIRFIL*17, ERRMSG*80
LOGICAL SIZEORD
INTEGER LFN,NARGC,NEWCHR,I
DATA DIRFIL /'W1'/
DATA LFN /99/
C CONVERT THE FILE NAME TO UPPER CASE
NARGC = MIN( NDATA, LEN(AREANM) )
FOR I=1,NARGC
NEWCHR = ICHAR( AREANM(I:I) )
IF (NEWCHR .GT. ICHAR('a') .AND. NEWCHR .LT. ICHAR('z') ) THEN
NEWCHR = NEWCHR - ICHAR('a') + ICHAR('A')
AREANM(I:I) = CHAR( NEWCHR )
END IF
END FOR
C OPEN A DIRECTORY WORKFILE
OPEN (UNIT=LFN, FILE=DIRFIL, STATUS='OLD', IOSTAT=ISTAT)
IF (ISTAT .NE. 0) GO TO 810
REWIND (UNIT=LFN)
C WRITE DIRECTORY INFORMATION TO THE WORKFILE
SIZEORD = .FALSE.
CALL DIR(LFN,AREANM,NARGC,SIZEORD,ERRMSG,ISTAT)
IF (ISTAT .NE. 0) GO TO 800
C PREPARE TO SEND THE FIRST FILE
REWIND (UNIT=LFN)
CALL SWOPEN(ISTAT)
IF (ISTAT .NE. 0) GO TO 820
GO TO 900
800 CALL SNDERR(ERRMSG,MXDATA,DATA,NSEQ)
CLOSE (UNIT=LFN)
RETURN
810 CALL SNDERR('directory workfile inaccessable',MXDATA,DATA,NSEQ)
RETURN
820 CALL SNDERR('file not accessible',MXDATA,DATA,NSEQ)
RETURN
900 RETURN
END
SUBROUTINE SWOPEN(ISTAT)
C---
C--- OPEN THE NEXT FILE IN A LIST OF FILES TO SEND
C---
INTEGER ISTAT
CHARACTER FILNAM*19, BUF*80
INTEGER LFN
LOGICAL WLDSND
COMMON /SWCOM/ WLDSND
DATA LFN /99/
C READ NEXT ENTRY FROM THE FILE NAME LIST
DO
READ (LFN, '(A)', END=800) BUF
UNTIL ( BUF(9:9) .EQ. '*' .OR. BUF(16:16) .EQ. '*' )
IF ( BUF(9:9) .EQ. '*' ) THEN
FILNAM = '"' // BUF(1:17) // '"'
ELSE
FILNAM = '"' // BUF(8:24) // '"'
END IF
WRITE (*,*) 'OPENING ', FILNAM, ' FOR SEND'
OPEN (UNIT=50, FILE=FILNAM, STATUS='OLD', IOSTAT=ISTAT)
IF (ISTAT .NE. 0) GO TO 810
GO TO 900
800 ISTAT = 1 ! NO MORE FILE NAMES IN LIST
CALL SWCLOS()
WLDSND = .FALSE.
RETURN
810 ISTAT = -1 ! FILE OPEN UNSUCCESFUL
WLDSND = .FALSE.
RETURN
900 ISTAT = 0 ! FILE OPEN SUCCESFUL
WLDSND = .TRUE.
END
SUBROUTINE SWCLOS()
C---
C--- CLOSE THE FILE CONTAINING THE LIST OF FILES TO SEND
C---
INTEGER LFN
LOGICAL WLDSND
COMMON /SWCOM/ WLDSND
DATA LFN /99/
C IF THE FILE IS OPEN, CLOSE IT
IF (WLDSND) THEN
CLOSE (UNIT=LFN)
WLDSND = .FALSE.
END IF
END
C RECEIVE SUBROUTINES
C
C RECVSW -- PACKET TYPE SWITCHER FOR RECEIVING FILES
C RINIT -- EXCHANGE SEND/RECEIVE INFO WITH SENDING KERMIT
C RFILE -- RECIEVES FILE NAME AND CREATES RECEIVE FILE
C RDATA -- RECEIVES FILE CONTENTS FROM SENDING KERMIT
C REOF -- RECEIVES "END-OF-FILE" PACKET FROM SENDING KERMIT
C RBREAK -- RECEIVES "BREAK" PACKET FROM SENDING KERMIT
C WDISK -- WRITES A SINGLE CHARACTER TO A DISK FILE
C ENPAD -- PADS OUTPUT RECORD TO A WORD BOUNDARY
C DELFIL -- DELETES A FILE PARTIALLY RECEIVED
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
SUBROUTINE RECVSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY)
C---
C--- THIS IS THE PACKET TYPE SWITCHER FOR RECEIVING FILES.
C--- IT LOOPS UNTIL EITHER IT IS FINISHED OR A FAULT IS ENCOUNTERED.
C---
INTEGER MXDATA,DATA(*),NDATA,NSEQ,MAXTRY
LOGICAL DEBUG
COMMON /DBGCOM/ DEBUG
LOGICAL FILOPN
INTEGER NUMTRY,OLDSEQ,ISTAT
CHARACTER STATE*1,TYPE*1
STATE = 'I'
TYPE = 'I'
FILOPN = .FALSE.
OLDSEQ = NSEQ
100 IF (TYPE .EQ. 'I') THEN ! GOT INIT PACKET
CALL RINIT(STATE,MXDATA,DATA,NDATA,NSEQ)
ELSE IF (TYPE .EQ. 'F') THEN ! GOT FILE-HEADER PACKET
CALL RFILE(STATE,MXDATA,DATA,NDATA,NSEQ,ISTAT)
IF (ISTAT .EQ. 0) FILOPN = .TRUE.
ELSE IF (TYPE .EQ. 'D') THEN ! GOT FILE-DATA PACKET
CALL RDATA(STATE,MXDATA,DATA,NDATA,NSEQ)
ELSE IF (TYPE .EQ. 'Z') THEN ! GOT EOF PACKET
CALL REOF(STATE,MXDATA,DATA,NDATA,NSEQ,ISTAT)
IF (ISTAT .EQ. 0) FILOPN = .FALSE.
ELSE IF (TYPE .EQ. 'B') THEN ! GOT BREAK PACKET
CALL RBREAK(STATE,MXDATA,DATA,NDATA,NSEQ)
ELSE IF (TYPE .EQ. 'E') THEN ! GOT ERROR PACKET
NDATA = 0
CALL SNDACK(DATA,NDATA,NSEQ)
STATE = 'A'
ELSE
IF (DEBUG) WRITE (*,*) 'INVALID PACKET TYPE'
STATE = 'A'
END IF
IF (STATE .EQ. 'A') GO TO 800 ! ABORT
IF (STATE .EQ. 'C') GO TO 900 ! COMPLETE
C RECEIVE A NEW PACKET
FOR NUMTRY=1,MAXTRY
CALL RCVPKT(MXDATA,DATA,NDATA,NSEQ,TYPE,ISTAT)
IF (ISTAT .EQ. 0) THEN
C GOT THE RIGHT PACKET?
CCC IF (NSEQ .EQ. MOD( OLDSEQ+1, 64 ) ) THEN SR11/86
IF (NSEQ .EQ. MOD( OLDSEQ+1, 64 ) .OR. TYPE .EQ. 'E') THEN SR11/86
OLDSEQ = NSEQ
GO TO 100
C NO. GOT PREVIOUS PACKET AGAIN BY MISTAKE?
ELSE IF (NSEQ .EQ. OLDSEQ) THEN
IF (NUMTRY .LT. MAXTRY) CALL RESEND
GO TO 200
END IF
END IF
C NO. NAK IT AND TRY AGAIN UP TO MAXTRY TIMES
IF (NUMTRY .LT. MAXTRY) CALL SNDNAK(NSEQ)
200 CONTINUE
END FOR
CALL SNDERR('too many retries',MXDATA,DATA,NSEQ)
GO TO 800
800 IF (DEBUG) WRITE (*,*) '--- ABORT ---'
IF (FILOPN) CALL DELFIL ! ERASE PARTIAL FILE
RETURN
900 IF (DEBUG) WRITE (*,*) '=== RECEIVE COMPLETE ==='
RETURN
END
SUBROUTINE RINIT(STATE,MXDATA,DATA,NDATA,NSEQ)
C---
C--- GOT RECEIVE-INIT PACKET, RESPOND WITH ACK AND OUR PARAMETERS
C---
CHARACTER STATE*1
INTEGER MXDATA,DATA(*),NDATA,NSEQ
CALL INIT(MXDATA,DATA,NDATA,NSEQ)
STATE = 'F'
END
SUBROUTINE RFILE(STATE,MXDATA,DATA,NDATA,NSEQ,ISTAT)
C---
C--- GOT FILE HEADER PACKET, CREATE THE SPECIFED FILE
C---
CHARACTER STATE*1
INTEGER MXDATA,DATA(*),NDATA,NSEQ,ISTAT
LOGICAL DEBUG
COMMON /DBGCOM/ DEBUG
LOGICAL WRKFIL
CHARACTER FILNAM*40
INTEGER IDOT,IAST,I
IF (STATE .NE. 'F') THEN
CALL SNDERR('not expecting F packet',MXDATA,DATA,NSEQ)
GO TO 800
END IF
C ASSEMBLE HARRIS FILE NAME
FILNAM = ' '
IDOT = 0
IAST = 0
NDATA = MIN( NDATA, MXDATA, LEN(FILNAM) )
FOR I=1,NDATA
FILNAM(I:I) = CHAR( DATA(I) )
IF (FILNAM(I:I) .EQ. '.') IDOT = I
IF (FILNAM(I:I) .EQ. '*') IAST = I
END FOR
IF (IDOT .GT. 0 .AND. IAST .EQ. 0) THEN
C TRANSLATE IBM-PC STYLE FILENAME
IF (IDOT .EQ. NDATA) THEN
NDATA = MIN( 8, IDOT-1 )
ELSE IF (NDATA .GT. 8) THEN
NDATA = 8
IF (IDOT .GT. 7) FILNAM(7:8) = '.' // CHAR( DATA(IDOT+1) )
END IF
END IF
C MAKE SURE THE FILE NAME IS VALID AND RESPOND
WRITE (*,*) 'OPENING FILE ', FILNAM(1:NDATA), ' FOR RECEIVE'
OPEN(UNIT=50, FILE=FILNAM(1:NDATA), STATUS='OLD', IOSTAT=ISTAT)
IF (ISTAT .EQ. 0) THEN
IF (WRKFIL(50)) GO TO 200
CLOSE (UNIT=50)
CALL SNDERR( FILNAM(1:NDATA) // ' exists', MXDATA,DATA,NSEQ)
GO TO 800
END IF
OPEN(UNIT=50, FILE=FILNAM(1:NDATA), STATUS='NEW', IOSTAT=ISTAT)
IF (ISTAT .NE. 0) THEN
C CAN'T CREATE FILE
CALL SNDERR( 'filename ' // FILNAM(1:NDATA) // ' is invalid',
+ MXDATA,DATA,NSEQ)
GO TO 800
END IF
200 CALL WDINIT
NDATA = 0
CALL SNDACK(DATA,NDATA,NSEQ)
GO TO 900
800 ISTAT = -1
STATE = 'A'
RETURN
900 ISTAT = 0
STATE = 'D'
RETURN
END
SUBROUTINE RDATA(STATE,MXDATA,DATA,NDATA,NSEQ)
C---
C--- GOT DATA PACKET, WRITE TO FILE
C---
CHARACTER STATE*1
INTEGER MXDATA,DATA(*),NDATA,NSEQ
INTEGER MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
COMMON /SNDCOM/ MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
INTEGER CTL
INTEGER IDATA,NEWCHR
IF (STATE .NE. 'D') THEN
CALL SNDERR('not expecting D packet',MXDATA,DATA,NSEQ)
GO TO 800
END IF
C UNPACK DATA AND WRITE TO FILE
IDATA = 0
C EXTRACT NEXT CHARACTER OF DATA FROM PACKET
100 IF (IDATA .GE. NDATA) GO TO 200
IDATA = IDATA + 1
NEWCHR = DATA(IDATA)
IF (NEWCHR .EQ. NSQUOT) THEN ! UNCONTROLLIFY QUOTED CHARACTER
IF (IDATA .LT. NDATA) THEN
IDATA = IDATA + 1
NEWCHR = DATA(IDATA)
IF (NEWCHR .NE. NSQUOT) NEWCHR = CTL( NEWCHR )
END IF
END IF
C TRANSFER IT TO THE DISK FILE
CALL WDISK(NEWCHR)
GO TO 100
200 NDATA = 0
CALL SNDACK(DATA,NDATA,NSEQ)
GO TO 900
800 STATE = 'A'
RETURN
900 STATE = 'D'
RETURN
END
SUBROUTINE REOF(STATE,MXDATA,DATA,NDATA,NSEQ,ISTAT)
C---
C--- GOT EOF PACKET, CLOSE FILE
C---
CHARACTER STATE*1
INTEGER MXDATA,DATA(*),NDATA,NSEQ,ISTAT
IF (STATE .EQ. 'F') GO TO 100
IF (STATE .NE. 'D') THEN
CALL SNDERR('not expecting Z packet',MXDATA,DATA,NSEQ)
GO TO 800
END IF
C HANDLE SPECIAL Z PACKET INSTRUCTING US TO DISCARD CURRENT FILE
IF (NDATA .EQ. 1 .AND. DATA(1) .EQ. ICHAR('D') ) THEN
CALL DELFIL
ELSE
CALL WDCLOS
WRITE (*,*) '=RECEIVE OF CURRENT FILE COMPLETE='
END IF
100 NDATA = 0
CALL SNDACK(DATA,NDATA,NSEQ)
GO TO 900
800 ISTAT = -1
STATE = 'A'
RETURN
900 ISTAT = 0
STATE = 'F'
RETURN
END
SUBROUTINE RBREAK(STATE,MXDATA,DATA,NDATA,NSEQ)
C---
C--- GOT BREAK PACKET, WE'RE DONE
C---
CHARACTER STATE*1
INTEGER MXDATA,DATA(*),NDATA,NSEQ
IF (STATE .NE. 'F') THEN
CALL SNDERR('not expecting B packet',MXDATA,DATA,NSEQ)
GO TO 800
END IF
NDATA = 0
CALL SNDACK(DATA,NDATA,NSEQ)
GO TO 900
800 STATE = 'A'
RETURN
900 STATE = 'C'
RETURN
END
SUBROUTINE WDISK(NEWCHR)
C---
C--- WRITES A CHARACTER TO A DISK FILE
C---
C--- ENTRY POINT "WDINIT" INITIALIZES
C--- ENTRY POINT "WDCLOS" FINISHES
C---
INTEGER NEWCHR
LOGICAL DEBUG
COMMON /DBGCOM/ DEBUG
INTEGER MAXW,MAXC
PARAMETER (MAXW=100, MAXC=3*MAXW)
INTEGER BUFW(MAXW)
INTEGER*1 BUFC(MAXC)
EQUIVALENCE (BUFW,BUFC)
INTEGER NBUF,CR,LF,I
SAVE BUFW,NBUF
DATA CR, LF /13, 10/
IF (NEWCHR .EQ. CR) THEN
C WRITE COMPLETED RECORD
CALL ENPAD(BUFC,NBUF)
WRITE (50,'(100A3)') (BUFW(I), I=1,NBUF/3)
NBUF = 0
ELSE IF (NEWCHR .EQ. LF .AND. NBUF .EQ. 0) THEN
C IGNORE LINEFEED FROM A CR/LF PAIR
ELSE
C ADD CHARACTER TO RECORD BUFFER
NBUF = NBUF + 1
BUFC(NBUF) = NEWCHR
END IF
RETURN
C---
C--- INITIALIZE CHARACTER COUNT
C---
ENTRY WDINIT()
NBUF = 0
RETURN
C---
C--- WRITE LAST RECORD IF INCOMPLETE AND CLOSE FILE
C---
ENTRY WDCLOS()
IF (NBUF .GT. 0) THEN
IF (DEBUG) WRITE (*,*) '*WARNING* NO EOL FOUND ON LAST RECORD'
CALL ENPAD(BUFC,NBUF)
WRITE (50,'(100A3)') (BUFW(I), I=1,NBUF/3)
NBUF = 0
END IF
CLOSE (UNIT=50)
RETURN
END
SUBROUTINE ENPAD(BUFC,NBUF)
C---
C--- PAD OUTPUT RECORD TO WORD BOUNDARY WITH BLANKS
C---
INTEGER*1 BUFC(*)
INTEGER NBUF
INTEGER I
FOR I=MOD(NBUF+2,3),1
NBUF = NBUF + 1
BUFC(NBUF) = ICHAR(' ')
END FOR
END
SUBROUTINE DELFIL
C---
C--- ERASE PARTIAL FILE ---NOT IMPLEMENTED YET---
C---
WRITE (*,*) '-CURRENT RECEIVE CANCELLED-'
CLOSE (UNIT=50)
END
C REMOTE COMMAND SUBROUTINES
C
C COMMND -- REMOTE COMMAND HANDLER, CALLS THE FOLLOWING:
C HELP -- SENDS USAGE INFORMATION TO RECEIVING KERMIT
C LOGOUT -- PREPARES TO SIGN THE CURRENT USER OFF THE SYSTEM
C FINISH -- PREPARES TO EXIT KERMIT SERVER
C DIRECT -- SENDS DIRECTORY INFORMATION TO RECEIVING KERMIT
C CMDARG -- EXTRACT A COMMAND ARGUMENT FROM PACKET
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
SUBROUTINE COMMND(MXDATA,DATA,NDATA,NSEQ,MAXTRY,ISTAT)
C---
C--- MAIN ROUTINE HANDLING REMOTE COMMANDS
C---
INTEGER MXDATA,DATA(*),NDATA,NSEQ,MAXTRY,ISTAT
LOGICAL DEBUG
COMMON /DBGCOM/ DEBUG
CHARACTER*1 CMD
C GET THE COMMAND
IF (NDATA .LE. 0) GO TO 900
CMD = CHAR( DATA(1) )
IF (CMD .EQ. 'H') THEN ! HELP
CALL HELP(MAXTRY,MXDATA,DATA)
ELSE IF (CMD .EQ. 'L') THEN ! LOGOUT
CALL LOGOUT(MAXTRY,MXDATA,DATA)
GO TO 800
ELSE IF (CMD .EQ. 'F') THEN ! FINISH
CALL FINISH(MAXTRY,MXDATA,DATA)
GO TO 800
ELSE IF (CMD .EQ. 'D') THEN ! DIRECTORY
CALL DIRECT(MAXTRY,MXDATA,DATA,NDATA)
ELSE
CALL SNDERR('remote command not implemented',MXDATA,DATA,NSEQ)
END IF
GO TO 900
800 ISTAT = 1 ! RETURN THEN EXIT PROGRAM
RETURN
900 ISTAT = 0 ! NORMAL RETURN
RETURN
END
SUBROUTINE HELP(MAXTRY,MXDATA,DATA)
C---
C--- SEND FILE CONTAINING USAGE INFORMATION
C---
INTEGER MAXTRY,MXDATA,DATA(*)
CHARACTER HLPFIL*17
INTEGER NDATA,NSEQ,PREFIX
DATA HLPFIL /'2000KERM*HARRIS'/
PREFIX = 0
CALL PUTDAT(HLPFIL,PREFIX,MXDATA,DATA,NDATA)
NSEQ = 0
CALL SENDSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY)
RETURN
END
SUBROUTINE LOGOUT(MAXTRY,MXDATA,DATA)
C---
C--- SEND CONFIRMATION MESSAGE AND DO A JOBCNTRL $OFF
C---
INTEGER MAXTRY,MXDATA,DATA(*)
LOGICAL DEBUG
COMMON /DBGCOM/ DEBUG
INTEGER NWORDS
PARAMETER (NWORDS=2)
INTEGER VOSCMD(NWORDS)
CHARACTER MSG*80
INTEGER NSEQ,USER(4),PREFIX,NDATA,ISTAT
NSEQ = 0
C PUT JOBCNTRL $OFF COMMAND IN LFN 0 BUFFER
VOSCMD(1) = 3H$OF
VOSCMD(2) = 3HF
CALL BKSTOR(0,VOSCMD,NWORDS,ISTAT)
IF (ISTAT .NE. 0) THEN
CALL SNDERR('unable to sign off',MXDATA,DATA,NSEQ)
RETURN
END IF
BACKSPACE (UNIT=0)
C COPY LOGOUT MESSAGE INTO DATA ARRAY
CALL USERNO( USER )
WRITE (MSG,1000) USER
1000 FORMAT ('SEE YOU LATER, ',4A3)
PREFIX = 1
CALL PUTDAT(MSG,PREFIX,MXDATA,DATA,NDATA)
C ACK WITH OUR CONFIRMATION MESSAGE
CALL SNDACK(DATA,NDATA,NSEQ)
END
SUBROUTINE FINISH(MAXTRY,MXDATA,DATA)
C---
C--- SEND CONFIRMATION MESSAGE AND EXIT PROGRAM
C---
INTEGER MAXTRY,MXDATA,DATA(*)
LOGICAL DEBUG
COMMON /DBGCOM/ DEBUG
INTEGER NSEQ,PREFIX,NDATA
C COPY EXIT MESSAGE INTO DATA ARRAY
PREFIX = 1
CALL PUTDAT('returning to JOBCNTRL',PREFIX,MXDATA,DATA,NDATA)
C ACK WITH OUR CONFIRMATION MESSAGE
NSEQ = 0
CALL SNDACK(DATA,NDATA,NSEQ)
END
SUBROUTINE DIRECT(MAXTRY,MXDATA,DATA,NDATA)
C---
C--- SEND DIRECTORY INFORMATION ABOUT A SINGLE DISK AREA
C---
INTEGER MAXTRY,MXDATA,DATA(*),NDATA
CHARACTER DIRFIL*17, AREANM*19, ERRMSG*80
LOGICAL SIZEORD
INTEGER LFN,NSEQ,ICOL,NARGC,PREFIX,ISTAT,I
DATA DIRFIL /'W1'/
DATA LFN /99/
C GET FILE NAME, OPTIONALLY CONTAINING WILDCARD CHARACTERS
IF (NDATA .EQ. 1) THEN
NARGC = 0
ELSE
ICOL = 2
CALL CMDARG(ICOL, DATA,NDATA, DATA,NARGC, ISTAT)
IF (ISTAT .NE. 0) GO TO 820
END IF
NARGC = MIN( NARGC, LEN(AREANM) )
AREANM = ' '
FOR I=1,NARGC
AREANM(I:I) = CHAR( DATA(I) )
END FOR
C OPEN A DIRECTORY WORKFILE
OPEN (UNIT=LFN, FILE=DIRFIL, STATUS='OLD', IOSTAT=ISTAT)
IF (ISTAT .NE. 0) GO TO 810
REWIND (UNIT=LFN)
C WRITE DIRECTORY INFORMATION TO THE WORKFILE
SIZEORD = .FALSE.
CALL DIR(LFN,AREANM,NARGC,SIZEORD,ERRMSG,ISTAT)
IF (ISTAT .NE. 0) GO TO 800
CLOSE (UNIT=LFN)
C INVOKE THE SEND SWITCHER TO SEND THE WORKFILE
PREFIX = 0
CALL PUTDAT(DIRFIL,PREFIX,MXDATA,DATA,NDATA)
NSEQ = 0
CALL SENDSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY)
GO TO 900
800 CALL SNDERR(ERRMSG,MXDATA,DATA,NSEQ)
RETURN
810 CALL SNDERR('directory workfile inaccessable',MXDATA,DATA,NSEQ)
RETURN
820 CALL SNDERR('invalid command format',MXDATA,DATA,NSEQ)
RETURN
900 RETURN
END
SUBROUTINE CMDARG(ICOL, DATA,NDATA, ARG,NARGC, ISTAT)
C---
C--- EXTRACT A LENGTH-ENCODED ARGUMENT FROM DATA FIELD
C---
INTEGER ICOL,DATA(*),NDATA,ARG(*),NARGC,ISTAT
INTEGER MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
COMMON /SNDCOM/ MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
INTEGER CTL,UNCHAR
INTEGER IDATA,IARGC,NEWCHR
C READ STARTING AT CHARACTER POSITION <ICOL> IN ARRAY <DATA>
NARGC = 0
IDATA = ICOL
C GET NEXT CHARACTER FROM <DATA>, UNCONTROLLIFYING AS NECESSARY
100 IF (IDATA .GT. NDATA) GO TO 800
NEWCHR = DATA(IDATA)
IDATA = IDATA + 1
IF (NEWCHR .EQ. NSQUOT) THEN
IF (IDATA .GT. NDATA) GO TO 800
NEWCHR = DATA(IDATA)
IDATA = IDATA + 1
IF (NEWCHR .NE. NSQUOT) NEWCHR = CTL( NEWCHR )
END IF
C CONVERT TO UPPER CASE
IF (NEWCHR .GT. ICHAR('a') .AND. NEWCHR .LT. ICHAR('z') ) THEN
NEWCHR = NEWCHR - ICHAR('a') + ICHAR('A')
END IF
C FIRST CHARACTER IS LENGTH CODE
IF (NARGC .EQ. 0) THEN
IARGC = 0
NARGC = UNCHAR( NEWCHR )
C COPY SUBSEQUENT CHARACTERS TO <ARG>
ELSE
IARGC = IARGC + 1
ARG(IARGC) = NEWCHR
END IF
C RETURN THE RESULT OF LENGTH <NARGC> IN ARRAY <ARG>
IF (IARGC .GE. NARGC) THEN
IF (IDATA .GT. NDATA) GO TO 900
GO TO 810
END IF
GO TO 100
800 ISTAT = -1 ! CAN'T DECODE ARGUMENT (INVALID LENGTH CODE)
RETURN
810 ISTAT = 1 ! SUCCESSFUL RETURN, MORE ARGUMENTS REMAIN
RETURN
900 ISTAT = 0 ! SUCCESSFUL RETURN, THIS IS LAST ARGUMENT
RETURN
END
SUBROUTINE DIR(LFN,AREANM,NC,SIZEORD,ERRMSG,ISTAT)
C
C CHECKS ALL AREANAMES AGAINST MATCH STRING, SAVING NECESSARY INFO
C ON THOSE WHICH MATCH IN COMMON. WRITES RESULTS TO SPECIFIED LFN.
C
C ARGUMENTS:
C LFN -- LOGICAL UNIT TO WRITE RESULTS
C AREANM -- INPUT AREANAME, OPTIONALLY CONTAINING WILDCARDS
C NC -- NUMBER OF CHARACTERS IN AREANM
C SIZEORD -- LOGICAL VARIABLE INDICATING ORDER BY SIZE IF TRUE
C ERRMSG -- TEXT STRING IDENTIFYING ERROR IF ISTAT NON-ZERO
C ISTAT -- ZERO=SUCCESSFUL COMPLETION; NON-ZERO=ERROR
C
INTEGER LFN, NC, ISTAT
CHARACTER AREANM*(*), ERRMSG*(*)
LOGICAL SIZEORD
C
INTEGER MXMAP
PARAMETER (MXMAP=999)
CHARACTER NAME*17, TYPE*3, RWXD*11, OWNER*12
INTEGER SIZE, GRAN, NLINK, NFILES, IFIRST
INTEGER MAXS, EL(6),GE(6),LA(6),LW(6)
COMMON /MAPDAT/ NAME(MXMAP), TYPE(MXMAP), RWXD(MXMAP),
+ OWNER(MXMAP), SIZE(MXMAP), NLINK(MXMAP), NFILES, IFIRST
C
INTEGER NTOT, IPREV, INEXT
INTEGER NCHARS, ISTAR, IWILD, I
REAL KBYTES
C
C INITIALIZE FILE LIST
C
NFILES = 0
IFIRST = 0
NTOT = 0
C
C PARSE MATCH STRING TO DETERMINE IF MORE THAN ONE AREANAME IS INVOLVED
C
NCHARS = 0
ISTAR = 0
IWILD = 0
FOR I=1,NC ! FIND SPECIAL CHARACTERS
IF (AREANM(I:I) .NE. ' ') THEN
NCHARS = I
IF (AREANM(I:I) .EQ. '*') ISTAR = I
IF (IWILD .EQ. 0 .AND.
+ AREANM(I:I) .EQ. '?') IWILD = I
END IF
END FOR
IF (ISTAR .EQ. NCHARS) THEN ! DEFAULT AREANAME IS ?
NCHARS = NCHARS + 1
AREANM(NCHARS:NCHARS) = '?'
IF (IWILD .EQ. 0) IWILD = I
END IF
C
C IF ONLY A SINGLE AREANAME IS INDICATED, DO IT NOW
C
IF (IWILD .EQ. 0) THEN
CALL MAP(AREANM,
+ NAME(1),TYPE(1),RWXD(1),SIZE(1),GRAN,MAXS,OWNER(1),
+ EL,GE,LA,LW, ISTAT)
IF (ISTAT .EQ. 0) THEN
KBYTES = SIZE(1) * 336.0 / 1024.0
WRITE (LFN,1100) NAME(1),OWNER(1),TYPE(1),RWXD(1),KBYTES,
+ GE,LW,LA
1100 FORMAT (7X,A, T40,'OWNER: ',A,
+ /'TYPE: ',A, 7X,'ACCESS: 'A, T40,'SIZE (KBYTES):',F7.1,
+ /'CREATED: ', 6A3,
+ /'LAST UPDATED: ', 6A3,
+ /'LAST ACCESSED: ', 6A3)
GO TO 900
ELSE
ERRMSG = '*disc area not found*'
GO TO 800
END IF
END IF
C
C MAKE SURE THEY DIDN'T WILDCARD ONLY PART OF THE QUALIFIER
C
IF (IWILD .LT. ISTAR .AND. ISTAR .NE. 2) THEN
ERRMSG =
+ '*error* invalid qualifier, use "?*" for all qualifiers'
GO TO 800
END IF
C
C INITIALIZE THE CALL TO MAPWILD
C
CALL MAPINIT(AREANM(1:NCHARS),ISTAT)
IF (ISTAT .NE. 0) THEN
ERRMSG = '*error* invalid qualifier or areaname'
GO TO 800
END IF
C
C LOOP THROUGH ALL FILES
C
NTOT = 0
LOOP
I = NFILES + 1
CALL MAPWILD(
+ NAME(I),TYPE(I),RWXD(I),SIZE(I),GRAN,MAXS,OWNER(I),
+ EL,GE,LA,LW, ISTAT)
IF (ISTAT .LT. 0) THEN
EXIT LOOP IF (ISTAT .EQ. -2)
WRITE (LFN,*) '*error* disc I/O error mapping file'
GO TO 300
END IF
C
C IF IT MATCHED, LINK INTO THE LIST IN SORTED ORDER
C
NTOT = NTOT + 1
IF (ISTAT .NE. 0) GO TO 200
NFILES = I
IPREV = 0
INEXT = IFIRST
WHILE (INEXT .GT. 0)
IF (SIZEORD) THEN ! ORDER BY SIZE
EXIT WHILE IF ( SIZE(INEXT) .GT. SIZE(NFILES) )
EXIT WHILE IF ( SIZE(INEXT) .EQ. SIZE(NFILES)
+ .AND. NAME(INEXT) .GE. NAME(NFILES) )
ELSE ! ORDER BY NAME
EXIT WHILE IF (NAME(INEXT) .GE. NAME(NFILES))
END IF
IPREV = INEXT
INEXT = NLINK(INEXT)
END WHILE
C WE FOUND WHERE IT GOES, NOW LINK IT IN
IF (IPREV .LE. 0) THEN ! INSERT AT ROOT OF LIST
NLINK(NFILES) = IFIRST
IFIRST = NFILES
ELSE ! INSERT INTO LIST
NLINK(NFILES) = INEXT
NLINK(IPREV) = NFILES
END IF
200 CONTINUE
300 END LOOP
C
C WRITE SORTED RESULTS TO SPECIFIED UNIT
C
IF (NFILES .LT. 1) THEN
ERRMSG = '*disc area not found*'
GO TO 800
END IF
WRITE (LFN,1500)
I = IFIRST
WHILE (I .GT. 0)
KBYTES = SIZE(I) * 336.0 / 1024.0
WRITE (LFN,1510) NAME(I),TYPE(I),RWXD(I),KBYTES,OWNER(I)
I = NLINK(I)
END WHILE
IF (NTOT .GT. NFILES) WRITE (LFN,1520) NFILES, NTOT
1500 FORMAT (4X,'AREANAME', 7X,'TYPE', 4X,'ACCESS',
+ 6X,'KBYTES', 4X,'OWNER')
1510 FORMAT (A, 2X,A, 3X,A, F8.1, 5X,A)
1520 FORMAT (/I4, ' files matched of', I5)
GO TO 900
800 ISTAT = -1
RETURN
900 ISTAT = 0
RETURN
END
INTEGER FUNCTION ICOMP(MATCH,NM,STRING,NS)
C
C COMPARES A MATCH STRING, CONTAINING WILDCARD CHARACTERS, WITH AN
C OBJECT STRING. RETURNS 0 IF MATCH SUCCEDED, 1 OTHERWISE
C
CHARACTER MATCH, STRING ! MATCH AND COMPARE STRINGS
INTEGER NM, NS ! LENGTHS OF ABOVE
C
CHARACTER C*1 ! CURRENT MATCH CHARACTER
LOGICAL AT ! SET IF LAST CHARACTER WAS ?
INTEGER M ! MATCH STRING POINTER
INTEGER S ! COMPARE STRING POINTER
INTEGER LM ! POINTER TO LAST ? PROCESSED
INTEGER LS ! S AFTER LAST ?
INTEGER J
C
C INITIALIZE
C
ICOMP = 1 ! ASSUME NO MATCH
M = 1
S = 1
LM = 0
LS = 0
AT = .FALSE.
C
C LOOP THROUGH MATCH CHARACTERS
C
10 WHILE (M .LE. NM)
C = MATCH(M:M) ! GET CURRENT MATCH CHARACTER
C
C HANDLE ? CHARACTER
C
IF (C .EQ. '?') THEN
AT = .TRUE.
LM = M
C
C HANDLE OTHER CHARACTERS
C
ELSE
IF (S .GT. NS) RETURN ! NO MORE CHARS IN SUBSTRING
IF (AT) THEN ! SKIP UNKNOWN CHARACTERS
J = INDEX(STRING(S:NS),C)
IF (J .EQ. 0) RETURN
S = S + J
LS = S
AT = .FALSE.
ELSE ! CHECK FOR EXACT MATCH
IF (C .EQ. STRING(S:S)) THEN
S = S + 1
ELSE ! NO MATCH
IF (LS .GT. 0) THEN
M = LM
S = LS
GO TO 10 ! BACK UP TO ?+1 AND TRY AGAIN
ELSE
RETURN
END IF
END IF
END IF
END IF
M = M + 1
END WHILE
C
C MAKE SURE ANY REMAINING CHARACTERS IN STRING ARE TRAILING BLANKS
C
IF (.NOT. AT) THEN
IF (S .LE. NS) THEN
IF (STRING(S:NS) .NE. ' ') THEN
M = LM
S = LS
GO TO 10 ! BACK UP TO ?+1 AND TRY AGAIN
END IF
END IF
END IF
ICOMP = 0 ! SUCCESSFUL MATCH
END
SUBROUTINE MAPINIT(AREANM,ISTAT),
+ MAPWILD(NAME,TYPE,RWXD,SIZE,GRAN,MAXS,OWNER,
+ ELDATE,GEDATE,LADATE,LWDATE,ISTAT)
C
C MAPWILD FORTRAN 77 / ASSEMBLER
C WRITTEN BY SKIP RUSSELL APRIL, 1983
C
C SUBROUTINE TO RETURN INFORMATION ABOUT ALL DISK AREAS WHICH
C SUCCESSFULLY MATCH A "WILDCARD" AREANAME STRING.
C
C THE QUALIFIER OF THE MATCH STRING, IF SPECIFIED, DETERMINES
C THE MAPPING OPERATION TO PERFORM AS FOLLOWS:
C
C NO QUALIFIER SPECIFIED -- SEARCH FILES UNDER CURRENT QUALIFIER
C VALID QUALIFIER -- SEARCH FILES UNDER SPECIFIED QUALIFIER
C QUALIFIER = "?" -- SEARCH ALL FILES OWNED BY CURRENT USER
C
C
C MAPINIT: (INITIALIZATION FOR MAPWILD)
C INPUT ARGUMENTS:
C AREANM -- AREA NAME TO MATCH CONTAINING WILDCARD CHARACTERS
C ISTAT -- STATUS INDICATOR, AS FOLLOWS:
C 0 = SUCCESSFUL
C -1 = INVALID NAME
C
C MAPWILD:
C OUTPUT ARGUMENTS:
C NAME -- QUAL*AREA (CHARACTER*17)
C TYPE -- PROGRAM TYPE (CHARACTER*3)
C RWXD -- READ/WRITE/EXECUTE/DELETE ACCESS (CHARACTER*11)
C SIZE -- CURRENT SIZE IN SECTORS (INTEGER)
C GRAN -- GRANULE SIZE IN SECTORS (INTEGER)
C MAXS -- MAXIMUM SIZE IN SECTORS (INTEGER)
C OWNER -- USER NAME OF THE OWNER (CHARACTER*12)
C ELDATE -- ELIMINATE DATE/TIME (6 INTEGER ARRAY)
C GEDATE -- GENERATE DATE/TIME (6 INTEGER ARRAY)
C LADATE -- LAST ACCESS DATE/TIME (6 INTEGER ARRAY)
C LWDATE -- LAST WRITE DATE/TIME (6 INTEGER ARRAY)
C ISTAT -- STATUS INDICATOR, AS FOLLOWS:
C 0 = MAP INFORMATION RETURNED AS REQUESTED
C +1 = FILE NAME DOES NOT MATCH GIVEN MATCH STRING
C -1 = ERROR (E.G. READ ERROR OR UNRESOURCED PACK)
C -2 = NO MORE FILES
C
C ---------------------------------------------------------------------
CHARACTER AREANM*(*) ! AREANAME MATCH STRING
C
CHARACTER NAME*17 ! AREANAME
CHARACTER TYPE*3 ! FILE TYPE
CHARACTER RWXD*11 ! ACCESS CODE
INTEGER SIZE ! CURRENT SIZE
INTEGER GRAN ! GRANULE SIZE
INTEGER MAXS ! MAXIMUM SIZE
CHARACTER OWNER*12 ! OWNER'S NAME
INTEGER ELDATE(6) ! PURGE DATE/TIME
INTEGER GEDATE(6) ! GENERATION D/T
INTEGER LADATE(6) ! LAST REFERENCE D/T
INTEGER LWDATE(6) ! LAST WRITE D/T
INTEGER ISTAT ! MAP STATUS RETURNED
C
INTEGER PARLST(5) ! PARAMETER LIST FOR $DASAVE
INTEGER DAIB(24,9) ! DISC AREA INFORMATION BLOCK
EQUIVALENCE (PARLST(5),DAIB)
C
CHARACTER NAMTMP*19 ! TEMPORARY AREANAME
INTEGER NAMEQV(7) ! HOLLERITH FORM OF AREANAME
EQUIVALENCE (NAMTMP,NAMEQV)
C
CHARACTER MATCH*15 ! AREANAME PORTION OF MATCH STRING
INTEGER NCHARS,ISTAR ! CHARACTER POINTERS
INTEGER NMATCH,I ! CHARACTER POINTERS
INTEGER MODE ! SEARCH FUNCTION TO PERFORM
INTEGER NWORDS, FILENO ! BUFFER POINTERS
INTEGER ICOMP, JCOMP ! COMPARISON FUNCTION, RESULT
DATA FILENO / -1 /
C
C GET QUALIFIER IN TRUNCATED ASCII, IF REQUIRED
C
ISTAR = 0
FOR I=1,LEN(AREANM)
C FIND QUALIFIER DELIMITER
IF (AREANM(I:I) .EQ. '*') THEN
ISTAR = I
EXIT FOR
END IF
END FOR
C HANDLE A WILDCARD QUALIFIER
IF (ISTAR .EQ. 2 .AND. AREANM(1:1) .EQ. '?') THEN
MODE = 2
ELSE
MODE = 1
C ASSEMBLE A DUMMY AREANAME USING THE SPECIFED QUALIFIER
IF (ISTAR .LE. 0) THEN
NAMTMP = 'TEMPNAME'
ELSE
NAMTMP = AREANM(1:ISTAR) // 'TEMPNAME'
END IF
CALL FILNAM(NAMTMP,PARLST,ISTAT)
IF (ISTAT .LE. 0) GO TO 800
END IF
C
C MAKE A COPY OF THE MATCH STRING
C
MATCH = AREANM(ISTAR+1:)
NMATCH = LEN(AREANM) - ISTAR
C
C PERFORM INITIAL CALL TO $DASAVE
C
IF (MODE .EQ. 1) THEN ! SINGLE QUALIFIER
:ASSEM
REEN MAKE THE ROUTINE RE-ENTRANT
*
TLO PARLST DEFINE PARAMETER LIST
BLU $DASAVE GET THE DISK INFO
DATA 2 FUNCTION CODE FOR GET ALL FILES FROM QUAL
CZA ERROR?
BNZ $800 YES, EXIT
TEM NWORDS NO, GET WORD COUNT
:END
ELSE ! ALL QUALIFIERS
:ASSEM
TLO PARLST DEFINE PARAMETER LIST
BLU $DASAVE GET THE DISK INFO
DATA 8 FUNCTION CODE FOR GET ALL USER FILES
CZA ERROR?
BNZ $800 YES, EXIT
TEM NWORDS NO, GET WORD COUNT
:END
END IF
FILENO = 1 ! INDICATE FIRST FILE
GO TO 900
C
C ---------------------------------------------------------------------
C
ENTRY MAPWILD
IF (FILENO .LE. 0) STOP '*error* MAPWILD not initialized'
IF (NWORDS .LE. 0) GO TO 810 ! NO MORE FILES
C
C MAKE SURE THE CURRENT FILE MATCHES BEFORE WE PROCESS IT
C
CALL TATOA(DAIB(13,FILENO),NAMEQV(1),8) ! QUALIFIER
CALL TATOA(DAIB( 1,FILENO),NAMEQV(4),8) ! AREANAME
NAMTMP(9:9) = '*'
NAME = NAMTMP
JCOMP = ICOMP( MATCH,NMATCH, NAME(10:17),8 )
IF (JCOMP .EQ. 0) THEN
CALL MAPIFY( DAIB(1,FILENO),
+ NAME,TYPE,RWXD,SIZE,GRAN,MAXS,OWNER,
+ ELDATE,GEDATE,LADATE,LWDATE )
END IF
C
C INCREMENT THE BUFFER POINTER
C
FILENO = FILENO + 1
NWORDS = NWORDS - 24
C
C IF THE CURRENT BUFFER IS EMPTY, GET INFORMATION ON UP TO 9 MORE FILES
C
IF (NWORDS .EQ. 0) THEN
:ASSEM
TLO PARLST DEFINE PARAMETER LIST
BLU $DASAVE GET THE DISK INFO
DATA 0 FUNCTION CODE FOR GET INFO
CZA ERROR?
BNZ $800 YES, EXIT
TEM NWORDS NO, GET NEW WORD COUNT
:END
FILENO = 1 ! INDICATE FIRST FILE
END IF
IF (JCOMP .NE. 0) GO TO 820
GO TO 900
C
C ERROR
C
800 ISTAT = -1
RETURN
C
C NO MORE FILES
C
810 ISTAT = -2
RETURN
C
C COMPARISON WITH MATCH STRING FAILED (ONLY QUAL*NAME RETURNED)
C
820 ISTAT = 1
RETURN
C
C SUCCESSFUL RETURN
C
900 ISTAT = 0
RETURN
END
SUBROUTINE MAP(AREANM, NAME,TYPE,RWXD,SIZE,GRAN,MAXS,OWNER,
+ ELDATE,GEDATE,LADATE,LWDATE,ISTAT)
C
C MAPFILE FORTRAN 77 / ASSEMBLER
C WRITTEN BY SKIP RUSSELL APRIL, 1983
C
C SUBROUTINE TO RETURN DIRECTORY INFORMATION ON A SINGLE DISK AREA
C
C
C INPUT ARGUMENTS:
C AREANM -- AREA NAME TO MATCH (CHARACTER STRING)
C
C OUTPUT ARGUMENTS:
C NAME -- QUAL*AREA (CHARACTER*17)
C TYPE -- PROGRAM TYPE (CHARACTER*3)
C RWXD -- READ/WRITE/EXECUTE/DELETE ACCESS (CHARACTER*11)
C SIZE -- CURRENT SIZE IN SECTORS (INTEGER)
C GRAN -- GRANULE SIZE IN SECTORS (INTEGER)
C MAXS -- MAXIMUM SIZE IN SECTORS (INTEGER)
C OWNER -- USER NAME OF THE OWNER (CHARACTER*12)
C ELDATE -- ELIMINATE DATE/TIME (6 INTEGER ARRAY)
C GEDATE -- GENERATE DATE/TIME (6 INTEGER ARRAY)
C LADATE -- LAST ACCESS DATE/TIME (6 INTEGER ARRAY)
C LWDATE -- LAST WRITE DATE/TIME (6 INTEGER ARRAY)
C ISTAT -- STATUS INDICATOR, AS FOLLOWS:
C +1 = FILE NOT FOUND
C 0 = MAP INFORMATION RETURNED (SUCCESSFUL)
C -1 = INVALID NAME SPECIFIED
C
C ---------------------------------------------------------------------
CHARACTER AREANM*(*) ! AREANAME MATCH STRING
C
CHARACTER NAME*17 ! AREANAME
CHARACTER TYPE*3 ! FILE TYPE
CHARACTER RWXD*11 ! ACCESS CODE
INTEGER SIZE ! CURRENT SIZE
INTEGER GRAN ! GRANULE SIZE
INTEGER MAXS ! MAXIMUM SIZE
CHARACTER OWNER*12 ! OWNER'S NAME
INTEGER ELDATE(6) ! PURGE DATE/TIME
INTEGER GEDATE(6) ! GENERATION D/T
INTEGER LADATE(6) ! LAST REFERENCE D/T
INTEGER LWDATE(6) ! LAST WRITE D/T
INTEGER ISTAT ! MAP STATUS RETURNED
C
INTEGER PARLST(5) ! PARAMETER LIST FOR $DASAVE
INTEGER DAIB(24) ! DISC AREA INFORMATION BLOCK
EQUIVALENCE (PARLST(5),DAIB)
C
C GET FILE NAME IN TRUNCATED ASCII
C
CALL FILNAM(AREANM,PARLST,ISTAT)
IF (ISTAT .LE. 0) GO TO 800
C
C CALL $DASAVE SYSTEM SERVICE
C
:ASSEM
REEN MAKE THE ROUTINE RE-ENTRANT
*
TLO PARLST DEFINE PARAMETER LIST
BLU $DASAVE GET THE DISK INFO
DATA 7 FUNCTION CODE FOR GET INFO ON ONE FILE
CZA ERROR?
BNZ $810 YES, EXIT
:END
C
C PROCESS OUTPUT AND RETURN
C
CALL MAPIFY(DAIB, NAME,TYPE,RWXD,SIZE,GRAN,MAXS,OWNER,
+ ELDATE,GEDATE,LADATE,LWDATE)
GO TO 900
C
C INVALID FILE NAME
C
800 ISTAT = -1
RETURN
C
C FILE NOT FOUND
C
810 ISTAT = 1
RETURN
C
C SUCCESSFUL RETURN
C
900 ISTAT = 0
RETURN
END
SUBROUTINE MAPIFY(DAIB, NAME,TYPE,RWXD,SIZE,GRAN,MAXS,OWNER,
+ ELDATE,GEDATE,LADATE,LWDATE)
C
C SUBROUTINE TO DECODE A DISK AREA INFORMATION BLOCK
C
C INPUT ARGUMENT:
C DAIB -- 24 WORD DAIB AS RETURNED BY THE $DASAVE SERVICE
C
C OUTPUT ARGUMENTS:
C NAME -- QUAL*AREA (CHARACTER*17)
C TYPE -- PROGRAM TYPE (CHARACTER*3)
C RWXD -- READ/WRITE/EXECUTE/DELETE ACCESS (CHARACTER*11)
C SIZE -- CURRENT SIZE IN SECTORS (INTEGER)
C GRAN -- GRANULE SIZE IN SECTORS (INTEGER)
C MAXS -- MAXIMUM SIZE IN SECTORS (INTEGER)
C OWNER -- USER NAME OF THE OWNER (CHARACTER*12)
C ELDATE -- ELIMINATE DATE/TIME (6 INTEGER ARRAY)
C GEDATE -- GENERATE DATE/TIME (6 INTEGER ARRAY)
C LADATE -- LAST ACCESS DATE/TIME (6 INTEGER ARRAY)
C LWDATE -- LAST WRITE DATE/TIME (6 INTEGER ARRAY)
C
C ---------------------------------------------------------------------
INTEGER DAIB(24) ! DISC AREA INFORMATION BLOCK
C
CHARACTER NAME*17 ! AREANAME
CHARACTER TYPE*3 ! FILE TYPE
CHARACTER RWXD*11 ! ACCESS CODE
INTEGER SIZE ! CURRENT SIZE
INTEGER GRAN ! GRANULE SIZE
INTEGER MAXS ! MAXIMUM SIZE
CHARACTER OWNER*12 ! OWNER'S NAME
INTEGER ELDATE(6) ! PURGE DATE/TIME
INTEGER GEDATE(6) ! GENERATION D/T
INTEGER LADATE(6) ! LAST REFERENCE D/T
INTEGER LWDATE(6) ! LAST WRITE D/T
C
CHARACTER OWNTMP*12 ! TEMPORARY OWNER NAME
INTEGER PARLS2(10) ! PARAMETER LIST FOR $USERNO
EQUIVALENCE (OWNTMP,PARLS2(5))
C
CHARACTER NAMTMP*18 ! TEMPORARY AREANAME
INTEGER NAMEQV(6) ! HOLLERITH FORM OF AREANAME
EQUIVALENCE (NAMTMP,NAMEQV)
C
CHARACTER PREFIX*1 ! PUBLIC/ACCOUNT FLAG
INTEGER I
C
C AREANAME
C
CALL TATOA(DAIB(13),NAMEQV(1),8) ! QUALIFIER
CALL TATOA(DAIB( 1),NAMEQV(4),8) ! AREANAME
NAMTMP(9:9) = "*"
NAME = NAMTMP
C
C TYPE
C
I = DAIB(8)
IF ((I.AND.'40000000) .NE. 0) THEN
TYPE = 'INT'
ELSE IF ((I.AND.'10000000) .NE. 0) THEN
TYPE = 'BLK'
ELSE IF ((I.AND.'04000000) .NE. 0) THEN
TYPE = 'RAN'
ELSE
TYPE = 'UNB'
END IF
C
C CURRENT & GRANULE & MAXIMUM SIZES
C
SIZE = DAIB(15)
GRAN = DAIB( 4)
MAXS = DAIB(16)
C
C ACCESS
C
I = DAIB(7) / 2**12
IF ((I.AND.'100) .NE. 0) THEN
PREFIX = "P"
ELSE
PREFIX = "A"
END IF
RWXD = "-----------"
IF ((I.AND.'2000) .NE. 0) THEN SR11/86
IF ((I.AND.'0001) .NE. 0) RWXD(10:11) = "OD" SR11/86
IF ((I.AND.'0002) .NE. 0) RWXD(04:05) = "OW" SR11/86
IF ((I.AND.'0004) .NE. 0) RWXD(10:11) = 'AD' SR11/86
IF ((I.AND.'0010) .NE. 0) RWXD(07:08) = 'AX' SR11/86
IF ((I.AND.'0020) .NE. 0) RWXD(04:05) = 'AW' SR11/86
IF ((I.AND.'0040) .NE. 0) RWXD(01:02) = 'AR' SR11/86
IF ((I.AND.'0100) .NE. 0) RWXD(10:11) = 'PD' SR11/86
IF ((I.AND.'0200) .NE. 0) RWXD(07:08) = 'PX' SR11/86
IF ((I.AND.'0400) .NE. 0) RWXD(04:05) = 'PW' SR11/86
IF ((I.AND.'1000) .NE. 0) RWXD(01:02) = 'PR' SR11/86
ELSE SR11/86
IF ((I.AND.'01) .NE. 0) RWXD(10:11) = "OD"
IF ((I.AND.'02) .NE. 0) RWXD(04:05) = "OW"
IF ((I.AND.'04) .NE. 0) RWXD(10:11) = PREFIX // 'D'
IF ((I.AND.'10) .NE. 0) RWXD(07:08) = PREFIX // 'X'
IF ((I.AND.'20) .NE. 0) RWXD(04:05) = PREFIX // 'W'
IF ((I.AND.'40) .NE. 0) RWXD(01:02) = PREFIX // 'R'
END IF SR11/86
C
C OWNER
C
IF (PARLS2(1) .NE. DAIB(5) .OR. PARLS2(2) .NE. DAIB(6)) THEN
PARLS2(1) = DAIB(5)
PARLS2(2) = DAIB(6)
PARLS2(3) = 0
PARLS2(4) = 0
OWNTMP = ' '
:ASSEM
REEN MAKE THE ROUTINE RE-ENTRANT
*
TLO PARLS2 DEFINE PARAMETER LIST
NSK
BLU $USERNO GET USER NAME
:END
END IF
OWNER = OWNTMP
C
C DATES AND TIMES
C
ELDATE(1) = DAIB(17)
ELDATE(2) = DAIB(18)
GEDATE(1) = DAIB(19)
GEDATE(2) = DAIB(20)
LADATE(1) = DAIB(21)
LADATE(2) = DAIB(22)
LWDATE(1) = DAIB(23)
LWDATE(2) = DAIB(24)
:ASSEM
TMK ELDATE
NSK
BLU $DATE
*
TMK GEDATE
NSK
BLU $DATE
*
TMK LADATE
NSK
BLU $DATE
*
TMK LWDATE
NSK
BLU $DATE
:END
IF (DAIB(17).EQ.'37777777) THEN
ELDATE(1) = ' '
ELDATE(2) = ' '
ELDATE(3) = ' '
ELDATE(4) = ' '
ELDATE(5) = ' '
ELDATE(6) = ' '
END IF
END
SUBROUTINE FILNAM(AREANM,TASCII,ISTAT)
C
C CHECK A DISC AREANAME TO INSURE THAT IS CORRECTLY FORMED,
C AND SET UP THE TRUNCATED ASCII REPRESENTATION WHICH IS USED
C BY SEVERAL HARRIS SYSTEM SERVICES
C
C INPUT:
C AREANM -- CHARACTER STRING CONTAINING THE AREANAME TO SCAN
C
C OUTPUT:
C TASCII -- 4 WORD ARRAY CONTAINING THE COMPLETE AREANAME IN
C TRUNCATED ASCII
C
C ISTAT -- STATUS FLAG RETURNED:
C NEGATIVE IF AREANAME IS MALFORMED
C LENGTH OF INPUT STRING IF SUCCESSFUL
C
C WRITTEN 4/83 BY SR
C
C ---------------------------------------------------------------------
CHARACTER AREANM*(*) ! INPUT AREANAME
INTEGER TASCII(4) ! OUTPUT AREANAME
INTEGER ISTAT ! STATUS CODE
CHARACTER NAMTMP*18
INTEGER NAMEQV(6)
EQUIVALENCE (NAMTMP,NAMEQV)
NAMTMP = AREANM ! CONVERT AREANAME TO HOLLERITH
:ASSEM
REEN MAKE THE ROUTINE RE-ENTRANT
*
TLO PARLST INITIALIZE THE SCANNER
BLU $SCINIT
*
TMK TASCII IDENTIFY THE OUTPUT BUFFER
BLU $AREANM CALL AREANAME SERVICE
TAM* ISTAT GET STATUS RETURNED
*
PORG * DATA
PARLST DATA 6 INPUT BUFFER LENGTH
LAC NAMTMP INPUT BUFFER ADDRESS
:END
RETURN
END
C KERMIT PRIMITIVES
C
C SNDPKT -- SEND PACKET
C RESEND -- RE-SEND PREVIOUS PACKET
C SNDACK -- SEND "ACK" PACKET
C SNDNAK -- SEND "NAK" PACKET
C SNDERR -- SEND ERROR PACKET
C RCVPKT -- RECEIVE PACKET
C RCVACK -- RECEIVE ACK/NAK PACKET
C UNPACK -- DECODE AN INCOMING PACKET
C SPAR -- ENCODE MY SEND/RECEIVE PARAMETERS
C RPAR -- DECODE THE OTHER KERMIT'S SEND/RECEIVE PARAMETERS
C PUTDAT -- FILL PACKET DATA WITH A STRING OF TEXT
C ICHKFN -- COMPUTE PACKET CHECKSUM (INTEGER FUNCTION)
C MAKEC -- MAKE A NUMBER PRINTABLE (INTEGER FUNCTION)
C UNCHAR -- RESTORE A NUMBER FROM PRINTABLE (INTEGER FUNCTION)
C ISCTRL -- IS THIS A CONTROL CHARACTER? (LOGICAL FUNCTION)
C CTL -- CONTROL CHAR TO/FROM PRINTABLE (INTEGER FUNCTION)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C PACKET DESCRIPTION:
C
C BYTE 1 -- MARK : SOH CHARACTER
C BYTE 2 -- COUNT : # OF BYTES FOLLOWING THIS FIELD
C BYTE 3 -- SEQ : SEQUENCE NUMBER MODULO 64
C BYTE 4 -- PTYPE : PACKET TYPE = {D,Y,N,S,B,F,Z,E,...}
C BYTE 5- -- DATA : THE ACTUAL DATA (N BYTES)
C BYTE N+5 -- CHKSUM : CHECKSUM OF BYTES 2 THROUGH N+4
C APPENDED: -- EOL : (NOT CONSIDERED PART OF PACKET PROPER)
SUBROUTINE SNDPKT(DATA,NDATA,NSEQ,TYPE)
C---
C--- BUILDS AND SENDS PACKET
C---
INTEGER DATA(*),NDATA,NSEQ
CHARACTER TYPE*1
LOGICAL DEBUG
COMMON /DBGCOM/ DEBUG
INTEGER MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
COMMON /SNDCOM/ MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
INTEGER ICHKFN,MAKEC
INTEGER PACK(94),NPACK,SOH,I
SAVE PACK,NPACK
DATA SOH /1/
NPACK = NDATA + 5 ! TOTAL CHARACTERS IN PACKET
PACK(1) = SOH ! MARK (START OF PACKET CHARACTER)
PACK(2) = MAKEC(NDATA+3) ! COUNT = SEQ+PTYPE+DATA+CHKSUM
PACK(3) = MAKEC(NSEQ) ! SEQUENCE NUMBER
PACK(4) = ICHAR(TYPE) ! PACKET TYPE
FOR I=1,NDATA
PACK(I+4) = DATA(I) ! DATA
END FOR
PACK(NDATA+5) = ICHKFN(PACK,NPACK) ! CHECKSUM
IF (DEBUG) THEN
IF (NDATA .LE. 0) THEN
WRITE (*,1100) NSEQ, TYPE, NPACK, NDATA
ELSE
WRITE (*,1100) NSEQ, TYPE, NPACK, NDATA,
+ ICHAR('<'), (DATA(I), I=1,NDATA), ICHAR('>')
END IF
1100 FORMAT (' SENT',I3,') TYPE=',A,' SIZE=',I3,' NDATA=',I3,
+ :,2X,R1,89R1,R1)
END IF
GO TO 100
C---
C--- RE-SENDS PREVIOUS PACKET
C---
ENTRY RESEND()
IF (DEBUG) WRITE (*,*) 'RE-SENDING LAST PACKET'
C SEND PADDING IF THEY REQUESTED IT
100 FOR I=1,NSPAD
CALL PUT1CW(NSPCHR,1)
END FOR
C SEND PACKET
CALL PUT1CW(PACK,NPACK)
END
SUBROUTINE SNDACK(DATA,NDATA,NSEQ)
C---
C--- SEND ACK PACKET
C---
INTEGER DATA(*),NDATA,NSEQ
CALL SNDPKT(DATA,NDATA,NSEQ,'Y')
END
SUBROUTINE SNDNAK(NSEQ)
C---
C--- SEND NAK PACKET
C---
INTEGER NSEQ
INTEGER DATA(1),NDATA
NDATA = 0
CALL SNDPKT(DATA,NDATA,NSEQ,'N')
END
SUBROUTINE SNDERR(MSG,MXDATA,DATA,NSEQ)
C---
C--- SEND ERROR PACKET
C---
CHARACTER MSG*(*)
INTEGER MXDATA,DATA(*),NSEQ
LOGICAL DEBUG
COMMON /DBGCOM/ DEBUG
INTEGER NDATA,PREFIX
IF (DEBUG) WRITE (*,*) MSG
C COPY MESSAGE INTO DATA ARRAY
PREFIX = 1
CALL PUTDAT(MSG,PREFIX,MXDATA,DATA,NDATA)
C SEND "E" PACKET
CALL SNDPKT(DATA,NDATA,NSEQ,'E')
END
SUBROUTINE RCVPKT(MXDATA,DATA,NDATA,NSEQ,TYPE,ISTAT)
C---
C--- RECEIVES PACKET
C---
INTEGER MXDATA,DATA(*),NDATA,NSEQ,ISTAT
CHARACTER TYPE*1
LOGICAL DEBUG
COMMON /DBGCOM/ DEBUG
INTEGER MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
COMMON /SNDCOM/ MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
INTEGER MXBUF
PARAMETER (MXBUF=80)
INTEGER PACK(MXBUF)
INTEGER I
C READ PACKET
CALL PUT1CW(NSEOL,1)
READ (3,'(100R1)',IOSTAT=ISTAT) PACK
IF (ISTAT .NE. 0) THEN
IF (DEBUG) WRITE (*,*) 'I/O ERROR ON READ, IOSTAT=', ISTAT
GO TO 800
END IF
C CHECK
CALL UNPACK(PACK,MXBUF,MXDATA,DATA,NDATA,NSEQ,TYPE,ISTAT)
IF (ISTAT .NE. 0) THEN
IF (DEBUG) WRITE (*,*) 'INVALID PACKET RECEIVED'
GO TO 800
END IF
GO TO 900
800 ISTAT = -1 ! UNSUCCESSFUL
RETURN
900 ISTAT = 0 ! SUCCESSFUL
RETURN
END
SUBROUTINE RCVACK(MXDATA,DATA,NDATA,NSEQ,ISTAT)
C---
C--- RECEIVE "ACK" PACKET AND CHECK VALIDITY
C---
INTEGER MXDATA,DATA(*),NDATA,NSEQ,ISTAT
LOGICAL DEBUG
COMMON /DBGCOM/ DEBUG
INTEGER RSEQ
CHARACTER TYPE*1
CALL RCVPKT(MXDATA,DATA,NDATA,RSEQ,TYPE,ISTAT)
IF (ISTAT .NE. 0) GO TO 810
IF (TYPE .EQ. 'Y' .AND. NSEQ .EQ. RSEQ) GO TO 900
IF (TYPE .EQ. 'N') THEN
IF (MOD(NSEQ+1,64) .EQ. RSEQ) THEN
IF (DEBUG) WRITE (*,*) '(EQUIVALENT TO ACK)'
GO TO 900
END IF
GO TO 810
END IF
CCC IF (TYPE .EQ. 'E') GO TO 800
CCC GO TO 810
800 ISTAT = -1 ! ERROR PACKET
RETURN
810 ISTAT = 1 ! UNSUCCESSFUL
IF (DEBUG) WRITE (*,*) 'RECEIVED NAK OR EQUIVALENT'
RETURN
900 ISTAT = 0 ! SUCCESSFUL
RETURN
END
SUBROUTINE UNPACK(PACK,MXBUF,MXDATA,DATA,NDATA,NSEQ,TYPE,ISTAT)
C---
C--- UNPACK AND VALIDATE PACKET (CALLED BY RCVPKT)
C---
INTEGER PACK(*),MXBUF
INTEGER MXDATA,DATA(*),NDATA,NSEQ,ISTAT
CHARACTER TYPE*1
LOGICAL DEBUG
COMMON /DBGCOM/ DEBUG
INTEGER UNCHAR,ICHKFN
INTEGER NPACK,IPACK,NSOH,CHKSUM,CHKSU2,NCHARS,SOH,I
DATA SOH /1/
C INITIALIZE
NSOH = 0
TYPE = '?'
C MARK FIELD : SOH CHARACTER
IPACK = 0
FOR I=1,MXBUF-3
IPACK = IPACK + 1
IF (PACK(IPACK) .EQ. SOH) GO TO 100
END FOR
IF (DEBUG) WRITE (*,*) 'UNPACK: SOH NOT FOUND'
GO TO 800
100 NSOH = IPACK
IF (DEBUG .AND. NSOH .NE. 1) WRITE (*,*) 'SOH FOUND AT', NSOH
C COUNT FIELD : # OF BYTES FOLLOWING THIS FIELD
IPACK = IPACK + 1
NPACK = UNCHAR( PACK(IPACK) )
IF (NPACK .LT. 3 .OR. NPACK+2 .GT. MXBUF) THEN
IF (DEBUG) WRITE (*,*) 'UNPACK: INVALID COUNT FIELD', NPACK
GO TO 800
ELSE IF (NPACK+NSOH+1 .GT. MXBUF) THEN
IF (DEBUG) WRITE (*,*) 'UNPACK: BUFFER OVERRUN', NPACK+NSOH+1
GO TO 800
END IF
NPACK = NPACK + 2
C SEQ FIELD : SEQUENCE NUMBER MODULO 64
IPACK = IPACK + 1
NSEQ = UNCHAR( PACK(IPACK) )
IF (NSEQ .LT. 0 .OR. NSEQ .GT. 63) THEN
IF (DEBUG) WRITE (*,*) 'UNPACK: INVALID SEQ FIELD', NSEQ
GO TO 800
END IF
C PTYPE FIELD : PACKET TYPE = {D,Y,N,S,B,F,Z,E,...}
IPACK = IPACK + 1
TYPE = CHAR( PACK(IPACK) )
IF (TYPE .LT. 'A' .OR. TYPE .GT. 'Z') THEN
IF (DEBUG) WRITE (*,*) 'UNPACK: INVALID PACKET TYPE ', TYPE
GO TO 800
END IF
C DATA FIELD : COPY INTO DATA ARRAY
NDATA = NPACK-5
IF (NDATA .GT. MXDATA) THEN
IF (DEBUG) WRITE (*,*) 'UNPACK: MORE DATA RECEIVED THAN',
+ ' EXPECTED (N=', NDATA, ' MAX=', MXDATA, ')'
NDATA = MXDATA
END IF
FOR I=1,NDATA
DATA(I) = PACK(I+NSOH+3)
END FOR
C CHKSUM FIELD : CHECKSUM OF BYTES 2 THROUGH N-4
CHKSUM = PACK(NPACK+NSOH-1)
CHKSU2 = ICHKFN( PACK(NSOH), NPACK )
IF (CHKSUM .NE. CHKSU2) THEN
IF (DEBUG) WRITE (*,*) 'UNPACK: CHECKSUMS=', CHKSUM,CHKSU2
GO TO 800
END IF
C LOG ERROR MESSAGES
IF (TYPE .EQ. 'E') THEN
IF (DEBUG) THEN
WRITE (*,*) 'ERROR PACKET RECEIVED:'
WRITE (*,*) '***', (CHAR(PACK(I)), I=NSOH+4,NPACK-1), '***'
END IF
END IF
GO TO 900
800 ISTAT = -1 ! UNSUCCESSFUL
IF (DEBUG) THEN
NCHARS = 0
FOR I=MXBUF,1,-1
IF (PACK(I) .NE. ICHAR(' ') ) THEN
NCHARS = I
EXIT FOR
END IF
END FOR
WRITE (*,*) 'DUMP OF PACKET CONTENTS:'
WRITE (*,'(26(2X,R1))') (MAX(ICHAR(' '),PACK(I)), I=1,NCHARS)
WRITE (*,'(1X,26I3)') (PACK(I), I=1,NCHARS)
END IF
RETURN
900 ISTAT = 0 ! SUCCESSFUL
IF (DEBUG) THEN
IF (NDATA .LE. 0) THEN
WRITE (*,1900) NSEQ, TYPE, NPACK, NDATA
ELSE
WRITE (*,1900) NSEQ, TYPE, NPACK, NDATA,
+ ICHAR('<'), (DATA(I), I=1,NDATA), ICHAR('>')
END IF
1900 FORMAT (' RCVD',I3,') TYPE=',A,' SIZE=',I3,' NDATA=',I3,
+ :,2X,93R1)
END IF
END
SUBROUTINE SPAR(MXDATA,DATA,NDATA)
C---
C--- FILL THE DATA ARRAY WITH MY SEND-INIT PARAMETERS
C---
INTEGER MXDATA,DATA(*),NDATA
LOGICAL DEBUG
COMMON /DBGCOM/ DEBUG
INTEGER MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME
COMMON /RCVCOM/ MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME
INTEGER MAKEC,CTL
LOGICAL FIRST
DATA FIRST /.TRUE./
NDATA = 6
IF (MXDATA .LT. NDATA) THEN
WRITE (*,*) 'FATAL ERROR: DATA ARRAY < MIN SIZE IN "SPAR"'
STOP
END IF
DATA(1) = MAKEC( MRPSIZ ) ! BIGGEST PACKET I CAN RECEIVE
DATA(2) = MAKEC( MYTIME ) ! WHEN I WANT TIMEOUT
DATA(3) = MAKEC( MYPAD ) ! HOW MUCH PADDING TO SEND ME
DATA(4) = CTL( MYPCHR ) ! PAD CHARACTER TO USE
DATA(5) = MAKEC( MYEOL ) ! EOL TO SEND ME
DATA(6) = MYQUOT ! CONTROL QUOTE CHAR I WILL SEND
C USE DEFAULTS FOR THE FOLLOWING:
C 7. NEITHER OF US WILL DO 8-BIT QUOTING
C 8. BOTH OF US WILL USE A SINGLE CHARACTER CHECKSUM
C 9. NEITHER OF US WILL USE REPEAT PREFIXES
IF (DEBUG .AND. FIRST) THEN
FIRST = .FALSE.
WRITE (*,*)
WRITE (*,*) 'HARRIS KERMIT REQUESTS THE FOLLOWING FROM LOCAL:'
WRITE (*,*)
WRITE (*,*) 'BIGGEST PACKET I CAN RECEIVE IS', MRPSIZ,' CHARS'
WRITE (*,*) 'SUGGEST THEY TIMEOUT AFTER', MYTIME, ' SECONDS'
WRITE (*,*) 'PREFIX PACKETS WITH', MYPAD, ' PAD CHARS',
+ ', USING CHARACTER', MYPCHR
WRITE (*,*) 'TERMINATE PACKETS WITH CHARACTER', MYEOL
WRITE (*,*) 'I WILL SEND "', CHAR(MYQUOT),
+ '" TO QUOTE CONTROL CHARACTERS'
WRITE (*,*) '(USE DEFAULTS FOR THE REMAINDER)'
WRITE (*,*)
END IF
END
SUBROUTINE RPAR(DATA,NDATA)
C---
C--- GET THE OTHER HOST'S SEND-INIT PARAMETERS
C---
INTEGER DATA(*),NDATA
LOGICAL DEBUG
COMMON /DBGCOM/ DEBUG
INTEGER MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
COMMON /SNDCOM/ MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
INTEGER UNCHAR,CTL
INTEGER I
LOGICAL FIRST
DATA FIRST /.TRUE./
C READ THEIR PACKET
IF (NDATA .LT. 1) GO TO 200
I = UNCHAR( DATA(1) ) ! BIGGEST PACKET THEY CAN RECEIVE
IF (I .GT. 0 .AND. I .LT. MSPSIZ) MSPSIZ = I
IF (NDATA .LT. 2) GO TO 200
NSTIME = UNCHAR( DATA(2) ) ! WHEN THEY WANT TIMEOUT
IF (NDATA .LT. 3) GO TO 200
NSPAD = UNCHAR( DATA(3) ) ! HOW MUCH PADDING TO SEND THEM
IF (NDATA .LT. 4) GO TO 200
NSPCHR = CTL( DATA(4) ) ! PAD CHARACTER TO USE
IF (NDATA .LT. 5) GO TO 200
I = UNCHAR( DATA(5) ) ! EOL TO SEND THEM
IF (I .GT. 0) NSEOL = I
IF (NDATA .LT. 6) GO TO 200
I = DATA(6) ! INCOMING DATA QUOTE CHARACTER
IF (I .GT. 0) NSQUOT = I
200 IF (DEBUG .AND. FIRST) THEN
FIRST = .FALSE.
WRITE (*,*)
WRITE (*,*) 'REQUESTED OF HARRIS KERMIT BY LOCAL:'
WRITE (*,*)
WRITE (*,*) 'BIGGEST PACKET TO SEND THEM IS', MSPSIZ, ' CHARS'
WRITE (*,*) 'SUGGEST I TIMEOUT AFTER', NSTIME, ' SECONDS'
WRITE (*,*) 'PREFIX PACKETS WITH', NSPAD, ' PAD CHARS',
+ ', USING CHARACTER', NSPCHR
WRITE (*,*) 'TERMINATE PACKETS WITH CHARACTER', NSEOL
WRITE (*,*) 'THEY WILL SEND "', CHAR(NSQUOT),
+ '" TO QUOTE CONTROL CHARACTERS'
WRITE (*,*) '(USING DEFAULTS FOR THE REMAINDER, REGARDLESS)'
WRITE (*,*)
END IF
END
SUBROUTINE PUTDAT(MSG,PREFIX,MXDATA,DATA,NDATA)
C---
C--- FILL PACKET DATA WITH SPECIFIED CHARACTER STRING
C---
C--- <PREFIX> NON-ZERO PREFIXES MESSAGE WITH "HARRIS:" IDENTIFIER
C---
CHARACTER MSG*(*)
INTEGER PREFIX,MXDATA,DATA(*),NDATA
INTEGER N,C,I
CHARACTER PRE*8
DATA PRE /'HARRIS: '/
C COPY PREFIX INTO DATA ARRAY IF REQUESTED
NDATA = 0
IF (PREFIX .NE. 0) THEN
FOR I=1,LEN(PRE)
EXIT FOR IF (NDATA .GE. MXDATA)
NDATA = NDATA + 1
DATA(NDATA) = ICHAR( PRE(I:I) )
END FOR
END IF
C COPY MESSAGE INTO DATA ARRAY, WITHOUT TRAILING BLANKS
N = NDATA
FOR I=1,LEN(MSG)
EXIT FOR IF (N .GE. MXDATA)
C = ICHAR( MSG(I:I) )
N = N + 1
IF (C .NE. ICHAR(' ') ) NDATA = N
DATA(N) = C
END FOR
END
INTEGER FUNCTION ICHKFN(PACK,NPACK)
C---
C--- CALCULATE CHECKSUM AND CONVERT TO PRINTABLE FORM
C---
INTEGER PACK(*),NPACK
INTEGER MAKEC
INTEGER S,CHKSUM,I
S = 0
FOR I=2,NPACK-1
S = S + PACK(I)
END FOR
C CHECKSUM = LOW ORDER 6 BITS OF THE RESULT OF THE FUNCTION:
C S(BITS 0:5) + S(BITS 6:7)
C WHERE S IS THE SUM OF ALL CHARACTERS IN THIS PACKET
CHKSUM = (S + ((S .AND. '300)/'100)) .AND. '77
ICHKFN = MAKEC(CHKSUM)
END
INTEGER FUNCTION MAKEC(ICHR)
C---
C--- CONVERT A NUMBER TO A PRINTABLE CHARACTER
C---
INTEGER ICHR
MAKEC = ICHR + 32
END
INTEGER FUNCTION UNCHAR(ICHR)
C---
C--- RESTORE A NUMBER FROM A CHARACTER (REVERSE OF "MAKEC")
C---
INTEGER ICHR
UNCHAR = ICHR - 32
END
LOGICAL FUNCTION ISCTRL(ICHR)
C---
C--- RETURN TRUE IF SPECIFIED CHARACTER A CONTROL CHARACTER
C---
INTEGER ICHR
ISCTRL = (ICHR .LT. 32 .OR. ICHR .EQ. 127)
END
INTEGER FUNCTION CTL(ICHR)
C---
C--- TOGGLE A CHARACTER BETWEEN CONTROL AND PRINTABLE REPRESENTATIONS
C---
INTEGER ICHR
CTL = ICHR .XOR. 64
END