Trailing-Edge
-
PDP-10 Archives
-
tops20_v7_0_tcpip_distribution_tape
-
tcpip-sources/mmailr.mac
There are 3 other files named mmailr.mac in the archive. Click here to see a list.
TITLE MMailr -- System Mailer Daemon for MM Mailsystem
SUBTTL Mike McMahon & Mark Crispin/TCR/DT/DE/CLH/yduJ/GZ/SRA/WD/LeL
;Version components
MMLWHO==0 ;Who last edited MMAILR (0=developers)
MMLVER==6 ;MMAILR's release version (matches monitor's)
MMLMIN==1 ;MMAILR's minor version
MMLEDT==^D522 ;MMAILR's edit version
SEARCH MACSYM,MONSYM ;System definitions
SEARCH SNDDEF ;Definitions for terminal messages
SALL ;Suppress macro expansions
.DIRECTIVE FLBLST ;Sane listings for ASCIZ, etc.
.TEXT "/NOINITIAL" ;Suppress loading of JOBDAT
.TEXT "MMAILR/SAVE" ;Save as MMAILR.EXE
.TEXT "/SYMSEG:PSECT:CODE" ;Put symbol table and patch area in CODE
.REQUIRE HSTNAM ;Host name routines
.REQUIRE WAKEUP ;MMailr wakeup routines - make LINK happy
.REQUIRE SNDMSG ;Terminal message support
.REQUIRE SYS:MACREL ;MACSYM support routines
.REQUIRE RELAY ;RELAY code
; *******************************************************************
; * *
; * MMailr is a multiple network mailer program for TOPS-20. Like *
; * most fine software, it is the result of several individuals' *
; * work. *
; * It was originally conceived as XMAILR about January 1980 by *
; * Mike McMahon (MIT Artificial Intelligence Lab) and jointly *
; * developed for TOPS-20 with Mark Crispin (Stanford Computer *
; * Science Dept.). *
; * The TENEX version of XMAILR was developed by Tom Rindfleisch *
; * (Stanford SUMEX Project) and Mike McMahon in January 1981. *
; * MMailr was developed from XMAILR version 524 for TCP/IP and *
; * SMTP by Mark Crispin in September 1982. Dan Tappan (BBN) *
; * assisted in the development and debugging of the new host name *
; * lookup technology, including eliminating the need for HOSTS2. *
; * David Eppstein (Stanford) wrote the interface into the send *
; * system, which in turn was written by Kirk Lougheed (Stanford) *
; * et. al. Charles Hedrick (Rutgers) wrote the new relaying code. *
; * Ken Rossman (Columbia) wrote the first DECnet support code. *
; * Willis Dair (Santa Clara Univ) wrote the new multi-hop *
; * Mark Crispin wrote the HSTNAM module and SMTP support, lots of *
; * miscellaneous code, specified the other modules noted above, *
; * and generally guided MMailr through its long evolution. *
; * *
; *******************************************************************
; Routines invoked externally
EXTERN $GTPRO,$GTNAM,$GTCAN,$GTLCL,$GTHST
EXTERN $ADDOM,$RMREL,$RRDOM,$UKHST
EXTERN $GTHNS,$PUPNS,$CHSNS,$DECNS,$SPCNS
EXTERN $PUPSN
EXTERN $SEND,$WTRCP,$SSTAT
EXTERN $GTRLY,$INRLY,DM%TRN,DM%RLY
SUBTTL Conditional Assembly
; Following are assembly switches and functions
IFNDEF DATORG,<DATORG==1000> ;Data on page 1
IFNDEF CODORG,<CODORG==10000> ;Code on page 10
IFNDEF PAGORG,<PAGORG==50000> ;Paged data on page 50
IFNDEF FREORG,<FREORG==100000> ;Free storage starts at page 100
IFNDEF NTDAYS,<NTDAYS==1> ;Default sender status period, 1 day
IFNDEF DEDAYS,<DEDAYS==3> ;Default dead letter period, 3 days
IFNDEF MAXTMT,<MAXTMT==^D15*60> ;Max time for Daemon to transmit whole message
IFNDEF MAXTMC,<MAXTMC==^D15*60> ;Max time for Daemon to transmit one copy
IFNDEF MAXTMB,<MAXTMB==^D2*60> ;Max time to transmit 1000 chars
IFNDEF INTRXM,<INTRXM==^D30> ;Number of minutes between retransmit scans
IFNDEF INTSCN,<INTSCN==^D5> ;Number of minutes between file scans
SUBTTL Definitions
F==:0 ;Flags
A=:1 ;JSYS/argument passing
B=:2 ;...
C=:3 ;...
D=:4 ;...
E=:5
T=:6 ;Scratch
TT=:7 ;Ditto
M=:10 ;Holds current message
N=:11 ;Current host block when sending
O=:12 ;Current recipient block ""
X=:14
Y=:15
CX=:16 ;Used by MACREL
;P=:17 ;Stack pointer
; Character definitions
.CHDQT=="""" ;Double quote
; Local UUO's
OPDEF UTYPE [1B8]
OPDEF UETYPE [2B8]
OPDEF UERR [3B8]
; Macros for initializing and disabling timer
TMRTCK==^D5 ;Timer tick interval in seconds
; intvl = time-out interval in seconds
; retad = time-out error return address
DEFINE TMOSET (INTVL,RETAD) <
SETZM INTOK ;An interrupt here could be embarrassing
MOVEM P,TIMRTP ;Save the stack ptr for return
PUSH P,[PC%USR+RETAD] ;Set the return address
POP P,TIMLOC
PUSH P,[-<INTVL/TMRTCK>] ;Set the time-out interval in ticks
POP P,INTOK
>;DEFINE TMOSET
DEFINE TMOCLR <
SETZM INTOK ;Turn off time-out counter
SETZM TIMLOC ;And the return adr
>;DEFINE TMOCLR
; The following print macros do output only if PRINTP is set
DEFINE TYPE (X)
< UTYPE [ASCIZ/X/] ;Just type string
>
DEFINE CTYPE (X)
< UTYPE 10,[ASCIZ/X/] ;Do crlf and type string
>
DEFINE CITYPE (X)
< UTYPE 1,[ASCIZ/X/] ;Conditional crlf and type string
>
DEFINE ETYPE (X)
< UETYPE [ASCIZ/X/] ;Type string (fmt codes)
>
DEFINE CETYPE (X)
< UETYPE 10,[ASCIZ/X/] ;Do crlf and type string (fmt codes)
>
DEFINE CIETYP (X)
< UETYPE 1,[ASCIZ/X/] ;Conditional crlf and type str (fmt codes)
>
DEFINE DEFERR (X,Y) <
DEFINE X (Z) <
IFB <Z>,<UERR Y,0>
IFNB <Z>,<UERR Y,[ASCIZ/Z/]>>
OPDEF %'X [UERR Y,]>
DEFERR WARN,0
DEFERR JWARN,4
DEFERR FATAL,10
DEFERR JFATAL,14
IFNDEF OT%822,OT%822==:1
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 Flags
; Beware! Flags are local, not global. Consequently, they shouldn't be
;referenced outside of their defined context. Each return from a SAVACS
;context will restore the flags to their prior context.
;
; There are a number of other flags in various location, this page is only
;for the flags in F.
;;; Parser flags
FP%FF== 1B0 ;Formfeed seen at start of line
FP%CLN==1B1 ;Colon seen
FP%EOL==1B2 ;Blank line (after any formfeed, that is)
FP%DEL==1B3 ;Rubout on line
FP%EQU==1B4 ;Equal sign seen (control parameter)
FP%BKA==1B5 ;Backarrow seen (sender spec)
FP%WSP==1B6 ;Whitespace at start
;;; Following used in parsing sender addresses from msg headers
FP%LBK==1B7 ;Left angle bracket seen
FP%RBK==1B8 ;Right angle bracket seen
FP%HST==1B9 ;Collecting host
FP%SEP==1B10 ;"Separator" at end of sender adr field
FP%DQT==1B11 ;" seen to start quoted field
;;; Delivery flags
FM%FAI==1B18 ;Failing message
FM%RLY==1B19 ;Current transaction is being relayed
FM%HDR==1B20 ;Headers already generated
FM%FLO==1B21 ;Addressee is a file
FM%VRC==1B22 ;Valid recipient seen
FM%QOT==1B23 ;Must quote this address in protocol
;;; Requeue flags
FQ%DON==1B26 ;"Host done" set on entry
FQ%XER==1B27 ;Discard msg on failure
FQ%XNT==1B28 ;Don't send non-delivery notifications
FQ%RNM==1B29 ;Rename file to have RETRANSMIT ext
FQ%SXX==1B30 ;Failure notice rerouted to mail agent
FQ%SDR==1B31 ;Mail failed to sender
FQ%MLA==1B32 ;Mail failed to mail agent
FQ%OMF==1B33 ;Old style mail queue file
FQ%ALL==1B34 ;Output all of this host
FQ%HST==1B35 ;Host already output
SUBTTL Paged storage
.PSECT DATPAG,PAGORG ;Enter paged data
DEFINE DEFPAG (ADDR,LENGTH) <
ADDR: IFB <LENGTH>,<BLOCK 1000>
IFNB <LENGTH>,<BLOCK 1000*LENGTH>
>;DEFINE DEFPAG
DEFPAG IPCPAG,1 ;Junk page for IPCF
DEFPAG HSTTBL,4 ;Internal table of hosts
HTBLSZ==<4*1000>-1 ;Length of table in TBLUK% format
DEFPAG FLGPAG ;For MAILER.FLAGS if needed
DEFPAG TMPBUF,2 ;Temporary storage
DEFPAG FWDWIN,2 ;Forwarding string window
.ENDPS
.PSECT FRESTG,FREORG
FSPAG==<FREORG/1000> ;First free storage page
.ENDPS
SUBTTL Impure storage
LOC 20 ;Low memory
FATACS: BLOCK 20 ;AC's saved on crash
UUOLOC: BLOCK 1 ;LUUO saved here
JSR UUOH ;Set up UUO handler
FHTAB: BLOCK 3 ;Start of daughter fork handle table
FORKX: BLOCK 1 ;Logical fork number
NEWF: BLOCK 1 ;Non-zero to scan new mail
NETF: BLOCK 1 ;Non-zero to deliver to network recipients
RXMF: BLOCK 1 ;Non-zero to scan retransmit mail
FSTF: BLOCK 1 ;Non-zero to cache dead hosts
DAEMNP: BLOCK 1 ;If running as system job
WOPRP: BLOCK 1 ;If WHEEL or OPERATOR
MYUSRN: BLOCK 1 ;User number
MYDIRN: BLOCK 1 ;Connected directory number
MYJOBN: BLOCK 1 ;Job number
MYLDIR: BLOCK 1 ;Logged-in directory
RELOC
.PSECT DATA,DATORG ;Enter data area
NPDL==500 ;Size of stack
PDL: BLOCK NPDL ;Pushdown list
MEMBEG==. ;Start of memory initialized at startup
IPCFON: BLOCK 1 ;Non-zero if IPCF is set up
LOGJFN: BLOCK 1 ;Log file when Daemon
STAJFN: BLOCK 1 ;Statistics file when Daemon
SEGSIZ: BLOCK 1 ;Size of segments we'll send
MPP: BLOCK 1 ;Saved stack ptr for SAVACS/RSTACS
SAVEN: BLOCK 1 ;Place to save recipient host ptr
SAVEP: BLOCK 1 ;For Pup abort returns
DODJFN: BLOCK 1 ;DODIR's current JFN
FRNHST: BLOCK 1 ;Address of foreign host string
FRNADR: BLOCK 1 ;Foreign host address
PGTBLL==<1000-FSPAG+^D35>/^D36
PAGTBL: BLOCK PGTBLL ;Bit table
FREPTR: BLOCK 1 ;Tail,,head for free block list
PLINBP: BLOCK 2 ;Start of line in parser
PWSPBP: BLOCK 2 ;Byte pointer of start of line after whitespace
PCLNBP: BLOCK 2 ;Where there was a colon
PDELBP: BLOCK 2 ;Where there was a rubout
PDELB2: BLOCK 2 ;Where it ends
SDRHST: BLOCK 1 ;Sender host site
SDRNAM: BLOCK 2 ;Ptr/cnt to sender name
NXTSEQ: BLOCK 1 ;Ascending number in sequence for uniqueness
NETJFN: BLOCK 1 ;Network JFN
REQJFN: BLOCK 1 ;Requeue output JFN
FAIJFN: BLOCK 1 ;Failure message JFN
NTFJFN: BLOCK 1 ;Sender notify message JFN
HSHPAG: BLOCK 1 ;Page it is mapped into
HSHSIZ: BLOCK 1 ;Size of hash file
SITHSH: BLOCK 1 ;Hash for this site
TXTJFN: BLOCK 1 ;JFN for text file
CURDTM: BLOCK 1 ;Date/time when MMailr scan started
SCNTIM: BLOCK 1 ;Time to do file scan
SYSDIR: BLOCK 1 ;SYSTEM: directory
MLQDIR: BLOCK 1 ;MAILQ: directory
DIRNUM: BLOCK 1 ;Directory being hacked
MFLAGP: BLOCK 1 ;Are mailer flags mapped in?
TIMKIL: BLOCK 1 ;-1 if clock should be killed
TIMLOC: BLOCK 1 ;PC to go to on time-out
TIMRTP: BLOCK 1 ;Stack ptr for time-out return
INTOK: BLOCK 1 ;Neg if time-out interrupt active
INTPC: BLOCK 1 ;Interrupt PC
CTGCNT: BLOCK 1 ;# of ^G's typed
ICPTIM: BLOCK 1 ;ICP time-out countdown
HDRLEN: BLOCK 1 ;Number of characters in current header block
FILIDX: BLOCK 1 ;File tbl index for queued file type
OMLRBF: BLOCK 20 ;Buffer for address strings (old MAILER)
MBXFK: BLOCK 1 ;MMAILBOX.EXE fork handle
INUUO: BLOCK 1 ;Safety check to prevent recursive UUO's
NUPDL==100 ;Size of UUO PDL
UUOPDL: BLOCK NUPDL ;Pushdown list for processing UUO's
UUOACS: BLOCK 20 ;ACs saved over UUO
INTACS: BLOCK 20 ;ACs saved over level 1 interrupt
HSTBFL==^D30
HSTBUF: BLOCK HSTBFL ;Put string of a host here
AUTLEN==20 ;Length of author strings
FILAUT: BLOCK AUTLEN ;Place for msg file's author string
ORGAUT: BLOCK AUTLEN ;Vanilla author string
GTINF: BLOCK <.JIBAT-.JITNO+1> ;GETJI% stores data here
GTDLEN==.GTDML+10
GTDBLK: BLOCK GTDLEN+1 ;GTDOM% argument block
RLYBFL==5*HSTBFL
RLYBUF: BLOCK RLYBFL ;MX relays buffer
USRNUM: BLOCK 1
NTDEQF: BLOCK 1 ;Pos -- Notify sender if undeliverable
;Zero -- No action
;Neg -- Dequeue msg if undeliverable
IPCNT: BLOCK 1 ;Count of times we've MSEND%'d
IPCFOK: BLOCK 1 ;Non-zero if okay to bump interrupted PC
NOSLEP: BLOCK 1 ;Non-zero if we should skip DISMS
DOMTBL: BLOCK 1 ;Table of domains created by relay code
SNRLYS: BLOCK 1
SRLYTB: BLOCK 20 ;Table of domain block pointers
DNRLYS: BLOCK 1 ;In TRNMGR a call is used to build a path
DRLYTB: BLOCK 20 ; back to the host given a domain
;The destination domain is at offest 0
; will all the domain blocks back to our
; neighbor
PTHEND: BLOCK 1 ;The offset off of PTHLST containing the
; last host in the path
PTHLST: BLOCK 40 ;List of host relays that are in the path
STRBSZ==1000 ;Length of string buffers
STRBUF: BLOCK STRBSZ ;String buffer, used globally
STRBF1: BLOCK STRBSZ ;Alternative string buffer, used locally
STRBF2: BLOCK STRBSZ ;Another alternate buffer used locally
FRMMSG=STRBF2+<STRBSZ/2>
MEMEND==.-1 ;End of memory initialized at startup
PIDGET: IP%CPD ;Create a PID
0 ;Where the PID goes
0 ;For <SYSTEM>INFO
ENDPID-.,,.+1 ;Length,,address of message block
1,,.IPCII ;Ask to associate a name
0 ;No PID for copy
ASCIZ/[SYSTEM]MMAILR/ ;The name
ENDPID==.
IPCFMS: 0 ;Flags
0 ;Sender
0 ;Receiver
IPCFBL,,IPCFBF ;Length,,address of message block
IPCFBL==10 ;Size of IPCF buffer
IPCFBF: BLOCK IPCFBL ;Place for MRECV%/MUTIL% to write to
SDBLOK: 0 ;.SDPID - PID for local sends
T%RSYS!T%HDR ;.SDFLG - We build the header, obey REF SYS
; Site-selectable runtime flags
TRALLP: 0 ;-1 if transmogrification should always be done
; when crossing network registries even if the
; name is a domain name. However, Internet
; names are never transmogrified.
; 0 if transmogrification is suppressed if the
; name is a domain name.
PRINTP: 0 ;-1 to print activity messages
DEBUGP: 0 ;-1 if debugging network protocol
LOGP: 0 ;-1 if should make logs
STATP: 0 ;-1 if should keep statistics
;;;Non-zero pure data
UUOH: 0 ;UUO handler
JRST UUOH0
SAVACS: 0 ;AC save routine
JRST SAVAC0
LCLNAM: ASCIZ/TOPS-20/ ;Gets clobbered at initialization time
BLOCK LCLNAM+20-.
LCLNME==. ;End of local name (for padding purposes)
LCLNCN: BLOCK 20 ;Local name for current network
CHNTAB::PHASE 0
1,,TIMINT ;Time-out
1,,CTGINT ;^G typed
IPCHAN::!1,,IPCINT ;Handle IPCF interrupt
WAKCHN::!1,,WAKINT ;Process interrupt wakeup channel
REPEAT <^D36-.>,<0>
DEPHASE
; Sending protocol information
;
; SNDRT0 contains all the routines that MMailr might use.
;
; SNDRTS is a table (built from SNTRT0) of the routines
; it can use (because the monitor knows about them)
;
DEFINE DEFNT(PROT,NTDEV,SNDRTN)<
[[ASCIZ/PROT/],,SNDRTN],,[ASCIZ/NTDEV/]
>;DEFINE DEFNT
; These should be ordered by prefered priority of use
SNDRT0: DEFNT(Special,MAILS,SPCSND) ;Special (non-MMailr) network
DEFNT(TCP,TCP,INTSND) ;Internet
DEFNT(Chaos,CHA,CHASND) ;Chaosnet
DEFNT(Pup,PUP,PUPSND) ;Pup Ethernet
DEFNT(DECnet,DCN,DCNSND) ;DECnet
NSNDRS==.-SNDRT0
; Format of a SNDRTS table entry is <Protocol name>,,<routine>
;
SNDRTS: BLOCK NSNDRS ;Where we build the table
0 ;End of table marker
.ENDPS
SUBTTL Pure storage
.PSECT CODE,CODORG ;Enter code
LEVTAB::INTPC ;Priority level table
0
0
BITS:
...BIT==0
REPEAT <^D36>,<
1B<...BIT>
...BIT==...BIT+1
>;REPEAT <^D36>
;;; Various timer value definitions
RXMINT: INTRXM*^D<60*1000> ;RETRANSMIT file scan interval
SCNINT: INTSCN*^D<60*1000> ;File scan interval
NTFINT: NTDAYS,,0 ;Sender notify interval (internal fmt)
MAXQUE: DEDAYS,,0 ;Maximum time in the queue (internal fmt)
TMTINT: MAXTMT*^D1000 ;Max total transmission time (msec)
TMCINT: MAXTMC*^D1000 ;Max transmission time/copy (msec)
DAEDIR: ASCIZ/OPERATOR/ ;Directory DAEMON runs out of
MLAGNT: ASCIZ/Mailer/ ;Person handling mail problems
; Following are definitions and a table of file names/processing
; functions to handle delivery of various queued mail formats:
DEFINE FILXX(GSTR,BSTR,PRCHDR,PRCTXT,FLGS)<
%FLSTR==0
[ASCIZ `GSTR`],,[ASCIZ `BSTR`] ;File group name string
%FLPRC==1
PRCHDR,,PRCTXT ;Setup routines for processing
;header/text
%FLFLG==2
FLGS
%FLLEN==3
>;DEFINE FILXX
; Control flags for processing names
FF%OML==1B0 ;Old style queue file (adr in extension)
FF%RNM==1B1 ;Rename file with RETRANSMIT ext if requeued
FF%RXM==1B2 ;Only scan this file type every RXMINT minutes
FF%XNT==1B3 ;Don't notify sender of failures
FF%NEW==1B4 ;This is a new file with possible local recipients
FF%NET==1B5 ;This file is requeued from NEW
FILTBL: FILXX(<[--QUEUED-MAIL--].NEW*>,<[--BAD-QUEUED-MAIL--].>,GQUEQM,GQUEH1,FF%RNM!FF%NEW)
FILXX(<[--QUEUED-MAIL--].NETWORK>,<[--BAD-QUEUED-MAIL--].NETWORK>,GQUEQM,GQUEH1,FF%RNM!FF%NET)
FILXX(<[--QUEUED-MAIL--].RETRANSMIT>,<[--BAD-QUEUED-MAIL--].RETRANSMIT>,GQUEQM,GQUEH1,FF%RXM)
FILXX(<[--RETURNED-MAIL--].NEW*>,<[--BAD-RETURNED-MAIL--].>,GQUEQM,GQUEH1,FF%RNM!FF%XNT!FF%NEW)
FILXX(<[--RETURNED-MAIL--].NETWORK>,<[--BAD-RETURNED-MAIL--].>,GQUEQM,GQUEH1,FF%RNM!FF%XNT!FF%NET)
FILXX(<[--RETURNED-MAIL--].RETRANSMIT>,<[--BAD-RETURNED-MAIL--].RETRANSMIT>,GQUEQM,GQUEH1,FF%XNT!FF%RXM)
FILXX(<[--UNSENT-MAIL--].*>,</UNDELIVERABLE-MAIL/.>,GQUEUN,GQUEH0,FF%OML!FF%NEW)
FILXX(<]--UNSENT-NEGATIVE-ACKNOWLEDGEMENT--[.*>,</UNDELIVERABLE-MAIL/.>,GQUEUN,GQUEH0,FF%OML!FF%XNT)
NFTBL==<.-FILTBL>/%FLLEN
SUBTTL Main program
IFNDEF VI%DEC,< ;In case MACSYM is prior to release 6
VI%DEC==1B18
>;IFNDEC VI%DEC
; Program entry vector
ENTVEC: JRST MMAILR ;START
JRST MMAILR ;REENTER
VI%DEC!<FLD MMLWHO,VI%WHO>!<FLD MMLVER,VI%MAJ>!<FLD MMLMIN,VI%MIN>!<FLD MMLEDT,VI%EDN>
FRKTAB: PHASE 1
NEWFRK:!JRST MMLNLF ;Fork 1: First time deliver to local recipients
NETFRK:!JRST MMLNNF ;Fork 2: New network mail, fast scan
RXMFRK:!JRST MMLRXM ;Fork 3: Retransmitted mail, slow scan
DEPHASE
NFRKS==.-FRKTAB ;Number of forks
ENTVCL==.-ENTVEC ;Length of entry vector
;;;Fork 1: First time delivery to local recipients
MMLNLF: MOVEI A,NEWFRK ;Set logical fork number
MOVEM A,FORKX
SETOM NEWF ;Scan new mail
SETZM NETF ;Don't deliver to network recipients
SETZM RXMF ;Don't scan retransmit mail
SETOM FSTF ;Cache dead hosts (doesn't matter here)
SETOM DAEMNP ;We are the daemon
SETOM WOPRP ;Also, we must have been WHEEL or OPERATOR
JRST MAILR1 ;Enter main program
;;;Fork 2: First time delivery to network recipients
MMLNNF: MOVEI A,NETFRK ;Set logical fork number
MOVEM A,FORKX
SETZM NEWF ;Don't scan new mail
SETOM NETF ;Deliver to network recipients
SETZM RXMF ;Don't scan retransmit mail
SETOM FSTF ;Cache dead hosts
SETOM DAEMNP ;We are the daemon
SETOM WOPRP ;Also, we must have been WHEEL or OPERATOR
JRST MAILR1 ;Enter main program
;;;Fork 3: Slow scan through the RETRANSMIT queue
MMLRXM: MOVEI A,RXMFRK ;Set logical fork number
MOVEM A,FORKX
SETZM NEWF ;Don't scan new mail
SETOM NETF ;Deliver to network recipients
SETOM RXMF ;Scan retransmit mail
SETZM FSTF ;Don't cache dead hosts
SETOM DAEMNP ;We are the daemon
SETOM WOPRP ;Also, we must have been WHEEL or OPERATOR
JRST MAILR1 ;Enter main program
;;;Mother fork start
MMAILR: DO.
GTAD% ;a =: date/time
AOSE A ;Set yet?
IFSKP.
MOVEI A,^D5000 ;No, wait 5 sec
DISMS%
LOOP. ;And try again
ENDIF.
ENDDO.
SETZM FORKX ;This is top fork
SETOM NEWF ;Assume scan new mail
SETOM NETF ;Assume deliver to network recipients
SETOM RXMF ;Assume scan retransmit mail
SETOM FSTF ;Assume cache dead hosts
SETZM DAEMNP ;Assume not the Daemon
SETOM PRINTP ;Assume print all messages
JSP CX,INIT ;Init the world
MOVX A,.FHSLF
RPCAP% ;Get our capabilities
IFXN. B,SC%WHL!SC%OPR ;WHEEL or OPERATOR?
SETOM WOPRP ;Yes, flag so
IOR C,B ;Enable everything we've got
EPCAP%
MOVX A,RC%EMO ;Now see if we're the Daemon (must be priv'd)
HRROI B,DAEDIR ;b =: dir Daemon runs out of
RCUSR%
MOVE T,C
GJINF%
DAEPAT:! ;;;Patch this location to NOP to force Daemon
CAMN A,T ;Are we logged in as the Daemon user?
SETOM DAEMNP ;Yes, we're the Daemon
ENDIF.
SKIPN DAEMNP ;Are we the daemon?
JRST MAILR2 ;No - run main program
;;; Mother fork
CALL WAKTOP ;Set up for passing on wakeup interrupts
MOVSI X,-NFRKS ;Set up fork count
DO.
MOVX A,CR%CAP ;Make an inferior fork, pass down capabilities
CFORK%
IFJER.
JFATAL <?Can't create MMailr daughter fork>
HALTF% ;Punt
JRST MMAILR ;Restart on CONTINUE
ENDIF.
MOVEM A,FHTAB(X) ;Save daughter's fork handle
SETZ T, ;Reset page index
DO.
MOVE A,T ;Get the page number
HRLI A,.FHSLF ;This fork
RMAP% ;Read page access
IFXN. B,RM%PEX ;Does page exist?
MOVE C,B ;Yes, get its access bits
ANDX C,RM%RD!RM%WR!RM%EX!RM%CPY ;Turn off unwanted bits
TXZE C,RM%WR ;Does this page have write access?
TXO C,RM%CPY ;Yes, set copy-on-write for daughters
MOVE A,T ;Get page number
HRLI A,.FHSLF ;This fork
MOVE B,T ;For destination also
HRL B,FHTAB(X) ;New fork handle
PMAP% ;Map the page
ENDIF.
CAIGE T,777 ;At last page?
AOJA T,TOP. ;No so keep going
ENDDO.
MOVE A,FHTAB(X) ;Start daughter fork
MOVEI B,FRKTAB(X) ;At specified address
SFORK%
AOBJN X,TOP. ;Start next fork
ENDDO.
DO.
MOVSI X,-NFRKS ;Set up
DO.
MOVE A,FHTAB(X) ;Get fork handle
RFSTS% ;Check its status
LOAD A,RF%STS,A ;Not interested in PSI or frozen flag
CAIE A,.RFHLT ;If HALTF%, treat like blew up
CAIN A,.RFFPT ;Forced process termination?
IFNSK.
MOVEI A,1(X) ;Get fork index
CETYPE <Fork %1O halted at >
MOVEI T,-1(B) ;Get PC
CALL SYMOUT ;Output symbolically
MOVE A,FHTAB(X) ;Get fork handle
GETER% ;Get last error of this process
ETYPE <, last error: %2E, ...restarting
>
MOVE A,FHTAB(X) ;Get fork handle again
MOVEI B,CRASH ;Get it to dump and reboot
SFORK%
ENDIF.
AOBJN X,TOP. ;Otherwise looks good, try next
ENDDO.
MOVX A,^D<5*60*1000> ;Wait five minutes between checks
DISMS%
LOOP.
ENDDO.
MAILR1: JSP CX,INIT ;Initialize the world
MOVX A,^D<2*60*1000> ;Wait two minutes for the network to stabilize
DISMS%
MAILR2: MOVEI A,.FHSLF ;Set up PSI
MOVE B,[LEVTAB,,CHNTAB]
SIR%
EIR%
MOVX B,1B0 ;Set up for channel 0 to interrupt
AIC%
TMOCLR ;No time-out interrupts, please
;
; Place initial entries in our host table
;
MOVEI A,HTBLSZ ;Maximum number of hosts we can handle at once
MOVEM A,HSTTBL ;Init the table
CALL INICNX ;Figure out the protocols we speak
HRROI A,LCLNAM ;Try to get local host name for Internet
CALL $GTLCL ;Get local host name
FATAL <Can't get local host name>
MOVEI A,HSTTBL ;Add it to our host table
MOVSI B,LCLNAM
TBADD%
MOVX B,HF%PRM ;Mark it permanent
IORM B,(A)
MOVEI A,ALCBLK ;Set up routines for use by relay code
MOVEI B,PRMHST
CALL $INRLY ;Init relay tables
MOVEM A,DOMTBL ;Save table of domains it made
JSP CX,SETTIM ;Set the timer up
SKIPE DAEMNP ;Are we the Daemon?
IFSKP.
MOVEI A,.FHSLF ;No, set up ^G interrupt
MOVX B,1B1
AIC%
MOVE A,[.TICCG,,1]
ATI%
SETOM PRINTP ;Print all messages
GTAD% ;Log current date/time
MOVEM A,CURDTM
MOVE B,MYDIRN ;Get connected directory
CAMN B,MYLDIR ;Login same as connected?
IFSKP.
CALL DODIR ;Do connected first
CALL CRIF
MOVE B,MYLDIR ;Get login directory
ENDIF.
CALL DODIR ;Do login
HALTF%
JRST MMAILR ;Restart totally if continue
ENDIF.
; falls through
SUBTTL Background operator task
; drops in
SETZM PRINTP ;Don't print detailed logs
SKIPE DEBUGP ;Unless debugging
SETOM PRINTP ;Want detailed logs
MOVX A,RC%EMO ;No MAILQ:, use SYSTEM:
HRROI B,[ASCIZ/SYSTEM:/]
RCDIR%
TXNE A,RC%NOM!RC%AMB ;Anything go wrong?
SETZ C, ;This shouldn't happen
MOVEM C,SYSDIR ;Save SYSTEM: directory
MOVX A,RC%EMO ;Look up MAILQ:
HRROI B,[ASCIZ/MAILQ:/]
RCDIR%
TXNE A,RC%NOM!RC%AMB ;Anything go wrong?
MOVE C,SYSDIR ;Yes, use SYSTEM: directory instead
MOVEM C,MLQDIR ;Set directory to check every time
MOVEI A,.FHSLF
SETOB C,B
EPCAP%
CALL MAPFLG ;Map in the mailer flags
JWARN <Failed to map MAILER flags>
; falls through
; drops in
;;;This is the main daemon loop
DO.
SKIPN LOGP ;Should make logs?
IFSKP. ;Yes
SETOM PRINTP ;Want details
DO.
MOVE A,[POINT 7,STRBUF]
MOVEI B,[ASCIZ/MAIL:/]
CALL MOVSTR
MOVE B,FORKX ;Fork handle
MOVX C,^D8
NOUT%
JFATAL
MOVEI B,[ASCIZ/-MMAILR.LOG/]
CALL MOVST0
HRROI B,STRBUF
MOVX A,GJ%SHT
GTJFN%
IFJER.
CAIE A,GJFX24 ;Work around monitor bug
JWARN <Cannot get LOG file>
MOVX A,^D5000 ;Wait 5 seconds
DISMS%
LOOP.
ENDIF.
MOVEM A,LOGJFN
MOVX B,<<FLD ^D7,OF%BSZ>!OF%APP>
OPENF%
IFJER.
PUSH P,A ;Save error code
MOVE A,LOGJFN ;Recover JFN
RLJFN% ;Release it
JWARN
SETZM LOGJFN ;Clear log JFN
MOVX A,^D5000 ;Wait a few seconds
DISMS%
POP P,A ;Recover error code
CAIN A,OPNX9 ;No error if file just busy
LOOP.
CAIE A,OPNX2 ;File disappeared?
WARN <Cannot open log file - %1E>
LOOP.
ENDIF.
ENDDO.
MOVEI B,(A) ;B := Nul,,log
HRLI B,.NULIO
MOVX A,.FHSLF ;Set primary JFNs for this fork
SPJFN%
ENDIF.
SKIPN STATP ;Taking statistics?
IFSKP.
DO.
MOVE A,[POINT 7,STRBUF]
MOVEI B,[ASCIZ/MAIL:/]
CALL MOVSTR
MOVE B,FORKX ;Fork handle
MOVX C,^D8
NOUT%
JFATAL
MOVEI B,[ASCIZ/-MMAILR.STAT/]
CALL MOVST0
HRROI B,STRBUF
MOVX A,GJ%SHT
GTJFN%
IFJER.
CAIE A,GJFX24 ;Work around monitor bug
JWARN <Cannot get STAT file>
MOVX A,^D5000 ;Wait 5 seconds
DISMS%
LOOP.
ENDIF.
MOVEM A,STAJFN
MOVX B,<<FLD ^D7,OF%BSZ>!OF%APP>
OPENF%
IFJER.
PUSH P,A ;Save error code
MOVE A,STAJFN ;Recover JFN
RLJFN% ;Release it
JWARN
SETZM STAJFN ;Clear STAT JFN
MOVEI A,^D5000 ;Wait a few seconds
DISMS%
POP P,A ;Recover error code
CAIN A,OPNX9 ;No error if file just busy
LOOP.
CAIE A,OPNX2 ;File disappeared?
WARN <Cannot open STAT file - %1E>
LOOP.
ENDIF.
ENDDO.
ENDIF.
; falls through
; drops in
CITYPE <Daemon wakeup>
CALL NDHOST ;Clear dead host list
AOSE TIMKIL ;If clock got killed restart it
JSP CX,SETTIM
CALL WAKINI ;Set up wakeup interrupt
SKIPE A,FORKX ;Initialize IPCF if fork 0 (single fork) or
CAIN A,1 ; fork 1 (first time requests). This is here
CALL IPCINI ; so we retry every scan if failed
SKIPN IPCFON ;IPCF on?
IFSKP.
JSP C,IPCHEK ;Yes, check the queue
IFSKP.
CIETYP <Clearing IPCF queue...> ;Log this
MOVEI A,.FHSLF ;Now fake an IPCF delivery
MOVX B,1B<IPCHAN>
IIC%
ENDIF.
ENDIF.
GTAD% ;Log current date/time
MOVEM A,CURDTM
TIME% ;Get time
SKIPN RXMF ;Scanning retransmit files?
IFSKP.
ADD A,RXMINT ;Yes, wait longer between wakeups
ELSE.
ADD A,SCNINT ;Normal scan interval
ENDIF.
MOVEM A,SCNTIM ;Set time to scan again
; falls through
; drops in
SKIPL MFLAGP ;Have mailer flags to do?
IFSKP.
MOVSI A,-1000
DO.
SKIPN B,FLGPAG(A) ;Find a word with bit set
IFSKP.
DO.
JFFO B,.+2 ;Get bit position
EXIT. ;Last bit in this word
PUSH P,A ;Found a directory, do it
PUSH P,B
MOVNI D,(C) ;Negative bit number
MOVX B,1B0
LSH B,(D) ;Make bit to clear
ANDCAM B,FLGPAG(A) ;Clear it in flag page
ANDCAM B,(P) ;And in saved word
MOVEI B,(A)
IMULI B,^D36
ADDI B,(C) ;Compute directory to do
HLL B,MYLDIR
CAME B,MLQDIR ;We'll do MAILQ: below
CAMN B,SYSDIR ;Ditto SYSTEM:
CAIA
CALL DODIR
POP P,B
POP P,A
LOOP.
ENDDO.
ENDIF.
AOBJN A,TOP.
ENDDO.
ENDIF.
; falls through
; drops in
SKIPN B,MLQDIR ;Scan the MAILQ: directory
IFSKP.
CALL DODIRX
MOVX A,DD%DTF+DD%DNF ;Deleting ;T and non-existent files
MOVE B,MLQDIR ;Now, expunge the directory
DELDF%
IFJER.
JWARN <Expunging MAILQ: failed>
ENDIF.
ENDIF.
SKIPE B,SYSDIR ;Scan the SYSTEM: directory
CAMN B,MLQDIR ;Only if it is different from MAILQ:
IFSKP.
CALL DODIRX ;It is, scan it
MOVX A,DD%DTF+DD%DNF ;Deleting ;T and non-existent files
MOVE B,SYSDIR ;Now, expunge the directory
DELDF%
IFJER.
JWARN <Expunging SYSTEM: failed>
ENDIF.
ENDIF.
MOVX A,.FHSLF ;Restore primaries
SETO B,
SPJFN%
SKIPN A,LOGJFN ;Close log file
IFSKP.
CLOSF%
JFATAL <Unable to close log file>
SETZM LOGJFN
ENDIF.
SKIPN A,STAJFN ;Close statistics file
IFSKP.
CLOSF%
JFATAL <Unable to close STAT file>
SETZM STAJFN
ENDIF.
TIME% ;Current time
EXCH A,SCNTIM ;Time to do scan
SUB A,SCNTIM
IFG. A ;Sleep only if time left in this interval
SKIPN RXMF ;Scanning retransmit files?
IFSKP.
CAMLE A,RXMINT ;Paranoia
MOVE A,RXMINT
ELSE.
CAMLE A,SCNINT ;Paranoia
MOVE A,SCNINT
ENDIF.
SETOM TIMKIL ;Kill the clock
SETOM IPCFOK ;Indicate IPCF interrupts are OK to grant
SKIPN NOSLEP ;Okay to sleep?
DISMS%
NOP ;In case of interrupts
SETZM IPCFOK ;Indicate IPCF interrupts not allowed
SETZM NOSLEP ;Allowed to DISMS% now
ENDIF.
LOOP.
ENDDO.
; Here to process files in a directory
DODIR: CIETYP <Trying %2U...>
DODIRX: MOVEM B,DIRNUM ;Save directory number
MOVE A,[-NFTBL,,FILTBL] ;Init file type index
SETZM DODJFN ;Initially no current group JFN
DO. ;For each group
SKIPE DODJFN ;Have a current JFN defined?
IFSKP. ;No current JFN defined
MOVEM A,FILIDX ;Save file flags index
HRROI A,STRBUF ;Build filename here
MOVE B,DIRNUM ;Start with desired directory
DIRST%
ERJMP ENDLP. ;No such directory, can't do anything
MOVE B,FILIDX ;b =: ptr to current file type string
HLRZ B,%FLSTR(B)
CALL MOVST0
MOVE A,[GJ%IFG!GJ%OLD!GJ%SHT+.GJALL]
HRROI B,STRBUF
GTJFN% ;See if file group found
IFNJE.
MOVEM A,DODJFN ;Save JFN
DO.
MOVE A,FILIDX ;Get pointer to file type string
MOVE A,%FLFLG(A) ;Get flags for this group
IFXN. A,FF%NEW ;Is this a new file?
SKIPE NEWF ;Allowed to do new files?
EXIT. ;Yes, do it
ELSE. ;Not new file
SKIPN NETF ;Allowed to do network I/O?
IFSKP. ;Network I/O ok
IFXN. A,FF%RXM ;Is this a retransmit file?
SKIPE RXMF ;Allowed to do retransmit files?
EXIT. ;Yes, do it
ELSE. ;Not retransmit file, assume 1st time net file
SKIPE FSTF ;Doing fast 1st time net mail delivery?
EXIT. ;Yes, do it
ENDIF. ;End retransmit file test
ENDIF. ;End network I/O okay
ENDIF. ;End test of group type
CALL MAIFLG ;Not allowed to do it, make sure mailer knows
HRRZ A,DODJFN ;Now flush this JFN
RLJFN%
NOP
SETZM DODJFN ;Don't try to do this group
ENDDO. ;End validate need to do this group
ENDIF. ;End found files matching this group
ENDIF. ;End no current JFN defined
SKIPN A,DODJFN ;Current JFN defined
IFSKP. ;Process current file for this JFN
DO.
HRRZS A
CALL GETQUE
JRST [TYPE <...queue map failed...requeued>
CALL MAIFLG ;Make sure mailer knows
EXIT.]
JRST [TYPE <...bad file format>
CALL MAIFLG ;Make sure mailer knows
EXIT.]
SETZM NTDEQF ;Clear dequeue flag
MOVE B,FILIDX ;Notify sender about this file type?
MOVE B,%FLFLG(B)
IFXE. B,FF%XNT
SKIPN A,MSGNTF(M) ;Sender notify time given?
IFSKP.
CAMGE A,CURDTM ;Yes, time to squawk if undeliverable?
AOS NTDEQF ;Yes, flag to send notification
ENDIF.
ENDIF.
SKIPN A,MSGDEQ(M) ;Dequeue time given?
IFSKP.
CAML A,MSGAFT(M) ;Yes, dequeue time before after time?
IFSKP.
MOVE A,MSGAFT(M) ;Yes, don't be absurd! Use after time
CAMG A,CURDTM ;Unless it's before now
MOVE A,CURDTM ;In which case we'll use the time now
ADD A,MAXQUE ;Plus interval
MOVEM A,MSGDEQ(M) ;Set corrected dequeue time
ENDIF.
CAMGE A,CURDTM ;Time to dequeue this file?
SETOM NTDEQF ;One more try, then dequeue failures
ENDIF.
CALL FWDLCL
MOVE A,MSGAFT(M) ;Get after parameter, if any
CAMLE A,CURDTM ;Time to do this message yet?
IFSKP.
PUSH P,MSGTMT(M) ;Yes, no overall time limits on locals
SETZM MSGTMT(M)
CALL SNDLCL ;Always try local recipients
IFNSK.
ADJSP P,-1 ;Reset stack
TYPE <...bad file format>
CALL MAIFLG ;Make sure mailer knows
EXIT.
ENDIF.
POP P,MSGTMT(M) ;Restore global delivery timeout
CALL SNDMSG ;Deliver the message
IFNSK.
TYPE <...bad file format>
CALL MAIFLG ;Make sure mailer knows
EXIT.
ENDIF.
SKIPE NETF ;If no net sends hold off on this
SETZM MSGDOP(M) ;Next time use MAIL to deliver this message
ELSE.
CIETYP < Processing of recipients deferred until %1T>
MOVEI A,MSGLCL(M) ;Pointer to local mail
DO. ;Flag "temporary" failure to fake out REMAIL
HRRZ B,(A)
IFN. B
MOVX C,FR%TMP
IORM C,RCPFLG(B)
MOVEI A,(B)
LOOP.
ENDIF.
ENDDO.
ENDIF.
CALL REMAIL ;Requeue or send failure
CALL RELQUE
CITYPE < Done, >
SKIPN REQJFN ;Was something requeued?
IFSKP.
TYPE <requeued>
CALL MAIFLG ;Make sure mailer knows
MOVE A,FILIDX ;Was the file renamed too?
MOVE A,%FLFLG(A)
IFXN. A,FF%RNM!FF%OML
HRRZ A,DODJFN ;Yes. GNJFN% fails if current file renamed
RLJFN% ;Release this jfn
JWARN
SETZM DODJFN
MOVE A,FILIDX ;Get current group
ADJSP A,-1 ;Back up group so iteration redos this one
SUBI A,%FLLEN-1
MOVEM A,FILIDX ;Now store it
ENDIF.
ELSE.
TYPE <deleting>
HRRZ A,DODJFN
TXO A,DF%NRJ
DELF%
JWARN <DELETE failed>
ENDIF.
CALL HSTCLR ;Clean up the host table
ENDDO.
ENDIF. ;End processing for this file
SKIPN A,DODJFN ;Get JFN back
IFSKP.
GNJFN% ;See if another file in this group
IFNJE.
LOOP. ;Another file, do it
ENDIF.
SETZM DODJFN ;No more JFNs in this group
ENDIF.
MOVE A,FILIDX ;a =: current file type index
ADDI A,%FLLEN-1 ;Step to next one
AOBJN A,TOP. ;And do next group if more to do
ENDDO. ;End of per-group processing
RET
INIT: RESET% ;Flush all I/O
MOVE P,[IOWD NPDL,PDL] ;Establish stack
SETZB F,MEMBEG ;Clear out impure storage
MOVE A,[MEMBEG,,MEMBEG+1]
BLT A,MEMEND
SETOM INUUO ;Init recursive UUO flag
GJINF%
MOVEM A,MYUSRN ;Save user number
MOVEM B,MYDIRN ;Save connected directory number
MOVEM C,MYJOBN ;Save job number
SETZ A, ;Get login directory
MOVE B,MYUSRN ;My user number
RCDIR%
MOVEM C,MYLDIR ;My logged-in directory
HRROI A,[ASCIZ/POBOX:/] ;Get post office box structure
STDEV%
IFJER.
HRROI A,STRBUF ;Failed, get logged-in directory string
MOVE B,MYLDIR ;From logged-in directory
DIRST%
JFATAL
HRROI A,STRBUF ;Now get its device designator
STDEV%
JFATAL
DEVST% ;Now get just its device name
JFATAL
MOVX B,":" ;Append the device delimiter
IDPB B,A
SETZ B, ;Now null-terminate it
IDPB B,A
MOVX A,.CLNSY ;Create systemwide logical name
HRROI B,[ASCIZ/POBOX/] ; for POBOX:
HRROI C,STRBUF ;From login structure
CIETYP <[POBOX: not found, defining as %3W]
>
CRLNM%
JFATAL
ENDIF.
JRST (CX)
SUBTTL Get atom from file routine
;;; Read atom into string buffer in C, from open JFN in A.
;;; Always pads to word boundaries, uppercasing.
FILATM: BIN%
ERJMP FILAT1 ;Done on EOF
JUMPE B,FILAT1 ; or on NUL
CAIE B,.CHLFD ; or LF
CAIN B,.CHSPC ; or space
JRST FILAT1
CAIN B,.CHCRT ; or CR
JRST FILAT3
CAIL B,"a"
CAILE B,"z"
CAIA
SUBI B,"a"-"A"
IDPB B,C ;Else, add it
JRST FILATM
FILAT3: BIN% ;CR, flush LF too
FILAT1: SETZ B, ;Tie off local name
FILAT2: IDPB B,C
TXNE C,76B4
JRST FILAT2
RET
; Routine to scan the possible sending routines, and remove
; those that the monitor doesn't know about.
; Create a protocol table for later use in mail sending
;
; Return: +1
INICNX: MOVX T,<-NSNDRS,,SNDRT0> ;Number of possible sending routines
MOVEI TT,SNDRTS ;Table of allowed sending routines
DO.
HRRO A,(T) ;a := ptr to dev name for this net
STDEV% ;Local system know about it?
IFNJE.
HLRZ A,(T) ;Get the data address
MOVE A,(A) ;And the data
MOVEM A,(TT) ;Save
AOS TT ;Increment table
ENDIF.
AOBJN T,TOP.
ENDDO.
SETZM (TT) ;End of table marker
RET ;Yes
SUBTTL Memory allocation
;;; Bit table hacking, page number in A for all
PAGSBT: PUSH P,[IORM B,(A)] ;Set bit
JRST PAGHBT
PAGCBT: PUSH P,[ANDCAM B,(A)] ;Clear bit
JRST PAGHBT
PAGTBT: PUSH P,[TDNE B,(A)] ;Skip if bit clear
PAGHBT: PUSH P,A
PUSH P,B
SUBI A,FSPAG ;Make relative to start of bit table
IDIVI A,^D36
MOVEI A,PAGTBL(A) ;Point to right word
MOVE B,BITS(B) ;Get right bit
XCT -2(P)
SKIPA
AOS -3(P)
POP P,B
POP P,A
ADJSP P,-1
RET
;;; Allocate number of pages in A, returns +1 failure, +2 page number in B
PAGAL1: MOVEI A,1 ;Allocate one page
PAGALC: PUSH P,C
PUSH P,A ;Save number of pages we need
MOVEI B,FSPAG ;Starting free page
PAGALB: CALL PAGFFP ;Fast search for first free page
JRST POPACJ ;Failure, just return
MOVEI A,1(B)
MOVE C,(P) ;Get number of pages to hack again
PAGALL: SOJLE C,PAGALW ;Got enough, return address from b
CAIL A,1000 ;Page number too big?
JRST POPACJ ;Yes, fail
CALL PAGTBT ;Is this bit set?
IFNSK.
MOVEI B,1(A) ;Try for next free page
JRST PAGALB
ENDIF.
AOJA A,PAGALL ;Try for next match
PAGALW: MOVE C,(P)
MOVEI A,(B)
PAGAW1: CALL PAGSBT ;Allocate one page
SOJLE C,POPAC1
AOJA A,PAGAW1
POPAC1: AOS -2(P) ;Winning return
POPACJ: POP P,A
POP P,C
RET
;;; Deallocate pages, number in A, starting page in B
PAGDA1: MOVEI A,1 ;Deallocate one page
PAGDAL: PUSH P,A
PUSH P,B
PUSH P,C
EXCH A,B ;Setup for page number in A
PAGDA2: SOJL B,PAGDA3
CALL PAGCBT ;Clear one bit
AOJA A,PAGDA2
PAGDA3: SETO A,
MOVE B,-1(P) ;Starting page
HRLI B,.FHSLF
HRRZ C,-2(P) ;Count
TXO C,PM%CNT
PMAP% ;Flush those pages
POP P,C
POPBAJ: POP P,B
CPOPAJ: POP P,A
RET
;;; Fast search for the first free bit, starting page in B
;;; Returns +1 failure, +2 with page number in B
PAGFFP: SUBI B,FSPAG ;Make relative to start of bit table
IDIVI B,^D36
SETCM A,PAGTBL(B) ;Get first word to check
LSH A,(C)
MOVNI C,(C)
LSH A,(C) ;Clear out random bits to left
SKIPA C,B ;Starting word index
PAGFF1: SETCM A,PAGTBL(C) ;Get word to check
JFFO A,PAGFF2 ;Got any ones?
CAIL C,PGTBLL ;No - beyond last word?
RET ;Failed
AOJA C,PAGFF1 ;No, search for next word
PAGFF2: IMULI C,^D36 ;Number of bits passed
ADDI B,FSPAG(C) ;Final winning page number
CAIL B,1000 ;Was page valid?
RET ;No
RETSKP
; Routine to unmap memory buffer pages currently in use
; Entry: pagtbl = bitmap for pages in use
; Call: CALL CLRPTB
; Return: +1
CLRPTB: SETO A, ;Unmap special prebuffer pages
MOVSI B,.FHSLF
SETZ C,
HRRI B,<FLGPAG/1000> ;Do FLAGS page
PMAP%
HRRI B,<TMPBUF/1000> ;Do MMAILBOX buffer page
MOVX C,PM%CNT!2 ;Unmap both temp pages
PMAP%
HRRI B,<FWDWIN/1000>
PMAP%
MOVSI T,-PGTBLL ;t =: aobjn ptr to PAGTBL
CLRPT0: SKIPE A,PAGTBL(T) ;Any bits in this entry?
JFFO A,CLRPT1 ;Yes, scan for 1st one
AOBJN T,CLRPT0 ;No more, try next word
RET ;Done
; Here to unmap a page flagged in PAGTBL
; Entry: t = ptr to PAGTBL word for page
; b = count of flag bit position for page
CLRPT1: MOVEI C,0(T) ;c =: PAGTBL word index
IMULI C,^D36 ;c =: page count for prior wds in table
ADDI B,FSPAG(C) ;b =: memory page number
CAIL B,1000 ;Legal page?
FATAL <CLRPTB: Invalid page table bit set>
CALL PAGDA1 ;Deallocate this page
JRST CLRPT0 ;Look for more to do
;;; Map in a file, given name in B,
;;; Returns +1 failure, +2 success, starting address in B,
;;; number of bytes in C, start,,count in D
MAPQFL: PUSH P,[OF%RD!OF%WR!OF%PDT]
SKIPA ;Try for write too first, save dates for queue
MAPFIL: PUSH P,[OF%RD] ;Normally try just read
MOVX A,GJ%OLD!GJ%SHT
GTJFN%
IFJER.
ADJSP P,-1
RET
ENDIF.
CIETYP < File %1J:>
MOVE B,(P) ;Get OPENF% flags
PUSH P,A ;Save the jfn
OPENF%
ERJMP MPFLOE
MAPFL1: SIZEF%
ERJMP MPFLE1
PUSH P,B ;Save number of bytes
MOVEI A,(C) ;Number of pages needed for whole file
CALL PAGALC ;Allocate them
IFNSK.
MOVE B,-2(P) ;Get starting OPENF% bits
TXNN B,OF%PDT ;From MAPQFL call?
JRST MAPFLE ;No, just fail return
JRST MAPQFE ;Make "Bad Mail" file
ENDIF.
HRLZ A,-1(P) ;Start with page 0 of file
HRLI B,.FHSLF
HRLI C,(PM%CNT!PM%RD!PM%CPY)
PMAP%
ERJMP MAPFLE
HRLI C,(B)
MOVS D,C ;Count,,start
LSH B,9 ;Make page number into address
POP P,C ;Count of bytes
POP P,-1(P) ;Move the jfn down on the stack
POPA1J: POP P,A
RETSKP
;; Here on error mapping file
MAPFLE: ADJSP P,-1 ;Clear byte count
MPFLE1: POP P,A ;Recover JFN
CLOSF%
JWARN
ADJSP P,-1 ;Clear OPENF% bits
RET
;; Here when mail file is too big. C = # of pages
MAPQFE: ADJSP P,-1 ;Clear byte count
POP P,A ;Recover JFN
ADJSP P,-1 ;Clear OPENF% bits
MOVE B,DIRNUM ;Directory number
WARN <MAPQFL: %2U%1J too big - %4D pgs.>
TXO A,CO%NRJ ;Close it but keep the JFN
CLOSF%
JFATAL
HRRZS A ;Just JFN again
CALL RENBAX ;Rename to bad mail file
MOVEI B,STRBUF ;Ptr to name of new file
WARN < Renamed to %2W>
RET
;; Here if OPENF% fails for file
MPFLOE: CAIE A,OPNX9 ;If not invalid simultaneous access
TXNN B,OF%WR ;And asking for write
JRST MPFOE1
MOVE A,(P) ;Try once more
MOVEI B,OF%RD ;With just read
OPENF%
ERJMP MPFOE1
JRST MAPFL1 ;Succeeded this way, use it
MPFOE1: POP P,A
RLJFN%
JWARN
ADJSP P,-1 ;Clear OPENF% bits
RET
;;; Free storage
;;; Format of free list is FREHDR,,forward-link ? size,,backward-link ...
;;; ... FRETAI,,0
;;; format of allocated entry is ALCHDR,,size ? ... ? ALCTAI,,0
FREHDR==<SIXBIT / FRE/>
FRETAI==<SIXBIT / ERF/>
ALCHDR==<SIXBIT / ALC/>
ALCTAI==<SIXBIT / CLA/>
;;; Routine to check the integrity of a free space block. Requires the
;;; header and tail to match and the tail to point to the header
; Entry: b = adr of block to check
; Call: CALL CHKBLK
; Return: +1, block format is bad
; +2, format OK - allocated block
; +3, format OK - free block
CHKBLK: HLRZ T,(B) ;t =: block header type
CAIN T,FREHDR ;Free block?
JRST CHKBLF ;Yes, check the rest
CAIE T,ALCHDR ;Allocated block?
RET ;No???
HRRZ T,0(B) ;t =: size of allocated block
ADDI T,1(B) ;t =: adr of tail word
HLRZ TT,0(T) ;tt =: block tail type
HRRZ T,0(T) ;t =: ptr to head
CAIN TT,ALCTAI ;Allocated block tail?
CAIE T,0(B) ;And ptr really to head of block?
RET ;No???
RETSKP ;Good allocated block, return +2
;;; Here to check out a free block tail
CHKBLF: HLRZ T,1(B) ;t =: size of free block
ADDI T,1(B) ;t =: adr of tail word
HLRZ TT,0(T) ;tt =: block tail type
HRRZ T,0(T) ;t =: ptr to head
CAIN TT,FRETAI ;Free block tail?
CAIE T,0(B) ;And ptr really to head of block?
RET ;No???
R2SKP: AOS (P) ;Do one skip
JRST RSKP ;and then a normal skip return
;;; Allocate a block, given size in A,
;;; Returns +1 failure, +2 address of block in B, real size in A
ALCBLK: JSR SAVACS ;Save all ACs
CAIGE A,5 ;Minimum size
MOVEI A,5
MOVEI C,FREPTR ;Start by pointing to free list
ALCBLL: HRRZ B,(C) ;Get link word
JUMPE B,ALCBPG ;End of list, need a whole new page
HLRZ D,1(B) ;Size of free block
CAIL D,(A) ;Large enough?
JRST ALCBLF ;Yes, found winner
MOVEI C,(B) ;Too small, setup to try next one
JRST ALCBLL
;; Now have block in B, previous in C, size in D, user's size still in A
ALCBLF: CALL CHKBLK ;Check block integrity
NOP ;+1, block type bad
FATAL <ALCBLK: Free list screwed up> ;+2, allocated block
CAIG D,5(A) ;Size close enough to desired?
JRST ALCBLR ;Yes, no need to split
MOVEI E,(B) ;Get copy of address of block
HRLM A,1(B) ;Store new size of block to be returned
ADDI E,2(A) ;Address of start of other block
HRRZ T,(B) ;Old forward link
HRRM E,(B) ;Second is forward link for first one
IFE. T
HRLM E,FREPTR
ELSE.
HRRM E,1(T)
ENDIF.
HRLI T,FREHDR
MOVEM T,(E) ;Old forward is forward link of second block
MOVSI T,FRETAI
HRRI T,(B)
MOVEM T,-1(E) ;Store end of first block
SUBI D,2(A) ;New size of rest of block
EXCH D,A ;D should have size of block we are returning
HRLI A,(B)
MOVSM A,1(E) ;Backward link of second block is first block
ADDI A,1(E)
HRRM E,(A) ;Update pointer to start of block
ALCBLR: HRRZ T,(B) ;Forward link of this block
HRRM T,(C) ;Becomes forward link of our backward link
IFE. T
HRLM C,FREPTR
ELSE.
HRRM C,1(T) ;Its backward link is our former backward link
ENDIF.
MOVEM D,A-ACBASE(P) ;Return real size in A
MOVSI T,ALCHDR
HRRI T,(D)
MOVEM T,(B)
ADDI B,1 ;User should see block, not header
MOVEM B,B-ACBASE(P) ;Return address in B
MOVSI A,0(B) ;Compose BLT pointer to clear block
HRRI A,1(B)
SETZM 0(B) ;Clear first word
ADDI B,(D) ;Address of end
CAIL D,2 ;If multiple words,
BLT A,-1(B) ; clear rest of block
MOVEI T,ALCTAI
HRLM T,(B) ;Mark end as used too
RETSKP ;Skip return
;; Need to allocate a whole other page
ALCBPG: PUSH P,A ;Save desired size
ADDI A,1003 ;Round to page and have room for headers
LSH A,-9 ;Get number of pages needed
CALL PAGALC ;Get that many
JRST CPOPAJ ;Failed, return failure to whole thing
LSH B,9 ;Make address out of it
HRRM B,(C) ;Link onto end of list
HRLM B,FREPTR ;And save end of free list
MOVSI T,FREHDR ;Setup header of block and forward link
MOVEM T,(B)
LSH A,9 ;Number of words we asked for
MOVEI D,-2(A) ;This is the created size
HRLM D,1(B) ;Store it
HRRM C,1(B) ;Store backward link
ADDI A,-1(B) ;End of page
MOVSI T,FRETAI
HRRI T,(B)
MOVEM T,(A) ;Mark end of block
POP P,A ;Get back size user requested
JRST ALCBLF ;Go return this one
;;; Deallocate a block, address in B
FREBLK: JSR SAVACS ;Save all ACs
SETO X, ;Flag if link into list someway
SUBI B,1 ;Point to real block
CALL CHKBLK ;Check block integrity
SKIPA ;+1, block type bad
SKIPA ;+2, good allocated block
FATAL <FREBLK: Attempt to deallocate bad block> ;+3, free blk
HRRZ A,(B) ;Get size of block
HLRZ T,-1(B) ;End of previous block, maybe
CAIE T,FRETAI ;Check for free entry
IFSKP.
MOVE C,-1(B) ;Yes, get start of block then
PUSH P,B ;Save input block adr
HRRZ B,C ;b =: ptr to preceding free block
CALL CHKBLK ;Check its integrity
NOP ;+1, Bad block
FATAL <FREBLK: Prior free blk screwed up> ;+2, Allocated block
POP P,B
HLRZ D,1(C) ;Get size of previous block
ADDI A,2 ;Freeing headers
ADDB D,A ;Get new total size
HRLM D,1(C) ;Store that
ADDI D,1(C) ;End of new big block
MOVEM C,(D) ;Store tail there
MOVEI B,(C) ;This is the block to use now
ADDI X,1
ENDIF.
MOVEI C,(A)
ADDI C,2(B) ;Address of start of next block, maybe
HLRZ T,(C)
CAIE T,FREHDR ;Is it?
JRST FREBL3 ;No
PUSH P,B ;Save input block adr
HRRZ B,C ;b =: ptr to preceding free block
CALL CHKBLK ;Check its integrity
NOP ;+1, Bad block
FATAL <FREBLK: Next free blk screwed up> ;+2, Allocated block
POP P,B
AOJE X,FREBL2 ;Was it linked to previous?
HRRZ D,(C) ;Forward link of block
HRRZ E,1(C) ;Backward link
IFE. E
HRRM D,FREPTR
ELSE.
HRRM D,(E) ;Splice out this entry since already there
ENDIF.
IFE. D
HRLM E,FREPTR
ELSE.
HRRM E,1(D) ;Backward link
ENDIF.
HLRZ D,1(C) ;Get size of block
ADDI A,2
ADDB D,A
HRLM D,1(B) ;Update size
ADDI D,1(B) ;End of new big block
HRRM B,(D) ;Store correct starting address
JRST FREBLR ;That's all there is to it
FREBL2: DMOVE T,(C) ;Start of second block
HLRZ D,TT ;Size of block
ADDI A,2(D)
HRL TT,A ;Update total size
DMOVEM T,(B) ;Store as start of this entry
TXNN TT,.RHALF
HRRI TT,FREPTR
HRRM B,(TT) ;Update forward link of backward link
IFXE. T,.RHALF
HRLM B,FREPTR
ELSE.
HRRM B,1(T) ;And vice versa
ENDIF.
ADDI C,1(D) ;End of large block
HRRM B,(C) ;Store pointer to start
FREBL3: IFL. X ;Already linked in?
HRLZM A,1(B) ;Clear backward link, store size
HRRZ T,FREPTR ;Old beginning of free list
HRRM T,(B)
IFE. T
HRLM B,FREPTR
ELSE.
HRRM B,1(T) ;Update backward link of old beginning
ENDIF.
HRRM B,FREPTR ;New beginning
ENDIF.
FREBLR: MOVEI T,FREHDR ;Free header
HRLM T,(B)
ADDI A,1(B) ;End of block
MOVEI B,FRETAI
HRLM B,(A) ;Free tail
RET ;Return
;;; Make a block bigger, address of block in B, length in A
;;; Returns with new address and length
GROBLK: JSR SAVACS
HLRZ T,-1(B) ;t =: old block header
CAILE A,0 ;New length reasonable?
CAIE T,ALCHDR ;Old block type right?
FATAL <Attempt to grow bad block>
;;;*** This should try to steal from next block ***
CALL ALCBLK ;Get a new block
RET
DMOVE T,A ;Save new results
EXCH A,A-ACBASE(P) ;This is what we return
EXCH B,B-ACBASE(P)
HRLI TT,(B) ;Old,,new
ADDI T,(TT) ;End of new block
BLT TT,-1(T) ;Transfer data into new block
CALL FREBLK ;Release the old block now
RETSKP
;;; Set the bit for a particular directory
MAIFLG: HLLZ A,DIRNUM ;Get str #
HLLZ B,MYLDIR ;Compare with login str #
CAMN A,B ;Same?
CALL MAPFLG ;No, map flags if not mapped
RET ;Non-login str or can't map flags
HRRZ A,DIRNUM ;Get directory number
IDIVI A,^D36
MOVNI B,(B)
MOVX C,1B0
LSH C,(B)
IORM C,FLGPAG(A)
RET
;;; Map in the mailer flags
MAPFLG: SKIPGE A,MFLAGP ;Have the mailer flags already?
RETSKP ;Yes, don't bother
JUMPG A,R ;Cannot get them
MOVX A,GJ%OLD!GJ%SHT
HRROI B,[ASCIZ/MAIL:MAILER.FLAGS.1/]
GTJFN%
IFJER.
MOVX A,GJ%OLD!GJ%SHT ;Failed, try on SYSTEM:
HRROI B,[ASCIZ/SYSTEM:MAILER.FLAGS.1/]
GTJFN%
IFJER.
AOS MFLAGP ;Flag that we can't get the flags
RET
ENDIF.
ENDIF.
MOVEI B,OF%RD!OF%WR!OF%THW
MOVE C,A ;Save JFN away in case OPENF% loses
OPENF%
IFJER.
AOS MFLAGP
MOVE A,C ;Get rid of the JFN we got
RLJFN%
JWARN
RET
ENDIF.
HRLZ A,A
MOVE B,[.FHSLF,,FLGPAG/1000]
MOVX C,PM%RD!PM%WR
PMAP%
SETOM MFLAGP ;Flag that we have the flags in
RETSKP
SUBTTL Host name routines
; The host table is a TBLUK% format table, with the left half of
;each entry pointing to the host name string (in fully expanded
;format) and the right half holding flags
;
; Currently defined flags are
HF%PRM==1 ;Permanent table entry
HF%DED==2 ;Host was dead recently
; Parse a host name
; Call: CALL HSTNAM
; B/ Pointer to host name
; Returns:
; +1 Host not known
; +2 Success
; B/ Host pointer
HSTNAM: SAVEAC <A,C,D>
STKVAR <HSTPTR,<HSTTMP,HSTBFL>,<HSTCAN,HSTBFL>>
HRROI A,HSTTMP ;Make a copy of the host name
MOVX C,5*<HSTBFL-1> ;Up to this many characters
SETZ D, ;Terminate on null
SOUT%
JUMPE C,R ;If ran out of space just die
MOVEI A,HSTTBL ;Point to our table
HRROI B,HSTTMP
TBLUK% ;Look it up in the cache
IFXN. B,TL%EXM ;Found it?
HLRZ B,(A) ;Great, get the string address
RETSKP ;Return success
ENDIF.
HRROI A,HSTTMP ;Name to canonicalize
HRROI B,HSTCAN ;Where to put the name
CALL MXNAME ;Do the canonicalization
IFSKP.
IFLE. A ;Did we get a relay list?
IFE. A ;No, was it indeterminate?
HRROI A,HSTTMP ;If so, see if protocols can help
HRROI B,HSTCAN ;Canonical name from MXNAME was just a copy
ELSE. ;Otherwise we are the relay for this host
HRROI A,HSTCAN ;So sniff at that name
HRROI B,HSTTMP ;We don't care what protocols say is canonical
ENDIF.
CALL HSNAME ;Look up the name through protocols
ANSKP.
JUMPE A,RSKP ;Handle the local name case
ENDIF.
MOVEI A,HSTCAN ;Make pointer to canonical name
HRLI A,(<POINT 7,>)
ELSE.
HRROI A,HSTTMP ;Get the string pointer
HRROI B,HSTCAN ;Where to put canonical name
CALL HSNAME
IFSKP.
JUMPE A,RSKP ;Handle the local name case
MOVEI A,HSTCAN ;Make pointer to canonical name
HRLI A,(<POINT 7,>)
ELSE.
HRROI A,HSTTMP ;Try for a relay, return canonical name in A
CALL $GTRLY
RET
ENDIF.
ENDIF.
MOVEM A,HSTPTR ;Save pointer to canonical name
MOVEI A,HSTTBL ;Cache header
MOVE B,HSTPTR ;Pointer to possible name to add
TBLUK%
IFXE. B,TL%EXM ;Found it?
MOVE A,HSTPTR
CALL CPYSTR ;Copy the string
HRLZS B ;RH 0 means temporary table entry
MOVEI A,HSTTBL ;Point to the table
TBADD% ;Add it to table
ENDIF.
HLRZ B,(A) ;Get the string address
RETSKP ;Return success
ENDSV.
; GETPRO - Get host address and find protocol supported by host
; Accepts:
; A/ host name string
; C/ pointer to protocol list or -1 to try all supported protocols
; CALL GETPRO
; Returns +1: Failed
; +2: Success, updated pointer in A, host address in B,
; protocol address in C
GETPRO: STKVAR <HSTPTR,HSTPT1,<HSTTMP,HSTBFL>>
MOVEM A,HSTPTR ;Save host pointer
HRROI B,HSTTMP ;See if an MX entry for this guy
CALL MXNAME ;Well, is there?
IFSKP.
ANDG. A ;Must have a relay list
MOVE A,(A) ;Get CAR of relay list
MOVEM A,HSTPT1 ;Get name of first relay
MOVE B,HSTPTR ;Compare with name user wants
STCMP%
IFXN. A,SC%SUB ;Is relay name a subset name user wants?
ILDB A,B ;Yes, see what follows
CAIE A,"." ;Relative domain delimiter?
ANSKP.
ILDB A,B ;If we have a relative domain, it means the
CAIN A,"#" ; relay is really the host itself, so we must
SETZ A, ; skip all the MX games
ENDIF.
ANDN. A ;Relay must be different from host
MOVE A,HSTPT1 ;Get back relay name
ELSE.
MOVE A,HSTPTR ;Get back host pointer
SETZM GTDBLK+.GTDRD ;Note no MX in progress in case optional %<host>
ENDIF.
CALLRET $GTPRO ;Now do the normal $GTPRO
ENDSV.
; HSNAME - Get canonical name and relays for physical host
; Accepts:
; A/ host name string
; B/ destination host name string
; CALL HSNAME
; Returns +1: Failed
; +2: Success, A/ 0 and B/ LCLNAM if local host, A/ non-zero otherwise
HSNAME: SAVEAC <C>
STKVAR <HSTADR,<HSTTMP,HSTBFL>>
MOVEI C,SNDRTS ;Check all protocols known at this point
CALL $GTCAN ;Get canonical name, address, and registry
RET ;Fails
MOVEM B,HSTADR ;Success, save host address
HRROI A,HSTTMP ;Where to store name
SETO B, ;Local host address for this protocol
CALL $GTNAM ;Canonicalize the name
IFSKP. ;Can't fail most places
CAME B,HSTADR ;Is this our local host?
ANSKP.
SETZ A, ;Yes, flag as such
MOVEI B,LCLNAM ;Return the local name pointer here
ENDIF.
RETSKP
ENDSV.
; MXNAME - Get canonical name and relays for MX host
; Accepts:
; A/ host name string
; B/ destination host name string
; CALL MXNAME
; Returns +1: Failed
; +2: Success, A/ pointer to relay list
; 0 if indeterminate, -1 if we are the relay
MXNAME: SAVEAC <B,C,D>
STKVAR <DSTPTR,<HSTTMP,HSTBFL>>
MOVEM B,DSTPTR ;Save destination pointer
MOVE B,A ;Copy string so we can muck with it
HRROI A,HSTTMP ;Into HSTTMP
MOVX C,5*<HSTBFL-1> ;Up to this many characters
SETZ D, ;Terminate on null
SOUT%
ERJMP R ;Percolate failure up to caller
JUMPE C,R ;String too long if exhausted
HRROI A,HSTTMP ;Now remove Internet domain
HRROI B,[ASCIZ/Internet/]
CALL $RRDOM
RET
ILDB A,A ;Sniff at first character
CAIE A,"#" ;Looks like a literal?
CAIN A,"["
RET ;Yes, can't possibly be MX then!!
MOVX A,GTDLEN ;Set up length of argument block
MOVEM A,GTDBLK+.GTDLN
SETZM GTDBLK+.GTDTC ;No special query type/class
MOVX A,<RLYBFL*5>-1 ;Length of relay buffer
MOVEM A,GTDBLK+.GTDBC ;Save relay buffer length
SETZM GTDBLK+.GTDNM ;This gets returned
SETZM GTDBLK+.GTDRD ;So does this
MOVX A,.GTDMX ;Want MX poop
HRROI B,HSTTMP ;Source pointer
HRROI C,RLYBUF ;Destination string buffer
MOVEI D,GTDBLK ;Argument block
CALL $GTHST
RET
IFN. A ;Have determinate information?
MOVE A,DSTPTR ;Indeterminate, just copy the argument
HRROI B,HSTTMP ;As the canonical name
SETZ C,
SOUT%
SETZ A, ;No relay pointer
ELSE.
MOVE A,DSTPTR ;Copy to canonical name
MOVE B,GTDBLK+.GTDNM ;Get pointer to canonical string
MOVX C,5*<HSTBFL-1> ;Up to this many characters
SETZ D, ;Terminate on null
SOUT%
ERJMP R ;Percolate failure up to caller
JUMPE C,R ;String too long if exhausted
MOVEI D,GTDBLK+.GTDRD ;Scan relay list
DO.
SKIPN A,(D) ;Get item from relay list
EXIT.
HRROI B,LCLNAM ;Compare with local name
STCMP%
IFE. A ;Handle even the unlikely case
SETO A, ;So flag that
RETSKP ;And return success
ENDIF.
IFXN. A,SC%SUB ;Is relay name a subset of our name?
ILDB A,B ;Yes, see what follows
CAIE A,"." ;Relative domain delimiter?
ANSKP.
ILDB A,B
CAIE A,"#"
ANSKP. ;We are the relay to this MX!
SETO A, ;So flag that
RETSKP ;And return success
ENDIF.
AOJA D,TOP. ;Else consider next relay
ENDDO.
MOVEI A,GTDBLK+.GTDRD ;Return pointer to relay list
ENDIF.
RETSKP
ENDSV.
; Make a host a permanent table entry
; Call: CALL HSTPRM
; B/ Host pointer
; Returns: +1 always.
HSTPRM: SAVEAC <A,B>
MOVEI A,HSTTBL
TBLUK%
TXNE B,TL%NOM!TL%AMB
FATAL <HSTPRM - Impossible TBLUK failure>
MOVX B,HF%PRM
IORM B,(A) ;Set the right flag
RET
; Combination of HSTNAM and HSTPRM.
; Call: CALL PRMHST
; B/ Host string
; returns +1 or +2, like HSTNAM, but also marks host perm if
; it works.
PRMHST: CALL HSTNAM
RET ;Fail if HSTNAM does
SAVEAC <B>
HRRO B,B
CALL HSTPRM ;Mark it permanent
RETSKP
; Clear the table of all temporary entries.
; Call: CALL HSTCLR
; Returns: +1 always
HSTCLR: SAVEAC <A,B,C>
HLRZ C,HSTTBL ;number of entries
MOVNS C
MOVSS C
HRRI C,HSTTBL+1 ;Make an AOBJN pointer
MOVEI A,HSTTBL
DO.
HRRZ B,(C) ;get entries flag
IFE. B ;0 = temp entry
HLRZ B,(C) ;Get name string block
CALL FREBLK ;release the storage
MOVEI B,(C)
TBDEL%
SOS C ;correct pointer for deleted entry
ENDIF.
AOBJN C,TOP.
ENDDO.
RET
; Routine to check if a host is known to be dead
; Entry: b = host pointer
; Call: CALL HSTDED
; Return: +1, host dead
; +2, host is alive
HSTDED: SKIPN NETF ;Allowed to scan network mail?
RET ;No, pretend host is dead
SKIPN FSTF ;Slow scan fork?
RETSKP ;Yes, no need to scan dead host table
SAVEAC <A,B,C>
MOVEI A,HSTTBL ;Look this one up
HRROS B ;Make sure byte pointer
TBLUK%
TXNE B,TL%NOM!TL%AMB ;Paranoia
FATAL <HSTDED - Impossible TBLUK failure>
HRRZ A,(A) ;Get flags
JXN A,HF%DED,R ;Dead?
RETSKP ;Else return success
; Routine to add a host to the dead list.
; Entry: FRNHST = host pointer
; Call: CALL ADEADH
; Return: +1 always
ADEADH: SKIPN FSTF ;Slow scan?
RET ;Yes, no need to do this
SAVEAC <A,B>
MOVEI A,HSTTBL
HRRO B,FRNHST
TBLUK% ;Look it up
TXNE B,TL%NOM!TL%AMB
FATAL <ADEADH - Impossible TBLUK failure>
MOVX B,HF%DED
IORM B,(A) ;Set the right flag
RET
; Routine to remove all dead host flags from the list
; Call: CALL NDHOST
; Return: +1 always
NDHOST: HLRZ A,HSTTBL ;Get length
MOVNS A ;(Better be at least one)
MOVSS A
HRRI A,HSTTBL+1 ;Make an AOBJN pointer
MOVX B,HF%DED
DO.
ANDCAM B,(A) ;Clear the flag
AOBJN A,TOP. ;and loop
ENDDO.
RET
SUBTTL Parser
;;; Initialize parser, called with starting address in B, byte count in C
PARINI: HRLI B,(<POINT 7,0>)
DMOVE X,B
RET
;;; Parse a single line
PARLIN: TXZ F,FP%FF!FP%CLN!FP%EOL!FP%DEL!FP%WSP
SETZM PDELB2 ;Filter for malformed <del> pairs
DO.
DMOVEM X,PLINBP ;Save start of line
DO.
DMOVEM X,PWSPBP
SOJL Y,R
ILDB D,X ;Get first character
CAIE D,.CHTAB ;Leading whitespace?
CAIN D,.CHSPC
IFNSK.
TXO F,FP%WSP ;Yes, note it
LOOP. ;And continue
ENDIF.
ENDDO.
IFXE. F,FP%FF ;Seen formfeed yet?
CAIE D,.CHFFD ;No, is there one now?
IFSKP.
TXO F,FP%FF
TXZ F,FP%BKA!FP%EQU ;Clear special flags
LOOP.
ENDIF.
ELSE.
IFXE. F,FP%EQU!FP%BKA ; Seen one of these yet?
CAIE D,"=" ;Equal sign?
IFSKP.
TXO F,FP%EQU ;Yes
LOOP.
ENDIF.
CAIE D,"_" ;Backarrow?
IFSKP.
TXO F,FP%BKA ;Yes
LOOP.
ENDIF.
ENDIF.
ENDIF.
ENDDO.
CAIN D,.CHCRT ;End of line?
IFSKP.
DO.
CAIE D,.CHDEL
IFSKP.
TXON F,FP%DEL ;Rubout within line is start of host
IFSKP.
SKIPN PDELB2 ;Matching pair?
IFSKP.
SETOM PDELB2 ;No, flag error
ELSE.
DMOVEM X,PDELB2
ENDIF.
ELSE.
DMOVEM X,PDELBP
ENDIF.
ELSE.
CAIN D,":"
TXOE F,FP%CLN
IFSKP.
DMOVEM X,PCLNBP ;Save pointers when got to colon
ENDIF.
ENDIF.
SOJL Y,R
ILDB D,X
CAIE D,.CHCRT
LOOP.
ENDDO.
ELSE.
TXO F,FP%EOL
ENDIF.
SOJL Y,R
ILDB D,X ;Skip lf too
SKIPG PDELB2 ;Matching <del> set?
TXZ F,FP%DEL ;No, ignore any seen
RETSKP
;;; Parse a keyword from table in A
;;; Returns +1 failure, else calls routine pointed to by table
PARKEY: IFXN. F,FP%CLN ;Line had a colon in it?
MOVE D,PCLNBP ;Yes, use byte pointer of colon then
ELSE.
SETO D,
ADJBP D,X
ENDIF.
LDB TT,D ;Get character that terminates atom
SETZ T,
DPB T,D ;Replace it with null
MOVE T,0(A) ;t := aobjn ptr to lookup table
PARKY2: HLRZ A,0(T) ;a := ptr to next table entry
HRLI A,(<POINT 7,0>)
MOVE B,PLINBP ;Start of line
CALL STRCMP ;Match?
AOBJN T,PARKY2 ;No, try the next
DPB TT,D ;Replace character
JUMPGE T,R ;If no match, return
HRRZ A,(T) ;Get entry
JRST (A) ;Go call that routine
;;; Get pointers for this line
PARSTR: DMOVE C,PLINBP
PARST1: SUB D,Y
SUBI D,2 ;Number of chars less CRLF
RET
;;; Make lengths of fields in line with rubout relative
PARDEL: MOVE T,PLINBP+1 ;Start of line
MOVE TT,PDELBP+1
SUB T,TT
SUBI T,1 ;Less rubout itself
MOVEM T,PLINBP+1
MOVE T,PWSPBP+1
SUB T,TT
SUBI T,1
MOVEM T,PWSPBP+1
MOVE T,PDELB2+1
SUB TT,T
SUBI TT,1
MOVEM TT,PDELBP+1
SUB T,Y
SUBI T,2 ;Less CRLF
MOVEM T,PDELB2+1
RET
;;; Return a host index for string in C and D, returns as HSTNAM
PARHLN: CALL PARSTR ;Get pointers for this line
PARHST: MOVE B,[POINT 7,HSTBUF]
DO.
ILDB A,C ;Copy string
IDPB A,B
CAIE A,.CHNUL ;Quit on null
SOJG D,TOP. ;Or count
ENDDO.
SETZ A, ;Fill out with nulls
DO.
IDPB A,B
TXNE B,76B4
LOOP.
ENDDO.
MOVE B,[POINT 7,HSTBUF]
CALLRET HSTNAM ;Go try to parse host name
SUBTTL Queue file handling
;;; Structure of a queue file entry:
MSGPAG==0 ;Count,,starting page mapped into
MSGJFN==1 ;Flags,,JFN for it
MSGFHS==2 ;Foreign host
MSGHDR==3 ;Byte pointer of start of headers
MSGHCN==4 ;Count of bytes in that
MSGTXT==5 ;Byte pointer of start of text
MSGTCN==6 ;Count of bytes in that
MSGNHD==7 ;Count,,addr of headers for this network
MSGRCP==10 ;Network recipients
MSGLCL==11 ;Local recipients
MSGSDR==12 ;Sender of msg
MSGWRT==13 ;Time msg was queued
MSGAFT==14 ;Time to start attempting message delivery
MSGNTF==15 ;Time to tell sender of delivery status
MSGDEQ==16 ;Time to dequeue the msg -- dead letter
MSGTMT==17 ;Time limit for sending whole msg (msec)
MSGTMC==20 ;Time limit for sending one copy (msec)
MSGDOP==21 ;Delivery options
MSGRPT==22 ;Return path
MSGLEN==23 ;Length of entry
;;; Global flags for msg handling (lh of MSGJFN)
FG%XER==1B0 ;Discard file on error (hard failure or
;dequeue time-out)
;;; Structure of host entry:
HSTFLG==0 ;Flags,,link to next
FH%DON==1B0 ;Host done
FH%DN1==1B1 ;Host about to be done
;;; Flags for "sender" specification (used in sender host block)
FS%BKA==1B2 ;Sender specified in mail file preamble
FS%RMF==1B3 ;Sender from "ReSent-From:" line
FS%SDR==1B4 ;Sender from "Sender:" line
FS%FRM==1B5 ;Sender from "From:" line
FS%RPL==1B6 ;Sender from "Reply-to:" line
FS%NTM==1B7 ;"Mail-from:" net host line seen
FS%MLA==1B8 ;"Mail Agent" is the default sender
HSTHST==1 ;Host pointer
HSTRCP==2 ;Recipients
HSTLEN==3 ;Length of entry
;;; Structure of recipient entry:
RCPFLG==0 ;Flags,,link to next
FR%FAI==1B0 ;Hard failure
FR%TMP==1B1 ;Temporary failure
FR%ERM==1B2 ;There is a consed up error
FR%STR==1B3 ;Name is consed locally
FR%MLA==1B4 ;Recip = mail agent and failed
FR%SDR==1B5 ;Recip = sender and failed
RCPBPT==1 ;Byte pointer to name
RCPCNT==2 ;Byte count
RCPERR==3 ;Error message
RCPLEN==4 ;Length of entry
;;; Get a queue file JFN in A, returns +1 if failure, +2 with file entry in M
GETQUE: JSR SAVACS ;Save all ACs
MOVEI B,(A)
HRROI A,STRBUF
SETZ C,
JFNS%
HRROI B,STRBUF ;Must get another JFN
CALL MAPQFL
RET ;Failed, return
CALL PARINI ;Initialize parser
PUSH P,A ;Save JFN
MOVEI A,MSGLEN
CALL ALCBLK ;Allocate a block for message
IFNSK.
POP P,A ;Restore JFN
CALL UNMQU0 ;Unmap file and return
NOP
RET
ENDIF.
MOVEI M,(B) ;Pointer to block
POP P,MSGJFN(M) ;Save JFN
MOVEM M,M-ACBASE(P) ;Return that too
MOVEM D,MSGPAG(M) ;Page info
SETZM MSGFHS(M)
SETZM MSGNHD(M)
SETZM MSGRCP(M) ;Initialize recipient pointers
SETZM MSGLCL(M)
SETZM MSGSDR(M)
SETZM MSGAFT(M) ;Clear default after interval
SETZM MSGNTF(M) ;Clear delivery status notification time
SETZM MSGDEQ(M) ;Clear default dequeue time for msg
SETZM MSGDOP(M) ;Clear delivery options
SETZM MSGRPT(M) ;Clear return path
SKIPN A,DAEMNP ;Running as daemon?
IFSKP.
SKIPE RXMF ;Doing a retransmission?
IFSKP.
TIME% ;No, log xmit time limit for whole msg
ADD A,TMTINT
ELSE.
SETZ A, ;No overall time limit for retransmissions
ENDIF.
ENDIF.
MOVEM A,MSGTMT(M) ;Record it
SETZM MSGTMC(M) ;Clear xmit time limit/msg copy
HRRZ A,MSGJFN(M) ;Get file write date
CALL .GFWDT
MOVEM B,MSGWRT(M)
CALL GDFSDR ;Set up the default sender
FATAL <GETQUE: Error setting up default sender>
MOVE A,MPP ;From here on, return +2 on error
AOS (A)
MOVE A,FILIDX ;a := current file type index
HLRZ A,%FLPRC(A) ;a := processing dispatch for header
JRST 0(A) ;Do it
;; Here to fake a header for xxx.<addressee> files
GQUEUN: PUSH P,X ;Save the current msg string info
PUSH P,Y
HRROI A,STRBUF ;a := buffer for the extension info
HRRZ B,MSGJFN(M) ;b := msg file JFN
MOVSI C,000100 ;Print extension only
JFNS%
MOVE A,[POINT 7,STRBUF] ;Now scan the string for the host name
MOVE B,A
SETZB X,Y ;Init host ptr and string length
DO.
ILDB C,B ;c := next char
IFN. C ;While non-null
CAIN C,.CHCNV ;^V?
LOOP. ;Yes, ignore it
CAIE C,"@" ;Start of host?
IFSKP.
SETZ C, ;Yes, clobber the "@" with a null
IDPB C,A
MOVE X,A ;Save start of string
LOOP.
ENDIF.
IDPB C,A ;Store the char
AOJA Y,TOP. ;Count the char and do the next
ENDIF.
SKIPN X ;"@" seen?
MOVE X,A ;No, update host ptr
CAME A,X ;Is host null?
IFSKP.
MOVE B,[POINT 7,LCLNAM] ;No, use local name
LOOP.
ENDIF.
ENDDO.
MOVE B,A ;OK, terminate edited string
IDPB C,B
;;;Now we create a fake header (as if [--QUEUED-MAIL--])
MOVE A,[POINT 7,OMLRBF] ;a := place to build it
MOVEI B,.CHFFD ;Start with ^L<host><crlf>
IDPB B,A
MOVE B,X ;b := ptr to host string
SETZ C,
SOUT% ;(Have to SOUT% - not word boundary)
MOVEI B,CRLF0
CALL MOVSTR
MOVEI B,STRBUF ;Add <addressee><crlf>
CALL MOVSTR
MOVEI B,CRLF0
CALL MOVSTR
MOVEI B,.CHFFD ;And finish with ^L<CRLF>
IDPB B,A
MOVEI B,CRLF0
CALL MOVST0
MOVE X,[POINT 7,OMLRBF] ;Now set to scan the string
ADDI Y,^D8+1 ;Account ^L's and <crlf>'s in length
;(and 1 so PARLIN thinks a msg follows)
; JRST GQUEQM ;Drop into common code
;; Parse the head of the file
GQUEQM: CALL PARLIN ;Get a line from the file
JRST QUEEOF ;Premature eof
IFXE. F,FP%FF ;Was a formfeed seem?
CALL QUEBAD ;No, bad format file
HRROI B,[ASCIZ/Invalid queued mail file format in line "/]
JRST QUEBP0 ;Toss the losing file out
ENDIF.
;; Now parse the message recipients
GQUERC: IFXN. F,FP%EOL ;Empty line?
JXN F,FP%EQU,QUEBPM ;Error if control parameter specification
JXE F,FP%BKA,GQUEHD ;If not sender, must be start of actual msg
MOVEI B,LCLNAM ;Default sender host to us
JRST GQUSDR ;Set up new sender spec
ENDIF.
TXNE F,FP%EQU ;Control parameter specification?
JRST GQUPRM ;Yes, decode it
CALL PARHLN ;Get host from name
IFNSK.
JXE F,FP%BKA,QUEBHS ;If not sender spec, can't win...
DO. ;Yes, ignore it
CALL PARLIN ;Eat line
JRST QUEEOF ;Premature EOF
TXNE F,FP%FF ;Started with form?
JRST GQUERC ;Yes, done with this
LOOP. ;Otherwise eat remainder of specification
ENDDO.
ENDIF.
JXN F,FP%BKA,GQUSDR ;Set up if sender spec
SKIPN WOPRP ;WHEEL or OPERATOR?
IFSKP.
CAIE B,LCLNAM ;Yes, deliver directly if local host
IFSKP.
MOVEI O,MSGLCL(M) ;Point to local entry
JRST GQURC5
ENDIF.
ENDIF.
PUSH P,B ;Save site entry
HRROS B ;Set to check if this host already seen
MOVEI N,MSGRCP(M) ;Starting pointer for linked host list
GQURC2: HRRZ A,(N) ;a := next host entry on list
JUMPE A,GQURC3 ;Quit at end of list
MOVEI N,(A) ;n := adr of this host block
CAME B,HSTHST(N) ;Host already on list?
JRST GQURC2 ;No, check next block
POP P,B ;Yes, recover site entry
JRST GQURC4 ;Append these users
;; Here when the new host is not already on the recipient list
GQURC3: MOVEI A,HSTLEN ;Get a host entry
CALL ALCBLK
JRST QUEBRT ;Failed, free what we used and return
HRRM B,(N) ;Link it in
MOVEI N,(B) ;Now the end of the list
SETZM HSTFLG(N)
POP P,HSTHST(N) ;Save host pointer
SETZM HSTRCP(N) ;Init recipient list
GQURC4: MOVEI O,HSTRCP(N) ;This is the start of the recipients
GQURC5: HRRZ A,(O) ;a := next recipient entry on list
JUMPE A,GQURC1 ;Quit at end of the list
MOVEI O,(A) ;o := adr of this recipient block
JRST GQURC5 ;Try another
;; Here to process the next input line...
GQURC1: CALL PARLIN ;Get a line
JRST QUEEOF ;Premature eof
TXNE F,FP%FF ;Started with form?
JRST GQUERC ;Yes, next host then
TXNE F,FP%EOL ;End of line?
JRST GQURC1 ;Yes, ignore it and try another
MOVEI A,RCPLEN ;Get block for this recipient
CALL ALCBLK
JRST QUEBRT ;Failed, return
HRRM B,(O) ;Link it in
MOVEI O,(B) ;Now the end of the list
SETZM RCPFLG(O) ;Clear flags
CALL PARSTR ;Limits of string
DMOVEM C,RCPBPT(O) ;Save them
JRST GQURC1
;; Here when sender spec encountered. b = host site tbl adr
GQUSDR: PUSH P,[0] ;Save place for user ptr
PUSH P,[0]
PUSH P,B ;Save host adr (until we have a user)
GQUSD0: CALL PARLIN ;Get a line
IFNSK.
ADJSP P,-3 ;Premature eof
JRST QUEEOF
ENDIF.
TXNE F,FP%FF ;Started with form?
JRST GQUSD1 ;Yes, record what we have
TXNE F,FP%EOL ;End of line?
JRST GQUSD0 ;Yes, ignore it and try another
CALL PARSTR ;OK, get limits of string
DMOVEM C,-2(P) ;Save them
TXZE F,FP%BKA ;First user entry?
JRST GQUSD0 ;Yes, see if there are anymore
JRST GQUSDB ;Too many, bad sender spec
;; Here when new line starting with FF
GQUSD1: JXN F,FP%BKA,GQUSDB ;Exactly one sender?
REPEAT 0,< ;; This needs more thought for Cafard, etc.
DMOVE A,[POINT 7,ORGAUT ;File's last writer
POINT 7,DAEDIR] ;Daemon directory
CALL STRCMP ;Match?
IFNSK.
ADJSP P,-3 ;Reset stack
JRST GQUERC ;See about next host
ENDIF.
>;REPEAT 0
HRRZ B,MSGSDR(M) ;OK, b := adr of host entry block
MOVX A,FS%MLA ;Clear "mlagnt" bit if on
ANDCAM A,HSTFLG(B)
MOVX A,FS%BKA ;Set "_sender" bit
IORM A,HSTFLG(B)
POP P,HSTHST(B) ;Install new sender host
HRRZ B,HSTRCP(B) ;b := adr of recipient entry block
POP P,RCPCNT(B) ;Install new byte count
POP P,RCPBPT(B) ;and byte ptr
SETZM RCPERR(B) ;Clear error
JRST GQUERC ;Now see about the next host
;; Now finish up, remembering where the headers start
GQUEHD: MOVE A,FILIDX ;a := index to current file type
HRRZ A,%FLPRC(A) ;a := processing dispatch for msg
JRST 0(A) ;Do it
GQUEH0: POP P,Y ;Recover ptr info for msg text itself
POP P,X
GQUEH1: DMOVEM X,MSGHDR(M)
CALL FNDSDR ;Find sender by parsing msg headers
MOVE P,MPP ;Undo extra pushes
RETSKP ;Skip return from it all
;;; Here to process file processing parameter specifications. These are
;;; of the form <ff>=<keyword>:<value>
GQUPRM: MOVEI A,QUEPTB ;Lookup in parameter keyword table
CALL PARKEY
JRST QUEBPM ;Bad luck...
JRST GQURC1 ;Got it, continue processing
;;; Here to fetch return path
QUERPT: DMOVE C,PCLNBP ;Rest of line after colon
CALL PARST1
SKIPN A,D ;Length of string
RETSKP ;Return path null? Ignore it I guess
IDIVI A,5 ;Size in words
ADDI A,1 ;Add an extra word for remainder and null pad
CALL ALCBLK
RETSKP ;Don't care all that much
MOVEM B,MSGRPT(M) ;Save pointer to block
HRLI B,(<POINT 7,>) ;Make byte pointer
QUERP1: ILDB A,C ;Copy string
IDPB A,B
SOJG D,QUERP1 ;Continue until count exhausted
IDPB D,B ;Tie off string with null
RETSKP
;;; Here to fetch delivery options
QUEDEL: DMOVE C,PCLNBP ;Rest of line after colon
CALL PARST1
CAIE D,4 ;Is string 4 characters precisely?
RET ;No, can't be valid
ADJBP D,C ;Pointer to delimeter byte
ILDB TT,D ;Get delimiter byte
SETZ T, ;Make it null-terminated
DPB T,D
MOVEI A,QUEDOP ;Lookup in parameter keyword table
MOVE B,C
TBLUK%
DPB TT,D ;Put delimiter back
TXNE B,TL%NOM!TL%AMB ;Bad delivery option?
RET
HRRZ B,(A) ;Get delivery options table code
MOVEM B,MSGDOP(M)
RETSKP
QUEDOP: NQDOPS,,NQDOPS
DOPTAB: PHASE 0
[ASCIZ/MAIL/],,. ;Mail (MUST BE FIRST IN TABLE!!!!!!!!)
D%SAML:![ASCIZ/SAML/],,. ;Send and mail
D%SEND:![ASCIZ/SEND/],,. ;Send
D%SOML:![ASCIZ/SOML/],,. ;Send or mail
DEPHASE
NQDOPS=.-DOPTAB
;;; Here to fetch physical host that connected to us
QUEHST: DMOVE C,PCLNBP ;Rest of line after colon
CALL PARST1
CALL PARHST ;Parse the host name
SETZ B, ;Failed, ignore it (shouldn't happen)
MOVEM B,MSGFHS(M)
RETSKP
;;; Here to fetch time to attempt network retransmissions
QUEAFT: CALL GQUTIM ;Decode the time value
RET ;No go
MOVEM B,MSGAFT(M) ;Save it
RETSKP ;And success return
;;; Here to fetch time to notify sender of transmission status
QUENTF: CALL GQUTIM ;Decode the time value
RET ;No go
MOVEM B,MSGNTF(M) ;Save it
RETSKP ;And success return
;;; Here to fetch time to notify sender of transmission status
QUEDEQ: CALL GQUTIM ;Decode the time value
RET ;No go
MOVEM B,MSGDEQ(M) ;Save it
RETSKP ;And success return
;;; Here to set flag for discarding msg without notifying sender if
;;; failed or dequeued.
QUEDER: MOVX A,FG%XER ;Set flag
IORM A,MSGJFN(M)
RETSKP ;And success return
;;; Routine to decode a time value for a control parameter
;;; Return: +1, error
;;; +2, success - value in b
GQUTIM: DMOVE C,PCLNBP ;Rest of line after colon
CALL PARST1
MOVE A,[POINT 7,STRBF1] ;Temp buffer for time string
GQUTI0: ILDB B,C
CAIE B,.CHSPC ;Skip starting spaces and tabs
CAIN B,.CHTAB
IFNSK.
SOJG D,GQUTI0 ;Look some more
RET ;Unless string exhausted
ENDIF.
SKIPA
GQUTI1: ILDB B,C ;Next char
IDPB B,A ;Copy it
CAIN B,.CHNUL ;Quit on null
JRST GQUTI2
SOJG D,GQUTI1 ;If not end of string, continue
MOVEI B,0 ;Else end with null
IDPB B,A
GQUTI2: HRROI A,STRBF1 ;Now convert the time string
IDTIM%
RET
RETSKP
;;; Table of parameter keywords and processing routines
QUEPTB: -NQPRMS,,.+1
[ASCIZ/AFTER/],,QUEAFT ;Formerly RETRANSMIT
; [ASCIZ/DATA/],,QUEDAT
[ASCIZ/DELIVERY-OPTIONS/],,QUEDEL
[ASCIZ/DEQUEUE/],,QUEDEQ
[ASCIZ/DISCARD-ON-ERROR/],,QUEDER
; [ASCIZ/ERROR/],,QUEERR
[ASCIZ/NET-MAIL-FROM-HOST/],,QUEHST
[ASCIZ/NOTIFY/],,QUENTF
[ASCIZ/RETURN-PATH/],,QUERPT
NQPRMS=.-QUEPTB-1
; Routine to set up the default sender for a msg
; Entry: queue file mapped
; Call: CALL GDFSDR
; Return: +1, failure
; +2, OK
GDFSDR: HRRZ A,MSGJFN(M) ;a := queue file JFN
HRLI A,.GFLWR ;Get its author string
HRROI B,FILAUT ;Into filaut buffer
GFUST%
MOVE A,[FILAUT,,ORGAUT] ;Save original in ORGAUT
BLT A,ORGAUT+AUTLEN-1
MOVE N,[POINT 7,MLAGNT] ;Set up mail agent as default author
DMOVE A,[POINT 7,FILAUT ;See if it was written by system server
POINT 7,DAEDIR]
CALL STRCMP ;Was it?
IFNSK.
MOVX A,RC%EMO ;No, see if looks like a local user name
HRROI B,FILAUT
RCUSR% ;Parse user name
IFNJE.
TXNN A,RC%NOM!RC%AMB ;Parsed, does it exist?
MOVE N,[POINT 7,FILAUT] ;Yes, set local user as default author
ENDIF.
ENDIF.
PUSH P,N ;Save author on stack
MOVEI N,MSGSDR(M) ;n := root for sender host entry blk
MOVEI A,HSTLEN ;Get a host entry
CALL ALCBLK
JRST GDFSDX ;Failed, return +1
HRRM B,0(N) ;Link it in
MOVEI N,(B) ;Now the end of the list
SETZM B,HSTFLG(N)
MOVX A,FS%MLA ;Check if dflt sender = mail agent
HRRZ B,(P)
CAIN B,MLAGNT ;Is it?
IORM A,HSTFLG(N) ;Yes, set the flag
MOVEI B,LCLNAM ;b := host site tbl adr
MOVEM B,HSTHST(N) ;Save site entry
MOVEI O,HSTRCP(N) ;o := start of the sender recipient
MOVEI A,RCPLEN ;Get block for this recipient
CALL ALCBLK
JRST GDFSDX ;Failed, return +1
HRRZM B,(O) ;Link it in
MOVEI O,(B) ;Now the end of the list
SETZM RCPFLG(O) ;Clear flags
MOVE A,(P) ;a := ptr to dflt sender string
SETZ B, ;b := str length
ILDB C,A ;c := next char
CAIE C,.CHNUL ;Quit on null
AOJA B,.-2 ;Otherwise count it
POP P,A ;a := fresh ptr to sender string
DMOVEM A,RCPBPT(O) ;Install the sender name
RETSKP ;Return +2
; Here if error allocating blocks
GDFSDX: ADJSP P,-1 ;Reset the stack
RET ;Fail return +1
;;; The following code is to parse the msg headers to find the msg
;;; sender if none was specified by "_sender" in the msg preamble and
;;; the msg file author was DAEDIR.
; Keyword table for locating msg header lines possible containing a
; sender address.
FSDRTB: -NFSDR,,.+1
[ASCIZ/RESENT-FROM/],,SDRRMF
[ASCIZ/REMAILED-FROM/],,SDRRMF
[ASCIZ/REDISTRIBUTED-FROM/],,SDRRMF
[ASCIZ/SENDER/],,SDRSDR
[ASCIZ/FROM/],,SDRFRM
[ASCIZ/REPLY-TO/],,SDRRPL
[ASCIZ/MAIL-FROM/],,SDRNTM
NFSDR==.-FSDRTB-1
; Find sender name by parsing message header. Message file mapped
; Entry: m = adr of message block
; x,y = ptr/cnt to start of msg headers
; Call: CALL FNDSDR
; Returns +1 always
FNDSDR: HRRZ N,MSGSDR(M) ;n := adr of "sender" recip host block
MOVX A,FS%BKA
MOVX B,FS%MLA
TDNN A,HSTFLG(N) ;Sender from file preamble?
TDNN B,HSTFLG(N) ;No, sender = non-DAEDIR file author?
RET ;Yes, don't supersede that
HRRZ O,HSTRCP(N) ;o := adr of "sender" recipient block
SETZM SDRHST ;Init sender temp locs
SETZM SDRNAM
FNDSD0: CALL PARLIN ;Get a line from the msg text
JRST FNDSD1 ;EOF, check out sender
TXNE F,FP%EOL ;Empty line?
JRST FNDSD1 ;No more header lines, check out sender
MOVEI A,FSDRTB ;a := sender spec line keywords
TXNE F,FP%CLN ;Colon seen?
CALL PARKEY ;Yes, look up this line's keyword
JRST FNDSD0 ;+1, no go, move on to next line
HRRM B,SDRHST ;Save the new host
DMOVEM C,SDRNAM ;Install the new recipient name ptr
JRST FNDSD0 ;Loop through rest of headers
; Here when finished with msg headers
FNDSD1: DMOVE C,SDRNAM ;c/d := new recipient name ptr/cnt
JUMPE C,R ;If highest priority spec failed, quit
DMOVEM C,RCPBPT(O) ;Install the new recipient name ptr
SKIPN B,SDRHST ;b := sender host site
MOVEI B,LCLNAM ;Yes
HRRZM B,HSTHST(N) ;Install it
RET ;Done
; Following are the routines to check out various "sender"
; specification lines.
; Return: +1, No sender found
; +2, Sender address found
; b = host site tbl entry adr
; c = ptr to sender name string
; d = byte count for sender name
; Here to process "ReSent-From:" line
SDRRMF: MOVX A,FS%RMF ;a := flag for this line type
IORM A,SDRHST ;Show we've seen one
SDRRM0: CALL GTSNDR ;Go scan for the sender
JRST SDRXXX ;Error
RETSKP ;Success, return +2
; Here to process "Sender:" line
SDRSDR: MOVX A,FS%SDR ;a := flag for this line type
IORM A,SDRHST ;Show we've seen one
MOVX A,FS%RMF ;Already have higher priority spec?
TDNE A,SDRHST
RET ;Yes
CALLRET SDRRM0 ;Go scan for the sender
; Here to process "From:" line
SDRFRM: MOVX A,FS%FRM ;a := flag for this line type
IORM A,SDRHST ;Show we've seen one
MOVX A,FS%RMF!FS%SDR ;Already have higher priority spec?
TDNE A,SDRHST
RET ;Yes
CALLRET SDRRM0 ;No, go scan for the sender
; Here to process "Reply-to:" line
SDRRPL: MOVX A,FS%RPL ;a := flag for this line type
IORM A,SDRHST ;Show we've seen one
MOVX A,FS%RMF!FS%SDR!FS%FRM ;Already have higher priority spec?
TDNE A,SDRHST
RET ;Yes
CALLRET SDRRM0 ;No, go scan for the sender
; Here to process "Mail-from:" line
SDRNTM: MOVX A,FS%NTM ;a := flag for this line type
IORM A,SDRHST ;Show we've seen one
RET
; Here on error in parsing sender address line
SDRXXX: HLLZS SDRHST ;Clear the sender address stuff
SETZM SDRNAM
RET
; Parse a line for sender's name and host
; Entry: Input line set up to parse
; Call: CALL GTSNDR
; Return: +1, error, no valid address
; +2, success, b = host site, c/d = sender name ptr/cnt
GTSNDR: STKVAR <SDRHSP,SDRNPT,SDRNCT,SAVEB,SAVEC,SAVED>
TXZ F,FP%LBK!FP%RBK!FP%DQT ;Clear flags
DMOVE C,PCLNBP ;Set to scan from ":"
CALL PARST1 ;Adjust counts
GTSND0: SETZM SDRHSP ;Reset host/name
SETZM SDRNPT
TXZ F,FP%HST ;Not collecting host yet
CALL GTSFLD ;Scan a field of the input string
JUMPL B,R ;If questionable char, do error return
MOVEM T,SDRNPT ;Save the name ptr/cnt
MOVEM TT,SDRNCT
TXNN F,FP%SEP ;Special char term?
JRST GTSND3 ;Yes
; Here to check for "at" field signalling host name
GTSND1: CALL GTSFLD ;Get the next field
JUMPL B,R ;Quit on questionable char
IFXE. F,FP%SEP ;This field end with separator?
SETZM SDRNPT ;No, bad syntax
JRST GTSND4 ;Try to make sense of spec char
ENDIF.
TXZ A,10040 ;Capitalize last two small letters
CAIN A,"AT" ;Is it "at"?
JRST GTSND5 ;Yes, process host name
SETZM SDRNPT ;Random string format, flush ptr
GTSND2: CALL GTSFLD ;Look for field ending with a spec char
JUMPL B,R ;Quit on error
TXNN F,FP%SEP ;This field term with separator?
JRST GTSND4 ;No, better be eol or bracket
JRST GTSND2 ;Scan further
; Here when hit special char
GTSND3: CAIN B,"@" ;At-sign?
JRST GTSND5 ;Yes, end name and start host
GTSND4: CAIN B,.CHCRT ;End of line?
JRST GTSND6 ;Yes
CAIE B,.CHDQT ;Start of quoted string?
IFSKP.
TXOE F,FP%DQT ;Yes, set flag and check for error
RET ;Shouldn't be here then
JRST GTSND0 ;Start collection over
ENDIF.
CAIE B,"<" ;Left angle-bracket?
IFSKP.
TXOE F,FP%LBK ;Yes, mark it and check for earlier one
RET ;Can't have more than one
JRST GTSND0 ;OK, start over
ENDIF.
CAIE B,">" ;Right angle-bracket?
IFSKP.
TXO F,FP%RBK ;Yes, set flag
JRST GTSND6 ;Check it out
ENDIF.
RET ;No, can't make sense of it, bomb!
; Here when saw "@" or "at". Should get host name next
GTSND5: CALL GTSFLD ;Get the next field
JUMPL B,R ;Quit on weird char
JUMPE TT,GTSND4 ;If null string, check terminator
MOVEM B,SAVEB ;Save current field info
MOVEM C,SAVEC
MOVEM D,SAVED
DMOVE C,T ;Get ptr to this field
CALL PARHST ;Lookup the host name
RET ;No go, punt
TXON F,FP%HST ;Good host, already have one?
MOVEM B,SDRHSP ;No, save this host site entry
MOVE D,SAVED ;Restore field scanning information
MOVE C,SAVEC
MOVE B,SAVEB
TXNN F,FP%SEP ;Last field end with separator?
JRST GTSND3 ;No, check out special char
JRST GTSND1 ;Better be more host stuff!
; Here when done processing line
GTSND6: SKIPN SDRNPT ;Find a name?
RET ;No
TXCE F,FP%LBK!FP%RBK ;Either no <>
TXCN F,FP%LBK!FP%RBK ;Or matching set?
TRNA ;OK
RET ;Bad news
MOVE D,SDRNCT ;b,c,d := host site and ptr/cnt
MOVE C,SDRNPT
MOVE B,SDRHSP
RETSKP ;Return +2 - sender found
ENDSV.
; Routine to scan for next field in sender address
; Entry: c/d = ptr/cnt to remainder of line
; Call: CALL GTSFLD
; Return: +1, always
; t = starting ptr, tt = char count for field
; a = last 5 chars of field
; b = terminating char
; fp%sep set if terminated by special char
GTSFLD: SETZB T,TT ;Clear field string ptr/cnt
SETZ A, ;Clear shift reg for last chars in field
TXZ F,FP%SEP ;Reset separator flag
GTSFL0: CALL GTSCHR ;Get a char
JRST GTSFL0 ;+1, ignore leading separators
RET ;+2, special char - return
MOVE T,C ;+3, regular char - save starting ptr
ADD T,[7B5]
GTSFL1: ADDI TT,1 ;Bump char counter
LSH A,7 ;Accumulate last chars of field
IORI A,0(B)
CALL GTSCHR ;Get next character
TXO F,FP%SEP ;+1, separator - set flag
RET ;+2, special char - return
JRST GTSFL1 ;+3, regular char - continue collecting
; Get next input character in scanning for sender address. Skips over
; multiple blanks, tabs, and comments (...), checks for allowed special
; chars: "@" "<", ">", or <crlf>. Other special chars abort the parsing
; and require human intervention to decode the address: ",", ";", or ":".
; Entry: c/d = source byte ptr/cnt
; Call: CALL GTSCHR
; Return: +1, separator seen, b = space
; +2, special character, b = character
; +3, normal character, b = character
; Updates c/d appropriately
GTSCHR: CALL GTSLDB ;Fetch a byte
JRST GTSCH4 ;eol
IFXN. F,FP%DQT ;Quoted string?
CAIE B,.CHDQT ;Yes, ending now?
JRST R2SKP ;No, take char as is
TXZ F,FP%DQT ;Turn off quote flag
JRST GTSCH1 ;And make like it is a separator
ENDIF.
CAIE B,.CHSPC ;Space?
CAIN B,.CHTAB ;Tab?
JRST GTSCH1 ;Yes
CAIN B,"(" ;Start of comment?
JRST GTSCH2 ;Yes
CALL CHKSPC ;Address punctuation?
RETSKP ;Yes, return +2
JRST R2SKP ;No, treat as regular char, return +3
; Here to process separators
GTSCH1: CALL GTSLDB ;Fetch a byte
JRST GTSCH4 ;EOL
CAIE B,.CHSPC ;Space or tab?
CAIN B,.CHTAB
JRST GTSCH1 ;Yes, skip over it
CAIE B,"(" ;Start of comment?
JRST GTSCH3 ;No, end of separator
; Here to skip over a comment (...)
GTSCH2: CALL GTSLDB ;Fetch a byte
IFNSK.
SETO B, ;eol before matching ")", fail
RETSKP ;Return +2 (special char)
ENDIF.
CAIN B,")" ;End of comment?
JRST GTSCH1 ;Yes, back to skipping separtors
JRST GTSCH2 ;Find end of comment
; Here on end of a separator
GTSCH3: CALL CHKSPC ;Special char after the separator?
RETSKP ;Yes, return it +2
MOVEI B,.CHSPC ;Return " " for separator
ADD C,[7B5] ;Back up input ptr/cnt
AOJA D,R
; Here on end of line
GTSCH4: MOVEI B,.CHCRT ;b := <cr>
RETSKP ;Return +2 (special char)
; Routine to fetch a byte from a sender line. Ignores null's and del's.
; Entry: c/d = ptr/cnt to input line
; Call: CALL GTSLDB
; Return: +1, eol encountered
; +2, b = next char
GTSLDB: SOJL D,R ;EOL if count exhausted
ILDB B,C ;b := next char
TXNE F,FP%DQT ;Quoted string?
RETSKP ;Yes, return whatever it is
CAIE B,.CHNUL ;Null?
CAIN B,.CHDEL ;Or DEL
JRST GTSLDB ;Yes, ignore it
RETSKP ;Got a char, return +2
; Routine to categorize special chars
; Entry: b = char
; Call: CALL CHKSPC
; Return: +1, char part of address punctuation
; +2, char not part of punctuation
CHKSPC: TXNE F,FP%DQT ;Quoted string?
RETSKP ;Yes, char can't be special
CAIN B,.CHDQT ;Start of quoted string?
RET ;Yes
CAIE B,"<" ;Part of <> address subfield?
CAIN B,">"
RET ;Yes
CAIN B,"@" ;Start of host field?
RET ;Yes
CAIE B,"," ;Human intervention required?
CAIN B,";"
JRST CHKSP0 ;Yes
CAIN B,":" ;Human intervention required?
JRST CHKSP0 ;Yes
RETSKP
; Here char is not a recognized punctuation char but is not part of
; regular name either..
CHKSP0: SETO B,
RET
;; Premature EOF
QUEEOF: CALL QUEBAD ;Setup message back to luser
HRROI B,[ASCIZ/Premature end of file, /]
SOUT%
JRST QUEBDR ;Finish up
;; Bad control parameter specification
QUEBPM: CALL QUEBAD
HRROI B,[ASCIZ/Bad control parameter in line "/]
QUEBP0: SOUT%
CALL PARSTR
MOVE B,C
MOVN C,D
SOUT%
SETZ C,
JRST QUEBH1
;; Here on invalid sender spec
GQUSDB: CALL QUEBAD ;Too many, set up neg ack file
HRROI B,[ASCIZ/Invalid sender specification.
/]
SETZ C, ;Print the bad news
SOUT%
JRST QUEBDF ;Abort
;; Bad host
QUEBHS: CALL QUEBAD
HRROI B,[ASCIZ/No such host as "/]
SOUT%
HRROI B,HSTBUF
SOUT%
QUEBH1: HRROI B,[ASCIZ/",
/]
SOUT%
QUEBDR: SKIPE MSGJFN(M)
SKIPN MSGPAG(M)
IFSKP.
HRROI B,[ASCIZ/bad queue file follows:
-------
/]
SETZ C,
SOUT%
PUSH P,A
HRRZ A,MSGJFN(M)
SIZEF%
IFNSK.
HLRZ B,MSGPAG(M)
IMULI B,5000
ENDIF.
POP P,A
MOVN C,B
HRRZ B,MSGPAG(M)
IMULI B,1000
HRLI B,(<POINT 7,0>)
SKIPGE C
SOUT%
HRROI B,[ASCIZ/
-------
/]
SETZ C,
SOUT%
CLOSF%
JFATAL <Could not close queue file>
HRRZ A,MSGJFN(M) ;Get back file jfn
PUSH P,A ;Save it
TXO A,CO%NRJ
CALL UNMQUF ;Unmap
NOP
POP P,A ;And get rid of it
DELF%
JWARN <Could not delete bad queue file>
JRST QUEBRT
ENDIF.
HRROI B,[ASCIZ/ file renamed to /]
SOUT%
QUEBDF: CALL RENBAD ;Rename file as bad
HRROI B,STRBUF
SETZ C,
SOUT%
HRROI B,[ASCIZ/
-------
/]
SOUT%
CLOSF%
JFATAL <Could not close queue file>
;; Bad return
QUEBRT: CALL RELQUE ;Free entry
MOVE P,MPP ;Undo excess pushes
RET ;Single return
;;; Release storage from queue entry in M
RELQUE: PUSH P,A
PUSH P,B
PUSH P,N
PUSH P,O
HRRZ B,MSGNHD(M) ;Are there any headers allocated?
SKIPE B
CALL FREBLK
HRRZ A,MSGJFN(M)
CALL UNMQUF ;Unmap queue
NOP ;Can't happen
SKIPE N,MSGRCP(M) ;Any network recipients?
CALL RELQHS ;Yes, release the list buffers
SKIPE O,MSGLCL(M) ;Local recipients?
CALL RELQLS ;Yes, release them
SKIPE N,MSGSDR(M) ;Any "sender" specification?
CALL RELQHS ;Yes, release it
SKIPE B,MSGRPT(M) ;Any return path specification?
CALL FREBLK ;Free the return path
MOVEI B,(M) ;Release the message block itself
CALL FREBLK
POP P,O
POP P,N
JRST POPBAJ
; Routine to chase down a list of hosts/recipients, releasing the
; free space blocks in use.
; Entry: n = adr of first host entry
; Call: CALL RELQHS
; Return: +1
RELQHS: DO.
SKIPE O,HSTRCP(N) ;Any recipients for this host?
CALL RELQLS ;Yes, release them
MOVEI B,(N)
HRRZ N,HSTFLG(N) ;Link to next
CALL FREBLK ;Free this host block
JUMPN N,TOP. ;Do them all
ENDDO.
RET
; Routine to chase down a list of recipients, releasing the free space
; blocks in use for names and error msgs
; Entry: o = adr of first recipient entry
; Call: CALL RELQLS
; Return: +1
RELQLS: DO.
MOVX B,FR%ERM ;Consed error message
TDNN B,RCPFLG(O)
IFSKP.
MOVE B,RCPERR(O) ;b := error message block adr
CALL FREBLK ;Free it up
ENDIF.
MOVX B,FR%STR ;Locally generated string for name?
TDNN B,RCPFLG(O)
IFSKP.
HRRZ B,RCPBPT(O) ;Yes, can free it then
CALL FREBLK
ENDIF.
MOVEI B,(O)
HRRZ O,RCPFLG(O) ;Link to next one
CALL FREBLK ;Free this recipient block
JUMPN O,TOP. ;Do them all
ENDDO.
RET
; Routine to reset the error flags for a recipient
; Entry: o = adr of recipient block
; Call: CALL RSTRCP
; Return: +1, flags cleared and error msg block freed
; No AC's clobbered
RSTRCP: SAVEAC <B>
MOVX B,FR%ERM ;Consed error message?
TDNN B,RCPFLG(O)
IFSKP.
MOVE B,RCPERR(O) ;b := error message?
CALL FREBLK ;Free it up
ENDIF.
MOVX B,FR%FAI!FR%TMP!FR%ERM ;Clear the error flags
ANDCAM B,RCPFLG(O)
RET
; Routine to update error information for all recipients at a given
; host. If error message is already present, it is left as is unless
; the severity of the error increases from TMP to FAI.
; Entry: b = error flags
; strbuf = error msg
; saven = ptr to host block
; Call: CALL STUMSG
; Return: +1 always
STUMSG: SKIPG N,SAVEN ;n := ptr to starting recipient host
RET ;None
MOVEI O,HSTRCP(N) ;o := recipient list adr for this host
STUMS0: DO.
CALL NXTRCP ;Get the next recipient
RET ;No more, quit
JN FR%FAI,RCPFLG(O),TOP. ;Leave alone if recipient already lost hard
TXNE B,FR%FAI ;Increasing soft to hard?
CALL RSTRCP ;Yes, clear out the old stuff
CALL STEMSG ;Install new failure flags and msg
LOOP. ;Do next recipient
ENDDO.
; Routine to install failure information for addressee
; Entry: b = error flags
; strbuf = error msg (attached to user if FR%ERM on in b)
; o = adr of recipient block
; Call: CALL STEMSG
; Return: +1 always
STEMSG: SAVEAC <A>
JN FR%FAI,RCPFLG(O),R ;Leave alone if recipient already lost hard
IFXN. B,FR%ERM ;Append error msg now?
ANDQE. FR%ERM,RCPFLG(O) ;Yes, but not if a message installed already
MOVEI A,STRBUF ;a := ptr to last response
PUSH P,B ;Save flags
CALL CPYSTR ;Get a copy
MOVEM B,RCPERR(O) ;Install it
POP P,B
ENDIF.
IORM B,RCPFLG(O) ;Flag failure type
RET
; Routine to set up an appropriate failure msg for all hosts/recipients
; using the information already collected for hosts that were processed.
; If this is to dequeue the msg file, all errors become hard. If it is
; just to notify the sender, temporary errors are conjured up. Default
; errors are used when none came out of the processing.
; Entry: m = adr of message block
; Call: CALL SERRCP
; Return: +1
SERRCP: JSR SAVACS ;Save the ac's
MOVE A,[POINT 7,STRBUF] ;Set up default error msg
MOVEI B,[ASCIZ/Cannot append to mailbox/]
CALL MOVST0
MOVEI O,MSGLCL(M) ;Do locals first
TXO F,FQ%DON ;We must have done the locals
CALL SERRLS ;Hack this list
MOVE A,[POINT 7,STRBUF] ;Set up default error msg
MOVEI B,[ASCIZ/Cannot connect to host/]
CALL MOVST0
MOVEI N,MSGRCP(M) ;Now scan net recipients
DO.
HRRZ N,(N) ;n := next host block adr
JUMPE N,R ;Quit on 0
MOVX B,FH%DON ;"Host done" set?
TDNN B,HSTFLG(N)
TXZA F,FQ%DON ;No, clear flag
TXO F,FQ%DON ;Yes, record fact
SKIPG NTDEQF ;Dequeueing msg?
IORM B,HSTFLG(N) ;Yes, always show host done
MOVEI O,HSTRCP(N) ;Do recipients for this host
CALL SERRLS
LOOP. ;Do all hosts
ENDDO.
; Routine to scan a list of recipients and install failure/error
; Entry: o = adr of recipient list
; strbuf = default error string if none already given
; Call: CALL SERRLS
; Return: +1
SERRLS: DO.
HRRZ O,(O) ;o := adr of next recipient
JUMPE O,R ;Done with list
MOVE A,RCPFLG(O) ;Fetch recipient flags
JXN A,FR%FAI,TOP. ;Ignore if hard error already seen
IFXE. A,FR%TMP ;Any temporary error seen?
JXN F,FQ%DON,TOP. ;No, if host processed, assume recipients ok
ENDIF.
MOVX B,FR%ERM!FR%TMP ;If notifying sender, leave error temporary
SKIPL NTDEQF ;Dequeueing msg?
IFSKP.
ANDCAM B,RCPFLG(O) ;Yes, clear "temporary" error indicators
MOVX B,FR%ERM!FR%FAI ;And make error hard
ENDIF.
CALL STEMSG ;Set the error message
LOOP. ;Do all recipients at this host
ENDDO.
; Here to unmap a queued msg file
UNMQUF: MOVE D,MSGPAG(M)
CALL UNMQU0
SKIPA
AOS (P)
SETZM MSGJFN(M)
SETZM MSGPAG(M)
RET
UNMQU0: JUMPE D,UNMQU1
PUSH P,A
HLRZ A,D
HRRZ B,D
CALL PAGDAL
POP P,A
UNMQU1: JUMPE A,R
TXZN A,CO%NRJ ;Don't release JFNs?
IFSKP.
PUSH P,A ;Yes, save JFN
HRROI A,STRBF1 ;Buffer to put filename string into
HRRZ B,(P) ;JFN to release
MOVE C,[111110,,JS%PAF] ;Dev/dir/nam/ext/gen, punctuate
JFNS% ;Get string for this file
IFJER.
ADJSP P,-1
RET ;In case JFN already released somehow
ENDIF.
MOVX A,GJ%SHT!GJ%OLD!GJ%DEL ;Now get another JFN
HRROI B,STRBF1 ;On the same filename
GTJFN% ;Get virgin JFN in A
IFJER.
POP P,A ;Get back JFN
CLOSF% ;Flush it
NOP ;Don't care if it failed
RET
ENDIF.
POP P,B ;Old JFN in B
SWJFN% ;Make old JFN caller know about virgin JFN
ENDIF.
CLOSF% ;Flush the JFN
JWARN <Error closing queue file in UNMQUF>
RETSKP
;;; Create a response queue file for a bad one
QUEBAD: CALL RESPQF ;Initialize the file
CALL SDRADR ;Addressee = sender
CALL RESPQB ;Finish up the file
HRRZ B,MSGJFN(M)
MOVE C,[111110,,1]
JFNS%
HRROI B,[ASCIZ/
/]
SETZ C,
SOUT%
RET
;;; Rename a bad file
RENBAX: PUSH P,A ;Save a
PUSH P,A ;Save the JFN
JRST RENBA0
RENBAD: PUSH P,A ;Save present JFN
HRRZ A,MSGJFN(M)
PUSH P,A
TXO A,CO%NRJ
CALL UNMQUF ;Unmap, leave JFN
IFNSK.
ADJSP P,-1
JRST CPOPAJ
ENDIF.
RENBA0: HRROI A,STRBUF
HRRZ B,(P)
MOVE C,[110000,,1]
JFNS%
MOVE B,FILIDX ;b := index to current file type
HRRZ B,%FLSTR(B) ;b := ptr to "bad file" name
CALL MOVSTR
HRROI B,[ASCIZ/;P770000/]
SETZ C,
SOUT%
DO.
MOVX A,GJ%NEW!GJ%FOU!GJ%SHT
HRROI B,STRBUF
GTJFN%
IFJER.
CAIE A,GJFX24 ;Work around monitor bug
JWARN <Cannot get BAD file>
MOVEI A,^D5000 ;Wait 5 seconds
DISMS%
LOOP.
ENDIF.
ENDDO.
MOVE B,A
POP P,A
CALL RNMFIL ;Rename the file
IFNSK.
JWARN <Cannot rename BAD file>
EXCH A,B ;A:=existing JFN, B:=JFN we failed to rename to
RLJFN% ;Flush the failing JFN
NOP
ENDIF.
HRROI A,STRBUF
MOVE C,[111110,,1]
JFNS%
MOVE A,B
RLJFN%
JWARN
JRST CPOPAJ
;;; Create a response queue file
RESPQN: SKIPA A,[[ASCIZ/[--RETURNED-MAIL--].NEW-NOTIFY-/]]
RESPQF: MOVEI A,[ASCIZ/[--RETURNED-MAIL--].NEW-FAILURE-/]
STKVAR <<GTJARG,2>,TMPJFN,RESPQT>
MOVEM A,RESPQT ;Save queue type
HRROI A,STRBUF ;Put this file where msg file came from
HRRZ B,MSGJFN(M)
MOVE C,[110000,,1]
JFNS%
MOVE B,RESPQT
CALL MOVSTR
MOVE B,FORKX
MOVX C,^D8
NOUT%
JFATAL
MOVEI B,[ASCIZ/;P770000/]
CALL MOVST0
MOVX A,GJ%NEW!GJ%FOU!GJ%SHT
HRROI B,STRBUF
SETZ C,
DMOVEM A,GTJARG ;Save the args
DO.
DMOVE A,GTJARG ;Install args
GTJFN%
IFJER.
CAIE A,GJFX24 ;Work around monitor bug
JWARN <Cannot get queue file>
MOVEI A,^D5000 ;Wait 5 seconds
DISMS%
LOOP.
ENDIF.
MOVEM A,TMPJFN ;Save the JFN
MOVX B,<<FLD ^D7,OF%BSZ>!OF%WR>
OPENF%
IFJER.
EXCH A,TMPJFN ;Recover JFN, save error code
RLJFN% ;Release it
JWARN
MOVEI A,^D5000 ;Wait a few seconds
DISMS%
MOVE A,TMPJFN ;Recover error code
CAIE A,OPNX9 ;No error if file just busy
CAIN A,OPNX2 ;File disappeared?
LOOP. ;Yes, try again
WARN <Cannot open queue file - %1E>
LOOP.
ENDIF.
ENDDO.
HRLI A,.FBBYV ;Set to retain infinite versions
MOVX B,FB%RET
SETZ C,
CHFDB%
HRRZS A ;a := output JFN
CALLRET SDRMLA ;Write the sender header = mail agent
ENDSV.
;; Here to set up "DISCARD-ON-ERROR" parameter
; Entry: a = output jfn
DSCRDE: MOVEI B,.CHFFD ;Signal parameter start
BOUT%
HRROI B,[ASCIZ/=DISCARD-ON-ERROR
/]
SETZ C,
SOUT%
RET
; Here to finish up reply file header
RESPQB: MOVEI B,.CHFFD ;Terminate addressee headers
BOUT%
HRROI B,[ASCIZ/
Date: /]
SOUT%
SETO B, ;Now
MOVX C,OT%DAY!OT%SPA!OT%TMZ!OT%SCL!OT%822 ;RFC 822 standard date/time
ODTIM%
HRROI B,[ASCIZ/
From: The Mailer Daemon </] ;> -- so MACRO doesn't fail
SETZ C,
SOUT%
HRROI B,MLAGNT ;Use MLAGNT so user can reply
SOUT%
MOVEI B,"@"
BOUT%
MOVEI B,.CHDEL
BOUT%
HRROI B,LCLNAM ;Get local host name string
SOUT%
MOVEI B,.CHDEL
BOUT%
HRROI B,[ASCIZ/>
To: /]
SOUT%
MOVE D,MSGSDR(M) ;d := entry adr for sender
HRRZ C,HSTRCP(D)
MOVE B,RCPBPT(C) ;b,c := ptr,-cnt to sender name string
MOVN C,RCPCNT(C)
SOUT% ;write the sender's address
MOVEI B,"@"
BOUT%
MOVEI B,.CHDEL
BOUT%
HRRO B,HSTHST(D) ;Get the host pointer
SOUT%
MOVEI B,.CHDEL
BOUT%
HRROI B,[ASCIZ/
Subject: /]
SOUT%
RET
; Routine to output the sender as "sender" or "addressee" in mail file
; header
; Entry: a = output JFN
; m = ptr to queued msg block
; Call: CALL SDRHDR ("sender" = sender)
; CALL SDRADR ("addressee" = sender)
; Return: +1, b = ptr to sender host string
SDRHDR: MOVEI B,.CHFFD ;Do ff to signal host
BOUT%
MOVX B,"_" ;Flag "sender" header
SKIPA
SDRADR: MOVX B,.CHFFD ;Do ff to signal host
BOUT%
PUSH P,C ;Save ac's
PUSH P,D
MOVE D,MSGSDR(M) ;d := hst entry adr for sender
HRRO B,HSTHST(D) ;b := file site tbl adr for host
SETZ C,
SOUT%
HRROI B,CRLF0 ;Terminate line
SOUT%
HRRZ C,HSTRCP(D) ;d := adr of sender recipient list
MOVE B,RCPBPT(C) ;b,c := ptr,-cnt to sender name string
MOVN C,RCPCNT(C)
SOUT%
HRROI B,CRLF0 ;Terminate line
SOUT%
POP P,D ;Recover working ac's
POP P,C
RET
; Routine to output a "sender" = mail agent header
; Entry: a = output JFN
; Call: CALL SDRMLA ("sender" = mail agent)
; CALL MLAADR ("addressee" = mail agent)
; Return: +1
SDRMLA: MOVEI B,.CHFFD ;Do ff to signal host
BOUT%
MOVX B,"_" ;Flag "sender" header
SKIPA
MLAADR: MOVX B,.CHFFD ;Do ff to signal host
BOUT%
HRROI B,LCLNAM ;Get local name string
SETZ C,
SOUT%
HRROI B,CRLF0
SOUT%
HRROI B,MLAGNT ;Now the mail agent's name
SOUT%
HRROI B,CRLF0
SOUT%
RET
;;; Generate headers for message in M to host in A
; B has the ultimate host pointer while A has the "neighbor" host
; host pointer
GENHDL: SETZ A, ;Local host; no special transmogrification
SKIPA E,[LCLNAM] ;Don't convert LCLNAM to LCLNCN
GENHDR: MOVEI E,LCLNCN ;Convert LCLNAM to LCLNCN
JSR SAVACS ;Save all AC's
STKVAR <LCLHPT,DSTHPT,<HSTTMP,^D52>,LINCNT,ULTHPT>
MOVEM B,ULTHPT ;Save ultimate destination host pointer
MOVEM A,DSTHPT ;Save destination host pointer
MOVEM E,LCLHPT ;Save local name pointer
DMOVE X,MSGHDR(M) ;Start of headers of message
SKIPN O,MSGNHD(M) ;Was there a block from last time?
IFSKP.
HRRZ A,-1(O) ;Get size of block
ELSE.
MOVEI A,100 ;Nominal block to allocate
CALL ALCBLK
FATAL <Memory exhausted>
MOVEI O,(B)
MOVEM O,MSGNHD(M)
ENDIF.
HRLI O,(<POINT 7,0>)
MOVEI N,(A)
IMULI N,5 ;Number of bytes available
MOVEM N,HDRLEN ;Save it in case we grow
DO. ;Output BP in O, free byte count in N
DMOVEM X,MSGTXT(M)
CALL PARLIN ;Read a line
IFNSK.
MOVE C,[POINT 7,CRLF0] ;Failed, just write CRLF
MOVEI D,2
EXIT.
ENDIF.
IFXN. F,FP%EOL ;Blank line?
DMOVEM X,MSGTXT(M) ;Update start of actual message text
MOVE C,[POINT 7,[BYTE (7) .CHCRT,.CHLFD,.CHCRT,.CHLFD,.CHNUL]]
MOVEI D,4
EXIT. ;Yes, finish up then
ENDIF.
IFXE. F,FP%CLN!FP%WSP ;Looks like a valid line?
MOVE C,[POINT 7,CRLF0] ;No, just write CRLF
MOVEI D,2
EXIT.
ENDIF.
IFXE. F,FP%DEL ;Is this a special line?
CALL OUHNWL ;New line
CALL PARSTR ;Get whole line
CALL OUHSTR ;Finish
LOOP. ;And go hack next line
ENDIF.
MOVE T,PLINBP+1 ;Save line context (may get host error)
MOVEM T,LINCNT
CALL PARDEL ;Canonicalize lengths
DMOVE C,PDELBP ;Start of host
CALL PARHST ;Parse it
IFNSK.
MOVE T,LINCNT ;Bad host! Restore line context
MOVEM T,PLINBP+1
CALL OUHNWL ;Make like never saw <del>'s
CALL PARSTR ;Get whole line
CALL OUHSTR ;Output it
LOOP. ;And go hack next line
ENDIF.
MOVEI A,HSTTMP ;Copy returned string so we can muck it
HRLI A,(<POINT 7,>) ;Make string pointer
MOVEM A,PDELBP ;Save pointer
CAIN B,LCLNAM ;Local host name returned?
MOVE B,LCLHPT ;Yes, use local name for this network
MOVE C,ULTHPT ;Ultimate destination host pointer
MOVE D,DSTHPT ;Destination host pointer
CALL TRNMGR ;Transmogrify host
IFSKP.
SOS PLINBP+1 ;Flush "@" preceeding
SOS PWSPBP+1
ENDIF.
SETZ C, ;Now count its length
DO.
ILDB B,A ;Get byte
CAIE B,.CHNUL ;Null?
AOJA C,TOP. ;No, count it and do another
ENDDO.
MOVEM C,PDELBP+1 ;Save length too
IFXN. F,FP%WSP ;Is this a continuation line?
MOVEI T,1(E) ;Length of line so far, plus a new space
ADD T,PWSPBP+1 ;Plus line without whitespace
ADD T,PDELBP+1 ;Plus start of host
ADD T,PDELB2+1 ;Plus end of host
CAIL T,^D79 ;Is that a reasonable length line?
IFSKP.
MOVEI T,.CHSPC ;Yes, put in a space
CALL OUHCHR
DMOVE C,PWSPBP ;And use start of stuff after whitespace
ELSE.
CALL OUHNWL ;New line
DMOVE C,PLINBP ;Use start of line
ENDIF.
ELSE.
CALL OUHNWL ;New line
DMOVE C,PLINBP ;Use start of line
ENDIF.
CALL OUHSTR ;Output it
DMOVE C,PDELBP ;First part of host
CALL OUHSTR ;Output that
DMOVE C,PDELB2 ;Rest of line
CALL OUHSTR ;Finish
LOOP. ;And go hack next line
ENDDO.
CALL OUHSTR
MOVE T,MSGNHD(M)
HRRZ T,-1(T) ;Length of block
IMULI T,5 ;Total bytes
SUB T,N ;Less bytes left is bytes used
HRLM T,MSGNHD(M)
RET
ENDSV.
;TRNMGR - transmogrify host name for destination host
; A/ output byte pointer
; B/ host pointer
; C/ ultimate destination host pointer
; D/ destination host pointer
; Returns +1 if no transmogrification is needed
; +2 if transmogrified so preceeding "@" should be flushed.
;
TRNMGR: SAVEAC <A,B,C,D> ;Don't clobber invoker's context
STKVAR <BUFPTR,SRCPTR,DSTPTR,DOMPTR,ULTPTR,UPPLIM,INTDOM,ATPTR>
MOVEM A,BUFPTR ;Save the output buffer pointer
HRRZM B,SRCPTR ;Save source pointer
MOVEM C,ULTPTR ;Ultimate destination pointer
HRRZM D,DSTPTR ;Save destination pointer
CALL MOVST0 ;Make copy of src to output buffer
MOVE A,BUFPTR ;Remove relative domains
CALL $RMREL
; Don't transmogrify if the source and destination are on the same network
; providing that network is a full-connectivity net. At the present time,
; only Special is not (or rather is not guaranteed to be such). This tries
; to avoid unnecessary transmogrification.
MOVE A,SRCPTR ;Check source
HRLI A,(<POINT 7,>)
SETZM DOMPTR ;Look for relative domain
DO.
ILDB B,A
IFN. B
CAIN B,"."
MOVEM A,DOMPTR
LOOP.
ENDIF.
ENDDO.
ILDB A,DOMPTR ;Now see if it's really relative
CAIE A,"#"
IFSKP.
MOVE A,DOMPTR ;It is, see if it's a full-connectivity net
HRROI B,[ASCIZ/Special/] ;"Special" is the only one that isn't
STCMP%
ANDN. A ;Full-connectivity net?
MOVE A,ULTPTR ;Check destination
HRLI A,(<POINT 7,>)
SETZM ATPTR ;Look for relative domain in destination
DO.
ILDB B,A
IFN. B
CAIN B,"."
MOVEM A,ATPTR
LOOP.
ENDIF.
ENDDO.
ILDB A,ATPTR ;Now see if it's really relative
CAIE A,"#"
ANSKP.
MOVE A,DOMPTR ;It is, see if it's the same net
MOVE B,ATPTR
STCMP%
JUMPE A,R ;If the same, then no transmogrification
ENDIF.
SETZM DOMPTR ;See if there is a real domain
MOVE A,BUFPTR
DO.
ILDB B,A
IFN. B
CAIN B,"." ;Domain separator?
MOVEM A,DOMPTR ;Save the pointer for later
LOOP.
ENDIF.
ENDDO.
SKIPN B,DOMPTR ;Is there a domain?
IFSKP.
MOVE A,DOMTBL ;Yes, it one of the pseudo-domains?
TBLUK%
IFXE. B,TL%EXM ;Found it?
SKIPN TRALLP ;No, do we always transmogrify?
RET ;No, no transmogrification needed then
ELSE.
SETZ C,
DPB C,DOMPTR ;Remove pseudo-domain
MOVE A,DOMPTR ;Pointer to pseudo-domain
HRROI B,[ASCIZ/$Internet/]
STCMP% ;See if going to Internet
JUMPE A,R ;Yes, so don't bother transmogrifying
ENDIF.
ENDIF.
;Try to transmogrify the source so that the destination will know about it
SKIPN DSTPTR ;Local delivery?
RET ;Yes, return
MOVE A,SRCPTR ;The source host
MOVE B,ULTPTR ;This destination host
CALL TRNBLD ;Build relay tables, SRLYTB, DRLYTB
SETZM PTHLST ;Set the first element of the path 0 to start
;Find the Internet domain block address; save it in INTDOM
MOVE A,DOMTBL ;Yes, is the domain relayed to?
HRROI B,[ASCIZ/$Internet/]
TBLUK%
TXNE B,TL%NOM ;Find it?
TDZA B,B ;Didn't find it, Internet not defined here
HRRZ B,(A) ;Yes, get domain block address in B
MOVEM B,INTDOM ;Internet domain block address
;Add the source host to our path first
SKIPN A,INTDOM ;A/ domain block; is it in the Internet domain?
IFSKP.
HRRZ B,DM%RLY(A) ;Get the relay pointer
CAME B,SRCPTR ;Is source host in Internet?
ANSKP.
MOVEI B,DM%TRN ;Yes, it is Internet use transmog. string
CALL PTHADD ;Put it in the path
JRST BLDPTH ;Since Internet, jump directly to build path
ENDIF.
MOVE D,DOMTBL ;Set up aobjn pointer to domain table
HLL D,(D)
TXC D,.LHALF
DO. ;Look for destination host
AOBJP D,ENDLP. ;Next domain
HRRZ A,(D) ;Get domain block
HRRZ C,DM%RLY(A) ;Get the host pointer
CAME C,SRCPTR ;Is it the same as the source host?
LOOP. ;No, go for more
ENDDO.
IFGE. D ;Is host a relay?
MOVE A,SRCPTR ;No
SETZ B,
ELSE. ;Yes it is host relay
MOVEI B,DM%RLY ;Not Internet, use relay string
ENDIF.
CALL PTHADD ;Add this host
;One last chance to check if we really need to transmogrify
MOVE A,SRCPTR
CAMN A,ULTPTR ;If source and destinations are the same
RET ;Then no need to do anything!
;Ascend the source table
SKIPN SNRLYS ;Any relays in source?
IFSKP. ;Yes, let's process
SETZ D, ;Start at the bottom
DO.
MOVE A,SRLYTB(D) ;Get the domain block pointer
MOVEI B,DM%RLY ;Which transmogrification string to use
CALL PTHADD ;Add this relay to the path construct
CAMN A,INTDOM ;Is it magic Internet domain?
JRST BLDPTH ;Yes, jump out
ADDI D,1 ;Increment index
CAMGE D,SNRLYS ;Less than the number of relays?
LOOP. ;Yes, loop around
ENDDO.
ENDIF.
;Add our local host here
MOVEI A,LCLNCN ;Our local name
SETZ B, ;Only a string
CALL PTHADD ;Add it to path
;now descend destination table
SKIPN D,DNRLYS ;Any relays in destination?
IFSKP. ;Yes, let's process
SUBI D,1 ;Index to start with
DO.
MOVE A,DRLYTB(D) ;Get the domain block pointer
MOVEI B,DM%TRN ;Which transmogrification string to use
CALL PTHADD ;Add this relay to the path construct
CAMN A,INTDOM ;Is it magic Internet domain?
JRST BLDPTH ;Yes, jump out
SOJGE D,TOP. ;If not bottom of the table, loop.
ENDDO.
ENDIF.
;Build the transmogified path using PTHLST
BLDPTH: SKIPN DNRLYS ;From destination to source?
SKIPN PTHEND ;More than one in the path?
IFSKP.
MOVE D,PTHEND ;Yes, get the offet of the last entry
DO.
HLRZ C,PTHLST(D) ;Get the domain flags
IFE. C ;Is it a plain string?
HRRZ A,PTHLST(D) ;Yes, get the string address
ELSE. ;Not a string, it is a domain block
HRRZ B,PTHLST(D) ;Get the domain block
HRRZ A,DM%RLY(B) ;Get a string pointer
ENDIF.
CAME A,DSTPTR ;Is it the same as the destination
IFSKP.
SETZM PTHLST(D) ;Yes, zap it from the list
EXIT. ;And done
ENDIF.
SOJG D,TOP. ;Otherwise loop until done
ENDDO.
ENDIF.
MOVE B,BUFPTR
SETZ A,
IDPB A,B ;Re-init output string by putting a zero
MOVEI D,PTHLST ;Start at the beginning of the path list
DO.
HLRZ C,(D) ;Get the flag of the entry
IFE. C ;Is it a string pointer?
HRRZ B,(D) ;Yes, get the address
MOVE A,[POINT 7,STRBF2]
CALL MOVST0 ;Make a copy of the string
MOVEI A,STRBF2
CALL RMDOM1 ;Remove the pseudo-domain
MOVE B,[POINT 7,STRBF2]
MOVEI C,"%" ;Use a % for relaying
ELSE. ;Not a string pointer, but a domain pointer
HRRZ B,(D) ;Get the domain block pointer
CAIE C,DM%TRN ;Use transmog. string as host name relay?
IFSKP. ;Yes, no need to fool around with domains
MOVE B,DM%TRN(B)
HRLI B,(<POINT 7,>) ;Point to the transmog. string
ILDB C,B ;Get the relay character
ELSE. ;Use relay string as host name relay
PUSH P,B ;Save the domain pointer
MOVE B,DM%TRN(B)
HRLI B,(<POINT 7,>) ;Point to the transmogrification string
ILDB C,B ;And get the relay character
POP P,B ;Now get the domain block pointer back
MOVE B,DM%RLY(B)
HRLI B,(<POINT 7,>) ;Point to the relay string instead
MOVE A,[POINT 7,STRBF2]
CALL MOVST0 ;Make a copy of the relay string
MOVEI A,STRBF2
CALL RMDOM1 ;Get rid of the pseudo-domain
MOVE B,[POINT 7,STRBF2]
ENDIF.
ENDIF.
;A/ output buffer B/ string to append C/ prepend character
MOVE A,BUFPTR
CALL HSTAPP ;Append this host to path
MOVEM B,ATPTR ;Save the byte pointer to the last @ sign
ADDI D,1 ;Look at next element in path list
SKIPE (D) ;End of list?
LOOP. ;No, loop
ENDDO.
MOVEI A,"@" ;The last relay character must be @ sign
DPB A,ATPTR ;Put it there
RETSKP ;Say we did a transmogrification
ENDSV.
;A/ byte pointer to host string to tweak
;
;Returns +1 always
; no change to ACS; string should be tweaked
;
RMDOM1: SAVEAC <A,B,C>
STKVAR <DOMPTR>
HRLI A,(<POINT 7,>)
CALL $RMREL
SETZM DOMPTR ;See if there is a real domain
DO.
ILDB B,A ;Get a character from the string
IFN. B ;Null (end of string)?
CAIN B,"." ;Nope, check if domain separator
MOVEM A,DOMPTR ;Yes, save the pointer for later
LOOP. ;Back for more
ENDIF.
ENDDO.
SKIPN B,DOMPTR ;See a domain?
IFSKP.
MOVE A,DOMTBL ;Look at know domains
TBLUK% ;Is it one of ours?
JXE B,TL%EXM,R ;No, don't do anything
SETZ A, ;Yes, remove pseudo-domain
DPB A,DOMPTR
ENDIF.
RET
ENDSV.
;A/ output byte pointer
;B/ string pointer
;C/ prepend character
;
; Returns +1 always
; B has byte pointer where prepend character was put
;
HSTAPP: SAVEAC <A,C,D>
STKVAR <STRPTR>
MOVEM B,STRPTR ;Save string pointer
DO. ;Look for null at end of string
ILDB B,A ;Get a character
JUMPN B,TOP. ;If not null step through string
ENDDO.
MOVE D,A ;Save the atsign pointer
DPB C,A ;Put the prepend character into string
MOVE B,STRPTR ;Get the string pointer again
CALL MOVST2 ;Append the string
MOVE B,D ;Here is the atsign pointer
RET
ENDSV.
;A/ byte pointer to the source host
;B/ byte pointer to the ultimate destination host
;
; Returns +1 always
; This routine builds the relay tables SRLYTB and DRLYTB.
; SNRLYS and DNRLYS are updated to reflect the number of relay entries
; in the respective tables.
;
TRNBLD: SAVEAC <A,B>
STKVAR <DSTPTR>
MOVEM B,DSTPTR ;Save destination pointer
CALL SRCPTH ;Build source table
MOVE A,DSTPTR ;Get the destination pointer back
CALLRET DSTPTH ;Build destination table
ENDSV.
;A/ host pointer to source host
; Returns +1 always
SRCPTH: SAVEAC <A,B,C,D>
STKVAR <SRCPTR>
MOVEM A,SRCPTR
SETZM SNRLYS ;No relays yet
;Test for local host here if source is local return
HRRZ A,SRCPTR ;Get source pointer
CAIN A,LCLNCN ;Local host
RET
;First do source. Find a path from the source host to us
DO.
HRRO A,SRCPTR ;Get name of host to check
MOVEI C,SNDRTS ;Try direct protocols first
CALL GETPRO ;Is it directly connected to us?
IFSKP.
CAME B,$UKHST ;Do the relay thing if we really don't know
RET ;Looks good, return
ENDIF.
HRRO A,SRCPTR ;Get the host to find relay for
CALL $GTRLY ;Get the relay
RET
MOVE A,DM%RLY(B) ;Get the pointer
MOVEM A,SRCPTR ;Save it as the next host pointer
MOVE A,SNRLYS ;Get the number of relays
MOVEM B,SRLYTB(A) ;Save the domain block pointer
AOS SNRLYS ;Increment number of relays we saw
LOOP. ;Go up and try again
ENDDO.
ENDSV.
;A/ pointer to destination host pointer
; Returns +1 always
;Now do destination. Find a path from the destination host to us
DSTPTH: SAVEAC <A,B,C,D>
STKVAR <DSTPTR>
MOVEM A,DSTPTR
SETZM DNRLYS
HRRZ A,DSTPTR ;Get destination pointer
CAIN A,LCLNCN ;Is it local?
RET ;Yes, return
DO.
HRRO A,DSTPTR ;Get name of host to check
MOVEI C,SNDRTS ;Try direct protocols first
CALL GETPRO ;Is it directly connected to us?
IFSKP.
CAME B,$UKHST ;Do the relay thing if we really don't know
RET ;Looks good, return
ENDIF.
HRRO A,DSTPTR ;Get the host to find relay for
CALL $GTRLY ;Get the relay
RET ;Probably local host
MOVE A,DM%RLY(B) ;Get the pointer
MOVEM A,DSTPTR ;Save it as the next host pointer
MOVE A,DNRLYS ;Get the number of relays
MOVEM B,DRLYTB(A) ;Save the domain block pointer
AOS DNRLYS ;Increment number of relays we saw
LOOP. ;Go up and try again
ENDDO.
ENDSV.
;A/ domain block pointer or string pointer
;B/ if 0, A is string pointer
; if non-zero, A is a domain block pointer and the value of B
; is the offset into the domain block for transmogrification string
PTHADD: SAVEAC <A,B,C,D>
SETZ D,
HRRZ A,A ;Only address, just in case
DO. ;Step through list looking for duplicates
SKIPN C,PTHLST(D) ;Get element from path list
IFSKP.
HRRZ C,C ;Only the address
CAMN C,A ;Are the 2 domains the same?
EXIT. ;Yes, out of loop
ADDI D,1 ;No, incr. index
LOOP.
ENDIF.
ENDDO.
;D/ where to put the domain or string pointer
HRL A,B ;Move the flag bits to LH of A
MOVEM A,PTHLST(D) ;Save the next path
MOVEM D,PTHEND ;Save the end of the list
ADDI D,1 ;Next location
SETZM PTHLST(D) ;Zero the next location to end list
RET
;;; Header string output routines, byte pointer is in O,
;;; count of bytes left is in N, length of line is in E
OUHNWL: DMOVE C,[POINT 7,CRLF0
2]
TDZA E,E ;Init to 0
OUHSTR: ADDI E,(D) ;Update length of line
JUMPE D,R ;Nothing if empty string
SAVEAC <C,D>
DO.
ILDB T,C
CALL OUHCHR
SOJG D,TOP.
ENDDO.
RET
OUHCHG: MOVE B,MSGNHD(M)
HRRZ A,-1(B) ;Length of block now
ADDI A,100 ;Increment by this much
SUBI O,(B) ;Make pointer relative in case relocated
CALL GROBLK
FATAL <Memory exhausted>
MOVEM B,MSGNHD(M)
ADDI O,(B) ;Make pointer absolute again
IMULI A,5 ;Number of bytes total available
MOVE N,HDRLEN ;Get previous size of block
SUBM A,N ;Update now available
MOVEM A,HDRLEN ;Update for current size
OUHCHR: SOJL N,OUHCHG ;Room left in buffer?
IDPB T,O ;Yes, just stick it in
RET
SUBTTL Sending routines
;;; Send the message in M
SNDMSG: JSR SAVACS ;I don't know why, but it's necessary
STKVAR <RLYLST>
SETZM RLYLST
TXZ F,FM%RLY ;Not relaying here
MOVEI N,MSGRCP(M) ;Start of recipient list
DO.
SKIPN MSGTMT(M) ;Total timeout for msg?
IFSKP.
TIME% ;Yes, elapsed yet?
CAML A,MSGTMT(M)
RETSKP ;Yes, quit on this round
ENDIF.
;The following loop looks for the next physical host. If we are in the
;middle of relaying, it will try the next host in the list of possible
;relays. Otherwise, it will try the next host in the list of recipient
;hosts. The only exit from this loop is the success return from GETPTH.
;So after this loop, the AC's will be set as in GETPTH, for some
;physical host (i.e. if we have to relay, the relay host).
DO. ;Look for a host to send to
IFXE. F,FM%RLY ;Have we been relaying?
HRRZ N,(N) ;No, get next host
JUMPE N,RSKP ;None, done for now
MOVX TT,FH%DON ;Already done this one?
TDNE TT,HSTFLG(N)
LOOP. ;Yes, look at the next
HRRZ B,HSTHST(N) ;Get host pointer
CALL GETPTH ;Do we have a direct path?
IFSKP. <EXIT.> ;Yes, do it then
HRRO A,HSTHST(N) ;Get back the host
CALL $GTRLY ;See if we can relay to it
LOOP. ;No, so much for that host...
SKIPN B,DM%RLY(B) ;Get list of relays
LOOP. ;None
MOVEM B,RLYLST ;Initial current list pointer
TXO F,FM%RLY ;Note that we are relaying
ENDIF.
; Try to find physical host to send to. This will recurse as necessary.
;Someday this routine needs to be rewritten to be somewhat more general and
;allow more flexibility in MAILER-RELAY-INFO.TXT.
DO.
MOVE B,RLYLST ;Get current relay list pointer
CALL GETPTH ;Have a path to this relay?
IFSKP. <EXIT.>
HRRO A,RLYLST ;Let's see if we can relay to it
CALL $GTRLY ;Well?
IFSKP.
MOVE B,DM%RLY(B) ;Yes, get host we can relay to
ELSE.
HLRZ B,RLYLST ;Get pointer to more
SKIPE B ;Is there?
MOVE B,(B) ;Yes, go get it
ENDIF.
MOVEM B,RLYLST ;Save current pointer
JUMPN B,TOP. ;Try again if any more to go
ENDDO.
IFE. B ;Found a host to send this to?
TXZ F,FM%RLY ;No, fail utterly
LOOP. ;Do next host
ENDIF.
ENDDO.
MOVX TT,FH%DN1 ;Mark that we are trying to do this one
IORM TT,HSTFLG(N)
MOVEI O,HSTRCP(N) ;Point to start of recipients
MOVEM C,FRNADR ;Save returned host address
MOVEM B,FRNHST ;Remember the host we're connecting to
HRRO B,HSTHST(N) ;Get final destination
CIETYPE < Queued mail for %2W>
HLRZ T,E ;Get protocol name
IFXN. F,FM%RLY ;If relaying
HRRO B,FRNHST ;Get back immediate destination
ETYPE < routing via %2W using %6W>
ELSE.
ETYPE < using %6W>
ENDIF.
TXZ F,FM%FAI ;Haven't failed
MOVEM N,SAVEN ;Save the position in the host list
HRRZ A,HSTHST(N) ;Get final destination
MOVE B,FRNHST ;Get back host pointer
MOVE C,FRNADR ;Get the address back
CALL (E) ;Call the routine
IFNSK.
TXO F,FM%FAI ;Failed
TYPE < failed.>
IFXN. F,FM%RLY ;If relaying
HLRZ T,RLYLST ;Then go to next possible host
SKIPE T ;If zero, no more relays
SKIPN T,(T) ;Else get next relay
TXZ F,FM%RLY ;Note we're no longer relaying
MOVEM T,RLYLST
ENDIF.
ELSE. ;If it succeeded
SETZM RLYLST ;Forget any further possible relay hosts
TXZ F,FM%RLY ;Note we're no longer relaying
SKIPN A,STAJFN ;Doing statistics?
ANSKP.
HRRO B,FRNHST ;Get back host pointer
SETZ C, ;Null-terminated
SOUT%
ERJMP .+1
MOVX B,"," ;Delimiter
BOUT%
ERJMP .+1
HLRZ B,MSGNHD(M) ;Length of headers generated
ADD B,MSGTCN(M)
MOVX C,^D10 ;In decimal
NOUT%
ERJMP .+1
HRROI B,CRLF0 ;Finally output CRLF
SETZ C,
SOUT%
ERJMP .+1
ENDIF.
MOVE T,SAVEN ;Recover starting recipient host
DO.
MOVX TT,FH%DN1 ;Check if "about to be done"
TDNN TT,HSTFLG(T)
IFSKP.
ANDCAM TT,HSTFLG(T) ;If so, clear that
MOVX TT,FH%DON
TXNN F,FM%FAI ;Unless it failed
IORM TT,HSTFLG(T)
ENDIF.
CAIN T,(N) ;Reached host we just processed?
EXIT. ;Yes
HRRZ T,(T) ;May have sent more, check them out
JUMPN T,TOP.
ENDDO.
MOVE N,SAVEN ;Recover starting host
LOOP. ;Loop
ENDDO.
ENDSV.
; Get the next recipient for this route, skip if success
; Call: CALL NXTRCP
; N/ Current host block
; O/ Current recipient block
; FRNHST: The current host we have a connection to
; Returns:
; +1 if no more possible recipients
; +2 new recipient
; N/ Host block (possibly changed if relaying)
; O/ Recipient block (definitely changed)
;
NXTRCP: SAVEAC <A,B,C>
HRRZ O,(O) ;Next recipient
JUMPN O,RSKP ;Found one
RET ;Don't - old optimization code is history since
; often the headers were wrong
; Find the path to a given host
; Call: CALL GETPTH
; B/ Host pointer
; Returns:
; +1 No path to host
; +2 path found
; E/ Protocol name,,routine
; B/ Host pointer
; C/ Numeric address to use for this protocol
;
GETPTH: STKVAR <HSTPTR>
MOVEM B,HSTPTR ;Set up pointer
CALL HSTDED ;Is host up?
RET ;No, no path
MOVEI C,SNDRTS ;Try direct protocols first
HRRO A,HSTPTR ;Get name
CALL GETPRO ;Try to find a protocol
RET ;None
MOVE E,(C) ;Get protocol data
MOVE C,B ;Get foreign host address for this protocol
MOVE B,HSTPTR ;Get foreign host pointer
RETSKP
ENDSV.
;;; Output host in B in absolute form to the output designator in A
HSTTSZ==^D40
OUTAHS: SAVEAC <C,D>
STKVAR <HSTPTR,<HSTTMP,HSTTSZ>>
MOVEM A,HSTPTR ;Save output designator
MOVEI A,HSTTMP ;Get copy of host name in HSTTMP
HRLI A,(<POINT 7,>)
HRLI B,(<POINT 7,>)
MOVX D,<5*HSTTSZ>-1 ;Up to this many bytes
DO.
ILDB C,B
JUMPE C,ENDLP.
IDPB C,A
SOJG D,TOP.
SETZ C, ;Tie off string
ENDDO.
IDPB C,A
HRROI A,HSTTMP ;Remove relative domains
CALL $RMREL
MOVE A,HSTPTR ;Restore output designator
HRROI B,HSTTMP ;B := host in absolute form
SETZ C,
SOUT%
RET
ENDSV.
;;; Output host in B in absolute form to the pointer in A with quoting
OUTAHQ: STKVAR <HSTPTR,<HSTTMP,^D13>>
MOVEM A,HSTPTR ;Save output designator
MOVEI A,HSTTMP ;Get copy of host name in HSTTMP
HRLI A,(<POINT 7,>)
CALL MOVST0
HRROI A,HSTTMP ;Remove relative domains
CALL $RMREL
MOVEI A,HSTTMP ;B := host in absolute form
HRLI A,(<POINT 7,>)
MOVX C,.CHCNV
DO.
ILDB B,A ;Get next byte
JUMPE B,ENDLP. ;Punt if null
CAIN B,"." ;Period that needs quoting?
IDPB C,HSTPTR ;Yes, quote it
IDPB B,HSTPTR ;Store the byte
LOOP. ;Loop for more
ENDDO.
MOVE A,HSTPTR ;Return updated pointer
IDPB B,HSTPTR ;Terminate with null
RET
ENDSV.
;;; Output this recipient to designator in A, also to terminal if appropriate
OUTRCP: STKVAR <OTRJFN,OTRHPT,OTRHCT,<HSTTMP,^D13>,UPPLIM,BUFPTR>
MOVEM A,OTRJFN ;Save JFN
MOVE C,[POINT 8,STRBF1]
DMOVE T,RCPBPT(O)
MOVEM TT,OTRHCT ;Save count before relaying
DO.
ILDB D,T
IDPB D,C ;Copy recipient to STRBF1
SOJG TT,TOP.
ENDDO.
IFXN. F,FM%RLY ;Are we relaying?
MOVEM C,BUFPTR ;Save the pointer to add transmogification
SETZM STRBF2 ;Clear the buffer
MOVEI A,HSTTMP
HRLI A,(<POINT 7,0>) ;Point to the temporary host buffer
MOVEM A,OTRHPT ;Save the pointer for later
HRRZ B,HSTHST(N) ;Get the destination host
CALL MOVST0 ;Make a copy of it
MOVE A,OTRHPT
CALL RMDOM1 ;Rip out the domain
MOVE A,[POINT 7,STRBF2] ;A/ is output buffer
MOVE B,OTRHPT ;B/ host string to add
MOVEI C,"%" ;C/ prepend char
CALL HSTAPP ;Append this host to the path
HRRZ A,HSTHST(N) ;From site entry
CALL SRCPTH ;Build a destination path
MOVE D,SNRLYS ;Get number of relays
SUBI D,2 ;Don't include our neighbor in the list
MOVEM D,UPPLIM ;Save the upper limit
IFGE. D ;Less than 0?
SETZ D, ;No, start at the bottom
DO.
MOVE B,SRLYTB(D) ;Get the domain block pointer
PUSH P,B ;Save the pointer
MOVE B,DM%TRN(B) ;Point to the relay character
HRLI B,(<POINT 7,>)
ILDB C,B ;Get the relay character
POP P,B ;Get domain block back again
MOVE B,DM%RLY(B) ;Get the relay host's name
HRLI B,(<POINT 7,>)
MOVE A,OTRHPT
CALL MOVST0 ;Make a copy of the host name
MOVE A,OTRHPT
CALL RMDOM1 ;Rip out the domain
MOVE A,[POINT 7,STRBF2] ;A/ is output buffer
MOVE B,OTRHPT ;B/ host string to add, C/ prepend char
CALL HSTAPP ;Append this host to the path
ADDI D,1 ;Increment index
CAMG D,UPPLIM ;Less than the upper limit?
LOOP. ;Yes, loop around
ENDDO.
ENDIF.
;Now to build the whole thing together
MOVE A,BUFPTR ;Where to add the host path
MOVE B,[POINT 7,STRBF2] ;Where to get the host path
DO.
ILDB D,B ;Get a character
IFN. D ;Is it null (end of string)?
IDPB D,A ;No, put the char in the output buffer
AOS OTRHCT ;Inc. the character count
LOOP.
ENDIF.
ENDDO.
ENDIF.
CITYPE < >
MOVX A,.PRIOU
MOVE B,[POINT 8,STRBF1]
MOVN C,OTRHCT ;Updated count
SKIPE PRINTP
SOUT%
TYPE <: >
MOVE A,OTRJFN ;Restore JFN
MOVE B,[POINT 8,STRBF1]
MOVN C,OTRHCT ;Updated count
SOUT%
ERJMP .+1
RET
ENDSV.
;;; Output only message headers to JFN in A
;;; Returns: +1, transmission error
;;; +2, successful
OUTMSH: STKVAR <OUTMSD>
MOVEM A,OUTMSD ;Save designator
MOVEI A,^D1000 ;Transmit 1000 bytes at a time
MOVEM A,SEGSIZ ;Set segment size
SKIPN A,MSGTMT(M) ;Overall delivery timeout in effect?
IFSKP.
TIME% ;Yes, compute time limit for this copy
ADD A,TMCINT
CAMLE A,MSGTMT(M) ;Beyond total delivery timeout?
MOVE A,MSGTMT(M) ;Yes, use that
ENDIF.
MOVEM A,MSGTMC(M) ;Record copy timeout
MOVE A,OUTMSD ;Restore designator
MOVE B,MSGNHD(M) ;Headers we generated
HLRZ C,B ;Length
HRLI B,(<POINT 7,0>) ;Build byte pointer to message
MOVNI C,(C) ;And byte count
ADDI C,2 ;Skip over the CRLF at the start
IBP B
IBP B
CALL OUTMST ;Check copy timer
JRST OUTMSF
CALL $SOUT ;If no timeout, output the headers
JRST OUTMSF
OUTMDN: AOS (P) ;Set success (+2)
OUTMSF: TMOCLR ;Disallow timer interrupts now
RET
ENDSV.
;;; Output whole text of message and headers to JFN in A
;;; Returns: +1, transmission error
;;; +2, successful
OUTMSG: CALL OUTMSH ;Output headers
RET ;+1 Transmission error
SKIPE D,MSGTCN(M) ;+3 Success. Is message body empty?
IFSKP.
HRROI B,CRLF0 ;Yes, must output at least a CRLF
SETZ C,
CALL $SOUT
JRST OUTMSF
ELSE.
MOVE B,MSGTXT(M) ;Message non-empty, get pointer to message text
DO. ;No, here with message pointer in B, count in D
TMOCLR ;Disallow timer interrupts now
CAIG D,^D1000 ;Do 1000 characters at a time
SKIPA C,D
MOVEI C,^D1000
SUBI D,(C) ;Account for this many characters output
MOVNS C ;Negative byte count for SOUT%
CALL OUTMST ;Check copy timer
JRST OUTMSF ;Timed out
CALL $SOUT ;Output the string
JRST OUTMSF
JUMPG D,TOP. ;Continue output if more bytes to go
ENDDO.
ENDIF.
JRST OUTMDN ;Message output done
;;; Output whole text of message and headers to JFN in A with period checking
;;; Returns: +1, transmission error
;;; +2, successful
MSGOUT: STKVAR <BUFPTR>
CALL OUTMSH ;Output headers
RET ;+1 Transmission error
SKIPN D,MSGTCN(M) ;Get text count or flag text empty
IFSKP. ;Message non-empty with count in D
MOVE B,MSGTXT(M) ;Get pointer to message text
ILDB B,B ;Get first byte of message
CAIE B,"." ;Is it a period?
IFSKP.
CALL $BOUT ;Yes, double it in transmission
JRST OUTMSF
ENDIF.
MOVE B,MSGTXT(M) ;Get pointer to message body again
DO. ;Do 1000-bytes at a time with period checking
TMOCLR ;Disallow timer interrupts
MOVEM B,BUFPTR ;Save pointer to start of buffer
SETZB C,TT ;Character count zero, no doubled dot
DO. ;Search for "<CRLF>." sequence within buffer
CAILE D,2(C) ;Possible at all for "<CRLF>." sequence?
IFSKP. ;No, too near end of message
MOVE C,D ;Set to output rest of message
EXIT. ;And be done with this
ENDIF.
CAMLE C,SEGSIZ ;Buffer filled?
EXIT. ;Yes, output it
ILDB T,B ;Get byte from buffer
ADDI C,1 ;Count this character
CAIE T,.CHCRT ;Is it a CR?
LOOP. ;No, continue scan
ILDB T,B ;Saw CR, get possible LF
ADDI C,1 ;Count this character
CAIE T,.CHLFD ;Have we gotten a <CRLF>?
LOOP. ;No, continue scan
MOVE T,B ;Saw <CRLF>, get pointer to peek at next byte
ILDB T,T ;Peek at next byte
CAIE T,"." ;Have we gotten a line starting with period?
LOOP. ;No, continue scan
SETO TT, ;Yes, end buffer here, flag must double dot
IBP B ;Advance pointer beyond the dot
ADDI C,1 ;And count it
ENDDO. ;End scan through message for <CRLF>.
MOVE B,BUFPTR ;Get back pointer to start of buffer
SUBI D,(C) ;Account for this many characters output
MOVNS C ;Negative byte count for SOUT%
CALL OUTMST ;Check copy timer
JRST OUTMSF ;Timed out
CALL $SOUT ;Output the string
JRST OUTMSF
IFN. TT ;Do we have to double dot?
MOVEM B,BUFPTR ;Yes, save pointer to buffer
MOVEI B,"." ;Output the extra period
CALL $BOUT
JRST OUTMSF
MOVE B,BUFPTR ;Retrieve pointer
ENDIF.
JUMPG D,TOP. ;Continue output if more bytes to go
ENDDO.
SETO T, ;Back up pointer to last two bytes in buffer
ADJBP T,B
LDB D,T ;Get next to last byte
CAIE D,.CHCRT ;Was it a CR?
TDZA D,D ;No, can't be a CRLF sequence
ILDB D,T ;Yes, possible CRLF, get last byte
ENDIF.
CAIN D,.CHLFD ;Here D has either: the last byte output from
IFSKP. ; the message, or zero. D can be zero if the
HRROI B,CRLF0 ; message body is empty or if the next to the
SETZ C, ; last byte wasn't a CR. We can suppress
CALL $SOUT ; outputting the CRLF before the EOM only if
JRST OUTMSF ; D has a "last byte" of line feed
ENDIF.
HRROI B,[ASCIZ/.
/] ;Send End-Of-Message signal
SETZ C,
CALL $SOUTR
JRST OUTMSF
JRST OUTMDN
ENDSV.
;;; Routine to check timer for this msg copy
; Entry: MSGTMC(M) = time limit for transmitting this copy
; Call: CALL OUTMST
; Return: +1, timeout expired
; +2, ready to send next block of text
OUTMST: SKIPN MSGTMC(M) ;Copy timeout in effect?
IFSKP.
SAVEAC <A,B> ;Save ACs
TIME% ;Time limit up?
CAML A,MSGTMC(M)
CALL TIMOUT ;Timer expired
ENDIF.
RETSKP
SUBTTL Process local mail
SNDLCL: SKIPN MSGLCL(M) ;Any local mail?
RETSKP ;No
JSR SAVACS ;Yes, save all ACs
MOVEI X,MSGLCL(M) ;Pointer to local mail
SKIPE MSGDOP(M) ;If sending, do this another way
JRST SNDLCT
CITYPE < Processing local mail>
CALL GENHDL ;Build local headers
DO.
HRRZ O,(X) ;Get next recipient
JUMPE O,RSKP ;All done
MOVE B,RCPFLG(O) ;Get address flags
IFXE. B,FR%FAI!FR%TMP ;Forwarding errors on this address?
CALL SNDLCF ;No, try to send to file
IFSKP.
TYPE <OK> ;Success, log it
ELSE.
CALL CHKSFT ;Failed, was it a soft error?
IFSKP.
SKIPE NTDEQF ;Soft error, has message expired?
ANSKP.
MOVX B,FR%TMP ;No, just record soft failure
IORM B,RCPFLG(O)
CIETYP < %1E> ;JSYS error message
ELSE.
MOVE B,A ;Dequeueing, get a copy of the JSYS error text
HRROI A,STRBF1
HRLI B,.FHSLF
SETZ C,
ERSTR%
ERJMP .+1
ERJMP .+1
MOVEI A,STRBF1
MOVX B,FR%ERM!FR%TMP ;Assume sender notify and requeue
SKIPG NTDEQF
MOVX B,FR%ERM!FR%FAI ;No, dequeueing
CALL RCPLCX ;Save the error string
ENDIF.
ENDIF.
ENDIF.
MOVEI X,(O)
LOOP.
ENDDO.
;;;Skip if error code in A is soft
CHKSFT: CAIE A,OPNX6 ;Append access required means no WOPR or file
CAIN A,OPNX23 ;Quota exceeded (all cases -- see OVRQTA)
RETSKP
CAIE A,GJFX16 ;If POBOX: went away consider it temporary too
CAIN A,OPNX9 ;Let invalid simultaneous access through too
RETSKP ; OVRQTA and this is soft
;;;Maybe some others need adding here?
RET
; Here when address forwards to bad host, it is HSTBUF
RCPLXH: MOVE A,[POINT 7,STRBF1] ;a := buffer to construct msg
MOVEI B,[ASCIZ/Can't forward - unknown host "/]
CALL MOVSTR
MOVEI B,HSTBUF
CALL MOVSTR
MOVEI B,.CHDQT
IDPB B,A
SETZ B,
IDPB B,A
MOVEI A,STRBF1 ;Now give him the bad news
MOVX B,FR%ERM!FR%FAI ;Hard failure
;;; JRST RCPLCX
; Set error message for a recipient
; a = address of error string
; b = error bits for user block
RCPLCX: CALL RSTRCP ;Clear error msgs for this recipient
IORM B,RCPFLG(O)
CALL CPYSTR
MOVEM B,RCPERR(O)
UTYPE (B) ;Print the reason
RET
; Here to do SNDLCL processing for terminal messages
; returns +2/always
; messages to be sent as mail requeued with temporary error flag
; failed messages that can't be remailed flagged as permanent errors
SNDLCT: MOVE A,MSGDOP(M) ;Point to delivery-options
HLRO A,DOPTAB(A) ;Get delivery option string
CIETYP < Processing %1S terminal message>
;; Build message text to send
HRROI A,STRBF1 ;We build the message into STRBUF
SKIPN D,MSGSDR(M) ;d := adr of sender host entry block
FATAL <No sender block set up>
HRRZ C,HSTRCP(D) ;Get pointer to recipient entry block
MOVE B,RCPBPT(C) ;Point to sender user name
MOVN C,RCPCNT(C) ;And sender count
SOUT% ;Add it in
FMSG <@> ;Add atsign
HRRO B,HSTHST(D) ;Now get name for host
CALL OUTAHS ;Add host name
FMSG <, > ;Comma
SETO B, ;Current time
MOVX C,OT%NSC!OT%12H!OT%SCL ;C/Format flags: no seconds, 12 hour time
ODTIM% ;Write it
HRROI A,STRBUF ;Into normal place to make send
HRROI B,STRBF1 ;From header we just made
MOVEI C,STRBSZ*5-1 ;With number of chars allowed in buffer
SETZ D, ;To a null
SOUT% ;String-to-string copy
MOVEI B,.CHCRT ;Now another CR
DPB B,A ;Write over null with it
MOVEI B,.CHLFD ;And a linefeed
IDPB B,A ;To finish the header line
CAML C,MSGHCN(M) ;See how much space we have
IFSKP.
HRROI TT,[ASCIZ/Message text much too long/]
CIETYP < All sends failed: %7S>
DO.
HRRZ O,(X) ;Get next recipient
JUMPE O,ENDLP. ;If zero, done flagging them
CALL SERMRK ;Set error flags and message
MOVEI X,(O) ;Move on to next recipient
LOOP.
ENDDO.
ELSE.
MOVE B,MSGHDR(M) ;Point to message header start
MOVN C,MSGHCN(M) ;And get count of letters
SOUT% ;Copy message text across to finish message
;; Message built. Now make a list of recipients.
SETZB T,TT ;No first block, no latest block
DO.
HRRZ O,(X) ;Get next recipient
JUMPE O,ENDLP.
MOVE A,[POINT 7,STRBF1] ;Get pointer to random string buffer
DMOVE B,RCPBPT(O) ;Point to recipient name, byte count
DO.
ILDB D,B ;Get a byte
IDPB D,A ;And drop it in
SOJG C,TOP. ;Until there are no more bytes left
ENDDO.
IDPB C,A ;Drop in a null to terminate
;; Have name for recipient. Try looking up as a local user
MOVX A,RC%EMO ;Forcing exact match
HRROI B,STRBF1 ;With string we made
RCUSR% ;Read user name
IFNJE. ;If we succeeded
ANDXE. A,RC%NOM ;And got a match
PUSH P,C ;Save user number
CALL GSRCPT ;Get recipient block in TT
MOVSI A,RC.USR ;This is a user number
MOVEM A,(TT) ;Save as block header
POP P,1(TT) ;Save user number as data
ELSE.
HRROI A,STRBF1 ;That failed, point to buffer again
MOVEI C,^D8 ;Terminal numbers are octal
NIN% ;Try to read one in
IFNJE.
LDB C,A ;Read terminator byte
ANDE. C ;Must be null
PUSH P,B ;Is, save terminal number
CALL GSRCPT ;Get recipient block for it
MOVSI A,RC.TTY ;This is a terminal number
MOVEM A,(TT) ;Save as block header
POP P,1(TT) ;Save terminal number as data
ELSE.
MOVX A,FR%TMP ;Couldn't translate, want to send as mail
IORM A,RCPFLG(O) ;So requeue with a "temporary error"
ENDIF.
ENDIF.
MOVEI X,(O) ;Move on to next recipient
LOOP.
ENDDO.
ANDN. T ;If nobody left, give up in disgust
;; Here to attempt to send to rcpt list pointed to by T
DO.
HRROI A,STRBUF ;From string buffer where we built message
MOVE B,T ;Starting at the first send
MOVEI C,SDBLOK ;With send state block
CALL $SEND ;Send it off
NOP ;We can tell if it succeeded by looking at B
;; Message has been sent. Loop through rcpts until we find one
;; that failed, logging and freeing blocks as we go.
EXCH B,T ;Get starting recipient block in a useful place
MOVE TT,A ;Save error pointer if we have any
DO.
HRROI A,STRBF1 ;Into alternate buffer
CALL $WTRCP ;Write recipient name for strings
CAMN B,T ;Are we where we left off yet?
IFSKP.
HRROI A,STRBF1 ;No, rcpt succeeded, get recipient name string
CIETYP < %1S: Sent> ;Say we delivered it
MOVE A,MSGDOP(M) ;Get delivery options
CAIE A,D%SAML ;Send and mail?
IFSKP.
MOVX A,FR%TMP ;Yes, we need to send it as mail too
MOVE O,2(B) ;Point back to recipient block
IORM A,RCPFLG(O) ;Requeue with a "temporary error"
ENDIF.
LOAD O,RC%NXT,(B) ;Point to next recipient
CALL FREBLK ;Free this one
MOVE B,O ;Get next block pointer back
JUMPN B,TOP. ;Got someone, go on
SETZ T, ;Break out of outer loop
ELSE.
HRROI A,STRBF1 ;Point to recipient name
CIETYP < %1S: %7S>
MOVE O,2(T) ;Point back to recipient block
CALL SERMRK ;Set error flags for that recipient
MOVE B,T ;Get pointer to this block
LOAD T,RC%NXT,(T) ;And move on to the next
CALL FREBLK ;Free this one
ENDIF.
ENDDO.
JUMPN T,TOP. ;If we have more to do, go do it
ENDDO.
ENDIF.
RETSKP
; Here with a bad recipient, error string in TT.
SERMRK: MOVE A,MSGDOP(M) ;Get message delivery options
CAIE A,D%SOML ;If SOML, just set temporary failure
CAIN A,D%SAML ;Ditto for SAML
IFSKP.
HRROI A,STRBF1 ;Into random string buffer
MOVE B,TT ;From error string
SETZ C, ;No limit (short string, don't worry about it)
SOUT% ;String-to-string copy
HRROI A,STRBF1 ;Now point to start of string again
CALL CPYSTR ;Copy into safer string space
MOVEM B,RCPERR(O) ;Save error message with recipient
MOVX A,FR%ERM!FR%FAI ;Hard failure
ELSE.
MOVX A,FR%TMP ;Get flag for temporary error
ENDIF.
IORM A,RCPFLG(O) ;Set error flags in recipient block
RET
; Here to make a recipient block
GSRCPT: MOVEI A,3 ;Need: recipient type and data, copy of O
CALL ALCBLK ;Allocate block
FATAL <Memory exhausted>
MOVEM O,2(B) ;Save recipient pointer for flagging
SKIPN T ;If we don't have a first block yet
MOVEM B,T ;This is it
SKIPE TT ;If we had a previous block
STOR B,RC%NXT,(TT) ;Link through for $SEND
MOVEM B,TT ;In any case save this as the previous block
RET
; Mail failed. Check to see if the addressee is the mail agent.
; If so set the FR%MLA bit in RCPFLG(O).
; Entry: n = adr of host block
; o = adr of recipient block
; mlagnt = mail agent name string
; Call: CALL MMLGTL (check addressee assuming local host)
; CALL MMLGT (check addressee on network host)
; Return: +1, always
MMLGT: MOVE A,HSTHST(N) ;a := host site
CAIE A,LCLNAM ;Local?
RET ;No, can't be mail agent
MMLGTL: MOVE A,[POINT 7,MLAGNT] ;a := ptr to mail agent name
DMOVE B,RCPBPT(O) ;b,c := ptr/ctr to recipient name
CALL STRCAL ;Compare the strings
RET ;Not same
MOVX A,FR%MLA ;Same, flag mail agent failure
IORM A,RCPFLG(O)
RET
; Mail failed. Check to see if the addressee is the sender.
; If so set the FR%SDR bit in RCPFLG(O).
; Entry: n = adr of host block
; o = adr of recipient block
; msgsdr = message sender
; Call: CALL MSNDRL (check addressee on local host)
; CALL MSNDR (check addressee on network host)
; Return: +1, always
MSNDR: SKIPA C,HSTHST(N) ;c := addressee host
MSNDRL: MOVEI C,LCLNAM ;c := addressee host = local host
MOVE A,MSGSDR(M) ;a := adr of sender host block
MOVE B,HSTHST(A) ;b := sender host
CAME B,C ;Same host?
RET ;No, addressee neq sender
HRRZ B,HSTRCP(A) ;a/b := ptr/len of sender name
DMOVE A,RCPBPT(B)
DMOVE C,RCPBPT(O) ;c/d := ptr/len of recipient name
CALL STRCLL ;Compare the strings
RET ;Not same
MOVX A,FR%SDR ;Same, flag sender failure
IORM A,RCPFLG(O)
RET
; Routine to check forwarding address.
; Entry: strbuf = new addressee name
; hstbuf = new host
; Call: CALL CKFWDL
; Return: +1, host not recognized
; +2, new addressee = old one
; +3, forwarding OK, b = host site address
CKFWDL: MOVE B,[POINT 7,HSTBUF] ;b := ptr to host name
CALL HSTNAM ;Look it up
RET ;No go, return +1
CAIE B,LCLNAM ;Still to local host?
JRST R2SKP ;No, return +3
AOS 0(P) ;Return at least +2 from here
SAVEAC <B>
MOVE A,[POINT 7,STRBUF] ;a := ptr to new user name
DMOVE B,RCPBPT(O) ;b/c := ptr/len of old name
CALL STRCAL ;Compare them (upper case)
RETSKP ;No match, return +3
RET
;;; Add a forwarding address
;;; O/ ptr to recipient block
;;; B/ host index
ADDRCP: MOVEI N,MSGRCP(M)
ADDRC7: HRRZ T,HSTFLG(N) ;n := adr of next host block
JUMPE T,ADDR11 ;This host not on list
MOVE TT,HSTHST(T)
CAME TT,B ;Same host
JRST [ MOVEI N,(T)
JRST ADDRC7]
MOVEI N,(T)
ADDRC8: MOVEI T,HSTRCP(N)
ADDRC9: HRRZ TT,RCPFLG(T) ;Reached end?
JUMPE TT,ADDR10
MOVEI T,(TT)
JRST ADDRC9
ADDR10: HRRM O,(T) ;Link onto end
HRRZ T,(O) ;Get old end
HRRM T,(X) ;Link to previous
HLLZS (O) ;This is the new end of its list
MOVEI O,(T)
RET
ADDR11: PUSH P,B ;Save host
MOVEI A,HSTLEN ;Make a new host block
CALL ALCBLK
FATAL <Memory exhausted>
HRRM B,(N)
MOVEI N,(B)
POP P,HSTHST(N)
SETZM HSTFLG(N)
SETZM HSTRCP(N)
JRST ADDRC8
; Try to send local mail to addressee
; Returns: +1: Failure, JSYS error in A
; +2: Success, message delivered
SNDLCF: STKVAR <LCFJFN,<FILSIZ,2>,SDRPTR,FILPTR>
SKIPE WOPRP ;Must be WOPR to run here (checked earlier)
IFSKP.
MOVEI A,OPNX6 ;Pick a convincing error code
RET ;And return
ENDIF.
TXZ F,FM%FLO ;Assume addressee is not a file
MOVE A,RCPBPT(O) ;a := ptr to recipient name
ILDB B,A ;b := 1st char
CAIE B,"*" ;File address designator?
IFSKP.
TXO F,FM%FLO ;Yes
CALL SNLFAD ;Prepare file name string
IFNSK.
MOVEI A,GJFX33 ;Failed, pick a convincing error code
RET ;And return
ENDIF.
ELSE.
MOVE A,[POINT 7,STRBUF] ;Start filename string
MOVEI B,[ASCIZ/POBOX:</]
CALL MOVSTR
MOVEM A,FILPTR ;Save pointer for typing out
DMOVE B,RCPBPT(O)
ILDB D,B ;Get first byte of user string
CAIE D,"&" ;Was it the special local user hack?
SKIPA B,RCPBPT(O) ;No, use existing pointer/counter
SUBI C,1 ;Otherwise skip over and decrement count
DO.
ILDB D,B
IDPB D,A
SOJG C,TOP.
ENDDO.
MOVE B,A
IDPB C,B ;Terminate it for now
EXCH A,FILPTR
CIETYPE < %1W: >
MOVE B,[POINT 7,[ASCIZ/SYSTEM/]] ;Check if SYSTEM mail
CALL STRCMP
SKIPA
TXO F,FM%FLO ;SYSTEM mail, treat as output to file
MOVE A,FILPTR
MOVEI B,[ASCIZ/>MAIL.TXT.1/]
CALL MOVST0
ENDIF.
;;; The need for two GTJFN% calls is to work around a long-standing monitor
;;;bug in DIRECT -- GT%FOU!GJ%OLD will cause an empty mail file to go away.
;;;This bug is fixed at Stanford, but not in DEC TOPS-20 as of 5.1.
MOVX A,GJ%OLD!GJ%DEL!GJ%SHT ;Verify there is a mail file there
HRROI B,STRBUF
GTJFN%
ERJMP R ;Return JSYS error
IFXN. F,FM%FLO ;OK, output to file?
MOVEM A,LCFJFN ;Special-case NUL: device
;;;Actually, need some general tests for non-disk devices. For now, only disk
;;;and NUL: can possibly work.
DVCHR% ;Get characteristics
IFNJE.
LOAD B,DV%TYP,B ;Get device type
CAIE B,.DVNUL ;NUL:?
ANSKP.
MOVE A,LCFJFN ;Yes, all done here
RLJFN%
JWARN
RETSKP
ENDIF.
MOVE A,LCFJFN
CALL SNLFCK ;Yes, check for append access
ANNSK.
RLJFN% ;No go, release the JFN
JWARN
MOVEI A,OPNX6 ;Convincing error code
RET ;And fail return
ENDIF.
MOVE B,[1,,.FBDRN]
MOVEI C,C
GTFDB%
ERJMP .+1
RLJFN% ;Now get rid of this JFN
JWARN
MOVX A,GJ%FOU!GJ%DEL!GJ%SHT ;Get the JFN again (note: no GJ%OLD!!)
HLR A,C ;Default version number from old
HRROI B,STRBUF
GTJFN% ;Try to get guys mail file
ERJMP R ;This shouldn't have happened, oh well
MOVEM A,LCFJFN ;Save JFN
MOVX B,<<FLD ^D7,OF%BSZ>!OF%RD!OF%WR> ;Open for read/write
OPENF%
IFJER.
EXCH A,LCFJFN ;JSYS error, save error code
RLJFN% ;Flush the JFN
JWARN
MOVE A,LCFJFN ;Now return error to caller
RET
ENDIF.
SKIPN DAEMNP ;Allow enabled wheel to circumvent quota check
IFSKP.
MOVX A,.FHSLF ;Get our capabilities
RPCAP%
TXZ C,SC%WHL!SC%OPR ;Disable them
EPCAP%
ENDIF.
MOVE A,LCFJFN ;Get JFN
MOVE B,[2,,.FBBYV] ;Get two words of file size
MOVEI C,FILSIZ ;Into FILSIZ
GTFDB%
LDB C,[POINT 6,FILSIZ,11] ;Get file byte size
CAIN C,7 ;Already the right byte size?
IFSKP.
MOVEI B,^D36 ;Ugh, compute total bytes per word
IDIVI B,(C)
EXCH B,1+FILSIZ
IDIV B,1+FILSIZ ;Compute number of words
IMULI B,5 ;Compute # of characters
ELSE.
MOVE B,1+FILSIZ ;Use exact byte count if 7 bit bytes
ENDIF.
MOVEM B,FILSIZ ;Save prior file size
SFPTR% ;Set this as the place to write to
JFATAL
SETO B, ;Now
MOVX C,OT%TMZ
ODTIM%
IFNJE.
MOVEI B,","
BOUT%
..TAGF (ERJMP,) ;I sure wish ANNJE. existed!
SETZM STRBUF ;Assume nothing needed
DMOVE A,[POINT 7,ORGAUT ;See if it was written by system server
POINT 7,DAEDIR]
CALL STRCMP ;Strings match?
IFNSK.
HRROI A,STRBUF
HRROI B,[ASCIZ/Mail-From: /]
SETZ C,
SOUT%
HRROI B,ORGAUT
SOUT% ;Give him the author
HRROI B,[ASCIZ/ created at /]
SOUT%
HRRZ B,MSGJFN(M) ;Date of queue file
MOVEI C,JS%LWR ;Last write
JFNS%
HRROI B,CRLF0
SETZ C,
SOUT% ;And crlf
ELSE.
HRROI A,STRBUF
ENDIF.
SKIPN MSGRPT(M) ;Return path specified?
IFSKP.
HRROI B,[ASCIZ/Return-Path: </] ;Yes, output it
SETZ C,
SOUT%
HRRO B,MSGRPT(M) ;Now output the path
SOUT%
MOVEI B,">"
BOUT%
HRROI B,CRLF0 ;Terminating CRLF
SOUT%
ENDIF.
SKIPN STRBUF
IFSKP.
LDB B,[POINT 6,A,5] ;High order 2 octal digits
ADDI B,3 ;High order digit is now 4,3,2,1,or 0
LSH B,-3 ;Get 4 - 0
TXZ A,.LHALF ;Clear left half of ptr
SUBI A,STRBUF-1 ;Number of words
IMULI A,5 ;Number of chars
SUB A,B ;Adjust by number not used in last word
ELSE.
SETZ A, ;Nothing to be done
ENDIF.
;;;Note that B is off by 2, since it includes a CRLF in front of the message.
;;; In most cases, we compensate by subtracting 2. If the message is null,
;;; however, we will generate a free CRLF so we don't compensate
HLRZ B,MSGNHD(M) ;Length of headers
ADD B,A ;Add the MAIL-FROM/RETURN-PATH headers
SKIPE C,MSGTCN(M) ;Is there a message body?
SUBI B,2 ;Yes, adjust count
MOVE A,LCFJFN ;Get back JFN
ADD B,MSGTCN(M) ;Plus text
MOVEI C,^D10 ;Decimal
NOUT%
..TAGF (ERJMP,) ;I sure wish ANNJE. existed!
HRROI B,[ASCIZ/;000000000000
/]
SETZ C,
SOUT%
..TAGF (ERJMP,) ;I sure wish ANNJE. existed!
HRROI B,STRBUF ;Output the Mail-From: line
SOUT%
..TAGF (ERJMP,) ;I sure wish ANNJE. existed!
CALL OUTMSG ;Now output message for real
ANSKP.
MOVX A,.FHSLF ;Get our capabilities
RPCAP%
IOR C,B ;Re-enable them
EPCAP%
ELSE.
;;; Here when destination directory appears to be over quota. Back out of
;;;sending the message.
MOVX A,.FHSLF ;Get our capabilities
RPCAP%
IOR C,B ;Re-enable them
EPCAP%
MOVE A,LCFJFN
RFBSZ% ;Get current byte size
ERJMP .+1
MOVEI C,^D36
IDIVI C,(B) ;Compute bytes per word
MOVE D,C ;Save this for later
RFPTR% ;Get current EOF pointer
ERJMP .+1
IDIVI B,(D) ;Compute words
LSH B,-11 ;Make it a page number
MOVE C,FILSIZ ;Get original EOF pointer
IDIVI C,(D) ;Compute word #
LSH C,-11 ;Get page number
SUB B,C ;Compute # of pages added
IFN. B
EXCH B,C ;Get args in proper regs
TXO C,PM%CNT
SETO A, ;Delete pages
HRL B,LCFJFN ;JFN
ADDI B,1 ;Starting page
PMAP% ;Zap the extra file pages
MOVE A,LCFJFN ;JFN again
ENDIF.
HRLI A,.FBBYV ;Make sure byte size is correct
MOVX B,FB%BSZ ;Set byte size
MOVX C,<FLD 7,FB%BSZ> ;Set it to 7-bit bytes
CHFDB% ;Do it
IFNJE.
HRLI A,.FBSIZ ;Now set the size
SETO B, ;Set entire word
MOVE C,FILSIZ ;And back to original count
CHFDB% ;Do it
ERJMP .+1
ENDIF.
MOVE A,LCFJFN ;Get JFN again
HRROI B,[ASCIZ/somebody pending because of disk quota/] ;39 chrs max!
CALL .SFUST ;Set as writer
MOVE A,LCFJFN ;Get JFN one last time
CLOSF% ;Close the file
JWARN
MOVX A,OPNX23 ;Disk quota exceeded
RET ;JSYS error return
ENDIF.
;;;Make sure the message just delivered has made it to the disk, otherwise
;;;if the system crashes before DDMP runs it will be lost.
MOVE A,LCFJFN ;Get back JFN
RFPTR% ;Get pointer to last byte we wrote
JFATAL <Can't get local mail file size>
MOVEM B,FILSIZ
IDIVI B,5*^D512 ;Convert to number of pages
SKIPE C ;Was there a remainder?
ADDI B,1 ;Yes, a partially written page exists
HRL A,LCFJFN ;JFN in LH
HRRI A,1 ;Start with page 1
UFPGS% ;Drop the pages and wait until it happens
JWARN <Can't update local mail file>
MOVE A,LCFJFN
HRLI A,.FBBYV ;Make sure byte size is correct
MOVX B,FB%BSZ ;Set byte size
MOVX C,<FLD 7,FB%BSZ> ;Set it to 7-bit bytes
CHFDB% ;Do it
IFNJE.
HRLI A,.FBSIZ ;Now set the size
SETO B, ;Set entire word
MOVE C,FILSIZ ;Make damn sure FDB is updated
CHFDB% ;Do it
ERJMP .+1
ENDIF.
MOVE A,LCFJFN ;Get back JFN
TXO A,CO%NRJ ;Close file w/o releasing JFN
CLOSF%
JFATAL <Can't close local mail file>
MOVE D,MSGSDR(M) ;d := sender host block adr
HRRZ C,HSTRCP(D) ;c := sender recipient block adr
HRRZ B,RCPBPT(C) ;b := ptr to sender name
CAIN B,MLAGNT ;Our mail agent?
SKIPN B,MSGFHS(M) ;Yes, any "Net-mail-from-host" spec?
IFNSK.
HRROI A,STRBUF ;a := ptr to temp buffer for author name
MOVE B,RCPBPT(C) ;b/c := ptr/-cnt to name field
MOVN C,RCPCNT(C)
SOUT%
MOVE D,HSTHST(D) ;d := sender host site tbl entry
CAIN D,LCLNAM ;Local host?
IFSKP.
MOVEI B,"@" ;Add on host name
BOUT%
HRRO B,D ;Pointer to host name
SETZ C,
SOUT%
ENDIF.
HRROI B,STRBUF ;b := author string ptr
ENDIF.
MOVEM B,SDRPTR ;And string pointer
MOVE C,RCPCNT(O) ;Length of receiver's name
ADJBP C,RCPBPT(O) ;Pointer to receiver's name
SETZ D, ;Tie off name string
IDPB D,C
MOVE B,RCPBPT(O) ;Pointer to receiver's name
ILDB A,B ;Get first byte
CAIE A,"&" ;Was it special force local user hack?
MOVE B,RCPBPT(O) ;No, use it as is
MOVX A,RC%EMO ;Match string exactly
RCUSR% ;Get user number
IFNJE.
ANDN. C
MOVEM C,USRNUM ;Save user number
HRROI A,FRMMSG ;Create output msg in FRMMSG
HRROI B,[ASCIZ/
[You have a message from /]
SETZ C,
SOUT%
HRRO B,SDRPTR ;Get back sender name string pointer
CALL OUTAHS ;Output absolute host
HRROI B,[ASCIZ/ on /] ;Tell him where he has new mail
SOUT% ; since he may have TELNETed somewhere else
HRROI B,LCLNAM
CALL OUTAHS
HRROI B,[ASCIZ/]
/]
SOUT%
IDPB C,A ;Tie off with null
SETZ D, ;Init job number for scan
DO.
MOVEI A,(D) ;Job number
MOVE B,[-<.JIBAT-.JITNO+1>,,GTINF] ;Get values from monitor
MOVX C,.JITNO ;Get term # and logged in dir
GETJI% ;Get them
IFNJE.
SKIPE GTINF+<.JIBAT-.JITNO> ;Is this a batch job?
ANSKP.
DMOVE A,GTINF ;No, get GETJI% data in regs
ANDGE. A ;Detached?
CAME B,USRNUM ;Logged into the user number we want?
ANSKP.
IORX A,.TTDES ;Make it a device designator
MOVX B,.MORNT ;Does user want system messages?
MTOPR%
..TAGF (ERJMP,) ;I sure wish ANNJE. existed!
ANDE. C ;Ignore if refusing system messages
HRROI B,FRMMSG ;Get message block
TTMSG% ;Send to this user
ERJMP ENDLP. ;Ignore failure
ELSE.
CAIN A,GTJIX3 ;"Invalid job number"?
EXIT. ;Yes, all done
ENDIF.
AOJA D,TOP. ;Do all jobs
ENDDO.
ENDIF.
MOVE A,LCFJFN ;Get back JFN
MOVE B,SDRPTR ;Restore string pointer
SKIPE DAEMNP ;Daemon running?
CALL .SFUST ;Yes, set the author
ANDX A,.RHALF ;Isolate file JFN
RLJFN% ;Release it
JWARN
RETSKP ;Return success
ENDSV.
; Here to set up for sending mail to a file specification, defaulting the
; device and directory from the msg file JFN.
; Entry: o = adr of recipient buffer
; Call: CALL SNLFAD
; Return: +1, failure (bad string)
; +2, OK, name string set up in STRBUF
SNLFAD: STKVAR <FILPTR,<RCPPTR,2>>
MOVE A,[POINT 7,STRBUF] ;a := buffer for name string
DMOVE B,RCPBPT(O) ;b,c := ptr/ctr to file name string
IBP B ;Step over "*"
SOJLE C,R ;And decrement count (if null str, quit)
MOVEM A,FILPTR ;Save buffer pointer
DMOVEM B,RCPPTR ;Save recipient pointer and counter
DO.
ILDB D,B ;Look for device delimiter
IDPB D,A ;Stick character in buffer in case
CAIE D,.CHCNV ;CTRL-V?
IFSKP.
SOJLE C,R ;Yes, next character doesn't count
ILDB D,B
IDPB D,A
ELSE.
CAIN D,":" ;Found one?
SOJA C,ENDLP. ;Yes, no need to default device
ENDIF.
SOJG C,TOP. ;Look for device delimiter until exhausted
MOVE A,FILPTR ;Device not specified, must default it
HRRZ B,MSGJFN(M) ;b := JFN for this queued file
MOVE C,[100000,,1] ;Print the device part (assumed)
JFNS%
DMOVE B,RCPPTR ;Retrieve pointer/count to start over
ENDDO.
MOVEM A,FILPTR ;Update buffer pointer
DMOVEM B,RCPPTR ;Update saved pointer/count
JUMPE C,R ;In case no more text
DO.
ILDB D,B ;Search for directory delimiter
IDPB D,A ;Stick character in buffer in case
CAIE D,.CHCNV ;CTRL-V?
IFSKP.
SOJLE C,R ;Yes, next character doesn't count
ILDB D,B
IDPB D,A
ELSE.
CAIE D,"[" ;This is a directory delimiter too
CAIN D,"<" ;Found it?
SOJA C,ENDLP. ;Yes, no need to default directory
ENDIF.
SOJG C,TOP. ;Look for directory delimiter until exhausted
MOVE A,FILPTR ;Directory not specified, must default it
HRRZ B,MSGJFN(M) ;b := JFN for this queued file
MOVE C,[010000,,1] ;Print the directory part (assumed)
JFNS%
DMOVE B,RCPPTR ;Retrieve pointer/count to start over
ENDDO.
JUMPE C,R ;In case no more text
DO.
ILDB D,B ;d := next char
IDPB D,A
SOJG C,TOP. ;Do the whole string
ENDDO.
IDPB C,A ;Terminate the string
MOVE A,[POINT 7,STRBUF] ;a := ptr to start of buffer
CIETYP < %1W: > ;Print it if needed
RETSKP ;Return +2
ENDSV.
; Routine to check for append access to a file
; Entry: a = JFN to file
; strbuf = file name string (must not clobber it)
; Call: CALL SNLFCK
; Return: +1, access not allowed
; +2, append access OK
SNLFCK: SKIPL DAEMNP ;Running as daemon?
RETSKP ;No, system will take care of access chk
PUSH P,A ;Save the JFN
DMOVE A,[POINT 7,ORGAUT ;See if it was written by system server
POINT 7,DAEDIR]
CALL STRCMP ;Strings match?
JRST SNLFC1 ;No, do CHKAC% to validate access
SNLFC0: POP P,A ;Random source, check for world append access
MOVE B,[1,,.FBPRT] ;Want protection code for file
MOVEI C,C ;Into C
GTFDB%
ERJMP R ;Can't get protection, deny
TXNE C,FP%APP ;Append access for the world?
RETSKP ;Yes, allow access
RET ;No, deny access
CKABLK==<STRBF1+20> ;CHKAC% argument
SNLFC1: HRROI A,STRBF1 ;a := ptr for file directory string
HRRZ B,MSGJFN(M) ;b := queue file JFN
MOVE C,[010000,,1] ;Set STRBF1 to "connected directory", or some
JFNS% ;suitable approximation
MOVEI A,CKABLK-1 ;Area to store CHKAC% argument block
PUSH A,[.CKAAP] ;Tbl wd 0: append access
PUSH A,[POINT 7,ORGAUT] ;Tbl wd 1: user name string
PUSH A,[POINT 7,STRBF1] ;Tbl wd 2: conn dir string
PUSH A,[0] ;Tbl wd 3: enabled privileges
PUSH A,(P) ;Tbl wd 4: JFN for file to be accessed
MOVE A,[CK%JFN+5] ;a := JFN flag,,tbl length
MOVEI B,CKABLK ;b := adr of table on stack
CHKAC% ;Check for access rights
ERJMP SNLFC0 ;JSYS failed, check for world access
MOVE B,A ;Get CHKAC% result in B
POP P,A ;a := file JFN
JUMPN B,RSKP ;Skip return if access allowed
RET ;Else fail return
; Routine to run MMailbox program to lookup forwarding address or mailing list
; Entry: a = ptr to user name
; Call: CALL MLFWRD
; Return: +1, No forwarding
; +2, forwarding found
MLFWRD: SAVEAC <A,B> ;Save calling args
STKVAR <MBXJFN,MBXPTR>
MOVEM A,MBXPTR ;Save mailbox pointer
SKIPE MBXFK ;Fork already existing?
IFSKP.
MOVX A,GJ%OLD!GJ%SHT ;No, get JFN of forwarder
HRROI B,[ASCIZ/SYS:MMAILBOX.EXE/]
GTJFN%
ERJMP R ;Not there.
MOVEM A,MBXJFN ;Save JFN
MOVX A,CR%CAP ;Create an inferior fork
CFORK%
IFJER.
MOVEI A,^D5000 ;Failed get fork, wait 5 sec
DISMS%
MOVX A,CR%CAP
CFORK%
IFJER.
MOVE A,MBXJFN ;Failed again, quit
RLJFN% ;Punt the JFN
JWARN ;Don't care
RET ;Return to caller
ENDIF.
ENDIF.
MOVEM A,MBXFK ;Save fork handle
RPCAP% ;TOPS-20 will not let you do anything
TXO B,SC%SUP ; to a superior (ie IIC it) unless you
TXO C,SC%SUP ; have the cap to map it.
EPCAP% ;So enable that capability
MOVE A,MBXJFN ;Get back JFN
HRL A,MBXFK ;a := fork handle,,JFN
GET% ;Get pgm into fork
ERJMP CLRMLF
ENDIF.
HRLZ A,MBXFK ;a := inferior fork,,page 0
DMOVE B,[.FHSLF,,<TMPBUF/1000> ;b := our fork,,shared page
PM%RD!PM%WR!PM%CNT+2]
PMAP%
ERJMP CLRMLF
MOVE A,[POINT 7,TMPBUF+200] ;a := ptr to shared page (200)
MOVE B,MBXPTR ;b := ptr to address user name
CALL MOVST0 ;Copy string and terminating null
MOVX A,.FHSLF ;Get our primary JFN's
GPJFN%
ERJMP CLRMLF
MOVE A,MBXFK ;Set MMailbox's to match
SPJFN%
ERJMP CLRMLF
MOVE A,MBXFK ;a := fork handle again
MOVX B,3 ;MMailr entry
SFRKV%
ERJMP CLRMLF
WFORK% ;Wait for it to halt
ERJMP CLRMLF
RFSTS% ;Read status
ERJMP CLRMLF
HLRZS A ;a := termination code
CAIN A,.RFHLT ;Normal HALTF%?
IFSKP.
CALL CLRMLF ;No, better clean it up
MOVEI A,[ASCIZ/Forwarding program error/]
MOVX B,FR%ERM!FR%TMP ;Temporary failure
CALLRET RCPLCX ;Set recipient error message
ENDIF.
SKIPL A,TMPBUF+177 ;Check success flag
IFSKP.
MOVE A,[POINT 7,STRBUF]
MOVEI B,[ASCIZ/Forwarding error: /]
CALL MOVSTR
HRRZ B,TMPBUF+177 ;Get from inferior
CALL FWDCPY ;Copy here
SETZ B, ;Tie off string
DPB B,A ;Not IDPB! FWDCPY uses MOVST0
MOVE A,[POINT 7,STRBUF] ;Point to error string
SKIPE TMPBUF+176 ;Auxillary value returned?
SKIPA B,[FR%ERM!FR%FAI] ;Yes, failure is hard then
MOVX B,FR%ERM!FR%TMP ;Otherwise temporary failure
CALLRET RCPLCX ;Set recipient error message
ENDIF.
IFE. A
MOVEI A,[ASCIZ/No such mailbox/]
MOVX B,FR%ERM!FR%FAI ;Failure is hard here
CALLRET RCPLCX ;Set recipient error message
ENDIF.
CAIL A,3 ;Valid local entry?
IFSKP.
HRRZ B,(O) ;Temporarily link it out of the list
HRRM B,(X)
CALL UNQRCP ;Is it unique?
IFSKP.
HRRM O,(X) ;Yes, put it back
ELSE.
CALL FREDUP
MOVEI O,(X)
ENDIF.
RET
ENDIF.
RETSKP
ENDSV.
; Routine to clear up the MMAILBOX.EXE fork
; Entry: MBXFK = frk handle
; frk pg 0 possibly mapped to TMPBUF in our space
CLRMLF: SKIPN MBXFK ;a := fork handle
RET ;If none, nothing to do
SETO A, ;Unmap shared page
DMOVE B,[.FHSLF,,<TMPBUF/1000>
PM%CNT+2]
PMAP%
ERJMP .+1
HRRI B,<FWDWIN/1000>
MOVE C,[PM%CNT+2]
PMAP%
ERJMP .+1
MOVE A,MBXFK ;a := fork handle
KFORK% ;Get rid of fork
ERJMP .+1
SETZM MBXFK ;Show fork gone
RET ;Return
;;; Forward local mail
;;; CALL FWDLCL
;;; Returns +1 always
FWDLCL: SKIPN MSGDOP(M) ;Delivering as mail?
SKIPN MSGLCL(M) ;Any local mail?
RET ;Terminal message or nothing local, stop now
JSR SAVACS ;Got something to do, save all ACs
CITYPE < Checking local mail for mailing lists>
MOVEI X,MSGLCL(M) ;Pointer to local mail
DO.
HRRZ O,(X) ;Current message pointer in O, previous in X
JUMPE O,R ;If done, just return
CALL FWDLCF ;Try to forward it
MOVEI X,(O) ;Set current as previous
LOOP. ;Try next message
ENDDO.
;;; Try to forward a single local recipient
;;; O/ Current recipient
;;; X/ Previous recipient (in case of relinking)
FWDLCF: MOVE A,[POINT 7,STRBUF] ;a := ptr for copy of the addressee name
DMOVE B,RCPBPT(O) ;b,c := ptr/ctr to name
DO.
ILDB D,B ;d := next char
IDPB D,A
SOJG C,TOP. ;Copy all chars in name
ENDDO.
IDPB C,A ;Terminate with null
MOVE A,[POINT 7,STRBUF] ;a := ptr to user name
CIETYPE < %1W: >
CALL MLFWRD ;Look up forwarding address
RET ;No forwarding, all done
;; A valid forwarding has been found, get it out of the inferior
MOVX T,FR%STR
HRRZ B,RCPBPT(O)
TDNE T,RCPFLG(O) ;Generated recipient string?
CALL FREBLK ;Yes, deallocate
HRRZ B,O ;Get pointer to old block
HRRZ O,(O) ;Get forward pointer for relinking
CALL FREBLK ;Deallocate recipient block
HRRM O,(X) ;Link out current block
MOVEI Y,TMPBUF+300 ;Where the expansion was put
DO.
SKIPE T,(Y) ;End of addresses?
IFSKP.
MOVEI O,(X) ;Get current pointer again (O had forward ptr)
RET ;Go back and do next local address
ENDIF.
PUSH P,O ;Save next address
CALL FWDRCP ;Make recipient block
CAIN B,LCLNAM ;Local host?
IFSKP.
CALL ADDRCP ;No, add another recipient
ELSE.
CALL UNQRCP ;Yes, unique local recipient?
IFNSK.
CALL FREDUP ;No
POP P,O ;Leave O and X the same
AOJA Y,TOP.
ENDIF.
HRRM O,(X) ;Yes, link to previous address
HRRZ X,O ;Make it be previous address
ENDIF.
POP P,O ;Get back next address
HRRM O,(X) ;Set as next on list
AOJA Y,TOP. ;And try for rest of recipient
ENDDO.
;Free duplicate recipient
FREDUP: CIETYP <FREDUP: Duplicate recipient deleted: >
MOVX A,.PRIOU
MOVE B,RCPBPT(O)
MOVN C,RCPCNT(O)
SKIPN PRINTP
IFSKP.
SOUT%
CALL CRLF
ENDIF.
MOVX T,FR%STR
HRRZ B,RCPBPT(O)
TDNE T,RCPFLG(O) ;Generated recipient string?
CALL FREBLK ;Yes, deallocate
HRRZ B,O
CALLRET FREBLK
;;; Skip if this recipient (O) is unique among local recipients
UNQRCP: PUSH P,X ;Preserve caller's X
CALL UNQRCX ;Call worker routine
SKIPA ;Non-skip return from worker
AOS -1(P) ;Skip return from worker
POP P,X ;Restore caller's X
RET
UNQRCX: MOVEI X,MSGLCL(M) ;Head of local recipient list
DO.
HRRZ X,(X) ;Next local rcpt
JUMPE X,RSKP ;It's unique
DMOVE A,RCPBPT(O) ;Compare them
DMOVE C,RCPBPT(X)
CALL STRCLL
LOOP. ;Different, try next
ENDDO.
RET ;Identical, string not unique
;;; Copy a string from the forwarding inferior
;;; A/ output string
;;; B/ address in inferior
FWDCPY: STKVAR <FWDSTR,FWDADR>
MOVEM A,FWDSTR ;Save parameters
MOVEM B,FWDADR
LSH B,-<^D9> ;Get inferior page number
HRL A,MBXFK
HRR A,B
MOVX C,PM%CNT!PM%RD!PM%CPY!2
CAIN B,777 ;Is inferior page page 777?
SUBI C,1 ;Yes, only map 1 page then
MOVE B,[.FHSLF,,FWDWIN/1000]
PMAP%
MOVE A,FWDSTR
LDB B,[POINT 9,FWDADR,35]
ADDI B,FWDWIN
CALLRET MOVST0
ENDSV.
;;; Make a new recipient block from forwarded address
;;; T/ host,,name
;;; Returns O/ standard recipient block
FWDRCP: PUSH P,T
MOVEI A,RCPLEN ;Get block for this recipient
CALL ALCBLK
FATAL (Memory exhausted)
MOVEI O,(B)
MOVX B,FR%STR
MOVEM B,RCPFLG(O) ;Initialize flags
MOVE A,[POINT 7,STRBUF]
HRRZ B,(P)
CALL FWDCPY ;Copy string from inferior
HRROI A,STRBUF
CIETYP < %1W>
CALL CPYSTR ;Get byte pointer and count
HRLI B,(<POINT 7,0>)
DMOVEM B,RCPBPT(O) ;Save them
POP P,T
HLRZ B,T ;Get host address
JUMPE B,FWDRC1 ;Local
MOVE A,[POINT 7,HSTBUF]
CALL FWDCPY ;Copy host name from inferior
DO.
TXNN A,76B4 ;Filled to word boundary?
EXIT.
IDPB D,A ;No, do another null
LOOP.
ENDDO.
HRROI B,HSTBUF
ETYPE <@%2W>
CALL HSTNAM
SKIPA
RET
CALL RCPLXH ;Put in error for no such host
FWDRC1: MOVEI B,LCLNAM ;And store as local
RET
SUBTTL Requeue or send failure message for message in M
REMAIL: JSR SAVACS ;Save all ACs
STKVAR <RMLJFN>
TXZ F,FQ%SXX ;Clear flags
SETZM MSGTMT(M) ;No more timeouts when requeueing
SKIPE NTDEQF ;Dequeueing file or notifying sender?
CALL SERRCP ;Yes, finalize errors
REMAI0: SETZM FAIJFN ;Reset output jfn's
SETZM NTFJFN
SETZB N,REQJFN ;Do local mail
TXZ F,FQ%OMF!FQ%MLA!FQ%SDR!FQ%RNM!FQ%XNT!FQ%XER ;Clear flags
MOVE A,FILIDX ;a := flags for current queue file type
MOVE A,%FLFLG(A)
TXNE A,FF%OML ;Old style?
TXO F,FQ%OMF ;Yes
TXNE A,FF%RNM ;Rename to add RETRANSMIT extension?
TXO F,FQ%RNM ;Yes
TXNE A,FF%XNT ;Suppress non-delivery notifications?
TXO F,FQ%XNT ;Yes
MOVX A,FG%XER ;Discard on error?
TDNE A,MSGJFN(M)
TXO F,FQ%XER ;Yes
;;; I think it's probably all right to allow local mail here, even if not WOPR
MOVEI O,MSGLCL(M)
TXZ F,FQ%ALL
CALL REMALS ;Hack this list
MOVEI N,MSGRCP(M)
DO.
HRRZ N,(N)
JUMPE N,ENDLP.
MOVX T,FH%DON ;This host got done?
TDNN T,HSTFLG(N)
TXOA F,FQ%ALL ;No, output it all
TXZ F,FQ%ALL
MOVEI O,HSTRCP(N)
CALL REMALS
LOOP.
ENDDO.
SKIPN NTFJFN ;Sender notification?
SKIPE FAIJFN ;Or failure file?
IFNSK.
CALL GENHDL ;Build local headers
SKIPN A,FAIJFN ;Failure file?
IFSKP.
MOVEI B,OUTMSG ;Routine to output headers/text
CALL REMHTX ;Do it with punctuation
TXNN F,FQ%SXX ;Processing rerouted failure msg?
TXNN F,FQ%SDR ;No, fail on sender?
IFSKP.
IFXE. F,FQ%MLA ;Also fail on mail agent?
TXO F,FQ%SXX ;Divert failure msg to mail agent
DELF% ;Delete current reply file
JFATAL
CLOSF% ;Close it
JFATAL
SKIPN A,REQJFN ;Also requeue file?
IFSKP.
CLOSF% ;Yes, close it
JFATAL
SETZM REQJFN
ENDIF.
SKIPN A,NTFJFN ;Also notification file?
IFSKP.
DELF% ;Delete it
JFATAL
CLOSF% ;And close it
JFATAL
SETZM NTFJFN
ENDIF.
JRST REMAI0
ENDIF.
TXO A,CO%NRJ ;Close fail msg file and keep JFN
CLOSF%
JFATAL
MOVEI A,0(A) ;Now rename the file to "bad mail"
CALL RENBAX
ELSE.
CLOSF% ;Close out failure file
JFATAL
SKIPN NTFJFN ;Only set flags once
SKIPE REQJFN
SKIPA
CALL MAIFLG
ENDIF.
ENDIF.
SKIPN A,NTFJFN ;Notification file pending?
IFSKP.
MOVEI B,OUTMSH ;Routine to output headers and no text
CALL REMHTX ;Do it with punctuation
CLOSF% ;Close out notification file
JFATAL
SKIPN REQJFN ;Only set flags once
CALL MAIFLG
ENDIF.
ENDIF.
SKIPN A,REQJFN ;Have a requeue file?
RET ;No, all done
MOVEI B,.CHFFD ;No, must end addressee specs
BOUT%
HRROI B,CRLF0
SETZ C,
SOUT%
DMOVE B,MSGHDR(M) ;Finish off file
MOVNI C,(C)
SOUT%
TXO A,CO%NRJ ;Close file, preserve JFN
CLOSF%
JFATAL
HRRZ A,MSGJFN(M) ;Get back JFN of original file
MOVEM A,RMLJFN
TXO A,CO%NRJ
CALL UNMQUF ;Unmap, leave JFN
RET ;Percolate error up
MOVE A,RMLJFN
HRLI A,.GFLWR ;Save file writer
HRROI B,STRBUF
GFUST%
ERJMP .+1
IFXN. F,FQ%RNM!FQ%OMF ;Rename file extension or old mail first?
HRROI A,STRBF1 ;Yes, construct new name
MOVE B,RMLJFN ;From original file's JFN
IFXN. F,FQ%OMF
MOVX C,JS%DEV!JS%DIR!JS%PAF
JFNS%
TXNN F,FQ%XNT ;Notify about errors?
SKIPA B,[[ASCIZ/[--QUEUED-MAIL--]/]]
MOVEI B,[ASCIZ/[--RETURNED-MAIL--]/]
CALL MOVSTR
ELSE.
MOVX C,JS%DEV!JS%DIR!JS%NAM!JS%PAF
JFNS%
ENDIF.
SKIPN NETF ;Were we allowed to deliver network mail?
SKIPA B,[[ASCIZ/.NETWORK;P770000/]] ;No, use alternate name
MOVEI B,[ASCIZ/.RETRANSMIT;P770000/] ;Yes, use standard name
CALL MOVST0
DO.
MOVX A,GJ%NEW!GJ%FOU!GJ%ACC!GJ%SHT ;And rename the file
HRROI B,STRBF1
GTJFN%
IFJER.
CAIE A,GJFX24 ;Work around monitor bug
JWARN <Cannot get RETRANSMIT file>
MOVEI A,^D5000 ;Wait 5 seconds
DISMS%
LOOP.
ENDIF.
MOVE B,A ;JFN of name we will rename to
ENDDO.
EXCH A,RMLJFN ;Set original file JFN, get former one
CALL RNMFIL
IFNSK.
JWARN <Unable to rename to RETRANSMIT extension>
MOVEM A,RMLJFN ;Rename failed, restore former name
MOVE A,B ;JFN we tried to use
RLJFN% ;Flush this useless JFN
ERJMP .+1 ;Don't care if it fails
ENDIF.
ENDIF.
MOVE A,REQJFN ;Requeue file we just made
MOVE B,RMLJFN ;Original file JFN
CALL RNMFIL
IFNSK.
JWARN <Cannot rename requeue file>
EXCH A,RMLJFN ;A:=existing JFN, RMLJFN:=JFN failed to rename
RLJFN% ;Flush the failing JFN
NOP
ENDIF.
MOVE A,RMLJFN ;JFN we ended up with
MOVEI B,MSGWRT(M) ;Set its write date
MOVEI C,1
SFTAD%
ERJMP .+1
HRROI B,STRBUF
CALL .SFUST ;Set its writer
MOVE B,RMLJFN
RLJFN%
JWARN
CALL MAIFLG ;Set flags unless already did
IFXN. F,FQ%RNM!FQ%OMF ;Rename file extension or old mail first?
SKIPN NETF ;Did we queue something for the network fork?
CALL WAKNET ;Yes, go wake it up
ENDIF.
RET
ENDSV.
;; Routine to output msg headers and text with punctuation to a
;; notification or error file
; Entry: a = output jfn
; b = message output routine
REMHTX: PUSH P,B ;Save output routine
HRROI B,[ASCIZ/ ------------
/]
SETZ C,
SOUT% ;Do starting punctuation
POP P,B ;Execute output routine
CALL (B)
JFATAL <Local message output lost> ;+1, error???
HRROI B,[ASCIZ/-------
/]
SETZ C,
SOUT% ;Add trailing punctuation
RET
;; Check one list of recipients
REMALS: TXZ F,FQ%HST ;Host not yet output
REMLS1: HRRZ O,(O)
JUMPE O,R ;Done with list
DO.
IFXE. F,FQ%ALL ;Output all of this host?
MOVE A,RCPFLG(O) ;a := recipient flags,,link to next
TXNN A,FR%FAI ;Permanent failure?
TXNN A,FR%TMP ; or no errors?
EXIT. ;Then don't requeue this one
ENDIF.
TXON F,FQ%HST ;Already got host?
CALL REMLHS ;No, output it
HRRZ A,REQJFN ;a := requeue file JFN
MOVE B,RCPBPT(O)
MOVN C,RCPCNT(O)
SOUT%
HRROI B,CRLF0
SETZ C,
SOUT%
SKIPG NTDEQF ;Notifying sender of status?
IFSKP.
SKIPN A,NTFJFN ;Yes, JFN already set up?
CALL REMNTF ;No, do it
CALL APPERM ;Now append error msg
ENDIF.
ENDDO.
MOVX T,FR%FAI
TXNN F,FQ%ALL ;Outputing all of this host?
TDNN T,RCPFLG(O) ;Or not permanent failure?
IFSKP.
IFN. N ;If not local mail,
CALL MMLGT ;Check for mail agent failure
CALL MSNDR ;And sender failure
ENDIF.
MOVE A,RCPFLG(O) ;a := recip flags,,link to next recip
IFXN. A,FR%MLA ;Is this a failure for mail agent?
TXON F,FQ%MLA ;Yes
WARN <Failed sending msg to Mail Agent>
ENDIF.
TXNE A,FR%SDR ;Is this a failure for the sender?
TXO F,FQ%SDR ;Yes
IFXN. F,FQ%XER ;Discard this file on error?
MOVEI A,[ASCIZ/ Message queued too long, file purged/]
SKIPL NTDEQF ;Dequeueing file?
MOVEI A,[ASCIZ/ Message file purged/] ;No, must be error
UTYPE 1,(A) ;Type appropriate msg
ELSE.
SKIPE A,FAIJFN
IFSKP.
SKIPGE NTDEQF ;Dequeue this file?
CITYPE < Message queued too long, sender notified>
CALL REMLFA ;Init failure file
ENDIF.
CALL APPERM ;Append the name and error msg
ENDIF.
ENDIF.
JRST REMLS1
;; Routine to append recipient name and error msg to a sender
;; notification or error file.
; a = output jfn
; o = adr of recipient block
APPERM: MOVE B,RCPBPT(O) ;b/c := recipient name ptr
MOVN C,RCPCNT(O)
SOUT%
MOVEI B,"@"
BOUT%
IFE. N ;Output host
HRROI B,LCLNAM
ELSE.
HRRO B,HSTHST(N)
ENDIF.
SOUT%
HRROI B,[ASCIZ/: /]
SOUT%
HRRO B,RCPERR(O) ;And the error msg
TXNN B,.RHALF ;Given?
HRROI B,[ASCIZ/No error msg given./]
SOUT%
HRROI B,CRLF0 ;Append a CRLF
SOUT%
RET
;; Output host first time
REMLHS: SKIPN A,REQJFN
CALL REMLRQ
MOVEI B,.CHFFD
BOUT%
IFE. N
HRROI B,LCLNAM
ELSE.
HRRO B,HSTHST(N)
ENDIF.
SETZ C,
SOUT%
HRROI B,CRLF0
SOUT%
RET
;; Start of requeue file
REMLRQ: HRROI A,STRBF1 ;As good a place as any I guess
HRRZ B,MSGJFN(M) ;JFN for queued file
MOVE C,[110000,,1] ;Print device and directory
JFNS%
HRROI B,[ASCIZ/-REQUEUED-MAIL/]
SETZ C,
SOUT% ;Append our filename to it
MOVEI B,"-"
IDPB B,A
MOVE B,MYJOBN ;Set up job number
MOVEI C,^D10 ;Output in decimal
NOUT%
JFATAL
MOVEI B,"-"
IDPB B,A
MOVE B,FORKX ;Tack in fork number
NOUT%
JFATAL
HRROI B,[ASCIZ/.TMP.-1/]
SETZ C,
SOUT% ;Append our filename to it
MOVX A,GJ%FOU!GJ%NEW!GJ%SHT
HRROI B,STRBF1
GTJFN%
IFJER.
CAIN A,GJFX24 ;Somebody's DELDF% screwed us? (monitor bug)
IFSKP.
MOVEI A,STRBF1 ;No, set up name for warning
JWARN <Can't get %1W in REMLRQ>
ENDIF.
MOVEI A,^D5000 ;Wait 5 seconds
DISMS%
JRST REMLRQ ;Try again
ENDIF.
MOVEM A,REQJFN ;Save the JFN
MOVX B,<<FLD ^D7,OF%BSZ>!OF%WR>
OPENF%
IFJER.
CAIN A,OPNX2 ;Somebody's DELDF% screwed us? (monitor bug)
IFSKP.
MOVE B,REQJFN ;Get JFN for message
JWARN <Can't open %2J in REMLRQ>
ENDIF.
MOVE A,REQJFN ;Flush JFN
RLJFN%
JWARN
MOVEI A,^D5000 ;Wait 5 seconds
DISMS%
JRST REMLRQ ;Try again
ENDIF.
MOVX B,.CHFFD ;Output delivery option
BOUT%
HRROI B,[ASCIZ/=DELIVERY-OPTIONS:/]
SOUT%
MOVE B,MSGDOP(M)
HLRO B,DOPTAB(B) ;Get delivery option string
SOUT%
HRROI B,CRLF0
SOUT%
SKIPN D,MSGFHS(M) ;Net host spec?
IFSKP.
MOVEI B,.CHFFD ;Output keyword part
BOUT%
HRROI B,[ASCIZ/=NET-MAIL-FROM-HOST:/]
SOUT%
HRRO B,D
SOUT%
HRROI B,CRLF0
SOUT%
ENDIF.
SKIPN MSGRPT(M) ;Return path specified?
IFSKP.
MOVEI B,.CHFFD ;Yes, copy it to output
BOUT%
HRROI B,[ASCIZ/=RETURN-PATH:/] ;Yes, output it
SETZ C,
SOUT%
HRRO B,MSGRPT(M) ;Now output the path
SOUT%
HRROI B,CRLF0 ;Terminating CRLF
SOUT%
ENDIF.
SKIPN C,MSGAFT(M) ;After specified?
IFSKP.
CAMG C,CURDTM ;Yes, before current time?
IFSKP.
HRROI B,[ASCIZ/=AFTER: /] ;No, write new after period
CALL OUDTIM ;Output after parameter
ELSE.
SETZM MSGAFT(M) ;Set no after parameter
ENDIF.
ENDIF.
IFXE. F,FQ%XNT ;Suppress non-delivery notifications?
SKIPE C,MSGNTF(M) ;No, sender notification time set?
IFSKP.
SKIPN C,MSGAFT(M) ;Must compute it, have an After time?
SKIPA C,CURDTM ;No, start with current time then
ADD C,NTFINT ;Otherwise use After time plus notify interval
ENDIF.
DO.
CAMLE C,CURDTM ;Past current time?
IFSKP.
ADD C,NTFINT ;No, bump an interval
LOOP. ;And try again
ENDIF.
ENDDO.
HRROI B,[ASCIZ/=NOTIFY: /]
CALL OUDTIM ;Use previous notification time
ENDIF.
SKIPE C,MSGDEQ(M) ;Dequeue time set?
IFSKP.
MOVE C,MSGWRT(M) ;No, get write time
CAMG C,MSGAFT(M) ;Is an after time specified that's greater?
MOVE C,MSGAFT(M) ;Yes, use after time as base
ADD C,MAXQUE ;Plus interval
ENDIF.
HRROI B,[ASCIZ/=DEQUEUE: /]
CALL OUDTIM ;Use previous dequeue time
TXNE F,FQ%XER ;Discard on error?
CALL DSCRDE ;Yes, retain that property
CALLRET SDRHDR ;Write the sender spec
;; Routine to output a time difference (t1 - t2) in days.
; Entry: a = output jfn
; b = t1 (internal date/time format)
; c = t2 (internal date/time format)
OTMDIF: SUB B,C ;Compute time difference
CAIGE B,0 ;Set neg value to 0
SETZ B,
ADDI B,400000 ;Round to nearest day
HLRZS B
MOVEI C,^D10 ;Print it in decimal
NOUT%
JFATAL
MOVE C,B ;Save the value
HRROI B,[ASCIZ/ days/]
CAIN C,1 ;Exactly one?
HRROI B,[ASCIZ/ day/]
SETZ C,
SOUT%
RET
;;; Routine to compute internal date/time after given delay
; Entry: b = delay in seconds
; curdtm = current date/time
; Call: CALL DLYTIM
; Return: +1, c = new date/time
DLYTIM: HRLZ C,B ;Normalize delay to internal std
IDIVI C,^D<24*60*60>
ADD C,CURDTM ;Add on current time
RET
;;; Routine to output a date/time control parameter
; Entry: b = ptr to parameter keyword
; c = internal time value
; Call: CALL OUDTIM
; Return: +1
OUDTIM: PUSH P,C ;Save the time
PUSH P,B ;And the text ptr
MOVEI B,.CHFFD ;Output keyword part
BOUT%
POP P,B
SETZ C,
SOUT%
POP P,B ;Now the time
MOVX C,OT%NSC!OT%SCL
ODTIM%
HRROI B,CRLF0 ;End line
SETZ C,
SOUT%
RET
;; Init failure file
REMLFA: CALL RESPQF ;Initialize the file
IFXE. F,FQ%SXX ;Divert reply to mail agent?
CALL SDRADR ;Addressee = sender
ELSE.
CALL MLAADR ;Addressee = mail agent
ENDIF.
CALL RESPQB ;Finish up the file
MOVEM A,FAIJFN
HRROI B,[ASCIZ/Message of /]
SETZ C,
SOUT%
MOVE B,MSGWRT(M) ;b := file write date/time
MOVX C,OT%SCL
ODTIM%
SKIPGE NTDEQF ;Last try?
IFSKP.
HRROI B,[ASCIZ/
Message failed for the following:
/]
SETZ C,
ELSE.
HRROI B,[ASCIZ/
Message undeliverable and dequeued after /]
SETZ C,
SOUT%
MOVE B,CURDTM ;Compute time in queue so far
MOVE C,MSGWRT(M)
CALL OTMDIF ;And output it
HRROI B,[ASCIZ/:
/] ;Finish punctuation
ENDIF.
SOUT%
RET
;; Routine to initialize a response file to notify sender that msg has
;; not been sent.
REMNTF: CALL RESPQN ;Initialize the file
CALL SDRADR ;Addressee = sender
CALL DSCRDE ;Set discard parameter
CALL RESPQB ;Finish up the file
MOVEM A,NTFJFN
HRROI B,[ASCIZ/Message of /]
SETZ C,
SOUT%
MOVE B,MSGWRT(M) ;b := file write date/time
MOVX C,OT%SCL
ODTIM%
HRROI B,[ASCIZ/
Message undelivered after /]
SETZ C,
SOUT%
MOVE B,CURDTM ;Output time in queue
MOVE C,MSGWRT(M)
CALL OTMDIF
HRROI B,[ASCIZ/ -- will try for another /]
SOUT%
MOVE B,MSGDEQ(M) ;Output remaining time in queue
MOVE C,CURDTM
CALL OTMDIF
HRROI B,[ASCIZ/:
/] ;Finish punctuation
SOUT%
RET
;;; Routine to rename a file
; Entry: a = source file jfn
; b = destination file JFN
; Call: CALL RNMFIL
; Return: +1, error
; +2, success
RNMFIL: SAVEAC <A,B>
STKVAR <SRC,DST>
MOVEM A,SRC ;Save source/destination JFNs
MOVEM B,DST
DO.
RNAMF% ;Rename, superceding
IFJER.
CAIE A,RNAMX5 ;File busy?
RET
MOVEI A,^D5000 ;Yes, wait 5 seconds and try again
DISMS%
MOVE A,SRC ;Get back source
LOOP.
ENDIF.
ENDDO.
MOVE A,DST ;Get destination JFN
HRLI A,.FBBYV ;Set to retain infinite versions
MOVX B,FB%RET
SETZ C,
CHFDB%
ERJMP .+1 ;Ignore failure
RETSKP
ENDSV.
SUBTTL Internet routines
; B/ Host name to connect to
; C/ Host number to connect to
INTSND: CAMN C,$UKHST ;Unknown host address?
JRST ADEADH ;Yes, fail right away
STKVAR <INTDST,INTADR,INTTRY,INTERR,DSTHPT>
MOVEM A,DSTHPT ;Save the ultimate destination
MOVEM B,INTDST ;Save destination
MOVEM C,INTADR ;Save destination address
MOVX A,^D10 ;Don't loop more than 10 times
MOVEM A,INTTRY
HRROI A,LCLNCN ;Local name for this network
SETO B, ;Output local host
CALL $GTHNS
FATAL (Can't get Internet local host name)
MOVE A,INTDST ;Get immediate destination
MOVE B,DSTHPT ;Ultimate destination host
CALL GENHDR ;Generate headers
MOVE N,SAVEN ;n := starting recipient host
MOVEI O,HSTRCP(N) ;o := start of recipient list
MOVE A,[POINT 7,STRBUF] ;a := ptr to net file name str
DO.
MOVEI B,[ASCIZ/TCP:/] ;Build device
CALL MOVSTR
;;; By default, DEC uses a port number of 100000+<job#>_6+<JFN#>
;;;For most applications, this is alright. It is not good enough
;;;for us, however. We open lots of connections, and are quite
;;;likely to get the same JFN each time. Because of this, any time
;;;we open to the same host in succession we're in danger of getting
;;;the same TCB before it's been fully flushed. What we'll do is use
;;;a slightly smarter version of DEC's algorithm, keeping within the
;;;reserved port number space if possible.
PUSH P,A
GJINF% ;Get our job number for local port
POP P,A
SKIPN C ;Job 0?
MOVEI C,377 ;Yes, do not use a small port number!
LSH C,6 ;Put job # where DEC expects it
AOS B,NXTSEQ ;Get next number in sequence
ANDI B,37 ;Cycle through 5 bits
IOR B,C ;Merge in job number
MOVE C,FORKX ;Get our fork ID
CAIN C,NETFRK ;Net fork?
TXO B,40 ;Yes, distinguish between it and rxmfrk
SKIPN WOPRP ;Privileged?
TXZA B,100000 ;Yes, make sure an unprivileged port
TXO B,100000 ;Yes, make like we're using a DEC port!
MOVX C,^D10 ;Ports are decimal
NOUT%
ERJMP R ;Failed
MOVEI B,[ASCIZ/#./] ;Privileged use of absolute local port
SKIPN WOPRP ;Privileged?
MOVEI B,[ASCIZ/./] ;No, just delimit to foreign port
CALL MOVSTR
MOVE B,INTADR ;Destination host number
MOVX C,^D8 ;TCP: hosts are in octal
NOUT% ;Output to file string
ERJMP R ;Shouldn't fail
MOVEI B,[ASCIZ/-25;CONNECTION:ACTIVE/] ;Port 25
CALL MOVST0
SETOM INTERR ;No default "OPENF% error code"
MOVX A,GJ%SHT ;Short form
HRROI B,STRBUF ;Pointer to file string we made
GTJFN% ;Make a JFN on it
ERJMP ADEADH ;Failed so mark dead
MOVEM A,NETJFN ;Save JFN
MOVX B,<<FLD ^D8,OF%BSZ>!<FLD .TCMWH,OF%MOD>!OF%RD!OF%WR>
DO. ;Begin timed control block
TMOSET (^D30,ENDLP.) ;Quit after 30 seconds
OPENF% ;Open 8 read/write buffered and wait
IFNJE.
TMOCLR ;Got it, clear timer
CALL SMTSND ;Call SMTP worker routine
DO.
TMOSET (^D60,ENDLP.) ;Don't wait too long for the FIN to happen
MOVE A,NETJFN ;Send a FIN to the other end
MOVX B,.TCSFN
TCOPR% ;Send the FIN
IFNJE.
DO. ;Now go into a loop slurping bytes from
BIN% ; the other end
ERJMP ENDLP. ;Closed, JFN close okay now
LOOP. ;Keep going until slurped up last byte
ENDDO.
ENDIF.
ENDDO.
TMOCLR
CALL $CLOSF ;Close the connection
RETSKP ;Success return
ELSE.
MOVEM A,INTERR ;Save last error code if OPENF% failed
ENDIF.
ENDDO. ;End of timed control block
TMOCLR ;Clear timer
MOVE A,NETJFN ;Get Internet JFN back
RLJFN% ;Release it
JWARN
SETZM NETJFN
MOVE A,INTERR ;Get back last error
CAIN A,TCPX19 ;Connection already exists?
SOSLE INTTRY ;Yes, have any more retries?
JRST ADEADH ;Other error or out of retries
LOOP. ;Yes to both, try next port up
ENDDO.
ENDSV.
;;; SMTP routines, independent of Internet
; SMTP command reply summary
; ^D220 ;Server greeting
; ^D250 ;OK
; ^D251 ;OK, but will forward
; ^D354 ;Ready for message
; ^D4xx ;Soft failure
; ^D5xx ;Hard failure
; ^D500 ;Unrecognized command
; ^D501 ;Unimplemented command
; ^D550 ;No such mailbox
SMTSND: STKVAR <SMTDOP,SMTHPT,DOMPTR,<HSTTMP,^D13>,<HSTLCL,^D13>>
HRROI A,HSTLCL ;Make absolute copy of local name string
HRROI B,LCLNCN
CALL OUTAHS
MOVE A,MSGDOP(M) ;Get message's delivery option
MOVEM A,SMTDOP ;And save as a temporary here
CALL SMRPLY ;Get greeting message
JRST SMTJER
CAIE B,^D220 ;Success reply is 220
JRST SMTSMF
MOVE A,NETJFN ;Negotiate HELO command
HRROI B,[ASCIZ/HELO /]
SETZ C,
CALL $SOUT
JRST SMTJER
HRROI B,HSTLCL ;Absolute form of local host
CALL SMMESG
JRST SMTJER
CAIE B,^D250 ;Success reply is 250
JRST SMTSMF
MOVE A,NETJFN ;Negotiate MAIL FROM command
MOVE B,SMTDOP ;Get delivery option index
HLRO B,DOPTAB(B) ;Get delivery option string
SETZ C,
CALL $SOUT
JRST SMTJER
HRROI B,[ASCIZ/ FROM:</]
DO.
CALL $SOUT
JRST SMTJER
SKIPN D,MSGRPT(M) ;Have a return path?
IFSKP.
MOVEI B,"@" ;Yes, must prepend local host as part
CALL $BOUT ;of source route. Output an at
JRST SMTJER
HRROI B,HSTLCL ;Local host name
CALL $SOUT
JRST SMTJER
MOVE B,MSGRPT(M) ;Make pointer to return path
HRLI B,(<POINT 7,>)
ILDB B,B ;Get first character of return path
CAIE B,"@" ;Additional source routing specification seen?
SKIPA B,[":"] ;No, use colon to terminate source routing
MOVEI B,"," ;Else must use comma for continuation
CALL $BOUT ;Output the character
JRST SMTJER
MOVE D,B ;Last delimiter
MOVE B,MSGRPT(M) ;Now output return path
HRLI B,(<POINT 7,>)
SETZ C, ;Terminate on null
CALL $SOUT
JRST SMTJER
ELSE. ;Return path not known, create one using sender
ANDQE. FG%XER,MSGJFN(N) ;But not if discarding errors!
MOVE D,MSGSDR(M) ;D := addr of sender host entry block
HRRZ C,HSTRCP(D) ;C := adr of recipient entry block
HRRZ B,RCPBPT(C) ;B := ptr to sender name
CAIN B,MLAGNT ;Only do this if not mail agent
ANSKP.
HRROI A,STRBUF ;Output to recipient buffer
MOVE B,RCPBPT(C) ;B,C := sender name ptr/byte count
MOVN C,RCPCNT(C) ;C := neg byte count
SOUT%
HRRZ B,HSTHST(D) ;B := sender host pointer
CAIN B,LCLNAM ;Is it our host?
MOVEI B,HSTLCL ;Yes, use canonical form
MOVEM B,SMTHPT ;Save host pointer
CAIN B,HSTLCL ;Is it me?
IFSKP.
MOVEI B,"%" ;Punctuate
IDPB B,A
MOVEI B,HSTLCL ;Set up local name
EXCH B,SMTHPT ;Restore host
HRROS B
SOUT%
ENDIF.
MOVE C,A ;Save termination
MOVE A,NETJFN ;Restore JFN
MOVE B,[POINT 7,STRBUF]
CALL QOTSTR ;Output it quoted
JRST SMTJER
MOVEI B,"@" ;Punctuate
CALL $BOUT
JRST SMTJER
HRRO B,SMTHPT ;Restore host
CALL $SOUT ;Output host name
JRST SMTJER
ENDIF. ;End of return-path output conditional
HRROI B,[ASCIZ/>/]
CALL SMMESG
JRST SMTJER
CAIN B,^D250 ;Success reply is 250
IFSKP.
MOVE A,NETJFN ;Failed, restore JFN
MOVE B,SMTDOP ;Get delivery option index
HLRO B,DOPTAB(B) ;Get delivery option string
SETZ C,
CALL $SOUT ;Output delivery option
JRST SMTJER
HRROI B,[ASCIZ/ FROM:<>/] ;Output null return path in case the SMTP
CALL SMMESG ; server didn't like its syntax...
JRST SMTJER
CAIN B,^D250 ;Did it win this time?
IFSKP.
SKIPN SMTDOP ;No, non-MAIL delivery option?
IFSKP.
SETZM SMTDOP ;Yes, convert to MAIL delivery option
MOVE A,NETJFN ;Restore JFN
LOOP. ;and try again
ENDIF.
JRST SMTSMF ;Treat as failure of entire message
ENDIF.
ENDIF.
ENDDO.
TXZ F,FM%VRC ;Initially no valid recipient seen
DO.
CALL NXTRCP ;Get next recipient
IFSKP.
CALL RSTRCP ;Reset error flags from other tries
MOVE A,NETJFN ;Start transaction
HRROI B,[ASCIZ/RCPT TO:</]
SETZ C,
CALL $SOUT
JRST SMTJER
MOVE A,[POINT 7,STRBUF]
CALL OUTRCP ;Output recipient name to STRBUF
MOVE C,A ;End of string pointer
MOVE A,NETJFN
MOVE B,[POINT 7,STRBUF] ;Recipient name to output
CALL QOTSTR ;Output it, quoted
JRST SMTJER ;Output failed
MOVE A,[POINT 7,STRBUF]
MOVX B,"@"
IDPB B,A
HRRO B,FRNHST ;Get site we are talking to
CALL OUTAHS ;Output it
MOVEI B,">"
IDPB B,A
SETZ B,
IDPB B,A
HRROI B,STRBUF
CALL SMMESG
JRST SMTJER
ETYPE <%1W> ;Type reply for user
CAILE B,^D299 ;Valid recipient?
IFSKP.
TXO F,FM%VRC ;Flag a valid recipient seen
ELSE.
CAIGE B,^D500 ;Hard fail code?
SKIPA B,[FR%TMP!FR%ERM] ;No, temporary error
MOVX B,FR%FAI!FR%ERM ;Yes, permanent
CALL STEMSG ;Flag the user failure
ENDIF.
LOOP.
ELSE.
ANDXN. F,FM%VRC ;A valid recipient seen?
CITYPE < > ;Yes, indicate sending the message text
HRROI B,[ASCIZ/DATA/]
CALL SMMESG ;Get reply
JRST SMTJER
CAIE B,^D354 ;Good reply?
JRST SMTSMF ;No, whole message fails
MOVE A,NETJFN ;Get output designator
CALL MSGOUT ;Output message, checking for periods
JRST SMTJER ;+1 Network error
CALL SMRPLY ;Get a reply
JRST SMTJER
ETYPE <%1W> ;Type reply
CAIE B,^D250 ;250 is success reply
JRST SMTSMF ;Whole message fails
ENDIF.
ENDDO.
SMTQIT: HRROI B,[ASCIZ/QUIT/] ;Negotiate QUIT command
CALL SMMESG
NOP ;Don't care
RET
ENDSV.
;;;JSYS error in SMTP dialog
SMTJER: TMOCLR ;No more interrupts
; CALLRET NETJER
NETJER: HRROI A,STRBUF ;Create error string
HRLOI B,.FHSLF ;This fork,,last error
SETZ C,
ERSTR%
ERJMP .+1
ERJMP .+1
HRROI A,STRBUF ;Set up string for SMTSMF
CETYPE <%1W> ;Type error msg for user
MOVX B,FR%TMP!FR%ERM ;Yes, save error info for dequeue
CALLRET STUMSG ;Update user errors
;;;Entire message fails due to SMTP error reply
SMTSMF: CETYPE <%1W> ;Type error msg for user
CAIGE B,^D500 ;Hard fail code?
SKIPA B,[FR%TMP!FR%ERM] ;No, mark as soft
MOVX B,FR%ERM!FR%FAI ;Otherwise hard
CALL STUMSG ;Update user errors
JRST SMTQIT
;;; SMTP quoting
;Accepts:
; A/ Destination designator
; B/ Source pointer - may not be to STRBF1!!!!!!!
; C/ End of source string pointer or 0 to terminate on null
; CALL QOTSTR
;Returns +1: JSYS error
; +2: success
; Clobbers STRBUF, STRBF1
QOTSTR: SAVEAC <A,D,T,TT>
STKVAR <QOTDES,QOTSRC,QOTTMP,QOTCNT>
MOVEM A,QOTDES ;Save output designator
MOVEM B,QOTSRC ;Save source pointer
MOVE A,[POINT 7,STRBF1] ;Pointer to temporary buffer
MOVEM A,QOTTMP ;Save temporary buffer pointer
MOVE A,C ;End of string pointer
SETZM QOTCNT ;Initial number of copied bytes count
TXZ F,FM%QOT ;Initially require no quoting
MOVX B,"\" ;Quote for wierd characters
DO. ;Copy to STRBF1 with \ insert and " need check
IFN. A ;If end of string pointer exists
CAMN A,QOTSRC ;Reached end of buffer?
EXIT. ;Yes, leave now
ENDIF.
ILDB C,QOTSRC ;Get character in buffer
IFE. A ;If terminate on null
JUMPE C,ENDLP. ;Terminate on null
ENDIF.
MOVEI T,(C) ;Make a copy of it to hack
IDIVI T,^D32 ;T := word to check, TT := bit to check
MOVNS TT
MOVX D,1B0 ;D := bit to check
LSH D,(TT)
TDNE D,QOTMSK(T) ;Is it a special character?
TXO F,FM%QOT ;Yes, note
TDNN D,QT1MSK(T) ;Is it an wierd character?
IFSKP.
IDPB B,QOTTMP ;Yes, put in wierd character quote
SOS QOTCNT ;Count the quoting character
ENDIF.
IDPB C,QOTTMP ;Now copy character
SOS QOTCNT
LOOP. ;Count and continue
ENDDO.
MOVE A,[POINT 8,STRBUF]
MOVX T,.CHDQT
TXNE F,FM%QOT ;Need to do atomic quoting?
IDPB T,A ;Yes, insert it
MOVE B,[POINT 7,STRBF1]
MOVE D,QOTCNT ;Count of bytes in recipient string
DO.
ILDB C,B ;Copy recipient string to command buffer
IDPB C,A
AOJL D,TOP.
ENDDO.
TXNE F,FM%QOT ;Need to do atomic quoting?
IDPB T,A ;Yes, insert it
HRRZ T,A ;Last word written
SUBI T,STRBUF-1 ;Number of words written
LSH T,2 ;Number of bytes in those words
LDB TT,[POINT 3,A,2] ;Number of padding bytes
SUBI T,(TT) ;Number of bytes in string
MOVE A,QOTDES
MOVE B,[POINT 8,STRBUF]
MOVN C,T
CALL $SOUT ;Output buffer
RET
RETSKP
ENDSV.
;;;If any of these characters are seen, the entire string must be
;;;quoted within double quotes
BRINI. ;Initialize break mask
BRKCH. (.CHNUL,.CHTAB) ;CTRL/@ 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. ;Form table
;;;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. (.CHDQT) ;"
BRKCH. (134) ;"\"
QT1MSK: EXP W0.,W1.,W2.,W3. ;Form table
;;; Send a line and get response
SMMESG: MOVE A,NETJFN
SETZ C,
CALL $SOUT
RET
HRROI B,CRLF0
SETZ C,
CALL $SOUTR ;Output buffer
RET
;;; CALLRET SMRPLY ;Get a reply and return
;;; Get a reply, return text starting pointer in A, number in B
SMRPLY: STKVAR <TXTPTR>
DO.
TMOSET(^D300,TIMOUT) ;Wait 5 minutes before giving up
MOVE A,NETJFN
MOVE B,[POINT 7,STRBUF]
MOVEM B,TXTPTR
MOVX C,<5*STRBSZ>-1
MOVEI D,.CHLFD ;Terminate on line feed
SIN% ;Read a line
IFJER.
TMOCLR
RET
ENDIF.
TMOCLR ;No more interrupts...
LDB C,B ;Sniff at last byte of text
CAIN C,.CHLFD ;Ended in LF? (should have)
IFSKP.
WARN <SMRPLY didn't get full text of SMTP reply>
ELSE.
MOVNI C,2 ;Yes, back up over CRLF
ADJBP C,B ;C := backed over byte pointer
MOVE B,C ;Update copy in B for tie-off below
ILDB C,C ;Get expected CR
CAIN C,.CHCRT ;Was it?
ANSKP.
WARN <SMRPLY got an SMTP reply that ended with LF, not CRLF>
IBP B ;No, don't wipe the whatever it was out
ENDIF.
SETZ C, ;Make sure string is properly tied off
IDPB C,B
SKIPN DEBUGP ;Debugging SMTP replies?
IFSKP.
MOVEI A,STRBUF ;Print the whole buffer
CIETYP < SMTP: %1W
> ;CRLF and text
ENDIF.
SETZ B, ;Accumulate number here
DO.
ILDB C,TXTPTR ;Get byte
CAIE C,177 ;IAC? (Some cretin sending TELNET protocol!)
IFSKP.
ILDB C,TXTPTR ;Sigh, get command byte
CAIL C,173 ;WILL/WONT/DO/DONT?
ILDB C,TXTPTR
LOOP. ;Having ignored this IAC, try again
ENDIF.
CAIL C,"0" ;Is this character a digit?
CAILE C,"9"
EXIT. ;End of number
IMULI B,^D10 ;Else add in the new digit
ADDI B,-"0"(C)
LOOP. ;Get another digit
ENDDO.
CAIE C,"-" ;Continuation line?
CAIGE B,^D100 ;Some silly message we don't care about?
LOOP. ;Yes to either, get a new line
ENDDO.
MOVE A,TXTPTR
RETSKP
ENDSV.
SUBTTL DECnet Routines
;
; Try to connect and deliver a message to a remote DECnet host.
; Deliver using SMTP (object #125) if possible. If nobody answers,
; try using Mail-11 (object #27) instead. If this fails too,
; we're out of luck (it's a tough life).
;
; Entry: A/ Name of ultimate destination host
; B/ Name of DECnet host to connect to
; Call: CALL DCNSND
; Return: +1 -- Failure, error message printed using SMTJER
; +2 -- Success, connection JFN in NETJFN
DCNSND: STKVAR <DCNNAM,DSTHST,OBJIX>
MOVEM A,DSTHST ;Save ultimate destination host
MOVEM B,DCNNAM ;Save remote DECnet host name
HRROI A,LCLNCN ;Storage for local name for this network
SETO B, ;Output local host
CALL $DECNS
FATAL (Can't get DECnet local host name)
MOVE A,DCNNAM ;Immediate destination host
MOVE B,DSTHST ;Ultimate destination host
CALL GENHDR ;Generate headers
MOVEI A,DCNTBL ;Set up pointer to object table
MOVEM A,OBJIX
DO.
HLRZ A,@OBJIX ;Get object spec
JUMPE A,ADEADH ;Mark host as dead if no more specs
MOVE B,DCNNAM ;Name of remote host
CALL DCNCON ;Try to connect
IFSKP.
HRRZ A,@OBJIX ;Call transport routine
MOVE B,DCNNAM ;Get remote name agatin
MOVE N,SAVEN ;N := starting recipient host
MOVEI O,HSTRCP(N) ;O := start of recipient list
CALL (A) ;Call the proper worker routine
CALL $CLOSF ;Close the connection
RETSKP ;Success return
ENDIF.
AOS OBJIX
LOOP.
ENDDO.
ENDSV.
DCNTBL: [ASCIZ/-125/],,SMTSND
[ASCIZ/-TASK-MX-LISTENER/],,SMTSND
[ASCIZ/-27/],,VAXSND
0
; Connect to a DECnet host
;
; Entry: A/ Remote object name
; B/ Remote host name
; Call: CALL DCNCON
; Return: +1 -- Failure, couldn't connect
; +2 -- Success, connection JFN in NETJFN
DCNTIM==^D30000 ;DECnet user time-out interval (msec)
DCNDTM==^D60000 ;DECnet daemon time-out interval (msec)
DCNCON: STKVAR <DCNNAM,DCNOBJ>
MOVEM A,DCNOBJ ;Save DECnet object and
MOVEM B,DCNNAM ;Save DECnet host name for later
MOVE A,[POINT 7,STRBUF] ;a := ptr to net file name str
MOVEI B,[ASCIZ/DCN:/] ;Build device spec
CALL MOVSTR
HRRO B,DCNNAM ;Pick up our remote host name again
CALL OUTAHS ;Drop it in without the relative domain
MOVE B,DCNOBJ ;Add DECnet object spec
CALL MOVST0
MOVX A,GJ%OLD!GJ%SHT ;Old, short form, name from string
HRROI B,STRBUF
GTJFN% ;Get a JFN for our connection
ERJMP R ;Failed, so fail-return
MOVEM A,NETJFN ;Else, save our network JFN
MOVX B,<FLD(^D8,OF%BSZ)!FLD(1,OF%MOD)!OF%RD!OF%WR>
OPENF% ;Open the connection
IFJER.
MOVE A,NETJFN ;Get our DECnet JFN back
RLJFN% ;Release it
JWARN
SETZM NETJFN
RET ;Return lossage
ENDIF.
MOVX B,DCNTIM ;Set timeout interval (assume user)
SKIPE DAEMNP ;Are we the daemon?
MOVX B,DCNDTM ;Yes, so get different timeout interval
MOVEM B,ICPTIM
DO.
MOVE A,NETJFN
MOVX B,.MORLS ;Read link status
SETZ C, ;No addresses returned
MTOPR% ;Check our status
IFNJE.
JXN C,MO%CON,RSKP ;Exit if connected
TXNN C,MO%ABT ;Did the other end abort the connection?
SKIPE CTGCNT ;Or, did we see a ^G abort?
ANSKP.
MOVX A,^D100 ;No, still looking for connect confirm
MOVNI B,(A)
ADDB B,ICPTIM ;Have we timed out?
ANDG. B
DISMS% ;No, wait another 100 msec
LOOP. ;Go check again
ENDIF.
ENDDO.
CALLRET $CLOSF ;Lossage, close connection
ENDSV.
;;; Mail-11 DECnet Routines
; Send the message to a Mail-11 listener.
;
; Entry: NETJFN/ connection JFN
; Call: CALL VAXSND
; Return: +1 -- Always, via VAXJER if an error occurred
VAXSND: STKVAR <SMTDOP,SMTHPT,DOMPTR,<HSTTMP,^D13>,<HSTLCL,^D13>>
HRROI A,HSTLCL ;Make absolute copy of local name string
HRROI B,LCLNCN
CALL OUTAHS
MOVE A,MSGDOP(M) ;Get message's delivery option
MOVEM A,SMTDOP ;And save as a temporary here
MOVE A,[POINT 7,STRBUF] ;We'll put the sender's name here
SKIPN D,MSGRPT(M) ;Have a return path?
IFSKP.
MOVEI B,.CHDQT ;Quote it
IDPB B,A
HRRO B,MSGRPT(M) ;Now output return path
SETZ C, ;Terminate on null
SOUT%
MOVEI B,.CHDQT ;And add an ending quote
IDPB B,A
SETZ B,
IDPB B,A
ELSE. ;Return path not known, create one using sender
MOVE D,MSGSDR(M) ;D := addr of sender host entry block
HRRZ C,HSTRCP(D) ;C := adr of recipient entry block
HRRZ B,RCPBPT(C) ;B := ptr to sender name
CAIN B,MLAGNT ;Only do this if not mail agent
IFSKP.
HRRZ B,HSTHST(D) ;B := sender host pointer
CAIN B,LCLNAM ;Is it our host? (Local user)
IFSKP.
MOVEM B,SMTHPT ;No, add host and quote all of it
MOVEI B,.CHDQT ;Start with a quote
IDPB B,A
MOVE B,RCPBPT(C) ;B,C := sender name ptr/byte count
MOVN C,RCPCNT(C) ;C := neg byte count
SOUT%
MOVEI B,"@" ;Separate user/host with an atsign
IDPB B,A
HRRO B,SMTHPT ;Add host
SOUT%
MOVEI B,.CHDQT ;Finish with an ending quote
IDPB B,A
SETZ B, ;And a null, of course
IDPB B, A
ELSE. ;It's a local sender -- just name is sufficient
MOVE B,RCPBPT(C) ;B,C := sender name ptr/byte count
MOVN C,RCPCNT(C) ;C := neg byte count
SOUT%
ENDIF. ;End of local sender conditional
ENDIF. ;End of origin not mail agent conditional
ENDIF. ;End of return-path output conditional
HRROI B,STRBUF ;Send sender to the vax
CALL VAXLIN
JRST VAXJER
TXZ F,FM%VRC ;Initially no valid recipient seen
DO.
CALL NXTRCP ;Get next recipient
EXIT.
CALL RSTRCP ;Reset error flags from other tries
MOVE A,[POINT 7,STRBUF]
CALL OUTRCP ;Output recipient name to STRBUF
SKIPN GTDBLK+.GTDRD ;Doing MX?
IFSKP.
MOVX B,"%" ;Yes, shove in relay poop
BOUT% ;Probably this should have been done better
HRRO B,FRNHST
CALL OUTAHS
ENDIF.
SETZ B, ;Mark EOS
IDPB B,A
HRROI A,STRBUF ;Get recepient
CALL UCASE ;And turn it to upper case
HRROI A,STRBUF ;Double colonize address
CALL VAXTRN
HRROI B,STRBUF ;Send receiver to the VAX
CALL VAXLIN
JRST VAXJER
CALL VAXVRF ;Valid recipient?
IFSKP.
ANDE. B ;Single losers make whole message fail
ELSE.
MOVX B,FR%TMP ;Whole message lost, mark as soft error
CALLRET STUMSG ;Update user errors
ENDIF.
TYPE <Recepient accepted> ;Yes, tell user
TXO F,FM%VRC ;Flag a valid recipient seen
LOOP.
ENDDO.
JXE F,FM%VRC,R ;Punt now if no valid recipients
CITYPE < > ;Yes, indicate sending the message text
CALL VAXNIL ;Mark end of recepient list
JRST VAXJER
MOVEI A,[ASCIZ "TO"]
CALL FNDHEA ;Find recepients
HRROI B,[ASCIZ ""] ;Null string in case of none
CALL VAXLIN ;Send it
JRST VAXJER
MOVEI A,[ASCIZ "SUBJECT"]
CALL FNDHEA ;Find subject
HRROI B,[ASCIZ ""] ;In case of none
CALL VAXLIN ;And send it
JRST VAXJER
MOVE A,NETJFN ;Get output designator
CALL VAXMSG ;Output message, checking for CRLFs
JRST VAXJER ;+1 Network error
CALL VAXNIL ;Indicate end of message
JRST VAXJER
;;;Go through each recepient and verify that he/she really got the message
MOVE N,SAVEN ;N := starting recipient host
MOVEI O,HSTRCP(N) ;O := start of recipient list
DO. ;DO for each recepient
CALL NXTRCP ; Get next recipient
IFSKP. ; IF got another?
JN FR%FAI!FR%TMP,RCPFLG(O),TOP. ;Leave alone if already failed
CALL VAXVRF ; Verify this one
RET ; Whole message lost
LOOP. ; LOOP for each recepient
ENDIF. ; ENDIF got another
ENDDO. ;ENDDO for each recepient
RET
ENDSV.
;;; Transmogrify address to VMS double colon format (A/ address string)
;;; eg. a%b@c => c::b::a a%b.dom@c => c::dom%b::a (using VMS Foreign Protocol)
VAXTRN: TXC A,.LHALF ;Is str pnt LH -1?
TXCN A,.LHALF
HRLI A,(<POINT 7,>) ;Set up byte pointer
MOVE T,A ;T := start of string
SETZ TT, ;TT: = non-zero if quote seen
PUSH P,A ;Push pnt of beg of string
DO. ;Now find all %-routes
ILDB C,A
JUMPE C,ENDLP. ;End if null
CAIN C,.CHDQT ;Start/end of quoted material?
SETCA TT, ;Toggle quote flag
JUMPN TT,TOP. ;Don't check for %'s inside quoted text
CAIN C,"%" ;Is it percent kludge?
PUSH P,A ;Yes, push pointer
LOOP. ;Go for next char
ENDDO.
MOVE D,[POINT 7,TMPBUF] ;Temporary storage
DO. ;Next change them into :: route
POP P,B ;Check what we've found
CAMN B,T ;Back to user part (beg of string)?
EXIT. ;Yes, don't process, just copy
PUSH P,B ;No, save pointer again
SETZ TT, ;Outside of quoted material
DO. ;Search for .pseudoDomain (*%*.x*)
ILDB C,B
JUMPE C,ENDLP.
CAIN C,.CHDQT ;Start/end of quoted material?
SETCA TT, ;Toggle quote flag
JUMPN TT,TOP. ;Don't check for %'s or .'s inside quoted text
CAIN C,"%" ;End on %
EXIT.
CAIE C,"." ;Found domain?
LOOP. ;No, check next char
DO. ;Yes, move it + % sign
ILDB C,B
JUMPE C,ENDLP.
CAIN C,.CHDQT ;Start/end of quoted material?
SETCA TT, ;Toggle quote flag
IFE. TT ;Inside quoted text?
CAIN C,"%" ;No, end on %
EXIT.
ENDIF.
IDPB C,D ;Copy char
LOOP.
ENDDO.
MOVEI C,"%" ;Add % sign (VMS Foreign Protocol)
IDPB C,D
ENDDO.
POP P,B ;Get string pointer again
SETZ TT, ;Outside quoted text again
DO. ;Now move host name (*%x.*)
ILDB C,B
JUMPE C,ENDLP.
CAIN C,.CHDQT ;Start/end of quoted material?
SETCA TT, ;Toggle quote flag
IFE. TT ;Inside quoted text?
CAIE C,"%" ;No, end on %
CAIN C,"." ;..or "."
EXIT.
ENDIF.
IDPB C,D ;Move it
LOOP.
ENDDO.
MOVEI C,":" ;Append double colon
IDPB C,D
IDPB C,D
LOOP.
ENDDO.
SETZ TT, ;Clear quote flag
DO. ;Move user part (x*)
ILDB C,B
JUMPE C,ENDLP.
CAIN C,.CHDQT ;Start/end of quoted material?
SETCA TT, ;Toggle quote flag
IFE. TT ;Inside quoted text?
CAIN C,"%" ;No, end on %
EXIT.
ENDIF.
IDPB C,D ;Move it
LOOP.
ENDDO.
SETZ C, ;Mark null
IDPB C,D
MOVE A,T ;Move string back again
HRROI B,TMPBUF
SETZ C,
SOUT%
RET
;;; Send a line in B to VAX but don't wait for response
VAXLIN: MOVE A,NETJFN
SETZ C,
CALLRET $SOUTR
;;;JSYS error in MAIL-11 dialog
VAXJER: CALLRET SMTJER
;;; Mark end of recepeint list by sending a NULL
VAXNIL: MOVE A,NETJFN
HRROI B,[0]
MOVEI C,1
SETZ D,
CALLRET $SOUTR
;;; Verify a recepient by an acknowledge from the VAX.
;;; Returns +1 if whole message lost, +2 if message either succeded
;;; (with B/ 0) or only lost for this user (with B/ error flags)
VAXVRF: TMOSET(^D120,TIMOUT) ;Wait 2 minutes before giving up
SETZM STRBUF ;Clear STRBUF
MOVE A,NETJFN ;Get network JFN
HRROI B,STRBUF ;Set destination to STRBUF
MOVX C,-4 ;Want 4 bytes
SINR%
ERJMP VAXJER ;Couldn't get it -- report total soft error
HLRZ A,STRBUF ;What did the VAX say?
SETZ B, ;Reset error flags in B
CAIN A,4000 ;Good acknowledgement?
IFSKP.
HRROI B,STRBUF ;No, put error message in STRBUF
DO.
MOVE A,B ;Destination in A (STRBUF)
HRROI B,CRLF0 ;Start it with a CRLF
SETZ C, ;(Including the NULL)
SOUT%
MOVE B,A ;Destination in B (STRBUF)
MOVE A,NETJFN ;What went wrong?
SINR% ;Go get it
ERJMP VAXJER ;Couldn't get it -- report total soft error
LDB D,B ;Got a null string (= end of error msg)?
CAIE D,.CHLFD ;Then, we're still pointing on the last LF
LOOP. ;Otherwise get next line
ENDDO.
MOVX D,-2 ;Backup before last CRLF
ADJBP D,B
SETZ C,
IDPB C,D ;Smash last CR with NULL
HRROI A,STRBUF ;Point to the string
ETYPE <%1W> ;Type message for user
MOVX B,FR%ERM!FR%FAI ;Mark as hard error
CALL STEMSG ;Record error for user
ENDIF.
RETSKP
; Find the value of a certain header
;
; Entry: A/ mem addrs of asciz header key string
; Call: CALL FNDHEA
; Return: +1 for Failure
; +2 for Success with B/ asciz pnt to header value string
FNDHEA: HRLM A,HEATAB+1 ;Save header key
MOVE X,MSGNHD(M) ;Count,,byte-> to headers for this net
HLRZ Y,X ;Put count in Y
SUBI Y,2 ;Subtrace first CRLF
HRLI X,220700 ;And fill LR of X with a byte-> to 3rd byte
FNDSB0: CALL PARLIN ;Parse another line
RET ;End of file
JXN F,FP%EOL,R ;Empty line?
MOVEI A,HEATAB ;Point to header table
TXNE F,FP%CLN ;Ended by a colon?
CALL PARKEY ;Yes, check if subject
JRST FNDSB0 ;Either not colon or not subject -- try next
MOVE B,PCLNBP ;Got one!
IBP B ;Skip colon
CALL CPYHEA ;Copy the header
RETSKP
HEATAB: -1,,.+1
0,,[RETSKP]
; Copy a header value into STRBUF
;
; Entry: B -- Byte pointer to header value
; Call: CALL CPYHEA
; Return: +1 with B/ byte pnt asciz string in STRBUF
;
CPYHEA: MOVE A,[POINT 7,STRBUF]
DO.
ILDB C,B ;Copy a byte
IDPB C,A
CAIE C,.CHCRT ;Found CR?
LOOP. ;No, move next
SETZ C, ;Mark possible EOS
DPB C,A
ILDB C,B ;1st char on next line
CAIN C,.CHLFD ;(Skip LF)
ILDB C,B ;(Get real 1st char)
CAIE C,.CHTAB ;Tab? Then continue
CAIN C," " ;Space? Also continue
IFSKP. <EXIT.> ;Neither, done
IDPB C,A ;Copy this byte
LOOP.
ENDDO.
MOVE B,[POINT 7,STRBUF] ;Done copying, exit with B byte-> STRBUF
RET
; Turn a string into upper case
;
; Entry: A/ Pnt to asciz string
; Call: CALL UCASE
; Return: +1 always with string changed to uc and updated byte pnt in a
UCASE: SAVEAC <B>
TXC A,.LHALF ;Is str pnt LH -1?
TXCN A,.LHALF
HRLI A,(<POINT 7,>) ;Set up byte pointer
DO.
ILDB B,A ;Get next char
JUMPE B,R ;Return if done
CAIL B,"a" ;Turn into UC if >= "a" and <= "z"
CAILE B,"z"
CAIA
SUBI B,"a"-"A"
DPB B,A ;Put char back again
LOOP.
ENDDO.
;;; Output only message headers to JFN in A
;;; Returns: +1, transmission error
;;; +2, successful
VAXHEA: STKVAR <OUTMSD,BUFPTR>
MOVEM A,OUTMSD ;Save designator
;;; MOVEI A,^D256 ;Transmit 256 bytes at a time
MOVEI A,^D199 ;VMAIL can't handle more than 199 bytes, sigh!
MOVEM A,SEGSIZ ;Set segment size
SKIPN A,MSGTMT(M) ;Overall delivery timeout in effect?
IFSKP.
TIME% ;Yes, compute time limit for this copy
ADD A,TMCINT
CAMLE A,MSGTMT(M) ;Beyond total delivery timeout?
MOVE A,MSGTMT(M) ;Yes, use that
ENDIF.
MOVEM A,MSGTMC(M) ;Record copy timeout
MOVE A,OUTMSD ;Restore designator
MOVE B,MSGNHD(M) ;Headers we generated
HLRZ D,B ;Length
HRLI B,(<POINT 7,0>) ;Build byte pointer to message
SUBI D,2 ;Skip over the CRLF at the start
IBP B
IBP B
IFN. D ;Message non-empty with count in D
DO. ;Do 256-bytes at a time with CRLF checking
TMOCLR ;Disallow timer interrupts
MOVEM B,BUFPTR ;Save pointer to start of buffer
SETZB C,TT ;Character count zero, no doubled dot
DO. ;Search for "<CRLF>" sequence within buffer
CAMLE C,SEGSIZ ;Buffer filled?
EXIT. ;Yes, output it
ILDB T,B ;Get byte from buffer
ADDI C,1 ;Count this character
CAIE T,.CHCRT ;Is it a CR?
LOOP. ;No, continue scan
ILDB T,B ;Saw CR, get possible LF
ADDI C,1 ;Count this character
CAIE T,.CHLFD ;Have we gotten a <CRLF>?
LOOP. ;No, continue scan
ENDDO. ;End scan through message for <CRLF>.
MOVE B,BUFPTR ;Get back pointer to start of buffer
SUBI D,(C) ;Account for this many characters output
MOVNS C ;Negative byte count for SOUT%
ADDI C,2 ;Don't send CRLF
CALL OUTMST ;Check copy timer
JRST OUTMSF ;Timed out
IFE. C ;A null line?
HRROI B,[ASCIZ ""] ;Yes, send a NULL terminated null string
CALL $SOUTR
JRST OUTMSF
MOVE B,BUFPTR ;Then restore text pointer
ELSE.
CALL $SOUTR ;No, output the string as usual
JRST OUTMSF
ENDIF.
ILDB T,B ;Skip CRLF we didn't send
ILDB T,B
JUMPG D,TOP. ;Continue output if more bytes to go
ENDDO.
ENDIF.
AOS (P) ;Set success (+2)
TMOCLR ;Disallow timer interrupts now
RET
ENDSV.
;;; Output whole text of message and headers to JFN in A with CRLF checking
;;; Returns: +1, transmission error
;;; +2, successful
VAXMSG: STKVAR <BUFPTR>
CALL VAXHEA ;Output headers
RET ;+1 Transmission error
MOVEI B,^D256 ;Transmit 256 bytes at a time
MOVEM B,SEGSIZ ;Set segment size
MOVE B,MSGTXT(M) ;Get pointer to message text
MOVE D,MSGTCN(M) ;Get text count
DO. ;Do 256-bytes at a time with CRLF checking
JUMPLE D,OUTMDN ;Quit if no more bytes to do
TMOCLR ;Disallow timer interrupts
MOVEM B,BUFPTR ;Save pointer to start of buffer
SETZ C, ;Character count zero
DO. ;Search for "<CRLF>" sequence within buffer
CAMLE C,SEGSIZ ;Buffer filled?
EXIT. ;Yes, output it
ILDB T,B ;Get byte from buffer
ADDI C,1 ;Count this character
CAIE T,.CHCRT ;Is it a CR?
LOOP. ;No, continue scan
ILDB T,B ;Saw CR, get possible LF
ADDI C,1 ;Count this character
CAIE T,.CHLFD ;Have we gotten a <CRLF>?
LOOP. ;No, continue scan
ENDDO. ;End scan through message for <CRLF>
MOVE B,BUFPTR ;Get back pointer to start of buffer
SUBI D,(C) ;Account for this many characters output
MOVNS C ;Negative byte count for SOUT%
ADDI C,2 ;Don't send <CRLF> itself
CALL OUTMST ;Check copy timer
JRST OUTMSF ;Timed out
IFE. C ;A null line?
HRROI B,[ASCIZ ""] ;Yes, send a NULL terminated null string
CALL $SOUTR
JRST OUTMSF
MOVE B,BUFPTR ;Then restore text pointer
ELSE.
CALL $SOUTR ;No, output the string as usual
JRST OUTMSF
ENDIF.
ILDB T,B ;Skip CRLF we didn't send
ILDB T,B
LOOP.
ENDDO.
ENDSV.
SUBTTL Chaosnet routines
;;; Chaos specific symbols, etc
;Timeouts
CHATIM==^D7000 ;User time-out
CHADTM==^D20000 ;Daemon time-out
;Connection states
;IFNDEF .CSCLS,<.CSCLS==0> ;Closed
;IFNDEF .CSLSN,<.CSLSN==1> ;Listening
;IFNDEF .CSRFC,<.CSRFC==2> ;RFC received
IFNDEF .CSRFS,<.CSRFS==3> ;RFC sent
IFNDEF .CSOPN,<.CSOPN==4> ;Opened
;IFNDEF .CSLOS,<.CSLOS==5> ;LOS-ing
IFNDEF .CSINC,<.CSINC==6> ;Incomplete transmission (no response to SNS)
IFNDEF .MOPKR,<.MOPKR==27> ;MTOPR% code to read a packet
;Packet description
$CPKOP==<POINT 8,Z,7> ;Opcode
$CPKNB==<POINT 12,Z,31> ;Number of bytes
CHPKDT==4 ;First word of data
CHPMXC==^D488 ;Maximum number of characters of data
;Packet opcodes
;IFNDEF .CORFC,<.CORFC==1> ;Request for connect
;IFNDEF .COOPN,<.COOPN==2> ;Open
IFNDEF .COCLS,<.COCLS==3> ;Close
;IFNDEF .COFWD,<.COFWD==4> ;Forward
;IFNDEF .COANS,<.COANS==5> ;Answer
;IFNDEF .COSNS,<.COSNS==6> ;Sense status
;IFNDEF .COSTS,<.COSTS==7> ;Report status
;IFNDEF .CORUT,<.CORUT==10> ;Routing info (not used)
IFNDEF .COLOS,<.COLOS==11> ;You are losing
;IFNDEF .COLSN,<.COLSN==12> ;Listen (never used)
;IFNDEF .COMNT,<.COMNT==13> ;Maintenance
;IFNDEF .COEOF,<.COEOF==14> ;EOF connection stream
;IFNDEF .COMAX,<.COMAX==15> ;Maximum opcode+1
;IFNDEF .CODAT,<.CODAT==200> ;Random data opcode
;;; Send message in M to Chaosnet host in E
; B/ Host name to connect to
; C/ Host number to use
CHASND: STKVAR <HSTPTR,DSTHPT>
MOVEM A,DSTHPT ;Save ultimate host
MOVEM B,HSTPTR ;Save host pointer
HRROI A,LCLNCN ;Local name for this network
SETO B, ;Output local host
CALL $CHSNS
FATAL (Can't get Chaosnet local host name)
MOVE A,HSTPTR ;Get immediate destination
MOVE B,DSTHPT ;Get ultimate destination
CALL GENHDR ;Generate headers
SETZM NETJFN ;No MAIL connection yet
DO.
CALL NXTRCP ;Get next recipient
EXIT. ;No, done with recipients
CALL RSTRCP ;Reset error flags from other tries
SKIPN MSGDOP(M) ;Want some kind of send?
IFSKP. ;Guess so...
MOVE C,HSTPTR ;Need name back
PUSH P,NETJFN ;Save jfn we're using for MAIL
CALL CHSEND ;Try a chaos SEND
IFSKP. ;Did it win?
POP P,NETJFN ;This MUST happen on all paths through here!!
MOVE B,MSGDOP(M) ;Yup, it won, see what we were doing
CAIE B,D%SAML ;Want mail even when send won?
LOOP. ;Nope, done with this recipient
ELSE. ;Send lost
POP P,NETJFN ;This MUST happen on all paths through here!!
MOVE B,MSGDOP(M) ;See what we were doing
CAIN B,D%SEND ;Send only?
LOOP. ;Yup, really lost, next recipient
ENDIF. ;Going on to do MAIL if we get here
ENDIF. ;Or here
CALL RSTRCP ;Reset error flags again
SETZM TMPBUF ;Clear reply string buffer
SKIPE A,NETJFN ;Net mail jfn
IFSKP. ;Don't have one yet
MOVE A,[POINT 7,STRBUF] ;Construct contact name
MOVEI B,[ASCIZ/CHA:/] ;Chaos
CALL MOVSTR
MOVE B,HSTPTR ;Host name
CALL OUTAHQ ;Add it, in absolute form
MOVEI B,[ASCIZ/.MAIL/] ;Contact name is MAIL
CALL MOVST0 ;Tack it on, end with null
HRROI B,STRBUF ;Point at filename
SETZ C, ;No third arg for OPENF%
CALL CHAOPN ;Go open the connection
CALLRET $CLOSF ;Couldn't, host is dead, out of here
MOVE A,NETJFN ;Get jfn we just opened
ENDIF. ;Have a net jfn in A
CALL CHARCP ;Output this name
TYPE <(MAIL) > ;Say we are trying MAIL
MOVEI B,<200+.CHCRT> ;Newline
BOUT%
IFNJE.
MOVEI B,.MOSND
MTOPR%
..TAGF (ERJMP,) ;I sure wish ANNJE. existed!
CALL CHAREP ;Get reply
ANSKP.
CAIN D,"+" ;Address ok?
LOOP. ;Yes, flag as such
CAIN D,"%" ;Temporary error?
ANSKP.
CALL CHAECP ;No, hard error, copy error string
MOVX B,FR%FAI!FR%ERM ;Record failure
CALL STEMSG
LOOP. ;Try next recipient
ELSE.
CALL CHAECP ;Set up error string
MOVX B,FR%TMP!FR%ERM
CALL STEMSG ;Set error information
LOOP.
ENDIF.
ENDDO.
CITYPE < > ;Indicate sending message text
SETZM TMPBUF ;Clear network reply buffer
SKIPN A,NETJFN ;Are we doing mail at all?
RETSKP ;No, bye
MOVE C,MSGNHD(M)
HLRZ D,C
HRLI C,(<POINT 7,0>)
CALL CHOSTR ;Dump out headers
IFSKP.
DMOVE C,MSGTXT(M) ;Okay, now the message
CALL CHOSTR
ANSKP.
MOVEI B,.MOEOF
MTOPR%
..TAGF (ERJMP,) ;I sure wish ANNJE. existed!
CALL CHAREP ;Get reply
ANSKP.
CAIE D,"+" ;Ok?
ANSKP.
ELSE.
CALL CHAECP ;Yes, copy error string
MOVX B,FR%TMP!FR%ERM ;Save error info for dequeue
CALL STUMSG ;Update user errors
ENDIF.
CALL $CLOSF ;Close it - take care of data error
RETSKP
ENDSV.
;Open a chaos connection, returns +1 on failure, +2 on success
;NETJFN might be open even if connection didn't, so you can get the error msg.
;B/ Filespec for connection
;C/ Zero or contact name word for OPENF%
CHAOPN: MOVX A,GJ%SHT ;Generic
GTJFN% ;B already points to filespec
ERJMP R ;Failed completely, host dead or something
MOVEM A,NETJFN ;Save the jfn
MOVEI A,CHATIM ;Set timer
SKIPE DAEMNP
MOVEI A,CHADTM
MOVEM A,ICPTIM
SETZM CTGCNT
MOVE A,NETJFN ;Open 8-bit, mode 6 (don't wait for OPN)
MOVX B,<<FLD ^D8,OF%BSZ>!<FLD 6,OF%MOD>!OF%RD!OF%WR>
OPENF% ;There may be a contact name in C
IFJER. ;Lost completely
MOVE A,NETJFN
RLJFN%
JWARN
SETZM NETJFN ;Be paranoid
RET ;It's dead, give up
ENDIF.
DO. ;Wait for the OPN
MOVE A,NETJFN
GDSTS% ;Get connection status
ERJMP R ;Give up
ANDI B,17 ;Just the state bits
CAIN B,.CSOPN ;OPN ?
RETSKP ;Yup, we won
CAIN B,.CSRFS ;RFS ?
SKIPE CTGCNT ;User requested abort?
EXIT. ;Out of here
MOVX A,-^D100 ;Still RFS and no abort, wait a while
ADDB A,ICPTIM ;Count off time to wait
JUMPLE A,ENDLP. ;Timeout, B has state
MOVX A,^D100
DISMS% ;Time left, dally on it
LOOP. ;Go try again
ENDDO. ;We've lost if we get here
CAIE B,.CSINC ;Not responding?
CAIN B,.CSRFS ;or timeout on RFS?
CALL ADEADH ;If either, mark as dead
RET ;Return failure
; Do a chaos SEND, return +1 on failure, +2 on sucess
;C/ Host name
CHSEND: MOVE A,[POINT 7,TMPBUF+1000] ;Build filename for connection
MOVEI B,[ASCIZ/CHA:/] ;Chaos
CALL MOVSTR
MOVE B,C ;Host name
CALL OUTAHQ ;Add it, in absolute form
MOVEI B,[ASCIZ/./] ;No contact name yet, easier to do in OPENF%
CALL MOVST0 ;Tack it on with a null
MOVE A,[POINT 8,TMPBUF] ;Cons up RFC packet
MOVEI B,[ASCIZ/SEND /] ;Contact name
CALL MOVSTR
CALL CHARCP ;The recipient
TYPE <(SEND) > ;Log that we are sending
IFXN. F,FM%RLY ;Are we relaying?
MOVEI B," " ;Yes, add space
IDPB B,A
SKIPN D,MSGSDR(M) ;and the sender
FATAL <No sender block set up>
HRRZ C,HSTRCP(D) ;Get pointer to sender's recipient entry block
MOVE B,RCPBPT(C) ;Point to sender user name
SKIPN C,RCPCNT(C) ;Have a recipient?
HRROI B,[ASCIZ/Unknown user/] ;No, make pretty name
SOUT% ;Write it
MOVEI B,"@" ;Add atsign
IDPB B,A
HRRO B,HSTHST(D) ;Now get name for host
CALL OUTAHS ;Add host name
ENDIF.
MOVEI C,-TMPBUF+1(A) ;Find length
IMULI C,4
LSH A,-41
SUB C,A
CAILE C,CHPMXC
MOVEI C,CHPMXC
HRLI C,TMPBUF
MOVSS C ;C/ length,,buffer (contact name)
HRROI B,TMPBUF+1000 ;B/ filespec (no contact name)
CALL CHAOPN ;Open the connection
IFSKP. ;Won, user available
MOVE A,NETJFN ;Output reply-parsable header:user<sp>date<nl>
SKIPN D,MSGSDR(M) ;d := adr of sender host entry block
FATAL <No sender block set up>
HRRZ C,HSTRCP(D) ;Get pointer to recipient entry block
MOVE B,RCPBPT(C) ;Point to sender user name
SKIPN C,RCPCNT(C) ;Have a recipient?
HRROI B,[ASCIZ/Unknown user/] ;No, make pretty name
SOUT% ;Write it
IFNJE.
MOVEI B,"@" ;Add atsign
BOUT%
..TAGF (ERJMP,) ;ANNJE.
HRRO B,HSTHST(D) ;Now get name for host
CALL OUTAHS ;Add host name
MOVEI B,.CHSPC ;Space
BOUT%
..TAGF (ERJMP,) ;ANNJE.
SETO B, ;Current time
MOVX C,OT%NSC!OT%12H!OT%SCL
ODTIM%
..TAGF (ERJMP,) ;ANNJE.
MOVE C,MSGNHD(M) ;Dump out headers (start with a newline)
HLRZ D,C
HRLI C,(<POINT 7,0>)
CALL CHOSTR
ANSKP.
DMOVE C,MSGTXT(M) ;And now the message
CALL CHOSTR
ANSKP.
MOVEI B,.MOEOF ;Send EOF
MTOPR%
..TAGF (ERJMP,) ;ANNJE.
MOVEI B,.MONOP ;Wait til it is ack'd
MTOPR%
..TAGF (ERJMP,) ;ANNJE.
TXO A,CO%WCL
CLOSF%
..TAGF (ERJMP,) ;ANNJE.
TYPE <OK>
SETZM NETJFN ;Be paranoid
RETSKP ;Won, return success
ENDIF.
;here if jsys error sending message, could get the emsg but most
;likely it's just 'data error' or something equally uninformative
MOVE TT,[POINT 7,[ASCIZ/SEND connection not completed/]]
ELSE. ;Here if couldn't even open a connection
MOVE TT,[POINT 7,[ASCIZ/Couldn't get a SEND connection to host/]]
SKIPN NETJFN
ANSKP.
DO.
MOVE A,NETJFN
GDSTS%
ERJMP ENDLP.
JXE C,.RHALF,ENDLP. ;No more packets, punt
MOVEI B,.MOPKR ;Else get a packet
MOVEI C,TMPBUF
MTOPR%
ERJMP ENDLP.
LDB C,[$CPKOP+TMPBUF]
CAIE C,.COLOS ;LOS packet?
CAIN C,.COCLS ;CLS packet?
IFSKP. <LOOP.> ;Neither, get another one
LDB C,[$CPKNB+TMPBUF]
IFG. C ;Ok, have a reply
MOVE TT,[POINT 8,TMPBUF+CHPKDT]
ADJBP C,TT ;Tie it off
SETZ A,
IDPB A,C
ENDIF.
ENDDO.
ENDIF.
ETYPE <failed - %7W>
CALL SERMRK ;Mark the error
CALLRET $CLOSF ;Done
;;Output recipient name for chaos with quoting, sigh. Apparently Unix servers
;;can't handle "user%host", they want "user"%host.... Everybody else seems to
;;be able to handle either, so we do it the Unix way.
CHARCP: MOVE A,[POINT 8,STRBUF]
DMOVE B,RCPBPT(O) ;Recipient
ADJBP C,B ;C=end pointer
CALL QOTSTR ;Output the user name string
FATAL (Impossible QUOSTR failure in CHARCP)
MOVE A,B ;Foo, QOTSTR preserves A...
IFXN. F,FM%RLY
MOVEI C,"@" ;Use @ to decrease chance of servers choking on
IDPB C,A ;quotes. Ok since no other @ follows.
MOVE C,A ;Save pointer
HRRZ B,HSTHST(N) ;Add host name
CALL MOVST0
EXCH A,C ;Flush the domain if any
CALL GETDOM
MOVE B,C
SETO A,
ADJBP A,B
ENDIF.
MOVEI D,-STRBUF+1(A) ;Find length
IMULI D,4
LSH A,-41
SUB D,A
CITYPE < >
MOVX A,.PRIOU
MOVE B,[POINT 8,STRBUF]
MOVN C,D
SKIPE PRINTP
SOUT%
TYPE <: >
MOVE A,NETJFN
MOVE B,[POINT 8,STRBUF]
MOVN C,D
SOUT%
ERJMP .+1
RET
;;Find (pseudo)domain in host name if any. If successful, A has domain block
;;and B pointer to the domain name.
GETDOM: STKVAR <DOMPTR>
TXCE A,.LHALF
TXCN A,.LHALF
HRLI A,(POINT 7,)
SETZM DOMPTR
DO.
ILDB B,A
CAIN B,"."
MOVEM A,DOMPTR
JUMPN B,TOP.
ENDDO.
MOVE A,DOMTBL
SKIPN B,DOMPTR
RET
PUSH P,C
TBLUK%
POP P,C
JXE B,TL%EXM,R ;Oops, not really a domain
MOVE B,DOMPTR
RETSKP
ENDSV.
;; Get chaos reply into TMPBUF, with timeout
;; A/ output JFN
;; On successful return, D has reply code
CHAREP: DO.
TMOSET(^D60,ENDLP.) ;Don't hang
SETZM TMPBUF ;Init empty buffer
MOVE B,[POINT 8,TMPBUF]
MOVX C,4000
MOVX D,<200!.CHCRT>
SIN% ;Read response line
ERJMP ENDLP.
TMOCLR
SETZ D,
DPB D,B ;Replace newline with null
MOVE A,[POINT 8,TMPBUF] ;Pointer to message (including status since
ETYPE <%1W> ; Unix doesn't send any text with status)
LDB D,[POINT 8,TMPBUF,7] ;Return status byte
RETSKP
ENDDO.
TMOCLR ;No more timeout
SETZM TMPBUF ;Flush any partial reply
RET
;; Here to copy error string to STRBUF with ending crlf
;; b = ptr to string source
CHAECP: DMOVE A,[POINT 7,STRBUF ;a := output buffer
POINT 8,TMPBUF] ;Error reply from network?
SKIPN TMPBUF
MOVE B,[POINT 7,[ASCIZ/Chaosnet error/]] ;No
CALLRET MOVST2
;;;Output string to Chaosnet, non-skip if failure
;;; A/ destination JFN
;;; C/ pointer
;;; D/ byte count
;;;This routine will never win an award for efficiency.
CHOSTR: DO.
SOJL D,RSKP
ILDB B,C ;Get next char
CAIN B,.CHLFD ;Lfs don't go
LOOP.
CAIL B,.CHBSP
CAILE B,.CHCRT
CAIA
TXO B,200
BOUT%
ERJMP R ;Failed: give error return
LOOP.
ENDDO.
SUBTTL Pup routines
PUPTIM==^D12000 ;Ethernet user time-out (msec)
PUPDTM==^D20000 ;Ethernet Daemon time-out (msec)
PUPSTM==^D60000 ;Ethernet Send reply time-out (msec)
; Packet level input/output
OPDEF PUPI% [JSYS 441]
OPDEF PUPO% [JSYS 442]
; Flags for PUPI%/PUPO%
PU%CHK==:1B1 ;Compute/check checksum
PU%TIM==:1B4 ;No input timeout in MS in AC3
; Packet structure definitions (from PUPSYM)
MNPLEN==:^D22 ;Minimum Pup Length in bytes
MXPLEN==:^D554 ;Maximum Pup Length in bytes
MXPBLN==:<MXPLEN+3>/4 ;Maximum size of PB, in words
DEFSTR PUPLEN,TMPBUF,15,16 ;Pup Length
DEFSTR PUPTYP,TMPBUF,31,8 ;Pup Type
PBCONT==5 ;Word data starts at
; Marks for mail transport
YESMRK==3 ;Yes
NOMRK==4 ;No
EOCMRK==6 ;End of command
HEREFL==5 ;Here is the file
STMAIL==20 ;Store mail
MBXEXC==23 ;Mailbox exception
; OF%MOD file open modes
.PUORW==16 ;Open port in raw packet mode
; MTOPR% functions
.MORMK==23 ;Read the most recently received mark
.MOSAB==25 ;Generate abort and close connection
.MORAB==26 ;Read abort code and string (abort state only)
; BSP port states
P%RFCO==1 ;RFC out
P%OPEN==3 ;Open
P%ABRT==7 ;Abort
; B/ Name to connect to
; C/ Address to use
PUPSND: STKVAR <PUPNAM,PUPADR,DSTHPT>
MOVEM A,DSTHPT ;Save ultimate host pointer
MOVEM P,SAVEP ;Save the starting P
MOVEM B,PUPNAM ;Save pointer
MOVEM C,PUPADR ;Save address
HRROI A,LCLNCN ;Local name for this network
SETO B, ;Output local host
CALL $PUPNS
FATAL (Can't get Pup local host name)
MOVE A,PUPNAM ;Get immediate destination
MOVE B,DSTHPT ;Get ultimate destination
CALL GENHDR ;Generate headers
SKIPN MSGDOP(M) ;Want to send message?
IFSKP.
MOVE A,[POINT 7,STRBUF] ;a := ptr to net file name str
MOVEI B,[ASCIZ/PUP:!J./] ;Output device and local host part
CALL MOVSTR
MOVE B,PUPNAM ;Host name
CALL OUTAHQ ;Add it, in absolute form
MOVEI B,[ASCIZ/+Misc-Services/] ;Misc-Services well-known socket
CALL MOVST0 ;Finish up the string as ASCIZ
MOVX A,GJ%OLD!GJ%SHT ;Old, short form, name from string
HRROI B,STRBUF
GTJFN% ;Get a JFN for the port
ERJMP ADEADH ;Fail
MOVEM A,NETJFN ;Save JFN
MOVX B,FLD(8,OF%BSZ)!FLD(.PUORW,OF%MOD)!OF%RD!OF%WR
OPENF% ;Open in raw packet mode
IFJER.
MOVE A,NETJFN ;Release output JFN
RLJFN%
JWARN
SETZM NETJFN
CALLRET ADEADH ;Fail
ENDIF.
;; Set up recipient blocks for loop
MOVE N,SAVEN ;n := starting recipient host
MOVEI O,HSTRCP(N) ;o := start of recipient list
CALL NXTRCP ;Next recipient
IFNSK.
CALL $CLOSF
RETSKP ;No recipients???
ENDIF.
DO.
CALL RSTRCP ;Reset error flags from other tries
SETZM TMPBUF ;Clear start of buffer
MOVE A,[TMPBUF,,TMPBUF+1]
BLT A,TMPBUF+MXPBLN-1 ;Clear it out for the length of a packet
MOVX A,300 ;Get packet type for ether send
STOR A,PUPTYP ;Save it
MOVE A,[POINT 8,PBCONT+TMPBUF] ;Get dest ptr
CALL PUPSDR ;Say who this send is from
MOVEI B,":" ;Colon
IDPB B,A ;Drop it in
CALL OUTRCP ;Copy string for net recipient
SKIPN GTDBLK+.GTDRD ;Doing MX?
IFSKP.
MOVX B,"%" ;Yes, shove in relay poop
BOUT% ;Probably this should have been done better
HRRO B,FRNHST
CALL OUTAHS
ENDIF.
MOVEI B,":" ;Colon
IDPB B,A ;Drop it in
CALL OUTMSG ;Add message text
FATAL <Unexpected +1 return from OUTMSG>
MOVEI B,(A) ;Compute address of last word
SUBI B,TMPBUF-1 ;Compute # 36-bit words used
LSH B,2 ;Convert to bytes
LSH A,-^D33 ;Get bytes not used in last word
SUBI B,(A) ;Compute Pup length
ADDI B,2 ;Include checksum
STOR B,PUPLEN ;Save length
HRRZ A,NETJFN ;Get JFN back
TXO A,PU%CHK ;Compute checksum
MOVE B,[MXPBLN,,TMPBUF] ;Max length, from buffer
PUPO% ;Send it out
IFJER.
CALL $CLOSF ;Close output JFN
CALLRET ADEADH ;Random lossage
ENDIF.
HRRZ A,NETJFN ;Get JFN again
TXO A,PU%CHK!PU%TIM ;Checksum, with timeout
MOVX C,PUPSTM ;Waiting for up to a minute
PUPI% ;Read it back in
IFJER.
CALL $CLOSF ;Close JFN
CALLRET ADEADH ;Random lossage
ENDIF.
LOAD A,PUPTYP ;Get type
CAIN A,301 ;Success?
IFSKP.
LOAD B,PUPLEN ;Get length of Pup
SUBI B,MNPLEN ;Minus minimum number is length of error string
IFE. B ;If we have nothing
HRROI B,[ASCIZ/Unknown network error/] ;Make up a string
ELSE.
MOVE B,[POINT 8,PBCONT+TMPBUF] ;Get pointer to error
ADJBP A,B ;Point to end of error message
SETZ C, ;Get a null
IDPB C,A ;Drop it in at end of string
ENDIF.
HRROI A,STRBUF ;Into string buffer
SETZ C, ;Ending on null
SOUT% ;Copy reason for failure
MOVX B,FR%FAI!FR%ERM ;Permanent failure with text message
CALL STEMSG ;Remember lossage for recipient
ENDIF.
CALL NXTRCP ;Find another recipient
EXIT. ;No more
LOOP. ;Do next
ENDDO.
CALL $CLOSF ;Flush the JFN
MOVE A,MSGDOP(M) ;Get back delivery options
CAIE A,D%SAML ;Send and mail?
RETSKP ;No, done sending
MOVE N,SAVEN ;n := starting recipient host
MOVEI O,HSTRCP(N) ;o := start of recipient list
ENDIF.
MOVE A,[POINT 7,STRBUF] ;a := ptr to net file name str
MOVEI B,[ASCIZ/PUP:!J./] ;Output device and local host part
CALL MOVSTR
HLRZ B,PUPADR ;b := dest subnet #
MOVX C,^D8 ;Octal output
NOUT%
ERJMP R
MOVEI B,[ASCIZ/#/] ;Add a #
CALL MOVSTR
HRRZ B,PUPADR ;b := dest host #
NOUT%
ERJMP R
MOVEI B,[ASCIZ/#/] ;Add another #
CALL MOVSTR
MOVEI B,[ASCIZ/0+Mail/] ;And finish with the "mail" socket
CALL MOVST0 ;(ASCIZ)
MOVX A,GJ%OLD!GJ%SHT ;Old, short form, name from string
HRROI B,STRBUF
GTJFN% ;Get a JFN for the port
ERJMP ADEADH ;Fail
MOVEM A,NETJFN ;Ok, save JFN
MOVX B,<<FLD ^D8,OF%BSZ>!<FLD 1,OF%MOD>!OF%RD!OF%WR>
OPENF% ;Initiate rendezvous
IFJER.
MOVE A,NETJFN ;a := output JFN
RLJFN% ;Release it
JWARN
SETZM NETJFN
CALLRET ADEADH
ENDIF.
MOVEI A,PUPTIM ;Set time-out count (user/daemon)
SKIPE DAEMNP
MOVEI A,PUPDTM
MOVEM A,ICPTIM
DO.
MOVE A,NETJFN ;a := net JFN
SETZ C, ;No addresses returned
GDSTS%
IFNJE.
ANDI B,17 ;Isolate port state in b
CAIN B,P%OPEN ;State = OPN ?
EXIT. ;Yes, have connection
CAIN B,P%RFCO ;State = RFC out ?
SKIPE CTGCNT ;Yes, ^G abort?
ANSKP.
MOVX A,^D100 ;No, RFC pending, a := 100 msec
MOVNI B,(A) ;Time-out expired?
ADDB B,ICPTIM
ANDG. B
DISMS% ;No, wait 100 msec
LOOP.
ENDIF.
CALL $CLOSF ;Close it
CALLRET ADEADH ;Add to dead host list
ENDDO.
SETZM CTGCNT ;Clear ^G abort flag
MOVE A,NETJFN ;a := transmit JFN
MOVX B,.MOEOF ;b := "mark" MTOPR% fct
MOVX C,STMAIL ;Start property list transfer
MTOPR%
ERJMP PUPJER ;Just in case
TXO F,FP%BKA ;Show sender property not sent
DO.
CALL NXTRCP ;Get the next recipient
EXIT. ;No more
CALL RSTRCP ;Reset error flags from other tries
MOVE A,[POINT 7,STRBUF] ;a := place for temp string
MOVEI B,[ASCIZ/((/] ;Start property punctuation
CALL MOVSTR
TXZN F,FP%BKA ;Sender property already sent?
IFSKP.
MOVEI B,[ASCIZ/End-of-Line-Convention CRLF)(Sender /]
CALL MOVSTR
CALL PUPSDR ;Output string for sender
MOVEI B,[ASCIZ/)(/] ;Finish this property entry and start another
CALL MOVSTR
ENDIF.
MOVEI B,[ASCIZ/Mailbox /] ;Start mailbox property entry
CALL MOVSTR
CALL OUTRCP ;Output this recipient's name
SKIPN GTDBLK+.GTDRD ;Doing MX?
IFSKP.
MOVX B,"%" ;Yes, shove in relay poop
BOUT% ;Probably this should have been done better
HRRO B,FRNHST
CALL OUTAHS
ENDIF.
MOVEI B,[ASCIZ/))/] ;End this property entry
CALL MOVST0
HRRZ A,NETJFN ;a := output JFN
HRROI B,STRBUF ;b := string just built
SETZ C,
SOUT% ;Send it off
ERJMP PUPJER
LOOP. ;Do all the recipients
ENDDO.
MOVE A,NETJFN ;a := transmit JFN
MOVX B,.MOEOF ;b := "mark" MTOPR% fct
MOVX C,EOCMRK ;End our transmission
MTOPR%
ERJMP PUPJER ;Just in case
CALL RPLYP ;Get the remote reply
IFSKP.
MOVE A,NETJFN ;a := transmit JFN
MOVX B,.MOEOF ;b := "mark" MTOPR% fct
MOVX C,HEREFL ;Good, so here comes the mail file...
MTOPR%
ERJMP PUPJER ;Just in case
CALL OUTMSG ;Output the mail text
JRST PUPJER ;+1, error, close up shop
MOVE A,NETJFN ;a := transmit JFN
MOVX B,.MOEOF ;b := "mark" MTOPR% fct
MOVX C,YESMRK ;End our transmission
MTOPR%
ERJMP PUPJER ;Just in case
SETZB B,C ;Yes code
BOUT%
ERJMP PUPJER
HRROI B,[ASCIZ/End of mail text./]
SOUT%
ERJMP PUPJER
MOVX B,.MOEOF ;b := "mark" MTOPR% fct
MOVX C,EOCMRK ;End our transmission
MTOPR%
ERJMP PUPJER ;Just in case
CALL RPLYP ;Get the remote response
ANSKP.
CALL $CLOSF ;Close it - take care of data error
HRROI A,STRBUF ;Print reply text
CIETYP < %1W>
HRRZS B ;b := starting mark
CAIN B,YESMRK ;Mail OK?
IFSKP.
MOVX B,FR%TMP!FR%ERM ;Treat as temp, save error text
CALL STUMSG ;Update user errors
ENDIF.
ELSE.
CALL PUPBRT ;Server barfed, abort connection
ENDIF.
RETSKP ;Return success
ENDSV.
;;;Say who this is from
PUPSDR: SKIPN D,MSGSDR(M) ;d := adr of sender host entry block
FATAL <No sender block set up>
HRRZ C,HSTRCP(D) ;c := adr of sender "recipient" entry block
MOVE B,RCPBPT(C) ;b,c := sender name ptr/-byte count
MOVN C,RCPCNT(C)
SOUT%
PUSH P,A ;Save destination
HRRO A,HSTHST(D) ;Pointer to sender host
CALL $PUPSN ;Recognized to Pup world?
IFSKP.
POP P,A ;Restore destination BP
MOVEI B,"@" ;Success, punctuate
IDPB B,A
HRRO B,HSTHST(D) ;Output name in absolute form
CALLRET OUTAHS ;That's all for this sender
ENDIF.
POP P,A ;Restore destination BP
MOVE B,HSTHST(D) ;Get host pointer
CAIN B,LCLNAM ;If local name, don't need extra path
IFSKP.
MOVEI B,"%" ;Use kludgy routing to make sure destination
IDPB B,A ; doesn't choke on unknown sender host
HRRO B,HSTHST(D) ;b := local host
SOUT% ;Output it in relative form
ENDIF. ;Fall out to addition of local name
;; Sender not given, on local host, or routed with "%".
;; Add at-sign and Pup name for local host.
MOVEI B,"@" ;Punctuate
IDPB B,A
HRROI B,LCLNCN ;Output absolute local host name
CALLRET OUTAHS ;Return after adding host name
;;;JSYS error while sending mail
PUPJER: CALL NETJER ;Get JSYS error string
JRST PUPBRT ;Abort connection
;;;JSYS error in a subroutine
PUPJEX: TMOCLR ;This may be needed
CALL NETJER ;Get last JSYS error
MOVE P,SAVEP ;Reset the stack
JRST PUPBRT
;;;Error in a subroutine, text of error in B
PUPERX: TMOCLR ;This may be needed
MOVE A,[POINT 7,STRBUF]
CALL MOVST0 ;Create error string
PUPERY: MOVE A,[POINT 7,STRBUF] ;Here when STRBUF set up
CIETYP < %1W
> ;CRLF and text
MOVX B,FR%TMP!FR%ERM ;Save error info for dequeue
CALL STUMSG ;Update user errors
MOVE P,SAVEP ;Reset the stack
; JRST PUPBRT
;;;Here to abort connection
PUPBRT: HRRZ A,NETJFN ;a := output JFN
MOVEI B,.MOSAB ;Abort function
SETZ C, ;No code assigned
HRROI D,[ASCIZ/Mail transfer aborted/] ;Abort text
MTOPR% ;Abort the connection
ERJMP .+1 ;Just in case
CALLRET $CLOSF ;Close the connection
; Routine to handle remote replies
; Entry: Remote response expected
; Call: CALL RPLYP
; Return: +1 if hard failure blocking us from continuing
; +2 if all ok to proceed
RPLYP: STKVAR <RPLMRK,RPLREP>
DO.
CALL RSPPUP ;Wait for his reply
IFNSK.
MOVEM B,RPLMRK ;Error reply, save end mark,,start mark
MOVEM C,RPLREP ;And the reply code
HRRZ A,RPLMRK ;Get start mark
CAIE A,NOMRK ;"No" mark?
IFSKP.
HRROI A,STRBUF ;Output error string
CIETYP < %1W>
MOVX B,FR%TMP!FR%ERM ;Assume temporary problem
CAIE C,41 ;Bad "mailbox" property syntax?
CAIN C,42 ;Or "sender" property syntax?
MOVX B,FR%FAI!FR%ERM ;Yes, permanent error
CAIE C,40 ;All mailboxes bad?
CAIN C,110 ;Permanent file system problem?
MOVX B,FR%FAI!FR%ERM ;Yes, permanent error
CALLRET STUMSG ;Update user msgs
ENDIF.
CAIE A,-1 ;"Timeout mark"?
IFSKP.
HRROI A,STRBUF ;Yes, output error string
CIETYP < %1W>
MOVX B,FR%TMP!FR%ERM ;Assume temporary problem
CALLRET STUMSG ;Update user msgs
ENDIF.
CAIN A,MBXEXC ;"Mailbox exception" mark?
IFSKP.
HRROI A,STRBUF ;No, some strange lossage
CIETYP < %1W>
MOVX B,FR%FAI!FR%ERM ;Permanent error
CALLRET STUMSG ;Update user msgs
ENDIF.
MOVE A,[POINT 7,STRBUF] ;a := ptr into reply string
SETZ B, ;b := start of "index" code
DO.
ILDB D,A ;d := char
CAIL D,"0" ;Digit?
CAILE D,"9"
EXIT. ;No, analyze what we have
IMULI B,^D10 ;Form decimal value
ADDI B,-"0"(D)
LOOP.
ENDDO.
CIETYP < %1W> ;Type msg for user
MOVE N,SAVEN ;n := starting recipient host
MOVEI O,HSTRCP(N) ;o := start of recipient list
IFLE. B
HRROI A,[ASCIZ/Server bug: Impossible mailbox exception index/]
CIETYP < %1W>
MOVX B,FR%FAI!FR%ERM ;Assume temporary problem
CALLRET STUMSG
ENDIF.
DO.
CALL NXTRCP ;No, get the next one
IFNSK.
HRROI A,[ASCIZ/Server bug: Mailbox exception index out of range/]
CIETYP < %1W>
MOVX B,FR%FAI!FR%ERM ;Assume temporary problem
CALLRET STUMSG
ENDIF.
SOJG B,TOP. ;Index down to our man
ENDDO.
MOVX B,FR%TMP!FR%ERM ;Assume temporary failure
SKIPN C,RPLREP ;c := reply code
IFSKP.
CAIE C,3 ;No, transient error?
MOVX B,FR%FAI!FR%ERM ;No, assume permanent error
ENDIF.
CALL STEMSG ;Install the error flags and message
ENDIF.
HLRZ A,B ;a := ending mark type
CAIE A,EOCMRK ;EOC?
LOOP. ;No, get the rest
ENDDO.
RETSKP
ENDSV.
; Routine to wait for a response from the Ethernet
; Entry: connection opened
; Call: CALL RSPPUP
; Return: +1, negative reply or timeout
; +2, positive reply
; b = end mark,,start mark, c = reply code, strbuf = text
; If the expected mark/code/text sequence is violated, a mark type of
; 0 is returned. The terminating mark is left set.
RSPPUP: STKVAR <MRKTYP,MRKCOD>
SETZM STRBUF ;Clear reply text
TMOSET(^D120,PUPTMO) ;Max 2 mins for a reply
CALL RCVCH ;Better have a mark now...
CALL CLMARK ;OK, clear the mark
JSP B,RSPPER ;No mark, sequence error
MOVEM B,MRKTYP ;Save the starting mark
CALL RCVCH ;Now read the code value
JSP B,RSPPER ;Mark - sequence error
MOVEM B,MRKCOD ;Save the code
HRROI B,STRBUF ;b := ptr to receive the text
MOVX C,<5*STRBSZ>-1 ;c := max byte count
SETZ D, ;Or terminate on null
SIN%
ERJMP .+1
IFE. C
MOVEI B,[ASCIZ/Pup too long/]
JRST PUPERX
ENDIF.
CALL RCVCH0 ;Check the termination
TRNA ;Mark ends the text
JSP B,RSPPER ;No mark, fail
HRLM B,MRKTYP ;Save it
TMOCLR ;No more time out
CAIE B,EOCMRK ;Last one EOC?
IFSKP.
CALL CLMARK ;Yes, clear the last mark
JSP B,RSPPER ;None, bomb out
CAIE B,EOCMRK ;Got one, better be EOC
JSP B,RSPPER ;No, bomb out
ENDIF.
MOVE C,MRKCOD ;c := reply code
MOVE B,MRKTYP ;b := end mark,,start mark
HRRZ A,B ;a := start mark
CALL PUPDBG ;Print text if debugging
CAIE A,YESMRK ;Yes mark?
RET ;No, fail return
RETSKP ;Success return
ENDSV.
; Here when time-out on reply wait. Returns error msg in STRBUF and
; dummy ending marks.
PUPTMO: DMOVE A,[POINT 7,STRBUF
[ASCIZ/Connection timed-out/]]
CALL MOVST0 ;Set up an error string
TMOCLR ;No more time out
SETOB B,C ;Set timeout code in return AC's
CALLRET PUPDBG ;Print text if debugging and return
; Here on random Pup protocol error
; JSP B,RSPPER
RSPPER: STKVAR <RSPEPC>
MOVEM B,RSPEPC ;Save error PC
DMOVE A,[POINT 7,STRBUF
[ASCIZ/Pup protocol error, PC=/]]
CALL MOVSTR ;Set up an error string
HRRZ B,RSPEPC ;Retrieve PC
MOVX C,^D8 ;Octal output
NOUT% ;Put PC in error reply
JFATAL
TMOCLR ;No more time out
SETZB B,C ;Response error, clear return ac's
; CALLRET PUPDBG ;Print text if debugging and return
; Routine to print Ethernet reply text in debug mode
; Entry: strbuf = adr of reply text
; b = end mark,,start mark
; c = reply code
; Call: CALL PUPDBG
; Return: +1 always, prints only if DEBUGP non-zero
PUPDBG: SKIPN DEBUGP ;Debugging network protocol?
RET ;No
SAVEAC <A,B,D>
HRROI A,STRBUF ;a := reply text
HLRZ D,B ;d := end mark
HRRZS B ;b := start mark
CETYPE < PUP: [%2O] %3O %1W [%4O]> ;CRLF and text
RET
; Fetch a character from the remote host.
; Entry: NETJFN = receive JFN
; Call: CALL RCVCH
; Return: +1, mark encountered. b = mark type
; +2, b = char received
RCVCH: HRRZ A,NETJFN ;a := receive JFN
BIN% ;b := next input char
IFNJE.
CAIE B,.CHNUL ;Null byte?
RETSKP ;No, got a char - return +2
ENDIF.
RCVCH0: CALL CHKMRK ;Check for mark state
IFSKP.
MOVEI B,.MORMK ;Read mark type
MTOPR%
ERJMP PUPJEX ;Can't do much with this
MOVE B,C ;b := mark type
RET ;Return +1
ENDIF.
ANDI B,17 ;Isolate port state
CAIE B,P%ABRT ;Abort?
IFSKP.
MOVEI B,.MORAB ;Yes, get the abort reason
HRROI D,STRBUF
MTOPR%
ERJMP PUPJEX ;Just in case
JRST PUPERY ;And close things out
ENDIF.
MOVX B,.CHNUL ;Just null char -- return it
RETSKP
; Routine to clear a mark state
; Entry: NETJFN = receive JFN
; Call: CALL CLMARK
; Return: +1, no mark set
; +2, mark cleared, b = type
CLMARK: CALL CHKMRK ;Check for mark state
RET ;None
TXZ B,1B4 ;Mark present, clear it
SDSTS% ;A Mark, clear it
MOVEI B,.MORMK ;Read mark type
MTOPR%
ERJMP PUPJEX ;Just in case
MOVE B,C ;b := mark type
RETSKP ;Return +2
; Routine to check for mark input state
; Entry: NETJFN = receive JFN
; Call: CALL CHKMRK
; Return: +1, no mark
; +2, mark present, b = status
CHKMRK: MOVE A,NETJFN ;a := receive JFN
SETZ C,
GDSTS% ;Check state of connection
IFXN. B,1B5 ;EOF?
MOVEI B,[ASCIZ/Pup connection EOF/]
CALLRET PUPERX ;Abort and close the connection
ENDIF.
TXNN B,1B4 ;Mark?
RET
RETSKP ;Yes, skip return
SUBTTL Special routines
;;; Send message in M to Special host in E
; B/ Host name to connect to
; C/ Host number to use
SPCSND: STKVAR <SPCPTR,SPCADR,<SPCLCL,^D13>,SPCHPT,DSTHPT>
MOVEM A,DSTHPT ;Save ultimate host pointer
MOVEM B,SPCPTR ;Save host pointer
MOVEM C,SPCADR ;And address
HRROI A,LCLNCN ;Local name for this network
SETO B, ;Output local host
CALL $SPCNS
FATAL (Can't get Special local host name)
HRROI A,SPCLCL ;Make absolute copy of local name string
HRROI B,LCLNCN
CALL OUTAHS
MOVE A,SPCPTR ;Get immediate destination
MOVE B,DSTHPT ;Get ultimate destination host pointer
CALL GENHDR ;Generate headers
HRROI A,STRBUF ;Output directory name
MOVE B,SPCADR ;From Special host (a.k.a. directory) number
DIRST%
ERJMP ADEADH ;Failed
MOVEI B,[ASCIZ/-MAIL./] ;Filename of outgoing mail
CALL MOVSTR
PUSH P,A ;Save string poiter
GTAD% ;Get system date/time
MOVE B,A ;Output it in octal
POP P,A
MOVX C,^D8
NOUT%
JFATAL
AOS B,NXTSEQ ;Get next unique number
MOVNS B ;With hyphen...output it too
NOUT%
JFATAL
HRROI B,[ASCIZ/.-1;P777700/] ;Next generation, protection 777700
CALL MOVST0
MOVX A,GJ%SHT ;Get a JFN on it...
HRROI B,STRBUF
GTJFN%
ERJMP ADEADH ;Failed completely
MOVEM A,NETJFN
MOVX B,<<FLD ^D7,OF%BSZ>!OF%WR>
OPENF%
IFJER.
MOVE A,NETJFN
RLJFN%
JWARN
CALLRET ADEADH
ENDIF.
SKIPN MSGRPT(M) ;Have a return path?
IFSKP.
MOVEI B,"@" ;Yes, must prepend local host as part
BOUT% ; of source route. Output an at
HRROI B,SPCLCL ;Local host name
SETZ C,
SOUT%
MOVE B,MSGRPT(M) ;Make pointer to return path
HRLI B,(<POINT 7,>)
ILDB B,B ;Get first character of return path
CAIE B,"@" ;Additional source routing specification seen?
SKIPA B,[":"] ;No, use colon to terminate source routing
MOVEI B,"," ;Else must use comma for continuation
BOUT% ;Output the character
MOVE B,MSGRPT(M) ;Now output return path
HRLI B,(<POINT 7,>)
SOUT%
ELSE.
HRROI A,STRBUF ;Output to recipient buffer
MOVE D,MSGSDR(M) ;D := addr of sender host entry block
HRRZ C,HSTRCP(D) ;C := adr of recipient entry block
MOVE B,RCPBPT(C) ;B,C := sender name ptr/-byte count
MOVN C,RCPCNT(C)
SOUT%
HRRZ B,HSTHST(D) ;B := sender host pointer
CAIN B,LCLNAM ;Is it our host?
MOVEI B,SPCLCL ;Yes, use canonical form
MOVEM B,SPCHPT ;Save host pointer
CAIN B,SPCLCL ;Is it me?
IFSKP.
MOVEI B,"%" ;Punctuate
IDPB B,A
MOVEI B,SPCLCL ;Set up local name
EXCH B,SPCHPT ;Restore host
HRROS B
SOUT%
ENDIF.
MOVE C,A ;Save termination
MOVE A,NETJFN ;Restore JFN
MOVE B,[POINT 7,STRBUF]
CALL QOTSTR ;Output it quoted
FATAL (Special net QOTSTR failed)
MOVEI B,"@" ;Punctuate
BOUT%
HRRO B,SPCHPT ;Restore host
SOUT% ;Output host name
ENDIF.
HRROI B,CRLF0 ;Now start recipient list
SOUT% ;Delimiting with first CRLF
DO.
CALL NXTRCP ;Get next recipient
EXIT. ;No, done with recipients
CALL RSTRCP ;Reset error flags from other tries
SETZM TMPBUF ;Clear reply string buffer
MOVE A,NETJFN ;Get back JFN
CALL OUTRCP ;Output recipient
SKIPN GTDBLK+.GTDRD ;Doing MX?
IFSKP.
MOVX B,"%" ;Yes, shove in relay poop
BOUT% ;Probably this should have been done better
HRRO B,FRNHST
CALL OUTAHS
ENDIF.
HRROI B,CRLF0 ;Newline
SETZ C,
SOUT%
LOOP.
ENDDO.
MOVX B,.CHFFD ;End of recipients
BOUT%
HRRO B,MSGNHD(M) ;Pointer to headers
HLRZ C,MSGNHD(M) ;Size of headers
MOVNS C
SOUT% ;Output headers
MOVE B,MSGTXT(M) ;Pointer/size of message body
MOVN C,MSGTCN(M)
SOUT% ;Output message body
CLOSF% ;Close queue file
JWARN <Error closing Special queue file>
RETSKP
ENDSV.
SUBTTL JSYS jacket routines
; Routine to close a net connection. If the connection has a data
; error, a second CLOSF% is done to abort the JFN.
; Entry: NETJFN/ net JFN
; Call: CALL $CLOSF
; Return: +1 always
$CLOSF: SAVEAC <A,B> ;Preserve these guys
STKVAR <CLZJFN> ;JFN to close
SKIPN A,NETJFN ;Have JFN?
RET ;No, just return
MOVEM A,CLZJFN ;Save the JFN to close
SETZM NETJFN ;And clear the cell
GTSTS% ;Get its status
ERJMP .+1 ;Ignore error
JXE B,GS%NAM,R ;This shouldn't happen, but check anyway
IFXE. B,GS%OPN ;JFN open?
RLJFN% ;This is easy - just flush the JFN
JWARN <Error releasing network JFN> ;Lost??
RET
ENDIF.
DO.
TMOSET(^D60,ENDLP.) ;Prevent hanging
CLOSF%
IFNJE.
TMOCLR ;Succeeded, clear timer and return
RET
ENDIF.
ENDDO.
TMOCLR
MOVE A,CLZJFN ;Try again
TXO A,CZ%ABT ;Abort it without waiting for anything
CLOSF%
JWARN <Error closing net connection>
RET
ENDSV.
; Versions of BOUT%, SOUT%, and SOUTR% which output to primary output if
;DEBUGP is set, to allow protocol debugging.
$BOUT: SKIPE DEBUGP ;If debugging, output to primary output too
CALL DBGBOU
JSP CX,$TIMER ;Put a timer on this if necessary
BOUT%
ERJMP R
RETSKP
$SOUT: SKIPE DEBUGP ;If debugging, output to primary output too
CALL DBGSOU
JSP CX,$TIMER ;Put a timer on this if necessary
SOUT%
ERJMP R
RETSKP
$SOUTR: SKIPE DEBUGP ;If debugging, output to primary output too
CALL DBGSOU
JSP CX,$TIMER ;Put a timer on this if necessary
SOUTR%
ERJMP R
RETSKP
$TIMER: SKIPGE INTOK ;Is there a timer set up already?
JRST (CX) ;Yes, use it then
TMOSET(MAXTMB,TIMOUT) ;Wait 5 minutes before giving up
CALL (CX) ;Do the code
TRNA ;+1 Return
AOS (P) ;+2 Return
TMOCLR ;Clear the timer
RET ;Return +1/+2
TIMOUT: TMOCLR ;Clear timeout
SAVEAC <A,B>
MOVX A,.FHSLF ;Set last error
MOVX B,TTMSX1 ;"Unable to send within timeout interval"
SETER%
ERJMP .+1
RET
DBGBOU: SAVEAC <A>
MOVX A,.PRIOU
BOUT%
RET
DBGSOU: SAVEAC <A,B,C,D>
MOVX A,.PRIOU
SOUT%
RET
SUBTTL General-purpose subroutines
;;;Move a string from B to A
MOVSTR: HRLI B,(<POINT 7,0>)
MOVST1::DO.
ILDB D,B
IFN. D
IDPB D,A
LOOP.
ENDIF.
ENDDO.
RET
;;;Move string and terminating null
MOVST0: HRLI B,(<POINT 7,0>)
MOVST2: SAVEAC <D>
DO.
ILDB D,B
IDPB D,A
JUMPN D,TOP.
ENDDO.
RET
;;; Make a copy of string in A, return address in B, count in C
CPYSTR::PUSH P,A ;Save address
HRLI A,(<POINT 7,0>)
SETZ C,
DO.
ILDB D,A
JUMPE D,ENDLP.
AOJA C,TOP.
ENDDO.
MOVEI A,5(C) ;Account for null and round wd cnt up
IDIVI A,5
CALL ALCBLK
FATAL <Memory exhausted>
HRL B,(P)
HRRZM B,(P)
ADDI A,(B)
BLT B,-1(A)
POP P,B
RET
SUBTTL Interrupt stuff
;;;Here to initialize the timer, called via JSP CX,SETTIM. Note that A,B,C
;;;are clobbered!
SETTIM: MOVE A,[.FHSLF,,.TIMEL] ;Tick the timer
MOVX B,<TMRTCK*^D1000> ;Every TMRTCK seconds
SETZ C, ;On channel 0
TIMER%
ERJMP .+1
JRST (CX)
;;;Here on timer interrupt
TIMINT: MOVEM 17,INTACS+17 ;Save ACs
MOVEI 17,INTACS
BLT 17,INTACS+16
AOSE TIMKIL ;If we weren't asked to kill the clock
JSP CX,SETTIM ;Reinitialize the timer
AOSE INTOK ;Should time out now?
IFSKP.
SKIPN A,TIMLOC ;Get time-out routine
FATAL <No time-out PC set>
MOVEM A,INTPC ;Set it
MOVE P,TIMRTP ;Reset stack ptr
ENDIF.
MOVSI 17,INTACS ;Restore ACs
BLT 17,17
DEBRK%
;;; Here on ^G interrupt
CTGINT: AOS CTGCNT
DEBRK%
SUBTTL IPCF handling
;Here to initialize for IPCF - we want to be known as [SYSTEM]MMAILR
IPCINI: SKIPE IPCFON ;Has IPCF been set up yet?
RET ;Yes, don't do it again
SETZM IPCNT ;Zero count of MSEND%s we've done
SETZM PIDGET+.IPCFS ;Indicate we want a fresh PID
DO.
MOVE A,IPCNT ;Get the count
CAIG A,5 ;Too many?
IFSKP.
WARN <Unable to send to <SYSTEM>INFO>
RET
ENDIF.
SETZ A, ;Assume we have a PID
SKIPN PIDGET+.IPCFS ;Do we?
MOVX A,IP%CPD ;No
MOVEM A,PIDGET+.IPCFL
SETZM PIDGET+.IPCFR ;Send to INFO
MOVEI A,.IPCFP+1 ;Length of packet
MOVEI B,PIDGET ;Packet address
MSEND%
IFJER.
AOS B,IPCNT ;Failed!
TXNN B,1 ;Warn only every other try
JWARN <Trying to send to INFO...>
SETZM PIDGET+.IPCFS ;Clear possible bad PID
MOVEI A,^D1000 ;Wait a while for things to settle
DISMS%
LOOP.
ENDIF.
AOS IPCNT ;Increment count
DO.
SETZB C+.IPCFL,C+.IPCFS ;No flags, any sender
MOVE C+.IPCFR,PIDGET+.IPCFS ;Get our PID
MOVE C+.IPCFP,[IPCFBL,,IPCFBF] ;Where to read into
MOVEI A,.IPCFP-.IPCFL+1 ;Get response from <SYSTEM>INFO
MOVEI B,C
MRECV%
IFJER.
JWARN <MRECV% from <SYSTEM>INFO failed>
RET
ENDIF.
LOAD D,IP%CFC,C+.IPCFL
CAIE D,.IPCCC ;From SYSTEM?
CAIN D,.IPCCF ;Or INFO?
CAIA
LOOP. ;No, toss it
ENDDO.
TXNE C+.IPCFL,IP%CFM ;Delivered?
LOOP. ;No, try again
ENDDO.
IFXN. C+.IPCFL,IP%CFE ;See if any errors
WARN <Error in message from <SYSTEM>INFO>
RET
ENDIF.
SETZM IPCFOK ;Disable IPCF interrupts
SETZM NOSLEP ;And sleeps
MOVEI A,.FHSLF ;Enable the channel
MOVX B,1B<IPCHAN>
AIC%
MOVEI C,.MUPIC ;Enable for IPCF interrupts
MOVE D,PIDGET+.IPCFS ;For our new PID
MOVEI E,IPCHAN ;On this channel
MOVEI A,E-C+1 ;Length of arg block
MOVEI B,C ;Location
MUTIL%
JFATAL <Could not enable IPCF interrupts>
SETOM IPCFON ;Note IPCF set up
RET
; Here when an IPCF packet is received
; Note that since we only get interrupted when the queue goes from empty
; to non-empty, we must ensure that the queue is empty before dismissing
; the interrupt! No JWARNs may be done here as we may be in a UUO when this
; happens
IPCINT: MOVEM 17,INTACS+17 ;Save ACs
MOVEI 17,INTACS
BLT 17,INTACS+16
DO.
JSP C,IPCHEK ;Check the queue
EXIT. ;Done, depart
MOVE A,IPCFBF+.IPCFL+1 ;Check flags
IFXN. A,IP%CFV ;Page request?
MOVX A,IP%CFB!IP%CFV ;Don't block and read a page
MOVEM A,IPCFBF+.IPCFL
SETZM IPCFBF+.IPCFS ;Any sender
MOVE A,PIDGET+.IPCFS ;Set up our PID
MOVEM A,IPCFBF+.IPCFR
MOVE A,[1000,,IPCPAG/1000] ;Read a page worth
MOVEM A,IPCFBF+.IPCFP
MOVX A,.IPCFP+1 ;Read the data
MOVEI B,IPCFBF
MRECV%
ERJMP .+1 ;MRECV% to read data page failed
LOOP.
ENDIF.
MOVX A,IP%CFB!IP%TTL ;Don't block and truncate
MOVEM A,IPCFMS+.IPCFL
SETZM IPCFMS+.IPCFS ;Any sender
MOVE A,PIDGET+.IPCFS ;Set up our PID
MOVEM A,IPCFMS+.IPCFR
MOVX A,.IPCFP+1 ;Now read the emssaage
MOVEI B,IPCFMS
MRECV%
ERJMP TOP. ;MRECV% to read IPCF message failed?
MOVE A,IPCFBF+.IPCI0 ;Get word 0 of user's request
CAME A,[SIXBIT/PICKUP/] ;Wakeup and reply?
IFSKP.
MOVX A,IP%CFO ;Yes, allow us to exceed send quota
MOVEM A,IPCFMS+.IPCFL
MOVE A,PIDGET+.IPCFS ;Get our PID
EXCH A,IPCFMS+.IPCFS ;From us
MOVEM A,IPCFMS+.IPCFR ;To him
SKIPL IPCFOK ;Were we sleeping?
SKIPA A,[SIXBIT/BUSY/] ;No, so say so
MOVE A,[SIXBIT/GOING/] ;Yes, tell him we're continuing
MOVEM A,IPCFBF+.IPCI0 ;Set the reply
MOVX A,.IPCFP+1 ;Send reply
MOVEI B,IPCFMS
MSEND%
ERJMP .+1 ;MSEND% to send reply failed
MOVE A,[SIXBIT/WAKEUP/] ;Fake a WAKEUP request
ENDIF.
CAME A,[SIXBIT/WAKEUP/] ;Just wakeup?
IFSKP.
SETOM NOSLEP ;Do not sleep next time around
AOSN IPCFOK ;Ok to interrupt?
AOS INTPC ;Yes, bump PC from DISMS%
ENDIF.
LOOP. ;And see if any more in queue
ENDDO.
MOVSI 17,INTACS ;Restore ACs
BLT 17,17
DEBRK% ;Dismiss interrupt
; Here to check for a packet, called by JSP C,IPCHEK
IPCHEK: MOVX A,.MUQRY ;Query function for MUTIL%
MOVEM A,IPCFBF
MOVE A,PIDGET+.IPCFS ;Query packets for our PID
MOVEM A,IPCFBF+1
MOVX A,.IPCFP+2 ;Get length
MOVEI B,IPCFBF ;Address
MUTIL%
ERJMP (C) ;MUTIL% failed -- no JWARN, may be interrupt
JRST 1(C) ;Got it, so win
; Here for wakeup interrupt to net fork
WAKTOP: MOVEI A,.FHSLF ;On self
MOVE B,[LEVTAB,,CHNTAB] ;With interrupt table
SIR% ;Set up interrupt system
EIR%
WAKINI: MOVEI A,.FHSLF ;If multiforking,
MOVX B,1B<WAKCHN> ;Need channel to wake up other forks
AIC% ;So activate it
RET
; Here for fork 1 to set up so fork 2 will be interrupted
WAKNET: SAVEAC <A,B> ;Don't mung registers
MOVX A,.FHSUP ;On the mother fork
MOVX B,1B<WAKCHN> ;With wakeup interrupt
IIC% ;Initiate interrupt condition
RET
WAKINT: MOVEM 17,INTACS+17 ;Save ACs
MOVEI 17,INTACS
BLT 17,INTACS+16
SKIPE FORKX ;Are we the top fork?
IFSKP.
MOVE A,FHTAB+NETFRK-1 ;Yes, get network daughter fork
MOVX B,1B<WAKCHN> ;And wakeup interrupt channel
IIC% ;Wake up the fork
ELSE.
SETOM NOSLEP ;Do not sleep next time around
AOSN IPCFOK ;Ok to interrupt?
AOS INTPC ;Yes, bump PC from DISMS%
ENDIF.
MOVSI 17,INTACS ;Restore ACs
BLT 17,17
DEBRK% ;Return from interrupt
SUBTTL UUO handler
; UUO enters here via JSR UUOH
UUOH0: AOSE INUUO ;Recursive call?
CALL CRASH ;No, crash
MOVEM 17,UUOACS+17 ;Save AC 17
MOVEI 17,UUOACS ;Save AC's 0-16
BLT 17,UUOACS+16
MOVE P,[IOWD NUPDL,UUOPDL] ;Set up local stack
PUSH P,UUOH ;Save the UUO PC for debugging
LDB A,[POINT 9,UUOLOC,8] ;a := opcode field
CAIL A,MXUUO ;UUO valid?
CALL CRASH ;No, die
CALL @UUOS(A) ;Dispatch to handler routine
SOS INUUO ;Reset the entry flag
POP P,UUOH ;Restore the UUO PC
MOVSI 17,UUOACS ;Restore ACs
BLT 17,17
JRSTF @UUOH ;Dismiss UUO
; UUO handler dispatch table
UUOS: CRASH ;UUO 0 is impossible
%TYPE
%ETYPE
%ERROR
MXUUO==.-UUOS ;Maximum UUO
%TYPE: SKIPN PRINTP
RET
CALL TYCRIF ;Check if we should do a CRLF
HRRO A,UUOLOC ;Get string
PSOUT%
RET
TYCRIF: SKIPE DAEMNP ;Daemon?
JRST DTYCRF ;Yes, different routine
MOVE A,UUOLOC ;Get instruction
TXNE A,<10,0> ;Wants CRLF all the time?
JRST CRLF ;Yes
TXNE A,<1,0> ;Wants fresh line?
JRST CRIF ;Yes
RET
DTYCRF: MOVE A,UUOLOC ;Get instruction
TXNN A,<11,0> ;Want a CRLF at any time?
RET ;No, continuation of previous message probably
TIMSMP: SAVEAC <A,B,C>
CALL CRLF1 ;Always CRLF to log file, RFPOS% unreliable
MOVEI A,.PRIOU ;Now timestamp output
SETO B,
SETZ C,
ODTIM%
ERJMP .+1
MOVX A,.CHSPC ;Space before text
PBOUT%
MOVX A,.FHSLF ;Get my primary JFN's
GPJFN%
AOJN B,R ;Don't write "MMailr (n)" if output to file
TMSG <MMailr (>
MOVE A,FORKX ;Output fork number
ADDI A,"0"
PBOUT%
TMSG <): >
RET
CRIF: SAVEAC <A,B>
MOVEI A,.PRIOU
RFPOS%
TXNE B,.RHALF ;If not at start of line,
CALL CRLF1 ;Type CRLF
RET
CRLF: SAVEAC <A>
CRLF1: HRROI A,CRLF0
PSOUT%
RET
CRLF0: ASCIZ/
/
%ERROR: SKIPN DAEMNP ;Different code if daemon
IFSKP.
MOVE B,UUOLOC ;Get instruction
IFXN. B,<<10,0>> ;Fatal error?
MOVX A,.FHSLF ;Be sure this gets printed
SETO B,
SPJFN%
SKIPN A,LOGJFN ;And close off log file if we can
IFSKP.
TXO A,CO%NRJ
CLOSF%
NOP
ENDIF.
SKIPN A,STAJFN ;Also nuke statistics file
ANSKP.
TXO A,CO%NRJ
CLOSF%
NOP
ENDIF.
CALL TIMSMP ;Timestamp output
ELSE.
CALL CRIF ;Get a fresh line
MOVE B,UUOLOC ;Get instruction
TXNE B,<10,0> ;Wants %?
SKIPA A,["?"] ;No
MOVEI A,"%"
PBOUT%
ENDIF.
MOVE B,UUOLOC
IFXN. B,.RHALF ;Any message to print?
CALL %ETYE0 ;Yes, print it out
MOVE B,UUOLOC ;And recover instruction
ENDIF.
IFXN. B,<<4,0>> ;Wants JSYS error message?
IFXN. B,.RHALF ;If a previous message, type delimiter
TMSG < - >
ENDIF.
MOVX A,.PRIOU
HRLOI B,.FHSLF ;This fork
SETZ C,
ERSTR%
ERJMP .+1
ERJMP .+1
MOVE B,UUOLOC ;See if primary message was given
IFXE. B,.RHALF
TMSG <, at > ;None, should give PC...
HRRZ T,UUOH ;Get PC of UUO caller
SUBI T,1
CALL SYMOUT
ENDIF.
ENDIF.
CALL CRLF ;Output CRLF
MOVE B,UUOLOC ;Get instruction
TXNE B,<10,0> ;Fatal error?
CALL CRASH
RET ;No, return to user
;;; Fatal errors
CRASH: MOVEM 17,FATACS+17 ;Save ACs at time of crash
MOVEI 17,FATACS
BLT 17,FATACS+16
MOVE 17,FATACS+17
SKIPE DAEMNP ;If not running as a daemon
IFSKP.
DO.
TMSG <?Fatal error - can't continue
>
HALTF% ;Just die
LOOP.
ENDDO.
ENDIF.
MOVX A,.FHSLF ;Be sure this gets printed
SETO B,
SPJFN%
SKIPN A,LOGJFN ;And close off log file if we can
IFSKP.
TXO A,CO%NRJ ;Don't flush yet to allow debug
CLOSF% ;Don't SETZM yet so dump has JFN
NOP
ENDIF.
SKIPN A,STAJFN ;Close statistics file
IFSKP.
TXO A,CO%NRJ ;Don't flush yet to allow debug
CLOSF% ;Don't SETZM yet so dump has JFN
NOP
ENDIF.
MOVX A,GJ%FOU!GJ%NEW!GJ%SHT
HRROI B,[ASCIZ/MAIL:MMAILR-CRASH-DUMP.EXE;P770000/]
GTJFN%
IFJER.
DO.
HALTF% ;Just die
TMSG <?Can't get crash dump file
>
LOOP.
ENDDO.
ENDIF.
MOVE B,A
CALL TIMSMP
TMSG <Fatal error - taking crash dump onto >
MOVX A,.PRIOU
SETZ C,
JFNS% ;Output name of the file
MOVE A,B
HRLI A,.FHSLF ;This fork
MOVE B,[777760,,20] ;Save all assigned nonzero memory
SAVE% ;Take the crash dump
IFJER.
TMSG < (failed)> ;Don't blow up if out of disk space
ENDIF.
RESET% ;Flush everything we were doing
TMSG < ...reloading in 5 minutes
>
SETOM TIMKIL ;Kill the clock
MOVE A,[5*^D60*^D1000] ;5 minutes
DISMS%
MOVX A,GJ%SHT!GJ%OLD
HRROI B,[ASCIZ/SYS:MMAILR.EXE/]
GTJFN%
IFJER.
MOVX A,GJ%SHT!GJ%OLD
HRROI B,[ASCIZ/SYSTEM:MMAILR.EXE/]
GTJFN%
IFJER.
DO.
TMSG <?Can't get MMAILR.EXE
>
HALTF% ;Just die
LOOP.
ENDDO.
ENDIF.
ENDIF.
HRRM A,RLDSLF ;Save JFN in reload routine
MOVSI P,RLDSLF ;Blt the reload rtn into acs
BLT P,P
SKIPN FORKX ;Top fork?
IFSKP.
HRRI %RLDFX,<FRKTAB-ENTVEC>-1 ;No, entry vector offset for daughter
ADD %RLDFX,FORKX ;Get fork index
ENDIF.
JRST %RLDSL
; Following is the ac routine used to reload ourselves
RLDSLF:
PHASE 0 ;Loc cntr := 0
.FHSLF,,0 ;0 GET arg
-1 ;1 PMAP% arg to clear memory
.FHSLF,,0 ;2 PMAP% arg to clear memory
0 ;3 PMAP% dummy access arg
1000 ;4 PMAP% cntr for all memory
%RLDSL:!PMAP% ;5 Entry to clear memory
ADDI B,1 ;6 Bump page ptr
SOJG D,%RLDSL ;7 PMAP% loop
MOVE A,F ;10 a := GET arg
GET% ;11
MOVEI A,.FHSLF ;12 a := our frk handle
CLZFF% ;13 Cleanup outstanding files
%RLDFX:!MOVEI B,0 ;14 Start at entry vec
SFRKV% ;15
HALTF% ;16 ???
0 ;17
DEPHASE
%FATL1: HALTF%
TMSG <?Can't continue
>
CALL CRASH
; 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 symbol in T.
SYMOUT: SETZB C,E ;No current program name or best symbol
MOVE D,116 ;Symbol table pointer
HLRO A,D
SUB D,A ;-Count,,ending address +1
SYMLUP: LDB A,[POINT 4,-2(D),3] ;Symbol type
JUMPE A,NXTSYM ;Program names are uninteresting
CAILE A,2 ;0=prog name, 1=global, 2=local
IFSKP.
MOVE A,-1(D) ;Value of the symbol
CAME A,T ;Exact match?
IFSKP.
MOVE E,D ;Yes, select it
JRST FNDSYM
ENDIF.
CAML A,T ;Smaller than value sought?
IFSKP.
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.
ENDIF.
NXTSYM: ADD D,[2000000-2] ;Add 2 in the left, sub 2 in the right
JUMPL D,SYMLUP ;Loop unless control count is exhausted
SKIPN D,E ;Did we find anything helpful?
JRST OCTSYM
;Found an entry that looks close. See if it really is and if so use it
FNDSYM: MOVE A,T ;Desired value
SUB A,-1(D) ;Less symbol's value = offset
CAIL A,200 ;Is offset small enough?
IFSKP.
MOVE D,E ;Yes, get the symbol's address
MOVE A,-2(D) ;Symbol name
TXZ A,<MASKB 0,3> ;Clear flags
CALL SQZTYO ;Print symbol name
MOVE B,T ;Get desired value
SUB B,-1(D) ;Less this symbol's value
JUMPE B,R ;If no offset, don't print "+0"
MOVEI A,"+" ;Add + to the output line
PBOUT%
ELSE.
OCTSYM: MOVE B,T ;Here if PC must be in octal
ENDIF.
MOVX A,.PRIOU ;And copy numeric offset to output
MOVEI C,^D8
NOUT%
ERJMP R
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
%ETYPE: SKIPN PRINTP
RET
CALL TYCRIF ;Type a CRLF maybe
%ETYE0: HRRZ N,UUOLOC
%ETYS0: HRLI N,(<POINT 7,0>) ;Get byte pointer to string
DO.
ILDB A,N ;Get char
IFN. A
CAIN A,"%" ;Escape code?
IFSKP.
PBOUT% ;No, just print it out
LOOP.
ENDIF.
SETZ O, ;Reset AC
DO.
ILDB A,N
CAIL A,"0" ;Is it part of addr spec?
CAILE A,"7"
IFSKP.
IMULI O,^D8 ;Yes, increment address
ADDI O,-"0"(A)
LOOP.
ENDIF.
ENDDO.
CAIG A,"Z" ;If within range of special codes
CAIGE A,"A"
IFSKP.
CALL @%ETYTB-"A"(A) ;Do code-dependent thing
ELSE.
CALL %ETYP0 ;Else output character as is
JUMPE A,ENDLP. ;If string terminated with "%" exit now
ENDIF.
LOOP.
ENDIF.
ENDDO.
RET
%ETYP0: PUSH P,A ;Here if function not defined, save character
MOVEI A,"%" ;Output leading %
PBOUT%
POP P,A ;Now output the losing character
PBOUT%
RET
%ETYTB: %ETYPA ;A - print time
%ETYPB ;B - print date
%ETYP0 ;C
%ETYPD ;D - print decimal
%ETYER ;E - error code
%ETYPF ;F - floating
%ETYP0 ;G
%ETYPH ;H - RH as octal
%ETYP0 ;I
%ETYPJ ;J - filename
REPEAT 4,<%ETYP0> ;K, L, M, N
%ETYPO ;O - octal
%ETYPP ;P - pluralizer
REPEAT 2,<%ETYP0> ;Q, R
%ETYPS ;S - string
%ETYPT ;T - date and time
%ETYPU ;U - user name
%ETYP0 ;V
%ETYPW ;W - string without "%" processing
REPEAT 3,<%ETYP0> ;X, Y, Z
%ETYPA: MOVX C,OT%NDA ;No day, just time
JRST %ETYB0
%ETYPT: TDZA C,C ;Both date and time
%ETYPB: MOVX C,OT%NTM ;No time, just day
%ETYB0: JUMPE O,.+2 ;If AC field spec'd
SKIPA B,UUOACS(O) ;Use it
SETO B, ;Else use now
MOVEI A,.PRIOU
ODTIM%
RET
%ETYPD: SKIPA C,[^D10] ;Decimal
%ETYPO: MOVEI C,^D8 ;Octal
MOVE B,UUOACS(O) ;Get data
%ETYO0: MOVEI A,.PRIOU
NOUT%
ERJMP .+1
RET
%ETYER: MOVEI A,.PRIOU
MOVSI B,.FHSLF ;This fork
HRR B,UUOACS(O) ;Get error code
SETZ C,
ERSTR%
ERJMP .+1
ERJMP .+1
RET
%ETYPF: MOVEI A,.PRIOU
MOVE B,UUOACS(O)
SETZ C,
FLOUT%
ERJMP .+1
RET
%ETYPH: MOVEI C,^D8
HRRZ B,UUOACS(O)
JRST %ETYO0
%ETYPJ: MOVEI A,.PRIOU
HRRZ B,UUOACS(O)
MOVE C,[001110,,1]
JFNS%
RET
%ETYPP: MOVEI A,"s"
MOVE B,UUOACS(O)
CAIE B,1
PBOUT% ;Make plural unless just one
RET
%ETYPS: PUSH P,N
SKIPE N,UUOACS(O)
CALL %ETYS0 ;Recursive call
CPOPNJ: POP P,N
RET
%ETYPU: MOVEI A,.PRIOU
MOVE B,UUOACS(O)
DIRST%
ERJMP .+1
RET
%ETYPW: MOVE A,UUOACS(O)
TXNN A,.LHALF
HRLI A,(<POINT 7,0>)
PSOUT%
RET
SUBTTL Utility Routines
;;;Helper routine for JSR SAVACS. MPP is necessary because some of the
;;;routines which use SAVACS are less than careful about making sure the
;;;stack context is the same as it was right after the JSR SAVACS call (e.g.
;;;some error returns fail to pop saved stuff on the stack). These should
;;;eventually be identified and fixed, then MPP can be flushed.
ACBASE==17 ;Base where AC0 resides on stack
;Reference saved AC's with AC-ACBASE(P)
SAVAC0: PUSH P,MPP ;Save former stack context save
ADJSP P,ACBASE ;Create room on the stack for our ACs
MOVEM ACBASE-1,(P) ;Save AC16 on stack
MOVEI ACBASE-1,-<ACBASE-1>(P) ;AC0 to lowest save area location
BLT ACBASE-1,-1(P) ;Save AC0-AC15
MOVE ACBASE-1,(P) ;Retrieve AC16
CALL [ MOVEM P,MPP ;Save current stack context
JRST @SAVACS] ;Call invoking routine
JRST SAVAR0 ;+0
JRST SAVAR1 ;+1
JRST SAVAR2 ;+2
JRST SAVAR3 ;+3
JRST SAVAR4 ;+4
JRST SAVAR5 ;+5
SAVAR6: AOS -<ACBASE+1>(P) ;+6, hopefully as hairy as we'll ever get!
SAVAR5: AOS -<ACBASE+1>(P) ;+5
SAVAR4: AOS -<ACBASE+1>(P) ;+4
SAVAR3: AOS -<ACBASE+1>(P) ;+3
SAVAR2: AOS -<ACBASE+1>(P) ;+2
SAVAR1: AOS -<ACBASE+1>(P) ;+1
SAVAR0: MOVSI ACBASE-1,-<ACBASE-1>(P) ;AC0 from lowest save area location
BLT ACBASE-1,ACBASE-1 ;Restore AC0-AC15
ADJSP P,-ACBASE ;Garbage collect stack location
POP P,MPP ;Restore former stack context save
RET ;Return to caller
; "Super" SFUST emulation.
; Entry: a = JFN
; b = ptr to author string
; Call: CALL .SFUST
; Return: +1, always
.SFUST: STKVAR <AUTJFN>
MOVEM A,AUTJFN ;Save JFN
MOVX A,.CHCNV ;Quote character
TXC B,.LHALF ;See if LH = -1
TXCN B,.LHALF
HRLI B,(<POINT 7,0>) ;Yes, set up as byte pointer
MOVE D,[POINT 7,FRMMSG] ;A convenient place to write it into
DO.
ILDB C,B
CAIE C,.CHCNV ;Quote?
IFSKP.
IDPB C,D ;Yes, next character is quoted already
ILDB C,B
IDPB C,D
LOOP.
ENDIF.
CAIL C,"a" ;Character lowercase?
CAILE C,"z"
CAIA
IDPB A,D ;Yes, quote it
IDPB C,D
JUMPN C,TOP.
ENDDO.
HRROI A,FRMMSG ;Remove relative domain
CALL $RMREL
MOVE A,AUTJFN ;Restore JFN
HRLI A,.SFLWR ;Set its writer
HRROI B,FRMMSG
SFUST%
ERJMP .+1
RET
ENDSV.
; Routine to fetch the write date/time of a file
; Entry: a = file JFN
; Call: CALL .GFWDT
; Return: +1, b = file write date/time
.GFWDT: SAVEAC <C>
MOVEI B,B ;Answer into b
MOVX C,<.RSWRT+1> ;Only the write date/time
RFTAD%
RET
; Routine to compare two strings ignoring case differences
; Entry: a,b = ptrs to strings
; Call: CALL STRCMP
; Return: +1, match failed
; +2, strings match
STRCMP: SAVEAC <C,D>
DO.
ILDB C,A ;c := next char from a
CAIL C,"a" ;Raise it if necessary
CAILE C,"z"
CAIA
SUBI C,"a"-"A"
ILDB D,B ;d := next char from b
CAIL D,"a" ;Raise it if necessary
CAILE D,"z"
CAIA
SUBI D,"a"-"A"
CAME C,D ;Same?
IFSKP.
JUMPN C,TOP. ;If not end of strings, continue
RETSKP ;Match, return +2
ENDIF.
ENDDO.
RET
; Routine to compare two strings ignoring case differences
; Entry: a = ptr to ASCIZ string
; b/c = ptr/len of string
; Call: CALL STRCAL
; Return: +1, match failed
; +2, strings match
STRCAL: ILDB T,A ;t,tt := next chars raised
JUMPE T,R ;If ended here, no match
CAIL T,"a"
CAILE T,"z"
CAIA
SUBI T,"a"-"A"
ILDB TT,B
CAIL TT,"a"
CAILE TT,"z"
CAIA
SUBI TT,"a"-"A"
CAME T,TT ;Match?
RET ;No
SOJG C,STRCAL ;Check if more input
ILDB T,A ;No more in string 2, 1st ended?
JUMPE T,RSKP ;If so, have a match
RET ;Otherwise, no match
; Routine to compare two strings ignoring case differences
; Entry: a/b = ptr/len of string 1
; c/d = ptr/len of string 2
; Call: CALL STRCLL
; Return: +1, match failed
; +2, strings match
STRCLL: CAME B,D ;Strings same length?
RET ;No, can't match
JUMPE B,RSKP ;Same length, if null, match already
DO.
ILDB T,A ;t,tt := next chars raised
CAIL T,"a"
CAILE T,"z"
CAIA
SUBI T,"a"-"A"
ILDB TT,C
CAIL TT,"a"
CAILE TT,"z"
CAIA
SUBI TT,"a"-"A"
CAME T,TT ;Match?
RET ;No
SOJG B,TOP. ;Check if more input
ENDDO.
RETSKP ;Good match
...LIT: XLIST
LIT
LIST
END <ENTVCL,,ENTVEC> ;Set up entry vector