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==^D530                   ;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==^D<15*60>> ;Daemon max time to transmit whole message
IFNDEF MAXTMC,<MAXTMC==^D<15*60>> ;Max time for Daemon to transmit one copy
IFNDEF MAXTMB,<MAXTMB==^D<2*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
RLYPGS==:2
DEFPAG RLYTBL,RLYPGS            ;TBLUK table for host/nicknames

       .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)
       MOVNS 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 - %3D 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
       MOVNS 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>
         CALLRET $GTPRO        ;Now do the normal $GTPRO
       ENDIF.
       CALL $GTPRO             ;Get address for this relay
       IFNSK.
         MOVE B,$UKHST         ;Say we don't know which host
         MOVEI C,[[ASCIZ/TCP/],,INTSND] ;Fake that it's on TCP
       ENDIF.
       RETSKP

       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!!
       SETZM GTDBLK            ;Init GTDOM% block
       MOVE A,[GTDBLK,,GTDBLK+1]
       BLT A,GTDBLK+GTDLEN
       MOVX A,GTDLEN           ;Set up length of argument block
       MOVEM A,GTDBLK+.GTDLN
       MOVX A,<RLYBFL*5>-1     ;Length of relay buffer
       MOVEM A,GTDBLK+.GTDBC   ;Save relay buffer length
       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
       MOVNS 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%
       MOVE B,MSGHDR(M)        ;Finish off file
       MOVN C,MSGHCN(M)
       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
       MOVE B,DCNNAM           ;Pick up our remote host name again
       HRLI B,(<POINT 7,>)
       DO.
         ILDB C,B              ;Copy node name part only
         IFN. C
           CAIN C,"."
         ANSKP.
           IDPB C,A
           LOOP.
         ENDIF.
       ENDDO.
       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,HSTADR>
       MOVEM A,DSTHPT          ;Save ultimate host
       MOVEM B,HSTPTR          ;Save host pointer
       MOVEM C,HSTADR          ;Save host address
       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,HSTADR       ;Need address 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,HSTADR       ;Host address
           MOVX C,^D8          ;Add it in octal
           NOUT%
            NOP
           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 address
       MOVX C,^D8
       NOUT%
        NOP
       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
         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/#0+Misc-Services/] ;Misc-Services 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/#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