Trailing-Edge
-
PDP-10 Archives
-
SRI_NIC_PERM_SRC_3_19910112
-
mm-dom/maiser.mac
There are 3 other files named maiser.mac in the archive. Click here to see a list.
;[SRI-NIC]SRC:<MM-DOM>MAISER.MAC.43, 11-Apr-90 16:32:49, Edit by ZZZ
; in GETTCP - use GTHST% instead of TCOPR% to get our local host
; address for resolution. prevents failure when connection is on
; a port that's enabled but not in the host table.
; also conditionalized logging - set logsw nonzero to enable it.
;[SRI-NIC]SRC:<MM-DOM>MAISER.MAC.25, 9-Aug-89 17:52:22, Edit by MKL
; check for mail from ourselves
;[SRI-NIC]SRC:<MM-DOM>MAISER.MAC.21, 15-May-89 17:08:07, Edit by MKL
; reject routed mail (non-local deliveries) in .RCPT
;[SRI-NIC]SRC:<MM-DOM>MAISER.MAC.8, 15-May-89 00:16:08, Edit by MKL
; add logging code (if LOGNAM file exists)
;[SRI-NIC]SRC:<MM-DOM>MAISER.MAC.4, 25-Apr-88 13:02:14, Edit by MKL
; merge new domainized maiser with ours.
; cosmetic changes.
; use USER messages instead of SYSTEM messages bit (mtopr) for sends.
TITLE MAISER TOPS-20 SMTP mail server
SUBTTL Written by Mark Crispin - November 1982
; Copyright (C) 1982, 1983, 1984, 1985, 1986, 1987, 1988 Mark Crispin
; All rights reserved
; Version components
MLSWHO==0 ; who last edited MAISER (0=developers)
MLSVER==6 ; MAISER's release version (matches monitor's)
MLSMIN==1 ; MAISER's minor version
MLSEDT==^D162 ; MAISER's edit version
SEARCH MACSYM,MONSYM ; system definitions
SALL ; suppress macro expansions
.DIRECTIVE FLBLST ; sane listings for ASCIZ, etc.
.TEXT "/NOINITIAL" ; suppress loading of JOBDAT
.TEXT "MAISER/SAVE" ; save as MAISER.EXE
.TEXT "/SYMSEG:PSECT:CODE" ; put symbol table and patch area in CODE
.REQUIRE HSTNAM ; host name routines
.REQUIRE WAKEUP ; MMailr wakeup routine
.REQUIRE SYS:MACREL ; MACSYM support routines
IFNDEF OT%822,OT%822==:1
; MAISER is the server to receive electronic mail from other systems via
; a network. It implements the server half of SMTP (Simple Mail Transfer
; Protocol), the DoD standard electronic mail interchange protocol defined
; by Jon Postel in RFC 821, and documented online on the Internet as:
; [SRI-NIC.ARPA]<NETINFO>RFC821.TXT
;
; While nominally MAISER will be used layered on top of the DoD transport
; protocols (TCP/IP) in the Internet environment, it has been designed so
; that this is not necessary. All I/O is done via primary I/O, and the
; Internet system call dependencies have been kept to a minimum so that the
; server can essentially support any network.
;
; MAISER runs on TOPS-20 release 5.3 and later monitors. MAISER will not
; run on Tenex; the "Twenex" operating system is a figment of the imagination
; of certain individuals. There ain't no such thing as a free lunch.
; Routines invoked externally
EXTERN $GTPRO,$GTNAM,$GTLCL,$GTHNS,$GTHSN,$GTHRL,$RMREL
EXTERN $WAKE
SUBTTL Assembly options
IFNDEF DATORG,<DATORG==1000> ; data on page 1
IFNDEF PAGORG,<PAGORG==100000> ; paged data on page 100
IFNDEF CODORG,<CODORG==400000> ; code on page 400
IFNDEF FTTCPBUG,<FTTCPBUG==1> ; non-zero to compensate for TCP bug which
; puts crud from a previous connection in our
; input buffer
IFNDEF TIMOCT,<TIMOCT==^D20> ; number of 15-second ticks of inactivity
; allowed before autologout
; These fields have required minimum sizes established by RFC 822. Someday
; these ought to be made to be dynamically assigned out of free storage.
IFNDEF TXTLEN,<TXTLEN==2*^D512> ; length of a text line (512 required minimum)
IFNDEF ADLLEN,<ADLLEN==2*^D256> ; length of an a-d-l (256 required minimum)
IFNDEF USRNML,<USRNML==2*^D64> ; length of a user name (64 required minimum)
IFNDEF HSTNML,<HSTNML==2*^D64> ; length of a host name (64 required minimum)
IFNDEF PDLLEN,<PDLLEN==200> ; stack length
SUBTTL Definitions
; AC definitions
FL==:0 ; flags
A=:1 ; JSYS, temporary ACs
B=:2
C=:3
D=:4
E=:5 ; non-JSYS temporary ACs
F=:6
G=:7
P=:17 ; stack pointer
; Flags
MSKSTR F%HLO,FL,1B0 ; HELO command seen
MSKSTR F%FRM,FL,1B1 ; have a FROM specification
MSKSTR F%TO,FL,1B2 ; have a TO specification
MSKSTR F%EOL,FL,1B3 ; EOL seen
MSKSTR F%ELP,FL,1B4 ; buffer began with EOL
MSKSTR F%EXP,FL,1B5 ; EXPN vs. VRFY command
MSKSTR F%DOP,FL,3B7 ; delivery option code (see DOPTAB)
MSKSTR F%NOK,FL,1B8 ; PARMBX allows null path (for MAIL FROM:)
MSKSTR F%MOK,FL,1B9 ; PARMBX allows null domain (for RCPT TO:)
MSKSTR F%VLH,FL,1B10 ; given host name validated
MSKSTR F%REE,FL,1B11 ; reenter
MSKSTR F%NVT,FL,1B12 ; on a network terminal, must log out when done
MSKSTR F%RFS,FL,1B13 ; found a user who's refusing sends
MSKSTR F%PRO,FL,3B15 ; transport protocol:
P%UNK==0 ; unknown
P%TCP==1 ; TCP
MSKSTR F%QOT,FL,1B16 ; doing quoting
; Fatal assembly error macro
DEFINE .FATAL (MESSAGE) <
PASS2
PRINTX ?'MESSAGE
END
>;DEFINE .FATAL
.CHLPR==:"(" ; work around various macro lossages
.CHRPR==:")"
.CHRAB==:">"
SUBTTL GTDOM% definitions
IFNDEF GTDOM%,<
OPDEF GTDOM% [JSYS 765]
GD%LDO==:1B0 ; local data only (no resolve)
GD%MBA==:1B1 ; must be authoritative (don't use cache)
GD%RBK==:1B6 ; resolve in background
GD%EMO==:1B12 ; exact match only
GD%RAI==:1B13 ; uppercase output name
GD%QCL==:1B14 ; query class specified
GD%STA==:1B16 ; want status code in AC1 for marginal success
.GTDX0==:0 ; total success
.GTDXN==:1 ; data not found in namespace (authoritative)
.GTDXT==:2 ; timeout, any flavor
.GTDXF==:3 ; namespace is corrupt
.GTDWT==:12 ; resolver wait function
.GTDPN==:14 ; get primary name and IP address
.GTDMX==:15 ; get MX (mail relay) data
.GTDLN==:0 ; length of argblk (inclusive)
.GTDTC==:1 ; QTYPE (ignored for .GTDMX),,QCLASS
.GTDBC==:2 ; length of output string buffer
.GTDNM==:3 ; canonicalized name on return
.GTDRD==:4 ; returned data begins here
.GTDML==:5 ; minimum length of argblock (words)
.GTDAA==:16 ; authenticate address
.GTDRR==:17 ; get arbitrary RR (MIT formatted RRs)
>;IFNDEF GTDOM%
SUBTTL Impure storage
LOC 20 ; enter low memory
FATACS: BLOCK 20 ; save of fatal ACs
.JBUUO: BLOCK 1 ; LUUO saved here
.JB41: JSR UUOPC ; instruction executed on LUUO
UUOACS: BLOCK 20 ; save of UUO ACs
LOC 116
.JBSYM: BLOCK 1 ; symbol table pointer
.JBUSY: BLOCK 1 ; place holder
RELOC ; enter low segment
PDL: BLOCK PDLLEN ; stack
UUOPC: BLOCK 1 ; PC of LUUO
MOVEM 17,FATACS+17 ; save ACs in FATACS for debugging
MOVEI 17,FATACS ; save from 0 => FATACS
BLT 17,FATACS+16 ; ...to 16 => FATACS+16
MOVE 17,FATACS+17 ; restore AC17
TMSG <421-Illegal instruction >
MOVX A,.PRIOU ; output the losing LUUO
MOVE B,.JBUUO
MOVX C,^D8 ; in octal
NOUT%
NOP
TMSG < at >
HRRZ F,UUOPC ; output PC which lost
CALL SYMOUT
JRST IMPERR ; indicate impossible error and die
; Data area
.PSECT DATA,DATORG ; enter data area
BUFFER: BLOCK <TXTLEN/5>+1 ; general purpose buffer
GTJBLK: BLOCK <.JIBAT-.JITNO+1> ; GETJI% stores data here
TMPBUF: BLOCK 30 ; temporary buffer
IN2ACS: BLOCK 3 ; save area for ACs A-C, level 2
LEV1PC: BLOCK 1 ; PSI level 1 PC
LEV2PC: BLOCK 1 ; PSI level 2 PC
LEV3PC: BLOCK 1 ; PSI level 3 PC
TIMOUT: BLOCK 1 ; timeout count
INICBG==. ; first location cleared at once-only init
MYUSRN: BLOCK 1 ; my user number
; Following two lines must be in this order
MYJOBN: BLOCK 1 ; my job number
MYTTYN: BLOCK 1 ; my TTY number
; end of critical order data
MBXFRK: BLOCK 1 ; mailbox fork
MBXWIN: BLOCK 1 ; current window pointer into mailbox
; Host name/address storage
LCLHNO: BLOCK 1 ; local host address from STAT%
LCLHNC: BLOCK 1 ; local host address (in canonical form)
LCLHST: BLOCK <HSTNML/5>+1 ; local host name
FRNHNO: BLOCK 1 ; foreign host address from STAT%
FRNHST: BLOCK <HSTNML/5>+1 ; foreign host name from FRNHNO
FRNHNM: BLOCK <HSTNML/5>+1 ; foreign host name from HELO negotiation
IFN NICSW,<
LOGJFN: 0
LOGMJF: 0
LOGNAM: BLOCK 40
LOGBUF: BLOCK 1000
>
RSTCBG==. ; first location cleared at RSET time
MLQJFN: BLOCK 1 ; queued mail file JFN
MBXBEG==. ; first mailbox location
ATDOML: BLOCK <ADLLEN/5>+1 ; at domain list specification
MAILBX: BLOCK <USRNML/5>+1 ; mailbox specification
DOMAIN: BLOCK <HSTNML/5>+1 ; domain specification
MBXEND==.-1 ; last path location
RSTCEN==.-1 ; last location cleared at RSET time
INICEN==.-1 ; last location cleared at once-only init
.ENDPS
; Paged data area
.PSECT DATPAG,PAGORG ; data pages
MBXPAG: BLOCK 2000 ; for mailing list forwarding pointers
WINPAG: BLOCK 2000 ; for mailing list forwarding strings
.ENDPS
SUBTTL Start of program
.PSECT CODE,CODORG ; pure code
; Entry vector
EVEC: JRST MAISER ; START address
JRST MAIREE ; REENTER address
<FLD MLSWHO,VI%WHO>!<FLD MLSVER,VI%MAJ>!<FLD MLSMIN,VI%MIN>!<FLD MLSEDT,VI%EDN>
EVECL==.-EVEC
MAISER: TDZA FL,FL ; clear flags
MAIREE: MOVX FL,F%REE
RESET% ; flush all I/O
MOVE P,[IOWD PDLLEN,PDL] ; init stack context
SETZM INICBG ; clear once-only area
MOVE A,[INICBG,,INICBG+1]
BLT A,INICEN
; It looks like a bad idea to run with capabilities, and it is. However, a
; system which runs with account validation may cause problems when trying
; to write the queued mail file. We also want to avoid possible problems
; with protections or quotas in the queued mail directory.
MOVX A,.FHSLF ; get my capabilities
RPCAP%
IOR C,B ; enable as many capabilities as we can
EPCAP%
ERJMP .+1 ; ignore possible ACJ ITRAP
IFN NICSW,<
CALL LOGOPN
hrroi 1,buffer
hrroi 2,[asciz /Begin/]
setz 3,
SOUT%
call logapp
>
MOVNI A,TIMOCT ; reset timeout count
MOVEM A,TIMOUT
CALL SETPSI ; set up PSIs
; See if top-level fork, and if so assume we're a network server on an NVT.
; Note that all I/O is done via primary I/O. This allows several ways we can
; be set up, e.g.:
; . traditional CRJOB% style running as a job on an NVT
; . on a physical terminal, as in a "TTY network" environment.
; . with primary I/O remapped to the network JFN's.
GJINF% ; get job info
MOVEM A,MYUSRN ; save my user number
DMOVEM C,MYJOBN ; save job number/TTY number for later use
IFGE. D ; can be NVT server only if attached
MOVX A,.FHSLF ; see what my primary I/O looks like. If
GPJFN% ; AC2 isn't -1 (.CTTRM,,.CTTRM), then we
..TAGF (<AOJN B,>,) ; can assume setup process init'd TTY
MOVX A,.FHTOP ; top fork
SETZ B, ; no handles or status
MOVE C,[-4,,BUFFER] ; fork structure area
GFRKS% ; look at fork structure
ERJMP .+1 ; ignore error (probably GFKSX1)
HRRZ A,BUFFER+1 ; get the top fork's handle
CAIE A,.FHSLF ; same as me?
IFSKP.
MOVX A,.PRIIN ; set terminal type to ideal
MOVX B,.TTIDL
STTYP%
MOVE B,[TT%MFF!TT%TAB!TT%LCA!TT%WKF!TT%WKN!TT%WKP!TT%WKA!<FLD .TTASC,TT%DAM>!<FLD .TTLDX,TT%DUM>]
SFMOD% ; has formfeed, tab, lowercase, all wakeup,
STPAR% ; no translate ASCII, line half-duplex
DMOVE B,[BYTE (2)2,2,2,0,2,2,2,2,2,2,2,2,2,2,2,2,2,2
BYTE (2)2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2]
SFCOC% ; disable all echoing on controls
MOVX A,TL%CRO!TL%COR!TL%SAB!.RHALF ; break and refuse links
MOVX B,.RHALF
TLINK%
ERCAL FATAL
MOVX A,.PRIIN ; refuse system messages
MOVX B,.MOSNT
MOVX C,.MOSMN
MTOPR%
ERCAL FATAL
MOVE A,[SIXBIT/MAISER/] ; set our name
SETNM%
IFN FTTCPBUG,<
MOVX A,.PRIIN ; clear possible crud in our input buffer
CFIBF% ; from an earlier connection
ERJMP .+1
>;IFN FTTCPBUG
TQO F%NVT ; flag an NVT server
ENDIF.
ENDIF.
; Get host info
CALL GETTCP ; get TCP local/foreign host poop
IFNSK.
;; calls for other networks go here
HRROI A,LCLHST ; otherwise get local host name any way we can
CALL $GTLCL
IFNSK.
TMSG <421-Unable to get local host name>
JRST IMPERR
ENDIF.
HRROI A,LCLHST ; remove relative relative domain from name
CALL $RMREL
ENDIF.
; See if SYSTEM:DISABLE-MAIL.FLAG exists, and if so hang up
IFE NICSW,<
MOVX A,GJ%SHT!GJ%OLD ; check if mail disabled now
HRROI B,[ASCIZ/SYSTEM:DISABLE-MAIL.FLAG/]
GTJFN% ; by seeing if this magic file exists
IFNJE.
RLJFN% ; it does, flush the JFN we made
NOP
TMSG <421->
HRROI A,LCLHST ; output host name
PSOUT%
TMSG < SMTP service is disabled, please try again later
421 >
JRST QUIT1
ENDIF.
>;IFE NICSW
; Here to output a banner announcing the service
TMSG <220-> ; start banner
HRROI A,LCLHST ; output host name
PSOUT%
TMSG < SMTP Service >
MOVX A,.PRIOU ; set up for primary output
LOAD B,VI%MAJ,EVEC+2 ; get major version
MOVX C,^D8 ; octal output for all version components
NOUT%
ERCAL FATAL
LOAD B,VI%MIN,EVEC+2 ; get minor version
IFN. B ; ignore if no minor version
MOVX A,"." ; output delimiting dot
PBOUT%
MOVX A,.PRIOU ; now output the minor version
NOUT%
ERCAL FATAL
ENDIF.
; LOAD B,VI%EDN,EVEC+2 ; get edit version
; IFN. B ; ignore if no edit version
; MOVX A,.CHLPR ; edit delimiter
; PBOUT%
; MOVX A,.PRIOU ; now output the edit version
; NOUT%
; ERCAL FATAL
; MOVX A,.CHRPR ; edit close delimiter
; PBOUT%
; ENDIF.
; LOAD B,VI%WHO,EVEC+2 ; get who last edited
; IFN. B ; ignore if last edited at DEC
; MOVX A,"-" ; output delimiting hyphen
; PBOUT%
; MOVX A,.PRIOU ; now output the who version
; NOUT%
; ERCAL FATAL
; ENDIF.
TMSG < at >
MOVX A,.PRIOU ; output date/time
SETO B, ; time now
MOVX C,OT%DAY!OT%SPA!OT%TMZ!OT%SCL!OT%822 ; RFC 822 standard date/time
ODTIM%
ERCAL FATAL
TMSG <
220 Don't Worry.>
JRST GETCMD
SUBTTL Command loop
GETCMD: DO.
CALL CRLF ; terminate reply with CRLF
MOVNI A,TIMOCT ; reset timeout count
MOVEM A,TIMOUT
SETZM BUFFER ; clear out old crud in BUFFER
MOVE A,[BUFFER,,BUFFER+1]
BLT A,BUFFER+<TXTLEN/5>
MOVX A,.PRIIN ; from primary input
HRROI B,BUFFER ; pointer to command buffer
MOVX C,TXTLEN-1 ; up to this many characters
MOVX D,.CHCRT ; terminate on carriage return
SIN% ; read a command
ERJMP INPEOF ; finish up on error
IFE. C ; if count unsatisfied, must have seen CR
LDB A,B ; get last byte
CAIN A,.CHCRT ; was it a CR?
IFSKP.
TMSG <500 Line too long>
LOOP.
ENDIF.
ENDIF.
PBIN% ; get expected LF
ERJMP INPEOF ; finish up on error
CAIN A,.CHLFD ; was it a line feed?
IFSKP.
TMSG <500 Line does not end with CRLF>
LOOP.
ENDIF.
SETZ A, ; make command null-terminated
DPB A,B
LDB C,[POINT 7,BUFFER,34] ; make sure space or NUL
CAIE C,.CHSPC
JUMPN C,SYNERR
MOVE A,BUFFER ; get command from buffer
ANDCM A,[BYTE (7) 040,040,040,040,177] ; upper caseify
IFN NICSW,< CALL LOGAPP >
MOVSI B,-CMDTBL ; length of command table
DO.
CAME A,CMDTAB(B) ; command matches?
AOBJN B,TOP. ; try next command
ENDDO.
JRST @CMDDSP(B) ; dispatch to command
ENDDO.
SUBTTL Command table and dispatch
DEFINE COMMANDS <
; "Minimum required for an SMTP implementation" commands
CMD HELO
CMD MAIL
CMD RCPT
CMD DATA
CMD RSET
CMD NOOP
CMD QUIT
; "Optional" commands
CMD SEND
CMD SOML
CMD SAML
CMD VRFY
CMD EXPN
CMD HELP
CMD TURN
>;DEFINE COMMANDS
DEFINE CMD (CM) <ASCII/'CM'/>
CMDTAB: COMMANDS ; command names
CMDTBL==.-CMDTAB
DEFINE CMD (CM) <.'CM>
CMDDSP: COMMANDS ; command dispatch
BADCMD ; here if command not found
SUBTTL Command service routines
; HELO - HELLO: negotiate identities
.HELO: TQZ <F%HLO,F%VLH> ; cancel valid HELO and host validated
JUMPE C,MISARG ; must have argument
SETZM FRNHNM
DMOVE A,[POINT 7,BUFFER+1 ; pointer to foreign host name
POINT 7,FRNHNM] ; where we store it
MOVX D,HSTNML ; length of a host name
CALL GETDOM ; get domain name
JRST SYNFLD
JUMPN C,SYNFLD ; error if not newline here
LOAD A,F%PRO ; get protocol used
CAIN A,P%TCP ; TCP?
IFSKP.
TQO F%HLO ; HELO is valid
HRROI D,[ASCIZ/ - Your name accepted but not validated/] ; no
ELSE.
SKIPE FRNHST ; got foreign host name yet?
IFSKP.
HRROI A,FRNHST ; get foreign host name
MOVE B,FRNHNO ; from foreign address
CALL $GTHNS
IFNSK.
TMSG <421-Unable to get foreign host name>
JRST IMPERR
ENDIF.
HRROI A,FRNHST ; remove relative domain from name
CALL $RMREL
ENDIF.
HRROI A,FRNHNM ; see if name is a literal
CALL $GTHRL ; parse it and return address in B
IFSKP.
CAME B,FRNHNO ; read a literal, address matches?
IFSKP.
TQO <F%HLO,F%VLH> ; yes, note host name validated
ELSE.
MOVE C,B ; in case needed to restore
HRROI A,BUFFER ; canonicalize address: get name for address
CALL $GTHNS
IFSKP.
HRROI A,BUFFER
CALL $RMREL
HRROI A,BUFFER ; see if that name matches
HRROI B,FRNHST
STCMP%
IFE. A
TQO <F%HLO,F%VLH> ; yes, note host name validated
ELSE.
HRROI A,BUFFER ; now get the address from the name
CALL $GTHSN
MOVE B,C ; restore address after failure
ENDIF.
ELSE.
MOVE B,C ; restore address after failure
ENDIF.
ENDIF.
ELSE.
HRROI A,FRNHNM ; point to her claimed foreign host name
HRROI B,FRNHST ; compare with what we think it is
STCMP% ; got a match?
IFE. A
TQO <F%HLO,F%VLH> ; yes, note host name validated
ELSE.
MOVX A,.GTDAA ; authenticate address
HRROI B,FRNHNM ; from claimed name
MOVE C,FRNHNO ; and its address
GTDOM%
IFNJE.
TQO <F%HLO,F%VLH> ; note validated if OK
ELSE.
HRROI A,FRNHNM ; point to claimed name
CALL $GTHSN ; get its address
SETO B, ; unknown name
ENDIF.
ENDIF.
ENDIF.
ANDQE. F%HLO ; if we're still not certain...
CAMN B,LCLHNC ; check for mirror connections
IFSKP.
TQO F%HLO ; HELO is valid
SKIPGE B
SKIPA D,[-1,,[ASCIZ/ - Never heard of that name/]]
HRROI D,[ASCIZ/ - You are a charlatan/]
ELSE.
HRROI A,LCLHST ; could be...allow it if it really is me!
HRROI B,FRNHST
STCMP%
SKIPN A
TQOA <F%HLO,F%VLH> ; this can happen when going by the numbers
HRROI D,[ASCIZ/ - You can't impersonate me/]
ENDIF.
ENDIF.
IFN NICSW,<
HRROI 1,FRNHNM
HRROI 2,LCLHST
STCMP%
JUMPE 1,[TMSG <501 Possible mail loop>
JRST RSET2]
>
TQNN F%HLO ; have a valid HELO?
SKIPA A,[-1,,[ASCIZ/501 /]] ; HELO failure reply
HRROI A,[ASCIZ/250 /] ; HELO success reply
PSOUT%
HRROI A,LCLHST ; output our name
PSOUT%
TQNN F%VLH ; host name validated?
SKIPA A,D ; no, output auxillary message
HRROI A,[ASCIZ/ - Hello/]
PSOUT%
SKIPN FRNHST ; do we know who foreign host is?
IFSKP.
TMSG <, > ; yes, prepare to output it
HRROI A,FRNHST ; output foreign host's registered name
PSOUT%
ENDIF.
JRST RSET2 ; enter RSET code
; RSET - RESET state to initial
.RSET: JUMPN C,BADARG ; can't have an argument
RSET1: TMSG <250 OK> ; acknowledge command
RSET2: SKIPN A,MLQJFN ; if a queue file open, flush its JFN
IFSKP.
TXO A,CZ%ABT ; abort it
CLOSF%
ERCAL FATAL ; why should this fail?
ENDIF.
IFE NICSW,<
CALL SETPSI ; set up PSIs
>
SETZM RSTCBG ; clear reset area
MOVE A,[RSTCBG,,RSTCBG+1]
BLT A,RSTCEN
TQZ <F%FRM,F%TO> ; no more FROM or TO specification known
JRST GETCMD
; VRFY - VERIFY mailbox
; EXPN - EXPAND mailing list
.VRFY: TQZA F%EXP ; flag not expand
.EXPN: TQO F%EXP ; flag expand
JUMPE C,MISARG ; must have an argument
DMOVE A,[POINT 7,BUFFER+1 ; command argument
POINT 7,MAILBX] ; where we load mailbox
MOVX D,USRNML ; maximum length of a name
ILDB C,A ; get first byte
JUMPE C,MISARG ; missing argument
CAIE C,"""" ; quoted string?
IFSKP.
DO.
ILDB C,A ; get next byte to consider
CAIN C,"""" ; end of quoted string?
IFSKP.
SOJL D,SYNFLD ; no, make sure field isn't too large
JUMPE C,SYNFLD ; also make sure no premature end of line
IDPB C,B ; store byte in string
LOOP. ; get next byte
ENDIF.
ENDDO.
ILDB C,A ; get final byte
JUMPN C,SYNFLD ; make sure line ends here
ELSE.
DO.
MOVEI E,(C) ; get copy of character
IDIVI E,^D32 ; E/ word to check, F/ bit to check
MOVNS F
MOVX G,1B0 ; make bit to check
LSH G,(F)
TDNE G,SPCMSK(E) ; is it a special character?
JRST SYNERR ; it is, lose
CAIE C,.CHRAB ; disallow broket and at as specials
CAIN C,"@"
JRST SYNERR
CAIN C,"\" ; quote next byte literally?
ILDB C,A ; yes, get next byte
IDPB C,B ; store byte in string
ILDB C,A ; get next byte to consider
SOJL D,SYNFLD ; field too large
JUMPN C,TOP. ; if non-null, continue parse
ENDDO.
ENDIF.
IDPB C,B ; tie off string
HRROI A,MAILBX ; point to mailbox
CALL RUNMBX ; validate address
IFNSK.
SKIPE MBXFRK ; did mailbox fork run successfully?
IFSKP.
TMSG <451 Mailbox lookup process terminated abnormally>
JRST GETCMD
ENDIF.
SKIPG MBXFRK ; couldn't find mailbox fork?
JRST NOTIMP ; command not implemented
TMSG <550 No such local mailbox as ">
HRROI A,MAILBX ; output the bad mailbox
PSOUT%
TMSG <", not verified>
JRST GETCMD
ENDIF.
IFQE. F%EXP ; EXPN or VRFY?
TMSG (250 <) ; VRFY, just echo back the mailbox name given
HRROI A,MAILBX
PSOUT%
MOVX A,"@"
PBOUT%
HRROI A,LCLHST
PSOUT%
MOVX A,.CHRAB
PBOUT%
ELSE.
SKIPE MBXPAG+300 ; some answer must be returned
IFSKP.
TMSG <451 Mailbox lookup process returned null answer>
JRST GETCMD
ENDIF.
MOVEI D,MBXPAG+300 ; pointer to list of addresses
DO.
SKIPN C,(D) ; if end of list, return
EXIT.
SKIPN 1(D) ; is this the last item on the list?
SKIPA A,[-1,,[ASCIZ/250 </]] ; yes, no continuation
HRROI A,[ASCIZ/250-</] ; no, indicate continuation coming
PSOUT% ; output reply code and opening broket
TXNN C,.RHALF ; local user reply?
MOVSS C ; yes, set up as local address reply
HRRZ A,C ; get user address
CALL INFOUT ; output string from inferior
MOVX A,"@" ; output mailbox/host delimiter
PBOUT%
IFXE. C,.LHALF ; was a host specified?
HRROI A,LCLHST ; no, output local host name
PSOUT%
ELSE.
HLRZ A,C ; use specified host name
CALL INFOUT ; output string from inferior
ENDIF.
MOVX A,.CHRAB
PBOUT%
SKIPN 1(D) ; is this the last item on the list?
IFSKP. <TMSG <
>> ; no, output CRLF (don't use CALL CRLF!!)
AOJA D,TOP. ; continue until done
ENDDO.
ENDIF.
JRST GETCMD
DOPTAB: PHASE 0 ; delivery option names and F%DOP indices
D%MAIL:!ASCIZ/MAIL/ ; mail
D%SEND:!ASCIZ/SEND/ ; send
D%SOML:!ASCIZ/SOML/ ; send or mail
D%SAML:!ASCIZ/SAML/ ; send and mail
IFN <.-4>,<.FATAL Incorrect number of delivery options>
DEPHASE
; SEND - initiate SEND transaction
.SEND: JUMPE C,MISARG ; must have an argument
JE F%HLO,,HLOREQ ; bad sequence if HELO not done yet
JN F%FRM,,INPROG ; bad sequence if transaction already started
MOVX A,D%SEND ; set delivery option
JRST MAKQUE ; make a queued mail file
; SOML - initiate SEND transaction, mail if not on-line
.SOML: JUMPE C,MISARG ; must have an argument
JE F%HLO,,HLOREQ ; bad sequence if HELO not done yet
JN F%FRM,,INPROG ; bad sequence if transaction already started
MOVX A,D%SOML ; set delivery option
JRST MAKQUE ; make a queued mail file
; SAML - initiate SEND transaction and mail
.SAML: JUMPE C,MISARG ; must have an argument
JE F%HLO,,HLOREQ ; bad sequence if HELO not done yet
JN F%FRM,,INPROG ; bad sequence if transaction already started
MOVX A,D%SAML ; set delivery option
JRST MAKQUE ; make a queued mail file
; Table of devices to queue mail to
MLQTAB: -1,,[ASCIZ/MAILQ:/] ; MAILQ: is the official directory
-1,,[ASCIZ/SYSTEM:/] ; if not, MMAILR still scans SYSTEM:
-1,,[ASCIZ/DSK:/] ; otherwise must use connected directory
MLQTBL==.-MLQTAB
; MAIL - initiate MAIL transaction
.MAIL: JUMPE C,MISARG ; must have an argument
JE F%HLO,,HLOREQ ; bad sequence if HELO not done yet
JN F%FRM,,INPROG ; bad sequence if transaction already started
MOVX A,D%MAIL ; set delivery option
; JRST MAKQUE ; make a queued mail file
; Make a mailer queued request file
MAKQUE: STOR A,F%DOP ; set delivery options
MOVE A,BUFFER+1 ; get what comes after MAIL<SP>
ANDCM A,[BYTE (7) 040,040,040,040,000] ; uppercaseify if needed
CAME A,[ASCII/FROM:/] ; was it MAIL FROM:, etc.?
JRST SYNERR ; no, syntax error
MOVE A,[POINT 7,BUFFER+2] ; start parse after the colon
TQO F%NOK ; allow null mailbox
TQZ F%MOK ; if mailbox non-null, must have domain
CALL PARMBX ; parse a mailbox
JRST SYNFLD ; syntax error in mailbox
MOVSI D,-MLQTBL ; pointer to table of mail queue devices
DO.
HRROI A,TMPBUF ; pointer to name of queued mail file we build
MOVE B,MLQTAB(D) ; get device to try
SETZ C,
SOUT%
HRROI B,[ASCIZ/[--QUEUED-MAIL--].NEW-/]
SOUT% ; set up initial part of name
PUSH P,A ; save string pointer
GTAD% ; get system date/time
MOVE B,A ; now output it in octal
POP P,A
MOVX C,^D8
NOUT%
ERCAL FATAL
HRROI B,[ASCIZ/-MAISER-J/] ; add originating process name
SETZ C,
SOUT%
HRRZ B,MYJOBN ; insert job number for unique name
MOVX C,^D10 ; in decimal
NOUT%
ERCAL FATAL
HRROI B,[ASCIZ/.-1;P770000/] ; next generation, protection 770000
SETZ C,
SOUT%
MOVX A,GJ%NEW!GJ%FOU!GJ%PHY!GJ%SHT ; want new file
HRROI B,TMPBUF ; with name we build
GTJFN% ; try to get JFN on it
IFJER.
AOBJN D,TOP. ; can't do it, try alternative place
TMSG <421-Unable to get queue file - >
CALL ERROUT ; output last JSYS error
JRST IMPERR ; now die
ENDIF.
MOVEM A,MLQJFN ; save JFN for later use
MOVX B,<<FLD 7,OF%BSZ>!OF%WR> ; open for write, 7-bit bytes
OPENF%
IFJER.
MOVE A,MLQJFN ; OPENF% failed, release the JFN
RLJFN%
ERJMP .+1
SETZM MLQJFN ; forget about it
AOBJN D,TOP. ; can't do it, try alternative place
TMSG <421-Unable to open queue file - >
CALL ERROUT ; output last JSYS error
JRST IMPERR ; now die
ENDIF.
ENDDO.
SETZ C, ; make C be 0 for SOUT%'ing below
SKIPN FRNHST ; foreign host number known?
IFSKP.
MOVX B,.CHFFD ; yes, write a NET-MAIL-FROM-HOST line
BOUT%
ERCAL FATAL
HRROI B,[ASCIZ/=NET-MAIL-FROM-HOST:/]
SOUT%
ERCAL FATAL
HRROI B,FRNHST ; output host name
SOUT%
ERCAL FATAL
HRROI B,[ASCIZ/
/] ; output trailing CRLF
SOUT%
ERCAL FATAL
ENDIF.
MOVX B,.CHFFD ; write delivery options line
BOUT%
ERCAL FATAL
HRROI B,[ASCIZ/=DELIVERY-OPTIONS:/]
SOUT%
ERCAL FATAL
LOAD B,F%DOP ; get delivery options
HRROI B,DOPTAB(B)
SOUT%
ERCAL FATAL
HRROI B,[BYTE (7) .CHCRT,.CHLFD,.CHFFD]
SOUT%
ERCAL FATAL
SKIPE MAILBX ; was a proper return path specified?
IFSKP.
HRROI B,[ASCIZ/=DISCARD-ON-ERROR/]
SOUT% ; no, failures go to a black hole
ELSE.
HRROI B,[ASCIZ/=RETURN-PATH:/]
SOUT%
ERCAL FATAL
SKIPN ATDOML ; is an at-domain-list defined?
IFSKP.
HRROI B,ATDOML
SOUT%
ERCAL FATAL
ENDIF.
MOVE B,[POINT 7,MAILBX] ; now output Mailbox
CALL MBXOUT
MOVX B,"@" ; mailbox/domain delimiter
BOUT%
ERCAL FATAL
HRROI B,DOMAIN ; output domain
SOUT%
ERCAL FATAL
HRROI B,[BYTE (7) .CHCRT,.CHLFD,.CHFFD,"_"]
SOUT% ; write sender specification
ERCAL FATAL
HRROI B,DOMAIN ; output domain
SOUT%
ERCAL FATAL
HRROI B,[BYTE (7) .CHCRT,.CHLFD]
SOUT%
ERCAL FATAL
HRROI B,MAILBX ; output mailbox
SOUT%
ERCAL FATAL
ENDIF.
HRROI B,[BYTE (7) .CHCRT,.CHLFD,.CHFFD]
SOUT%
ERCAL FATAL
TQO F%FRM ; flag "from" part of transaction complete
TMSG <250 > ; acknowlege command
LOAD A,F%DOP ; get delivery options
HRROI A,DOPTAB(A)
PSOUT%
TMSG < accepted>
JRST GETCMD ; get next command
; RCPT - identify a RECIPIENT for this transaction
.RCPT: JUMPE C,MISARG ; must have an argument
JE F%FRM,,MAIREQ ; bad sequence if transaction not started yet
MOVE A,BUFFER+1 ; get what comes after RCPT<SP>
ANDCM A,[BYTE (7) 040,040,000,177,177] ; uppercaseify if needed
CAME A,[ASCII/TO:/] ; was it RCPT TO:?
JRST SYNERR ; no, syntax error
MOVE A,[POINT 7,BUFFER+1,20] ; start parse after the colon
TQZ F%NOK ; do not allow null mailbox
TQO F%MOK ; if domain null, assume local host
IFN NICSW,<
SETZM ATDOML
>
CALL PARMBX ; parse a mailbox
JRST SYNFLD ; syntax error
IFN NICSW,<
SKIPN ATDOML
IFSKP.
TMSG <550 Local deliveries only, please!>
JRST GETCMD
ENDIF.
>;IFN NICSW
SKIPN DOMAIN ; if domain given, see if our own
IFSKP.
HRROI A,DOMAIN ; look up recipient host name
SETO C, ; through all naming registries
CALL $GTPRO ; get address and registry
IFNSK.
TMSG <550 Host name ">
HRROI A,DOMAIN ; output the bad host
PSOUT%
TMSG <" unknown, recipient rejected>
JRST GETCMD
ENDIF.
MOVE D,B ; save address
HRROI A,BUFFER ; store local name out of the way
SETO B, ; want local address for this protocol
CALL $GTNAM ; get local name
IFNSK.
TMSG <421-Unable to get local host for recipient naming registry>
JRST IMPERR
ENDIF.
CAMN B,D ; was destination host in fact us?
SETZM DOMAIN ; yes, note local domain
ENDIF.
SKIPE DOMAIN ; local domain?
IFSKP.
LOAD A,F%DOP ; get delivery option
CAIE A,D%SEND ; SEND?
IFSKP.
MOVX A,RC%EMO ; yes, see if local user name
HRROI B,MAILBX
RCUSR%
IFJER.
TMSG <550-Invalid username ">
HRROI A,MAILBX ; output the bad mailbox
PSOUT%
TMSG <", recipient rejected
550 Use SOML if you're trying to do a third-party send>
JRST GETCMD
ENDIF.
IFXN. A,RC%NOM!RC%AMB ;Parsed, does it exist?
TMSG <550-No such local user as ">
HRROI A,MAILBX ; output the bad mailbox
PSOUT%
TMSG <", recipient rejected
550 Use SOML if you're trying to send to a mailing list>
JRST GETCMD
ENDIF.
TQZ F%RFS ; no online users refusing sends yet
MOVX D,1 ; initial job number for scan
MOVE E,C ; user number to look for in E
DO.
MOVEI A,(D) ; job number to sniff at
MOVE B,[-<.JIBAT-.JITNO+1>,,GTJBLK]
MOVX C,.JITNO ; get TTY #, user #, ..., batch flag
GETJI%
IFJER.
CAIN A,GTJIX4 ; No such job?
AOJA D,TOP. ; yes, try next higher job number
TMSG <450 User ">
HRROI A,MAILBX ; output the bad mailbox
PSOUT%
TQNE F%RFS ; was there an online job refusing?
SKIPA A,[-1,,[ASCIZ/" is refusing sends/]]
HRROI A,[ASCIZ/" is not online now/]
PSOUT%
TMSG <, try again later>
JRST GETCMD
ENDIF.
SKIPE GTJBLK+<.JIBAT-.JITNO> ; is this a batch job?
AOJA D,TOP. ; yes, skip it
SKIPL A,GTJBLK ; attached to a terminal
CAME E,GTJBLK+<.JIUNO-.JITNO> ; yes, the user we want?
AOJA D,TOP. ; no to either, try next job
TXO A,.TTDES ; make it a device designator
; MOVX B,.MORNT ; does user want system messages?
MOVX B,.MORTF ; does user want user messages?
MTOPR%
; IFNJE.
; JUMPE C,ENDLP. ; found a logged in user receiving sends, done!
; ENDIF.
IFNJE.
TXNN C,MO%NUM
JRST ENDLP.
ENDIF.
TQO F%RFS ; found an online user who's refusing
AOJA D,TOP. ; otherwise try next job
ENDDO.
ELSE.
TQZ F%EXP ; don't expand here
HRROI A,MAILBX
CALL RUNMBX ; validate address
ANNSK.
SKIPE MBXFRK ; failed, did mailbox fork run successfully?
IFSKP.
TMSG <451 Mailbox lookup process terminated abnormally>
JRST GETCMD
ENDIF.
SKIPG MBXFRK ; is there a mailbox fork?
ANSKP.
TMSG <550 No such local mailbox as ">
HRROI A,MAILBX ; output the bad mailbox
PSOUT%
TMSG <", recipient rejected>
JRST GETCMD
ENDIF.
ENDIF.
SKIPE A,MLQJFN ; get JFN of queue file
IFSKP.
TMSG <421-Queue not set up in RCPT command>
JRST IMPERR
ENDIF.
SKIPN DOMAIN ; domain specified?
SKIPA B,[-1,,LCLHST] ; no, use local host as default domain
HRROI B,DOMAIN ; output destination domain
SETZ C,
SOUT%
ERCAL FATAL
HRROI B,[ASCIZ/
/]
SOUT%
ERCAL FATAL
HRROI B,MAILBX ; now output destination mailbox
SOUT%
ERCAL FATAL
HRROI B,[BYTE (7) .CHCRT,.CHLFD,.CHFFD]
SOUT%
ERCAL FATAL
TQO F%TO ; flag "to" part of transaction complete
TMSG <250 Recipient accepted> ; acknowledge
JRST GETCMD ; and get next command
; DATA - DATA for mail transaction
.DATA: JUMPN C,BADARG ; must not have an argument
JE F%TO,,RCPREQ ; have FROM/TO specifications?
SKIPE A,MLQJFN ; get JFN of queue file
IFSKP.
TMSG <421-Queue not set up in DATA command>
JRST IMPERR
ENDIF.
LOAD B,F%DOP ; get delivery option
CAIN B,D%SEND ; if SEND, don't add Received: header
IFSKP.
HRROI B,[ASCIZ/
Received: from /] ; now, write Received line
SETZ C,
SOUT%
ERCAL FATAL
HRROI B,FRNHNM ; write foreign host
SOUT%
ERCAL FATAL
IFQE. F%VLH ; foreign host number validated?
HRROI B,[ASCIZ/ (/] ; no, start a comment
SOUT%
ERCAL FATAL
SKIPN FRNHST ; foreign host known?
SKIPA B,[-1,,[ASCIZ/not validated/]]
HRROI B,FRNHST ; output foreign host name
SOUT%
ERCAL FATAL
MOVX B,.CHRPR ; terminate comment
BOUT%
ERCAL FATAL
ENDIF.
HRROI B,[ASCIZ/ by /]
SOUT%
ERCAL FATAL
HRROI B,LCLHST ; write local host
SOUT%
ERCAL FATAL
HRROI B,[ASCIZ/; /] ; default is no With specification
LOAD D,F%PRO ; get protocol used
CAIN D,P%TCP ; TCP?
HRROI B,[ASCIZ/ with TCP; /]
SOUT%
ERCAL FATAL
SETO B, ; output current date/time
MOVX C,OT%DAY!OT%SPA!OT%TMZ!OT%SCL!OT%822 ; RFC 822 standard date/time
ODTIM%
ERCAL FATAL
ENDIF.
HRROI B,[ASCIZ/
/] ; now output terminating CRLF
SETZ C,
SOUT%
ERCAL FATAL
TMSG <354 Start mail input; end with <CRLF>.<CRLF>>
CALL CRLF
TQZ F%EOL ; no EOL seen on this line yet
SETO E, ; no lookahead yet
DO.
MOVNI A,TIMOCT ; reset timeout count
MOVEM A,TIMOUT
MOVE B,[POINT 7,BUFFER] ; pointer to buffer
MOVX C,TXTLEN-1 ; up to this many characters
SKIPGE A,E ; any lookahead byte?
IFSKP.
SETO E, ; yes, no lookahead now
IDPB A,B ; stash it in the buffer
SUBI C,1 ; account for it
CAIE A,.CHCRT ; was it a CR?
ANSKP. ; if so don't read anything
ELSE.
MOVX A,.PRIIN ; read a line from primary input
MOVX D,.CHCRT ; terminate on carriage return
SIN%
ERJMP INPEOF ; finish up on error
LDB A,B ; get last character read
ENDIF.
CAIE A,.CHCRT ; was it a CR?
IFSKP.
PBIN% ; yes, get byte after CR
ERJMP INPEOF ; finish up on error
CAIE A,.CHLFD ; is this a real EOL?
IFSKP.
IDPB A,B ; yes, insert it in the buffer
SUBI C,1 ; account for it in the buffer
TQO F%EOL ; flag EOL seen
ELSE.
MOVE E,A ; set lookahead byte after CR
ENDIF.
ENDIF.
MOVE B,[POINT 7,BUFFER] ; buffer we read into
SUBI C,TXTLEN-1 ; negative count of bytes to output
IFQN. F%ELP ; buffer begin with EOL?
LDB A,[POINT 7,BUFFER,6] ; yes, get first byte of buffer
CAIE A,"." ; was it a period?
IFSKP.
IBP B ; yes, skip over it
ADDI C,1 ; account for it in the count
IFQN. F%EOL ; buffer end with EOL?
CAMN C,[-2] ; yes, only two bytes to output?
EXIT. ; yes, must be EOM
ENDIF.
ENDIF.
ENDIF.
MOVE A,MLQJFN ; output buffer to queue file
SOUT%
ERCAL FATAL
TQZE F%EOL ; EOL seen?
TQOA F%ELP ; yes, set EOL seen in previous buffer
TQZ F%ELP ; no EOL in previous buffer
LOOP.
ENDDO.
MOVE A,MLQJFN ; yes, must be EOM
CLOSF%
ERCAL FATAL
SETZM MLQJFN ; flush the JFN
TMSG <250-Message accepted and queued for delivery
>
CALL $WAKE ; wake up MMailr
JRST RSET1 ; now do an implicit RSET
; QUIT - QUIT out of mail service
.QUIT: JUMPN C,BADARG ; must not have an argument
TMSG <221 > ; start acknowledgement
QUIT1: HRROI A,LCLHST ; output our host name
PSOUT%
TMSG < -- Be Happy!>
CALL CRLF
INPEOF: CALL HANGUP ; hang up the connection
JRST MAISER ; restart program
HANGUP:
IFN NICSW,<
CALL LOGCLS
MOVE A,[.FHSLF,,.TIMAL] ;remove all timers pending
TIMER%
ERJMP .+1
>
SKIPN A,MLQJFN ; if a queue file open, flush its JFN
IFSKP.
TXO A,CZ%ABT ; abort it
CLOSF%
ERJMP .+1 ; why should this fail?
SETZM MLQJFN ; flush JFN
ENDIF.
MOVX A,.PRIOU ; wait until the output happens
DOBE%
ERJMP .+1
IFQN. F%NVT ; NVT server?
DTACH% ; detach the job to prevent "Killed..." message
ERJMP .+1
SETO A, ; now log myself out
LGOUT%
ERJMP .+1
ENDIF.
HALTF% ; stop
RET
; NOOP - NOOP null command
.NOOP: JUMPN C,BADARG ; must not have an argument
TMSG <250 OK> ; acknowledge command
JRST GETCMD
; HELP - HELP message
.HELP: JUMPN C,BADARG ; must not have an argument
HRROI A,HLPMSG ; output help message
PSOUT%
JRST GETCMD
HLPMSG: ASCIZ/214-The following commands are implemented:
214- HELO, MAIL, RCPT, DATA, RSET, NOOP, QUIT, SEND, SOML, SAML,
214- VRFY, EXPN, HELP, TURN
214 This system is a DECSYSTEM-20 running the TOPS-20 operating system/
; TURN - TURN around transaction
.TURN: JUMPN C,BADARG ; must not have an argument
TMSG <250 TURN command accepted, send 220 greeting>
CALL CRLF
CALL RDRPLY ; read SMTP reply
CAME A,[ASCII/220/] ; 220 greeting?
IFSKP.
TMSG <HELO > ; yes, output HELO
HRROI A,LCLHST ; and local host name
PSOUT%
CALL CRLF
CALL RDRPLY
; *** Here would go code to support a future implementation of outgoing mail.
; The purpose of this is for situations where two-way mail interactions on
; the same connection are useful.
ENDIF.
CAMN A,[ASCII/421/] ; was last reply code a 421 hangup?
IFSKP.
TMSG <QUIT>
CALL CRLF ; no, negotiate a normal QUIT
CALL RDRPLY ; get reply for it
ENDIF.
CALL HANGUP ; hang up the connection
JRST MAISER ; restart
; Read SMTP reply from server process (for TURN command). Returns ASCII
; of reply code in A.
RDRPLY: DO.
SETZM BUFFER ; make sure no random crud here
MOVX A,.PRIIN ; from primary input
HRROI B,BUFFER ; pointer to command buffer
MOVX C,TXTLEN-1 ; up to this many characters
MOVX D,.CHCRT ; terminate on carriage return
SIN% ; read the greeting header
ERJMP INPEOF ; finish up on error
LDB A,B ; get last byte of line
DO. ; slurp up bytes until see a CRLF
CAIN A,.CHCRT ; got a CR?
IFSKP.
PBIN% ; no, read next byte
ERJMP INPEOF ; finish up on error
LOOP. ; see if this one looks good
ENDIF.
PBIN% ; get expected LF
ERJMP INPEOF ; finish up on error
CAIE A,.CHLFD ; saw LF?
LOOP. ; no, start over again
ENDDO.
LDB A,[POINT 7,BUFFER,27] ; get possible continuation byte
CAIN A,"-" ; was continuation specified?
LOOP. ; yes, get new line
CAIE A," " ; single reply seen?
CALL HANGUP ; no, something's wrong - punt
ENDDO.
MOVE A,BUFFER ; get reply code
AND A,[BYTE (7) 177,177,177,000,000] ; without text crud
RET ; return to caller
SUBTTL Subroutines
; Here to parse a mailbox specification pointed to in A. Skips if success.
; Returns a-d-l in ATDOML, mailbox in MAILBX, and domain in DOMAIN.
; F%NOK indicates that a null mailbox is allowed, to allow null return-paths
; per the SMTP specification.
; F%MOK indicates that a domain is optional, that is, the command:
; RCPT TO:<FOO>
; will be interpreted as local mailbox FOO.
PARMBX: SETZM MBXBEG ; clear previous mailbox
MOVE C,[MBXBEG,,MBXBEG+1]
BLT C,MBXEND
ILDB C,A ; get opening character
CAIE C,"<" ; must be opening broket
RET ; parse fails
ILDB C,A ; get first character in path
CAIE C,.CHRAB ; is this a close broket?
IFSKP.
JN F%NOK,,PRMDUN ; yes, if null mailbox okay then return success
ENDIF.
CAIE C,"@" ; a-d-l present?
IFSKP.
MOVE B,[POINT 7,ATDOML] ; set up pointer to a-d-l
IDPB C,B ; store the starting "@"
MOVX D,ADLLEN-1 ; set up limit of domain list length
DO.
CALL GETDOM ; get a domain
RET ; syntax error in domain
CAIE C,"," ; another domain in route list?
IFSKP.
IDPB C,B ; yes, save the comma
SOJL D,R ; count the comma
ILDB C,A ; get next byte
CAIE C,"@" ; start of next at-domain?
IFSKP.
IDPB C,B ; yes, store this "@"
SOJGE D,TOP. ; count the "@"
RET ; no more space
ENDIF.
MOVX D,":" ; no, must be an RFC 788 SMTP sender, patch
DPB D,B ; a colon over the comma and exit
ELSE.
CAIE C,":" ; end of domain?
RET ; no, syntax error in domain
IDPB C,B ; save a-d-l terminator
SOJL D,R ; let's count that terminator as well
ILDB C,A ; get first character of local part
ENDIF.
ENDDO.
ENDIF.
; Here to process the local part of a mailbox, C has first character
MOVE B,[POINT 7,MAILBX] ; set up pointer to mailbox
MOVX D,USRNML ; set up maximum length of user name
CAIE C,"""" ; quoted string?
IFSKP.
DO.
ILDB C,A ; yes, get next quoted byte
CAIE C,"""" ; end of quoted string?
IFSKP.
ILDB C,A ; get expected at
CAIN C,"@" ; was it an at?
EXIT. ; saw an at, finished with mailbox
CAIN C,.CHRAB ; is this a close broket?
SKIPN MAILBX ; yes, was mailbox non-null?
RET ; not close broket or mailbox null, syntax err
JN F%MOK,,PRMDUN ; yes, if F%MOK then allow missing domain
RET ; syntax error
ENDIF.
CAIE C,.CHCRT ; CR or LF invalid in quoted string
CAIN C,.CHLFD
RET
CAIN C,"\" ; quote next byte literally?
ILDB C,A ; yes, get next byte
IDPB C,B ; store byte in string
SOJGE D,TOP. ; continue with next byte unless overflowed
RET ; mailbox name too long
ENDDO.
ELSE.
DO. ; parse unquoted string
MOVEI E,(C) ; get copy of character
IDIVI E,^D32 ; E/ word to check, F/bit to check
MOVNS F
MOVX G,1B0 ; make bit to check
LSH G,(F)
TDNE G,SPCMSK(E) ; is it a special character?
RET ; yes, syntax error
CAIE C,.CHRAB ; saw close broket?
IFSKP.
SKIPN MAILBX ; yes, was mailbox non-null?
RET ; no, syntax error
JN F%MOK,,PRMDUN ; if F%MOK then allow missing domain
RET ; else syntax error
ENDIF.
CAIN C,"@" ; was it an at?
IFSKP.
CAIN C,"\" ; quote next byte literally?
ILDB C,A ; yes, get next byte
IDPB C,B ; store byte in string
ILDB C,A ; get next byte to consider
SOJGE D,TOP. ; continue byte unless overflowed
RET
ENDIF.
ENDDO.
ENDIF.
; Process the destination domain and terminate the command string
MOVE B,[POINT 7,DOMAIN] ; point at domain string
MOVX D,HSTNML ; maximum length of a host name
CALL GETDOM ; get domain name
RET ; syntax error in domain
CAIE C,.CHRAB ; closing broket?
RET ; no, syntax error
SKIPE MAILBX ; mailbox required
SKIPN DOMAIN ; domain required
RET ; mailbox or domain missing
PRMDUN: ILDB C,A ; see if line ends now
JUMPN C,R ; it doesn't, return
RETSKP
; Table of special characters
BRINI. ; initialize break mask
BRKCH. (.CHNUL,.CHSPC) ; all controls are special characters
BRKCH. (042) ; """"
BRKCH. (050,051) ; "(", ")"
BRKCH. (054) ; ","
BRKCH. (072,074) ; ":", ";", "<"
; BRKCH. (076) ; ">" commented out because processed in code
; BRKCH. (100) ; "@" commented out because processed in code
BRKCH. (133) ; "["
; BRKCH. (134) ; "\" commented out because processed in code
BRKCH. (135) ; "]"
SPCMSK: EXP W0.,W1.,W2.,W3. ; form table of special characters
; These tables are for quoting in the return-path
BRINI. ; initialize break mask
BRKCH. (.CHCNA,.CHTAB) ; CTRL/A through CTRL/I
BRKCH. (.CHVTB,.CHFFD) ; CTRL/K, CTRL/L
BRKCH. (.CHCNN,.CHSPC) ; CTRL/N through space
BRKCH. (050,051) ; "(", ")"
BRKCH. (054) ; ","
BRKCH. (072,074) ; ":", ";", "<"
BRKCH. (076) ; ">"
BRKCH. (100) ; "@"
BRKCH. (133) ; "["
BRKCH. (135) ; "]"
QOTMSK: EXP W0.,W1.,W2.,W3.
; If any of these characters are seen, they must be quoted with backslash
BRINI. ; initialize break mask
BRKCH. (.CHLFD) ; line feed
BRKCH. (.CHCRT) ; carriage return
BRKCH. (042) ; """"
BRKCH. (134) ; "\"
QT1MSK: EXP W0.,W1.,W2.,W3.
; Here to get a domain string, source pointer in A, destination pointer in B,
; maximum number of bytes in D. Skips if success with delimiter in C.
GETDOM: ILDB C,A ; get first byte of domain string
CAIE C,"#" ; monolithic number?
IFSKP.
IDPB C,B ; save indicator of moby number
SUBI D,1 ; account for character
ILDB C,A ; get first byte of number
CAIL C,"0" ; is it a number?
CAILE C,"9"
RET ; must have at least one digit
DO.
IDPB C,B ; save digit
ILDB C,A ; get subsequent digit(s)
CAIL C,"0" ; is it a number?
CAILE C,"9"
EXIT. ; no, end of domain
SOJGE D,TOP. ; else store digit and try again
RET ; string too long
ENDDO.
ELSE.
CAIE C,"[" ; dot-number?
IFSKP.
MOVX E,3 ; number of dots expected in field
DO.
IDPB C,B ; save bracket or dot
SOJL D,R ; account for character (syn err if full)
ILDB C,A ; get first byte of number
CAIL C,"0" ; is it a number?
CAILE C,"9"
RET ; must have at least one digit
DO. ; collect a number into the buffer
IDPB C,B ; save digit
ILDB C,A ; get subsequent digit(s)
CAIL C,"0" ; is it a number?
CAILE C,"9"
EXIT. ; no, leave
SOJGE D,TOP. ; numeric, store digit and try again
RET ; string too long
ENDDO.
SOJL E,ENDLP. ; if seen three dots then done
CAIN C,"." ; dot expected, did we see one?
LOOP. ; yes, store it and collect next number
RET ; else syntax error
ENDDO.
CAIE C,"]" ; closing bracket?
RET ; no, syntax error
IDPB C,B ; store closing bracket in string
SOJL D,R ; see if it makes string too long
ILDB C,A ; get delimiter byte for caller
ELSE.
CAIL C,"A" ; non-alphabetic?
CAILE C,"z"
RET ; first character must be alphabetic
CAILE C,"Z" ; further alphabetic checking
CAIL C,"a"
CAIA
RET ; non-alphabetic, lose
DO.
IDPB C,B ; store byte in string
SOJL D,R ; length check
ILDB C,A ; get next byte of string
CAIE C,"." ; dot?
CAIN C,"-" ; hyphen?
LOOP. ; yes, store in string
CAIL C,"A" ; non-alphabetic?
CAILE C,"z"
IFSKP.
CAILE C,"Z" ; further alphabetic checking
CAIL C,"a"
LOOP. ; character is alphabetic, store in string
ENDIF.
CAIL C,"0" ; numeric?
CAILE C,"9"
EXIT. ; no, end of domain
LOOP. ; character is numeric, store in string
ENDDO.
LDB E,B ; get last byte in string
CAIE E,"." ; disallow null domain element
CAIN E,"-" ; domain string may not end in hyphen
RET ; it did, syntax error
ENDIF.
ENDIF.
SAVEAC <B> ; leave string pointing at null
SETZ E, ; tie off string with null
IDPB E,B
RETSKP ; return success to caller
; Here to lookup a mailbox pointed to in A in the mailbox database. Skips
; if mailbox found, with pointers in MBXPAG+300.
RUNMBX: SAVEAC <A> ; don't clobber mailbox pointer
STKVAR <MBXPTR>
MOVEM A,MBXPTR ; save mailbox pointer
SKIPLE MBXFRK ; see if already a mailbox fork
IFSKP.
SETOM MBXFRK ; no, flag trying to get a mailbox fork
SETOM MBXWIN ; clear memory of cached mailbox window
MOVX A,GJ%OLD!GJ%SHT ; get JFN of forwarder
HRROI B,[ASCIZ/SYS:MMAILBOX.EXE/]
GTJFN%
ERJMP R ; not implemented if no mailbox fork
MOVEM A,MBXFRK ; save here temporarily
MOVX A,CR%CAP ; create an inferior fork
CFORK%
ERCAL FATAL
EXCH A,MBXFRK ; save fork handle, get JFN
HRL A,MBXFRK ; get prog into fork
GET%
ERCAL FATAL
ENDIF.
HRLZ A,MBXFRK ; page 0 of inferior
DMOVE B,[.FHSLF,,MBXPAG/1000 ; mapped to this fork's MBXPAG
PM%RD!PM%WR!PM%CNT+2] ; read+write access
PMAP%
ERCAL FATAL
MOVE A,[POINT 7,MBXPAG+200] ; destination
MOVE B,MBXPTR ; source address
MOVX C,-USRNML ; maximum length of an address
SOUT%
ERCAL FATAL
MOVE A,MBXFRK ; get fork handle back again
TQNN F%EXP ; need to expand?
SKIPA B,[4] ; no, just verify existance
MOVX B,3 ; expansion entry
SFRKV% ; start fork
ERCAL FATAL
WFORK% ; wait for it to halt
ERCAL FATAL
RFSTS% ; see if it finished ok
ERCAL FATAL
HLRZ A,A
CAIN A,.RFHLT ; halted normally?
IFSKP.
SETO A, ; unmap shared pages
DMOVE B,[.FHSLF,,MBXPAG/1000 ; mapped to this fork's MBXPAG
PM%CNT+2]
PMAP%
ERCAL FATAL
DMOVE B,[.FHSLF,,WINPAG/1000 ; mapped to this fork's WINPAG
PM%CNT+2]
PMAP%
ERCAL FATAL
MOVE A,MBXFRK ; flush the fork
KFORK%
ERCAL FATAL
SETZM MBXFRK
RET
ENDIF.
SKIPG MBXPAG+177 ; yes, success answer?
RET ; no, non-skip return
RETSKP ; success, skip return with fork still mapped
ENDSV.
; Output string from mailbox starting from address in A
INFOUT: SAVEAC <A,B,C> ; preserve ACs
STKVAR <MBXADR>
MOVEM A,MBXADR ; save address we're going to PSOUT% for later
LSH A,-<^D9> ; get inferior page number desired
CAMN A,MBXWIN ; already cached?
IFSKP.
MOVEM A,MBXWIN ; no, set as new mailbox window page
DMOVE B,[.FHSLF,,WINPAG/1000 ; map two pages to our WINPAG
PM%CNT!PM%RD!PM%CPY+2]
CAIN A,777 ; guard against page 777
SUBI C,1 ; oops, only one page then
HRL A,MBXFRK ; mailbox fork,,page number
PMAP%
ERCAL FATAL
ENDIF.
MOVX A,.PRIOU ; output to primary I/O
MOVE B,MBXADR ; get address back
MOVX C,<WINPAG/1000> ; page in our address space
DPB C,[POINT 9,B,26] ; set up as new address
HRLI B,(<POINT 7,>) ; make pointer
CALLRET MBXOUT ; output mailbox
ENDSV.
; Here to output mailbox with RFC822 quoting
; Accepts: A/ destination designator
; B/ mailbox source pointer
; CALL MBXOUT
; Returns +1: always
MBXOUT: SAVEAC <C,D,E,F,G>
STKVAR <SRCPTR>
MOVEM B,SRCPTR ; save source pointer
TQZ F%QOT ; initially require no quoting
MOVX B,"\" ; quote for wierd characters
MOVE G,[POINT 7,TMPBUF] ; pointer to temporary buffer
DO. ; copy to TMPBUF with \ insert and " need check
ILDB C,SRCPTR ; get character from source
ERCAL FATAL ; in case of page mapping lossage
MOVEI E,(C) ; make a copy of it to hack
IDIVI E,^D32 ; E := word to check, F := bit to check
MOVNS F
MOVX D,1B0 ; D := bit to check
LSH D,(F)
TDNE D,QOTMSK(E) ; is it a special character?
TQO F%QOT ; yes, note
TDNE D,QT1MSK(E) ; is it an wierd character?
IDPB B,G ; yes, put in wierd character quote
IDPB C,G ; now copy character
JUMPN C,TOP. ; continue
ENDDO.
MOVX B,""""
TQNE F%QOT ; need to do atomic quoting?
BOUT% ; yes, insert it
HRROI B,TMPBUF ; output buffer
SETZ C,
SOUT%
MOVX B,""""
TQNE F%QOT ; need to do atomic quoting?
BOUT% ; yes, insert it
RET
; Outputs a CRLF iff it is necessary
CRLF: SAVEAC <A,B,C>
MOVX A,.PRIOU ; use SOUTR% for non-TTY primary I/O
HRROI B,[ASCIZ/
/]
SETZ C,
SOUTR% ; this pushes the text on networks
ERJMP .+1
RET
; Convert a 32-bit quantity in A from squoze to ASCII
SQZTYO: IDIVI A,50 ; divide by 50
PUSH P,B ; save remainder, a character
SKIPE A ; if A is now zero, unwind the stack
CALL SQZTYO ; call self again, reduce A
POP P,A ; get character
ADJBP A,[POINT 7,[ASCII/ 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ.$%/],6]
LDB A,A ; convert squoze code to ASCII
PBOUT%
RET
SUBTTL Error handling
; Common routine called to output last error code's message
ERROUT: MOVX A,.PRIOU
HRLOI B,.FHSLF ; dumb ERSTR%
SETZ C,
ERSTR%
JRST ERRUND ; undefined error number
NOP ; can't happen
RET
ERRUND: TMSG <Undefined error >
MOVX A,.FHSLF ; get error number
GETER%
MOVX A,.PRIOU ; output it
HRRZS B ; only right half where error code is
MOVX C,^D8 ; in octal
NOUT%
ERJMP R ; ignore error here
RET
; Various SMTP errors
BADCMD: TMSG <500 Command unrecognized: >
JRST DMPCMD
SYNFLD: TMSG <500 Syntax error or field too long: >
JRST DMPCMD
SYNERR: TMSG <500 Syntax error in command: >
JRST DMPCMD
NOTIMP: TMSG <502 Command not implemented: >
JRST DMPCMD
HLOREQ: TMSG <503 HELO required before starting a transaction: >
JRST DMPCMD
MAIREQ: TMSG <503 MAIL FROM required before recipients: >
JRST DMPCMD
RCPREQ: TMSG <503 RCPT TO required before data: >
JRST DMPCMD
INPROG: TMSG <503 >
LOAD A,F%DOP ; get current delivery option
HRROI A,DOPTAB(A) ; output name of current delivery option
PSOUT%
TMSG < already in progress, must RSET first: >
JRST DMPCMD
MISARG: TMSG <500 Missing required argument: >
JRST DMPCMD
BADARG: TMSG <500 Argument given when none expected: >
DMPCMD: HRROI A,BUFFER ; output losing command
PSOUT%
JRST GETCMD
; Fatal errors arrive here
FATAL: MOVEM 17,FATACS+17 ; save ACs in FATACS for debugging
MOVEI 17,FATACS ; save from 0 => FATACS
BLT 17,FATACS+16 ; ...to 16 => FATACS+16
MOVE 17,FATACS+17 ; restore AC17
MOVX A,.PRIIN ; flush TTY input
CFIBF%
ERJMP .+1
CALL CRLF ; new line first
TMSG <421-Fatal system error: >
CALL ERROUT ; output last JSYS error
TMSG <, >
MOVE F,(P) ; get PC
MOVE F,-2(F) ; get instruction which lost
CALL SYMOUT ; output symbolic instruction if possible
TMSG < at PC >
POP P,F
MOVEI F,-2(F) ; point PC at actual location of the JSYS
CALL SYMOUT ; output symbolic name of the PC
; Entry point to ask for a report for non-JSYS "impossible" error
IMPERR: CALL CRLF
TMSG <421-This isn't expected to happen; please report this
421 >
JRST QUIT1 ; skip over 221 reply code in QUIT code
; Clever symbol table lookup routine. For details, read "Introduction to
; DECSYSTEM-20 Assembly Language Programming", by Ralph Gorin, published by
; Digital Press, 1981. Called with desired value in F.
SYMOUT: SETZB C,E ; no current program name or best symbol
MOVE D,.JBSYM ; symbol table pointer
HLRO A,D
SUB D,A ; -count,,ending address +1
DO.
LDB A,[POINT 4,-2(D),3] ; symbol type
IFN. A ; 0=prog name (uninteresting)
CAILE A,2 ; 1=global, 2=local
ANSKP.
MOVE A,-1(D) ; value of the symbol
CAME A,F ; exact match?
IFSKP.
MOVE E,D ; yes, select it as best symbol
EXIT.
ENDIF.
CAML A,F ; smaller than value sought?
ANSKP.
SKIPE B,E ; get best one so far if there is one
CAML A,-1(B) ; compare to previous best
MOVE E,D ; current symbol is best match so far
ENDIF.
ADD D,[2000000-2] ; add 2 in the left, sub 2 in the right
JUMPL D,TOP. ; loop unless control count is exhausted
ENDDO.
IFN. E ; if a best symbol found
MOVE A,F ; desired value
SUB A,-1(E) ; less symbol's value = offset
CAIL A,200 ; is offset small enough?
ANSKP.
MOVE A,-2(E) ; symbol name
TXZ A,<MASKB 0,3> ; clear flags
CALL SQZTYO ; print symbol name
SUB F,-1(E) ; difference between this and symbol's value
JUMPE F,R ; if no offset then done
MOVX A,"+" ; add + to the output line
PBOUT%
ENDIF.
MOVX A,.PRIOU ; and copy numeric offset to output
MOVE B,F ; value to output
MOVX C,^D8
NOUT%
ERJMP R
RET
; Get TCP location. Skips if a TCP connection
IFNDEF TCP%TV,TCP%TV==:1B11 ; TVT argument supplied
IFNDEF $TFH,$TFH==:7 ; TCB foreign address
IFNDEF $TLH,$TLH==:10 ; TCB local address
GETTCP: IFQN. F%NVT ; NVT server?
MOVX A,TCP%TV ; argument is TVT
HRR A,MYTTYN ; our TVT number
HRROI B,$TFH ; want host number
HRROI C,FRNHNO ; put it in FRNHNO
STAT%
ERJMP R
MOVX A,TCP%TV ; argument is TVT
HRR A,MYTTYN ; our TVT number
HRROI B,$TLH ; want local host address
HRROI C,LCLHNO ; put it in LCLHNO
STAT% ; get it
ERJMP R
ELSE.
MOVX A,.PRIIN ; get foreign host from TCB
MOVX B,.TCRTW
MOVEI C,$TFH
TCOPR%
ERJMP R
MOVEM C,FRNHNO ; save foreign host address
IFE NICSW,<
MOVEI C,$TLH ; now get local host
TCOPR%
ERJMP R
MOVEM C,LCLHNO ; save local host address
>
IFN NICSW,<
MOVEI A,.GTHSZ ;get host number
GTHST%
ERJMP R
MOVEM D,LCLHNO ; save local host address
>
ENDIF.
HRROI A,LCLHST ; get local host name
SETO B,
CALL $GTHNS
RET
HRROI A,LCLHST ; remove relative domain from name
CALL $RMREL
MOVEM B,LCLHNC ; save canonical local host address
CAMN B,LCLHNO ; same as local host address?
IFSKP.
HRROI A,BUFFER ; ugh, gotta look at this closer
MOVE B,LCLHNO ; get name from connection local address
CALL $GTHNS
ANSKP.
HRROI A,BUFFER ; remove relative domain from name
CALL $RMREL
HRROI A,LCLHST ; compare the names
HRROI B,BUFFER
STCMP%
ANDN. A
TMSG <421-> ; sorry, local ports not supported yet!!
HRROI A,BUFFER ; output host name
PSOUT%
TMSG < SMTP service isn't operational yet
421 >
JRST QUIT1
ENDIF.
MOVX A,P%TCP ; set protocol to be TCP
STOR A,F%PRO
RETSKP
SUBTTL Interrupt stuff
; PSI blocks
LEVTAB: LEV1PC ; priority level table
LEV2PC
LEV3PC
CHNTAB: PHASE 0 ; channel table
COFCHN:!1,,COFINT ; carrier off channel
TIMCHN:!2,,TIMINT ; timer channel
REPEAT ^D36-.,<0>
DEPHASE
; Set up PSIs
SETPSI: MOVX A,.FHSLF ; set level/channel tables
MOVE B,[LEVTAB,,CHNTAB]
SIR%
ERCAL FATAL
EIR% ; enable PSIs
ERCAL FATAL
MOVX B,<1B<TIMCHN>!1B<COFCHN>> ; on these channels
AIC%
ERCAL FATAL
MOVX A,<XWD .TICRF,COFCHN> ; arm for carrier off interrupts
ATI%
; CALLRET SETTIM
; Initialize the timer
SETTIM: MOVE A,[.FHSLF,,.TIMEL] ; tick the timer every 15 seconds
MOVX B,^D15*^D1000
MOVX C,TIMCHN
TIMER%
ERCAL FATAL
RET
; Timer interrupt
TIMINT: DMOVEM A,IN2ACS ; save ACs
MOVEM C,IN2ACS+2
AOSGE TIMOUT ; has timer run out yet?
IFSKP.
IFN NICSW,<
HRROI 1,BUFFER
HRROI 2,[ASCIZ /421 Autologout; idle for too long/]
SETZ 3,
SOUT%
CALL LOGAPP
>
MOVX A,.PRIIN ; flush TTY input
CFIBF%
ERJMP .+1
CALL CRLF ; output CRLF
TMSG <421-Autologout; idle for too long
421 >
MOVX A,<PC%USR!QUIT1> ; dismiss to quit code
MOVEM A,LEV2PC
ELSE.
CALL SETTIM ; reinitialize the timer
ENDIF.
DMOVE A,IN2ACS ; restore ACs
MOVE C,IN2ACS+2
DEBRK%
; Carrier-off interrupt
COFINT: CALL HANGUP ; hang up the connection
DEBRK% ; back out if continued
SUBTTL Other randomness
IFN NICSW,<
;logging code. log all incoming command lines.
LOGSW: 1 ;set this to nonzero to enable logging
LOGMNM: ASCIZ /MAILQ:SMTP.LOG/
LOGOPN: SKIPN LOGSW ;logging enabled?
RET ;no, return
SETZM LOGJFN
HRROI 1,LOGNAM
HRROI 2,[ASCIZ /MAILQ:SMTP.TMPLOG-/]
SETZ 3,
SOUT%
PUSH P,1
GTAD%
MOVE 2,1
POP P,1
MOVEI 3,10
NOUT%
JFCL
MOVX 1,GJ%SHT!GJ%FOU!GJ%NEW
HRROI 2,LOGNAM
GTJFN%
ERJMP R
MOVEM 1,LOGJFN
MOVX 2,<<FLD 7,OF%BSZ>!OF%RD!OF%WR>
OPENF%
ERJMP LOGERR
R: RET
LOGERR: MOVE 1,LOGJFN
RLJFN%
ERJMP .+1
SETZM LOGJFN
RET
LOGCLS: SKIPN LOGSW ;logging enabled?
RET ;no, return
SKIPN 1,LOGJFN
RET
SETZ 2,
SFPTR%
ERJMP LOGCLX
MOVX 1,GJ%SHT!GJ%OLD
HRROI 2,LOGMNM
GTJFN%
ERJMP LOGCLX
MOVEM 1,LOGMJF
MOVX 2,<<FLD 7,OF%BSZ>!OF%APP>
OPENF%
ERJMP LOGCLX
LOGCPY: MOVE 1,LOGJFN
HRROI 2,LOGBUF
MOVNI 3,777*5
SIN%
ERJMP .+1
MOVE 5,3
MOVE 1,LOGMJF
HRROI 2,LOGBUF
MOVNI 3,777*5
SUB 3,5
SOUT%
ERJMP LOGCLX
JUMPE 5,LOGCPY
LOGCLX: MOVE 1,LOGJFN
TXO 1,CO%NRJ
CLOSF%
ERJMP .+1
MOVE 1,LOGJFN
TXO 1,DF%EXP
DELF%
ERJMP .+1
SETZM LOGJFN
MOVE 1,LOGMJF
CLOSF%
ERJMP .+1
RET
LOGAPP: SKIPN LOGSW ;logging enabled?
RET ;no, return
SKIPN LOGJFN
RET
SAVEAC <1,2,3>
HRROI 1,LOGBUF
SETO 2,
SETZ 3,
ODTIM%
ERJMP .+1
MOVEI 2,.CHSPC
IDPB 2,1
HRROI 2,BUFFER ;current command line
SETZ 3,
SOUT%
ERJMP .+1
HRROI 2,[ASCIZ /
/]
SOUT%
ERJMP .+1
MOVE 1,LOGJFN
HRROI 2,LOGBUF
SOUT%
ERJMP LOGCLS
RET
>;IFN NICSW
; Literals
...VAR:!VAR ; generate variables (there shouldn't be any)
IFN .-...VAR,<.FATAL Variables illegal in this program>
...LIT: XLIST ; save trees during LIT
LIT ; generate literals
LIST
END EVECL,,EVEC ; The End