Trailing-Edge
-
PDP-10 Archives
-
bb-ev83b-bm
-
tcpip-sources/ftp2s.mac
There are 2 other files named ftp2s.mac in the archive. Click here to see a list.
MOVX A,<HSBAS/1000> ; Remove access to high segment
PUSH P,A ; Where the file activity code is
GOSPLP: MOVX A,<.FHSLF,,0> ; Page in this fork
HRR A,0(P) ; Here in the address space
RPACS ; See if the page exists
TXNN B,PA%PEX
JRST GONXTP ; No such page. See if any more.
MOVX B,1B8 ; Access to none, but trap if referenced
SPACS
GONXTP: AOS B,0(P) ; On to next page
CAIGE B,700 ; Up to DDT?
JRST GOSPLP ; No, discard another one
POP P,(P) ; Discard page number
SUBTTL Re-Initialization
GOBAK: SETZ F, ; Clear flags
MOVX A,^D1000 ; Sleep a sec
DISMS
MOVE A,PREPLY ; Initialize pointer
MOVEM A,REPLYP ; and store
GJINF ; See what my condition is & save
MOVEM A,GJINF1 ; 0 since not logged in (or User #)
MOVEM B,GJINF2 ; Connected directory #
MOVEM C,GJINF3 ; Job #
MOVEM D,GJINF4 ; -1 or attached terminal #
SKIPN A ; Am I logged in already?
TXZA F,F.LOGI ; No.
TXO F,F.LOGI ; Yes.
JUMPGE D,INIT1 ; Jump if I'm attached.
IFN TCPF,<
JRST HANGUP
> ; End of IFN TCPF
IFE TCPF,<
SETO A, ; Not attached, log out if not logged in
SKIPN GJINF1 ; Logged in directory?
CALL LOGOUT ; None. Kill off job
JFCL
MOVX A,.PRIOU ; Point to the controlling TTY
DOBE ; This will hang until attached
JRST GOBAK ; Go try again.
> ; End of IFE TCPF
SUBTTL Re-Initialization, cont.
INIT1: TXO F,F.TOPN ; TELNET connection is open
TXNE F,F.LOGI ; If logged in,
CALL GETHI ; Map the high seg back in, unwritable.
MOVX A,.FHSLF ; Get capabilities
SETOB B,C ; So can enable Control C,
EPCAP ; And deliver mail
CALL TIMEOK ; Set up initial time before PSI is on
SETOM TFORKX ; No timing fork yet
MOVX A,.PRIIN ; Set the wakeup set for the NVT
MOVX B,.TTIDL ; Ideal terminal - set for no padding
SKIPE TENEX ; Except on TENEX, which has no .TTIDL,
MOVX B,.TTNVT ; Use next best thing, and hope no TELNET
; handling gets in the way
STTYP
RFMOD ; See what it is
TXZ B,TT%WKP+TT%WKA+TT%UOC+TT%LIC ; Forget the printing characters
; Make lower case come in and out ok
TXO B,TT%WKF+TT%WKN ; Turn on all control char wakeups
TXO B,TT%MFF+TT%TAB+TT%LCA ; Allow lower case, TABs, FF's
TXZ B,TT%WID+TT%OSP ; Make line width be infinite & half duplex
SFMOD ; Put the rest back
STPAR
MOVX A,<TL%SAB+<0*TL%ABS>+TL%CRO+TL%COR+<0,,-1>>
MOVEI B,-1 ; Refuse and break links
TLINK
CALL BOMB
SKIPN TENEX ; TOPS-20 lacks ADVIZ
JRST INIT1A
; For TENEX
MOVE A,GJINF4 ; Terminal number
TXO A,.TTDES ; Designator
HRLI A,(1B0) ; Clear advice
JSYS 315 ; ADVIZ
CALL BOMB
JRST INIT1B ; Skip a little TOPS-20 stuff
SUBTTL Re-Initialization, cont.
INIT1A:
IFN REL4,<MOVX A,.PRIOU ; For this terminal
MOVX B,.MOSNT ; We don't want
MOVX C,.MOSMN ; System messages
MTOPR
> ; End Release 4 conditional
INIT1B: MOVX A,.PRIIN ; Set Ctrl chr echoing to all self
MOVX B,<BYTE (2)2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2>
MOVE C,B
SFCOC
SETZM $STRU
SETZM $MODE ; For file connection and so on
SETZM $TYPE ; Initialize all params to default
MOVX A,^D8 ; Default byte size
MOVEM A,$BYTE
SETZM $FORM
SETZM $LTYPE
MOVX A,^D7
MOVEM A,$LBYTE
MOVX A,FILTAB+0
MOVEM A,$FILLB
SETOM $PATH1
SETOM $PATH2
SETOM $SOCK
SETOM $HOST
;INIT2:
SETZM USRFCT ; No bad user names yet
SETZM PASFCT ; No password failures yet.
SETZM USERNM ; User ID has not been declared yet
; ID is TENEX Directory #
; or TOPS-20 User #
SETZM $CWD ; No CWD argument yet
SETOM $ACCES+2 ; Always connecting this job
SETZM PRVKWD ; No previous keyword yet,
SETZM KEYWRD ; And no current one either.
SETOM LGOCNT ; Init logout forcer counter
SETOM LCLJFN ; Clear JFN's used later
SETOM DATCON
SUBTTL Once-only Initialization
SKIPE RESTRT ; Are we restarting? (Came through HANGUP)
JRST INIT6 ; Yes, skip this next
SETZM ANOUNO ; No ANONYMOUS User ID
HRROI B,TXX.AN ; ANONYMOUS
CALL USRCHK ; Check if ANONYMOUS is a user
JFCL
SETZ B, ; None if error
MOVEM B,ANOUNO ; Yes, save the User ID
SETZM SYSDNM ; See what SYSTEM's User Num is
HRROI B,TXX.SY ; SYSTEM
CALL DIRCHK ; See if SYSTEM has a directory
CALL BOMB ; What??
MOVEM B,SYSDNM ; Store it
SUBTTL Once-only Initialization, cont.
INIT6:
IFE TCPF,< ; Do the following only if not TCP version
REPEAT 0,<
MOVE A,T1 ; Get the NVT range
HRLI A,1
GETAB
JRST HANGUP ; Gotta have that too
HLRE B,A ; Minus number of NVT's
HRRZ A,A ; First NVT
MOVMS B ; Compute last NVT
>
MOVX A,.GTNSZ ; Get NCP connection sizes
GTNCP
JRST HANGUP ; ??
HLRE B,C ; Extended +# NVTs
HRRZ A,C ; # First NVT
ADDI B,-1(A) ; # Last NVT
MOVE C,GJINF4 ; TTY I am on
CAML C,A ; Am I on an NVT?
CAMLE C,B
JRST NOTNVT ; No.
; Find out the data about this NVT
;WHTNVT:
REPEAT 0,< ; Long way (need on TENEX?)
MOVX A,<'NETSTS'> ; Ok, find out who has called in.
SYSGT ; Which requires scanning some tables.
MOVEM B,NSTSN ; Save the pointer
MOVX A,<'NETBUF'> ; Another one
SYSGT
MOVEM B,NBUFN
HLLZ X,B ; Loop thru tables
INITL3: MOVSI A,(X) ; Table index
HRR A,NSTSN ; Get connection state
GETAB
JRST HANGUP ; Can't fail
ROT A,4 ; Connection state
ANDI A,17 ; Four bit state
CAIE A,7 ; Is it OPENed?
JRST INITX3 ; No
MOVSI A,(X) ; Yes. See if connected to this TTY
HRR A,NBUFN
GETAB
JRST HANGUP ; Can't fail
CAMN A,GJINF4 ; This TTY?
JRST FNDNVT ; Found the NVT
INITX3: AOBJN X,INITL3 ; Keep looking
JRST HANGUP ; Not found!
SUBTTL Once-only Initialization, cont.
FNDNVT: HRRZM X,NETSKX ; Save the index
MOVX A,<'NETLSK'> ; Get the data about this NVT's connections
SYSGT
MOVE A,B
HRL A,X
GETAB
0
TRZ A,1 ; Save the even numbered socket
MOVEM A,NETLSK ; Local socket number
MOVX A,<'NETFSK'> ; Now get the foreign socket
SYSGT
MOVE A,B ; Same code...
HRL A,X
GETAB
0
TRZ A,1 ; Even one of pair
MOVEM A,FORNS ; Foreign socket
MOVX A,<'NETAWD'> ; Host is in this table
SYSGT
MOVE A,B
HRL A,X
GETAB
0
MOVEM A,NETAWD ; Save it
HLRZ A,A ; Get host
ANDI A,777
MOVEM A,FHSTN
>
MOVX A,.GTNNI ; Get data about this NVT
MOVE B,GJINF4 ; TTY #
XMOVEI C,NCPBLK ; 30 bit address
MOVX D,<-20,,0> ; Want 20 words from 0
GTNCP
JRST HANGUP
MOVE A,.NCLSK+NCPBLK ; Local socket #
TRZ A,1 ; Save the even numbered socket
MOVEM A,NETLSK ; Local socket number
MOVE A,.NCFSK+NCPBLK ; Foreign socket #
TRZ A,1 ; Even one of pair
MOVEM A,FORNS ; Foreign socket
MOVE A,.NCFHS+NCPBLK ; Foreign host
MOVEM A,FHSTN
JRST PSIINI
NOTNVT: MOVE A,LHOSTN ; Assume local host if not an NVT
MOVEM A,FHSTN
SETOM NETLSK ; Hope I don't need socket numbers
SETOM FORNS
JRST PSIINI ; Go set up PSI system
> ; End of IFE TCPF conditional
SUBTTL Initialize PSI system & create & start timing fork
PSIINI: MOVX A,<.TICCC,,CTCCHN> ; Assign ^C interrupt
SKIPE DBUGSW ; or ^E if debugging
MOVX A,<.TICCE,,CTCCHN> ; To this channel
ATI
MOVX A,<.TICRF,,DETCHN> ; NVT detaching (^D30, Carrier Off)
ATI ; To this channel
MOVX A,<.TICCT,,CTTCHN> ; And Control-T
ATI
MOVX A,.FHSLF ; Set up PSI system
MOVX B,<LEVTAB,,CHNTAB>
SIR
MOVE B,ONCHNS ; Turn on these channels
AIC
MOVX A,.FHSLF ; Now turn the system on
EIR
;MAKTFK:
MOVX A,.FHINF ; Kill all inferiors
KFORK
SETOM TFORKX ; No timing fork
MOVX A,CR%MAP!CR%CAP ; Create a fork for timing
CFORK ; Create it
JRST FULL ; If system can't make it
REPEAT 0,<ERJMP FULL ;TOPS-20 use ERJUMP to avoid ITRAPs>
HRRZM A,TFORKX ; Save the fork index
RPCAP ; Make sure it can poke me
TXO B,SC%SUP
TXO C,SC%SUP
EPCAP
MOVEI B,TFRKSA ; Where it starts
SFORK ; Start it. It will give me time checks
;FALL THRU
SUBTTL IPCF Logging Facility
;FALLS IN FROM ABOVE
IFN IPCLOG,<
GETPID: MOVX A,IP%CPD ; Get a PID for self
MOVEM A,PIDARG+.IPCFL
GPIDL: SETZM PIDARG+.ICPFS ; No PID of sender yet
GPID2: SETZM PIDARG+.ICPFR ; Receiver is 0, ie <SYSTEM>INFO
MOVX A,<ENDMSG-INFMSG,,INFMSG>
MOVEM A,PIDARG+.ICPFP ; The data of the message to INFO
MOVX A,4 ; Count
MOVEI B,PIDARG ; Descriptor
MSEND ; Get PID of FTSCTL
JRST [ MOVX A,^D1000
DISMS
JRST GPIDL]
MOVX B,IP%CPD ; Don't create another
ANDCAM B,PIDARG+.ICPFL
MOVE A,PIDARG+.ICPFS ; Stash my new PID
MOVEM A,MYPID
GETAGN: SETZM PIDARG+ICPFL ; No flags
SETZM PIDARG+.ICPFS ; No particular sender
MOVE A,MYPID ; I am receiver
MOVEM A,PIDARG+.ICPFR
MOVX A,<10,,IPCDAT> ; Receive this much data
MOVEM A,PIDARG+.ICPFP
MOVX A,4 ; Length of descriptor
MOVEI B,PIDARG ; Addr of descriptor
MRECV
JFCL
MOVE A,PIDARG+.ICPFL ; Get flags
ANDI A,7B32
CAIE A,1B32 ; Sent by monitor? <SYSTEM>ICPF .ICPCC
CAIN A,2B32 ; Sent by INFO? <SYSTEM>INFO .ICPCF
SKIPA ; Yes.
JRST GETAGN ; No, not interested.
MOVE A,PIDARG+.ICPFL
TRNE A,7 ;IP%CFM ; Was the packet undeliverable?
JRST GPID2 ; Yes.
TRNE A,77B29 ;IP%CFE ; Trouble?
JRST GETAGN ; Yes.
MOVE A,IPCDAT+.ICPI1 ; Get FTSCTL's PID
MOVEM A,CTLPID ; Save it.
>
HRROI A,[ASCIZS (300,220,< >)]
PSOUT
MOVX A,.PRIOU ; Output greeting
HRROI B,VERSTR
SETZ C,
SOUT
HRROI A,[ASCIZ / at /]
PSOUT
MOVX A,.PRIOU
SETO B,0 ; Current time stamp
MOVX C,<OT%DAY+<0*OT%FDY>+OT%NSC+OT%TMZ+OT%SCL>
ODTIM ; Format of time
HRROI A,CRLFM
PSOUT
JRST GETCOM ; Go read first command
SUBTTL Error Replys - NOLINE, SYNERR, ARGSYN, FULL
; JRST NOLINE NVT/TVT Detached, thus no reply possible
NOLINE: GJINF ; See if I got detached
JUMPL D,HANGUP ; If so, hang up and logout
JSP B,RPCRLP ; Must be super long line
ASCIZS (500,500,< Last line was not comprehensible.>)
; JRST SYNERR Bad Initial Character in Command Line
SYNERR: JSP B,RPCRLP ; Syntactical error in command
ASCIZS (501,500,< Syntax error at start of last command line.>)
; JRST SYNERR Bad Character after Verb
SYNER2: JSP B,RPCRLP
ASCIZS (501,500,< Syntax error - Character after command verb is bad.>)
; JRST ARGSYN Bad Argument Syntax
ARGSYN: CALL BEGREP ; Here to complain of argument syntax
ASCIZS (502,501,< Syntax error in argument of >)
CALL ADDKEY ; Append 6-bit keywrd
JSP B,RPCRLP ; Close off msg
ASCIZ / command./
SUBTTL Error Replys - BOMB, NVTNLI, FULL
; CALL BOMB Fatal Error, return gives PC
;NEVER RETURNS May be called BEFORE initialized
BOMB: MOVEM 16,PI3AC+16 ; Save ACs
MOVX 16,<0,,PI3AC>
BLT 16,PI3AC+15
POP P,C ; Return
MOVEI C,-1(C) ; Address w/o flags
MOVEM P,PI3AC+17
HRROI B,[ASCIZS (435,421,< Fatal system error at >)]
MOVEI D,PI3AC
CALL DMPREG
HRROI A,[ASCIZ / Goodbye./]
PSOUT
JRST HANGUP
; JRST NVTNLI Don't allow Network logins
NVTNLI: JSP B,ERRRPL ; Don't allow the LOGIN - due to TMON
ASCIZS (453,421,< Network logins not allowed at this time. Please try later.>)
; JRST FULL System is Full
FULL: JSP B,ERRRPL ; Cause hangup after sending this
ASCIZS (401,421,< Service full, please try later. Goodbye.>)
SUBTTL Reply Subroutines - BEG/ADDREP, ADDARG, ADDKEY, SYNER2
; CALL ADDREP or BEGREP Add to or begin a new reply message
; ASCIZ /.../
; <RETURN HERE>
BEGREP: SKIPA A,PREPLY ; Begin a new reply
ADDREP: MOVE A,REPLYP ; Add text after call to reply buffer
HRRO B,0(P) ; String ptr to text
SETZ C, ; ASCIZ form
SOUT
MOVEM A,REPLYP ; Update reply pointer
HRRM B,0(P) ; Pointer to word with NULL
AOS 0(P) ; One more is where to return to
RET ; Return there.
; CALL ADDARG (ARGWRD) CALL ADDKEY (KEYWRD)
;LEAVES A/ Pointing to end of text (after NULL)
;UPDATES REPLYP (Before NULL)
;PRESERVES B
;KILLS C
ADDARG: HRROI C,ARGWRD ; Append ARGWRD to reply REPLYP
SKIPA
ADDKEY: HRROI C,KEYWRD ; Append KEYWRD to reply REPLYP
PUSH P,B ; Save
MOVE A,REPLYP ; Add sixbit word in C to reply
MOVE B,C
SETZ C,
SOUT
MOVEM A,REPLYP ; End of reply so far
IDPB C,A ; Append NULL.
POP P,B ; Restore
RET
SUBTTL Error Message Completion
; JRST NOTIMP Unimplemented Command
NOTIMP: CALL BEGREP
ASCIZS (506,502,< The >)
CALL ADDKEY ; Append verb to message
JSP B,RPCRLP
ASCIZ / command is not yet implemented./
PCRLF: HRROI A,CRLFM
PSOUT
RET
CRLFM: BYTE (7)C.CR,C.LF,C.NUL
PREPLY: POINT 7,REPLYM
; MOVX B,[ASCIZ /.../]
; JRST ERRRPL/RPCRLP
; OR
; JSP B,ERRRPL/RPCRLP
; ASCIZ /.../
NURPLY: MOVE A,PREPLY ; Start over
JRST RPCRLP+1 ; ******
ERRRPL: TXO F,F.CMDK ; Flag this was a fatal error
RPCRLP: MOVE A,REPLYP ; Append msg in B to reply
SETZ C, ; It's ASCIZ
HRLI B,(POINT 7,0) ; String pointer (allows JSP B,RPCRLP)
SOUT
HRROI B,CRLFM ; Append CRLF
SOUT
HRROI A,REPLYM ; Now send it down TELNET line
PSOUT
; JRST GETCOM ; And get another command
;FALL INTO GETCOM
SUBTTL Get Next Command
; Here to get a command line. First see if system still up
GETCOM: MOVE A,PREPLY ; Initialize pointer to reply
MOVEM A,REPLYP ; For other routines to append to
MOVE P,GPDP ; Restore stack level, just in case.
CALL TIMEOK ; Mark that timeout hasn't happened
TXNE F,F.CMDK ; Asked to kill job before cmd reading?
JRST HANGUP ; Yes, do so.
MOVX A,<'ENTFLG'> ; See if system still open
SYSGT
JUMPE B,GETCM1 ; If no such table,
JUMPN A,GETCM1 ; Or ENTFLG is non-zero, go to it
SHUTDN: JSP B,ERRRPL ; Hang up on him
ASCIZS (436,421,< Service shutting down. Goodbye.>)
;CWL spontaneous response violates protocol??
GETCM1:
CALL LINEIN ; Collect a command line from TTY
JRST NOLINE ; EOF or super-long line
MOVX A,<'ENTFLG'> ; Flag went off during typein wait, maybe
SYSGT
JUMPE B,GETCM2 ; Continue if no flag avail
JUMPN A,GETCM2 ; Or flag still ok
JRST SHUTDN ; No good. Hang up.
GETCM2:
SKIPN CMDIB ; Blank line?
JRST [JSP B,RPCRLP ; Blank line
ASCIZ /200 Blank line ignored./]
MOVX BP,<POINT 7,CMDIB> ; Initialize saved byte pointer
GETCM3: MOVEM BP,SBP
ILDB C,BP ; Skip leading spaces and tabs
CAIE C,C.SPACE ; SST routine fails at start of line
CAIN C,C.TAB ; So do it this way
JRST GETCM3 ; That was a space. Skip it.
HRROI B,[ASCIZ /200 Comment OK./]
CAIN C,C.COMNT ; Let's allow comments
JRST RPCRLP ; Line started with semicolon
; Fall thru
SUBTTL Get Next Command, cont.
; Falls thru from above
CALL GETWRD ; Collect a word
JRST SYNERR ; Didn't start with a good character
LDB C,SBP ; Get the break character
CALL SST ; Step over spaces or tabs
JUMPE A,SYNERR ; Bad if first char on line not alphanum.
CAIE C,C.SPACE ; Spacing character after verb?
CAIN C,C.TAB
SKIPA ; Yes
JUMPN C,SYNER2 ; Jump unless end of line
SKIPE C,KEYWRD ; Any previous keyword?
MOVEM C,PRVKWD ; Yes, save it.
MOVEM A,KEYWRD ; Save the sixbit keyword
MOVX C,<-NCOMS,,COMAND+1> ; See if we can find the keyword
HLRZ D,(C)
CAMN A,(D) ; This one?
JRST KEYFND ; Yes
AOBJN C,.-3 ; No, look thru list
NOTKEY: CALL BEGREP
ASCIZ /500 I never heard of the /
CALL ADDKEY ; Append keyword
SETZM KEYWRD ; So don't move garbage into PRVKWD
JSP B,RPCRLP ; Finish the line
ASCIZ / command. Try HELP./
KEYFND: HRRZ B,(C) ; Dispatch to routine
TRNE B,400000 ; Need to be logged in? (highseg routine)
TXNE F,F.LOGI ; Yes. Am I?
SKIPA ; Logged in, or don't need to be
JRST [JSP B,RPCRLP ; No good. Complain.
ASCIZS (451,530,< Please log in first, with USER, PASS and ACCT.>)]
CALL 0(B) ; Call it (must set B to message)
JRST RPCRLP
JRST RPCRLP
SUBTTL Command Definitions
C.LGN==1B18 ; Need to log in to use this command NB: LH sign bit
DEFINE COMS < ; Keywords
CC (USER,0)
CC (PASS,0)
CC (ACCT,0)
CC (HELP,0)
CC (MAIL,0)
CC (MLFL,0)
CC (ABOR,0)
CC (NOOP,0)
IFE TCPP,<
CC (BYE,0)
CC (BYTE,0)
CC (SOCK,C.LGN)
CC (XSEN,0)
CC (XSEM,0)
CC (XCWD,C.LGN)
>
IFN TCPP,<
CC (QUIT,0)
CC (SITE,0)
CC (REIN,0)
CC (MSND,0)
CC (MSOM,0)
CC (MSAM,0)
CC (MRCP,0)
CC (PORT,C.LGN)
CC (PASV,C.LGN)
CC (SMNT,C.LGN)
>
CC (TYPE,0)
CC (STRU,0)
CC (MODE,0)
CC (RETR,C.LGN)
CC (STOR,C.LGN)
CC (APPE,C.LGN)
CC (RNFR,C.LGN)
CC (RNTO,C.LGN)
CC (DELE,C.LGN)
CC (LIST,C.LGN)
CC (NLST,C.LGN)
CC (ALLO,C.LGN)
CC (REST,C.LGN)
IFE TCPP,<CC (STAT,C.LGN)>
IFN TCPP,<CC (STAT,0)> ; Allow STAT<RETURN>
CC (CWD,C.LGN)
; FOLLOWING ARE NOT PART OF FORMAL SYNTAX BUT ARE ACCEPTED
CC (NOP,0)
CC (DEBUG,C.LGN)
CC (CRASH,0)
CC (BOMB,0)
>
SUBTTL Command Symbol & Dispatch Table
DEFINE CC(A,B)< XWD [ASCIZ \A\],Z'A
IFE B,<.IF Z'A,RELOCATABLE,<PRINTX ? Move Z'A to low segment>>
IFN B,<.IF Z'A,ABSOLUTE,<PRINTX ? Move Z'A to high segment>>
> ; End of DEFINE CC
COMAND: XWD NCOMS,NCOMS ; Maybe COMND...
COMS
NCOMS==.-COMAND-1 ; Length of table
SUBTTL Subroutines - LINEIN - Get Next Input Line
; The line collector. Performs character and word and line editting.
; Reads a line into CMDIN buffer, terminated by NULL, CRLF stripped off.
; CALL LINEIN
;Ret+1: Blank
;Ret+2: Have line
LINEIN: PUSH P,P1
PUSH P,P2
PUSH P,P3
; Reenter here on line delete
LINICU: TXZ F,F.LTL!F.QUOC ; Clear this routine's flags
MOVX P1,<5*LCMDIB>-3 ; Maximum line length to read
MOVE P2,LINEIP ; Initial byte pointer to buffer
SETZM CMDIB ; Clear the buffer, to be neat
MOVX A,<CMDIB,,CMDIB+1>
BLT A,CMDIB+LCMDIB-1
LININL: CALL TELBIN ; BIN from NVT
JRST LININX ; Non-skip if TTY gets EOF
TXZE F,F.QUOC ; C.QUOTE (^V) seen?
JRST LININ2 ; Yes. Store character EXACTLY
CAIN B,C.LF ; Is it a linefeed?
JRST LINEOL ; Yes. Quit.
TXNE F,F.INML ; In MAIL (so no editing)?
JRST LININ2 ; Yes, store code
CAIE B,C.NUL ; NUL or CR?
CAIN B,C.CR
JRST LININL ; Yes, ignore completely
CAIE B,C.BS ; Editting. Backspace?
CAMN B,CDELCH ; Editting character delete?
JRST LINICH ; Yes
CAMN B,CDELWD ; Editting word delete?
JRST LINICW ; Yes
CAMN B,CDELLN ; Editting line delete?
JRST LINICU ; Yes.
CAIN B,C.QUOTE ; Super-Quote?
TXO F,F.QUOC ; Flag Control-V seen, then store it
LININ2: IDPB B,P2 ; Store this character
SOJG P1,LININL ; Accumulate line
TXO F,F.LTL ; Line too long
LININX: POP P,P3 ; Non-skip return
POP P,P2
POP P,P1
RET
LINEOL: SETZ B, ; Normal end of line. Terminate with EOL
IDPB B,P2 ; Terminate the string
AOS -3(P) ; Skip return
JRST LININX
LINEIP: 010700,,CMDIB-1 ; Initial pointer to buffer
SUBTTL Subroutines - LINEIN - Editing Routines LINICH, LINICW
LINICH: CAMN P2,LINEIP ; Already at start of line?
JRST LININL ; Yes, ignore this ^A
MOVX B,C.NUL ; Clobber the current character
DPB B,P2
ADD P2,[070000,,0] ; Back up the pointer
SKIPGE P2 ; If off end of word,
SUB P2,[430000,,1] ; Previous word.
AOJA P1,LININL ; Un-count the deleted character
LINICW: LDB B,P2 ; Get current character
CALL ALNUMQ ; Skip if alphanumeric
JRST LINCW1 ; No, a break char.
LINCW2: MOVX B,C.NUL ; This is alphanumeric. Clobber it.
DPB B,P2
ADDI P1,1 ; Un-count it.
ADD P2,[070000,,0] ; Back up pointer
SKIPGE P2
SUB P2,[430000,,1]
CAMN P2,LINEIP ; Back to start of buffer?
JRST LININL ; Yes. Done deleting
LDB B,P2 ; No, see if this is still in the word.
CALL ALNUMQ ; Skip if alphanumeric
JRST LININL ; Break. Done.
JRST LINCW2 ; Still in word. Go delete it.
LINCW1: MOVX B,C.NUL ; Current char is a break. Get back to
DPB B,P2 ; Word before break(s), then delete it.
ADDI P1,1 ; Delete break character
ADD P2,[070000,,0]
SKIPGE P2
SUB P2,[430000,,1]
CAMN P2,LINEIP ; Back to start of buffer?
JRST LININL ; Yes. Quit.
LDB B,P2 ; See if multi-breaks after last word
CALL ALNUMQ ; Alphanumeric?
JRST LINCW1 ; No, more breaks. Delete this one too
JRST LINCW2 ; Into the word. Delete the word.
SUBTTL Subroutines - ALNUMQ
; B/ CHARACTER
; CALL ALNUMQ ; Alphanumeric?
; RET+1 ; Break
; RET+2 ; Alphanumeric or -
;PRESERVES ALL
ALNUMQ: CAIL B,"a" ; Lower case?
CAILE B,"z"
SKIPA ; No.
JRST ALNUMS ; Yes. Skip return.
CAIL B,"A" ; Upper case?
CAILE B,"Z"
SKIPA ; No
JRST ALNUMS ; Yes. Skip return
CAIL B,"0" ; Digit?
CAILE B,"9"
SKIPA ; No
JRST ALNUMS ; Yes. Skip return.
CAIN B,"-" ; Hyphen?
ALNUMS: AOS 0(P) ; Yes. Skip return
RET ; Something else. Non-skip.
SUBTTL Subroutine - GETWRD
; SBP/ Points to input
; CALL GETWRD Get word
; RET+1 ; No word before break
; RET+2 ; ASCIZ word in a
;Saves all but A, BP SBP updated to point to break
GETWRD: PUSH P,B ; Answer to A, preserve B and C
PUSH P,C
MOVE BP,SBP ; Current byte pointer
SETZ A, ; Clear the answer
MOVX C,<POINT 7,A> ; Start pointer to answer
GETWRL: ILDB B,BP ; Get a character
CALL ALNUMQ ; A-Z, 0-9, or Hyphen?
JRST GETWR1 ; No, break character
CAIL B,"a" ; If lower case
CAILE B,"z"
SKIPA
TRZ B,40 ; Make upper
TLNE C,760000 ; Room for another character?
IDPB B,C ; Yes, store in keyword
JRST GETWRL ; On to the break
GETWR1: MOVEM BP,SBP ; Update stored byte pointer (points to break)
POP P,C ; Restore AC's
POP P,B
SKIPE A ; Skip return unless no word
AOS 0(P) ; Skip return
RET
SUBTTL Subroutines - SIN6BT
REPEAT 0,<
; SBP/ POINTS TO INPUT
; CALL SIN6BT Get sixbit word
; RET+1 ; No word before break
; RET+2 ; Sixbit word in a
;Saves all but A, BP SBP updated to point to break
SIN6BT: PUSH P,B ; Answer to A, preserve B and C
PUSH P,C
MOVE BP,SBP ; Current byte pointer
SETZ A, ; Clear the answer
MOVX C,<POINT 6,A> ; Start pointer to answer
SIN6BL: ILDB B,BP ; Get a character
CALL ALNUMQ ; A-Z, 0-9, or Hyphen?
JRST SIN6B1 ; No, break character
CAIL B,100 ; Yes. Letter?
TRZ B,40 ; Yes, make sure upper case.
SUBI B,40 ; Yes. Convert to SIXBIT
TLNE C,770000 ; Room for another character?
IDPB B,C ; Yes, store in keyword
JRST SIN6BL ; On to the break
SIN6B1: MOVEM BP,SBP ; Update stored byte pointer (points to break)
POP P,C ; Restore AC's
POP P,B
SKIPE A ; Skip return unless no word
AOS 0(P) ; Skip return
RET
> ; End of REPEAT 0
SUBTTL Subroutines - SST
; SBP point to next input character
; CALL SST Skip over tabs and spaces
;PRESERVES ALL
SST: PUSH P,A ; Skip spaces and/or tabs at current SBP
TXZ F,F.QUOC ; Flag first character
SSTL: LDB A,SBP ; Get the current character
CAIE A,C.SPACE ; Is it a space or tab?
CAIN A,C.TAB
TXOA F,F.QUOC ; Yes. Flag moving up at least one char.
JRST SST01 ; No. Quit here
IBP SBP ; It's a space/tab. Move past it
JRST SSTL ; And go check the next one.
SST01: TXZN F,F.QUOC ; Unless didn't move forward at all.
JRST SST3 ; In which case leave it here.
MOVX A,<070000,,0> ; Back up so ILDB gets the non-space
ADD A,SBP
SKIPGE A
SUB A,[430000,,1]
MOVEM A,SBP
SST3: JRST APOPJ
SUBTTL Subroutines - TELBIN
; CALL TELBIN Get Input Character
; RET+1 ; EOF
; RET+2 ; Character in B
TELBIN: MOVX A,.PRIIN ; BIN from primary input
BIN ; Character to AC B
JUMPE B,[MOVX A,.PRIIN
GTSTS ; See if EOF or NULL
TXNN B,GS%EOF
JRST TELBIN ; Discard the NULL.
RET] ; EOF. Give non-skip return. But
; Detach will probably cause PSI anyhow
; Cannot do this if looking for escapes, etc
; TRZ B,200 ; Clear bit 200
CAIN B,C.CR ; CR's?
JRST TELBIN ; Wait for LF
CAIN B,TNXEOL ; TENEX EOL? (Not occur in TCPP)
MOVX B,C.LF ; Become linefeeds
CPOPJ1: AOS 0(P) ; Ok. Skip return.
RET
SUBTTL Subroutines - FORCLO, HANGUP, LOGOUT
; JRST FORCLO On timeout interrupt/abort
;CWL does this "extra" message violate protocol
FORCLO: HRROI A,[ASCIZS (434,421,< Autologout; Time exceeded without login.
>)]
PSOUT
; JRST HANGUP
; JRST HANGUP Close TELNET connection & logout
; may be called BEFORE initialized
HALTGO: ; (Compatability)
HANGUP: CLOSD DATCON ; Make sure data connection is closed
GJINF ; Get latest TTY number
JUMPL D,NOCLSD ; If already detached
MOVX A,.PRIOU ; Wait for end of output
DOBE
SKIPN DBUGSW ; Don't close TTY if debuging
CALL CLSTTY ; Close the terminal
NOCLSD:
; ;;; CALL DELTMP ; Flush and delete temp file if exists
IFE TCPP,<TXNE F,F.LOGI> ; Not if not logged in
CALL LOGOUT ; LOGOUT or HALTF if debugging
MOVE P,GPDP ; Restore stack level, just in case.
MOVX A,.FHSLF ; For this fork
CIS ; And clear pending ones
CALL TIMEOK ; Reset clock
SETOM RESTRT ; Mark ourselves as RESTARTING
SETO A, ; Make us as clean as possible
CLOSF ; by closing
SETO A,
RLJFN ; and releasing
JFCL ; all JFNS
JRST GOBAK ; And return to start
; CALL LOGOUT LOGOUT (no return) unless debuging (halt & return)
LOGOUT: SETO A, ; Logout me
SKIPN DBUGSW ; But not if debuging
LGOUT
ERJMP [HALTF] ;#2 die on failure
SKIPE DBUGSW
HALTF ; Halt if debuging
RET
SUBTTL Subroutines - CLSTTY
; Try to detach TTY and close the connection so system logout message
; isn't sent to server -- its not part of the protocol.
; CALL CLSTTY Close/Detach TTY
CLSTTY: DTACH ; Get off the TTY
SKIPN TENEX ; Different on TOPS20
JRST CLSTTX
; TENEX
MOVEI A,.TTDES(D) ; TENEX - line # to a TTY dev designator
ASND ; Assign it
RET
MOVEI A,.TTDES(D) ; Again
RELD ; Cause the NVT to close
JFCL
RET
; TOPS20
CLSTTX: HRROI A,GTJSTR ; TOPS-20
HRROI B,[ASCIZ /TTY/]
SETZ C,
SOUT ; Build TTY name
MOVEI B,(D)
MOVX C,OCTRAD ; Octal TTY #
NOUT
JFCL
HRROI B,[ASCIZ /:/]
SETZ C,
SOUT
MOVX A,GJ%SHT ; Now get JFN for it
HRROI B,GTJSTR ; Point to string
GTJFN
RET
PUSH P,A ; Save JFN for later
MOVX A,.FHSLF ; Adjust caps
RPCAP
PUSH P,C ; Save these to restore
PUSH P,B
TRZ C,-1 ; Ask for everything
EPCAP
MOVE A,-2(P) ; Now open TTY
MOVX B,<FLD(7,OF%BSZ)+OF%WR>
OPENF
JFCL
MOVX A,.FHSLF
POP P,B ; Capabilities to be restored
POP P,C
EPCAP
POP P,A ; JFN to be closed & released
CLOSF ; This to close net conn.
JFCL ; Shouldnt fail
RET
SUBTTL Subroutines - FRMHST
; CALL FRMHST APPEND " from host x" to string in A/
; KILLS B, C
REPEAT 0,<
FRMHST: PUSH P,A
HRROI B,[ASCIZ / from host /]
SETZ C, ; Identify the host
SOUT
MOVE B,A
MOVE C,FHSTN ; Foreign site number
MOVX A,.GTHNS
GTHST
JRST [MOVE A,(P) ; Get a back
MOVE B,FHSTN
MOVX C,OCTRAD ; Octal number
NOUT
JFCL
JRST .+1]
POP P,A ; Clean a off stack
RET
>
REPEAT 0,<
IFN TCPF,< MOVE B,FHSTN
LSHC B,-6
LSH B,-12
LSHC B,6
ANDI B,377>
IFE TCPF,< HRRZ B,FHSTN> ; Foreign site number
MOVX C,OCTRAD ; In octal if no name
CVHST ; Name, if any
NOUT ; No, number.
JFCL
> ; End of REPEAT 0
SUBTTL Subroutines - DECIN (OCTIN)
; Numeric input routine. Decimal unless preceded by "O" or "X".
; BP/ Points to separator before input
; CALL DECIN
; Ret+1 Bad input
; Ret+2 A/ number
;Kills C; Saves B,D; BP/ points to break
DECIN: ILDB C,BP ; Skip separator first
SETZ A, ; Collect number here
PUSH P,BP ; Save original byte POINTER
DECINL: CAIL C,"0" ; Decimal digit?
CAILE C,"9"
JRST DECINX ; No.
IMULI A,DECRAD ; Yes, accumulate number
ADDI A,-"0"(C)
ILDB C,BP ; On to next character
JRST DECINL ; See if break or digit
DECINX: CAME BP,0(P) ; Has any digit been seen?
JRST RADIXY ; Yes, skip return
CAIE C,"O" ; Octal prefix?
CAIN C,"o" ; Or lower case "O"
JRST OCTIN ; Yes. Go read it
CAIE C,"X" ; Hex input?
CAIN C,"x"
JRST HEXIN ; Yes. Go collect hex number
JRST RADIXZ ; No good. Discard pointer on stack
; and give non-skip return
OCTIN: ILDB C,0(P) ; Update start of number, skip the "O"
MOVE BP,0(P)
OCTINL: CAIL C,"0" ; Octal digit?
CAILE C,"7"
JRST RADIXX ; No. Quit.
LSH A,3 ; Yes. Accumulate number
ADDI A,-"0"(C)
ILDB C,BP ; Get next character
JRST OCTINL ; See if end of number
SUBTTL Subroutines - DECIN (HEXIN)
HEXIN: ILDB C,0(P) ; Skip the "X". Update start of number
MOVE BP,0(P)
HEXINL: CAIL C,"a" ; Lower case letter?
CAILE C,"z"
SKIPA ; No
TRZ C,"a"-"A" ; Yes. Make upper case
CAIL C,"A" ; Now, is it a hex digit-letter?
CAILE C,"F"
SKIPA ; No
SUBI C,"A"-"9"-1 ; Yes. Squunch down to digits
CAIL C,"0" ; Digit (including A-F)?
CAILE C,"0"+17
JRST RADIXX ; No
LSH A,4 ; Yes. Accumulate number
ADDI A,-"0"(C)
ILDB C,BP ; On to next character
JRST HEXINL ; Continue till break character
RADIXX: CAME BP,0(P) ; Any digits seen at all?
RADIXY: AOS -1(P) ; Yes. Skip return
RADIXZ: POP P,(P) ; Discard starting byte pointer
RET
SUBTTL Subroutines - DIRCHK
; Dirchk checks a directory name
; B/ A pointer to the name (W/ or W/o PS:<...>)
; CALL DIRCHK
; Ret+1 If fails
; Ret+2 Recognized, directory number in B
DIRCHK: PUSH P,A ; Save some AC's
PUSH P,B
PUSH P,C
SKIPN TENEX
JRST DIRCK1
SETZ A, ; TENEX
STDIR
JRST DIRCK6
JRST DIRCK6
HRRZ C,A ; Hw directory number
JRST DIRCK4
DIRCK1: MOVX A,RC%EMO ; TOPS-20 exact match only
RCDIR ; Try to recognize
ERJMP DIRCK2 ; If fail
TXNN A,RC%NOM!RC%EMO ; Check if good
JRST DIRCK4 ; Yes
DIRCK2: HRROI A,RCDSTR ; Where to build string
HRROI B,[ASCIZ /PS:</] ; Start of string
SETZ C,
SOUT
MOVE B,-1(P) ; Pointer
SOUT
HRROI B,[ASCIZ />/]
SOUT ; And finish with new string
MOVX A,RC%EMO
HRROI B,RCDSTR
RCDIR ; And try again with new string
ERJMP DIRCK6 ; Still bad
TXNE A,RC%NOM!RC%AMB ; Exists?
JRST DIRCK6 ; No
DIRCK4: MOVE B,C ; Yes, number into B
AOS -3(P) ; Skip return
DIRCK6: POP P,C ; Restore C
POP P,(P) ; Discard pointer
POP P,A
RET ; And return
SUBTTL Subroutines - USRCHK - Validate User Name String
; USRCHK Checks a user name string
; B/ a pointer to the name
; CALL USRCHK
; RET+1 If fails
; RET+2 FILES-ONLY
; RET+3 Recognized, User ID # is in B
;User ID number is TOPS-20 User Number (36-bit)
; TENEX Directory Number (18 bit)
USRCHK: PUSH P,A ; Save some AC's
PUSH P,B
PUSH P,C
SKIPN TENEX
JRST USRCK1 ; TOPS-20
; TENEX
SETZ A, ; Positive number for exact match
STDIR ; Check name pointed to by B
JRST USRCK6 ; No match
JRST USRCK6 ; Ambiguous
HRRZ B,A ; TENEX directory number
TXNE A,1B0 ; FILES-ONLY?
JRST USRCK4 ; Yes, lose (but return number)
JRST USRCK2 ; No, ok
USRCK1: MOVX A,RC%EMO ; Exact match only
RCUSR ; Try to recognize
ERJMP USRCK6 ; Fail
MOVE B,C ; Possible user # to B
TXNN A,RC%NOM!RC%AMB ; Exists?
JRST USRCK2 ; Yes
; No, or FILES-ONLY
EXCH B,-1(P) ; Restore pointer & save user #
CALL DIRCHK ; Special test for FILES-ONLY
JRST USRCK6 ; Not even FILES-ONLY
MOVE B,-1(P) ; Get back user #
JRST USRCK4 ; Ok means FILES-ONLY
USRCK2: AOS -3(P) ; Ok ret+3
USRCK4: AOS -3(P) ; FILES-ONLY ret+2
USRCK6: POP P,C ; Restore C
POP P,(P) ; Drop B
POP P,A
RET ; And return
SUBTTL Subroutines - SNDCTL
IFN IPCLOG,< ; Don't use this feature yet
SNDCTL: PUSH P,A
PUSH P,B
PUSH P,C
SETZM PIDARG+.ICPFL ; Send data to FTSCTL
MOVX C,3 ; Try three times
SNDCT1: MOVE A,MYPID
MOVEM A,PIDARG+.IPCFS
MOVE A,CTLPID
MOVEM A,PIDARG+.IPCFR
MOVX A,<20,,IPCDAT> ; Should put correct length on
MOVEM A,PIDARG+.IPCFP
MOVX A,4 ; Length of descriptor
MOVEI B,PIDARG ; Addr of descriptor
MSEND
JRST [MOVX A,^D1000
DISMS
SOJGE C,SNDCT1
JRST .+1]
POP P,C
POP P,B
POP P,A
RET
>
SUBTTL Subroutines - TIMEOK
; CALL TIMEOK ; Still ok, set timer fork for WATTIM from now
TIMEOK: PUSH P,A ; Update time till hangup forced
PUSH P,B ; Save AC's
TIME ; Get system uptime
IMULI B,WATTIM ; This many seconds to wait
ADD A,B ; Wait until time equals this
MOVEM A,KTIMET ; Then force a logout.
BAPOPJ: POP P,B
APOPJ: POP P,A
RET
SUBTTL Forks - TFORKX/TFRKSA - Timing Fork
; Timing fork to wake us up each minute
TFRKSA: MOVX A,^D60000
DISMS
MOVEI A,.FHSUP ; My superior
MOVX B,<1B<TIMCHN>> ; Channel to poke him on
IIC ; Do so
JRST TFRKSA ; And return
SUBTTL PSI Handlers - Level 1 (Fatal) - INSINT, MEMINT, PDLINT, FULINT
INSINT: MOVEM 17,PI1AC+17 ; Stash the AC's
MOVEI 17,PI1AC
BLT 17,PI1AC+16
MOVE P,L1PDP ; Set up a stack
JSP B,L1INTS
ASCIZS (,,<Illegal Instruction trap>)
MEMINT: MOVEM 17,PI1AC+17 ; Stash the AC's
MOVEI 17,PI1AC
BLT 17,PI1AC+16
MOVE P,L1PDP ; Set up a stack
JSP B,L1INTS
ASCIZS (,,<Illegal memory reference trap>)
PDLINT: MOVEM 17,PI1AC+17 ; Stash the AC's
MOVEI 17,PI1AC
BLT 17,PI1AC+16
MOVE P,L1PDP ; Set up a stack
JSP B,L1INTS
ASCIZS (,,<Pushdown stack overflow trap>)
FULINT: MOVEM 17,PI1AC+17 ; Stash the AC's
MOVEI 17,PI1AC
BLT 17,PI1AC+16
MOVE P,L1PDP ; Set up a stack
JSP B,L1INTS
ASCIZS (,,<Disk or Drum overflow>)
; Output registers and error message, if possible
L1INTS: MOVE C,RETPC1 ; PC
MOVEI D,PI1AC ; Pointer to registers
CALL DMPREG ; Tell the bad news
HRROI A,[ASCIZ / Goodbye.
/]
PSOUT
ERJMP .+1
JRST HANGUP
REPEAT 0,<
L1DBRK: MOVX 17,<PI1AC,,0> ; Restore lev 1 AC's
BLT 17,17
DEBRK ; and return from lev 1 PSI
>
SUBTTL PSI Handlers - Level 2 (Non-Fatal) - TIMINT, DETINT
; Timeout
TIMINT: MOVEM 17,PI2AC+17 ; Stash the AC's
MOVEI 17,PI2AC
BLT 17,PI2AC+16
MOVE P,L2PDP ; And set up a stack
TIME
CAMG A,KTIMET ; Time to quit?
JRST L2DBRK ; No.
TXNN F,F.ANON ; Yes. ANONYMOUS user?
TXNN F,F.LOGI!F.NALO ; Or not logged in at all?
SKIPA ; Yes. Autologout him.
JRST L2DBRK ; Real logged in user. Let it sit idle.
AOS A,LGOCNT ; Count the force-level counter
CAIL A,2 ; Panic?
JRST HANGUP ; Yes. Get out
MOVX B,<PC%USR+FORCLO> ; Assume forced logout
CAIL A,1 ; Still not seen at process level. First?
MOVEM B,RETPC2 ; Break out of present work & force off
L2DBRK: MOVX 17,<PI2AC,,0> ; Restore AC's
BLT 17,17
DEBRK ; And return from lev 2 PSI
ERJMP DBKFA1
; NVT Detached; No reply possible
DETINT: MOVEM 17,PI2AC+17 ; Stash AC's
MOVEI 17,PI2AC ; Just for symmetry
BLT 17,PI2AC+16
MOVE P,L2PDP ; Set up stack
MOVX A,<PC%USR+HANGUP> ; They went away, go hangup
MOVEM A,RETPC2 ; Save for return
DEBRK ; And return
ERJMP DBKFAL ; #2 go detach and logout
JRST DBKFAL ; Just in case
SUBTTL PSI Handlers - Level 2 (Non-Fatal) - CTCINT, IOXINT, QTAINT
; ^C (^E if debug)
CTCINT: MOVEM 17,PI2AC+17 ; Stash the AC's
MOVEI 17,PI2AC
BLT 17,PI2AC+16
MOVE P,L2PDP ; And set up a stack
SETOM CTCFLG
ABODBK: MOVX A,<PC%USR+ABORPC> ; Force it to break out at this PC
MOVEM A,RETPC2
JRST L2DBRK
; IO Error
IOXINT: MOVEM 17,PI2AC+17 ; Stash the AC's
MOVEI 17,PI2AC
BLT 17,PI2AC+16
MOVE P,L2PDP ; And set up a stack
SETOM IOXFLG ; Flag the I/O error
JRST ABODBK ; Abort to ABORPC on debreak
; Quota Exceeded
QTAINT: MOVE P,GPDP ; Restore stack level, just in case.
HRROI X,[ASCIZS (456,552,< Exceeded working quota>)]
MOVX A,<PC%USR+DATABE> ; Debreak out to close conn etc.
MOVEM A,RETPC2
DEBRK
ERJMP DBKFA3
SUBTTL PSI Handlers - Level 2 (Non-Fatal) - Control-T
CTTINT: MOVEM 17,PI2AC+17 ; Save registers
MOVX 17,<0,,PI2AC> ; Here
BLT 17,PI2AC+16
MOVX A,.PRIOU
DOBE
HRROI A,[ASCIZS (100,111,< Awaiting data transfer command.
>)]
SKIPN F$DTRQ ; Transfer requested or
SKIPE F$DTIP ; In progress
SKIPA ; Yes, report state
JRST CTINT7 ; No, simple reply
HRROI A,[ASCIZS (100,111,< Data transfer in progress, >)]
PSOUT
MOVX A,.PRIOU
MOVE B,NBYTES
MOVX C,DECRAD
NOUT
JFCL
HRROI A,[ASCIZ /. bytes sent/]
SKIPN F$SEND ; Which direction
HRROI A,[ASCIZ /. bytes received/]
PSOUT
TXNN F,F.TYPX
JRST CTINT4
HRROI A,[ASCIZ / (page /]
PSOUT
MOVX A,.PRIOU
MOVE B,PAGENO
NOUT
JFCL
HRROI A,[ASCIZ /)/]
PSOUT
CTINT4:
HRRZ B,LCLJFN
JUMPE B,CTINT6
HRROI A,[ASCIZ / from /]
SKIPN F$SEND ; Which direction
HRROI A,[ASCIZ / for /]
PSOUT
MOVX A,.PRIOU
MOVX C,<..DEVD+..DIRD+..NAMA+..TYPA+..GENA+JS%PAF>
JFNS
CTINT6: HRROI A,[ASCIZ /.
/]
CTINT7: PSOUT
JRST L2DBRK ; All done
SUBTTL Command Execution Routines - USER
ZUSER: GJINF ; See if logged in already
JUMPN A,[JSP B,RPCRLP ; If so, complain
ASCIZS (504,503,< You are already logged in.>)]
TXZ F,F.ANON ; Make sure not ANONYMOUS
SETZM $ACCT ; Clear any account junk
CALL SST ; Skip leading spaces
MOVX A,<POINT 7,$USER> ; User name string storage
MOVEI C,^D39 ; Maximum length
USER01: ILDB B,SBP ; Get a character
IDPB B,A ; Store in string
JUMPE B,USER02 ; Quit on null
SOJG C,USER01 ; Loop for whole name
USERNG: SETZM USERNM ; Too long. No User ID.
AOS A,USRFCT ; Count bad user names
CAIL A,5 ; Allow him a few, then force him out
JRST USER03 ; Too many
CALL ADDREP ; Tell him user doesn't exist
ASCIZS (431,530,< No such user as >)
HRROI B,$USER
SOUT
MOVEM A,REPLYP
JSP B,RPCRLP ; Return error msg
ASCIZ /./
USER03: JSP B,ERRRPL ; Hang up with following msg
ASCIZS (430,421,< Too many login failures. Goodbye.>)
USER02: MOVX B,<POINT 7,$USER> ; Name string
CALL USRCHK ; Check if valid user
JRST USERNG ; Failed
JRST [AOS A,USRFCT ; Cannot login to a FILES-ONLY Directory
CAIL A,5 ; Count failures, allow a few
JRST USER03 ; Too many. Hang him up.
JSP B,RPCRLP ; Tell him that's FILES-ONLY
ASCIZS (431,530,< You can't log in under that directory name.>)]
MOVEM B,USERNM ; Ok, save User ID #
CAME B,ANOUNO ; ANONYMOUS?
JRST USER04 ; No. Skip over ANONYMOUS
SUBTTL Anonymous User
; Anonymous User - Get ANONYMOUS' password from system file
SETZM ANOPSW ; Collect ANONYMOUS password
MOVX A,GJ%OLD+GJ%SHT ; From system file
HRROI B,T20.AU ;TOPS-20
SKIPE TENEX ;ANONYMOUS.USERFILE
HRROI B,TNX.AU ;TENEX
GTJFN
JRST USRAN1 ; File not there - don't allow logins
MOVEM A,ANNJFN ; Stash JFN here
MOVX B,<FLD(7,OF%BSZ)+OF%RD> ; Read ASCII from first line
OPENF ; Open file
JRST USRAN2 ; Can't?
MOVX D,<POINT 7,ANOPSW> ; Store text here
MOVX C,^D39 ; Max length in case file bad
USRAN4: BIN ; Get a character of password
IDPB B,D ; Store in string
SOJLE C,USRAN2 ; Too long
CAIL B,C.SPACE ; Valid character?
JRST USRAN4 ; Yes, get next
MOVX B,C.NUL ; Terminate with NULL
DPB B,D ; Over invalid byte
TXO F,F.ANON ; ANONYMOUS is the user name
USRAN2: CLOSR ANNJFN ; Finished with file
USRAN1: TXNE F,F.ANON ; Get password ok?
JRST USER04 ; Yes
SETZM USERNM ; Invalid user (ANONYMOUS)
AOS A,USRFCT
CAIL A,5 ; Count failures, allow a few
JRST USER03 ; Too many. Hang up.
JSP B,RPCRLP
ASCIZS (431,530,< ANONYMOUS logins are not allowed.>)
USER04: ; Continue...
; IFN REL4,<
SKIPN TENEX ; No GDACC in TOPS-20
JRST USER06 ; Have one in TENEX
;> ;END RELEASE 4 CONDITIONAL
MOVX A,<POINT 7,$ACCT+1> ; Back here from ANONYMOUS
MOVE B,USERNM ; See if user has a default account
JSYS 331 ; TENEX GDACC
JRST USER06 ; No.
MOVEM A,$ACCT ; Yes. Store it for LOGIN JSYS
USER06:
HRROI B,[ASCIZS (330,331,< ANONYMOUS user ok, send real ident as password.>)]
TXNE F,F.ANON ; ANONYMOUS or real user?
JRST RPCRLP ; ANONYMOUS. Ask for name (specal msg)
JSP B,RPCRLP ; Real. Ask for password
ASCIZS (330,331,< User name ok. Password, please.>)
SUBTTL Command Execution Routines - PASS
ZPASS: SETZM $PASS ; Make sure no junk left around
SKIPN USERNM ; Has a user been seen?
JRST PASS06 ; No.
CALL SST ; Skip leading (unquoted) spaces
MOVX A,<POINT 7,$PASS> ; Password string storage
MOVX C,^D39 ; Maximum length
PASS01: ILDB B,SBP ; Get a character
CAIN B,C.QUOTE ; Quote character?
JRST [ILDB B,SBP ; Quoted character. Copy it.
JRST PASS03] ; Without crunching lower case to upper
CAIL B,"a" ; Not quoted, make LC be UC
CAILE B,"z"
SKIPA ; Not lower case
SUBI B,"a"-"A" ; Make lower be upper
PASS03: IDPB B,A ; Store the character
JUMPE B,PASS04 ; Jump at end.
SOJG C,PASS01 ; Space counter
PASSNG: SETZM $PASS ; Clear. Flags that no good pswd yet.
AOS A,PASFCT ; Count bad passwords
HRROI B,[ASCIZS (430,421,< Password wrong again. Goodbye.>)]
CAIL A,5 ; Allow a few, then force off
JRST ERRRPL ; Hang up on him
JSP B,RPCRLP ; Bad, but not too many times yet
ASCIZS (431,530,< Password incorrect.>)
PASS04: TXNE F,F.LOGI ; Am I already logged in?
JRST PASCWD ; Yes, maybe for CWD
IFN REL4,<SKIPN TENEX
JRST PASS4A ; If TOPS-20
> ; End of Release 4 conditional
; TENEX
HRRZ A,USERNM ; Check the password. User ID
TXO A,1B0 ; Check, don't connect
HRROI B,$PASS ; The supplied password
IFN ANOP,< ; Do not demand user give password
TXNE F,F.ANON ; ANONYMOUS?
HRRI B,ANOPSW ; Yes, different password.
>
TXNE F,F.ANON ; If trying ANONYMOUS,
SKIPE $PASS ; Phony password must be non-null.
CNDIR ; Check it
JRST PASSNG ; Fail. Count it, reply, maybe hangup.
PASS4A:
SUBTTL Command Execution Routines - PASS, cont.
IFN REL4,<SKIPE TENEX ; If REL4 try without an account
>
SKIPE $ACCT ; Any default account?
JRST PASS10 ; Yes. Go do the login.
PASSAC: JSP B,RPCRLP ; No. ask for the account.
ASCIZS (331,332,< Password OK, Account please.>)
PASS06: JSP B,RPCRLP ; Pass w/o user
ASCIZS (431,503,< User name before password, please.>)
SUBTTL Command Execution Routines - PASS/ACCT - Try to login
;Back here from ACCT command, too, if not yet logged in.
PASS10: MOVX A,.SFNVT ; Are logins on NVT's allowed?
TMON
JUMPE B,NVTNLI ; If not, don't allow FTP service either
MOVE A,USERNM ; User ID
JUMPE A,PASS06 ; If no user name yet, don't login.
SKIPE TENEX ; Not supported on TOPS-20
HRLI A,(1B16) ; TENEX bit to suppress login date update
MOVX B,<POINT 7,$PASS> ; Password
MOVE C,$ACCT ; And account
IFN ANOP,< ; Do not demand user give password
TXNE F,F.ANON ; ANONYMOUS?
HRRI B,ANOPSW ; Yes. Here's its password.
>
LOGIN ; Failed? Strange. Report it.
SKIPA ; Lose
JRST PASS12 ; Ok, continue
SKIPN $ACCT ; See if defaulting
JRST [CAIN A,LGINX1 ; Invalid account?
JRST PASSAC ; Yes
CAIN A,602111 ; VACCX0 - invalid account
JRST PASSAC
CAIN A, 602112 ; VACCX1 - string too long
JRST PASSAC
CAIN A,602126 ; VACCX2 - account expired
JRST PASSAC
JRST .+1] ; Go give ERRSTR message
CALL CLRPSW ; No, clear secret info
PUSH P,A
CALL ADDREP ; Build a reply
ASCIZS (431,530,< Login failed unexpectedly, >)
POP P,B
HRLI B,.FHSLF ; Error in this fork
ERSTR ; String for the error
JFCL
SKIPA
MOVEM A,REPLYP ; End of string
JSP B,RPCRLP ; Carriage return and reply
ASCIZ /./
SUBTTL Command Execution Routines - PASS/ACCT - Logged in
PASS12: TXO F,F.LOGI ; Flag that I am logged in.
CALL CLRPSW ; Clear secret info
IFN ENABL,<
MOVX A,.FHSLF ; Enable caps
SETOB B,C
EPCAP
> ; End of ENABL
GJINF ; Update job info
MOVEM A,GJINF1
MOVEM B,GJINF2
MOVEM C,GJINF3
MOVEM D,GJINF4
MOVE A,REPLYP ; Compose a pretty login message
HRROI B,[ASCIZ /230 User /]
SETZ C,
SOUT
MOVE B,USERNM ; Convert User ID to name string
DIRST
ERJMP .+1 ; Can't fail
HRROI B,[ASCIZ / logged in at /]
SETZ C,
SOUT
SETO B,
MOVX C,<OT%DAY+<0*OT%FDY>+OT%NSC+OT%TMZ+OT%SCL>
ODTIM ; Format of date/time
HRROI B,[ASCIZ /, job /]
SETZ C,
SOUT
HRRZ B,GJINF3 ; Job number
MOVX C,DECRAD
NOUT
JFCL
HRROI B,[ASCIZ /. /]
SETZ C,
SOUT
MOVEM A,REPLYP ; Message pointer so far.
HRROI B,CRLFM ; End of line
SOUT
SUBTTL Command Execution Routines - Logged in, Get high segment
IFN IPCLOG,<
HRROI A,IPCDAT ; And tell controller
HRROI B,[ASCIZ /FTP Server: /]
SETZ C,
SOUT
MOVE B,PREPLY ; Get initial pointer
IBP B
IBP B
IBP B ; After the 230
SOUT
CALL SNDCTL
>
; Here to get in the file activity portion now that program is
; safely logged in. Note that this greatly reduces security errors.
GJINF ; Find out from system whether I am
SKIPN A ; really logged in.
CALL BOMB ; Not logged in! Quit and hang up.
CALL GETHI ; Map the high segment back to life
JSP B,RPCRLP ; All set, give greeting
0
SUBTTL Subroutines - GETHI, CLRPSW
; CALL GETHI Map High Segment back in (Only if logged in)
GETHI: MOVX A,<HSBAS/1000> ; First page of critical code
PUSH P,A ; Current page number to stack
GETLP: MOVX A,<.FHSLF,,0> ; In this fork,
HRR A,0(P) ; At this page,
RPACS ; See if page is there
TXNN B,PA%PEX
JRST GETLPN ; No, so can't make it accessible
MOVX B,PA%RD+PA%EX ; Set access to read execute (no write)
SPACS
GETLPN: AOS A,0(P) ; Look at next page
CAIGE A,700 ; Unless up to DDT area
JRST GETLP
POP P,A ; Discard page number
RET ; End of GETHI
; CALL CLRPSW Clear Passwords
;SAVES ALL
CLRPSW: PUSH P,A ; Be transparent
SETZM $PASS ; Clear secret info
MOVX A,<$PASS,,$PASS+1> ; In all password areas
BLT A,$PASS+7
SETZM ANOPSW
MOVX A,<ANOPSW,,ANOPSW+1>
BLT A,ANOPSW+7
SETZM CMDIB
MOVX A,<CMDIB,,CMDIB+1>
BLT A,CMDIB+20
JRST APOPJ
SUBTTL Command Execution Routines - ACCT
ZACCT: CALL SST
MOVE A,SBP ; Pick up account characters here
MOVX B,<POINT 7,$ACCT+1>; Store string here
MOVX D,^D39 ; Max length of string
SETZ T1, ; Accumulate number here
TXZ F,F.NUMA ; So far, it may be a number
SETZM $ACCT+1 ; Clear so can tell if null argument
ACCT01: ILDB C,A ; Get a character of the account
JUMPE C,ACCT02 ; End of argument
CAIL C,"a" ; Lower case?
CAILE C,"z"
SKIPA ; No
SUBI C,"a"-"A" ; Yes, make upper.
SKIPN TENEX ; Test system
JRST ACCTNN ; If TOPS-20 only string accounts
CAIL C,"0" ; Decimal digit?
CAILE C,"9"
JRST ACCTNN ; Not numeric
IMULI T1,12 ; Accumulate number
ADDI T1,-"0"(C)
SKIPA
ACCTNN: TXO F,F.NUMA ; Not numeric
IDPB C,B ; Add to text string
SOJG D,ACCT01 ; Loop if still space.
ACCTNG: JSP B,RPCRLP ; String too long or otherwise bad
ASCIZS (431,530,< Account not valid.>)
ACCT02:; MOVX C,C.NUL ; (It had to be to get here)
IDPB C,B ; Terminate string
SKIPN $ACCT+1 ; Was string non-null?
JRST ACCTNG ; No. Empty string is no good
TXNE F,F.NUMA ; Numeric?
JRST ACCT03 ; No, alphabetic.
TXNE T1,NMFLG ; 33 bit value or less?
JRST ACCTNG ; No. Bad.
TXOA T1,<FLD(NUMVAL,NMFLG)> ; Ok.
ACCT03: MOVX T1,<POINT 7,$ACCT+1> ; Here for string account
MOVEM T1,$ACCT ; This is the designator
SKIPN A,USERNM ; Do we know who we are?
GJINF ; Get who we are
MOVEM A,USERNM ; Save User ID
MOVE B,$ACCT ; Get pointer or number
SKIPN TENEX ; Different on TOPS20
JRST ACCT3A
JSYS 330 ; TENEX VACCT, is it ok?
JRST ACCTNG ; No
IFN REL4,<SKIPA> ; Skip TOPS-20 stuff
ACCT3A:
SUBTTL Command Execution Routines - ACCT, cont.
IFN REL4,<VACCT ; JSYS 566, TOPS-20 is it ok?
ERJMP ACCTNG ; Bad
> ; 101B doesn't validate accounts
TXNN F,F.LOGI ; Am I logged in already?
JRST PASS10 ; No, go do LOGIN.
MOVE A,$ACCT ; Yes, change to this account
MOVX B,0 ; No flags
CACCT ; Do the change
JRST ACCTNG ; This should not fail
JSP B,RPCRLP ; Ok, account has been changed.
ASCIZ /230 Account OK./
SUBTTL Command Execution Routines - TYPE
ZTYPE: CALL BEGREP ; Start building ok reply
ASCIZ /200 Type /
MOVX P1,<-NTYPES,,TYPTAB+1> ; # & Table of known types
CALL GETARG ; Look for arg in table
JRST ARGSYN ; Has to be one
JRST ARGUNK ; Arg was there but not known
MOVEM B,CARG1 ; Save argument so far
CALL 0(C) ; Go to it
LCMRET: JSP B,RPCRLP ; Finish msg and return
ASCIZ / ok./
IFN TCPP,<
TYPTAB: KM(TYPE,<A,E,I,L>,ARGNIM)
FILTAB: 40 ; ASCII <SPACE>
100 ; EBCDIC <SPACE>
0 ; NULL
0 ; NULL
TYPE$L: CALL ADDREP
ASCIZ / bytesize /
MOVE BP,SBP ; For DECIN
LDB B,BP ; Get break
CAIE B,C.SPACE ; Must have space
JRST [JSP B,NURPLY ; Need byte size
ASCIZ /501 TYPE L must specify byte size./]
IFN TCPF,< ; Support byte sizes 1-36
CALL DECIN ; Get logical byte size
JRST [JSP B,NURPLY ; Something wrong
ASCIZ /504 Error in TYPE L logical byte size parameter./]
HRROI B,[ASCIZ /504 TYPE L only implemented for logical byte sizes 1 to 36./]
CAIL A,^D1 ; Min
CAILE A,^D36 ; Max
JRST NURPLY ; Out of range
MOVE B,A ; Byte size
MOVE A,REPLYP ; Where to put it
MOVX C,DECRAD ; In decimal
NOUT ; For the user
JFCL
MOVEM A,REPLYP ; Updated pointer
MOVE A,B ; Byte size for following
CALLRET TY$LN ; Ok
> ; End of IFN TCPF
SUBTTL Command Execution Routines - TYPE, cont.
IFE TCPF,< ; Only support byte sizes 8, 32, 36
MOVX P1,<-NBYTSZ,,BSZTAB>
CALL GETARG ; Get byte size
JRST ARGSYN ; Has to be one
JRST ARGUNK ; Which is implemented
MOVE A,BYTESZ(B) ; Get byte size
MOVEM A,$BYTE ; Set it
MOVEM A,$LBYTE
HRRZ C,BSZTAB(B)
JRST (C) ; Call routine
BSZTAB: KM(BS,<8,32,36>)
NBYTSZ==.-BSZTAB
BYTESZ: DEC 8,32,36
> ; End of IFE TCPF
SUBTTL Command Execution Routines - TYPE, cont.
TYPE$A: LDB B,SBP ; Get break
JUMPE B,TY$DEF ; EOL means default (0)
CALL ADDREP
ASCIZ / /
CALL SST ; Skip break, spaces, tabs
MOVX P1,<-NFORMS,,FRMTAB+1>
CALL GETARG ; Get format arg
JRST ARGSYN ; Has to be one
JRST ARGUNK ; Has to be implemented
JRST (C) ; Call routine
FRMTAB: KM(FORM,<N,T,C>,ARGNIM)
TY$DEF: SETZB T2,CARG1
FORM$N: MOVEM B,$FORM ; Save format
MOVX A,0 ; Local packed words
MOVEM A,$LTYPE
MOVX A,7 ; Local ASCII size
MOVEM A,$LBYTE
MOVX A,^D8 ; ASCII is 8-bit bytes
JRST TCMRET
IFE TCPF,< ; Only support byte sizes 8, 32, 36
BS$8: SKIPA A,[^D8]
BS$32: MOVX A,^D32
SKIPA
BS$36:
> ; End of IFE TCPF
TYPE$I: MOVX A,^D36
TY$LN: MOVEM A,$LBYTE ; A/ byte, CARG1/ type
TCMRET: MOVEM A,$BYTE
; CARG1/ type
MOVE B,CARG1 ; Get type argument
MOVE T1,FILTAB(B) ; Fill character
MOVEM T1,$FILLB ; For this type
> ; End of IFN TCPP
IFE TCPP,<
TYPTAB: KM(TYPE,<A,E,I,L,P,XTP>)
NTYPES==.-TYPTAB
TYPE$A: TYPE$I: TYPE$L: TYPE$XTP:
MOVE B,CARG1 ; Get type argument
> ; End of IDE TCPP
MOVEM B,$TYPE ; Save the index into table
RET
SUBTTL Subroutines - ARGUNK, ARGNIM, GETARG
; JRST ARGUNK Unknown Letter Argument
ARGUNK: CALL BEGREP ; An argument that isn't even in table
ASCIZS (501,504,< I never heard of >)
CALL ADDKEY ; Put command name in
CALL ADDREP
ASCIZ / with argument /
JRST ARGUN1
; JRST ARGNIM Unimplemented Letter Argument
ARGNIM: CALL BEGREP ; An arg in the table but unimplemented
ASCIZS (506,504,< >)
CALL ADDKEY
CALL ADDREP
ASCIZ / is not implemented for argument /
ARGUN1: CALL ADDARG ; Add ARGWRD
JSP B,RPCRLP
ASCIZ /./
; SBP/ Points to next input
; MOVX P1,<-TABLE LENGTH,,TABLE ADDRESS>
; CALL GETARG
; Ret+1 Syntax Error
; Ret+2 Not in table
; Ret+3 Found in table: Index in B, arg added to REPLYM, SBP updated
GETARG: CALL GETWRD ; Get a word
RET ;+1 ; Syntax error
AOS 0(P) ; Ok, skip at least one
MOVEM A,ARGWRD ; Save for error msgs, replies
SETZ B, ; Index into table
GETAR2: HLRZ C,(P1) ; Get address of ASCIZ keyword
CAMN A,(C) ; (First 5 char) same as typein?
JRST GETAR4 ; Yes, found the word
; Go append to reply & skip return
ADDI B,1 ; No, next index
AOBJN P1,GETAR2 ; Loop looking for it
RET ;+2 ; Not in table
GETAR4: PUSH P,C ; Save all
PUSH P,B
PUSH P,A
CALL ADDARG ; Append keyletter to reply
POP P,A
POP P,B
POP P,C
HRRZ C,(P1) ; Dispatch address
AOS (P)
RET;+3
SUBTTL Command Execution Routines - MODE
ZMODE: CALL BEGREP ; Start building ok reply
ASCIZ /200 Mode /
MOVX P1,<-NMODES,,MODTAB+1> ; # & Table of known MODEs
CALL GETARG ; Look for arg in table
JRST ARGSYN ; Syntax error
JRST ARGUNK ; Argument not in table
CALL 0(C) ; Go to it
JRST LCMRET ; Common return for good letter commands
MODTAB:
IFE TCPP,<KM(MODE,<S,B,T,H>,ARGNIM) >
IFN TCPP,<KM(MODE,<S,B,C>,ARGNIM) >
MD$DEF: SETZ B,
MODE$S: MOVEM B,$MODE ; Save the index into table
RET
SUBTTL Command Execution Routines - BYTE
; Note BYTE is not a TCPP Command
IFE TCPP,<
ZBYTE: CALL SST ; Get byte size argument
MOVE BP,SBP
CALL DECIN ; Collect a number
JRST ARGSYN ; Not a number
CAIE A,^D8 ; Eight bits?
CAIN A,^D36 ; 36 bits?
JRST BYTEOK ; Yes
CAIE A,^D32 ; 32 bits?
JRST BYTEX1 ; No
BYTEOK: LDB B,BP ; Get terminator
JUMPN B,BYTEX1 ; Should be eol
MOVEM A,$BYTE ; Store the value
JSP B,RPCRLP ; Ok
ASCIZ /200 Byte size accepted./
BYTEX1: JSP B,RPCRLP
ASCIZS (506,504,< Byte size must be 8, 32, or 36.>)
>
SUBTTL Command Execution Routines - STRU
ZSTRU: CALL BEGREP ; Build a success reply
ASCIZ /200 Structure /
MOVX P1,<-NSTRUS,,STRTAB+1> ; # & Args to structure
CALL GETARG ; Look for arg in table
JRST ARGSYN ; Syntax error
JRST ARGUNK ; Not in table
CALL 0(C) ; Go to it.
JRST LCMRET ; Finish it up
STRTAB:
IFE TCPP,<KM(STRU,<F,R>,ARGNIM) >
IFN TCPP,<KM(STRU,<F,R,P>,ARGNIM) >
ST$DEF: SETZ B,
;STRU$R: ; Record length??
STRU$P:
STRU$F: MOVEM B,$STRU ; Store the arg
RET
SUBTTL Command Execution Routines - ABOR (^C or IO Error)
; DEBRK to ABORPC On ^C or IO Error
ABORPC: MOVE P,GPDP ; Restore stack level, just in case.
HRROI A,[ASCIZS (456,500,< ? Unknown error interrupt.
>)]
SKIPE CTCFLG ; Was it a ^C?
HRROI A,[ASCIZS (456,552,< Interrupt by user.
>)]
SETZM CTCFLG
SKIPE IOXFLG ; I/O error?
HRROI A,[ASCIZS (456,552,< System I/O Error.
>)]
SETZM IOXFLG
PSOUT ; Report error, fake ABOR
; ABORt command
ZABOR: SKIPE F$DTIP ; File activity?
JRST DOABOR ; Yes. Abort it
; No
IFN TCPP,<
SKIPLE DATCON ; Data connection open?
SKIPN DATCON+T.JCN
JRST ZABOR5 ; No
JSP B,RPCRLP ; Yes, report it
ASCIZS (<202 ABOR request ignored.>,<225 No file transfer in progress, Data connection OPEN.>)
ZABOR5:
> ; End of IFN TCPP
JSP B,RPCRLP ; Report data connection closed
ASCIZS (<202 ABOR request ignored.>,<226 No file transfer in progress, Data connection CLOSED. >)
; Abort data transfer
DOABOR: CLOSD DATCON ; Close the data connection
SETZM F$DTIP ; Data transfer no longer in progress
JSP B,RPCRLP ; Back to top.
ASCIZS (<200>,<226>,< File transfer aborted, Data connection CLOSED.>)
SUBTTL Command Execution Routines - BOMB, BYE/QUIT, CRASH, HELP, NOOP
ZBOMB: CALL BOMB ; Another one
ZBYE:
ZQUIT: JSP B,ERRRPL ; Send this message, then hang up.
ASCIZS (<231 BYE>,<221 QUIT>,< command received. Goodbye.>)
ZCRASH: JRST 4,. ; Test command for fatal errors
ZNOP:
ZNOOP: JSP B,RPCRLP
ASCIZS (200,200,< No-operation OK.>)
ZSITE: JSP B,RPCRLP
ASCIZS (100,214,< Use SMNT <structure-name> to use unregulated structures.>)
SUBTTL Command Execution Routines - HELP
;CWL ARG & MORE INFO
ZHELP:
IFE TCPP,<
JSP B,RPCRLP
ASCIZS (100,,< The following commands are allowed before logging in:
100 USER, PASS, ACCT, NOP, NOOP, HELP, MAIL, MLFL, BYE,
100 BYTE (8 only), TYPE (A only), MODE (S only), and STRU (F only).
100 After logging in, the following are allowed:
100 BYTE (8, 32 and 36 only), SOCK, TYPE (A,I,L,XTP only),
100 RETR, STOR, APPE, RNFR, RNTO, DELE, LIST, NLST,
100 STAT (for directory listing), CWD and XCWD.
200 End of help text.>)
>
IFN TCPP,<
HRROI B,HMSNL ; Pre-login message
TXNE F,F.LOGI
HRROI B,HMSLI ; Post-login message
JRST RPCRLP
HMSNL: ASCIZ /214-The following commands are allowed before logging in:
214- USER, PASS, ACCT, HELP, MAIL, MLFL, QUIT,
214- SITE, TYPE A, MODE S, STRU F, and NOOP.
214-After logging in, the following are also allowed:
214- TYPE I, TYPE L 1 to 36, STRU P,
214- RETR, STOR, APPE, RNFR, RNTO, SMNT, CWD,
214- DELE, LIST, NLST, STAT, PASV, and PORT.
214 End of help text./
HMSLI: ASCIZ /214-The following commands are allowed:
214- PASS, ACCT, HELP, QUIT, NOOP,
214- SITE, TYPE I, TYPE L 1 to 36, STRU P,
214- RETR, STOR, APPE, RNFR, RNTO, SMNT, CWD,
214- DELE, LIST, NLST, STAT, PASV, and PORT.
214 End of help text./
>
SUBTTL Command Execution Routines - MAIL/MLFL
; MAIL Command - Appends mail to local user's mailbox
; and MLFL Command, same but data on data conn instead of TELNET.
ZMAIL: TXZA F,F.MLFL ; Flag MAIL, not MLFL
ZMLFL: TXO F,F.MLFL ; Flag MLFL, not MAIL
TXNE F,F.LOGI ; Don't accept mail if logged in.
SKIPE DBUGSW ; If debug ok to be logged in
TRNA
JRST [JSP B,RPCRLP
ASCIZS (<504>,<530>,< Mail only accepted if you do NOT log in first.>)]
CALL SST ; Skip over to name
; XSEM joins here ;CWL WHAT ABOUT F.LOGI & F.MLFL
;MAILJ:
TXZ F,<F.MFWD+F.NXM> ; Assume not forwarding
CALL DELTMP ; Flush temp file if exists
CLOSR LCLJFN ; In case aborted out of MAIL
SETOM LCLJFN ; No temp file
SETZM F$KPGN
SETZM IBITCT ; No bits read yet
SETZM MLDIR ; No directory # yet
SETZM MLUSR ; No user # yet
SETZM MLUNST ; No user name yet
MOVE B,SBP
MOVX C,5*MLUNWD
SETZ D,
HRROI A,MLUNST
SOUT
MOVX B,C.NUL
IDPB B,A ; Terminate string
SKIPN MLUNST ; There was a name, wasn't there?
;CWL BETTER MESSAGE HERE?
JRST MAILX4 ; No. A losing command
SUBTTL Command Execution Routines - MAIL/MLFL, cont.
HRROI A,GTJSTR ; Now make the destination name
HRROI B,T20.DV ; TOPS-20 structure name
SKIPE TENEX ; Add structure name
HRROI B,TNX.DV ; TENEX structure name
SETZ C,
SOUT
MOVEI B,"<" ; Stick in user name
BOUT
HRROI B,MLUNST ; Name from command
SOUT
MOVEI B,">" ; End user name
BOUT
HRROI B,T20.MB ; TOPS-20
SKIPE TENEX ; Mailbox file name
HRROI B,TNX.MB ; TENEX
SOUT
PUSH P,A ; BBN save ptr for account
MOVX A,<GJ%DEL+GJ%SHT> ; TOPS-20
SKIPE TENEX
MOVX A,<GJ%OLD+GJ%DEL+GJ%SHT> ; See if TENEX mailbox exists
HRROI B,GTJSTR
GTJFN ; First try with user's default account
IFE MLACTF,<
JRST MLFWQ ; It doesn't. See if forwarding exists.
>
IFN MLACTF,<
JRST [POP P,A ; Restore string for account
HRROI B,TXX.AC ; Mail default account string
SOUT
MOVX A,<GJ%DEL+GJ%SHT> ; TOPS-20
SKIPE TENEX
MOVX A,<GJ%OLD+GJ%DEL+GJ%SHT> ; See if TENEX mailbox exists
HRROI B,GTJSTR ; Point to new string
GTJFN ; Second, try with mail account string
JRST MLFWQ ; Both lose, see if forwarding exists.
TXO F,F.NXM ;****; Mark user account as "nonexistant" (funny)
JRST .+2] ;****; Join below after pop
>
POP P,(P) ; Flush string
SUBTTL Command Execution Routines - MAIL/MLFL, cont.
MOVX B,<1,,.FBCTL> ; Make sure alleged mailbox is
MOVEI C,C ; permanent. If not, pretend
GTFDB ; it doesn't exist
TXNN C,FB%PRM
JRST [RLJFN ; If not permanent
JFCL
JRST MLFWQ] ; Forward it
RLJFN ; Release mailbox JFN
JFCL
CALL TIMEOK ; Update kill time
; Note: Mailboxes can exist in directories which are NOT users
HRROI B,MLUNST ; Ok, get directory number
CALL DIRCHK ; See if such a directory
JRST MAILX4 ; No such directory
; CWL CANE B, ANONYMOUS DIR # ; Refuse mail to ANONYMOUS?
CAMN B,SYSDNM ; System directory?
;CWL BETTER MESSAGE?
JRST MAILX4 ; Yes. Refuse it.
MOVEM B,MLDIR ; Save directory #
; MOVEM B,MLUSR ; Also default user # (if TENEX)
HRROI B,MLUNST ; Mailbox name
CALL USRCHK ; See if also a user
JFCL ; No, USER # is really DIR #
MOVE B,MLDIR ; FILES-ONLY (ok here)
MOVEM B,MLUSR ; Real user
SUBTTL Command Execution Routines - MAIL/MLFL, cont.
MAIL0A: HRROI A,GTJSTR ; Build a name for temp file for mail.
HRROI B,T20.DV ; TOPS-20
SKIPE TENEX ; Structure name
HRROI B,TNX.DV ; TENEX
SETZ C,
SOUT
HRROI B,TXX.MT ; Mail temp file name
SOUT
HRRZ B,GJINF3 ; Job number
MOVX C,DECRAD ; Decimal
NOUT ; Into filename
JSP E,MAILX9 ; Impossible failure
REPEAT 0,<
MOVEI B,"-" ; Separator
BOUT
PUSH P,A ; Save pointer
GTAD ; Get a number
MOVE B,A ; Store it
POP P,A ; Restore
NOUT ; And make file name unique
JSP E,MAILX9 ; Can't fail
>
HRROI B,[ASCIZ /;P770000/]; And make job dependent.
SETZ C,
SOUT
IFN MLACTF,<
HRROI B,TXX.AC ; Mail account
SOUT
> ; End of IFN MLACTF
MOVX B,C.NUL ; Make sure terminator
BOUT
;MAIL01:
MOVX A,<GJ%FOU+GJ%TMP+GJ%DEL+GJ%SHT>
HRROI B,GTJSTR ; GTJFN short, string, out, temp, ig del.
GTJFN
JSP E,MAILX9 ; Can't?
MOVEM A,LCLJFN ; Store JFN
CALL TIMEOK ; Update kill time
MOVX B,<FLD(7,OF%BSZ)+OF%WR> ; Open to write.
OPENF
JSP E,MAILX9 ; Can't?
SUBTTL Command Execution Routines - MAIL/MLFL, cont.
;MAIL HEADER:
; Mail-From: foreign host
; Recieved-Date: dd-mon-yy hhmm-tmz
;USER SHOULD START WITH Date:, From:, Subject: AND To:
HRROI B,[ASCIZ /Mail-From: /] ; Write mail header info
SETZ C,
SOUT
MOVE B,A ; Tmp file JFN
MOVX A,.GTHNS
MOVE C,FHSTN
GTHST
JRST [MOVE A,LCLJFN
HRROI B,[ASCIZ /Site /]
SETZ C,
SOUT
MOVX D,<POINT 8,FHSTN,3>
CALL HST4DA ; #.#.#.# to A/
JRST .+1]
;MAIL1B:
MOVE A,LCLJFN
HRROI B,[ASCIZ/
Received-Date: /]
SETZ C,
SOUT
MOVX C,<OT%NSC+OT%NCO+OT%TMZ+OT%SCL>
SETO B,
ODTIM
HRROI B,CRLFM ; End line
SETZ C,
SOUT
TXNE F,F.MLFL ; Mail file?
JRST MLFL01 ; Yes. Different data capture mechanism
SUBTTL Command Execution Routines - MAIL from TELNET connection
MOVX A,.PRIOU
HRROI B,[ASCIZS (<350 >,<354->,<Type mail, ended by a line with only a "."
>,<>,<354 Begin with Date:, From:, Subject: and To:
>)]
SETZ C,
SOUT ; Send msg and dump buffer
MAILL1: TXO F,F.INML ; Flag no editing
CALL LINEIN ; Now read TELNET lines.
JRST [TXZ F,F.INML ; Clear flag
TXNE F,F.LTL
JRST [JSP X,MAIL05 ;MAILX6:
ASCIZ /451 Line too long./]
JRST [JSP X,MAIL05 ;MAILX8: EOF ON TELNET. ABORT.
ASCIZS (453,426,< Net connection closed.>)]
]
TXZ F,F.INML
;MAIL1A:
MOVE A,CMDIB ; See if line was just a dot
CAMN A,[ASCII /./]
JRST MAIL02 ; Yes. Defines end.
MOVE A,LCLJFN
HRROI B,CMDIB ; Put the line in the temp file
SETZ C,
SOUT
HRROI B,CRLFM ; And a CR LF which was stripped
SOUT
CALL TIMEOK ; Update kill time
JRST MAILL1 ; Loop till dot or EOF
SUBTTL Command Execution Routines - MAIL from data connection
MLFL01: CALL OPN8NC ; Get a data connection
JRST [JSP B,RPCRLP ; MLFLXP: Fail because parameters no good
ASCIZS (454,501,< Mail file must be 8-bit, Ascii type, Stream mode, File structure.>)]
JRST [CLOSD DATCON ; MFPDX1:
CLOSR LCLJFN
CALL DELTMP
JSP B,RPCRLP
ASCIZS (454,425,< Unable to establish data connection.>)]
MOVX A,.PRIOU
HRROI B,[ASCIZS (250,150,< Begin mail file transfer.
>)]
SETZ C,
SOUT ; Send msg and dump buffer
MLFLL1: MOVE A,DATCON ; Get the mail
$BIN
JUMPN B,MLFLN ; EOF or NULL?
$GTSTS ; Yes. See which.
TXNE B,GS%EOF
JRST [CLOSD DATCON ; MLFLEF:
JRST MAIL02] ; Now copy to real mailbox.
JRST MLFLL1 ; NULL. Throw it away.
MLFLN: CAILE B,177 ; And throw away TELNET controls
JRST MLFLL1
MOVE A,LCLJFN ; Ok, a real char. Put in file
BOUT
CALL TIMEOK ; Update timeout
JRST MLFLL1 ; Onward.
;MLFLEX: CLOSD DATCON ; Close JFN
; JRST MAIL05 ; And release files
SUBTTL Command Execution Routines - MAIL from local temp file
; All mail in temp file
MAIL02: MOVX A,CO%NRJ ; Keep JFN
HRR A,LCLJFN ; For temp file
CLOSF ; But keep the JFN
JFCL
CALL TIMEOK ; Update kill time
HRRZ A,LCLJFN ; Re-open for reading
MOVX B,<FLD(7,OF%BSZ)+OF%RD> ; Reopen for reading
OPENF
JSP E,MAILX9 ; Can't
SIZEF ; Check size of the mail
JSP E,MAILX9 ; Can't fail
ASH B,3 ; Eight bits per
ADDM B,TRBITS
ASH B,-3
CAIL B,10000 ; Don't allow super-huge files.
JRST [JSP X,MAIL05 ; MAILX5: Bad.
ASCIZ /451 Message too long./]
TXNE F,F.MFWD ; Forwarding?
JRST [HRROI A,GTJSTR ; Yes. Copy file name to fwd thru
HRROI B,MLFWST
SETZ C,
SOUT
MOVX B,C.NUL
BOUT ; Terminate with null
JRST MAIL2A]
HRROI A,GTJSTR ; Now make the destination name
; HRROI B,T20.DV ; TOPS-20
; SKIPE TENEX ; Structure name
; HRROI B,TNX.DV ; TENEX
; SETZ C,
; SOUT
MOVEI B,"<" ; Stick in user name
IFN REL4,<SKIPE TENEX> ; If on TENEX, make into a directory
BOUT
MOVE B,MLDIR ; His directory number
DIRST ; TENEX "NAME"; TOPS-20 "PS:<NAME>"
JSP E,MAILX9 ; Shouldnt fail
MOVEI B,">"
IFN REL4,<SKIPE TENEX> ; If TENEX, stick in an anglebracket
BOUT
HRROI B,T20.MB ; TOPS-20
SKIPE TENEX ; Mail box file name
HRROI B,TNX.MB ; TENEX
SETZ C,
SOUT
HRROI B,TXX.AC ; Default account string
TXZE F,F.NXM ; Was mailbox "nonexistant"?
SOUT ; Yes, tack on an account
MOVX B,C.NUL ; Make sure NUL terminator
BOUT
; Falls thru
; Fallen into from above
; Try to open mailbox or "[--UNSENT-MAIL--].user@host"
;CWL FLAG FOR QUEUED VS DELIVERED FOR REPLY MESSAGE?
MAIL2A: MOVX X,5 ; Times to try if busy
MAIL2B: HRROI B,GTJSTR ; Now get a JFN for mailbox
MOVX A,GJ%DEL!GJ%SHT ; TOPS-20
SKIPE TENEX
MOVX A,GJ%OLD!GJ%DEL!GJ%SHT ; TENEX
TXNE F,F.MFWD ; Forwarding?
MOVX A,GJ%FOU!GJ%NEW!GJ%SHT ; New file only then
;MAIL2C:
GTJFN
JSP E,MAILX9 ; No such file
; JRST MAILX4 ; No such file
PUSH P,A ; Keep on stack
HRLI A,.FBCTL ; Make sure it's undeleted
MOVX B,FB%DEL
MOVX C,<0*FB%DEL> ; Not deleted bit
CHFDB
CALL TIMEOK ; Update kill time
HRRZ A,0(P) ; Restore JFN
MOVX B,<FLD(7,OF%BSZ)+OF%APP> ; Append to it.
OPENF
JRST [ ; Open failure
MOVEM A,B ; Save error code for diagnosis
POP P,A ; First release JFN
RLJFN
JFCL
SOJLE X,[ ; If giving up, diagnose failure
CAIE B,OPNX1 ; File is already open
CAIN B,OPNX9 ; Invalid simultaneous access
; If can forward, to MAIL2A above
JRST [MOVE A,FHSTN ; Don't queue if from same host
;CWL WHY NOT??
TXNN F,F.MFWD ; Only possible if to real mailbox
CAMN A,LHOSTN ; To avoid circular sending
JRST [JSP X,MAIL05
ASCIZS (453,450,< Mailbox busy.>)]
HRROI A,GTJSTR ; Ok to queue. Make file name
SUBTTL Command Execution Routines - MAIL from local temp file, cont.
HRROI B,T20.UM ; TOPS-20
SKIPE TENEX ; [--UNSENT-MAIL--].
HRROI B,TNX.UM ; TENEX
SETZ C,
SOUT
HRROI B,MLUNST ; User
SOUT
HRROI B,TXX.MA ; @
SETZ C,
SOUT ; No host (local)
HRROI B,T20.NV ; TOPS-20
SKIPE TENEX ; ./;-1
HRROI B,TNX.NV ; TENEX
SOUT
HRROI B,TXX.AC ; Optional mail account
SOUT
MOVX B,C.NUL
BOUT
TXO F,F.MFWD ; Now forwarding
JRST MAIL2A]
CAIN B,OPNX6 ; Append access required
JRST [JSP X,MAIL05
ASCIZS (450,550,< Append access to mailbox not allowed.>)]
CAIN B,OPNX10 ; Entire file structure full
JRST [JSP X,MAIL05
ASCIZS (453,452,< Disk full.>)]
CAIN B,OPNX16 ; File has bad index block
JRST [JSP X,MAIL05
ASCIZS (453,550,< Mailbox damaged.>)]
JRST [JSP X,MAIL05
ASCIZS (453,550,< Unexpected failure to open mailbox.>)]
]
MOVX A,^D2000 ; Wait & try again
DISMS
JRST MAIL2B]
SUBTTL Command Execution Routines - MAIL from local temp file, cont.
MOVE A,LCLJFN ; Get # of chars in temp file
SIZEF
JRST [POP P,A
CLOSF
JFCL
JSP E,MAILX9]
MOVEM B,T1 ; Save # chars in T1
TXNE F,F.MFWD ; Forwarding?
JRST MAILL2 ; Yes. Don't put header on.
MOVE A,0(P) ; Message file
SETO B, ; Put standard msg file format on.
MOVX C,OT%TMZ ; First, date and time with time zone.
ODTIM
MOVX B,"," ; Then comma
BOUT
MOVE B,T1 ; Size of text
MOVX C,DECRAD ; Decimal radix
NOUT
MOVE A,0(P) ; If error, JFN back to A
MOVX B,";" ; Now bit flag field ;#6 remove space
BOUT
SETZ B, ; Is normally 0.
MOVE C,FORNS ; If foreign ICP socket
REPEAT 0,< ; 3/81 conflicts with HERMES
CAIL C,MLSKT ; Is authenticated mail socket
CAILE C,MLSKT+5 ; In this group of 6
SKIPA ; No good.
TXO B,1B7 ; Ok, flag verified in B7
>
MOVX C,<NO%LFL+NO%ZRO+FLD(^D12,NO%COL)+FLD(OCTRAD,NO%RDX)>
NOUT ; 12 octal digits, leading 0'S.
MOVE A,0(P) ; If error, JFN back to A
HRROI B,CRLFM
SETZ C,
SOUT ; And CR, LF on end of line
; Fall thru
; MAIL BOX(forward) JFN on stack
MAILL2: MOVE A,LCLJFN ; Temp file JFN pointer back at start
SETZ B,
SFPTR
JFCL
MOVE B,T1 ; Count 8-bit chars, though includes
IMULI B,10 ; Small error of local header
ADDM B,IBITCT
ADDM B,TRBITS
MLLUP1: CALL TIMEOK ; Loop to copy from temp to msg file
SKIPG C,T1 ; # of chars left to copy
JRST MAIL03 ; No more
CAILE C,5000 ; If > 1 page, just do next page
MOVX C,5000
SUB T1,C ; Adjust # remaining chars
MOVE A,LCLJFN ; Set up to read from temp file
HRROI B,WINDOW ; into window
PUSH P,C ; Save # chars to read or
REPEAT 0,<
MOVX D,C.FF ; Stop on formfeed (to convert it)
MLLUP2:
>
SIN ; Read
REPEAT 0,<
LDB T2,B ; If last char FF, replace by LF
CAIN T2,C.FF
MOVX T2,C.LF
DPB T2,B
JUMPN C,MLLUP2 ; Finish SIN if incomplete
>
POP P,C ; # of chars read
MOVNS C ; Write them to msg file
HRROI B,WINDOW
MOVE A,0(P) ; Mail file JFN
SOUT
JRST MLLUP1 ; Loop for more
; Mail in mailbox or unsent mailbox
MAIL03:
IFN REL4,<SKIPE TENEX
JRST MAIL3A ; Don't do this if on TENEX
HRROI B,FHSTNM ; Foreign host name
MOVE C,FHSTN ; Foreign host number
MOVX A,.GTHNS ; Get string from number
GTHST
SETZM FHSTNM ; If fail, no name
HRROI B,FHSTNM
MOVE A,(P) ; Get file JFN
HRLI A,.SFLWR ; Last writer string
SFUST ; Set it
ERJMP .+1 ; If fails
> ; End of Release 4 conditional
MAIL3A:
POP P,A ; Close & delete temp file
CLOSF
JFCL
JFCL
; CALL MLSTAT ; Record mail statistics
TXO F,F.NALO ; No autologout, now. May be MAILER.
HRROI X,MAILM2 ; Mail done.
TXNE F,F.MLFL ; Or was it MLFL
HRROI X,MAILM3 ; Yes.
JRST MAIL05
MAILM3: ASCIZS (252,226,< Mail completed successfully.>) ; For MLFL
MAILM2: ASCIZS (256,250,< Mail completed successfully.>) ; For MAIL
SUBTTL Subroutines - MLSTAT
; CALL MLSTAT Record mail statistics if appropriate
; in PS:<MAIL2>,PS:<SYSTEM> MAIL.BLOG
; Page 1,2,3 Word(FHSTN) is # messages recieved
; Page 4,5,6 Word(Local DIR #) is # messages for directory
; Page 7 Word(1/2 hrs since midnight) is # messages
; Word(777) is CPU time used
; Page 10 Word(1/2 hrs since midnight) is # characters
MLSTAT: SKIPE DBUGSW ; Return if debugging
RET
SKIPLE A,FHSTN ; Cannot use internet ID
CAIL A,<^D3*512> ; 3 512. word pages
RET
HRROI A,GTJSTR
HRROI B,T20.DV ; TOPS-20
SKIPE TENEX ; Structure
HRROI B,TNX.DV ; TENEX
SETZ C,
SOUT
MOVEI B,"<"
BOUT
HRROI B,TXX.M2 ; See if MAIL2 directory exists
CALL DIRCHK
SKIPA B,[TXX.SY] ; No, use SYSTEM
MOVE B,[TXX.M2] ; Yes, use MAIL2
HRRO B,B ; Build pointer
; SETZ C,
SOUT
MOVEI B,">"
BOUT
HRROI B,TXX.ML ; Mail log file name
SOUT
SETO B, ; Calculate version number for
MOVX D,<IC%DSA+<0*IC%ADS>+IC%UTZ+FLD(0,IC%TMZ)>
ODCNV ; Statistics file based on GMT date
MOVE A,C ; Save day of week in RH, and
HRL A,D ; GMT seconds since midnight in LH
MOVEM A,MLTIMT ; In a time temp cell
HRRZ A,B ; Month
AOS A
IMULI A,^D100
HLRZ B,B ; Year
IDIVI B,^D100
ADD A,C ; Version=MMYY
SUBTTL Subroutines - MLSTAT, cont.
TXO A,GJ%SHT ; Shortc form GTJFN
HRROI B,GTJSTR ; File name for mail log file
GTJFN
RET ; Can't, give up
MOVEM A,LOGJFN ; Save JFN
MOVX B,<OF%RD+OF%WR+OF%THW> ; Read,Write,Thawed
OPENF
JRST MLSTA2 ; Can't, give up
HRL A,LOGJFN ; Map page 1 of statistics file
HRRI A,1
MOVX B,<.FHSLF,,<WINDOW/1000>>
MOVX C,<PM%RD+PM%WR> ;Read/Write
PMAP
MOVE A,FHSTN ; Increment # of msgs received
ANDI A,1777 ; Beware internet, etc address
AOS WINDOW(A) ; From this host
SETO A, ; Unmap page
SETZ C, ; No count
PMAP
HRL A,LOGJFN ; Map page 3 of file
HRRI A,3
MOVX C,<PM%RD+PM%WR> ;Read/Write
PMAP
MOVE A,LCLJFN ; Get # of chars in message
SIZEF ; =Length of local file
SETZ B, ; Shouldn't fail
PUSH P,B ; Save the size
MOVE A,FHSTN ; Add to # of chars received
ANDI A,1777 ; Beware internet, etc address
ADDM B,WINDOW(A) ; From this host
SETO A, ; Unmap page
MOVX B,<.FHSLF,,<WINDOW/1000>>
SETZ C, ; No count
PMAP
HRL A,LOGJFN ; Map page 4 of file
HRRI A,4
MOVX C,<PM%RD+PM%WR> ;Read/Write
PMAP
HRRZ C,MLDIR ; Directory number of user receiving mail
IDIVI C,^D36 ; Calculate word and bit
MOVX A,1B0 ; Corresponding to user #
MOVNS D
ROT A,(D)
IORM A,WINDOW+200(C) ; Turn on bit for that user
SETO A, ; Unmap page
SETZ C, ; No count
PMAP
SUBTTL Subroutines - MLSTAT, cont.
HRL A,LOGJFN ; Now the time-histogram pages
HRRI A,10 ; Page 10 is chars by time of day
MOVX C,<PM%RD+PM%WR> ; Read and write access
PMAP
HLRZ A,MLTIMT ; Get the time within day
IDIVI A,^D<60*30> ; The half-hour within the day
HRRZ D,MLTIMT ; The day in the week (Monday = 0)
IMULI D,^D48 ; Skip n days of half-hours
ADD D,A ; And add in today's half-hours
POP P,A ; Get back length of msg
ADDM A,WINDOW(D) ; Record it
SETO A, ; Unmap page
MOVX B,<.FHSLF,,<WINDOW/1000>>
SETZ C, ; No count
PMAP
HRL A,LOGJFN ; Now count msgs by time of day
HRRI A,7 ; In this page
MOVX C,<PM%RD+PM%WR> ; Read and write access
PMAP
AOS WINDOW(D) ; Count a msg
MOVX A,.FHSLF ; Now get run time of this fork
RUNTM
;CWL NOT INITIALIZED??
SUB A,IFRKTM ; Since started
SUB A,MALCPU ; Less any possible previous msg
ADDM A,MALCPU ; Update for this msg
ADDM A,WINDOW+777 ; Count it in total, last WD this PG
SETO A, ; Unmap page
MOVX B,<.FHSLF,,<WINDOW/1000>>
SETZ C, ; No count
PMAP
MLSTA2: CLOSR LOGJFN ; Close statistics file
RET
SUBTTL Forward Mail
; If mailbox is busy or cannot be opened, forward mail
MLFWQ: MOVX A,<GJ%OLD+GJ%SHT> ; Get JFN of forwarder
HRROI B,T20.MF ; TOPS-20
SKIPE TENEX ; Mailbox program
HRROI B,TNX.MF ; TENEX
GTJFN
JRST MFWDX1 ; Not there. ;CWL BETTER MESSAGE?
; No forwarder instead of no mailbox?
PUSH P,A ; Save JFN
CALL TIMEOK ; Update kill time
MOVX A,CR%CAP ; Create an inferior fork
CFORK
JRST [MOVX A,^D2000 ; Failed get fork, wait 2 sec & try again
DISMS
MOVX A,CR%CAP
CFORK
SKIPA ; Failed again
JRST .+1 ; Got fork, go back
POP P,A ; No fork. Release MAILBOX.EXE JFN
RLJFN
JFCL
JSP X,MAIL05 ; MAILX3:
ASCIZS (453,451,< No forks available; Please try later.>)]
PUSH P,A ; Save fork handle
;STACKED FORK HANDLE & JFN
HRL A,0(P) ; Get prog into fork
HRR A,-1(P) ; JFN
GET
; Access page of program
HRLZ A,0(P) ; Page 0 of inferior
MOVX B,<.FHSLF,,BLTPAG> ; Mapped from this fork
MOVX C,<PM%RD+PM%WR> ; Rd, Wrt access
PMAP
; Pass arguments to it
MOVX T1,<-10,,0> ; Copy name (10 is pgm paramater)
MOVE A,MLUNST(T1) ; Commanded addressee
MOVEM A,BLTADR+140(T1) ; To inferior
AOBJN T1,.-2
MOVE A,0(P) ; Fork handle again
MOVEI B,[1]-1 ; Set AC1 to 1 for local site
SFACS
CALL TIMEOK ; Update kill time
MOVX B,2 ; Entry vector offset for running as fork
SFRKV ; Start up inferior
WFORK
CALL TIMEOK ; Update kill time
RFSTS ; See if it finished ok
HLRZ A,A
CAIE A,.RFHLT ; HALTF?
JRST MFWDX3 ; No
MOVE A,0(P) ; Handle again
MOVX B,ACTACS ; Account fork AC blk is free here
RFACS ; Get answer
SKIPG ACTACS+1 ; Success answer?
JRST MFWDX3 ; No
MOVX A,<POINT 7,LHSTNM> ; Prevent loops.
MOVX B,<POINT 7,BLTADR+150> ; By checking for local host
MOVX C,50
MLFWQ2: ILDB T1,A ; Check user's host name from program
ILDB T2,B
CAME T1,T2
JRST MLFWQ3 ; User not at this host; punt
JUMPE T1,MLFWQ1 ; If matched thru end, check name
SOJG C,MLFWQ2 ; Look til end or mismatch
JRST MFWDX3 ; Wierd failure.
MLFWQ1: MOVX A,<POINT 7,MLUNST> ; See if user name matches too
MOVX B,<POINT 7,BLTADR+140>
MOVX C,50
MLFWQ4: ILDB T1,A
ILDB T2,B
CAME T1,T2
JRST MLFWQ3 ; Bad user name
JUMPE T1,MFWDX3
SOJG C,MLFWQ4
JRST MFWDX3
MLFWQ3: HRROI A,MLFWST ; Copy over for a new file
HRROI B,T20.UM ; TOPS-20
SKIPE TENEX ; Unsent mail file name
HRROI B,TNX.UM ; TENEX
SETZ C, ; Mailer standard name
SOUT
HRROI B,BLTADR+140
SOUT
HRROI B,TXX.MA ; Separate NAME@HOST
SOUT
HRROI B,BLTADR+150
SOUT
HRROI B,T20.NV ; TOPS-20
SKIPE TENEX ; New version of file
HRROI B,TNX.NV ; TENEX
SOUT
HRROI B,TXX.AC ; Account
SOUT
MOVX B,C.NUL
BOUT
HRROI A,STRTMP ; Build reply
HRROI B,[ASCIZS (951,151,< Mail will be forwarded to >)]
SOUT ; Tell user
HRROI B,BLTADR+140
SOUT ; Give addressee
HRROI B,[ASCIZ / at /]
SOUT
HRROI B,BLTADR+150
SOUT
HRROI B,CRLFM ; End of line
SOUT
MOVX B,C.NUL ; Be safe
BOUT
MOVX A,.PRIOU ; Now send it all
HRROI B,STRTMP
SOUT
TXO F,F.MFWD ; Flag for later processing
POP P,A ; Fork handle of forwarder
KFORK
MOVE A,0(P) ; And MAILBOX.EXE JFN
HRLI A,(CO%NRJ) ; Why keep if RLJFN??
CLOSF
JFCL
POP P,A
RLJFN
JFCL
CALL TIMEOK ; Update kill time
JRST MAIL0A ; Now get the mail
MFWDX3: POP P,A ; Fork
KFORK
MOVE A,0(P)
HRLI A,(CO%NRJ) ; Why keep if RLJFN??
CLOSF
JFCL
POP P,A ; JFN for MAILBOX.EXE
RLJFN
JFCL
MFWDX1: JRST MAILX4
REPEAT 0,< ; This would create a mailbox if
; data base said there should be one
MLFWMX: HRROI B,GTJSTR ; Mailbox string
MOVX A,GJ%SHT ; Short ( so be sure to create)
GTJFN
JRST MAILX4 ; Can't, give up
MOVX B,OF%RD!OF%WR ; Open it up ;CWL PROTECTION?
OPENF
JRST MAILX4 ; Failed
HRLI A,.FBCTL ; Ctl word
MOVX B,FB%PRM+FB%DEL ; Change deleted, permenant bits
MOVX C,FB%PRM ; To be off & on respectivly
CHFDB ; Set them
HRRZS A
CLOSF ; Close the file
JFCL
JRST MAIL01 ; And go get mail
> ; END REPEAT 0
MAILX4: JSP X,MAIL05
ASCIZS (450,504,< No such mailbox at this site.>)
MAILX9: HRROI A,ERRSTR
HRROI B,[ASCIZS (455,451,< >)]
SETZ C,
SOUT
HRLOI B,.FHSLF
ERSTR
SETZM ERRSTR ; If no msg, zero first byte
SETZM ERRSTR
HRROI B,[ASCIZ /, PC=/]
SOUT
HRRZ B,E ; Get PC
MOVX C,OCTRAD ; Octal
NOUT
JFCL
HRROI X,ERRSTR
; JRST MAIL05 ; Fall into MAIL05
; HRROI X,[ASCIZ /.../] JSP X,MAIL05
; JRST MAIL05 ASCIZ /.../
MAIL05: CALL DELTMP ; Flush temp file if exists
CLOSR LCLJFN
CLOSD DATCON
HRROI B,(X) ; Reply to correct AC
JRST RPCRLP ; Back to top level
; CLOSE AND DELETE LCLJFN
DELTMP: SKIPG A,LCLJFN ; Get out the temp file.
RET ; No file
HRLI A,(CO%NRJ) ; Keep JFN for expunge
CLOSF
JFCL
MOVX A,DF%EXP ; Expunge it too
HRR A,LCLJFN ; Get JFN
IFN REL4,<SKIPE TENEX> ; On TENEX don't set bit
HRRZS A ; So clear left half
DELF
JFCL
RET
;MAILM9:ASCIZS (453,451,< Scratch file failure.>)
SUBTTL Subroutines - OPN8NC
;Subr used by MLFL (and FORMERLY XLPTF) to open ascii data connection.
; CALL OPN8NC Open 8-bit ASCII data connection
;Ret+1: Bad parameters
;Ret+2: Open failure
;REt+3: Opened ok
OPN8NC: SKIPG $STRU ; Arguments for simple ASCII xfer?
SKIPLE $MODE
RET ; Params bad
SKIPN A,$BYTE ; Byte size 8?
MOVX A,^D8 ; Or unspecified?
SKIPG $TYPE ; And ASCII type?
CAIE A,^D8
RET ; No.
AOS 0(P) ; At least one skip after here
IFN TCPF,< ; TCP version of open
MOVEI A,T.CDB+DATCON ; Connection descriptor block
MOVE B,FTPDAT ; Local data port number
MOVEM B,.TCPLP(A)
MOVE C,LHOSTN ; Must use address by which we
MOVEM C,.TCPLH(A) ; were initially contacted
MOVE B,FHSTN
MOVEM B,.TCPFH(A)
MOVE B,FORNS
MOVEM B,.TCPFP(A)
MOVEI A,DATCON ; File block
MOVX B,<-T.NDBF,,DATBUF>; Number and location of data buffers
MOVX C,<TCP%WT!TCP%FS!T.BFSZ> ; Size of buffers
$GTJFN ; W/ initiate connection & wait
RET ; Failed
MOVEM A,DATCON ; "JFN"
MOVEI A,DATCON ; File block
MOVX B,<FLD(^D8,OF%BSZ)> ; 8-bit connection
TXNE F,F.SEND ; Send or receive?
TXOA B,OF%WR ; Send
TXO B,OF%RD ; Receive
$OPENF
RET ; Failed
> ; End of IFN TCPF conditional
IFE TCPF,< ; Version for NCP
HRROI A,GTJSTR ; Build name for data connection
HRROI B,[ASCIZ /NET:2./]
SETZ C,
SOUT
MOVE B,FHSTN ; Foreign host number
MOVX C,OCTRAD ; Octal
NOUT
JFCL
MOVX B,"-"
BOUT
MOVE B,FORNS ; Foreign socket of TELNET conn
TRO B,1 ; His socket is a sender
ADDI B,2 ; And two above the TELNET
NOUT
JFCL
HRROI B,[ASCIZ /;T/] ; Mine is job relative
SOUT
MOVX B,C.NUL
BOUT
MOVX A,GJ%SHT ; Now get a JFN
HRROI B,GTJSTR ; For this connection
GTJFN
RET ; Can't?
MOVEM A,DATCON ; Ok
MOVE B,GJINF3 ; My job number
ADDI B,^D100000 ; Construct socket number
LSH B,^D15
ADDI B,2
HRROI A,[ASCIZ /255 SOCK /] ; Socket reply
PSOUT
MOVX A,.PRIOU
MOVX C,DECRAD ; Tell him in net virtual radix (10.)
NOUT
JFCL
HRROI A,CRLFM ; End line
PSOUT
MOVE A,DATCON ; Now try to open the connection
MOVX B,<FLD(8,OF%BSZ)+FLD(^D20,OF%MOD)+OF%RD>
OPENF ; Type of connection to open
RET ; Can't?
> ; End of IFE TCPF conditional
AOS 0(P) ; Ok, skip return
RET
SUBTTL Command Execution Routines - XSEM, XSEN
REPEAT 0,< ; How get here??
;XSEN COMMAND HANDLING
ZXSEM: TXOA F,F.XSEM ; Flag if its an XSEM
ZXSEN: TXZ F,F.XSEM ; Its an XSEN
TXNE F,F.LOGI ; Don't accept mail if logged in.
SKIPE DBUGSW ; If debug ok to be logged in
TRNA
JRST ORDERX
;Get argument (name to send to) and check it
PUSHJ P,SST ; Push SBP to start of name
SKIPN TENEX
JRST XSEN0
MOVEI A,1 ; Exact match
MOVE B,SBP ; Check it out
STDIR
JRST MAILX4 ; No such user
JRST MAILX4 ; Ambiguous, just as bad
HRRZM A,MLUSR ; He exists! Save number
JRST XSEN1
XSEN0: MOVSI A,(RC%EMO)
MOVE B,SBP
RCUSR ; Check him/her/it out
TLNE A,(RC%NOM!RC%AMB) ; Non-exist or ambiguus?
JRST MAILX4 ; Yes, bad.
MOVEM C,MLUSR ; Save user number
; But is he online?
XSEN1: PUSHJ P,ONLINE ; Check it out
JUMPE A,XSENX7 ; If not online jump...
PUSHJ P,TTYACP ; Online, see if accepting links
JRST XSENX8
; Online, collect message
HRROI B,[ASCIZ /350 User online, send message ended by a line with only a "."
/]
PUSHJ P,SDUMPA ; Invite data
PUSHJ P,MSGBEG ; Set up buffer
PUSHJ P,MSGCOL ; And get message
JRST MAILX5 ; Oops, message to long
; Text collection done, try to put stuff into SENDS.TXT
; but dont die if can't
SETZM MLERRC ; Clear error indicator
MOVE A,SBP ; Get BP to name, happens to be dirctory
PUSHJ P,WRTSND
MOVEM A,MLERRC ; If error save code
; Check online TTY#'s again just before sending
PUSHJ P,ONLINE ; List of TTY's in A
JUMPE A,XSENX7 ; Oops he sneaked off
MOVEI D,ONLNTB
HLL D,A
; Now send message
SETZ T1, ; Clr cnt of wins
XSEN4: MOVEI A,400000
ADD A,(D) ; Get terminal designator
RFMOD ; Get mode word
TRNN B,1000 ; Links allowed?
JRST XSEN5 ; Nope, must be refusing
PUSHJ P,TIMEOK
DOBE ; Wait until we can send to him
SKIPN TENEX ; Don't bother with next on TOPS-20
JRST XSEND0
RFCOC ; Get control output word
MOVEM B,.TEMP1# ; Save first word and
MOVEM C,.TEMP# ; Save 2nd word of it
TLO B,14 ; Set bing ^G
TRO C,1400 ; Set to indicate EOL's
SFCOC
XSEND0: MOVE T2,[POINT 7,MSGBUF] ; Can send, get pointer to buffer
MOVEI C,$MBFLN
SUB C,MSGCNT ; And number ofal CHARACTERS
XSEND: ILDB B,T2 ; Get a char
BOUT ; Sendl IT
SOJG C,XSEND ; If more go back
SKIPN TENEX ; Again skip stuff if TOPS-20
JRST XSEND2
RFCOC
MOVE B,.TEMP1 ; Restore old control chr words
MOVE C,.TEMP
SFCOC
XSEND2: AOS T1 ; Add to times sent
XSEN5: AOBJN D,XSEN4
JUMPLE T1,XSENX9 ; Jump if didn't send any
; Message sent succesfully, one last check
SKIPE A,MLERRC ; Error in writing SENDS.TXT?
CAIE A,600130 ; Was it because file busy?
JRST XSEN9 ; If not or no error return now
; Try a little more to write to SENDS.TXT
MOVEI X,5 ; Number of times to try
XSEN7: MOVE A,SBP ; Luser name
PUSHJ P,WRTSND ; Try again
JRST [ CAIE A,600130
JRST .+1 ; Leave loop if strange error
SOJLE X,.+1 ; Or if tryed enough
MOVEI A,^D2000 ; Wait 2 sec each time
DISMS
JRST XSEN7]
; Return reply indicating success
XSEN9: JSP B,RPCRLP
ASCIZ /256 Message sent successfully./
XSENX7: HRROI B,[ASCIZ /User not online./]
JRST XSENXR
XSENX8: HRROI B,[ASCIZ /User refusing links./]
JRST XSENXR
XSENX9: JSP B,RPCRLP
ASCIZ /453 Message not sent-- user went away./
XSENXR: TXNE F,F.XSEM ; Try to mail it?
JRST XSENXM ; Yes
PUSH P,B ; No save ptr to string
HRROI B,[ASCIZ /453 /] ; Send error prefix
PUSHJ P,SDUMPA
POP P,B
JRST RPCRLP ; Send string and back to command level
; Here to fake MAIL for XSEM
XSENXM: PUSH P,B ; Save string
HRROI B,[ASCIZ/009 /] ; Prefix with info code
PUSHJ P,SDUMPA
POP P,B ; Then reason for mailing
PUSHJ P,SDUMPA
HRROI B,[ASCIZ / Will mail message.
/]
PUSHJ P,SDUMPA ; End with above
TXZ F,F.MLFL ; Tell mail it's coming over TELNET
JRST MAILJ ; And join mail code
; Random auxiliaries for XSEN
;ONLINE - takes dir # in MLUSR, returns in A an AOBJN
;pointer to list of TTY's logged in under that directory
ONLINE: SETZM ONLNPT ; Clear ptr to TTY's found
SKIPE TENEX ; Use different routine if TENEX
JRST ONLIN3
MOVSI D,-^D200 ; Setup pointer for jobs to look at
ONLIN0: MOVEI A,(D) ; Job number
MOVE B,[-2,,T1] ; Where to stick
MOVEI C,.JITNO ; Start with TTY#
GETJI
ERJMP ONLIN2 ; No job there
CAME T2,MLUSR ; Same guy?
JRST ONLIN2 ; Nope
JUMPL T1,ONLIN2 ; Detached..
SKIPN B,ONLNPT ; Get AOBJN ptr to TTY table
JRST [MOVEI B,ONLNTB ; If first time must fix up
MOVEM B,ONLNPT
JRST ONLIN1]
CAME T1,(B)
AOBJN B,.-1
JUMPL B,ONLIN2 ; Jump if TTY already in table
ONLIN1: MOVEM T1,(B) ; Not in table, store
MOVSI A,-1
ADDM A,ONLNPT ; Add to AOBJN count
CAIL B,ONLNTB+$OLNTL ; If stuck this in lat slot
JRST ONLIN6 ; Time to return
ONLIN2: AOBJN D,ONLIN0 ; Search all jobs
JRST ONLIN6 ; And return
; Here is TENEX stuff
ONLIN3: MOVE 1,[SIXBIT /JOBDIR/] ; Job table
SYSGT ; Get number, size
HLLZ D,B ; AOBJN pointer to job number
HRRZ T1,B ; Table number
ONLIN4: HRL A,D ; Index
HRR A,T1 ; Table number
GETAB
JFCL
HRRZ A,A
CAMN A,MLUSR ; Same guy?
PUSHJ P,GTTTY ; Yes, get his TTY#
AOBJN D,ONLIN4 ; Go back for more
ONLIN6: SKIPL A,ONLNPT ; Return AOBJN ptr
SETZ A, ; Or zero
POPJ P,
GTTTY: SKIPN B,ONLNPT ; If first time init things
JRST [ MOVE A,[SIXBIT /JOBTTY/]
SYSGT
HRRZM B,TABNM1# ; Save table number
MOVEI B,ONLNTB
MOVEM B,ONLNPT
JRST GTTTY2]
GTTTY2: HRL A,D
HRR A,TABNM1
GETAB
JFCL
HLRE A,A
JUMPL A,GTTTY6 ; If detached return
MOVEM A,(B) ; Store TTY in table
MOVSI A,-1
ADDI A,1
ADDM A,ONLNPT ; Add to AOBJN count
GTTTY6: POPJ P, ; Go back for more jobs
;TTYACP - Takes AOBJN ptr to TTY list in A,
;Skips if at least one is accepting links. Fails
;if none are accepting links. Doesn't clobber A
TTYACP: PUSH P,A
MOVE D,A
TTYAC4: MOVEI A,400000
ADD A,(D) ; Get terminal descriptor
RFMOD ; Get mode word
TRNE B,1000 ; See if accepting
AOSA -1(P) ; Yes, skip out and do a skip return
AOBJN D,TTYAC4 ; If not check some more
POP P,A
POPJ P,
;MSGBEG - Set up initial string in message buffer
MSGBEG: MOVE A,[440700,,MSGBUF]
HRROI B,[ASCIZ /
TTY message from net site /]
SETZ C,
SOUT
CALL HSTOUT
SETZ C,
HRROI B,[ASCIZ /
/]
SOUT ; Output a CRLF
MOVEM A,MSGBPT ; Store updated BP into buffer
HRROI B,MSGBUF
CALL PTRDIF ; Get BP pointer difference into C
SUBI C,$MBFLN ; Get -# chars left as count
MOVMM C,MSGCNT ; Store # of chars left as count.
MOVEI A,1
MOVEM A,MSGLNS ; Start count of number of lines
RET
; MSGCOL- Collects message text over command connections
;gobbles into core until usual "." line seen
MSGCL0: AOS MSGLNS ; Increment line cnt
CALL TIMEOK
MSGCOL: CALL GETLIN
RET ; If ran out of room non-skip return
CAIE C,2 ; "." check requires line length 2 exactly
JRST MSGCL0 ; Nope, get another line
ILDB D,B ; Get single char
CAIE D,"." ; Check
JRST MSGCL0 ; Nope, keep going
ADDM C,MSGCNT ; End! Take last line off count
AOS MSGCNT ; Plus extra LF
MOVEM B,MSGBPT ; And move BP back
AOS (P) ; And skip for win return
RET
;GETLIN - gobbles line from primary input into MSGBUF, updating
;MSGCNT and MSGBPT. Returns count of characters in line
;(including terminating CRLF) in C, turns CRLF's into EOL's
;if on TENEX, byte pointer to beginnning of line in B
;normally skips; will fail if buffer overflows
GETLIN: MOVE C,MSGCNT ; Get count and BP for hacking
MOVE BP,MSGBPT
GETLN2: CALL TELBIN
JRST HANGUP ; He went away
IDPB B,BP
SOJLE C,GETLN7 ; Jump if no more room
CAIE B,12 ; If end of line
JRST GETLN2 ; Nope, keep going
GETLN4: EXCH C,MSGCNT ; Store count, get old
SUB C,MSGCNT ; Find number of chars in line
MOVEI B,15 ; Get CR
DPB B,BP ; Overwrite LF
MOVEI B,12 ; LF
IDPB B,BP ; And stick it on
SOS MSGCNT ; Subtract extra character
EXCH BP,MSGBPT
MOVE B,BP ; Return BP in B to BOL
AOS (P)
RET
GETLN7: MOVEM BP,MSGBPT ; Buffer overflowed
SETZM MSGCNT
RET
;PTRDIF - Takes BP's in A and B, Leaves difference (# chars)
;in C. think of as A-B replaces C
;wont work for indexed/indirect pointers
PTRDIF: PUSH P,A
PUSH P,B
TLNE A,7077
HRLI A,440700
TLNE B,7077
HRLI B,440700
MULI B,5
ADD C,PTRD7P(B)
MULI A,5
ADD B,PTRD7P(A)
SUBM B,C
POP P,B
POP P,A
RET
133500,,0
BLOCK 4
PTRD7P: -54300,,5
-104300,,4
-134300,,3
-164300,,2
-214300,,1
;WRTSND - write out message buffer. A hold BP to directory name
;skips if succesfull. Error return gives err code in A
WRTSND: MOVE D,A
HRROI A,GTJSTR ; Cons up filename into this string
HRROI B,[ASCIZ /</]
SKIPN TENEX
HRROI B,[ASCIZ /PS:</]
SETZ C,
SOUT
MOVE B,D
SOUT
HRROI B,[ASCIZ />SENDS.TXT;0;T/]
SKIPN TENEX
HRROI B,[ASCIZ />SENDS.TXT.0;T/]
SOUT
SETZ B,
BOUT
;;; Have file name to find (or create), get JFN
MOVX A,GJ%SHT
HRROI B,GTJSTR
GTJFN
RET
MOVE D,A ; Save JFN
MOVX B,7B5+OF%APP ; Open for append
OPENF
JRST [ EXCH A,D ; Failed.. perhaps simultaneous access
RLJFN
JFCL ; For now just return
MOVE A,D ; Return err code
RET]
;;; Hey ! Got it open
MOVEI A,(D)
HRROI B,MSGBUF
MOVEI C,$MBFLN
SUB C,MSGCNT
SOUT
CLOSF
JFCL
AOS (P)
RET ; Skip return
;;; Output hostname to JFN in A
HSTOUT: MOVE B,A
MOVEI A,.GTHNS
MOVE C,FHSTN
GTHST
JFCL
MOVE A,B
RET
>
SUBTTL Password when logged in may be for CWD
.ORG ;BACK TO HIGH SEGMENT
; Here on PASS Command when already logged in. See if it goes with a CWD.
PASCWD: MOVE A,PRVKWD ; See what previous command keyword was
CAME A,['XCWD ']
CAMN A,['CWD '] ; Either form of CWD?
SKIPA ; Yes
JRST [JSP B,PASCW4 ; No. What's with this silly PASS?
ASCIZS (504,503,< You are already logged in. I don't know what this password is for.>)]
GJINF ; It follows CWD. See if already
CAMN B,$CWD ; Connected to the desired directory.
JRST [JSP B,PASCW4 ; Yes, ignore password.
ASCIZ /250 Password not needed for this CWD./]
; No, go do it.
IFN REL4,<SKIPN TENEX ; TENEX?
JRST CWDCHK ; Nope
> ; End of IFN REL4
HRRZ A,$CWD ; Desired Directory
MOVX B,<POINT 7,$PASS> ; Password
CNDIR ; Do the connect
JRST PASCW3 ; Failed
JRST CWDOK
CWDCHK: ;TOPS-20
MOVEI B,$ACCES ; Get address of argument block
MOVE A,$CWD ; Desired directory
MOVEM A,.ACDIR(B) ; Put in argument block
MOVX A,<POINT 7,$PASS> ; Password
MOVEM A,.ACPSW(B) ; Put in argument block
SETOM .ACJOB(B) ; This job
MOVX A,<AC%CON+3> ; Three word argument block
ACCES ; Connect to directory
ERJMP PASCW3 ; Failed
CWDOK:
CALL ADDREP ; CWD command joins here
ASCIZS (200,250,< Connected to >)
MOVE B,$CWD ; Plug name into message
DIRST
MOVE A,REPLYP ; Can't fail here, I hope.
MOVEM A,REPLYP ; Update pointer
JSP B,PASCW4 ; Ok
ASCIZ /./
PASCW3: JSP B,PASCW4 ; ACCES failed
ASCIZS (431,530,< CWD-PASS: Directory or Password wrong.>)
PASCW4: CALL CLRPSW ; Clear secret info (preserve B)
JRST RPCRLP
SUBTTL Post-Login Command Execution Routines - DEBUG
ZDEBUG: MOVX A,.FHSLF ; See if I am a WHEEL
RPCAP
TXNN B,<SC%WHL> ; Was also SC%OPR
JRST NOTIMP ; No. Pretend not implemented
DEBUG1: SKIPE 770000 ; Yes. Is DDT there?
JRST DEBUG0 ; Yes, go to it.
MOVX A,GJ%SHT+GJ%OLD ; No, get it
HRROI B,T20.UE ; TOPS-20
SKIPE TENEX ; UDDT filespec
HRROI B,TNX.US ; TENEX
GTJFN
JRST NOTIMP
HRLI A,.FHSLF ; Into this fork
GET
MOVE A,116 ; JOBSYM
MOVEM A,@770001 ; to $I-1
DEBUG0: MOVX A,<.FHSLF,,<HSBAS/1000>> ; Now put on copy/write bit in access
; So DDT can do breakpoints
DEBUGL: RPACS ; See if page there
TXNN B,PA%PEX
JRST DEBUGN ; No
MOVX B,<PA%RD+PA%WR+PA%EX> ; Assume private. R,W,E
TXNN B,PA%PRV ; If shared, put on CW
MOVX B,<PA%RD+PA%EX+PA%CPY> ; Make it R,E,CW
SPACS
DEBUGN: ADDI A,1 ; Next page
HRRI B,(A)
CAIGE B,700 ; Continue up to DDT
JRST DEBUGL
CALL 770000 ; Call DDT
DRETN: JSP B,RPCRLP
ASCIZS (200,200,< End of debug.>)
SUBTTL Post-Login Command Execution Routines - ALLOcate
; Allocate command - not really necessary on TOPS20
IFN TCPP,<
ZALLO: JSP B,RPCRLP
ASCIZ /202 Allocations are not requred at this site./
> ; End of INF TCPP
SUBTTL Post-Login Command Execution Routines - RESTart
; Restart Command
ZREST: JSP B,RPCRLP ; Restart command not implemented
ASCIZS (200,502,< Restart command received but ignored.>)
SUBTTL Post-Login Command Execution Routines - SMNT
ZSMNT: HRROI B,[ASCIZS (200,202,< SMNT is not required at this site>)]
SKIPE TENEX ; Only TOPS20 needs this
JRST RPCRLP
CALL SST ; Down to the argument
MOVE B,SBP ; Just collect string
MOVX A,<POINT 7,$PTHS1> ; Where to stash it
MOVNI C,<5*40>-2 ; Length
SOUT
MOVX A,<1,,.MSIMC> ; Imcrement mount count
MOVEI B,D ; Argument block
MOVX D,<POINT 7,$PTHS1> ; Structure name
MSTR
ERJMP SMNTX0
SMNTX: JSP B,RPCRLP ; Send this back
ASCIZS (200,202,< Structure mounted.>)
SMNTX0: MOVX A,<.FHSLF> ; Get error code
GETER
HRRZS B
CAIN B,MSTX31 ; Already mounted?
JRST SMNTX ; Yes, don't return error
CALL ADDREP
ASCIZS (451,550,< Failed to mount structure: >)
MOVX B,<.FHSLF,,-1>
ERSTR
JFCL
JFCL
MOVEM A,REPLYP
JSP B,RPCRLP
ASCIZ /./
SUBTTL Post-Login Command Execution Routines - CWD
ZXCWD: ; Change working directory
ZCWD: CALL SST ; Down to the argument
MOVE B,SBP ; Pointer to argument
CALL DIRCHK ; See if valid directory name
JRST XCWD1 ; No
MOVEM B,$CWD ; Save in case password follows
HRROI A,USERST ; To (garbage) string for user name
DIRST
JRST XCWD1 ; Cant fail
MOVX A,.FHSLF ; Get current caps
RPCAP
PUSH P,B ; Save them
PUSH P,C
SETO C, ; Enable for the CNDIR
EPCAP
MOVE A,$CWD ; See if can do a CNDIR to it
SETZ B, ; Without a password
SKIPN TENEX
JRST CWD6 ; TOPS-20
CNDIR ; TENEX
JRST XCWD2 ; No.
JRST CWD8 ; Jump around TOPS-20 stuff
; TOPS-20
CWD6: MOVEM A,$ACCES ; Put in arg block
MOVEM B,$ACCES+1 ; Without password
MOVX A,<AC%CON+3> ; Connect to directory
MOVEI B,$ACCES ; Get address of block
ACCES ; Connect
ERJMP XCWD2 ; No
CWD8:
POP P,C ; Yes, restore caps
POP P,B
MOVX A,.FHSLF
EPCAP
JRST CWDOK ; Go send success message
SUBTTL Post-Login Command Execution Routines - CWD, cont.
; Connect W/o password failed, ask for it
XCWD2: POP P,C ; Acces failed.
POP P,B
MOVX A,.FHSLF
EPCAP
JSP B,RPCRLP ; Say just prefix accepted.
ASCIZS (200,331,< Default name accepted. Send password to connect to it.>)
; Bad Directory Name (TOPS-20 structure ACCESS?)
XCWD1: JSP B,RPCRLP
ASCIZS (431,501,< No such directory - CWD.>)
SUBTTL Post-Login Command Execution Routines - SOCK/PORT
IFE TCPP,< ; NCP [HOST,] SOCK
ZSOCK: SETOM $HOST ; Default host
CALL DECIN ; Decimal number argument
JRST SOCKX1 ; Syntax error
CAIE C,"," ; Host number?
JRST SOCK01 ; No.
TXNE A,<740000,,0> ; Legal host?
JRST [JSP B,SOCKXX ; SOCKX2:
ASCIZS (503,501,< Host number exceeds 32 bits.>)]
MOVEM A,$HOST ; Yes. Save it.
CALL DECIN ; And get socket number
JRST SOCKX1 ; Has to be one. Default not allowed.
SOCK01: CAIE C,0 ; End of line now?
JRST SOCKX1 ; No. Error.
TLNE A,740000 ; Legal number?
JRST [JSP B,SOCKXX ; SOCKX3: Bad socket number (over 2**32)
ASCIZS (<503 Socket>,<501 Port>,< number out of range.>)]
> ; End of IFE TCPP
IFN TCPP,< ; TCP PORT H1,H2,H3,H4,P1,P2
P$SOCK: POINT 16,$SOCK,15 ; Leftmost 16 bits
ZPORT: MOVSI T2,-6 ; 4 bytes of $HOST & 2 of $SOCK
MOVE T1,[POINT 8,$HOST,3] ; Rightmost 32 bits
SETZM $HOST
; Check break characters?
SOCK02: CALL DECIN ; Get next byte
JRST SOCKX1
SKIPL A
CAILE A,377
JRST SOCKX1 ; Must be 0 to 377
IDPB A,T1 ; Save it
AOBJN T2,SOCK02 ; Get rest
SKIPG $HOST
SETOM $HOST
; Verify CR/EOL?
LDB A,P$SOCK ; Get 16 bits
> ; End of IFN TCPP
MOVEM A,$SOCK ; Save sock/port #
CLOSD DATCON ; Make sure data connection is closed
JSP B,RPCRLP ; And return to command loop
SOCKM1: ASCIZS (<200 Socket>,<200 Port>,< command accepted.>)
SUBTTL Post-Login Command Execution Routines - SOCK/PORT, cont.
SOCKX1: HRROI B,[ASCIZS (501,501,< Syntax error in >,SOCK,PORT,< command.>)] ; EOL not at right place
; Fall into SOCKXX
; HRROI B,[ASCIZ /.../]
; JRST SOCKXX JSP B,SOCKXX
; ASCIZ /.../
SOCKXX: SETOM $SOCK ; Clear to defaults
SETOM $HOST
JRST RPCRLP ; Reply
SUBTTL Post-Login Command Execution Routines - PASV
; Choose a port number, enter passive mode & listen for a connection
ZPASV: CLOSD DATCON ; Make sure connections are closed
TXO F,F.PASV ; Entering passive mode
CALL PREDAT ; To listen
JRST NURPLY ; B/ has pointer to msg; F.PASV cleared
CALL PRE255 ; Reply with pseudo PORT command.
JSP B,RPCRLP
0 ;ASCIZ //
SUBTTL Post-Login Command Execution Routines - DELE
ZDELE: HRROI A,JFNTXS ; Copy argument for file name
MOVE B,SBP
SETZ C,
SOUT
IDPB C,B ; End string
CALL JBKINI ; Set up for delete file request
; Set A/JBLOCK, B/SBP
MOVX C,<GJ%OLD+.GJLEG> ; Old file required
MOVEM C,.GJGEN(A)
GTJFN
JRST [JSP B,DELXX ; No such file
ASCIZS (450,550,< DELE: No such>)]
MOVEM A,LCLJFN
LDB C,B ; Make sure got to EOL
JUMPN C,[JSP B,DELXX ; No. Bad syntax.
ASCIZS (550,501,< DELE: Bad name syntax (not confirmed) in>)]
CALL JFNTXT ; Store text string for this filename
DVCHR ; See what the device is
LOAD D,DV$TYP ; Get device type
CAIE D,.DVDSK ; Disk?
JRST [JSP B,DELXX ; No. Error.
ASCIZS (506,504,< DELE: Only implemented for DISK files, not>)]
HRRZ A,LCLJFN ; JFN
DELF ; Do the delete
JRST [JSP B,DELXX ; Can't. Assume access rights bad
ASCIZS (451,550,< DELE: You do not have access rights to delete>)]
SETOM LCLJFN ; JFN released by DELF JSYS
DELEOK: MOVEI A,JBLOCK ; Try to get next lowest
MOVE B,SBP ; Name string
GTJFN
JRST [JSP B,DELXX
ASCIZS (254,250,< File deleted ok,>)]
; Message used to be "only copy" but
; that could be wrong if user typed an
; explicit version (generation) number
RLJFN
JFCL
HRROI B,[ASCIZS (254,250,< Lowest generation deleted ok,>)]
DELXX: CLOSR LCLJFN
MOVE A,REPLYP
TLO B,-1
SETZ C,
SOUT ; Part of message to reply buffer
SKIPN JFNTXS ; A file name?
JRST DELXX1 ; No
HRROI B,[ASCIZ / file /]
SOUT
HRROI B,JFNTXS
SOUT ; Yes, tack on filename
DELXX1: MOVEM A,REPLYP
JSP B,RPCRLP ; Return a message
ASCIZ /./
SUBTTL Post-Login Command Execution Routines - RNFR/RNTO
ZRNFR: MOVE B,SBP ; Rename from. Just collect string
MOVX A,<POINT 7,$PTHS1> ; Where to stash it
MOVNI C,<5*40>-2 ; Length
SOUT
JSP B,RPCRLP ; Send this back
ASCIZS (200,350,< Rename-from name stored.>)
ZRNTO: SKIPN $PTHS1 ; Have old name from some previous RNFR?
JRST [JSP B,RPCRLP ; No, error
ASCIZS (431,503,< Please send old file name (RNFR) before new.>)]
SETOM $PATH1 ; No JFN's here yet
SETOM $PATH2
CALL JBKINI ; Set A/JBLOCK, B/SBP
MOVX C,<GJ%FOU+GJ%NEW> ; Output new file only
MOVEM C,.GJGEN(A)
GTJFN ; See if the file is there
JRST RNMX1 ; Can't get "to" JFN
MOVEM A,$PATH2
CALL JBKINI ; Ok. Try the from JFN
; Set A/JBLOCK, B/SBP
MOVX C,<GJ%OLD> ; Old file only
MOVEM C,.GJGEN(A)
HRROI B,$PTHS1 ; Stored from RNFR command
GTJFN
JRST [PUSH P,A ; Save error code
CALL ADDREP ; Start reply
ASCIZS (450,550,< Cannot access old-named file: >)
JRST RNMXE]
MOVEM A,$PATH1 ; Store JFN
MOVE B,$PATH2 ; Ok, get new name
RNAMF ; Do the rename
JRST [PUSH P,A ; Save error code
CALL ADDREP ; Start reply
ASCIZS (455,550,< Rename failed: >)
JRST RNMXE]
SETOM $PATH1 ; Good. This JFN now gone.
MOVE A,$PATH2
CALL JFNTXT
CALL ADDREP ; Build fancy reply
ASCIZS (253,250,< Old file renamed >)
HRROI B,JFNTXS ; New file name
SETZ C,
SOUT
JRST RNMXU
SUBTTL Post-Login Command Execution Routines - RNFR/RNTO, cont.
; GTJFN of new name failed, error code in A
RNMX1: PUSH P,A ; Save error code
CAIE A,GJFX20 ; Errors for file exists already
CAIN A,GJFX27
JRST RNMX2
CALL ADDREP
ASCIZS (455,450,< Can't get JFN for New file name: >)
JRST RNMXE
RNMX2: CALL ADDREP
ASCIZS (456,503,< "New Name" already exists. Delete it first: >)
JRST RNMXE
;RNMX2: PUSH P,A
; CALL ADDREP
; ASCIZS (451,550,< No access rights to create new file: >)
; JRST RNMXE
;RNMX4: PUSH P,A
; CALL ADDREP
; ASCIZS (451,550,< No access rights to delete old filename: >)
; JRST RNMXE
RNMXE: POP P,B ; Error code
HRLI B,.FHSLF
ERSTR ; Append system error code
JFCL
JFCL
RNMXU: MOVEM A,REPLYP ; Save end of message so far
CLOSR $PATH1 ; Clean up JFNs
CLOSR $PATH2
JSP B,RPCRLP
ASCIZ /./
SUBTTL Post-Login Command Execution Routines - STAT
; Outer level sets up for TELNET connection, then calls DOLIST
;STAT - TELNET Connection, TYPE A or E
;During file xfer, <CR> - State of transfer
;Between Transfers
; <CR> - Status including current transfer parameters
; <DIR> - File names w/o dir, all generations (one line)
; <FILE> - File info
; 211,212,213,504,530,550
.ORG ;BACK TO LOW SEGMENT
ZSTAT: TXO F,F.STAT ; Tell DOLIST it's a STAT
TXZ F,F.NLST ; Similar to LIST
MOVX A,.PRIOU ; Data goes to primary output
CALL DOLIST ; Do the work
JRST GETCOM ; Done.
.ORG ;BACK TO HIGH SEGMENT
SUBTTL Post-Login Command Execution Routines - LIST/NLST
; Outer level sets up for data connection, then calls DOLIST
;LIST - Data Connection <CR> - Connected Directory
; TYPE A or E <DIR> - File names w/o dir, all generations (one line)
; <FILE> - File Info
;NLST - Data Connection <CR> - Connected Directory
; TYPE A or E <DIR> - File names w/ dir, top generation
; 150-226, 504
ZLIST: TXZA F,F.NLST ; LIST, not NLST
ZNLST: TXO F,F.NLST ; NLST, not LIST.
SKIPGE A,$BYTE
MOVX A,^D8
MOVEM A,$BYTE
CAIN A,^D8 ; Must be 8-bit
SKIPLE $TYPE ; ASCII
JRST LISTX1 ; Lose
SKIPG $MODE ; Better be an ASCII connection
SKIPLE $STRU
JRST LISTX1 ; Lose
TXZ F,F.STAT ; Tell DOLIST it's a LIST, not STAT.
TXO F,F.SEND ; Set up a send connection
SETOM F$DTIP ; Data transfer in progress
CALL PREDAT ; ..
JRST RPCRLP ; No good.
MOVX A,.PRIOU
HRROI B,[ASCIZS (250,150,< List started.
>)]
SETZ C,
SOUT ; Send msg and dump buffer to SJFN
MOVE A,DATCON ; Where DOLIST should send answers
CALL DOLIST
CLOSD DATCON ; Done with the data connection
SETZM F$DTIP ; Data transfer no longer in progress
HRROI B,[ASCIZS (252,226,< Transfer completed.>)] ; & data closed
JRST RPCRLP
LISTX1: JSP B,RPCRLP
ASCIZS (506,504,< Parameters for LIST command must be STRU F, MODE S, TYPE A.>)
SUBTTL Post-Login Command Execution Routines - RETR
;Retrieve Command. File from server to user
; 150-<226,250,451>, 425, 501, 504, 550
ZRETR: TXZ F,F.TYPX!F.FDB!F.ERR ; Assume not paged mode, and error
TXZ F,F.DSK!F.NUL ; Clear a couple flags
TXO F,F.SEND ; This is a send connection of data
SKIPG B,$BYTE ; Any declared byte size?
MOVX B,^D8 ; No. Set it to default eight-bit
MOVEM B,$BYTE
SKIPLE $MODE ; See if default stream mode.
JRST RETX0 ; No.
MOVE C,$TYPE ; Get type
IFE TCPP,<CAIE C,TYPE.XTP> ; Is it paged?
IFN TCPP,<MOVE D,$STRU ; See if paged structure
CAIE D,STRU.P> ; Is it paged?
JRST RETR01 ; No, will filter later
; Paged Stru/Type
IFN TCPP,<CAIE C,TYPE.I ; Allow TYPE I
CAIN C,TYPE.L ; TYPE L 36 and
> ; End of IFN TCPP
CAIE B,^D36 ; 36 bits and paged?
JRST RETX0 ; No. Error
TXO F,F.TYPX ; It is 36-bit paged mode. Remember in flag.
IFN TCPP,<JRST RETR02> ; Already know STRU ok
RETR01: SKIPLE $STRU ; Structure must be default file
JRST RETX0
RETR02: CALL TIMEOK ; Update timeout
SETZM TYXSCT ; Clear net sequence count for page mode
CALL JBKINI ; Initilize GTJFN block
; Set A/JBLOCK, B/SBP
MOVX C,GJ%OLD ; Existing file for reading
MOVEM C,.GJGEN(A) ; No default version
GTJFN ; Open the local file
JRST RETX1
MOVEM A,LCLJFN ; Save it
LDB C,B ; Was terminator the end of line?
JUMPN C,RETX2 ; If not, complain
CALL JFNTXT ; Stash file name in txt storage
SUBTTL Post-Login Command Execution Routines - RETR, cont.
MOVE A,LCLJFN ; Ok. See what type device it is on
DVCHR
LOAD D,DV$TYP
CAIN D,.DVDSK ; Disk?
TXO F,F.DSK ; Yes, Local disk file.
CAIN D,.DVNUL ; Is it the NUL:?
TXO F,F.NUL ; Yes, Flag to phony up a NUL:
HRROI X,[ASCIZS (457,504,< Paged transfer must be on DSK: or NUL:.>)]
TXNN F,F.TYPX ; Paged mode?
JRST RET02B ; No.
TXNN F,F.NUL!F.DSK ; DSK: or NUL:?
JRST DATABE ; RETXPX: No.
RET02B:
TXNE F,F.NUL ; Nul:?
JRST RET02 ; Yes, Bypass OPENF
MOVX A,^D36 ; Common byte size
MOVE P1,$TYPE ; Get type
CAIE P1,TYPE.I ; Image type?
TXNE F,F.TYPX ; Or Paged?
JRST RETOPN ; Yes, All set
MOVX A,^D7
CAIN P1,TYPE.A ; Ascii?
JRST RETOPN ; Yes
MOVE A,$BYTE ; Get the connection byte size
CAIN P1,TYPE.L ; Local byte?
JRST RETOPN ; Yes
JRST RETX4 ; No. Unknown type. (impossible)
REPEAT 0,<
MOVE D,$BYTE ; Get the byte size
CAIE D,^D36 ; Only support image 36 bits now.
TXNE F,F.DSK ; Except ok on disk ;CWL 8 32
SKIPA
JRST RETX4 ; Say not supported, if not 36-bits.
HRROI B,SLOWM1 ; But give the guy a comment
MOVX A,.PRIOU
SETZ C,
CAIE D,^D36 ; That it will be slow if 8 or 32
SOUT ; Dump on TELNET send
MOVX A,^D36
>
SUBTTL Post-Login Command Execution Routines - RETR, cont.
RETOPN: MOVEM A,$LBYTE ; Local file byte size ($BYTE unless ASCII)
MOVX B,OF%RD ; Build OPENF parameter
STOR A,OF$BSZ,+B
RETOPO: MOVE A,LCLJFN ; Get local JFN back
PUSH P,B ; Save open flags.
OPENF
JRST [POP P,B
TXON B,OF%THW ; Try it thawed
JRST RETOPO
JRST RETX5] ; Already did. Fail.
POP P,B ; Clear stack
RET02: ; Enter here if NUL:
CALL SETCLSD ; Setup F.CLSD
SETOM F$DTIP ; Data transfer in progress
CALL PREDAT ; Set up the data connection
JRST RPCRLP ; Can't. Return reason.
MOVE A,REPLYP ; Send started msg
HRROI B,[ASCIZS (250,150,< Retrieve of >)]
SKIPL D,$TYPE ; Or more specific message.
CAIN D,TYPE.A ; ASCII type?
HRROI B,[ASCIZS (250,150,< ASCII retrieve of >)]
CAIN D,TYPE.I
HRROI B,[ASCIZS (250,150,< IMAGE retrieve of >)]
TXNE F,F.TYPX
HRROI B,[ASCIZS (250,150,< Paged retrieve of >)]
SETZ C,
SOUT
HRRZ B,LCLJFN ; File name
MOVX C,<..DEVD+..DIRA+..NAMA+..TYPA+..GENA+JS%TMP+JS%PAF> ; Format
JFNS
HRROI B,[ASCIZ / started.
/]
SETZ C,
SOUT
HRROI A,REPLYM ; Send it
PSOUT
MOVE A,PREPLY ; And prepare for next one
MOVEM A,REPLYP
SETZM REPLYM
CALL XFRDAT ; Transfer file
CLOSR LCLJFN ; Close these files if open
SETZM F$DTIP ; Data transfer no longer in progress
HRROI B,0(X) ; Pointer to reply message
JRST RPCRLP ; Reply
SUBTTL Post-Login Command Execution Routines - APPE/STOR
; Store and Append commands. File from remote to server.
; (111) 150-<226,250,451>, 425, 501, 504, 550
ZAPPE: TXOA F,F.APPE ; Append. Much like STOR.
ZSTOR: TXZ F,F.APPE ; Not append
TXZ F,F.DSK+F.NUL+F.SEND ; Assume not DSK: or NUL:, not send
TXZ F,F.RLPT+F.TYPX+F.FDB!F.ERR ; Assume not to spooled LPT,
SETZM F$KPGN ; not paged mode, and error
SETZM TYXSCT ; But if it is, start at seq zero
MOVX B,PGT$AP ; Data page with access control
MOVEM B,RECTYP ; In case EOF comes in immediately.
SETZM IBITCT ; Image bit count is 0
SKIPLE A,$MODE ; Stream mode?
JRST STOX0 ; No. Unsupported.
MOVE B,$STRU
MOVE C,$TYPE ; Get type
SKIPG D,$BYTE ; Byte still at default?
MOVX D,^D10 ; Yes. Set to real size
MOVEM D,$BYTE
IFE TCPP,<CAIE C,TYPE.XTP> ; Is it paged?
IFN TCPP,<CAIE B,STRU.P> ; Is it paged?
JRST STO00 ; No
; Paged
IFN TCPP,<CAIE C,TYPE.I ; Allow TYPE I or
CAIN C,TYPE.L ; TYPE L 36 and
> ; End of IFN TCPP
CAIE D,^D36 ; Paged and 36 bit bytes?
JRST STOX0 ; No. Bad.
TXNE F,F.APPE ; Yes. STOR, I hope.
JRST STOX0 ; No. Can't append in page mode
TXO F,F.TYPX ; Ok. Flag page mode
SETOM F$KPGN ; Allow rename to retain generation #
IFN TCPP,<JRST STO02> ; Already know STRU ok
STO00: SKIPLE $STRU ; Only file structured so far.
JRST STOX0
STO02: CALL TIMEOK ; Update timeout.
CALL JBKINI ; Set up the default strings in GTJFN blk
; Set A/JBLOCK, B/SBP
MOVX C,GJ%FOU+GJ%FLG ; Output use bit and request flags bit
TXNE F,F.APPE ; Unless append, whence
MOVX C,GJ%FLG ; Use current version if any.
TXNE F,F.ANON ; If ANONYMOUS, no new files at all.
MOVX C,GJ%OLD+GJ%FLG ; So don't default to new version
MOVEM C,.GJGEN(A)
GTJFN ; Get it.
JRST STOX1 ; Can't
HRRZM A,LCLJFN ; Store the JFN
TXNN A,GJ%NHV ; Want higher generation #?
SETZM F$KPGN ; No, don't rename
SUBTTL Post-Login Command Execution Routines - APPE/STOR, cont.
SKIPE JBLOCK+.GJACT ; Was there an account?
JRST STO01 ; Yes. Main string pointer not needed.
;CWL WHAT GOES HERE??
STO01: LDB C,B ; Get the terminator
JUMPN C,STOX2 ; Jump if not EOL
MOVE A,LCLJFN ; Ok. Name was good.
CALL JFNTXT ; Store the text string for file name
MOVE A,LCLJFN
DVCHR ; See what device it's on.
LOAD A,DV$TYP ; Get device type
CAIN A,.DVDSK ; Disk
TXO F,F.DSK ; Yes.
CAIN A,.DVNUL ; NUL device?
TXO F,F.NUL ; Yes
HRROI X,[ASCIZS (457,504,< Paged transfer must be on DSK: or NUL:.>)]
TXNN F,F.TYPX ; Paged mode?
JRST STO02B ; No.
TXNN F,F.NUL!F.DSK ; Disk or NUL?
JRST DATABE ; RETXPX: No.
STO02B:
CAIE A,.DVLPT ; LPT:?
JRST STO03 ; No
; Check if spooled line printer??
STOLPT: TXNE F,F.ANON ; ANONYMOUS login?
JRST [JSP X,DATABE ; STOX8: Let's not have ANONYMOUS listings
ASCIZS (450,504,< Anonymous users may not write on LPT:.>)]
MOVX A,^D7 ; Spooled byte size
MOVE B,$BYTE ; For now, only allow ASCII 8-bit.
; This should be fixed, though.
CAIN B,^D8 ; Eight bit conn?
SKIPLE P1,$TYPE ; And ASCII?
JRST .+2 ; No.
JRST STOOPN ; Yes.
JSP X,DATABE ; Error.
ASCIZS (503,504,< Transfers to LPT: must be ASCII, 8-bit connections.>)
SUBTTL Post-Login Command Execution Routines - APPE/STOR, cont.
STO03: MOVX A,^D36 ; Common byte size
MOVE P1,$TYPE ; Get type
CAIE P1,TYPE.I ; Image type?
TXNE F,F.TYPX ; Or Paged?
JRST STOOPN ; Yes, All set
MOVX A,^D7
CAIN P1,TYPE.A ; Ascii?
JRST STOOPN ; Yes
MOVE A,$BYTE ; Get the connection byte size
CAIN P1,TYPE.L ; Local byte?
JRST STOOPN ; Yes
JRST STOX4 ; No. Unknown type. (impossible)
REPEAT 0,<
IFE TCPF,<
HRROI B,SLOWM1 ; But complain about it.
MOVX A,.PRIOU
SETZ C,
CAIE D,^D36 ; If not 36 bit mode
SOUT ; Send down TELNET conn
> ; End of IFE TCPF
> ; End of REPEAT 0
STOOPN: MOVEM A,$LBYTE ; Local file byte size ($BYTE unless ASCII)
MOVX B,OF%WR ; Build OPENF parameter - Writeing
TXNE F,F.APPE ; or
TXO B,OF%APP ; Appending
STOR A,OF$BSZ,+B
MOVE A,LCLJFN ; Restore the JFN
OPENF ; Open according to stuff in B
JRST STOX5 ; Can't.
CALL SETCLSD ; Setup F.CLSD
SETOM F$DTIP ; Data transfer in progress
CALL PREDAT ; Set up common params,
JRST RPCRLP ; No good. Msg in B.
SUBTTL Post-Login Command Execution Routines - APPE/STOR, cont.
MOVE A,REPLYP ; Send started msg
HRROI B,[ASCIZS (250,150)]
SKIPL D,$TYPE ; Or more specific message.
CAIN D,TYPE.A ; ASCII type?
HRROI B,[ASCIZS (250,150,< ASCII>)]
CAIN D,TYPE.I
HRROI B,[ASCIZS (250,150,< IMAGE>)]
TXNE F,F.TYPX
HRROI B,[ASCIZS (250,150,< Paged>)]
SETZ C,
SOUT
HRROI B,[ASCIZ / Store of /]
TXNE F,F.APPE ; Or append msg
HRROI B,[ASCIZ / Append to /]
SOUT
HRRZ B,LCLJFN ; File name
MOVX C,<..DEVD+..DIRA+..NAMA+..TYPA+..GENA+..PROA+..ACTA+JS%TMP+JS%PAF> ; Format
JFNS
HRROI B,[ASCIZ / started.
/]
SETZ C,
SOUT
HRROI A,REPLYM ; Send it
PSOUT
MOVE A,PREPLY ; And prepare for next one
MOVEM A,REPLYP
SETZM REPLYM
CALL XFRDAT ; Transfer file
TXNN F,F.ERR ; Have a local error?
JRST STO08 ; No, seems ok
CLOSK (LCLJFN)
HRRZ A,LCLJFN ; File to be deleted
TXO A,<DF%EXP>
DELF ; Delete and expunge file
JFCL
SETOM LCLJFN ; Gone
STO08:
SKIPA
DATABE: TXO F,F.ERR ; Have error (Interrupt break-out address)
IFN TCPP,<TXNN F,F.ERR ; Close if error or
TXNE F,F.CLSD ; EOF requires it
CAIA ; Have to close
JRST STO09> ; Leave open - paged & ok
CLOSD (DATCON,CO%WCL) ; Wait for other end to see close
STO09:
;DATABT:
CLOSR LCLJFN ; Close these files if open
SETZM F$DTIP ; Data transfer no longer in progress
HRROI B,0(X) ; Pointer to reply message
JRST RPCRLP ; Reply
SUBTTL File Transfer Errors
RETX0: STOX0: ; Neither LCLJFN nor DATCON
RETX4: STOX4: ; LCLJFN
JSP X,DATABE ; Paged & not 36, unknown type, mode, stru
ASCIZS (457,504,< Parameter combination illegal or unimplemented.>)
RETX1: ; GTJFN failed
RETX5: JSP X,ERRMSG ; OPEN filed
ASCIZS (450,550,< File not accessable. >)
RETX2: STOX2: ; LCLJFN - bad terminator - Syntax
JSP X,DATABE
ASCIZS (550,501,< Bad terminator after file name.>)
RETX3: STOX3:
JSP X,DATABE ; Access denied message
ASCIZS (451,550,< You do not have access for that file operation.>)
STOX1: ; GTJFN failed
STOX5: JSP X,DATABE ; OPEN failed
ASCIZS (450,550,< Can't write such a file.>)
STOX6: JSP X,DATABE ; No account specified
ASCIZS (433,532,< Account must be supplied to store files. Send ACCT.>)
SLOWM1: ASCIZS (<050 >,<111->,<Image mode requires 36-bit bytes for efficiency.
>,050,111,< Use TYPE L instead if possible. Proceeding...
>)
ERRMSG: CALL ERRSUB
JSP X,DATABE
0
ERRSUB: HRROI A,(X)
PSOUT ; Output message
MOVX A,.PRIOU ; Output the error message
MOVX B,<.FHSLF,,-1> ; Last error for this process
SETZ C,
ERSTR
JFCL
JFCL
RET
SUBTTL Subroutines - PREDAT
; Subroutine called by commands which need the data connection.
; Prepares the data socket, sends the 255 socket reply, and
; then opens the connection.
; Skip return if ok, else non-skip with error msg in B.
; Arguments are F.SEND (for direction) and the socket/host/byte params
; Ok or 425
PREDAT: SKIPGE A,DATCON ; Connection already there?
JRST PRED2A ; No.
$GTSTS ; Yes. Is it the right kind?
TXNN B,GS%OPN ; Open?
JRST PRED2 ; No. Flush.
IFN TCPP,<
JRST PRED2I ; Go set byte size, etc
> ; End of IFN TCPP
IFE TCPP,<
TXNE F,F.SEND ; Yes. Right direction?
TXNN B,GS%WRF ; Sending and open for write?
JRST PRED1A ; No
CALL PRE255 ; Yes. Send socket reply,
JRST PRED3 ; And use it again
PRED1A: TXNN F,F.SEND ; Receiving?
TXNN B,GS%RDF ; And open for read?
JRST PRED2 ; No
CALL PRE255 ; Send socket reply
JRST PRED3 ; And use it
> ; End of IFE TCPP
SUBTTL Subroutines - PREDAT, cont.
PRED2: $CLOSF ; Get rid of old connection
JFCL ; If can't, just get another JFN
PRED2A: SETOM DATCON ; No useful old connection
IFE TCPF,< ; Version for NCP
;NET:<LOCAL_SOCKET>.<$HOST(FHSTN)>-<$SOCK(FORNS+2 OR 3)>;T
MOVX A,<POINT 7,GTJSTR> ; Pointer to build a new socket name
HRROI B,[ASCIZ /NET:/]
SETZ C,
SOUT ; Start it.
; 2 is old FTP
MOVX B,2 ; Local socket is 2 or 3, job relative.
TXNE F,F.SEND ; Write connection?
ADDI B,1 ; Yes, make it odd
MOVX C,OCTRAD ; Octal number in NCP
NOUT
CALL BOMB
MOVX B,"." ; Separate from distant field
IDPB B,A
SKIPGE B,$HOST ; Foreign host specified?
MOVE B,FHSTN ; No, default is where TELNET is from
MOVX C,OCTRAD
NOUT
CALL BOMB
MOVX B,"-" ; Flag for socket
IDPB B,A
SKIPGE B,$SOCK ; Foreign socket specified?
JRST [MOVE B,FORNS ; No, get TELNET conn socket
ADDI B,2 ; Plus 2 to receive
TXNN F,F.SEND ; Or is he sending?
ADDI B,1 ; Yes. Make his odd number
JRST .+1]
MOVX C,OCTRAD ; Socket in octal
NOUT
CALL BOMB
HRROI B,[ASCIZ /;T/] ; Job-local socket
SETZ C,
SOUT
CALL TIMEOK ; Update timer clock
SUBTTL Subroutines - PREDAT, cont.
MOVX A,GJ%SHT ; Now try to get the socket
HRROI B,GTJSTR
GTJFN
JRST PREDX1 ; Can't?
MOVEM A,DATCON ; Ok, save the JFN
;CWL TENEX?
CVSKT ; Now get the socket number (absolute)
JRST PREDX2 ; Can't?
TXNN F,F.SEND ; Make sure sex bit is right
TRZA B,1
TRO B,1 ; Sending
MOVEM B,MYDATS ; Save it
CALL PRE255 ; Now send the 255 reply
CALL TIMEOK ; Update timer
MOVX B,<FLD(^D20,OF%MOD)+OF%WR> ; Write, buffered send
TXNN F,F.SEND ; See which way to point it
MOVX B,OF%RD ; Read.
SKIPG A,$BYTE ; Get byte size
MOVX A,10 ; Default is 8-bit
STOR A,OF$BSZ,+B
MOVE A,DATCON ; Now do the connect
OPENF
JRST PREDX2 ; Can't
PRED3: AOS 0(P) ; Success return from PREDAT
RET
PREDX2: MOVE A,DATCON ; Couldn't open or CVSKT
; CLOSF ; Be sure closed
; JFCL ; Don't care if fails
RLJFN ; Free the JFN
JFCL
JRST PREDX1 ; Error exit
> ; End of IFE TCPF conditional
SUBTTL Subroutines - PREDAT, cont.
IFN TCPF,< ; Opend TCP data connection
MOVEI A,T.CDB+DATCON ; Connection descriptor block
MOVE B,GJINF3 ; Our job # is
LSH B,^D8 ; High byte of port
TXNN F,F.PASV ; If PASV
SETZ B, ; Otherwise high byte is 0
ADD B,FTPDAT ; Low byte is Data socket number
MOVEM B,.TCPLP(A) ; To CDB
MOVE C,LHOSTN ; Must use address by which we
MOVEM C,.TCPLH(A) ; were initially contacted
SKIPGE B,$HOST ; Specific host given?
MOVE B,FHSTN ; No, use TELNET host
SKIPG C,$SOCK ; Specific port specified
MOVE C,FORNS ; No, use same as TELNET
TXNE F,F.PASV ; However if PASV then
SETZB B,C ; Wild foreign Host/Port
MOVEM B,.TCPFH(A)
MOVEM C,.TCPFP(A)
MOVEI A,DATCON ; File block
MOVX B,<-T.NDBF,,DATBUF>
MOVX C,T.BFSZ
TXNN F,F.PASV ; If passive, don't wait or force sync
TXO C,<TCP%WT!TCP%FS>
$GTJFN
JRST PREDX1 ; Failed
MOVEM A,DATCON ; Initialized
TXNE F,F.PASV ; Passive?
JRST PRED3 ; Passive open - need F.SEND for $OPENF
PRED2I: SKIPG A,DATCON ; Should contain DATCON here
JRST PREDX0 ; ??
SKIPG C,$BYTE
MOVX C,^D8
MOVEM C,$BYTE
SETZ B,
STOR C,OF$BSZ,+B ; For open
TXNE F,F.SEND ; Sending?
TXOA B,OF%WR ; Yes
TXO B,OF%RD ; No, reading
$OPENF
JRST PREDX0 ; Failed
PRED3: AOS 0(P) ; Success return from PREDAT
RET
> ; End of IFN TCPF conditional
SUBTTL Subroutines - PREDAT, cont.
PREDX0: CLOSD DATCON
PREDX1: TXZ F,F.PASV ; Not in PASV mode either
HRROI A,STRTMP ; Build error msg here
HRROI B,[ASCIZS (454,425,< Data connection failed: >)]
SETZ C,
SOUT
HRLOI B,.FHSLF
SETZ C,
ERSTR
JFCL
JFCL
HRROI B,STRTMP ; Point to msg
RET ; Fail return
SUBTTL Subroutines - PRE255
; CALL PRE255
PRE255: MOVE A,PREPLY ; Build reply
HRROI B,[ASCIZS (<255 SOCK >,<227 Entering Passive mode, use PORT >)]
SETZ C,
SOUT ; Send server socket reply in specified
MOVX C,DECRAD ; Network virtual radix
IFE TCPP,<
MOVE B,MYDATS
NOUT
CALL BOMB
HRROI B,CRLFM
SETZ C,
SOUT
SETZ B,
BOUT
HRROI A,REPLYM ; Output it all at once
PSOUT
>
SUBTTL Subroutines - PRE255, cont.
IFN TCPP,<
MOVX D,<POINT 8,LHOSTN,3> ; First 8 bits
MOVSI T1,-4 ; 4 bytes of host
PRE257: ILDB B,D
NOUT
CALL BOMB
MOVX B,","
BOUT
AOBJN T1,PRE257
MOVX D,<POINT 8,.TCPLP+T.CDB+DATCON,27> ; Two byte socket #
LDB B,D
NOUT
CALL BOMB
MOVX B,","
BOUT
ILDB B,D
NOUT
CALL BOMB
MOVEM A,REPLYP ; For whoever to finish
>
IFN TCPF,<
;CWL ???
JRST PRE25X
MOVEI X,^D120
PRE25L: MOVEI A,^D1000
DISMS
MOVE A,DATCON+T.JCN
;CWL *** TOPS20 & TENEX
; LOADI B,TSTAT ; Get TSTAT word
; HRRO B,B
; HRROI C,C
; STAT
; JRST PRE25X
; ANDI C,TRSYN!TSSYN ; Still synchable
; CAIN C,<FLD(4,TRSYN)+FLD(4,TSSYN)>
; SOJG X,PRE25L ; Yes, wait
PRE25X: > ; End of IFN TCPF conditional
RET
SUBTTL Subroutines - DOLIST
; DOLIST is the guts of LIST, NLST and STAT.
; 211, 212, 213, 504, 530, 550
.ORG ;BACK TO LOW SEGMENT
DOLIST: MOVEM A,LSTJFN ; Save the destination.
LDB B,SBP ; First character of argument
TXNE F,F.STAT ; Jump if not STAT
SKIPE B ; Or if STAT with non-null argument
JRST DOLI00
; STAT<RETURN>
HRROI A,$FILST ; Build string here
CALL LCLSTS ; Append info to string A/
SOUT
IDPB C,A ; End string
MOVE A,LSTJFN ; TELNET or data connection
HRROI B,$FILST ; Accumulated string
$SOUT ; Send it
IFE TCPP,< ; NCP ends this way
HRROI B,[ASCIZ /200 End of status.
/]
TXNE F,F.STAT ; On TELNET conn?
$SOUT ; Yes. Flag end.
> ; End of IFE TCPP
RET ; Return from DOLIST
SUBTTL DOLIST - Return directory/file info
DOLI00: TXNE F,F.LOGI ; Am I logged in?
JRST DOLI01 ; Yes, continue in high segment
JSP B,RPCRLP ; No good. Complain.
ASCIZS (451,530,< Please log in first, with USER, PASS and ACCT.>)
.ORG ;BACK TO HIGH SEGMENT
DOLI01: TXZ F,F.PDIR ; Clear flags: omit directory
TXZ F,F.T1!F.T2 ; Not need CR, more than generation changed
CALL JBKINI ; See if his string makes sense
; Set A/JBLOCK, B/SBP
HRROI T1,[ASCIZ /*/] ; Set up for defaults
MOVEM T1,.GJNAM(A)
MOVEM T1,.GJEXT(A) ; Name and ext
MOVX T1,<GJ%OLD+GJ%IFG+.GJDEF> ; Flags for wild, hi gen of old files
TXNN F,F.NLST ; Unless NLST command,
HRRI T1,.GJALL ; "Star" for version default
MOVEM T1,.GJGEN(A)
MOVE T1,A ; Save args
MOVE T2,B
GTJFN
JRST DOLIX1 ; No good
MOVEM A,LCLJFN ; Save it
TXNN A,GJ%DEV+GJ%UNT+GJ%DIR+GJ%NAM+GJ%EXT+GJ%VER ; Any wild cards?
JRST DOLINS ; No stars, single file
TXNE A,GJ%DEV+GJ%UNT+GJ%DIR ; Wild dev or dir?
JRST DOLIX3 ; Yes. Don't allow whole dumps.
; Stars don't necessairly mean multiple files...
MOVE A,LCLJFN
GNJFN ; More than one?
TXOA F,F.T1 ; No, only one (and lost JFN too)
RLJFN ; Get to common state - no JFN
JFCL
MOVE A,T1 ; Restore args
MOVE B,T2
GTJFN ; Get JFN back
JRST DOLIX1 ; No good
MOVEM A,LCLJFN ; Save it
TXZE F,F.T1 ; What was the result?
JRST DOLINS ; Only one found
SUBTTL Subroutines - DOLIST - Multiple files
TXNN F,F.NLST ; If LIST command, then
TXO F,F.PDIR ; Print directory name first time
DOLIL0: MOVX A,<POINT 7,STRTMP> ; Build line here
MOVEM A,T1 ; Beginning of string
MOVEM A,T2 ; Current end
TXZ F,F.T1 ; Need prefix (not appending a generation)
DOLIL1: CALL TIMEOK ; Update time kill.
MOVE A,T2 ; Append to this string
HRROI B,[ASCIZS (<151 >,<212->)] ; Header for TELNET connection
SETZ C,
TXON F,F.T1 ; Already started line?
TXNN F,F.STAT ; No. Need the header?
SKIPA ; Yes, don't need header again
SOUT ; New line and need header
MOVX B,"," ; Separating versions only?
TXNE F,F.T2
BOUT ; Yes.
HRRZ B,LCLJFN ; The file name to be listed
TXZN F,F.PDIR ; Want directory line?
JRST DOLI03 ; Not now
; Output a directory name line
MOVX C,<..DEVA+..DIRA+JS%PAF> ; TOPS-20
SKIPE TENEX
MOVX C,<..DIRA+JS%PAF> ; TENEX only dir name, punctuated
JFNS ; Append to string
HRROI B,CRLFM ; Force an end of line here.
SETZ C,
SOUT
MOVEM A,T1 ; Beginning of next line
MOVEM A,T2 ; Always have another line following
TXZ F,F.T1 ; And say not started this line
JRST DOLIL1 ; Back for first file name
SUBTTL Subroutines - DOLIST - Multiple files, append filespec
DOLI03: MOVX C,<..NAMA+..TYPA+..GENA+JS%TMP+JS%PAF>
TXZE F,F.T2 ; Just a new version?
MOVX C,<..GENA> ; Yes. Just print that.
TXNE F,F.NLST ; But if NLST, send different format.
MOVX C,<..DEVD+..DIRA+..NAMA+..TYPA+..GENA+JS%TMP+JS%PAF>
JFNS ; Append something.
MOVEM A,T2 ; Save string pointer
MOVE A,LCLJFN ; Step the handle
GNJFN
JRST DOLILZ ; No more. Go bash "-".
TXNE F,F.NLST ; NLIST command?
JRST DOLIN2 ; Yes. Always separate lines.
TXNN A,GN%DIR+GN%NAM+GN%EXT ; Just version change?
JRST DOLI02 ; Yes.
TXNE A,GN%DIR ; New directory?
TXO F,F.PDIR ; Yes. Want to mention it.
SKIPN TENEX
TXNN A,GN%STR ; New structure on TOPS-20?
SKIPA ; No
TXO F,F.PDIR ; Yes. Want to mention it.
DOLIN2: MOVE A,T2 ; String pointer
HRROI B,CRLFM ; End line.
SETZ C,
SOUT
MOVEM A,T2 ; Save pointer again
IDPB C,A ; End string
MOVE A,LSTJFN ; Output this file
HRROI B,STRTMP
$SOUT
JRST DOLIL0 ; Loop to next line & file.
; Only version changed, pointer is on top of stack
DOLI02: TXO F,F.T2 ; Ext is all that changes
JRST DOLIL1 ; Loop
; End of list, send last line
DOLILZ: MOVE A,T2
IFN TCPP,<ILDB B,T1 ; Skip 3 digits
ILDB B,T1
ILDB B,T1
MOVX B," "
TXNE F,F.STAT ; Only STAT has header
IDPB B,T1 ; Whose last line has a space
> ; End of IFN TCPP
JRST DOLIZ1 ; A/ points to end
SUBTTL Subroutines - DOLIST - Single file
DOLINS: MOVX A,<POINT 7,STRTMP> ; Build string here
HRROI B,[ASCIZS (150,213,< >)]
SETZ C,
TXNE F,F.STAT ; Cue needed?
SOUT ; Yes
MOVX C,<..DEVD+..DIRD+..NAMA+..TYPA+..GENA+..PROA+..ACTA+JS%TMP+JS%SIZ+JS%CDR+JS%LWR+JS%LRD+JS%PSD+JS%PAF> ; QFD format
TXNE F,F.STAT ; But if STAT, give full pathname
MOVX C,<..DEVA+..DIRA+..NAMA+..TYPA+..GENA+..PROA+..ACTA+JS%TMP+JS%SIZ+JS%CDR+JS%LWR+JS%LRD+JS%PSD+JS%PAF> ; QFD format
TXNE F,F.NLST ; But if NLST, send different format.
MOVX C,<..DEVD+..DIRD+..NAMA+..TYPA+..GENA+..PROA+..ACTA+JS%TMP+JS%PAF> ; Bits for format
HRRZ B,LCLJFN ; Get the file JFN
JFNS
TXNN F,F.STAT ; STAT?
JRST DOLIZ1 ; No
; Return creator/writer names with STAT
SKIPE TENEX ; TENEX?
JRST DOLINX ; Yes
; TOPS20 names via GFUST
MOVE D,A ; Save pointer to string
HRRZ A,LCLJFN
MOVX B,<OF%RD+OF%WR> ; ? Why do we need writing??
skipa; OPENF
JRST DOLINT
MOVE A,D
MOVX B,"," ; Append creator & last writer
BOUT
MOVE B,A ; String pointer
HRRZ A,LCLJFN ; File &
HRLI A,<.GFAUT> ; Function
GFUST
ERJMP DOLINT
MOVE D,B
MOVE A,B
MOVX B,","
BOUT
MOVE B,A
HRRZ A,LCLJFN
HRLI A,<.GFLWR>
GFUST
ERJMP DOLINT
MOVE A,B
JRST DOLIZ1
DOLINT: MOVE A,D
JRST DOLIZ1
; TENEX names via GTFDB/DIRST
DOLINX: PUSH P,A ; Save pointer
HRRZ A,LCLJFN
MOVE B,[1,,.FBUSE] ; LH is writer's number
MOVEI C,D
GTFDB
MOVX A,<.NULIO>
HLRZ B,D ; User number
DIRST
JRST DOLINZ
MOVE A,(P) ; String
MOVX B,"," ; Append creator & last writer
BOUT
HLRZ B,D ; User number
DIRST
JRST .+1
MOVX B,"," ; Append creator & last writer
BOUT
HLRZ B,D ; User number
DIRST
JRST .+1
MOVEM A,(P)
DOLINZ: POP P,A
; Common wrapup for last line
DOLIZ1: HRROI B,CRLFM ; Output EOL
SETZ C,
SOUT
IDPB C,A ; End string
CLOSR (LCLJFN) ; Release STAT JFN
MOVE A,LSTJFN ; TELNET or data connection
HRROI B,STRTMP ; Accumulated string
$SOUT ; Send it
IFE TCPP,< ; NCP ends this way
HRROI B,[ASCIZ /200 End of status.
/]
TXNE F,F.STAT ; On TELNET conn?
$SOUT ; Yes. Flag end.
> ; End of IFE TCPP
RET ; Return from DOLIST
SUBTTL Subroutines - DOLIST - Error Exits
; GTJFN error on user argument
DOLIX1: HRROI B,[ASCIZS (450,550,< >)] ; File status
HRROI D,[ASCIZ /? Not found.
/]
JRST DOLIXX
; Star for device or directory is illegal
DOLIX3: HRROI B,[ASCIZS (451,504,< >)]
HRROI D,[ASCIZ /? * not allowed for device or directory.
/]
DOLIXX: HRRZ A,LCLJFN ; Close JFN which has too many stars
RLJFN
JFCL
SETOM LCLJFN
MOVE A,LSTJFN
SETZ C,
TXNE F,F.STAT ; Header needed on TTY conn?
$SOUT ; Yes.
MOVE B,D
$SOUT
RET ; Error return from DOLIST
SUBTTL Subroutines - JBKINI, JFNTXT
; CALL JBKINI Initialize long-form GTJFN block
;SETS A/ JBLOCK Address of long form block for GTJFN
; B/ C(SBP) Frequent string to GTJFN
JBKINI: MOVEI A,JBLOCK ; Address of block
SETZM (A) ; Set up for long for GTJFN
MOVX B,<JBLOCK,,JBLOCK+1>
BLT B,EJBLOK ; Clear it first
MOVX B,<.NULIO,,.NULIO> ; No TTY I/O
MOVEM B,.GJSRC(A)
MOVE B,SBP ; Rest of user's argument
RET ; Return
; CALL JFNTXT
JFNTXT: PUSH P,A ; Preserve AC's
PUSH P,B
PUSH P,C
SETZM JFNTXS ; Clear text storage
MOVX A,<JFNTXS,,JFNTXS+1>
BLT A,EJFNTX
HRRZ B,-2(P) ; The JFN
HRROI A,JFNTXS ; Store string here
MOVX C,<..DEVD+..DIRA+..NAMA+..TYPA+..GENA+JS%PAF> ; Bits for format
JFNS
POP P,C
POP P,B
POP P,A
RET
SUBTTL Subroutine - SETCLSD
; CALL SETCLSD ; Sets F.CLSD if data connecion has to
; ; be closed to indicate EOF, Else cleared
SETCLS: TXO F,F.CLSD ; Assume close at EOF (NCP always closes)
IFN TCPP,< ; Have to close data connection for EOF?
SKIPGE A,$MODE2 ; Get current parameters
SETZ A, ; Default
SKIPGE B,$STRU2
SETZ B,
CAIE A,MODE.C ; Modes Compressed or
CAIN A,MODE.B ; Blocked
TXZ F,F.CLSD ; Don't have to
CAIN A,MODE.S ; Mode S and
CAIE B,STRU.P ; Structure P
SKIPA ; No
TXZ F,F.CLSD ; Yes, don't have to
> ; End of IFN TCPP
RET
; TXNN F,F.CLSD
; RET
.ORG ;BACK TO LOW SEGMENT
SUBTTL Routine to trap DEBRK failures
;#2 Called with pointer to asciz string, identifying routine, in A
DBKFA1: HRROI D,[ASCIZ / TIMINT or CTTINT
/]
JRST DBKFAI
DBKFA2: HRROI D,[ASCIZ / DETINT
/]
JRST DBKFAI
DBKFA3: HRROI D,[ASCIZ / QTAINT
/]
TRN
DBKFAI:
REPEAT 0,< ;Monitor bug causing need of this
; is believed gone.
MOVX A,GJ%SHT
HRROI B,[ASCIZ /<SYSTEM>FTP-FAIL.LOG/]
GTJFN
ERJMP DBKFAL
HRRZM A,FAIJFN
MOVX B,FLD(7,OF%BSZ)!OF%RD!OF%APP
OPENF
ERJMP [HRRZ A,FAIJFN
RLJFN
TRN
JRST DBKFAL]
GTAD ;#2 get identifying date
MOVE B,A
HRRZ A,FAIJFN
ODTIM
MOVE B,D
SETZ C,
SOUT
CLOSF
TRN
> ; End repeat 0
DBKFAL: GJINF ;#2 add detach of controlling terminal
CALL CLSTTY ;#2 detach it
JRST LOGOUT ;#2 and logout
SUBTTL