;<PUP>PUPFTS.MAC;56 14-MAY-83 15:45:15 EDIT BY TAFT
;<PUP>PUPFTS.MAC;55 13-JAN-83 14:19:36 EDIT BY TAFT
;<PUP>PUPFTS.MAC;54 8-NOV-82 16:33:00 EDIT BY TAFT
;<PUP>PUPFTS.MAC;53 4-OCT-82 16:28:45 EDIT BY TAFT
; Bug fix in GFNPRP
;<PUP>PUPFTS.MAC;51 26-SEP-82 15:14:10 EDIT BY TAFT
; Implement New-enumerate
; Observe Desired-property requests
;<PUP>PUPFTS.MAC;49 10-AUG-81 18:00:30 EDIT BY TAFT
; Time zones in Retrieve date properties.
;<PUP>PUPFTS.MAC;47 18-MAY-81 11:41:48 EDIT BY TAFT
;<PUP>PUPFTS.MAC;46 24-APR-81 21:26:29 EDIT BY TAFT
; Include time zone in date properties
;<PUP>PUPFTS.MAC;45 16-JAN-81 10:41:07 EDIT BY TAFT
; Strip "↑.registry" if present in distribution list name.
; Suppress trailing "." in Name-body if filename extension is blank.
;<PUP>PUPFTS.MAC;44 2-DEC-80 09:17:45 EDIT BY TAFT
; Fix bug in handling of connect name in LOGCHK.
;<PUP>PUPFTS.MAC;43 29-AUG-80 13:43:23 EDIT BY TAFT
; Add FRNHAD
;<PUP>PUPFTS.MAC;42 26-AUG-80 11:11:23 EDIT BY TAFT
; Generate full property list in Delete
;<PUP>PUPFTS.MAC;41 15-AUG-80 18:38:29 EDIT BY TAFT
; Call RECPAS from LOGCHK
;<PUP>PUPFTS.MAC;40 22-JUL-80 19:16:04 EDIT BY TAFT
; Do an automatic Expunge if "directory full" error occurs during Store
; CKRPAR generate No rather than Comment for errors in single-file retrieves
;<PUP>PUPFTS.MAC;39 2-FEB-80 18:00:31 EDIT BY TAFT
; Send Size property in Retrieve property list
;<PUP>PUPFTS.MAC;38 20-JAN-80 17:42:05 EDIT BY TAFT
; FTPM does not attempt to send if receive connection closes in midstream.
;<PUP>PUPFTS.MAC;37 28-NOV-79 11:36:13 EDIT BY TAFT
; Add checks to distinguish between FTP and Mail server functions.
; Add code for anonymous distribution list retrieval in Mail server.
;<PUP>PUPFTS.MAC;36 4-NOV-79 12:24:55 EDIT BY TAFT
; Set creation date during [Store] if present in property list
;<PUP>PUPFTS.MAC;35 2-SEP-79 15:59:33 EDIT BY TAFT
;<PUP>PUPFTS.MAC;34 16-JAN-79 14:26:59 EDIT BY TAFT
;<PUP>PUPFTS.MAC;33 8-OCT-78 19:49:40 EDIT BY TAFT
; Rejuvenate watchdog timer in REFILL procedure so we don't get
; nailed while processing long mail distribution lists
;<PUP>PUPFTS.MAC;32 4-SEP-78 13:05:01 EDIT BY TAFT
; Add Rename error code 112
;<PUP>PUPFTS.MAC;31 4-JUL-78 16:41:36 EDIT BY TAFT
; Fix bug in Rename failure code
;<PUP>PUPFTS.MAC;30 24-MAY-78 18:26:44 EDIT BY TAFT
; Add [New-store] command
;<PUP>PUPFTS.MAC;29 3-FEB-78 19:46:55 EDIT BY TAFT
; Add distinct error code for file busy
;<PUP>PUPFTS.MAC;28 16-SEP-77 10:14:14 EDIT BY TAFT
;<PUP>PUPFTS.MAC;27 1-SEP-77 15:54:44 EDIT BY TAFT
; Make a few things internal for the mail server
;<PUP>PUPFTS.MAC;26 26-JUL-77 14:58:18 EDIT BY TAFT
; "Directory" defaults server filename to *.*;*
; Reset watchdog timer in appropriate places
;<PUP>PUPFTS.MAC;25 3-JUN-77 13:09:16 EDIT BY TAFT
; Add "Rename" command
;<PUP>PUPFTS.MAC;24 15-APR-77 09:55:20 EDIT BY TAFT
; Move some flag bits to avoid conflict with PUPDEF
; Default version to lowest in "Delete"
;<PUP>PUPFTS.MAC;23 7-APR-77 17:42:08 EDIT BY TAFT
; Zero memory cells holding JFNs when they are closed or released.
;<PUP>PUPFTS.MAC;22 31-MAR-77 21:10:00 EDIT BY TAFT
; Add hooks for mail server
;<PUP>PUPFTS.MAC;20 19-MAR-77 20:05:57 EDIT BY TAFT
; Add "Delete" command
;<PUP>PUPFTS.MAC;19 19-MAR-77 13:39:42 EDIT BY TAFT
; Fix bugs in Tenex-paged stuff
;<PUP>PUPFTS.MAC;18 18-MAR-77 19:13:59 EDIT BY TAFT
; Add REFILL procedure for property list parser
;<PUP>PUPFTS.MAC;16 18-MAR-77 17:41:10 EDIT BY TAFT
; Rip out property list parser and data transfer code --
; now share these modules with PUPFTP.
; Add checks for Tenex-paged type.
;<PUP>PUPFTS.MAC;14 17-OCT-76 00:41:41 EDIT BY TAFT
; Permit retrieving a 36-bit file with any byte size, but
; generate a suitable warning message
;<PUP>PUPFTS.MAC;13 30-JUN-76 17:21:38 EDIT BY TAFT
; Remove various utility routines to PUPUTL.MAC
;<PUP>PUPFTS.MAC;11 1-JUN-76 19:41:50 EDIT BY TAFT
; Change FIXNAM to apply generic filename properties as defaults
;<PUP>PUPFTS.MAC;8 1-JUN-76 16:43:58 EDIT BY TAFT
; "Directory" returns properties as separate commands for each file
;<PUP>PUPFTS.MAC;7 31-MAY-76 19:13:49 EDIT BY TAFT
; Include dates in retrieve property lists
;<PUP>PUPFTS.MAC;5 14-MAY-76 20:07:10 EDIT BY TAFT
; Add code to handle CLOSF failure at FTPEND
;<PUP>PUPFTS.MAC;4 27-MAR-76 18:01:12 EDIT BY TAFT
; Straighten out defaulting of account during store
;<PUP>PUPFTS.MAC;3 26-MAR-76 02:12:08 EDIT BY TAFT
; Convert lower-case password properties to upper-case
; Copyright 1979, 1980 by Xerox Corporation
TITLE PUPFTS -- FTP SERVER FORK OF PUP SERVER
SUBTTL E. A. Taft / October, 1975
SEARCH PUPDEF,PSVDEF,STENEX
USEVAR FTPVAR,FTPPVR
; Parameters
; Herald for version reply
VERTXT: ASCIZ /1.38 14-May-83/
FTPVER==1 ; Protocol version implemented
; Local flags
LOGCKF==1B27 ; Login parameters have been checked
ACTCKF==1B28 ; Account has been checked
CONCKF==1B29 ; Connect parameters have been checked
DSKDVF==1B30 ; Current file is on disk
; Assemble main command dispatch table
DEFINE XN(SYM,TYPE,NAME,FLAGS) <
REPEAT TYPE-<.-MRKDSP>,<0>
IF2,<IFNDEF C.'SYM,<EXTERN C.'SYM>>
0 ,, C.'SYM
>
DEFINE XS(SYM,TYPE,NAME,FLAGS) <
REPEAT TYPE-<.-MRKDSP>,<0>
IF2,<IFNDEF C.'SYM,<EXTERN C.'SYM>>
0 ,, C.'SYM
>
MRKDSP::MARKS
; Assemble Mark names and flags
DEFINE XN(SYM,TYPE,NAME,FLAGS) <
REPEAT TYPE-<.-MRKNAM>,<0>
FLAGS + [ASCIZ /NAME/]
>
DEFINE XS(SYM,TYPE,NAME,FLAGS) <
REPEAT TYPE-<.-MRKNAM>,<0>
1B0+FLAGS + [ASCIZ /NAME/]
>
MRKNAM::MARKS
NMARKS==.-MRKNAM
; -----------------------------------------------------------------
; Initialization, Main Loop, Termination
; -----------------------------------------------------------------
; Server fork started here
; Initialize
FTPFRK::JSYS FRKINI## ; Initialize ac's and stuff
HRRZ SV,SERVX ; Service table index in RH only
MOVEI A,400000 ; Initialize psi system
MOVE B,[LEVTAB##,,CHNTAB]
SIR
EIR
MOVE B,[ACTCHN] ; Activate channels
AIC
HRRZ A,FRKJFN(FX) ; Get address of foreign port
MOVE C,[1,,FRNHAD]
GDSTS
HRROI A,FRNHNM ; Get foreign host name
MOVE B,[1B1+1B2+C]
MOVE C,FRNHAD
SETZ D,
PUPNM
PUSHJ P,SCREWUP##
; Main command loop
COMLP: PUSHJ P,GETCMD ; Get next command
JRST FTPEND ; End received, close connection
MOVE C,MRKNAM(A) ; Check for command allowed in this server
CAIN SV,SV.MAI
TLZA C,(NOTFTS) ; We are a mail server
TLZ C,(NOTMLS) ; We are an FTP server
TLNE C,(NOTFTS+NOTMLS)
JRST [ HRRO A,MRKNAM(A)
HLRO B,SRVDSP##(SV)
FTPM(NO,3,<Command [%1S] not permitted in %2S server>)
JRST COMLP]
MOVE P1,MRKDSP(A) ; Get dispatch
PUSHJ P,0(P1) ; Process the command
JRST COMLP ; Repeat for next
; Here when End received
FTPEND::HLRZ A,FRKJFN(FX) ; Get Pup input JFN
CLOSF ; Close it
PUSHJ P,SCREWUP##
HRRZS A,FRKJFN(FX) ; Now same for output JFN
CLOSF
JRST [ ELOG <Connection closed uncleanly%/ - %1J>
HRRZ A,FRKJFN(FX) ; Should work a second time
CLOSF
HALTF
JRST .+1]
SETZM FRKJFN(FX) ; Note that no JFNs exist now
HALTF ; Terminate normally
; -----------------------------------------------------------------
; Individual command handlers
; -----------------------------------------------------------------
; "End-Of-Command"
C.EOC: FTPM(EOC,,,1) ; Just send answering EOC
; "Version"
C.VERS: HRROI A,VERTXT ; Give version string for text
HRROI B,LCLHNM## ; Local host name string
HLRO C,SRVDSP##(SV) ; Server type name
FTPM(VERS,FTPVER,<%2S Pup %3S Server %1S>,1)
; Commands that should never be received at top level
C.YES: ; "Yes"
C.NO: ; "No"
C.FILE: ; "Here-is-file"
C.PLST: ; "Here-is-property-list"
DTYPE < - Unexpected command%/>
; Commands that are ignored
C.ABOR: ; "Abort" (no-op at top level)
C.COMM: POPJ P, ; "Comment"
; "Retrieve"
C.RETR: SETZM FILPRP ; Clear out property list
MOVE A,[FILPRP,,FILPRP+1]
BLT A,FILPRP+PLSIZE-1
HRROI A,NETBUF ; Set pointer to argument string
MOVEI B,FILPRP ; File property list
PUSHJ P,SCNPRP## ; Scan property list
POPJ P, ; Failed
MOVEI A,FILPRP
MOVEI B,LOGCHK ; Normal login check
CAIN SV,SV.MAI ; Mail server?
MOVEI B,ANOLOG ; Yes, anonymous login
PUSHJ P,0(B) ; Check login/connect parameters
POPJ P, ; Failed
MOVEI A,TEMP ; Where to build GTJFN command list
MOVEI B,FILPRP ; Where property list is now
PUSHJ P,FIXNAM ; Fix args, build command list
MOVSI C,(1B2+1B11) ; Old file, permit "*"
HLLM C,TEMP
GTJFN ; Lookup the Server-Filename string
JRST RGJFER ; Failed, give reason and quit
MOVEM A,SRCJFN## ; Ok, save source JFN and flags
HRRZS A
PUSHJ P,CHKDSK ; Check device type
HRRZ A,FILPRP+P.TYPE ; Get transfer type
CAIN A,3 ; Paged?
TRNE F,DSKDVF ; Yes, device other than disk?
JRST C.RET1 ; No, ok
HRRZ A,SRCJFN## ; Yes, release JFN
RLJFN
PUSHJ P,SCREWUP##
SETZM SRCJFN##
FTPM(NO,15,<Type Tenex-Paged illegal for non-disk files>,1)
; Now have JFN (possibly indexable)
; Back here for each file referenced by the JFN
C.RET1: MOVE A,[FILPRP,,TMPPRP] ; Copy supplied property list
BLT A,TMPPRP+PLSIZE-1 ; into temps for this retrieval
MOVE A,SRCJFN## ; Get file JFN, including left half bits
MOVEI B,TMPPRP ; Set pointer to property list
PUSHJ P,CKRPAR ; Check retrieval parameters
JRST C.RET8 ; Bad, bypass this file
PUSHJ P,GNRPRP ; Generate property list reply
; Await "Yes" or "No" from user
C.RET2: PUSHJ P,GETCMD ; Get next command
JRST [ HRRZ A,SRCJFN## ; Connection closed, release JFN
RLJFN
PUSHJ P,SCREWUP##
SETZM SRCJFN##
JRST FTPEND] ; Handle EOF normally
CAIN A,MKNO ; Check command
JRST C.RET8 ; "No", skip this file
CAIN A,MKYES
JRST C.RET6 ; "Yes", send this file
MOVE C,MRKNAM(A) ; Not one of those, get dispatch
TLNN C,(OKRETR) ; Command ok in this context?
JRST [ HRRZ A,SRCJFN## ; No, flush file JFN
RLJFN
PUSHJ P,SCREWUP##
SETZM SRCJFN##
HRROS C ; Make string ptr to command name
FTPM(NO,3,<Command [%3S] out of sequence during Retrieve>,1)]
MOVE C,MRKDSP(A) ; Ok, get command dispatch
PUSHJ P,0(C) ; Do the command
JRST C.RET2 ; Look for another
; "Retrieve" (cont'd)
; Here when "Yes" encountered. Now send the file.
C.RET6: PUSHJ P,OPNRET ; Open file for retrieve
JRST C.RET8 ; Failed
HRRZ A,SRCJFN## ; Ok, get file JFN
LOG <Retrieve %1F> ; Make log entry
MOVEI A,MKFILE ; Insert "Here-Is-File" mark
SETZ B,
PUSHJ P,BEGCMD
HRRZ A,FRKJFN(FX) ; Destination is net
MOVEM A,DSTJFN##
MOVEI A,TMPPRP ; Property list
PUSHJ P,SNDDAT## ; Do the retrieval
JRST [ HRRZ A,SRCJFN## ; Data error, get JFN
FTPM(NO,103,<Data error in %1F, Retrieve aborted>)
JRST C.RET7]
HRRZ A,SRCJFN##
FTPM(YES,0,<Retrieve of %1F completed>)
C.RET7: HRLI A,400000 ; Close file, don't release JFN
CLOSF
PUSHJ P,SCREWUP##
; Here when done retrieval of one file. Check for more to do
C.RET8: SETZM DSTJFN##
MOVE A,SRCJFN## ; Get JFN with flags
GNJFN ; Step to next file if any
JRST [ SETZM SRCJFN## ; No more, done (JFN released)
POPJ P,]
JRST C.RET1 ; Another, go retrieve it
; "Retrieve" subroutines ...
; Check and/or default parameters for "Retrieve" command
; A/ JFN for file being retrieved -- including left-half bits
; B/ Pointer to property list
; Returns +1: Error, reply message already generated (as either Comment
; or No, depending on whether or not the JFN is indexable --
; i.e., whether or not successor files are possible)
; +2: Ok, type and byte size filled in appropriately
; Clobbers B-D
CKRPAR: PUSHJ P,SAVE1## ; Preserve another ac
MOVE P1,B ; Put the plist pointer there
SETZ B, ; Assume don't know byte size
TRNN F,DSKDVF ; Retrieving from disk?
JRST CKRPA2 ; No
MOVE B,[1,,11] ; Yes, read byte size from FDB
MOVEI C,C ; Put it here
PUSH P,A
HRRZS A
GTFDB
POP P,A
LDB B,[POINT 6,C,11] ; Extract byte size
CKRPA2: HRRZ C,P.TYPE(P1) ; Get specified transfer type
HRRZ D,P.BYTE(P1) ; Get specified byte size
JRST @[ RTYUNS ; Dispatch on type: Unspecified
RTYTXT ; Text
RTYBIN ; Binary
RTYPAG](C) ; Paged
; CKRPAR (cont'd)
; Here for type unspecified
RTYUNS: SKIPN D,B ; File byte size known?
JRST [ TLNE A,(77B5) ; Indexable JFN?
FTPM(COMM,,<Type specification required to retrieve %1F>,1)
FTPM(NO,,<Type specification required to retrieve %1F>,1)]
MOVEI C,2 ; Assume binary
CAIN B,7 ; 7-bit file?
MOVEI C,1 ; Yes, assume text
JRST CKRPA4 ; Go set parameters
; Here for type Text
RTYTXT: SKIPE D,B ; File byte size known?
CAIN D,↑D36 ; Yes, 36 bit words?
MOVEI D,7 ; Not known or 36, assume 7 bit
CAIE D,7 ; Legal byte size?
CAIN D,8
JRST CKRPA4 ; Yes
TLNE A,(77B5) ; Indexable JFN?
FTPM(COMM,,<Type Text inconsistent with byte size %4D of file %1F>,1)
FTPM(NO,,<Type Text inconsistent with byte size %4D of file %1F>,1)
; Here for type Binary
RTYBIN: JUMPN D,.+3 ; Transfer byte size specified?
SKIPN D,B ; No, substitute file byte size
JRST [ TLNE A,(77B5) ; Indexable JFN?
FTPM(COMM,,<Byte size specification required to retrieve %1F>,1)
FTPM(NO,,<Byte size specification required to retrieve %1F>,1)]
JUMPE B,CKRPA4 ; Ok if file byte size unknown
CAMN B,D ; Both known, consistent?
JRST CKRPA4 ; Yes
CAIE B,↑D36 ; No, allow only if file byte size is 36
JRST [ TLNE A,(77B5) ; Indexable JFN?
FTPM(COMM,,<File %1F not retrieved:
requested byte size = %4D but actual file byte size = %2D>,1)
FTPM(NO,,<File %1F not retrieved:
requested byte size = %4D but actual file byte size = %2D>,1)]
FTPM(COMM,,<File %1F byte size = %2D being retrieved
with byte size = %4D. This may be incorrect -- beware!>)
JRST CKRPA4
; Here for type Tenex-Paged
RTYPAG: TRNN F,DSKDVF ; Is local file on disk?
PUSHJ P,SCREWUP## ; No (should not get here)
MOVEI D,↑D36 ; Set local byte size to 36
; All cases converge here
; C/ Transfer type, D/ Transfer byte size
CKRPA4: MOVEM C,P.TYPE(P1) ; Store type and byte size
MOVEM D,P.BYTE(P1)
JRST SKPRET## ; Return +2
; "Retrieve" subroutines ...
; Generate retrieval property list reply
; Specifically, generate Here-is-Property-List command
; Assumes TMPPRP contains Type/Byte-size properties for this file,
; FILPRP contains Desired-property property from user request,
; SRCJFN setup
; Returns +1
; Clobbers A-D
GNRPRP: PUSHJ P,SAVE1##
MOVE P1,FILPRP+P.DPRP
HRROI A,NETBUF ; Where to buffer property list
HRRZ B,SRCJFN## ; Get file JFN
MOVE C,FILPRP+P.DPRP
PUSHJ P,GFNPRP ; Generate filename properties
HRRZ B,TMPPRP+P.TYPE ; Get type
HRRZ C,TMPPRP+P.BYTE ; Get byte size
TXNE P1,1B<X.TYPE>+1B<X.BYTE> ; Type and/or Byte-size requested?
XCT [ ; Append properties as appropriate
WRITE <(Type Text)>
WRITE <(Type Binary)(Byte-Size %3D)>
WRITE <(Type Tenex-Paged)>
]-1(B)
TXNE P1,1B<X.SIZE>+1B<X.CDAT>+1B<X.WDAT>+1B<X.RDAT> ; Want these props?
TRNN F,DSKDVF ; Is file on disk?
JRST GNRPR2 ; No, omit remaining properties
PUSH P,D+1
PUSH P,A ; Yes, save dest designator
HRRZ A,SRCJFN## ; Get file JFN
MOVE B,[4,,12] ; Read FDBSIZ FDBCRE, FDBWRT, FDBRED
MOVEI C,B ; Put them in B, C, D, D+1
GTFDB
POP P,A ; Restore dest designator
TXNE P1,1B<X.SIZE> ; Output whatever was requested
WRITE <(Size %2D)>
TXNE P1,1B<X.CDAT>
WRITE <(Creation-date %3Z)>
TXNE P1,1B<X.WDAT>
WRITE <(Write-date %4Z)>
JUMPE D+1,.+3 ; Skip if never read
TXNE P1,1B<X.RDAT>
WRITE <(Read-date %5Z)>
POP P,D+1
GNRPR2: HRROI A,NETBUF ; Make ptr to property list
FTPM(PLST,,<(%1S)>,1) ; Send off command and return
; Open file for retrieval
; Assumes file JFN is in SRCJFN
; and that transfer parameters are in TMPPRP
; Returns +1: Failed, "No" reply already generated
; +2: Succeeded, file open
; Clobbers A-D
OPNRET: TRNN F,DSKDVF ; Is file on disk?
JRST OPNRT1 ; No, bypass extension check
HRROI A,TEMP ; Yes, buffer file extension here
SETZM TEMP
HRRZ B,SRCJFN##
MOVSI C,(1B11) ; Get extension only
JFNS
MOVEI B,1B19+1B25 ; Assume want to open thawed
MOVE A,TEMP ; Get the extension
CAME A,[ASCII /SAV/] ; Leave thawed if .SAV
OPNRT1: MOVEI B,1B19 ; Open in frozen mode
MOVE A,TMPPRP+P.BYTE ; Get transfer byte size
DPB A,[POINT 6,B,5] ; Put in position
HRRZ A,SRCJFN## ; Setup JFN
OPENF ; Attempt to open
JRST [ TRC B,1B25 ; Failed, try flipping thawed bit
HRRZ A,SRCJFN##
OPENF
JRST ROPNER ; Failed again, give error
JRST .+1] ; Succeeded, continue
JRST SKPRET## ; Return +2
; "New-store"
C.NSTO: HRROS 0(P) ; Signal that this is a new-store
JRST .+2
; "Store"
C.STOR: HRRZS 0(P) ; Signal that this is an old-store
SETZM FILPRP ; Clear out property list
MOVE A,[FILPRP,,FILPRP+1]
BLT A,FILPRP+PLSIZE-1
HRROI A,NETBUF ; Set pointer to argument string
MOVEI B,FILPRP ; File property list
PUSHJ P,SCNPRP## ; Scan property list
POPJ P, ; Failed
MOVEI A,FILPRP
PUSHJ P,LOGCHK ; Check login/connect parameters
POPJ P, ; Failed
MOVEI A,TEMP ; Where to build GTJFN command list
MOVEI B,FILPRP ; Where property list is
PUSHJ P,FIXNAM ; Fix args, build command list
MOVE D,B ; Save main string ptr
MOVSI C,(1B0) ; For output use
HLLM C,TEMP
MOVE C,C.UACT ; Current user account designator
MOVEM C,TEMP+7
GTJFN ; Get a JFN for the file
JRST [ CAIE A,GJFX23 ; Failed, directory full?
JRST SGJFER ; Other error, fail
MOVE A,C.UNAM ; Yes, expunge login and connected dirs --
DELDF ; too hard to figure out exactly what dir
MOVE A,C.CNAM ; is involved, and login and connected dirs
CAME A,C.UNAM ; are the only ones we can expunge anyway
DELDF
MOVEI A,TEMP ; Try again
MOVE B,D
GTJFN
JRST SGJFER ; Still failed
JRST .+1]
MOVEM A,DSTJFN## ; Ok, save destination JFN
MOVE B,[FILPRP,,TMPPRP] ; Copy supplied property list
BLT B,TMPPRP+PLSIZE-1 ; into temps for this Store
PUSHJ P,CHKDSK ; Check device type
MOVEI B,TMPPRP ; Set pointer to property list
PUSHJ P,CKSPAR ; Check store parameters
JRST C.STO8 ; Bad, quit
PUSHJ P,OPNSTO ; Open file for store
JRST C.STO8 ; Failed
; Set file creation date to the date supplied in the property list
SKIPE C,TMPPRP+P.CDAT ; Date present in property list?
TRNN F,DSKDVF ; File on disk?
JRST C.STO2 ; No
HRRZ A,DSTJFN## ; Yes, set creation date
HRLI A,13
SETO B,
CHFDB
; Store (cont'd)
; Now that we have the file open, generate the positive reply
; and then await the "Here-is-file" command and file data
C.STO2: SKIPGE 0(P) ; Which kind of store?
JRST [ HRROI A,NETBUF ; New, buffer property list here
HRRZ B,DSTJFN##
MOVE C,FILPRP+P.DPRP
PUSHJ P,GFNPRP ; Generate filename properties
HRROI A,NETBUF ; Send Here-is-property-list reply
FTPM(PLST,,<(%1S)>)
JRST C.STO3]
HRRZ A,DSTJFN## ; Get JFN for use in message
FTPM(YES,0,<File %1F open, ready for data>)
C.STO3: PUSHJ P,GETCMD ; Get next command
JRST STOEND ; End received
CAIN A,MKFILE ; "Here-is-file"?
JRST C.STO7 ; Yes, go receive file
CAIN A,MKNO ; "No"? (i.e. abort)
JRST [ HRRZ A,DSTJFN## ; Yes, report abortion
LOG <Store of %1F aborted>
JRST KILFIL] ; Flush output file and return
MOVE C,MRKNAM(A) ; No, get dispatch
TLNN C,(OKSTOR) ; Command ok during "Store"?
JRST [ HRRO C,MRKNAM(A) ; No, make ptr to command name
FTPM(NO,3,<Command [%3S] out of sequence during Store>)
JRST KILFIL] ; Flush output file and return
MOVE C,MRKDSP(A) ; Ok, get dispatch
PUSHJ P,0(C) ; Do the command
JRST C.STO3 ; Look for another
; Here when "Here-is-file" command encountered
C.STO7: HRRZ A,DSTJFN ; Get file JFN
LOG <Store %1F> ; Make log entry
HLRZ A,FRKJFN(FX) ; Source is net
MOVEM A,SRCJFN##
MOVEI A,TMPPRP ; Property list being used
PUSHJ P,RECDAT## ; Do the store
JRST [ PUSHJ P,GETCMD ; Failed, suck up next command
JRST STOEND ; End received
HRRZ A,DSTJFN## ; Report failure
LOG <Data error during Store of %1F>
FTPM(NO,103,<Data error during Store of %1F>)
SETZM SRCJFN##
JRST KILFIL] ; Flush output file and return
SETZM SRCJFN##
PUSHJ P,GETCMD ; Done, get next command
JRST STOEND ; End received
CAIN A,MKNO ; Terminated by "No"?
JRST [ HRRZ A,DSTJFN## ; Report abortion
LOG <Store of %1F aborted>
FTPM(NO,106,<Store of %1F not completed>)
JRST KILFIL] ; Flush output file and return
CAIE A,MKYES ; Terminated by "Yes"?
JRST [ HRRO C,MRKNAM(A) ; No, make ptr to command name
FTPM(NO,3,<Command [%3S] out of sequence during Store>)
JRST KILFIL] ; Flush output file and return
HRRZ A,DSTJFN## ; Transfer ok
FTPM(YES,0,<Store of %1F completed>)
CLOSF ; Close file
ELOG <Unlikely CLOSF error: %1J%/>
SETZM DSTJFN##
POPJ P, ; Done
; Store (cont'd)
; Here to give up before opening file
C.STO8: HRRZ A,DSTJFN## ; Just release JFN
RLJFN
PUSHJ P,SCREWUP
SETZM DSTJFN##
POPJ P, ; Done
; Here when End received in the middle of a Store
STOEND: HRRZ A,DSTJFN## ; Report abortion
LOG <Store of %1F aborted>
PUSHJ P,KILFIL ; Delete output file if possible
JRST FTPEND ; Handle EOF normally
; "Store" subroutines ...
; Check and/or default parameters for "Store" command
; A/ JFN for file being stored
; B/ Pointer to property list
; Returns +1: Error, reply message already generated
; +2: Ok, type and byte size filled in appropriately
; Clobbers B-D
CKSPAR: HRRZ D,P.BYTE(B) ; Get bytesize specification
HRRZ C,P.TYPE(B) ; Dispatch on type
JRST @[ STYUNS ; Unspecified
STYTXT ; Text
STYBIN ; Binary
STYPAG](C) ; Paged
STYUNS: FTPM(NO,102,<Type specification required to store %1F>,1)
STYPAG: TRNN F,DSKDVF ; Paged, devide disk?
FTPM(NO,15,<Type Tenex-Paged illegal for non-disk files>,1)
MOVEI D,↑D36 ; Byte size is 36
JRST .+2
STYTXT: MOVEI D,7 ; Text, use byte size 7
STYBIN: SKIPN D ; Ensure have byte size
FTPM(NO,102,<Byte size specification required to store %1F>,1)
HRRM D,P.BYTE(B) ; Store byte size in property list
JRST SKPRET## ; Return +2
; Open file for store
; Assumes file JFN is in DSTJFN
; and that transfer parameters are in TMPPRP
; Returns +1: Failed, reply already generated
; +2: Succeeded, file open
; Clobbers A-D
OPNSTO: MOVE B,TMPPRP+P.BYTE ; Get transfer byte size
ROT B,-6 ; Put in position
HRRI B,1B20 ; Say opening for writing
HRRZ A,DSTJFN## ; Setup JFN
OPENF ; Attempt to open
JRST SOPNER ; Failed, give error
JRST SKPRET## ; Succeeded, return +2
; "New-enumerate"
C.NENU: HRROS 0(P) ; Set flag to denote new protocol
JRST .+2
; "Enumerate"
C.ENUM: HRRZS 0(P)
SETZM FILPRP ; Clear out property list
MOVE A,[FILPRP,,FILPRP+1]
BLT A,FILPRP+PLSIZE-1
HRROI A,NETBUF ; Set pointer to argument string
MOVEI B,FILPRP ; File property list
PUSHJ P,SCNPRP## ; Scan property list
POPJ P, ; Failed
MOVEI A,FILPRP
PUSHJ P,LOGCHK ; Check login/connect parameters
POPJ P, ; Failed
MOVEI A,TEMP ; Where to build GTJFN command list
MOVEI B,FILPRP ; Where property list is now
PUSHJ P,FIXNAM ; Fix args, build command list
SKIPN C,0(A) ; Version specified?
MOVEI C,-3 ; No, default to *
HRLI C,(1B2+1B11) ; Old file, permit "*"
MOVEM C,0(A)
HRROI C,[ASCIZ /*/] ; Default name and extension to *
MOVEM C,4(A)
MOVEM C,5(A)
GTJFN ; Lookup the Server-Filename string
JRST RGJFER ; Failed, give reason and quit
MOVEM A,SRCJFN## ; Ok, save JFN and flags
SKIPL 0(P) ; New protocol?
JRST C.ENU2 ; No
MOVEI A,MKPLST ; Yes, begin the (single) reply
SETZ B,
PUSHJ P,BEGCMD
; Loop to generate file property list(s)
C.ENU2: PUSHJ P,SETWDT## ; Reset watchdog timer
HRRZ A,SRCJFN## ; Get JFN for file
PUSHJ P,CHKDSK ; Check device type
HRROI A,NETBUF ; Buffer the property list here
HRRZ B,SRCJFN## ; File JFN
MOVE C,FILPRP+P.DPRP
PUSHJ P,GENPRP ; Generate property list for file
HRROI B,NETBUF
SKIPGE 0(P) ; Which protocol?
JRST [ DTYPE <%2S>
HRRZ A,FRKJFN(FX) ; New, just send property list itself
SETZ C,
SOUT
JRST .+2]
FTPM(PLST,0,<%2S>) ; Old, send entire Here-is-property-list response
MOVE A,SRCJFN## ; Recover JFN and flags
GNJFN ; Step to next if any
JRST [ SETZM SRCJFN## ; No more, done
SKIPL 0(P)
POPJ P, ; Old protocol
PUSHJ P,ENDCMD ; New protocol, force byte stream
DTYPE <%/>
POPJ P,]
JRST C.ENU2 ; More, repeat
; Generate complete file property list for supplied JFN
; A/ Destination designator
; B/ JFN
; C/ Desired-property flags
; Returns +1 always: A/ Designator (updated if string ptr)
; Clobbers B-D
GENPRP: PUSHJ P,SAVE1##
MOVE P1,C ; Preserve Desired-property flags
HRLM B,0(P) ; Preserve file JFN
WRITE <(> ; Start property list
PUSHJ P,GFNPRP ; Generate filename properties
MOVE D,A ; Move designator to D
TXNE P1,1B<X.TYPE>+1B<X.BYTE>+1B<X.SIZE>+1B<X.CDAT>+1B<X.WDAT>+1B<X.RDAT>+1B<X.AUTH>
; Want any of these properties?
TRNN F,DSKDVF ; Is file on disk?
JRST GENPR9 ; No, no more attributes
; For disk, output all interesting things in the FDB
HLRZ A,0(P)
MOVE B,[25,,0] ; Read entire FDB
MOVEI C,TEMP ; Put it here
GTFDB
TXNN P1,1B<X.TYPE>+1B<X.BYTE> ; Want Type and/or Byte-size?
JRST GENPR2 ; No
LDB B,[POINT 6,TEMP+11,11] ; Get byte size
JUMPE B,GENPR2 ; Jump if unknown
CAIN B,7 ; Say Text if byte size 7
WRITE D,<(Type Text)>
CAIE B,7 ; Binary for anything else
WRITE D,<(Type Binary)(Byte-size %2D)>
GENPR2: MOVE B,TEMP+12 ; Get file length
TXNE P1,1B<X.SIZE> ; Want Size property?
WRITE D,<(Size %2D)>
MOVE B,TEMP+13 ; Get creation date
TXNE P1,1B<X.CDAT> ; Want Creation-date property?
WRITE D,<(Creation-date %2Z)>
MOVE B,TEMP+14 ; Get write date
TXNE P1,1B<X.WDAT> ; Want Write-date property?
WRITE D,<(Write-date %2Z)>
TXNN P1,1B<X.RDAT> ; Want Read-date property?
JRST .+3
SKIPE B,TEMP+15 ; Get read date if there is one
WRITE D,<(Read-date %2Z)>
TXNN P1,1B<X.AUTH> ; Want Author property?
JRST .+4
HLRZ B,TEMP+6 ; Get author
SKIPE B ; Output if present
WRITE D,<(Author %2U)>
GENPR9: MOVE A,D ; Destination designator back to A
WRITE <)> ; End property list
POPJ P, ; Done
; "Delete"
C.DELE: SETZM FILPRP ; Clear out property list
MOVE A,[FILPRP,,FILPRP+1]
BLT A,FILPRP+PLSIZE-1
HRROI A,NETBUF ; Set pointer to argument string
MOVEI B,FILPRP ; File property list
PUSHJ P,SCNPRP## ; Scan property list
POPJ P, ; Failed
MOVEI A,FILPRP
PUSHJ P,LOGCHK ; Check login/connect parameters
POPJ P, ; Failed
MOVEI A,TEMP ; Where to build GTJFN command list
MOVEI B,FILPRP ; Where property list is now
PUSHJ P,FIXNAM ; Fix args, build command list
SKIPN C,0(A) ; Was version specified?
MOVEI C,-2 ; No, default to lowest
HRLI C,(1B2+1B11) ; Old file, permit "*"
MOVEM C,0(A)
GTJFN ; Lookup the Server-Filename string
JRST RGJFER ; Failed, give reason and quit
MOVEM A,SRCJFN## ; Ok, save source JFN and flags
HRRZS A
PUSHJ P,CHKDSK ; Check device type
; Now have JFN (possibly indexable)
; Back here for each file referenced by the JFN
C.DEL1: PUSHJ P,SETWDT## ; Reset watchdog timer
HRROI A,NETBUF ; Where to buffer property list
HRRZ B,SRCJFN## ; Get file JFN
MOVE C,FILPRP+P.DPRP
PUSHJ P,GENPRP ; Generate full property list
HRROI A,NETBUF ; Make ptr to property list
FTPM(PLST,,<%1S>) ; Send it off
; Await "Yes" or "No" from user
C.DEL2: PUSHJ P,GETCMD ; Get next command
JRST [ HRRZ A,SRCJFN## ; Connection closed, release JFN
RLJFN
PUSHJ P,SCREWUP##
SETZM SRCJFN##
JRST FTPEND] ; Handle EOF normally
CAIN A,MKNO ; Check command
JRST C.DEL8 ; "No", skip this file
CAIN A,MKYES
JRST C.DEL6 ; "Yes", delete this file
MOVE C,MRKNAM(A) ; Not one of those, get dispatch
TLNN C,(OKRETR) ; Command ok in this context?
JRST [ HRRZ A,SRCJFN## ; No, flush file JFN
RLJFN
PUSHJ P,SCREWUP##
SETZM SRCJFN##
HRROS C ; Make string ptr to command name
FTPM(NO,3,<Command [%3S] out of sequence during Delete>,1)]
MOVE C,MRKDSP(A) ; Ok, get command dispatch
PUSHJ P,0(C) ; Do the command
JRST C.DEL2 ; Look for another
; Here when "Yes" encountered. Now delete the file.
C.DEL6: HRRZ A,SRCJFN## ; Get file JFN
LOG <Delete %1F> ; Make log entry
HRLI A,400000 ; Don't release JFN
DELF ; Delete file
JRST [ LOG <Delete failed - %1J>
PUSHJ P,DELERR ; Report reason
JRST C.DEL8] ; On to next
HRRZ A,SRCJFN## ; Succeeded, report
FTPM(YES,0,<File %1F deleted>)
; Here when done deleting one file. Check for more to do
C.DEL8: MOVE A,SRCJFN## ; Get JFN with flags
GNJFN ; Step to next file if any
JRST [ SETZM SRCJFN## ; No more, done (JFN released)
POPJ P,]
JRST C.DEL1 ; Another, go delete it
; "Rename"
C.RENA: SETZM FILPRP ; Clear out property list
MOVE A,[FILPRP,,FILPRP+1]
BLT A,FILPRP+PLSIZE-1
SETZM TMPPRP ; Clear out another property list
MOVE A,[TMPPRP,,TMPPRP+1]
BLT A,TMPPRP+PLSIZE-1
HRROI A,NETBUF ; Set pointer to argument string
MOVEI B,FILPRP ; Where to put properties
PUSHJ P,SCNPRP## ; Scan property list
POPJ P, ; Failed
MOVEI B,TMPPRP
PUSHJ P,SCNPRP## ; Scan second property list
POPJ P,
MOVEI A,FILPRP
PUSHJ P,LOGCHK ; Check login/connect parameters
POPJ P, ; Failed
MOVEI A,TEMP ; Where to build GTJFN command list
MOVEI B,FILPRP ; Where "old" property list is now
PUSHJ P,FIXNAM ; Fix args, build command list
MOVSI C,(1B2) ; Old file required
IORM C,0(A)
GTJFN ; Lookup the "old" server filename
JRST RGJFER ; Failed, give reason and quit
MOVEM A,SRCJFN## ; Ok, save JFN
MOVEI A,TEMP ; Where to build GTJFN command list
MOVEI B,TMPPRP ; Where "new" property list is now
PUSHJ P,FIXNAM ; Fix args, build command list
MOVSI C,(1B0+1B1) ; Output use, new file only
IORM C,0(A)
GTJFN ; Get JFN for new file
JRST [ PUSHJ P,RENGJF ; Failed, give reason
HRRZ A,SRCJFN## ; Release old JFN
RLJFN
PUSHJ P,SCREWUP##
SETZM SRCJFN##
POPJ P,]
MOVE B,A ; Ok, get new JFN
MOVE A,SRCJFN## ; Old JFN
RNAMF ; Attempt rename
JRST [ PUSHJ P,RENERR ; Failed, give reason
HRRZ A,SRCJFN## ; Release old JFN
RLJFN
PUSHJ P,SCREWUP##
JRST .+2]
FTPM(YES,0,<Rename to %2F successful>)
SETZM SRCJFN## ; Old JFN now released
MOVE A,B ; Release new JFN
RLJFN
PUSHJ P,SCREWUP##
POPJ P, ; Done
; Generate filename properties given JFN
; A/ Destination designator
; B/ JFN
; C/ Desired-property flags
; Assumes DSKDVF set properly
; Returns +1 always: A/ Designator (updated if string ptr)
; Generates Device, Directory, Name-Body, Version, and
; Server-Filename properties as appropriate
; Clobbers B-D
GFNPRP: PUSHJ P,SAVE1##
MOVE P1,C ; Preserve flags
HRLM B,0(P) ; Preserve file JFN
MOVE D,A ; Put dest designator in D
TXNE P1,1B<X.DEVI> ; Want Device property?
TRNE F,DSKDVF ; Device disk?
JRST GFNPR1 ; Yes, omit device property
MOVSI C,(1B2) ; Print just device
PUSHJ P,DOJFNS ; Convert device name to string
WRITE D,<(Device %2S)> ; Generate property
GFNPR1: TXNE P1,1B<X.DIRE> ; Want Directory property?
TRNN F,DSKDVF ; Device disk?
JRST GFNPR2 ; No, omit directory
HLRZ B,0(P) ; Yes, get file JFN
MOVSI C,(1B5) ; Want just directory
PUSHJ P,DOJFNS ; Convert directory to string
WRITE D,<(Directory %2S)>; Generate property
GFNPR2: TXNN P1,1B<X.NAMB> ; Want Name-body property?
JRST GFNPR5 ; No
HLRZ B,0(P) ; Get file JFN
MOVE C,[1B8+1B11+1B35] ; Want name and ext, punctuated
PUSHJ P,DOJFNS ; Convert to string
PUSH P,B ; See if it ends in "."
GFNPR4: ILDB C,B
CAIN C,"."
JRST [ MOVE C,B
ILDB C,C
JUMPN C,GFNPR4
DPB C,B ; Yes, strip off trailing "."
JRST .+2]
JUMPN C,GFNPR4
POP P,B
WRITE D,<(Name-Body %2S)>; Generate property
GFNPR5: TXNE P1,1B<X.VERS> ; Want Version property?
TRNN F,DSKDVF ; Device disk?
JRST GFNPR3 ; No, omit version
HLRZ B,0(P) ; Yes, get file JFN
MOVSI C,(1B14) ; Want just version
PUSHJ P,DOJFNS ; Convert version to string
WRITE D,<(Version %2S)> ; Generate property
GFNPR3: TXNN P1,1B<X.SFIL> ; Want Server-filename property?
JRST GFNPR6 ; No
HLRZ B,0(P) ; Get file JFN
TRNN F,DSKDVF ; Device disk?
TDZA C,C ; No, print in default format
MOVE C,[2B2+1B5+1B8+1B11+1B14+1B21+1B35] ; Yes, force dir
PUSHJ P,DOJFNS ; Convert filename to string
WRITE D,<(Server-Filename %2S)>; Generate property
GFNPR6: MOVE A,D ; Put designator back in A
POPJ P, ; Done
; Do JFNS with output suitable for inclusion in property list
; B/ File JFN
; C/ JFNS flags
; Returns +1:
; B/ String ptr to JFNS text
; Clobbers A-C
DOJFNS: MOVE A,[POINT 7,TEMP] ; Where to put temp text
JFNS ; Convert to string
MOVE A,[POINT 7,TEMP] ; Source string
MOVE B,[POINT 7,TEMP+100] ; Destination string
DOJFN1: ILDB C,A ; Get a char
CAIN C,"V"-100 ; Tenex filename quote?
JRST DOJFN1 ; Yes, flush it
CAIE C,"(" ; Character need to be quoted?
CAIN C,")"
JRST .+3 ; Yes
CAIE C,PQUOTE
JRST DOJFN2 ; No
MOVEI C,PQUOTE ; Yes, insert quote character
IDPB C,B
LDB C,A ; Recover character
DOJFN2: IDPB C,B ; Store the character
JUMPN C,DOJFN1 ; Repeat if not at end
MOVE B,[POINT 7,TEMP+100] ; Where result string is now
POPJ P, ; Done
; Here to handle GTJFN errors peculiar to "Retrieve"
RGJFER::CAIL A,GJFX18 ; File not found errors
CAILE A,GJFX21
CAIN A,GJFX24
FTPM(NO,100,<No such file exists>,1)
JRST GJFERR ; Handle rest same as Store
; GTJFN errors peculiar to "Rename"
RENGJF: CAIE A,GJFX27 ; New file only
CAIN A,GJFX20 ; No such version (?? -- really flakey)
FTPM(NO,112,<Rename "to" file already exists>,1)
; GTJFN errors peculiar to "Store"
SGJFER: CAIL A,GJFX18 ; File not found errors
CAILE A,GJFX21 ; Really mean can't create file
CAIN A,GJFX24
FTPM(NO,101,<No access to create that file>,1)
; Here for errors common to "Retrieve" and "Store"
GJFERR: CAIL A,GJFX4 ; Illegal format errors
CAILE A,GJFX15
CAIN A,GJFX31
FTPM(NO,11,<Illegal filename>,1)
CAIE A,GJFX33 ; More illegal format errors
CAIN A,GJFX34
FTPM(NO,11,<Illegal filename>,1)
CAIN A,GJFX16 ; More file not found errors
FTPM(NO,100,<No such device exists>,1)
CAIN A,GJFX17
FTPM(NO,100,<No such directory exists>,1)
CAIN A,GJFX32
FTPM(NO,100,<No such file exists>,1)
FTPM(NO,0,<Filename error: %1J>,1) ; All others
; Here to handle OPENF errors peculiar to "Retrieve"
ROPNER::HRRZ C,SRCJFN## ; Setup JFN for reply message
JRST OPNERR ; Join common code
; Here to handle OPENF errors peculiar to "Store"
SOPNER: HRRZ C,DSTJFN## ; Setup JFN for message
; OPENF failure code common to "Retrieve" and "Store"
OPNERR: CAIL A,OPNX3 ; Check for protection errors
CAILE A,OPNX6
CAIN A,OPNX13
FTPM(NO,101,<Access denied to file %3F>,1)
CAIN A,OPNX23
FTPM(NO,101,<Access denied to directory containing %3F>,1)
CAIN A,OPNX9 ; File busy error
FTPM(NO,111,<File %3F busy>,1)
CAIN A,OPNX10 ; Disk full error
FTPM(NO,104,<No room for file %3F>,1)
CAIN A,SFBSX2 ; Byte size error
FTPM(NO,102,<Illegal byte size for file %3F>,1)
FTPM(NO,0,<File open error: %1J for file %3F>,1) ; Other
; "Delete" errors
DELERR: HRRZ C,SRCJFN##
CAIN A,DELFX1
FTPM(NO,101,<Delete access denied to file %3F>,1)
FTPM(NO,0,<Delete error: %1J for file %3F>,1)
; "Rename" errors
RENERR: HRRZ C,SRCJFN## ; Get "from" JFN
CAIN A,RNAMX3
FTPM(NO,101,<Access denied to new file %2F>,1)
CAIN A,RNAMX5
FTPM(NO,111,<File %2F busy>,1)
CAIN A,RNAMX8
FTPM(NO,101,<Access denied to existing file %3F>,1)
CAIN A,RNMX10
FTPM(NO,101,<File %3F busy>,1)
FTPM(NO,0,<Rename %3F to %2F failed: %1J>,1)
; -----------------------------------------------------------------
; File system utilities
; -----------------------------------------------------------------
; Check for device disk
; A/ JFN for file being retrieved or stored
; Returns +1 always
; Sets DSKDVF flag appropriately
; Clobbers B, C
CHKDSK: PUSH P,A ; Save JFN
DVCHR ; Get device characteristics
POP P,A ; Restore JFN
TLNN B,377 ; Check device type
TROA F,DSKDVF ; Device is a disk
TRZ F,DSKDVF ; Device is not a disk
POPJ P,
; "Kill" destination file, i.e. delete all its pages and
; try very hard to make it go away (works only for disk).
; Assumes DSTJFN contains open output JFN and that DSKDVF
; has already been set appropriately.
; Returns +1 always
; Closes and releases JFN
; Clobbers A-D
KILFIL::HRRZ A,DSTJFN## ; Get destination JFN
DELF ; First attempt to delete file
JRST KILFI5 ; Non-directory or no access, stop
TRNN F,DSKDVF ; Output to disk?
JRST KILFI5 ; No, just close file
MOVE B,[1,,1] ; Yes, get FDBCTL word
MOVEI C,C
GTFDB
TLNN C,(1B4) ; FDBNXF set?
JRST KILFI5 ; No, file previously existed
PUSHJ P,DELPGS ; Yes, delete all pages in file
HRRZ A,DSTJFN## ; Close the file
HRLI A,400000 ; but don't release JFN
CLOSF
POPJ P, ; Failed? give up
HRLI A,1 ; Now set FDBNXF to make the
MOVSI B,(1B4) ; file look invisible
MOVSI C,(1B4)
CHFDB
HRRZ A,DSTJFN## ; Release JFN
RLJFN
CAI
SETZM DSTJFN##
POPJ P, ; Done
; Here to just close file
KILFI5: HRRZ A,DSTJFN##
CLOSF
CAI
SETZM DSTJFN##
POPJ P,
; Delete all pages in a disk file
; Assumes file open for writing
; A/ JFN
; Returns +1 always
; Clobbers A, B
DELPGS::HRLZ A,A ; Make designator for file page 0
SETO B, ; Set arg for deleting pages
DELPG1: FFUFP ; Find next existing page
POPJ P, ; No more, done
EXCH A,B ; Found one, delete it
PMAP
EXCH A,B
AOJA A,DELPG1 ; On to next
; Fix up filename strings for Retrieve, Store, etc.
; A/ Where to build command list for GTJFN
; B/ Property list pointer
; Specifically, if a Server-Filename was not supplied, construct
; one from the Name-Body property. Then setup the remaining
; properties (if any) as defaults.
; Returns +1:
; A/ unchanged
; B/ main string pointer (for GTJFN)
; Clobbers B, C
FIXNAM: HRRZ C,P.VERS(B) ; Default version
MOVEM C,0(A)
MOVE C,[377777,,377777] ; No file i/o for GTJFN
MOVEM C,1(A)
SKIPE C,P.DEVI(B) ; Device supplied?
HRROI C,P.DEVI(B) ; Yes, set default device
MOVEM C,2(A)
SKIPE C,P.DIRE(B) ; Directory supplied?
HRROI C,P.DIRE(B) ; Yes, set default directory
MOVEM C,3(A)
SETZM 4(A) ; No default name
SETZM 5(A) ; No default extension
SETZM 6(A) ; No default protection
SETZM 7(A) ; No default account
MOVEI B,P.SFIL(B) ; Make string ptr to server name
HRLI B,(POINT 7)
SKIPN 0(B) ; Is there one?
HRRI B,P.NAMB-P.SFIL(B) ; No, use name body
CAIE SV,SV.MAI ; Done if not a mail server
POPJ P,
; Can get here only during Retrieve command issued to Mail server.
; Force the directory to be <Secretary> and the extension to be .DL,
; and explicitly concatenate them to the main name string (rather than
; supplying them as defaults) so that they cannot be overridden by the user.
SETZM 2(A) ; No default device or directory
SETZM 3(A)
PUSH P,A
PUSH P,B
ILDB A,B ; Scan name string for "↑"
CAIE A,"↑"
JUMPN A,.-2
SETZ A, ; Truncate string at that point
DPB A,B
POP P,B
HRROI A,TEMP+20 ; Buffer new name here
WRITE <<SECRETARY>%2S.DL>
HRROI B,TEMP+20 ; Return that name instead
POP P,A
POPJ P,
; Anonymous login (permitted only for mail server .DL retrieval).
ANOLOG: SKIPN C.UNAM ; Currently logged in?
JRST SKPRET## ; No, proceed using PUPSRV capabilities
; If already logged in, check login/connect parameters as usual.
; Check and apply login/connect parameters
; A/ Property list pointer
; Returns +1: Incorrect, reply already generated
; +2: Parameters correct
; Updates flags LOGCKF, ACTCKF, and CONCKF appropriately
; Clobbers A-D
LOGCHK::PUSHJ P,SAVE1## ; Save P1
MOVE P1,A ; Setup property list pointer
; Check login directory # and password
SKIPN A,P.UNAM(P1) ; Setup supplied dir #
FTPM(NO,2,<User-Name and Password required>,1)
CAME A,C.UNAM ; Same as current?
JRST LOGCH1 ; No, have to re-check
HRROI A,P.UPSW(P1) ; Same password?
HRROI B,C.UPSW
PUSHJ P,STRCMP##
LOGCH1: TRZ F,LOGCKF+ACTCKF+CONCKF ; No, invalidate parameters
TRNE F,LOGCKF ; Need to check name/password?
JRST LOGCH2 ; No, bypass
; Name and/or password not the same as before (or not logged in
; previously). "Log in" this fork as specified.
HRRZ A,P.UNAM(P1) ; Get dir #
HRLI A,(1B1) ; Want proxy login
HRROI B,P.UPSW(P1) ; String ptr to password
CNDIR ; Do login of fork group
JRST [ CAIN A,CNDIX1 ; Failed, check error
FTPM(NO,21,<User-Password incorrect>,1)
FTPM(NO,20,<Login failure: %1J>,1)]
; *** Explicitly verify password, since it's not checked if
; logging in under the "current" login directory (e.g. SYSTEM)
HRLI A,(1B0) ; Say check password
CNDIR
FTPM(NO,21,<User-Password incorrect>,1)
; ***
; Now successfully "logged in". Record successful name/password
; combination for future checks.
HRRZ B,P.UNAM(P1) ; Ok, record current user name
MOVEM B,C.UNAM
MOVEM B,C.CNAM ; Now connected to that dir also
MOVSI A,P.UPSW(P1) ; Record successful password
HRRI A,C.UPSW
BLT A,C.UPSW+USRSTL/5
TRO F,LOGCKF+CONCKF ; Say logged in and connected ok
LOG <Login as user %2U> ; Make log entry
HRROI A,C.UACT+1 ; Where to put default acct string
GDACC ; Get default account
SETZ A, ; None, remember so
MOVEM A,C.UACT ; Store account designator
IFN RECPWF,<
MOVE A,C.UNAM
HRROI B,C.UPSW
PUSHJ P,RECPAS##
>
; LOGCHK (cont'd)
; See whether account is same as before.
LOGCH2: SKIPN B,C.UACT ; Get current account designator
JRST LOGCH3 ; None, force check of new one
SKIPE A,P.UACT(P1) ; Get specified account designator
CAMN A,B ; Numeric and same as current?
JRST LOGCH4 ; Yes (or none), don't force check
TLC A,(5B2) ; Zero B0-2 if numeric
TLC B,(5B2)
TLNE A,(7B2) ; Both string?
TLNN B,(7B2)
JRST LOGCH3 ; No, need to re-check
TLC A,(5B2) ; Yes, fix string pointers
TLC B,(5B2)
PUSHJ P,STRCMP## ; Compare strings
LOGCH3: TRZ F,ACTCKF ; Not equal, force check
LOGCH4: TRNE F,ACTCKF ; Need to check account?
JRST LOGCH6 ; No
; Account different from before, check new one.
HRRZ A,C.UNAM ; Yes, setup dir # of user
SKIPN B,P.UACT(P1) ; Get account designator if given
SKIPE B,C.UACT ; Default if not given
VACCT ; Verify account
FTPM(NO,22,<User-Account invalid>,1)
; New account is ok. Remember it for future checks.
SKIPN A,P.UACT(P1) ; Get supplied designator
JRST LOGCH5 ; Not supplied, remember default
MOVSI B,P.UACT(P1) ; Copy string if there is one
HRRI B,C.UACT
BLT B,C.UACT+USRSTL/5+1
HRROI B,C.UACT+1 ; Make string ptr
TLC A,(5B2) ; Is designator numeric?
TLNE A,(7B2)
MOVEM B,C.UACT ; No, store string ptr
LOGCH5: TRO F,ACTCKF ; Note that acct has been checked
; See whether connected dir # and password are same as before
LOGCH6: SKIPN A,P.CNAM(P1) ; Get specified connected dir #
MOVE A,C.UNAM ; None, assume same as login
CAME A,C.CNAM ; Same as current?
JRST LOGCH7 ; No, have to re-check
HRROI A,P.CPSW(P1) ; Same password?
HRROI B,C.CPSW
PUSHJ P,STRCMP##
LOGCH7: TRZ F,CONCKF ; No, invalidate parameters
TRNE F,CONCKF ; Need to check name/password?
JRST SKPRET## ; No, done, return +2
; Not the same, do new "connect" of fork to dir.
SKIPN A,P.CNAM(P1) ; Get connect dir #
MOVE A,C.UNAM ; None, use login dir #
HRROI B,P.CPSW(P1) ; Password
CNDIR ; Connect to directory
JRST [ CAIN A,CNDIX1 ; Failed, check error code
FTPM(NO,24,<Connect-Password incorrect>,1)
FTPM(NO,23,<Connect failure: %1J>,1)]
HRRZM A,C.CNAM ; Succeeded, save current dir #
MOVSI A,P.CPSW(P1) ; Record successful password
HRRI A,C.CPSW
BLT A,C.CPSW+USRSTL/5
TRO F,CONCKF ; Say connected ok
JRST SKPRET## ; Done, return +2
; -----------------------------------------------------------------
; Subroutines
; -----------------------------------------------------------------
; Get next command
; Returns +1: End received
; +2: Ok, A/ Mark type, B/ Subcommand byte (if any)
; Clobbers A-D
; Check status to distinguish between Mark and End
GETCMD::PUSHJ P,SETWDT## ; Reset watchdog timer
HLRZ A,FRKJFN(FX) ; Get input JFN
SETZ C, ; Don't want address stuff
GDSTS ; Get status
TLNE B,(1B5) ; End received?
POPJ P, ; Yes, fail return
TLZN B,(1B4) ; Mark received?
JRST GETCM4 ; No, go flush extraneous data
; Got Mark, prepare to process command
SDSTS ; Clear flag
MOVEI B,23 ; Get the Mark byte
MTOPR
CAIGE C,NMARKS ; Mark byte in range?
SKIPN D,MRKNAM(C) ; Yes, fetch name pointer
JRST GETCME ; No or undefined
PUSH P,C ; Save Mark byte
TLNE D,(NFETCH) ; Want to pre-fetch command text?
JRST GETCM2 ; No
HRROI B,NETBUF ; Yes, buffer as 7-bit ASCII
MOVNI C,5000 ; Max # bytes in buffer
SIN
SETZ A,
SKIPGE C ; Unless completely filled buffer,
IDPB A,B ; Put null on end
SKIPA D,[POINT 7,NETBUF] ; Init string ptr
GETCM2: SETZB D,NETBUF ; Here if no text
POP P,A ; Recover Mark byte
HRRO C,MRKNAM(A) ; Get name string
SKIPGE MRKNAM(A) ; Does command have subcommands?
JRST GETCM3 ; Yes
DTYPE <U: [%3S] %4S%/> ; No, print command if debugging
JRST SKPRET## ; Return +2
GETCM3: ILDB B,D ; Get subcommand
DTYPE <U: [%3S] <%2O> %4S%/>; Print command if debugging
JRST SKPRET## ; Return +2
; Here if command undefined
GETCME: FTPM(NO,1,<Undefined command [%3O]>)
; Flush byte stream data to next Mark
GETCM4: HLRZ A,FRKJFN(FX) ; Get input JFN
MOVE B,[POINT 8,NETBUF] ; Byte ptr to buffer
MOVNI C,4000 ; # bytes in buffer
SIN ; Suck bytes from net
JUMPGE C,GETCM4 ; Repeat if didn't get it all
JRST GETCMD ; Go look again for Mark
; Refill the command buffer if necessary
; A/ used string pointer into NETBUF
; Returns +1:
; A/ updated string pointer
; Clobbers B-D
REFILL::TRNN A,400 ; Have we read half the buffer?
POPJ P, ; No, nothing to do
MOVE B,[NETBUF+400,,NETBUF] ; Yes, move upper half down
BLT B,NETBUF+377
SUBI A,400 ; Fix pointer
PUSH P,A ; Save it
HLRZ A,FRKJFN(FX) ; Get net input JFN
HRROI B,NETBUF+400 ; Where to put more input
MOVNI C,400*5 ; Max # chars
SIN ; Get more input
SETZ A,
SKIPGE C ; Unless buffer filled,
IDPB A,B ; Put null on end
PUSHJ P,SETWDT## ; Reset watchdog timer
POP P,A ; Restore byte ptr
POPJ P,
; FTPM (mark type, sub-code, <string>, pop count)
; UUO to generate FTP reply message
%UFTPM::PUSH P,@40 ; Preserve control word
AOS 40 ; Advance to start of string
PUSHJ P,FORMAT## ; Call UUO output formatter
HRROI A,TEMP+600 ; Setup -- buffer reply here
PUSHJ P,UFTPM2 ; Completion -- send off reply
HRLS 0(P) ; Put pop count (+1) in both halves
SUB P,0(P) ; Pop stack appropriately
POPJ P, ; Return from UUO (or from caller)
; FTPM completion
UFTPM2: SETZ B, ; Terminate string with null
IDPB B,A
; If an End has been encountered on the receive connection, do not
; send any replies: the user is attempting to shut down the connection
; in the middle of a command, and sending any data may cause a deadlock.
HLRZ A,FRKJFN(FX)
SETZ C,
GDSTS
TLNE B,(1B5) ; End received?
POPJ P, ; Yes, do nothing
LDB A,[POINT 8,-6(P),7] ; Get Mark type
LDB C,[POINT 8,-6(P),15] ; Get subcommand code if any
HRROI B,TEMP+600 ; Point to buffered reply
; JRST SNDCMD ; Send off the command and return
; Send a command
; A/ Command number (Mark type)
; B/ String ptr to command text (0 => none)
; C/ Subcommand (iff command requires one)
; Returns +1
; Clobbers A-D
SNDCMD: PUSHJ P,BEGCMD ; Do the work
JRST ENDCMD ; Force transmission
; Begin command, i.e. do all the output but don't force
; transmission. Calling sequence same as SNDCMD
BEGCMD::HRRO D,MRKNAM(A) ; Get string ptr to command name
SKIPL MRKNAM(A) ; Does command have subcommands?
DTYPE <S: [%4S] %2S%/> ; No
SKIPGE MRKNAM(A)
DTYPE <S: [%4S] <%3O> %2S%/>; Yes
MOVE D,B ; Save string ptr
HRLM C,0(P) ; Save subcommand if any
MOVE C,A ; Copy command number
HRRZ A,FRKJFN(FX) ; Get output JFN
MOVEI B,3 ; Send Mark
MTOPR
HLRZ B,0(P) ; Get subcommand if any
SKIPGE MRKNAM(C) ; Does command have subcommands?
BOUT ; Yes, send subcommand code
SETZ C,
SKIPE B,D ; Is there a string?
SOUT ; Yes, send it
POPJ P, ; Done
; End command by forcing the byte stream
; Returns +1
; Clobbers A, B
ENDCMD: HRRZ A,FRKJFN(FX) ; Get output JFN
MOVEI B,21 ; Force transmission
MTOPR
POPJ P,
; PSI channel definitions
DEFINE PSI(CH,LEV,DISP) <
ACTCHN==ACTCHN!1B<CH>
RELOC CHNTAB+↑D<CH>
LEV ,, DISP
>
ACTCHN==0
CHNTAB: PSI(9,1,PDLOVF##) ; Pushdown overflow
PSI(11,1,FTSDTE) ; Data error
PSI(15,1,ILLINS##) ; Illegal instruction
PSI(16,1,ILLRED##) ; Illegal read
PSI(17,1,ILLWRT##) ; Illegal write
PSI(18,1,ILLXCT##) ; Illegal execute
PSI(20,1,ILLSIZ##) ; Machine size exceeded
RELOC CHNTAB+↑D36
; Handling for data error in FTP server fork
FTSDTE: PUSH P,A ; Save an ac
SKIPL A,SRCDSP ; Check for error dispatches
SKIPGE A,DSTDSP
TRNN A,-1 ; Both specified and armed?
JRST DATERR## ; No, treat as fatal error
HRRZM A,CH1PC ; Armed, clobber interrupt pc
SETZM SRCDSP ; Disarm errors
SETZM DSTDSP
POP P,A
MOVE P,ERRPDP ; Go to correct stack level
DEBRK ; Break to error dispatch
; Storage
LSP NETBUF,1 ; Network I/O buffer
LSP FILBUF,1 ; Local file buffer
LS ERRPDP ; Stack pointer to restore on data error
LS SRCDSP ; Source file data error dispatch
LS DSTDSP ; Destination file data error dispatch
LS C.UNAM ; Current login dir #
LS C.UPSW,USRSTL/5+1 ; Current login password
LS C.UACT,USRSTL/5+2 ; Current account designator
LS C.CNAM ; Current connected dir #
LS C.CPSW,USRSTL/5+1 ; Current connect password
LS FILPRP,PLSIZE ; File property list (Store/Retrieve)
LS TMPPRP,PLSIZE ; Temp property list (for one transfer)
LS FRNHAD ; Foreign host address (net,,host)
LS FRNHNM,10 ; Foreign host name as a string
END