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, ;Data on page 1 IFNDEF CODORG, ;Code on page 10 IFNDEF PAGORG, ;Paged data on page 50 IFNDEF FREORG, ;Free storage starts at page 100 IFNDEF NTDAYS, ;Default sender status period, 1 day IFNDEF DEDAYS, ;Default dead letter period, 3 days IFNDEF MAXTMT,> ;Daemon max time to transmit whole message IFNDEF MAXTMC,> ;Max time for Daemon to transmit one copy IFNDEF MAXTMB,> ;Max time to transmit 1000 chars IFNDEF INTRXM, ;Number of minutes between retransmit scans IFNDEF INTSCN, ;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,[-] ;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 , IFNB ,> 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 , IFNB , >;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== ;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+ MEMEND==.-1 ;End of memory initialized at startup PIDGET: IP%CPD ;Create a PID 0 ;Where the PID goes 0 ;For 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 ,, ; 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!!!! 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 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 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 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 ; 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 MOVX A,^D5000 ;Wait 5 seconds DISMS% LOOP. ENDIF. MOVEM A,LOGJFN MOVX B,<!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 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 MOVX A,^D5000 ;Wait 5 seconds DISMS% LOOP. ENDIF. MOVEM A,STAJFN MOVX B,<!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 LOOP. ENDIF. ENDDO. ENDIF. ; falls through ; drops in CITYPE 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 ;Log this MOVEI A,.FHSLF ;Now fake an IPCF delivery MOVX B,1B 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 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 ENDIF. ENDIF. MOVX A,.FHSLF ;Restore primaries SETO B, SPJFN% SKIPN A,LOGJFN ;Close log file IFSKP. CLOSF% JFATAL SETZM LOGJFN ENDIF. SKIPN A,STAJFN ;Close statistics file IFSKP. CLOSF% JFATAL 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 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 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 HRRZ A,DODJFN TXO A,DF%NRJ DELF% JWARN 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, ;Do FLAGS page PMAP% HRRI B, ;Do MMAILBOX buffer page MOVX C,PM%CNT!2 ;Unmap both temp pages PMAP% HRRI B, 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 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 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== FRETAI== ALCHDR== ALCTAI== ;;; 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 ;+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 ;+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 ;+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 ;+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 ;;;*** 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 STKVAR ,> HRROI A,HSTTMP ;Make a copy of the host name MOVX C,5* ;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,() 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,() 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 > 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 % 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 STKVAR > 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 STKVAR > 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* ;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,-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* ;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 MOVEI A,HSTTBL TBLUK% TXNE B,TL%NOM!TL%AMB FATAL 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 HRRO B,B CALL HSTPRM ;Mark it permanent RETSKP ; Clear the table of all temporary entries. ; Call: CALL HSTCLR ; Returns: +1 always HSTCLR: SAVEAC 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 MOVEI A,HSTTBL ;Look this one up HRROS B ;Make sure byte pointer TBLUK% TXNE B,TL%NOM!TL%AMB ;Paranoia FATAL 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 MOVEI A,HSTTBL HRRO B,FRNHST TBLUK% ;Look it up TXNE B,TL%NOM!TL%AMB FATAL 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,() 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 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 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,() 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 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. 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 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 CALL MOVSTR MOVEI B,CRLF0 CALL MOVSTR MOVEI B,.CHFFD ;And finish with ^L 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 '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 =: 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,() ;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 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 . 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 := 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,() SKIPGE C SOUT% HRROI B,[ASCIZ/ ------- /] SETZ C, SOUT% CLOSF% JFATAL 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 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 ;; 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 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 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 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 MOVEI A,^D5000 ;Wait 5 seconds DISMS% LOOP. ENDIF. ENDDO. MOVE B,A POP P,A CALL RNMFIL ;Rename the file IFNSK. JWARN 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 <,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 MOVEI A,^D5000 ;Wait 5 seconds DISMS% LOOP. ENDIF. MOVEM A,TMPJFN ;Save the JFN MOVX B,<!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 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 ,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 MOVEI O,(B) MOVEM O,MSGNHD(M) ENDIF. HRLI O,() 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 '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,() ;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 ;Don't clobber invoker's context STKVAR 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,() 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,() 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 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 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 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 STKVAR HRLI A,() 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 STKVAR 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 STKVAR 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 STKVAR 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 STKVAR 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 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 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 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 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. ;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. 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 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 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 STKVAR > MOVEM A,HSTPTR ;Save output designator MOVEI A,HSTTMP ;Get copy of host name in HSTTMP HRLI A,() HRLI B,() 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 > MOVEM A,HSTPTR ;Save output designator MOVEI A,HSTTMP ;Get copy of host name in HSTTMP HRLI A,() CALL MOVST0 HRROI A,HSTTMP ;Remove relative domains CALL $RMREL MOVEI A,HSTTMP ;B := host in absolute form HRLI A,() 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 ,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 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,() 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,() 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 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,() ;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 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 "." sequence within buffer CAILE D,2(C) ;Possible at all for "." 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 ? LOOP. ;No, continue scan MOVE T,B ;Saw , 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 . 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 ;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 ;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 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 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 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 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 ,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: 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,<!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: " 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, ;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 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 MOVE A,LCFJFN HRLI A,.FBBYV ;Make sure byte size is correct MOVX B,FB%BSZ ;Set byte size MOVX C, ;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 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 > 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== ;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 ;Save calling args STKVAR 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,, ;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,, PM%CNT+2] PMAP% ERJMP .+1 HRRI B, 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 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 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,() 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 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 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 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 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 ;+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 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 ENDIF. MOVEI A,^D5000 ;Wait 5 seconds DISMS% JRST REMLRQ ;Try again ENDIF. MOVEM A,REQJFN ;Save the JFN MOVX B,<!OF%WR> OPENF% IFJER. CAIN A,OPNX2 ;Somebody's DELDF% screwed us? (monitor bug) IFSKP. MOVE B,REQJFN ;Get JFN for message JWARN 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 STKVAR 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 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+_6+ ;;;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,<!!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 ,> 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:) 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,() 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:" 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 STKVAR 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 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 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 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 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 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,() 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, 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 ,> 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 ;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,() ;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. ;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 TXC A,.LHALF ;Is str pnt LH -1? TXCN A,.LHALF HRLI A,() ;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 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,() ;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 "" 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 ? LOOP. ;No, continue scan ENDDO. ;End scan through message for . 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 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 "" 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 ? LOOP. ;No, continue scan ENDDO. ;End scan through message for 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 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== ;Opcode $CPKNB== ;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 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,() 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,<!!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 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:userdate SKIPN D,MSGSDR(M) ;d := adr of sender host entry block FATAL 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,() 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 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. ;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 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 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==:/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 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 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,<!!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 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 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 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 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 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 ,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,<!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,() 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,() 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 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 ;Preserve these guys STKVAR ;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 ;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 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 MOVX A,.FHSLF ;Set last error MOVX B,TTMSX1 ;"Unable to send within timeout interval" SETER% ERJMP .+1 RET DBGBOU: SAVEAC MOVX A,.PRIOU BOUT% RET DBGSOU: SAVEAC MOVX A,.PRIOU SOUT% RET SUBTTL General-purpose subroutines ;;;Move a string from B to A MOVSTR: HRLI B,() MOVST1::DO. ILDB D,B IFN. D IDPB D,A LOOP. ENDIF. ENDDO. RET ;;;Move string and terminating null MOVST0: HRLI B,() MOVST2: SAVEAC 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,() 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 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, ;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 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 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 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 INFO MOVEI B,C MRECV% IFJER. JWARN 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 INFO> RET ENDIF. SETZM IPCFOK ;Disable IPCF interrupts SETZM NOSLEP ;And sleeps MOVEI A,.FHSLF ;Enable the channel MOVX B,1B 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 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 ;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 ;Don't mung registers MOVX A,.FHSUP ;On the mother fork MOVX B,1B ;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 ;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 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 MOVE A,FORKX ;Output fork number ADDI A,"0" PBOUT% TMSG <): > RET CRIF: SAVEAC MOVEI A,.PRIOU RFPOS% TXNE B,.RHALF ;If not at start of line, CALL CRLF1 ;Type CRLF RET CRLF: SAVEAC 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 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 LOOP. ENDDO. ENDIF. MOVE B,A CALL TIMSMP TMSG 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 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,-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 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, ;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,() ;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,() 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,-(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 -(P) ;+6, hopefully as hairy as we'll ever get! SAVAR5: AOS -(P) ;+5 SAVAR4: AOS -(P) ;+4 SAVAR3: AOS -(P) ;+3 SAVAR2: AOS -(P) ;+2 SAVAR1: AOS -(P) ;+1 SAVAR0: MOVSI 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 MOVEM A,AUTJFN ;Save JFN MOVX A,.CHCNV ;Quote character TXC B,.LHALF ;See if LH = -1 TXCN B,.LHALF HRLI B,() ;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 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 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 ;Set up entry vector