TITLE MAPSER TOPS-20 Interactive Mail Access Protocol server SUBTTL Written by Mark Crispin ; Version components MAPWHO==0 ; who last edited MAPSER (0=developers) MAPMAJ==7 ; MAPSER's release version (matches monitor's) MAPMIN==1 ; MAPSER's minor version MAPEDT==^D363 ; MAPSER's edit version SEARCH MACSYM,MONSYM ; system definitions IFNDEF OT%822,OT%822==:1B35 ; in case old monitor SALL ; suppress macro expansions .DIRECTIVE FLBLST ; sane listings for ASCIZ, etc. .TEXT "/NOINITIAL" ; suppress loading of JOBDAT .TEXT "MAPSER/SAVE" ; save as MAPSER.EXE .TEXT "/SYMSEG:PSECT:CODE" ; put symbol table and patch area in CODE .TEXT "/REDIRECT:CODE" ; put MACREL in CODE .TEXT "/PVBLOCK:PSECT:PDV" ; put PDV's in PDV .REQUIRE SYS:MACREL ; MACSYM support routines .REQUIRE SYS:HSTNAM ; host name support routines ; MAPSER is the server to access electronic mail from another system via ; a network. It implements the server half of IMAP2 (Interactive Mail Access ; Protocol 2), the electronic mail access protocol defined by Mark Crispin in ; RFC 1176, and documented online on the Internet as: ; ftp://ftp.ietf.org/rfc/rfc1176.txt ; ; While nominally MAPSER will be used layered on top of the DoD transport ; protocols (TCP/IP) in the Internet environment, it has been designed so ; that this is not necessary. All I/O is done via primary I/O, and the ; Internet system call dependencies have been kept to a minimum so that the ; server can essentially support any network. ; ; MAPSER runs on TOPS-20 release 6.1 and later monitors on model B CPU's ; only. SUBTTL Definitions IFNDEF PDVORG, ; PDV's on page 1001 IFNDEF CODORG, ; code on page 1002 IFNDEF DATORG, ; data on page 1030 IFNDEF PRVSEC, ; first of two private data sections IFNDEF MBXSEC, ; mailbox section IFNDEF MBXSCN, ; number of mailbox buffer sections IFNDEF TIMOCT,> ; number of 5-second ticks before autologout IFNDEF LOGMAX, ; maximum number of login tries IFNDEF TXTLEN, ; length of a text line IFNDEF ARGLEN, ; length of a string argument IFNDEF HSTNML, ; length of a host name IFNDEF UXPAG, ; page number of date vector in index file UXADR==UXPAG*1000 ; address of date vector MAPVER==!!!VI%DEC! ; Routines invoked externally EXTERN $GTLCL,$RMREL ; AC definitions F==:0 ; flags A=:1 ; JSYS, temporary ACs B=:2 C=:3 D=:4 CX=:16 ; scratch P=:17 ; stack pointer ; Flags MSKSTR F%LOG,F,1B0 ; logged in MSKSTR F%REE,F,1B1 ; reenter MSKSTR F%NVT,F,1B2 ; on a network terminal, must log out when done MSKSTR F%EOL,F,1B3 ; EOL seen MSKSTR F%ELP,F,1B4 ; buffer began with EOL MSKSTR F%RON,F,1B5 ; read-only file MSKSTR F%NCL,F,1B6 ; suppress close parenthesis MSKSTR F%BBD,F,1B7 ; BBOARD vs. SELECT comand ; Substitute TMSG DEFINE TMSG (STRING) < HRROI A,[ASCIZ ~STRING~] PSOUT% >;DEFINE TMSG DEFINE TAGMSG (STRING) < CALL DMPTAG TMSG >;DEFINE TAGMSG ; Here's a macro that really should be in MACSYM! DEFINE ANNJE. <..TAGF (ERJMP,)> ; Fatal assembly error macro DEFINE .FATAL (MESSAGE) < PASS2 PRINTX ?'MESSAGE END >;DEFINE .FATAL .CHLPR==:"(" ; work around various macro lossages .CHRPR==:")" .CHLAB==:"<" .CHRAB==:">" SUBTTL Impure storage .PSECT DATA,DATORG ; enter data area WINDOW: BLOCK 2000 ; 2 page window for mapping flags WINPAG==WINDOW/1000 ; first window page INDEX: BLOCK 1000 ; window for mapping index file IDXPAG==INDEX/1000 SEQLSN==1000 SEQLST: BLOCK SEQLSN ; message sequence list MAXMGS==<.-SEQLST>*^D36 ; maximum number of messages FATACS: BLOCK 20 ; save of fatal AC's PDL: BLOCK ; stack FRKS: BLOCK ; readin area for GFRKS% CMDBUF: BLOCK +1 ; command buffer CMDCNT: BLOCK 1 ; free characters in command buffer TAGCNT: BLOCK 1 ; count of tag character in command IN2ACS: BLOCK 3 ; save area for ACs A-C, level 2 LEV1PC: BLOCK 2 ; PSI level 1 PC LEV2PC: BLOCK 2 ; PSI level 2 PC LEV3PC: BLOCK 2 ; PSI level 3 PC TIMOUT: BLOCK 1 ; timeout count LOGCNT: BLOCK 1 ; login failure count ATOM: BLOCK 1 ; atomic argument for search FSFREE: BLOCK 1 ; first free storage free location INICBG==. ; first location cleared at once-only init MBXJFN: BLOCK 1 ; JFN on currently SELECTed mailbox MBXBSZ: BLOCK 1 ; size of mailbox in bytes MBXMGS: BLOCK 1 ; number of messages in mailbox MBXNMS: BLOCK 1 ; number of new messages in mailbox MBXRDT: BLOCK 1 ; last reference of mailbox IDXJFN: BLOCK 1 ; index JFN on currently SELECTed mailbox IDXADR: BLOCK 1 ; address within index LGUSRN: BLOCK 1 ; login user number LGDIRN: BLOCK 1 ; login user directory LGUSRS: BLOCK 10 ; login user string MYUSRN: BLOCK 1 ; my user number ; Following two lines must be in this order MYJOBN: BLOCK 1 ; my job number MYTTYN: BLOCK 1 ; my TTY number ; end of critical order data REQID=='MM' ; request ID for ENQ%'ing ENQBLS==1 ; number of ENQ% blocks ENQBLL==ENQBLS*<.ENQMS+1> ; length of ENQ% block ENQBLK: BLOCK ENQBLL ; block for ENQ%'ing LCLHST: BLOCK +1 ; local host name NFLAGS==^D36 ; number of flags NFLINI==^D6 ; number of initial flags NKYFLG==NFLAGS-NFLINI ; number of keyword flags FLGTAB: BLOCK NFLAGS ; table of flag strings indexed by flag number FLGBUF: BLOCK +1 ; buffer for keyword flags INICEN==.-1 ; last location cleared at once-only init ; Following data block must be the last in this PSECT MSG1:! MSGIPT: BLOCK 1 ; pointer to internal header for message #1 MSGPTR: BLOCK 1 ; pointer for message #1 MSGTAD: BLOCK 1 ; date/time for message #1 MSGSIZ: BLOCK 1 ; length in bytes of message #1 MSGHSZ: BLOCK 1 ; length in bytes of header of message #1 MSGFLG: BLOCK 1 ; flags for message #1 MSGENV: BLOCK 1 ; pointer to envelope for message MSGLEN==.-MSG1 ; length of a message data block BLOCK ; space for many many messages .ENDPS .PSECT BUFSEC, ARGBUF: BLOCK ; argument buffer WRKBUF: BLOCK ; work buffer OUTBFR: BLOCK <1000000-> ; output buffer .ENDPS .PSECT FREE,<,,0> BLOCK 777777 ; free storage .ENDPS .PSECT MBXBUF, BLOCK 1 ; mailbox buffer .ENDPS SUBTTL Start of program .PSECT CODE,CODORG ; pure code MAPSER: TDZA F,F ; clear flags MAPREE: MOVX F,F%REE RESET% ; flush all I/O MOVE P,[IOWD PDLLEN,PDL] ; init stack context SETZM INICBG ; clear once-only area MOVE A,[INICBG,,INICBG+1] BLT A,INICEN MOVE A,[FREE] ; initialize free storage pointer MOVEM A,FSFREE MOVNI A,TIMOCT ; reset timeout count MOVEM A,TIMOUT MOVNI A,LOGMAX ; reset logout count MOVEM A,LOGCNT MOVE A,[FLGINI,,FLGTAB+NKYFLG] ; copy initial flags BLT A,FLGTAB+NKYFLG+NFLINI-1 SETZ A, ; create private section MOVE B,[.FHSLF,,PRVSEC] ; this process,,our private sections MOVX C,SM%RD!SM%WR!2 ; read/write access SMAP% ERCAL FATAL CALL SETPSI ; set up PSIs ; Get host info HRROI A,LCLHST ; get local host name CALL $GTLCL IFNSK. TMSG <* BYE Unable to get local host name> JRST IMPERR ENDIF. HRROI A,LCLHST ; remove relative domain from name we got CALL $RMREL ; See if top-level fork, and if so assume we're a network server on an NVT. ; Note that all I/O is done via primary I/O. This allows several ways we can ; be set up, e.g.: ; . traditional CRJOB% style running as a job on an NVT ; . on a physical terminal, as in a "TTY network" environment ; . with primary I/O remapped to the network JFN's GJINF% ; get job info MOVEM A,MYUSRN ; save my user number DMOVEM C,MYJOBN ; save job number/TTY number for later use IFGE. D ; can be NVT server only if attached MOVX A,.FHSLF ; see what my primary I/O looks like. If GPJFN% ; AC2 isn't -1 (.CTTRM,,.CTTRM), then we ..TAGF (,) ; can assume setup process init'd TTY MOVX A,.FHTOP ; top fork SETZ B, ; no handles or status MOVE C,[-FKSLEN,,FRKS] ; fork structure area GFRKS% ; look at fork structure ERJMP .+1 ; ignore error (probably GFKSX1) HRRZ A,FRKS+1 ; get the top fork's handle CAIE A,.FHSLF ; same as me? IFSKP. MOVX A,.PRIIN ; set terminal type to ideal MOVX B,.TTIDL STTYP% MOVE B,[TT%MFF!TT%TAB!TT%LCA!TT%WKF!TT%WKN!TT%WKP!TT%WKA!!] SFMOD% ; has formfeed, tab, lowercase, all wakeup, STPAR% ; no translate ASCII, line half-duplex DMOVE B,[BYTE (2)2,2,2,0,2,2,2,2,2,2,2,2,2,2,2,2,2,2 BYTE (2)2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2] SFCOC% ; disable all echoing on controls MOVX A,TL%CRO!TL%COR!TL%SAB!.RHALF ; break and refuse links MOVX B,.RHALF TLINK% ERCAL FATAL MOVX A,.PRIIN ; refuse system messages MOVX B,.MOSNT MOVX C,.MOSMN MTOPR% ERCAL FATAL MOVE A,[SIXBIT/MAPSER/] ; set our name SETNM% MOVX A,.PRIIN ; clear possible crud in our input buffer CFIBF% ; from an earlier connection ERJMP .+1 TQO F%NVT ; flag an NVT server ENDIF. ENDIF. ; Output banner TMSG <* OK [CAPABILITY IMAP2] > HRROI A,LCLHST ; output host name PSOUT% TMSG < IMAP2 > MOVX A,.PRIOU ; set up for primary output LOAD B,VI%MAJ,EVEC+2 ; get major version MOVX C,^D8 ; octal output for all version components NOUT% ERCAL FATAL LOAD B,VI%MIN,EVEC+2 ; get minor version IFN. B ; ignore if no minor version MOVX A,"." ; output delimiting dot PBOUT% MOVX A,.PRIOU ; now output the minor version NOUT% ERCAL FATAL ENDIF. LOAD B,VI%EDN,EVEC+2 ; get edit version IFN. B ; ignore if no edit version MOVX A,.CHLPR ; edit delimiter PBOUT% TMNE VI%DEC,EVEC+2 ; decimal version? MOVX C,^D10 ; yes, use decimal radix MOVX A,.PRIOU ; now output the edit version NOUT% ERCAL FATAL MOVX A,.CHRPR ; edit close delimiter PBOUT% ENDIF. LOAD B,VI%WHO,EVEC+2 ; get who last edited IFN. B ; ignore if last edited at DEC MOVX A,"-" ; output delimiting hyphen PBOUT% MOVX A,.PRIOU ; now output the who version NOUT% ERCAL FATAL ENDIF. TMSG < at > MOVX A,.PRIOU ; output date/time SETO B, ; time now MOVX C,OT%DAY!OT%SPA!OT%TMZ!OT%SCL!OT%822 ; standard date/time ODTIM% ERCAL FATAL SUBTTL Command loop DO. MOVE P,[IOWD PDLLEN,PDL] ; re-init stack context CALL CRLF ; terminate reply with CRLF MOVNI A,TIMOCT ; reset timeout count MOVEM A,TIMOUT CALL QCHECK ; do a quick check NOP SETZM CMDBUF ; clear out old crud in CMDBUF MOVE A,[CMDBUF,,CMDBUF+1] BLT A,CMDBUF+ HRROI B,CMDBUF ; pointer to command buffer MOVX C,TXTLEN-1 ; up to this many characters CALL GETCMD ; get command LOOP. ; error MOVE D,[POINT 7,CMDBUF] SETZM TAGCNT ; init tag count DO. ; search for end of tag AOS TAGCNT ; bump tag count ILDB A,D CAIE A,.CHSPC JUMPN A,TOP. ENDDO. IFE. A TMSG <* BAD Missing tag: > CALL DMPCOM LOOP. ENDIF. MOVSI C,-CMDTBL ; length of command table DO. HLRO A,CMDTAB(C) ; point to command string MOVE B,D ; point to start of command STCMP% ; compare strings IFN. A ; found it? IFXN. A,SC%SUB ; if subset ILDB A,B ; get delimiting byte CAIN A,.CHSPC ; was it a space? EXIT. ; won, argument forthcoming ENDIF. AOBJN C,TOP. ; try next command ENDIF. ENDDO. HRRO C,CMDTAB(C) ; get routine address CALL (C) ; dispatch to it LOOP. ; do next command ENDDO. ; Get command (or command continuation) ; Accepts: B/ pointer to buffer ; C/ number of available bytes ; CALL GETCMD ; Returns: +1 Error ; +2 Success GETCMD: SAVEAC MOVX A,.PRIIN ; from primary input MOVX D,.CHCRT ; terminate on carriage return SIN% ; read a command ERJMP INPEOF ; finish up on error IFE. C ; if count unsatisfied, must have seen CR LDB A,B ; get last byte CAIN A,.CHCRT ; was it a CR? ANSKP. TMSG <* BAD Line too long: > CALLRET DMPCOM ENDIF. PBIN% ; get expected LF ERJMP INPEOF ; finish up on error CAIN A,.CHLFD ; was it a line feed? IFSKP. MOVE B,A ; copy loser TMSG <* BAD Line does not end with CRLF: > MOVX A,.PRIOU ; output the loser MOVX C,^D8 ; in octal NOUT% ERCAL FATAL TMSG < > CALLRET DMPCOM ENDIF. SETZ A, ; make command null-terminated DPB A,B MOVEM C,CMDCNT ; save number of free characters RETSKP SUBTTL Command table and dispatch DEFINE COMMANDS < CMD NOOP CMD LOGIN CMD LOGOUT CMD FIND CMD SELECT CMD BBOARD CMD CHECK CMD EXPUNGE CMD COPY CMD FETCH CMD STORE CMD SEARCH CMD CAPABILITY >;DEFINE COMMANDS DEFINE CMD (CM) <[ASCIZ/'CM'/],,.'CM> CMDTAB: COMMANDS ; command names CMDTBL==.-CMDTAB BADCOM SUBTTL Command service routines ; NOOP - no-operation .NOOP: JUMPN A,BADARG ; must not have an argument TAGMSG RET ; CAPABILITY - report protocol capabilities .CAPAB: JUMPN A,BADARG ; must not have an argument TMSG <* CAPABILITY IMAP2 > TAGMSG RET ; LOGIN - log in to mail service .LOGIN: STKVAR <,+1>>,+1>>> IFQN. F%LOG ; make sure not doing this twice TAGMSG RET ENDIF. JUMPE A,MISARG ; error if no username HRROI A,USRNAM ; copy user name string MOVX C,ARGLEN+1 ; bounded by this many characters CALL ARGCPY RET JUMPE B,MISARG ; error if no password HRROI A,PASSWD ; copy password string MOVX C,ARGLEN+1 ; bounded by this many characters CALL ARGCPY RET JUMPN B,BADARG ; error if subsequent argument MOVX A,RC%EMO ; require exact match HRROI B,USRNAM RCUSR% ; parse user name string IFJER. TAGMSG CALLRET ERROUT ENDIF. IFXN. A,RC%NOM!RC%AMB ; bogus name? TAGMSG RET ENDIF. MOVEM C,LGUSRN ; save login user number SETZ A, ; get PS: directory of user in C MOVE B,LGUSRN RCDIR% ERCAL FATAL ; can't fail MOVEM C,LGDIRN ; save login directory ; Now try to log in SKIPN MYUSRN ; is job already logged in? IFSKP. MOVEM C,.ACDIR+ACCBLK ; directory number to check HRROI C,PASSWD ; password MOVEM C,.ACPSW+ACCBLK SETOM .ACJOB+ACCBLK ; this job MOVX A,AC%PWD!.ACJOB+1 ; validate password XMOVEI B,ACCBLK ACCES% IFJER. AOSGE LOGCNT ; count up another failing login attempt IFSKP. TAGMSG JRST IMPERR ENDIF. TAGMSG CALLRET ERROUT ENDIF. ELSE. MOVE A,LGUSRN ; user number to log in as HRROI B,PASSWD ; password SETZ C, ; account LOGIN% ; do the login IFJER. AOSGE LOGCNT ; count up another failing login attempt IFSKP. TAGMSG JRST IMPERR ENDIF. TAGMSG CALLRET ERROUT ENDIF. MOVX A,.FHSLF ; get my capabilities RPCAP% IOR C,B ; enable as many capabilities as we can EPCAP% ERJMP .+1 ; ignore possible ACJ ITRAP MOVE A,LGUSRN ; we're now logged in MOVEM A,MYUSRN ; so note that fact ENDIF. ; Job logged in, report success TQO F%LOG ; flag logged in TAGMSG HRROI A,LGUSRS ; make login user string MOVE B,LGUSRN DIRST% ERCAL FATAL HRROI A,LGUSRS ; output user name PSOUT% TMSG < logged in at > MOVX A,.PRIOU ; output date/time SETO B, ; time now MOVX C,OT%DAY!OT%SPA!OT%TMZ!OT%SCL!OT%822 ; standard date/time ODTIM% ERCAL FATAL TMSG <, job > MOVX A,.PRIOU ; output job number MOVE B,MYJOBN MOVX C,^D10 ; in decimal NOUT% ERCAL FATAL RET ENDSV. ; LOGOUT - log out of mail service .LOGOU: JUMPN A,BADARG ; must not have an argument TMSG <* BYE TOPS-20 IMAP server terminating connection > TAGMSG ; start acknowledgement HRROI A,LCLHST ; output our host name PSOUT% TMSG < Logout completed> IMPERR: CALL CRLF INPEOF: CALL CLSMBX ; close off mailbox CALL HANGUP ; hang up the connection JRST MAPSER ; restart program HANGUP: MOVX A,.PRIOU ; wait until the output happens DOBE% ERJMP .+1 IFQN. F%NVT ; NVT server? DTACH% ; detach the job to prevent "Killed..." message ERJMP .+1 SETO A, ; now log myself out LGOUT% ERJMP .+1 ENDIF. HALTF% ; stop RET ; FIND - file mailbox/bulletin board names .FIND: JE F%LOG,,NOTLOG ; must log in first JUMPE A,MISARG ; must have an argument STKVAR ,,+1>>,> HRROI A,MBXNAM ; copy argument type MOVX C,ARGLEN+1 ; bounded by this many characters CALL ARGCPY RET JUMPE B,MISARG ; must have another argument MOVEM B,TMPPTR HRROI A,MBXNAM ; see what type it is HRROI B,[ASCIZ/MAILBOXES/] ; try mailboxes first STCMP% IFN. A ; if no match HRROI A,MBXNAM ; try BBoards HRROI B,[ASCIZ/BBOARDS/] STCMP% ; well? JUMPN A,BADCOM ; sorry TQO F%BBD ; hunt through BBoards ELSE. TQZ F%BBD ; mailbox ENDIF. HRROI A,MBXNAM ; copy mailbox MOVE B,TMPPTR MOVX C,ARGLEN+1 ; bounded by this many characters CALL ARGCPY RET JUMPN B,BADARG ; no arguments after this ; Get file, using POBOX:.TXT as default to user's argument for ; FIND MAILBOXES command and POBOX:{arg}.TXT for FIND BBOARDS command IFQN. F%BBD ; BBOARD command? HRROI A,FILBUF ; yes, only allow name HRROI B,POBOX ; fill in device name SETZ C, SOUT% HRROI B,[ASCIZ/: ; only output filename ELSE. HRROI B,[ASCIZ/* MAILBOX /] CALL BFSOUT SETZ C, ; output full path name ENDIF. HRRZ B,FNDJFN ; this file JFNS% ; output name HRROI B,[ASCIZ/ /] CALL BFSOUT MOVEM A,TMPPTR ; save updated pointer ENDIF. MOVE A,FNDJFN ; try for next match GNJFN% IFNJE. ; found one, go do it ENDDO. ; Return the results to the user SETZ C, ; tie off buffer IDPB C,TMPPTR MOVX A,.PRIOU ; now blat the buffer MOVE B,[OWGP. 7,OUTBFR] SOUT% ERJMP .+1 ENDIF. HRRZ A,FNDJFN ; flush the JFN if set IFN. A RLJFN% ERJMP .+1 ENDIF. TAGMSG RET ENDSV. ; SELECT - select a mailbox .SELEC: TQZA F%BBD ; not BBOARD command .BBOAR: TQO F%BBD ; BBOARD command JE F%LOG,,NOTLOG ; must log in first JUMPE A,MISARG ; must have an argument STKVAR <,INIJFN,,+1>>,> HRROI A,MBXNAM ; copy mailbox MOVX C,ARGLEN+1 ; bounded by this many characters CALL ARGCPY RET JUMPN B,BADARG ; no arguments after this IFQE. F%BBD ; BBOARD command? HRROI A,MBXNAM ; compare user's argument HRROI B,INBOX ; with special name INBOX STCMP% ANDE. A ; if user wants the INBOX MOVE A,MAIL ; he really wants MAIL.TXT MOVEM A,MBXNAM ENDIF. SKIPE MBXJFN ; have a mailbox JFN open already? CALL CLSMBX ; yes, close it ; Get file, using POBOX:.TXT as default to user's argument for ; SELECT command and POBOX:.TXT for BBOARD command MOVX A,GJ%OLD!1 ; require extant file, default gen 1 MOVEM A,.GJGEN+GTJBLK MOVE A,[.NULIO,,.NULIO] ; only use the string MOVEM A,.GJSRC+GTJBLK HRROI A,POBOX ; default device MOVEM A,.GJDEV+GTJBLK TQNE F%BBD ; BBOARD command? SKIPA A,[-1,,BBOARD] HRROI A,LGUSRS ; will fill this in MOVEM A,.GJDIR+GTJBLK SETZM .GJNAM+GTJBLK ; no default filename HRROI A,TXT ; default extension MOVEM A,.GJEXT+GTJBLK SETZM .GJPRO+GTJBLK ; no special default protection SETZM .GJACT+GTJBLK ; no special default account SETZM .GJJFN+GTJBLK ; no special JFN MOVEI A,GTJBLK ; long form GTJFN% HRROI B,MBXNAM ; user's argument GTJFN% IFJER. SETZRO .RHALF,.GJGEN+GTJBLK ; try any generation MOVEI A,GTJBLK ; and try the GTJFN again HRROI B,MBXNAM GTJFN% IFJER. TAGMSG CALLRET ERROUT ENDIF. ENDIF. ; Have file, validate access MOVEM A,MBXJFN MOVX B,.CKARD ; first check read access MOVEM B,.CKAAC+CHKBLK MOVE B,LGUSRN ; our user number MOVEM B,.CKALD+CHKBLK MOVE B,LGDIRN ; login directory is connected MOVEM B,.CKACD+CHKBLK SETZM .CKAEC+CHKBLK ; no capabilities enabled MOVEM A,.CKAUD+CHKBLK ; JFN of file to check MOVX A,CK%JFN!.CKAUD+1 ; validate access to file given JFN XMOVEI B,CHKBLK CHKAC% ; validate access ERCAL FATAL IFE. A ; access ok? TAGMSG MOVE A,MBXJFN ; flush the JFN RLJFN% ERJMP .+1 SETZM MBXJFN ; and note no file open RET ENDIF. MOVX A,.CKAWR ; now see if write access MOVEM A,.CKAAC+CHKBLK MOVX A,CK%JFN!.CKAUD+1 ; validate access to file given JFN XMOVEI B,CHKBLK CHKAC% ; validate access ERCAL FATAL SKIPN A TQOA F%RON ; read-only file TQZ F%RON ; read/write file ; Access OK, open file and seize the lock MOVE A,MBXJFN MOVX B,<1,,.FBREF> ; get last file read TAD XMOVEI C,MBXRDT ; into this location GTFDB% ERCAL FATAL MOVX B,<!OF%RD> ; now open for read OPENF% IFJER. TAGMSG CALL ERROUT MOVE A,MBXJFN ; flush the JFN RLJFN% ERJMP .+1 SETZM MBXJFN ; and note no file open RET ENDIF. MOVX A, ; number of locks,,block length MOVEM A,ENQBLK+.ENQLN MOVX A,REQID ; PSI channel,,request ID MOVEM A,ENQBLK+.ENQID MOVX A,EN%SHR!EN%BLN ; shared access, no level #'s HRR A,MBXJFN ; this file MOVEM A,ENQBLK+.ENQLV HRROI A,[ASCIZ/Mail expunge interlock/] ; starting pointer MOVEM A,ENQBLK+.ENQUC ; ENQ% lock string SETZM ENQBLK+.ENQRS ; resources/group SETZM ENQBLK+.ENQMS ; resource mask block MOVX A,.ENQBL ; try and get lock, but don't wait XMOVEI B,ENQBLK ENQ% ERCAL FATAL ; If file has an index, grab it and get its date HRROI A,FILBUF ; create POBOX:file-name.IDX MOVE B,MBXJFN MOVX C,<!!!JS%PAF> JFNS% ; dump it HRROI B,[ASCIZ/.IDX/] ; output index's extension SETZ C, SOUT% ; copy the .IDX MOVX A,GJ%OLD!GJ%SHT ; see if there's an index file HRROI B,FILBUF GTJFN% IFNJE. MOVEM A,IDXJFN MOVX B,OF%RD!OF%WR!OF%THW ; now open it, thawed OPENF% IFJER. MOVE A,IDXJFN ; can't open init, flush JFN RLJFN% ERJMP .+1 ELSE. HRRZ A,LGUSRN ; get RH of user number ADDI A,UXADR ; plus well-known offset of BBoard poop IDIVI A,1000 ; A/ page number, B/ address in page MOVEM B,IDXADR ; save index address for later HRL A,IDXJFN ; A/ JFN,,page # MOVE B,LODIPG ; B/ process,,page # MOVX C,PM%RD!PM%WR ; want read/write access PMAP% ; seize access ERCAL FATAL XMOVEI A,INDEX ; make address pointer absolute ADDM A,IDXADR MOVE A,@IDXADR ; get index last read TAD IFNJE. MOVEM A,MBXRDT ; use as last file read TAD ELSE. SETZM IDXADR ; ugh ENDIF. ENDIF. ENDIF. ; File opened, now attempt to find init file for it HRROI A,MBXNAM ; get actual filename MOVE B,MBXJFN ; from JFN MOVX C, JFNS% ERCAL FATAL HRROI A,MBXNAM ; are we reading our MAIL.TXT? HRROI B,[ASCIZ/MAIL/] STCMP% IFN. A ; if user doesn't wants the INBOX HRROI A,FILBUF ; create POBOX:file-name.MM-INIT MOVE B,MBXJFN MOVX C,<!!!JS%PAF> JFNS% ; dump it HRROI B,[ASCIZ/.MM-INIT/] ; output init's extension SETZ C, SOUT% ; copy the .INIT IDPB C,A ; tie off name with null MOVX A,GJ%OLD!GJ%SHT ; see if there's an init file HRROI B,FILBUF GTJFN% ANNJE. ; this mailbox has a special init ELSE. HRROI A,FILBUF ; MAIL.TXT or special init fails MOVE B,MBXJFN ; create POBOX:MM.INIT MOVX C,<!!JS%PAF> JFNS% ; dump it HRROI B,[ASCIZ/MM.INIT/] ; output init's name and extension SETZ C, SOUT% IDPB C,A ; tie off name with null MOVX A,GJ%OLD!GJ%SHT ; see if there's an init file HRROI B,FILBUF GTJFN% SETZ A, ; no INIT file at all ENDIF. IFN. A ; got an INIT file? MOVEM A,INIJFN MOVX B,<!OF%RD> ; now open it OPENF% IFJER. MOVE A,INIJFN ; can't open init, flush JFN RLJFN% ERJMP .+1 ELSE. ; Have an init file to parse, do so DO. MOVE A,INIJFN ; reload JFN HRROI B,FLGBUF ; read in an init file line MOVX C,TXTLEN-1 ; up to this many bytes MOVX D,.CHCRT ; terminate on linefeed SIN% ; read a line ERJMP ENDLP. ; finish up IFE. C LDB C,B ; get last byte CAIE C,.CHCRT ; was it a CR? EXIT. ; no, line too long, punt this init ENDIF. SETZ C, ; null-terminate line DPB C,B BIN% ; get expected LF ERJMP ENDLP. CAIE B,.CHLFD ; validate it EXIT. ; init file bogus HRROI A,[ASCIZ/KEYWORDS/] ; see if KEYWORDS line found HRROI B,FLGBUF STCMP% JXN A,SC%LSS!SC%GTR,TOP. ; line not found ILDB A,B ; get delimiting byte CAIE A,.CHSPC ; expected space? EXIT. ; no -- lose SETZ C, ; start with flag 0 DO. MOVEM B,FLGTAB(C) ; save pointer to flag 0 DO. ILDB A,B ; get next byte CAIE A,"," ; if not comma or null then uninteresting JUMPN A,TOP. ENDDO. JUMPE A,ENDLP. ; if a null then we're done SETZ A, ; else tie off previous flag DPB A,B SKIPN FLGTAB+1(C) ; make sure not overwriting system flags AOJA C,TOP. ; and record start of new flag ENDDO. ENDDO. MOVE A,INIJFN ; now close init JFN CLOSF% ERJMP .+1 ENDIF. ENDIF. ; Output list of flags TMSG <* FLAGS (> MOVSI B,-^D36 ; maximum number of flags DO. SKIPN A,FLGTAB(B) ; get name of this flag if any AOBJN B,TOP. ; none here, try next (note can't fail here) PSOUT% ; have one, output it AOBJP B,ENDLP. ; done if last flag MOVX A,.CHSPC ; delimit PBOUT% LOOP. ; do next flag ENDDO. TMSG <) > ; Map the file in and parse it MOVE A,MBXJFN ; get JFN CALL FILSIZ ; return file size MOVEM A,MBXBSZ ; save number of characters CALL GETMBX ; finally get the mailbox IFSKP. TAGMSG IFQN. F%RON ; read-only file? TMSG <[READ-ONLY] for > ELSE. TMSG <[READ-WRITE] for > ENDIF. MOVX A,.PRIOU ; output filename MOVE B,MBXJFN MOVX C,JS%SPC ; entire spec please JFNS% ERCAL FATAL SKIPN IDXJFN ; indexed file? ANSKP. TMSG <, mailbox is indexed> ENDIF. RET ENDSV. ; Message flags DEFINE FLAG (STRING) < M%'STRING==:1B> -1,,[ASCIZ/\'STRING'/] >;DEFINE FLAG FLGINI: FLAG Draft 0 ; c-client uses this for "not \Recent" FLAG Answered FLAG Flagged FLAG Deleted FLAG Seen IFN >,<.FATAL Wrong number of initial flags> ; CHECK - check for new messages in mailbox .CHECK: JE F%LOG,,NOTLOG ; must log in first JUMPN A,BADARG ; must not have an argument SKIPN MBXJFN ; must have a mailbox open JRST NOMBX CALL FCHECK ; do a full check IFSKP. > RET ; FCHECK is called when the entire mail file should be reparsed ; QCHECK is called when nothing should be done if the file size is the same FCHECK: TDZA A,A ; want a full check QCHECK: SETO A, ; want a quick check STKVAR MOVEM A,FSTCHK ; save fast check flag SKIPN A,MBXJFN ; get JFN RETSKP ; return immediately if none CALL FILSIZ ; return file size SKIPE FSTCHK ; want a fast check? CAME A,MBXBSZ ; yes, return now if size unchanged IFSKP. CAML A,MBXBSZ ; did it shrink? IFSKP. TAGMSG CALL CLSMBX ; close file off JRST IMPERR ENDIF. MOVEM A,MBXBSZ ; save number of characters CALLRET GETMBX ENDSV. ; EXPUNGE - remove deleted messages from mailbox .EXPUN: JE F%LOG,,NOTLOG ; must log in first JUMPN A,BADARG ; must not have an argument SKIPN MBXJFN ; must have a mailbox open JRST NOMBX IFQN. F%RON ; read-only? TAGMSG RET ENDIF. ACVAR TRVAR ; See if there are any deleted messages to expunge SKIPE A,MBXMGS ; get number of messages IFSKP. TAGMSG ; tell user and go away RET ENDIF. SETZ M, ; start check with first message DO. JN M%DELE,MSGFLG(M),ENDLP. ; if found deleted message, must expunge ADDI M,MSGLEN ; else bump to next index SOJG A,TOP. ; and count down another message TAGMSG RET ; nothing to do then ENDDO. ; Some deleted messages exist, get the file for write and exclusive access CALL MBXWRT ; open mailbox for write RET ; can't get it for write MOVEM A,MBXJF2 ; save JFN we got SETZM EXPMSG ; number of messages expunged MOVX A,EN%SHR ; turn off share bit ANDCAM A,ENQBLK+.ENQLV MOVX A,.ENQMA ; change our lock to be exclusive XMOVEI B,ENQBLK ENQ% IFJER. TAGMSG RET ENDIF. CALL FCHECK ; do a full check first RET HRRZ A,MBXJFN ; page 0,,JFN FFFFP% ; find size of contiguous file pages ERCAL FATAL LDB C,[POINT 9,A,26] ; get number of sections of file TRNE A,777 ; any fractional section? ADDI C,1 ; plus 1 for fractional section HRLZ A,MBXJF2 ; source JFN,,start at section 0 MOVE B,[.FHSLF,,MBXSEC] ; our process,,mailbox section TXO C,SM%RD!SM%WR ; read/write access,,this many sections SMAP% ERCAL FATAL ; Go through mail file, blatting subsequent messages on top of deleted ones MOVE A,[OWGP. 7,OUTBFR] ; initialize buffer pointer HRLO D,MBXMGS ; get number of messages,,-1 SETCA D, ; -,,0 AOBJP D,.+1 ; -msgs,,1 SETZ M, ; start check with first message MOVE Q4,MSGIPT(M) ; initial destination pointer is first message SETZ Q5, ; with no GBP stuff DO. IFQN. M%DELE,MSGFLG(M) ; this message deleted? HRROI B,[ASCIZ/* /] ; mark unsolicited CALL BFSOUT MOVEI B,(D) ; output expunged message # SUB B,EXPMSG ; offset by the number already done CALL BFNOUT HRROI B,[ASCIZ/ EXPUNGE /] CALL BFSOUT AOS EXPMSG ; bump the expunged messages count SOS MBXMGS ; and decrement the current messages count ELSE. SKIPE EXPMSG ; anything expunged yet? IFSKP. MOVE Q4,MSGIPT+MSGLEN(M) ; no, destination pointer is next message SETZ Q5, ; with no GBP stuff ELSE. MOVE Q1,MSGIPT(M) ; init source with internal header of this message SETZ Q2, ; clear any previous GBP stuff DO. ILDB C,Q1 ; copy the internal header IDPB C,Q4 CAIE C,.CHLFD ; got to the LF yet? LOOP. ; no, continue copy ENDDO. MOVE Q0,MSGSIZ(M) ; source copy of bytes to copy MOVE Q3,Q0 ; destination count of byte to copy EXTEND Q0,[MOVSLJ ; blat the string 0] ; with a zero fill CALL MOVBOG ; this cannot happen ENDIF. ENDIF. ADDI M,MSGLEN ; bump to next index AOBJN D,TOP. ; and count down another message ENDDO. SETZ C, ; tie off status buffer IDPB C,A MOVX A,.PRIOU ; now send status buffer to client MOVE B,[OWGP. 7,OUTBFR] SOUT% ERJMP .+1 ; Compute new byte count for mail file IFN. Q5 ; got a GBP address? TLC Q4,000740 ; clear bits for "global POINT 7,0,35" TXNE Q4, ; make sure no bozo bits set CALL MOVBOG LDB A,[POINT 6,Q4,5] ; get position IDIVI A,7 ; divide by bytesize CAIG A,OWG7SZ CAIE B,1 ; is remainder correct? CALL MOVBOG ; foo MOVE Q4,OWG7TB(A) ; get correct pointer DPB Q5,[POINT 30,Q4,35] ; fill in GBP address ENDIF. LDB C,[POINT 30,Q4,35] ; get final destination address LDB D,[POINT 30,MSGIPT,35] ; get initial destination address SUB C,D ; get number of words difference IMULI C,5 ; convert to characters LDB D,[POINT 3,MSGIPT,5] ; subtract initial position from count SUB C,D LDB D,[POINT 3,Q4,5] ; add final position to count ADD C,D MOVEM C,MBXBSZ ; save new file size ; Set new file byte count and byte size MOVE A,MBXJF2 ; get the write JFN HRLI A,.FBBYV ; want to change file I/O poop TXO A,CF%NUD ; don't update the disk yet MOVX B,FB%BSZ ; now change bytesize MOVX C, ; to 7-bit bytes CHFDB% ERCAL FATAL HRLI A,.FBSIZ ; want to change file size TXO A,CF%NUD ; don't update the disk yet SETO B, ; change all bits MOVE C,MBXBSZ ; get new file size CHFDB% ; set the new size ERCAL FATAL ; Check for and delete extraneous mail file pages. Note that since page ; numbers are zero-origin, the size of the file in pages is the first page ; number to delete. IDIVI C,^D<5*512> ; get number of pages in mailbox SKIPE D ; is there a fractional page? ADDI C,1 ; yes, add that in HRRZ A,MBXJF2 ; see where the guy ends FFFFP% ERCAL FATAL HRRZS A ; first page that doesn't exist CAMG A,C ; file has more pages than we need? IFSKP. HRL B,MBXJF2 ; yes, need to flush pages HRR B,C ; JFN,,first page to flush SUBM A,C ; # of pages to flush TXO C,PM%CNT ; let monitor know we're giving it a count SETO A, ; want to delete pages PMAP% ; zap! IFJER. TMSG <* BAD Unable to delete extra file pages> CALL ERROUT ENDIF. ENDIF. ; Report final results of expunge to client SKIPE MBXMGS ; any messages left? IFSKP. MOVE A,MBXJF2 ; no, prepare to flush the file TXO A,DF%NRJ ; don't flush the JFN though DELF% ; sayonara ERCAL FATAL TAGMSG ELSE. CALL FCHECK ; now do a full check RET TAGMSG ; and output confirmation MOVX A,.PRIOU MOVE B,EXPMSG MOVX C,^D10 NOUT% ERCAL FATAL TMSG < messages> ENDIF. MOVX A,EN%SHR ; turn on share bit IORM A,ENQBLK+.ENQLV MOVX A,.ENQMA ; change the access back to shared XMOVEI B,ENQBLK ENQ% ERJMP .+1 RET ENDTV. ENDAV. ; COPY - copy messages to another mailbox .COPY: JE F%LOG,,NOTLOG ; must log in first JUMPE A,MISARG ; must have an argument SKIPN MBXJFN ; must have a mailbox open JRST NOMBX TRVAR <,CPYJFN,,+1>>> CALL GETSEQ ; get message sequence RET ; failed JUMPE A,MISARG ; must have a mailbox name following HRROI A,MBXNAM ; copy mailbox MOVX C,ARGLEN+1 ; bounded by this many characters CALL ARGCPY RET JUMPN B,BADARG ; no arguments after this HRROI A,MBXNAM ; compare user's argument HRROI B,INBOX ; with special name INBOX STCMP% IFE. A ; if user wants the INBOX MOVE A,MAIL ; he really wants MAIL.TXT MOVEM A,MBXNAM ENDIF. MOVX A,1 ; default gen 1 MOVEM A,.GJGEN+GTJBLK MOVE A,[.NULIO,,.NULIO] ; only use the string MOVEM A,.GJSRC+GTJBLK HRROI A,POBOX ; default device MOVEM A,.GJDEV+GTJBLK HRROI A,LGUSRS ; will fill this in MOVEM A,.GJDIR+GTJBLK SETZM .GJNAM+GTJBLK ; no default filename HRROI A,TXT ; default extension MOVEM A,.GJEXT+GTJBLK SETZM .GJPRO+GTJBLK ; no special default protection SETZM .GJACT+GTJBLK ; no special default account SETZM .GJJFN+GTJBLK ; no special JFN MOVEI A,GTJBLK ; long form GTJFN% HRROI B,MBXNAM ; user's argument GTJFN% IFJER. SETZRO .RHALF,.GJGEN+GTJBLK ; try any generation MOVEI A,GTJBLK ; and try the GTJFN again HRROI B,MBXNAM GTJFN% IFJER. TAGMSG CALLRET ERROUT ENDIF. ENDIF. ; Verify access and open for write MOVEM A,CPYJFN MOVEM A,.CKAUD+CHKBLK ; JFN of file to check MOVX B,OF%RD ; see if file exists OPENF% IFJER. MOVX B,.CKACF ; no, we need to see if we can create it ELSE. TXO A,CO%NRJ ; close but don't release... CLOSF% ERJMP +1 MOVX B,.CKAAP ; see if we have append access ENDIF. MOVEM B,.CKAAC+CHKBLK MOVE B,LGUSRN ; our user number MOVEM B,.CKALD+CHKBLK MOVE B,LGDIRN ; login directory is connected MOVEM B,.CKACD+CHKBLK SETZM .CKAEC+CHKBLK ; no capabilities enabled MOVX A,CK%JFN!.CKAUD+1 ; validate access to file given JFN XMOVEI B,CHKBLK CHKAC% ; validate access ERCAL FATAL IFE. A ; access ok? TAGMSG MOVE A,CPYJFN ; flush the JFN RLJFN% ERJMP .+1 SETZM CPYJFN ; and note no file open RET ENDIF. MOVE A,CPYJFN MOVX B,<!OF%APP> ; now open for append OPENF% IFJER. TAGMSG CALL ERROUT MOVE A,CPYJFN ; flush the JFN RLJFN% ERJMP .+1 RET ENDIF. ; Now do the copy HRROI A,[ASCIZ/ Copy /] XMOVEI B,CPYMSG ; set up message copy routine CALL SEQDSP ; do for each sequence IFSKP. > MOVE A,CPYJFN ; now close off the file CLOSF% ERCAL FATAL RET ; all done ; Routine to copy a single message CPYMSG: SAVEAC ACVAR STKVAR MOVEM B,MSG ; save message number in case error MOVEI M,-1(B) ; determine index into data structure IMULI M,MSGLEN MOVE A,CPYJFN ; set up JFN for output MOVE B,MSGTAD(M) ; now output date/time MOVX C,OT%TMZ ODTIM% IFNJE. MOVX B,"," ; output delimiter BOUT% ANNJE. MOVE B,MSGSIZ(M) ; output size MOVX C,^D10 ; in decimal NOUT% ANNJE. MOVX B,";" ; output delimiter BOUT% ANNJE. MOVE B,MSGFLG(M) ; output flags MOVX C,!> NOUT% ANNJE. HRROI B,[ASCIZ/ /] ; output CRLF before message SETZ C, SOUT% ANNJE. MOVE B,MSGPTR(M) ; from this byte MOVN C,MSGSIZ(M) ; and this many bytes SOUT% RET ; all done ENDIF. TAGMSG MOVX A,.PRIOU ; output message number MOVE B,MSG MOVX C,^D10 NOUT% ERCAL FATAL CALL ERROUT ; output last error string RETSKP ; abort the sequence ENDSV. ENDAV. ENDTV. ; FETCH - fetch attributes MAXATT==^D100 ; lots of attributes .FETCH: JE F%LOG,,NOTLOG ; must log in first JUMPE A,MISARG ; must have an argument SKIPN MBXJFN ; must have a mailbox open JRST NOMBX STKVAR > CALL GETSEQ ; get message sequence RET ; failed JUMPE A,MISARG ; must have an attribute following MOVE A,B ; sniff at attribute ILDB A,A ; Parse attribute list CAIE A,"(" ; attribute list? IFSKP. IBP B ; yes, skip the open paren MOVE A,[TQO ] ; we have a list of attributes MOVEM A,ATTLST MOVSI D,-MAXATT ; set up pointer to attribute list HRRI D,1+ATTLST DO. CALL GETATT ; get attribute RET ; failed HLR C,(C) ; get dispatch address CAIE A,.CHSPC ; more attributes coming? EXIT. ; no HRLI C,<(CALL)> ; yes, make into a CALL
instruction MOVEM C,(D) ; store the instruction AOBJN D,TOP. ; get next attribute TAGMSG RET ENDDO. CAIE A,")" ; saw a close paren? JRST SYNERR MOVE A,[TQZ ] ; this attribute is the last one MOVEM A,(D) ; store the instruction HRLI C,<(CALLRET)> ; make a CALLRET
instruction MOVEM C,1(D) ; store as final instruction ILDB A,B ; sniff past the close paren XMOVEI B,ATTLST ; set up dispatch to routine we compiled ; Atomic attribute ELSE. MOVEM B,ATTPTR ; save pointer HRROI A,[ASCIZ/ALL/] ; user want all? STCMP% IFE. A ; must be exact XMOVEI B,.FTALL ; win ELSE. HRROI A,[ASCIZ/FAST/] ; no, then try for fast MOVE B,ATTPTR STCMP% IFE. A XMOVEI B,.FTFST ; win ELSE. MOVE B,ATTPTR CALL GETATT ; user probably wants a single attribute RET ; failed HLRZ B,(C) ; get dispatch address XHLLI B, ENDIF. ENDIF. TQZ ; make sure this is initialized ENDIF. JUMPN A,BADARG ; must be end of arguments ; Now, do the fetching HRROI A,[ASCIZ/ Fetch (/] CALL SEQDSP ; do per-sequence dispatch IFSKP. > RET ENDSV. ; Fetch all for message in B .FTALL: TQO CALL .FTFLG CALL .FTDAT CALL .FTSIZ TQZ CALLRET .FTENV ; Fetch all fast attributes for message in B .FTFST: TQO CALL .FTFLG CALL .FTDAT TQZ CALLRET .FTSIZ ; Fetch envelope for message indexed in B .FTENV: SAVEAC ACVAR MOVEI M,-1(B) ; determine index into data structure IMULI M,MSGLEN SKIPN D,MSGENV(M) ; get envelope block pointer CALL GETENV HRROI B,[ASCIZ/Envelope (/] CALL BFSOUT SKIPE B,ENVDAT(D) ; get envelope date IFSKP. MOVE B,MSGTAD(M) ; default Date MOVX C,"""" ; quote the string IDPB C,A MOVX C,OT%DAY!OT%SPA!OT%TMZ!OT%SCL!OT%822 ; standard date/time ODTIM% ERCAL FATAL HRROI B,[ASCIZ/" /] CALL BFSOUT ELSE. CALL BFSTR ENDIF. MOVE B,ENVSUB(D) ; get envelope Subject CALL BFSTR MOVE B,ENVFRM(D) ; get envelope From CALL BFADR MOVE B,ENVSDR(D) ; get envelope Sender CALL BFADR MOVE B,ENVREP(D) ; get envelope Reply-To CALL BFADR MOVE B,ENVTO(D) ; get envelope To CALL BFADR MOVE B,ENVCC(D) ; get envelope cc CALL BFADR MOVE B,ENVBCC(D) ; get envelope bcc CALL BFADR MOVE B,ENVIRT(D) ; get envelope In-Reply-To CALL BFSTR MOVE B,ENVMID(D) ; get envelope Message-ID CALL BFSTR MOVEI B,")" ; close off the envelope DPB B,A CALLRET BFCRLF ENDAV. ; Fetch flags for message in B .FTFLG: SAVEAC ACVAR ; FLGX must be FLG+1 SETZ C, ; initially no delimiter MOVEI M,-1(B) ; determine index into data structure IMULI M,MSGLEN HRROI B,[ASCIZ/Flags (/] CALL BFSOUT MOVE FLG,MSGFLG(M) ; get message flags MOVE B,MSGTAD(M) ; get date of this message CAMG B,MBXRDT ; is this a recent message? IFSKP. HRROI B,[ASCIZ/\Recent/] ; yes, indicate it as such CALL BFSOUT MOVX C,.CHSPC ; have a delimiter now ENDIF. IFN. FLG ; any flags set? DO. JFFO FLG,.+2 ; get bit position EXIT. ; last bit in this word SKIPN B,FLGTAB(FLGX) ; is this flag defined? IFSKP. SKIPN C ; output delimiter if needed SKIPA C,[.CHSPC] ; have a delimiter now IDPB C,A CALL BFSOUT ; defined flag, output it ENDIF. ANDCM FLG,BITS(FLGX) ; clear this flag LOOP. ENDDO. ENDIF. MOVEI B,")" IDPB B,A CALLRET BFCRLF ENDAV. ; Fetch internal date in B .FTDAT: SAVEAC ACVAR MOVEI M,-1(B) ; determine index into data structure IMULI M,MSGLEN HRROI B,[ASCIZ/InternalDate "/] CALL BFSOUT MOVE B,MSGIPT(M) ; output date directly from the file DO. ILDB D,B JUMPE D,TOP. ; ignore leading nulls CAIE D,.CHSPC ; and leading whitespace CAIN D,.CHTAB LOOP. ENDDO. CAIL D,"0" ; numeric? CAILE D,"9" IFSKP. ILDB C,B ; sniff at next character too CAIL C,"0" ; numeric? CAILE C,"9" IFNSK. MOVX M,.CHSPC ; no, start with leading space IDPB M,A ENDIF. IDPB D,A ; ship first character (second in C) DO. IDPB C,A ; ship this character ILDB C,B ; get next character CAIE C,"," ; start of next field? LOOP. ; no, output remainder of field ENDDO. ELSE. MOVE B,MSGTAD(M) ; strange, better use the slow way then... MOVX C,OT%TMZ ODTIM% ERCAL FATAL ENDIF. MOVX B,"""" IDPB B,A CALLRET BFCRLF ENDAV. ; Fetch RFC 822 size in B .FTSIZ: SAVEAC ACVAR MOVEI M,-1(B) ; determine index into data structure IMULI M,MSGLEN HRROI B,[ASCIZ/RFC822.Size /] CALL BFSOUT MOVE B,MSGSIZ(M) ; now output size CALL BFNOUT CALLRET BFCRLF ENDAV. ; Fetch RFC 822 format message in B .FT822: SAVEAC ACVAR MOVEI M,-1(B) ; determine index into data structure IMULI M,MSGLEN CALL MRKMSG ; mark this message as having been seen MOVE B,MSGPTR(M) ; output message from this byte MOVE C,MSGSIZ(M) ; and this many bytes HRROI D,[ASCIZ/RFC822/] CALL BFBLAT CALLRET BFCRLF ENDAV. ; Fetch RFC 822 format header in B .FTHDR: SAVEAC ACVAR MOVEI M,-1(B) ; determine index into data structure IMULI M,MSGLEN SKIPE C,MSGHSZ(M) ; get header size IFSKP. MOVE B,M ; not known yet, set up index CALL FNDHSZ ; find the header ENDIF. MOVE B,MSGPTR(M) ; output body of message from this byte HRROI D,[ASCIZ/RFC822.Header/] CALL BFBLAT CALLRET BFCRLF ENDAV. ; Fetch text from RFC 822 format message in B .FTTXT: SAVEAC ACVAR MOVEI M,-1(B) ; determine index into data structure IMULI M,MSGLEN CALL MRKMSG ; mark message as having been seen SKIPE C,MSGHSZ(M) ; get header size IFSKP. MOVE B,M ; not known yet, set up index CALL FNDHSZ ; find the header ENDIF. MOVE B,MSGSIZ(M) ; get full message size SUBB B,C ; save message size MOVE B,MSGHSZ(M) ; output body of message ADJBP B,MSGPTR(M) ; from this byte HRROI D,[ASCIZ/RFC822.Text/] CALL BFBLAT CALLRET BFCRLF ENDAV. ; STORE - store attributes .STORE: JE F%LOG,,NOTLOG ; must log in first JUMPE A,MISARG ; must have an argument SKIPN MBXJFN ; must have a mailbox open JRST NOMBX IFQN. F%RON ; read-only? TAGMSG RET ENDIF. STKVAR CALL GETSEQ ; get message sequence RET ; failed JUMPE A,MISARG ; must have an attribute following CALL GETATT ; get attribute RET ; failed CAIN A,")" ; make sure delimiter is right JRST SYNERR HRRZ C,(C) ; get dispatch address MOVEM C,ARGDSP ; save dispatch IFN. A MOVE A,[OWGP. 7,ARGBUF] ; starting pointer MOVX C,-<<5*ARGBSZ>-1> ; wholeline argument is very large CALL ARGCPY ; copy the argument RET JUMPN B,BADARG ; must be last argument ELSE. SETZM @[ARGBUF] ; make argument empty ENDIF. HRROI A,[ASCIZ/ Store (/] HRRZ B,ARGDSP ; get dispatch address XHLLI B, CALL SEQDSP ; do attribute dispatch IFSKP. > RET ENDSV. .STBAD: TAGMSG RETSKP .STNIM: TAGMSG RETSKP ; Store flags for message in B .STFLG: SAVEAC CALL GETFLG ; parse user's flag list RETSKP ; failed CALL STOFLG ; store these flags RETSKP CALLRET .FTFLG ; and do a fetch of the new flags ; Store additional flags for message in B .STPFL: SAVEAC ACVAR MOVEI M,-1(B) ; determine index into data structure IMULI M,MSGLEN CALL GETFLG ; parse user's flag list RETSKP ; failed IOR C,MSGFLG(M) ; new flags are the OR function CALL STOFLG ; store these flags RETSKP CALLRET .FTFLG ; and do a fetch of the new flags ENDAV. ; Store cleared flags for message in B .STMFL: SAVEAC ACVAR MOVEI M,-1(B) ; determine index into data structure IMULI M,MSGLEN CALL GETFLG ; parse user's flag list RETSKP ; failed ANDCA C,MSGFLG(M) ; new flags are the AND of complement function CALL STOFLG ; store these flags RETSKP CALLRET .FTFLG ; and do a fetch of the new flags ENDAV. ; SEARCH - search for message with attributes .SEARC: JE F%LOG,,NOTLOG ; must log in first JUMPE A,MISARG ; must have an argument SKIPN MBXJFN ; must have a mailbox open JRST NOMBX SKIPE MBXMGS ; is there at least one message? IFSKP. TAGMSG RET ENDIF. ACVAR <,SEQ,PTR> STKVAR MOVEM B,CURPTR ; save pointer to current search command SETOM SEQLST ; initialize sequence list to ALL MOVE A,[SEQLST,,SEQLST+1] BLT A,SEQLST+SEQLSN-1 ; Pass 1: parse each criterion, and deselect messages which fail it DO. MOVSI C,-SRCTBL ; length of command table DO. HLRO A,SRCTAB(C) ; point to command string MOVE B,CURPTR ; point to base STCMP% ; compare JUMPE A,ENDLP. ; done if match IFXN. A,SC%SUB ; subset? ILDB A,B ; yes, get delimiting byte CAIN A,.CHSPC ; OK if something follows EXIT. ENDIF. AOBJN C,TOP. JRST BADCOM ENDDO. SKIPN A ; possibility of an argument? SETZ B, ; no, end of string HRRZ D,SRCTAB(C) ; get pointer to argument,,command dispatch MOVE D,(D) ; get argument,,command dispatch IFXN. D,.LHALF ; command takes an argument? SETZM @[ARGBUF] ; initialize argument SETZM ATOM ANDN. A ; yes, is there one in the buffer MOVE A,[OWGP. 7,ARGBUF] ; starting pointer MOVX C,<5*ARGBSZ>-1 ; buffer is very large CALL ARGCPY ; copy the argument RET HLRO C,D ; get routine that will process the argument CALL (C) ; go process it RET ; argument processor was unhappy with it ENDIF. HRRO C,D ; get routine to handle command MOVEM B,CURPTR ; save pointer to current search command MOVX D,1 ; start at first message DO. MOVEI A,-1(D) ; copy sequence IDIVI A,^D36 ; split into vector index and bit number MOVE B,BITS(B) ; get the desired bit TDNE B,SEQLST(A) ; is this message eligible to be checked? CALL (C) ; yes, check it ANDCAM B,SEQLST(A) ; bit is now ineligible CAMGE D,MBXMGS ; at the last message? AOJA D,TOP. ; no, try next message ENDDO. SKIPE B,CURPTR ; restore pointer LOOP. ; do next search spec if there is one ENDDO. ; Pass 2: output the messages which match the search MOVE A,[OWGP. 7,OUTBFR] ; initialize buffer pointer HRROI B,[ASCIZ/* SEARCH/] ; start search reply CALL BFSOUT SETZ PTR, ; and sequence pointer MOVE VEC,SEQLST ; get first word from bit vector DO. JFFO VEC,.+2 ; find a bit out of it IFSKP. MOVE SEQ,PTR ; get vector index IMULI SEQ,^D36 ; times number of bits in vector element ADDI SEQ,1(VEC+1) ; plus bit position gives this sequence CAMLE SEQ,MBXMGS ; off the end? EXIT. ; yes, all done ANDCM VEC,BITS(VEC+1) ; flush this bit for next time MOVX B,.CHSPC ; delimit IDPB B,A MOVE B,SEQ ; get sequence again CALL BFNOUT ; output sequence LOOP. ENDIF. CAIN PTR,SEQLSN ; at end? EXIT. ; yes, done with sequence MOVE VEC,SEQLST+1(PTR) ; get next word from bit vector AOJA PTR,TOP. ; charge on ENDDO. HRROI B,[ASCIZ/ /] CALL BFSOUT SETZ C, ; tie off buffer IDPB C,A MOVX A,.PRIOU ; now blat the buffer MOVE B,[OWGP. 7,OUTBFR] SOUT% ERJMP .+1 TAGMSG RET ENDSV. ENDAV. DEFINE SRC (NAME,DSP,ARG) <[ASCIZ/'NAME'/],,[ARG,,DSP]> SRCTAB: SRC All,RSKP SRC Answered,.SEANS SRC Bcc,.SEBCC,RSKP SRC Before,.SEBEF,.SEDAT SRC Body,.SEBOD,RSKP SRC Cc,.SECC,RSKP SRC Deleted,.SEDEL SRC Flagged,.SEFLG SRC From,.SEFRM,RSKP SRC Keyword,.SEKEY,.SEFLA SRC New,.SENEW SRC Old,.SEOLD SRC On,.SEON,.SEDAT SRC Recent,.SEREC SRC Seen,.SESEE SRC Since,.SESIN,.SEDAT SRC Subject,.SESUB,RSKP SRC Text,.SETEX,RSKP SRC To,.SETO,RSKP SRC Unanswered,.SEUAN SRC Undeleted,.SEUDE SRC Unflagged,.SEUFL SRC Unkeyword,.SEUKE,.SEFLA SRC Unseen,.SEUSE SRCTBL==.-SRCTAB ; Parse a date .SEDAT: SAVEAC MOVE A,[OWGP. 7,ARGBUF] ; pointer to the thing MOVX B,IT%NTI ; don't bother with the time IDTNC% ERJMP SYNERR IDCNV% ERJMP SYNERR LDB A,A ; better be the end JUMPN A,SYNERR ; it wasn't MOVEM B,ATOM ; time is OK RETSKP ; Parse a keyword flag .SEFLA: SAVEAC MOVSI C,-^D30 DO. MOVE A,FLGTAB(C) ; flag to consider MOVE B,[OWGP. 7,ARGBUF] ; point to the thing STCMP% IFN. A ; exact match? AOBJN C,TOP. ; no, try next flag TAGMSG RET ENDIF. ENDDO. MOVE A,BITS(C) ; get the flag MOVEM A,ATOM RETSKP ; Skip if text matches .SETEX: SAVEAC MOVEI B,-1(D) ; determine index into data structure IMULI B,MSGLEN MOVE A,MSGPTR(B) ; text of message MOVE B,MSGSIZ(B) ; size of message CALLRET SEARCH ; search for it! ; Skip if text in body of message matches .SEBOD: SAVEAC MOVEI B,-1(D) ; determine index into data structure IMULI B,MSGLEN SKIPN C,MSGHSZ(B) ; get header size CALL FNDHSZ ; find the header's size MOVE A,C ; get pointer to start of text ADJBP A,MSGPTR(B) MOVE B,MSGSIZ(B) ; size of entire message SUB B,C ; size of text only CALLRET SEARCH ; search for it! ; Skip if text in subject of message matches .SESUB: SAVEAC MOVEI B,-1(D) ; determine index into data structure IMULI B,MSGLEN EXCH B,D ; B has message number for GETENV SKIPN D,MSGENV(D) ; get envelope CALL GETENV MOVE A,ENVSUB(D) ; get pointer to subject SETZ B, ; count characters in subject DO. ILDB C,A JUMPE C,ENDLP. AOJA B,TOP. ENDDO. MOVE A,ENVSUB(D) ; get pointer to subject CALLRET SEARCH ; Skip if From matches .SEFRM: SAVEAC MOVEI B,-1(D) ; determine index into data structure IMULI B,MSGLEN EXCH B,D ; B has message number for GETENV SKIPN D,MSGENV(D) ; get envelope CALL GETENV MOVE D,ENVFRM(D) ; get From CALLRET .SEADR ; Skip if To matches .SETO: SAVEAC MOVEI B,-1(D) ; determine index into data structure IMULI B,MSGLEN EXCH B,D ; B has message number for GETENV SKIPN D,MSGENV(D) ; get envelope CALL GETENV MOVE D,ENVTO(D) ; get To CALLRET .SEADR ; Skip if cc matches .SECC: SAVEAC MOVEI B,-1(D) ; determine index into data structure IMULI B,MSGLEN EXCH B,D ; B has message number for GETENV SKIPN D,MSGENV(D) ; get envelope CALL GETENV MOVE D,ENVCC(D) ; get cc CALLRET .SEADR ; Skip if bcc matches .SEBCC: SAVEAC MOVEI B,-1(D) ; determine index into data structure IMULI B,MSGLEN EXCH B,D ; B has message number for GETENV SKIPN D,MSGENV(D) ; get envelope CALL GETENV MOVE D,ENVBCC(D) ; get bcc CALLRET .SEADR ; Skip on match for address list in D .SEADR: ACVAR SKIPN ADR,D ; get address list RET ; if empty address always fails SAVEAC MOVE A,[OWGP. 7,WRKBUF] ; destination buffer SETZ B, ; init byte count DO. SKIPN D,ADRNAM(ADR) ; output personal name IFSKP. DO. ILDB C,D IFN. C IDPB C,A AOJA B,TOP. ENDIF. ENDDO. MOVX C,.CHSPC ; and space as delimiter IDPB C,A ADDI B,1 ENDIF. SKIPN D,ADRMBX(ADR) ; output mailbox IFSKP. MOVX C,.CHLAB ; output left broket IDPB C,A ADDI B,1 DO. ILDB C,D IFN. C IDPB C,A AOJA B,TOP. ENDIF. ENDDO. SKIPN D,ADRHST(ADR) ; output host IFSKP. MOVX C,"@" ; delimiter IDPB C,A ADDI B,1 DO. ILDB C,D IFN. C IDPB C,A AOJA B,TOP. ENDIF. ENDDO. ENDIF. MOVX C,.CHRAB ; close broket IDPB C,A MOVX C,.CHSPC ; and space IDPB C,A ADDI B,2 ENDIF. MOVE ADR,ADRCDR(ADR) ; try next address JUMPN ADR,TOP. ; do it if there is one ENDDO. IDPB ADR,A ; tie off the string JUMPE B,R ; one last paranoia check MOVE A,[OWGP. 7,WRKBUF] ; destination buffer CALLRET SEARCH ; now do the search ENDAV. ; Skip on flag set for message in D .SEANS: SAVEAC MOVEI A,-1(D) ; determine index into data structure IMULI A,MSGLEN MOVE A,MSGFLG(A) ; get flags JXN A,M%ANSW,RSKP ; skip if answered RET .SEDEL: SAVEAC MOVEI A,-1(D) ; determine index into data structure IMULI A,MSGLEN MOVE A,MSGFLG(A) ; get flags JXN A,M%DELE,RSKP ; skip if deleted RET .SEFLG: SAVEAC MOVEI A,-1(D) ; determine index into data structure IMULI A,MSGLEN MOVE A,MSGFLG(A) ; get flags JXN A,M%FLAG,RSKP ; skip if flagged RET .SEKEY: SAVEAC MOVEI A,-1(D) ; determine index into data structure IMULI A,MSGLEN MOVE A,MSGFLG(A) ; get flags TDNE A,ATOM ; is the keyword set? RETSKP RET .SESEE: SAVEAC MOVEI A,-1(D) ; determine index into data structure IMULI A,MSGLEN MOVE A,MSGFLG(A) ; get flags JXN A,M%SEEN,RSKP ; skip if seen RET ; Skip if flag not set for message in D .SEUAN: SAVEAC MOVEI A,-1(D) ; determine index into data structure IMULI A,MSGLEN MOVE A,MSGFLG(A) ; get flags JXE A,M%ANSW,RSKP ; skip if unanswered RET .SEUDE: SAVEAC MOVEI A,-1(D) ; determine index into data structure IMULI A,MSGLEN MOVE A,MSGFLG(A) ; get flags JXE A,M%DELE,RSKP ; skip if undeleted RET .SEUFL: SAVEAC MOVEI A,-1(D) ; determine index into data structure IMULI A,MSGLEN MOVE A,MSGFLG(A) ; get flags JXE A,M%FLAG,RSKP ; skip if unflagged RET .SEUKE: SAVEAC MOVEI A,-1(D) ; determine index into data structure IMULI A,MSGLEN MOVE A,MSGFLG(A) ; get flags TDNN A,ATOM ; is the keyword clear? RETSKP RET .SEUSE: SAVEAC MOVEI A,-1(D) ; determine index into data structure IMULI A,MSGLEN MOVE A,MSGFLG(A) ; get flags JXE A,M%SEEN,RSKP ; skip if unseen RET ; Skip based on date of message .SENEW: CALL .SEREC ; is it recent? RET ; no CALLRET .SEUSE ; yes, then it's new if unseen .SEREC: SAVEAC MOVEI A,-1(D) ; determine index into data structure IMULI A,MSGLEN MOVE A,MSGTAD(A) ; get date of this message CAMG A,MBXRDT ; is this a recent message? RET RETSKP ; yes, message is new .SEOLD: SAVEAC MOVEI A,-1(D) ; determine index into data structure IMULI A,MSGLEN MOVE A,MSGTAD(A) ; get date of this message CAMLE A,MBXRDT ; is this a recent message? RET RETSKP ; yes, message is new ; Skip if message suits a particular date/time range .SEBEF: SAVEAC MOVEI A,-1(D) ; determine index into data structure IMULI A,MSGLEN MOVE A,MSGTAD(A) ; get TAD CAML A,ATOM ; before the date? RET RETSKP .SEON: SAVEAC MOVEI A,-1(D) ; determine index into data structure IMULI A,MSGLEN MOVE A,MSGTAD(A) ; get TAD CAMGE A,ATOM ; since the date? RET SUB A,[1B17] ; yes, back the TAD off by 1 day CAML A,ATOM ; if it's now before the date then it's that day RET RETSKP .SESIN: SAVEAC MOVEI A,-1(D) ; determine index into data structure IMULI A,MSGLEN MOVE A,MSGTAD(A) ; get TAD CAMGE A,ATOM ; since the date? RET RETSKP SUBTTL RFC 822 => Envelope handling routines ; Format of an envelope block ENVDAT==0 ; envelope Date ENVSUB==1 ; address of envelope Subject ENVFRM==2 ; address of envelope From ENVSDR==3 ; address of envelope Sender ENVREP==4 ; address of envelope Reply-To ENVTO==5 ; address of envelope To ENVCC==7 ; address of envelope cc ENVBCC==10 ; address of envelope bcc ENVIRT==11 ; address of envelope In-Reply-To ENVMID==12 ; address of envelope Message-ID ENVLEN==13 ; length of envelope block ; Format of an address block ADRNAM==0 ; address personal name ADRADL==1 ; address route list (a-d-l) ADRMBX==2 ; address mailbox ADRHST==3 ; address host ADRCDR==4 ; pointer to next address ADRLEN==5 ; length of an address block ; Get an envelope for a message ; Accepts: B/ message number ; CALL GETENV ; Returns +1: Always, envelope pointer in D GETENV: SAVEAC ACVAR TRVAR <,> MOVEI M,-1(B) ; determine index into data structure IMULI M,MSGLEN MOVX D,ENVLEN ; length of envelope block CALL FSGET MOVEM D,MSGENV(M) ; save envelope pointer SKIPE CTR,MSGHSZ(M) ; get header size IFSKP. MOVE B,M ; not known yet, set up index CALL FNDHSZ ; find the header MOVE CTR,MSGHSZ(M) ENDIF. MOVE PTR,MSGPTR(M) ; pointer to header DO. CALL GETLIN ; get an RFC 822 text line EXIT. ; didn't get one DMOVE A,[OWGP. 7,WRKBUF ; point to header line POINT 7,HEADER] ; and to where we store the item DMOVEM A,HDRPTR SETZM HEADER ; init item SETZM 1+HEADER SETZM 2+HEADER MOVEI A,^D15 ; maximum header item length DO. ILDB C,HDRPTR ; copy string, converting to uppercase JUMPE C,ENDLP. ; with appropriate terminating cases... CAIE C,.CHSPC CAIN C,.CHTAB EXIT. CAIN C,":" EXIT. CAIL C,"a" CAILE C,"z" TRNA SUBI C,"a"-"A" IDPB C,1+HDRPTR SOJG A,TOP. ENDDO. JUMPLE A,TOP. ; can't possibly win if ran out CAIN C,":" ; saw the delimiter IFSKP. CALL SKIPWS ILDB C,HDRPTR ; get delimiter CAIE C,":" ; saw appropriate delimiter? LOOP. ; no, this line can't possibly win then ENDIF. ; Do appropriate processing for this header line CALL SKIPWS DMOVE A,HEADER ; now, get the header item MOVE C,2+HEADER CAME A,[ASCII/DATE/] IFSKP. MOVE A,HDRPTR ; text to copy CALL CPYSTR MOVEM A,ENVDAT(D) ; store the date we parsed LOOP. ENDIF. CAMN A,[ASCII/SUBJE/] CAME B,[ASCII/CT/] IFSKP. MOVE A,HDRPTR ; text to copy CALL CPYSTR MOVEM A,ENVSUB(D) ; save pointer to subject in envelope LOOP. ENDIF. CAME A,[ASCII/FROM/] IFSKP. MOVE A,HDRPTR ; string to parse XMOVEI B,ENVFRM(D) ; location to store address list CALL GETADR ; parse address LOOP. ENDIF. CAMN A,[ASCII/SENDE/] CAME B,[ASCII/R/] IFSKP. MOVE A,HDRPTR ; string to parse XMOVEI B,ENVSDR(D) ; location to store address list CALL GETADR ; parse address LOOP. ENDIF. CAMN A,[ASCII/REPLY/] CAME B,[ASCII/-TO/] IFSKP. MOVE A,HDRPTR ; string to parse XMOVEI B,ENVREP(D) ; location to store address list CALL GETADR ; parse address LOOP. ENDIF. CAME A,[ASCII/TO/] IFSKP. MOVE A,HDRPTR ; string to parse XMOVEI B,ENVTO(D) ; location to store address list CALL GETADR ; parse address LOOP. ENDIF. CAME A,[ASCII/CC/] IFSKP. MOVE A,HDRPTR ; string to parse XMOVEI B,ENVCC(D) ; location to store address list CALL GETADR ; parse address LOOP. ENDIF. CAME A,[ASCII/BCC/] IFSKP. MOVE A,HDRPTR ; string to parse XMOVEI B,ENVBCC(D) ; location to store address list CALL GETADR ; parse address LOOP. ENDIF. CAMN A,[ASCII/IN-RE/] CAME B,[ASCII/PLY-T/] IFSKP. CAME C,[ASCII/O/] ANSKP. MOVE A,HDRPTR ; treat as text for now CALL CPYSTR MOVEM A,ENVIRT(D) ; save pointer in envelope LOOP. ENDIF. CAMN A,[ASCII/MESSA/] CAME B,[ASCII/GE-ID/] IFSKP. ANDE. C MOVE A,HDRPTR ; treat as text for now CALL CPYSTR MOVEM A,ENVMID(D) ; save pointer in envelope LOOP. ENDIF. LOOP. ENDDO. ; Default parts of the envelope MOVE B,ENVFRM(D) ; default Sender and Reply-to SKIPN ENVSDR(D) ; set default Sender if none in header MOVEM B,ENVSDR(D) SKIPN ENVREP(D) ; set default Reply-to if none in header MOVEM B,ENVREP(D) RET SKIPWS: SAVEAC DO. MOVE A,HDRPTR ; skip whitespace ILDB A,A CAIE A,.CHSPC CAIN A,.CHTAB IFNSK. IBP HDRPTR LOOP. ENDIF. ENDDO. RET ENDTV. ; Get an RFC822 line, called only from GETENV ; Accepts: PTR/ current RFC822 header pointer ; CTR/ number of bytes left in header ; CALL GETLIN ; Returns +1: Didn't get a line ; +2: Got a line in WRKBUF GETLIN: SAVEAC ; D used as a flag for unparsed text MOVE A,[OWGP. 7,WRKBUF] ; stash line in here SETZB D,@[WRKBUF] ; empty line ; Flush any leading whitespace or otherwise strange things. This is ; paranoia code and none of these conditions should ever happen with a ; well-formed RFC822 header. DO. MOVE C,PTR ; guard against perverse start of line CAIE C,.CHSPC ; LWSP CAIN C,.CHTAB IFSKP. CAIE C,.CHCRT ; CR CAIN C,"(" ; start of comment ANSKP. ; looks OK ELSE. SOJL CTR,R ; ugh, skip over this crap ILDB C,PTR LOOP. ; let's hope the next one is nicer... ENDIF. ENDDO. ; Copy line DO. SOJL CTR,R ; quit if out of header ILDB C,PTR ; get character from header IFE. D ; if we don't know whether text or not CAIE C,":" ; have delimiting colon? ANSKP. IDPB C,A ; yes, stash it in the string LDB B,[OWGP. 7,WRKBUF+1,<^D20>] ; sniff at delimiting character CAIN B,":" ; is it expected ":" IFSKP. CAIE B,.CHTAB ; no, then it had better be whitespace! CAIN B,.CHSPC ANSKP. AOJA D,TOP. ; it isn't, so assume we must parse it! ENDIF. DMOVE B,@[WRKBUF] ; get first two words of line AND B,[BYTE (7) 137,137,137,137,137] ; make sure uppercase AND C,[BYTE (7) 137,137,0,0,0] CAMN B,[ASCII/SUBJE/] ; look like a Subject: line? CAME C,[ASCII/CT/] AOJA D,TOP. ; no, flag that we must parse it SOJA D,TOP. ; yes, flag that it's non-parsed text ENDIF. IFGE. D ; needs pre-parsing? CAIE C,"\" ; yes, quoted-pair? IFSKP. IDPB C,A ; yes, store it in string SOJL CTR,R ; get next character ILDB C,PTR IDPB C,A LOOP. ENDIF. ; Handle quoted string CAIE C,"""" ; quoted-string? IFSKP. IDPB C,A ; store open quote DO. SOJL CTR,R ILDB C,PTR CAIE C,.CHCRT ; end of line? IFSKP. SOJL CTR,R ; get expected LF ILDB C,PTR CAIE C,.CHLFD ANSKP. SOJL CTR,R ; get expected LWSP-char ILDB C,PTR ENDIF. IDPB C,A ; store character in the string CAIE C,"\" ; quoted-pair? IFSKP. SOJL CTR,R ; get next character ILDB C,PTR IDPB C,A LOOP. ENDIF. CAIE C,"""" ; end of quote? LOOP. ; no, get next character ENDDO. LOOP. ENDIF. ; Handle comment CAIE C,"(" ; comment? IFSKP. SETZ B, ; initialize nesting count DO. SOJL CTR,R ILDB C,PTR ; get next character CAIE C,.CHCRT ; end of line? IFSKP. SOJL CTR,R ; get expected LF ILDB C,PTR CAIE C,.CHLFD ANSKP. SOJL CTR,R ; get expected LWSP-char ILDB C,PTR ENDIF. CAIE C,"\" ; quoted-pair? IFSKP. SOJL CTR,R ; yes, skip next character ILDB C,PTR LOOP. ENDIF. CAIN C,"(" ; nested comment? AOJA B,TOP. ; yes, increment nest count CAIE C,")" ; end of comment? LOOP. ; no SOJGE B,TOP. ; yes, decrement nest count and maybe finish ENDDO. MOVX C,.CHSPC ; make it into LWSP ENDIF. ; Whitespace CAIE C,.CHTAB ; LWSP-char? CAIN C,.CHSPC ANNSK. DO. MOVE C,PTR ; sniff at next character ILDB C,C CAIE C,.CHTAB ; LWSP-char? CAIN C,.CHSPC IFNSK. SOJL CTR,R ; yes, skip this character IBP PTR LOOP. ENDIF. ENDDO. LDB B,A ; see if LWSP already stored CAIN B,.CHSPC IFSKP. MOVX B,.CHSPC ; no, store a single LWSP IDPB B,A ENDIF. LOOP. ; try next character ENDIF. ; End of line (always come here whether or not parsable) CAIE C,.CHCRT ; end of line? IFSKP. MOVE B,PTR ; could be, sniff at next character ILDB B,B CAIE B,.CHLFD ; so, is it really EOL? ANSKP. SETZ C, ; yes, tie off line here MOVE B,A ; but be prepared for continuation so don't IDPB C,B ; step on A IBP PTR ; skip past the LF SOJLE CTR,ENDLP. ; guard against the header ending MOVE C,PTR ; sniff at next line ILDB C,C CAIE C,.CHTAB ; LWSP-char? CAIN C,.CHSPC LOOP. ; yes, continue eating text ELSE. IDPB C,A ; no, store this character LOOP. ; and get more text ENDIF. ENDDO. SKIPN @[WRKBUF] ; did we get any line at all? RET ; no, probably end of header RETSKP ENDAV. ; Get an RFC 822 address list ; Accepts: A/ pointer to address list string ; B/ address of location to store list pointer ; CALL GETADR ; Returns +1: Always ; This routine is quite a bit more generous than RFC 822 in what it will ; swallow, since there are still all sorts of gross address composers out ; there that generate flagrantly illegal addresses. GETADR: SAVEAC TRVAR CALL CPYSTR ; copy string to free storage SETZM GRPCNT ; init group count DO. SKIPN D,(B) ; run down this address list until at the IFSKP. ; end, since something may already be there. XMOVEI B,ADRCDR(D) ; B will have the address of the slot to put LOOP. ; in any new addresses ENDIF. ENDDO. ; Loop for each address DO. DO. MOVE C,A ; skip leading whitespace ILDB C,C CAIE C,.CHSPC CAIN C,.CHTAB IFNSK. IBP A LOOP. ENDIF. ENDDO. MOVEM A,CURPTR ; init "current pointer" SETZM NWSPTR ; init "non-whitespace pointer" ; Handle a possible personal name DO. ; slurp up a phrase ILDB C,A JUMPE C,ENDLP. ; end of string CAIE C,"\" ; quoted character? IFSKP. IBP A ; yes, skip next character MOVEM A,NWSPTR LOOP. ENDIF. CAIE C,"""" ; quoted string? IFSKP. DO. ILDB C,A ; yes, search for unquote CAIN C,"\" ; in case quoted quote IBP A CAIE C,"""" ; found unquote yet? JUMPN C,TOP. ; nope ENDDO. MOVEM A,NWSPTR ; new end of whitespace ENDIF. ; Deal with the possibility of : ; CAIE C,":" ; definite group phrase? IFSKP. DO. MOVE C,A ; yes, skip any whitespace ILDB C,C CAIE C,.CHSPC CAIN C,.CHTAB IFNSK. IBP A ; another bit of whitespace to skip LOOP. ENDIF. ENDDO. AOS GRPCNT ; bump number of groups SETZM NWSPTR ; toss out this entire phrase! MOVEM A,CURPTR EXIT. ENDIF. SKIPE GRPCNT ; group in effect? CAIE C,";" ; yes, end of group? IFSKP. SOS GRPCNT ; yes, decrement number of groups MOVX C,"," ; and treat like comma ENDIF. CAIE C,.CHLAB ; saw a definite route-addr? CAIN C,"," ; or definite end of this address? IFSKP. CAIE C,.CHSPC ; not yet, is it whitespace? CAIN C,.CHTAB IFSKP. ; no, save non-whitespace pointer LOOP. ; continue scan ENDIF. ENDDO. ; End of a phrase. If NWSPTR is zero then there's nothing to look at SKIPN C ; end of line? SETZ A, ; yes, note that SKIPN NWSPTR ; parsed anything at all? CAIN C,.CHLAB ; no, but do we see an address now? IFNSK. MOVX D,ADRLEN ; yes to either, get an address block CALL FSGET MOVEM D,(B) ; cons it to the end of the old list ; See if need to handle route-addr CAIE C,.CHLAB ; route-addr following? IFSKP. SETZ C, ; tie off string we parsed SKIPN NWSPTR ; only do this if we saw a phrase IFSKP. IDPB C,NWSPTR MOVE C,CURPTR ; save phrase as personal name ENDIF. MOVEM C,ADRNAM(D) DO. MOVE C,A ; skip whitespace ILDB C,C CAIE C,.CHSPC CAIN C,.CHTAB IFNSK. IBP A LOOP. ENDIF. ENDDO. ; Handle A-D-L MOVE C,A ; see if there's an A-D-L ILDB C,C CAIE C,"@" ; is there? IFSKP. MOVEM A,ADRADL(D) ; yes, save that pointer DO. ILDB C,A ; look for end of A-D-L CAIN C,"\" ; handle quotes IBP A CAIE C,"""" ; and this form too IFSKP. DO. ILDB C,A CAIE C,"\" IBP A CAIE C,"""" JUMPN C,TOP. ENDDO. ENDIF. CAIE C,":" ; end of A-D-L? IFSKP. SETZ C, DPB C,A ENDIF. JUMPN C,TOP. ENDDO. ENDIF. MOVEM A,CURPTR ; note current pointer MOVEM A,NWSPTR ; Look for end of route-addr DO. ILDB C,A ; look for closing broket CAIN C,"\" ; handle quotes IBP A CAIE C,"""" ; and this form too IFSKP. DO. ILDB C,A CAIE C,"\" IBP A CAIE C,"""" JUMPN C,TOP. ENDDO. ENDIF. CAIN C,.CHRAB EXIT. CAIE C,.CHSPC ; so we can skip over whitespace CAIN C,.CHTAB IFSKP. JUMPN C,TOP. SETZ A, ; note line ended ENDDO. CAIE C,.CHRAB ; this terminated it? ANSKP. DO. ILDB C,A ; flush until a comma CAIE C,"," JUMPN C,TOP. ENDDO. SKIPN C ; end of line? SETZ A, ; yes, note that ENDIF. ; Found end of route-addr or there wasn't a route-addr. Now know mailbox SETZ C, ; tie off string we parsed IDPB C,NWSPTR MOVE C,CURPTR ; get pointer to mailbox name MOVEM C,NWSPTR MOVEM C,ADRMBX(D) ; save it ; Locate host DO. ILDB C,CURPTR ; search for host delimiter JUMPE C,ENDLP. CAIN C,"\" ; quoted character? IBP CURPTR ; yes, skip next character CAIE C,"""" ; quoted string? IFSKP. DO. ILDB C,CURPTR ; yes, look for unquote CAIN C,"\" IBP CURPTR CAIE C,"""" JUMPN C,TOP. ENDDO. ENDIF. CAIE C,"@" ; saw host? IFSKP. SETZ C, ; tie off string IDPB C,NWSPTR DO. MOVE C,CURPTR ; flush leading whitespace ILDB C,C CAIE C,.CHSPC CAIN C,.CHTAB IFNSK. IBP CURPTR LOOP. ENDIF. ENDDO. MOVE C,CURPTR ; store host MOVEM C,ADRHST(D) ENDIF. CAIE C,.CHSPC ; not yet, is it whitespace? CAIN C,.CHTAB IFSKP. MOVE C,CURPTR ; no, save as non-whitespace pointer MOVEM C,NWSPTR ENDIF. LOOP. ; continue scan ENDDO. ; Have all the envelope fields, now get rid of RFC 822 quoting conventions SKIPE B,ADRNAM(D) ; remove RFC 822 quotes from the fields CALL FLSQOT SKIPE B,ADRADL(D) CALL FLSQOT SKIPE B,ADRMBX(D) CALL FLSQOT SKIPE B,ADRHST(D) CALL FLSQOT XMOVEI B,ADRCDR(D) ; set up new end of list pointer ENDIF. JUMPN A,TOP. ; parse remainder of string ENDDO. RET ENDTV. ; Flush RFC 822 quotes from string ; Accepts: B/ source/destination string pointer ; CALL FLSQOT ; Returns +1: Always FLSQOT: SAVEAC MOVE A,B ; destination will overwrite source DO. ILDB C,A ; copy from source CAIE C,"""" ; quoted string IFSKP. DO. ILDB C,A CAIN C,"""" ; end of string? EXIT. ; yes CAIE C,"\" ; quoted character? IFSKP. ILDB C,A ; yes, copy next character without checking IDPB C,B ELSE. IDPB C,B ; else copy this one and quit if end of string JUMPE C,R ENDIF. LOOP. ; do next character in quoted string ENDDO. LOOP. ; do next character in primary string ENDIF. CAIE C,"\" ; quoted character? IFSKP. ILDB C,A ; yes, get next character literally IDPB C,B ; copy to destination ELSE. IDPB C,B ; copy to destination JUMPE C,R ENDIF. LOOP. ENDDO. SUBTTL Output buffer routines ; Output address to buffer ; Accepts: A/ destination buffer poitner ; B/ address ; CALL BFADR ; Returns +1: Always BFADR: ACVAR SKIPN ADR,B ; get address in ADR JRST BFNIL ; if NIL then punt now MOVEI B,"(" ; open the address list IDPB B,A DO. MOVEI B,"(" ; open the address IDPB B,A MOVE B,ADRNAM(ADR) ; get personal name CALL BFSTR MOVE B,ADRADL(ADR) ; get route list CALL BFSTR MOVE B,ADRMBX(ADR) ; get mailbox CALL BFSTR MOVE B,ADRHST(ADR) ; get host CALL BFSTR MOVEI B,")" ; terminate address DPB B,A MOVE ADR,ADRCDR(ADR) ; see if any more addresses JUMPN ADR,TOP. ENDDO. MOVEI B,")" ; terminate address list IDPB B,A MOVX B,.CHSPC IDPB B,A RET ENDAV. ; Output NIL to buffer ; Accepts: A/ destination buffer poitner ; CALL BFNIL ; Returns +1: Always BFNIL: SAVEAC HRROI B,[ASCIZ/NIL /] ; dump a NIL to the buffer CALLRET BFSOUT ; Output string to buffer, using IMAP literal form if necessary ; Accepts: A/ destination buffer poitner ; B/ string ; CALL BFSTR ; Returns +1: Always BFSTR: SAVEAC ACVAR JUMPE B,BFNIL ; NIL if empty MOVE PTR,B ; copy pointer SETZB C,FLG ; initialize count DO. ILDB D,PTR ; sniff at string JUMPE D,ENDLP. CAIE D,"""" ; have a special? CAIN D,"{" IFSKP. CAIE D,.CHCRT ; this makes it special too CAIN D,.CHLFD ; paranoia ANSKP. CAIE D,"%" ; coddle Interlisp CAIN D,"\" ; coddle Commonlisp ANSKP. ELSE. SETO FLG, ; mark as special ENDIF. AOJA C,TOP. ; count character and continue ENDDO. IFN. FLG CALL BFBLAT ; blat the string if there are specials ELSE. MOVX C,"""" ; quote the string IDPB C,A CALL BFSOUT ; output the string MOVX C,"""" ; quote the string IDPB C,A ENDIF. MOVX C,.CHSPC ; output a trailing space IDPB C,A RET ENDAV. ; Output decimal number to buffer ; Accepts: A/ destination buffer poitner ; B/ number ; CALL BFNOUT ; Returns +1: Always BFNOUT: SAVEAC DO. IDIVI B,^D10 ; get low-order digit PUSH P,C ; save for later SKIPE B ; any more? CALL TOP. ; yes, recurse ENDDO. POP P,B ; get digit back ADDI B,"0" ; make decimal IDPB B,A ; output it RET ; decurse ; Output CRLF to buffer, with parenthesis closing if necessary ; Accepts: A/ destination buffer poitner ; CALL BFCRLF ; Returns +1: Always BFCRLF: IFQE. HRROI B,[ASCIZ/) /] ELSE. HRROI B,[ASCIZ/ /] ENDIF. ; CALLRET BFSOUT ; Output string to buffer ; Accepts: A/ destination buffer poitner ; B/ source string pointer ; CALL BFSOUT ; Returns +1: Always BFSOUT: SAVEAC TXC B,.LHALF ; check for -1 type pointer TXCN B,.LHALF HRLI B,<(POINT 7,)> DO. ; boring string copy... ILDB C,B IFN. C IDPB C,A LOOP. ENDIF. ENDDO. RET ; Blat a literal from string to buffer ; Accepts: A/ destination buffer pointer ; B/ pointer to string ; C/ length of string ; D/ leading string to output ; CALL BFBLAT ; Returns: +1 Always BFBLAT: ACVAR ; get a bunch of AC's MOVE Q0,C ; source count MOVE Q1,B ; source byte pointer SKIPN B,D ; output property name IFSKP. CALL BFSOUT MOVX B,.CHSPC IDPB B,A ENDIF. MOVX B,"{" ; start literal IDPB B,A MOVE B,Q0 ; output count CALL BFNOUT HRROI B,[ASCIZ/} /] CALL BFSOUT SETZB Q2,Q5 ; we're using 1-word byte pointers MOVE Q3,C ; destination count MOVE Q4,A ; destination byte pointer EXTEND Q0,[MOVSLJ ; blat the string 0] ; with a zero fill CALL MOVBOG ; this absolutely cannot happen IFE. Q5 ; got a OWGBP or a GBP? MOVE A,Q4 ; this microcode gives us a OWGBP back ELSE. TLC Q4,000740 ; clear bits for "global POINT 7,0,35" TXNE Q4, ; make sure no bozo bits set CALL MOVBOG LDB Q0,[POINT 6,Q4,5] ; get position IDIVI Q0,7 ; divide by bytesize CAIG Q0,OWG7SZ CAIE Q1,1 ; is remainder correct? CALL MOVBOG ; foo MOVE A,OWG7TB(Q0) ; get correct pointer DPB Q5,[POINT 30,A,35] ; fill in GBP address ENDIF. RET ENDAV. RADIX 10 OWG7TB: OWGP. 7,0,34 OWGP. 7,0,27 OWGP. 7,0,20 OWGP. 7,0,13 OWGP. 7,0,6 OWGP. 7,0 ; I don't think this can happen OWG7SZ==.-OWG7TB RADIX 8 MOVBOG: TAGMSG JRST IMPERR SUBTTL Free storage routines ; Carve out a piece of free storage ; Accepts: D/ length of desired block ; CALL FSGET ; Returns +1: Always, with address of block in D FSGET: SAVEAC EXCH D,FSFREE ; get current free address ADDM D,FSFREE ; claim the block SETZM (D) ; clear first word of the block HRL A,D ; set up BLT pointer HRRI A,1(D) BLT A,@FSFREE ; zap the block RET ; Copy text to free storage string ; Accepts: A/ pointer to source string ; CALL CPYSTR ; Returns +1: Always, address of string in A CPYSTR: TRVAR MOVEM A,SRC MOVE A,[OWGP. 7,0] ; copy remainder of line to free storage ADD A,FSFREE SAVEAC ; return address to caller DO. ILDB C,SRC IDPB C,A JUMPN C,TOP. ENDDO. ADDI A,1 ; move to next word of free space DPB A,[POINT 30,FSFREE,35] ; claim this free block RET ENDTV. SUBTTL Flag manipulation routines ; Mark message as having been seen ; Accepts: A/ buffer pointer ; B/ message number ; CALL MRKMSG ; Returns +1: Always MRKMSG: SAVEAC ACVAR MOVEI M,-1(B) ; determine index into data structure IMULI M,MSGLEN SKIPN IDXADR ; have an index file? IFSKP. MOVE C,@IDXADR ; get index last read TAD IFNJE. CAML C,MSGTAD(M) ; is it earlier than this message? ANSKP. MOVE C,MSGTAD(M) ; yes, update index MOVEM C,@IDXADR ENDIF. ELSE. MOVX C,M%SEEN ; no, mark the message as having been seen IOR C,MSGFLG(M) CAMN C,MSGFLG(M) ; was it already so marked? ANSKP. CALL STOFLG NOP XMOVEI D,[TQZ F%NCL ; clear the flag RET] TQON F%NCL ; temporarily say don't close the fetch PUSH P,D CALL .FTFLG ; do a fetch of the new flags ENDIF. RET ENDAV. ; Parse a list of flags ; Accepts: ARGBUF/ output buffer ; CALL GETFLG ; Returns +1: Failure, reason output ; +2: Success, flags in C GETFLG: SAVEAC ACVAR SETZ C, ; initially 0 flags MOVE PTR,[OWGP. 7,ARGBUF] ; starting pointer MOVE A,PTR ILDB A,A ; get starting byte of flags argument IFN. A CAIN A,"(" ; start of a list? SKIPA LST,[-1] ; yes, note that in list format TDZA LST,LST ; no, not a list IBP PTR ; skip over start of list DO. MOVSI D,-^D36 ; initialize iteration counter DO. MOVE A,FLGTAB(D) ; flag to consider MOVE B,PTR ; current flags argument STCMP% ; test this flag IFN. A ; exact match? IFXN. A,SC%SUB ; no, see if subset ILDB A,B ; it was a subset, get delimiting byte CAIE A,")" ; end of list? CAIN A,.CHSPC ; was it a space? EXIT. ; yes, found flag ENDIF. AOBJN D,TOP. ; no win, see if matches next flag TAGMSG RET ELSE. ; here if found flag at end of line ANDN. LST ; was end of list required? TAGMSG RET ENDIF. ENDDO. MOVEM B,PTR ; update pointer IOR C,BITS(D) ; update flag CAIE A,")" ; end of list? JUMPN A,TOP. ; no, if more flags to do go to them ENDDO. ENDIF. RETSKP ENDAV. ; Store flags in mailbox ; Accepts: B/ message number ; C/ new flags ; CALL STOFLG ; Returns +1: Failure ; +2: Success STOFLG: JN F%RON,,RSKP ; always fail if read-only SAVEAC ACVAR MOVEI M,-1(B) ; determine index into data structure IMULI M,MSGLEN TRVAR MOVE FLG,C CAMN FLG,MSGFLG(M) ; same value as flags had before? RETSKP ; yes, just return CALL MBXWRT ; want to write into mailbox now RET ; can't get it for write MOVEM A,JFN ; save the JFN we got MOVE D,MSGIPT(M) ; point to start of internal header DO. ILDB C,D ; get header byte CAIE C,.CHCRT ; at end of line?? IFSKP. TAGMSG RET ; sick mail file ENDIF. CAIE C,";" ; at start of bits? LOOP. ; not yet ENDDO. MOVE A,D ; sniff ahead to see that they're flags MOVX C,^D12 DO. ILDB B,A ; sniff at a byte CAIL B,"0" ; see if numeric CAILE B,"9" ; well? IFNSK. TAGMSG RET ; sick sick sick ENDIF. SOJG C,TOP. ENDDO. ; Now change the flags LDB B,[POINT 21,D,26] ; get page number of core address SUBI B, ; make disk page number HRL A,JFN ; A/ JFN,,disk page HRR A,B ; . . . LODWPG:!MOVE B,[.FHSLF,,WINPAG] ; into our window page MOVX C,PM%CNT!PM%WR!PM%RD!2 ; map two pages with write access PMAP% ERCAL FATAL ; blew it MOVEI B,WINPAG ; get core address of window DPB B,[POINT 21,D,26] ; set that in our pointer MOVE A,FLG ; get flags to write MOVX C,^D12 ; there are twelve chars.. DO. SETZ B, ; compose next "digit" ROTC A,3 ADDI B,"0" IDPB B,D ; update this triplet SOJG C,TOP. ENDDO. SETO A, ; now unmap the window pages ;;; On 21 October, 1986, I wasted over 4 hours in tracking down the cause of ;;; phase errors due to the LIT area being 1 location bigger in pass 2 than in ;;; pass 1. I finally narrowed it down to this instruction. ;;; MOVE B,[.FHSLF,,WINPAG] XCT LODWPG ; take that, you goddamned bagbiting assembler! MOVX C,PM%CNT!2 PMAP% ERCAL FATAL MOVEM FLG,MSGFLG(M) ; update core copy of flags RETSKP ENDTV. ENDAV. SUBTTL String search routine ; Bounded search for pattern within string ; Accepts: A/ OWGBP pointer to string to search in ; B/ string length ; ATOM/ pattern length ; ARGBUF/ pattern to search for ; CALL SEARCH ; Returns +1: pattern not found ; +2: pattern found, A/ position of pattern within string SEARCH: SAVEAC ACVAR SKIPLE ATOM IFSKP. JUMPLE B,RSKP ; win if there's no pattern RET ; otherwise return failure ENDIF. SUB B,ATOM ; difference between text and pattern JUMPL B,R ; lengths is the maximum # of tries LDB Q1,[POINT 6,A,5] ; get byte position CAIE Q1,66 ; aligned on previous word boundary? IFSKP. TXC A,7B5 ; yes, normalize to 61 form ADDI A,1 ; by complementing 61#66 and adding 1 ELSE. CAIE Q1,61 ; aligned to word boundary? JSP D,SEARQ ; no, pattern may begin within this word ENDIF. LDB Q5,[OWGP. 7,ARGBUF,6] ; first character IMUL Q5,[BYTE (1)0 (7)1,1,1,1,1] MOVE Q6,Q5 XOR Q6,[BYTE (1)0 (7)40,40,40,40,40] JSP D,.+1 ; come back to top if pattern not found DO. MOVE Q1,Q5 ; pattern to match MOVE Q2,Q6 ; case independent one LDB Q3,[POINT 30,A,35] MOVE Q3,(Q3) ; word to try LSH Q3,-1 ; right justify text word MOVE Q4,Q3 EQVB Q3,Q1 ; if the first pattern char is present EQVB Q4,Q2 ; this results in '177' at that char ADD Q3,[BYTE (1)1 (7)1,1,1,1,1] ; add 1 to each char complementing LSB, ADD Q4,[BYTE (1)1 (7)1,1,1,1,1] ; but note that any carry from '177' EQV Q3,Q1 ; un-complements LSB of left char! EQV Q4,Q2 ; check sameness of each char LSB TDNN Q3,[BYTE (1)1 (7)1,1,1,1,1] ; if any char LSB remains the same TDNE Q4,[BYTE (1)1 (7)1,1,1,1,1] ; then there is at least one match! JRST SEARQ ; yes, go see! SUBI B,5 ; we just tested five chars JUMPL B,R ; not found AOJA A,TOP. ; try some more ENDDO. SEARQ: MOVE Q4,A ; remember where we begin DO. MOVE Q1,[OWGP. 7,ARGBUF] DO. ILDB Q2,Q1 ; get next character JUMPE Q2,RSKP ; null, we found a match ILDB Q3,A ; get next char TRC Q3,(Q2) ; XOR text and pattern chars SKIPE Q3 ; exact match? CAIN Q3,40 ; no, other case match? LOOP. ; yes to either, try some more ENDDO. SOJL B,R ; no, quit if we've run out of text IBP Q4 ; increment pointer to next char in word MOVE A,Q4 ; get back pointer LDB Q1,[POINT 6,A,5] ; get position CAIE Q1,66 ; at end of word? LOOP. ; no, keep on looking ENDDO. LDB A,[POINT 30,Q4,35] ; address of this word ADD A,[OWGP. 7,1] ; point to start of next word JRST (D) ; not found this word, try some more ENDAV. SUBTTL Argument parsing routine ; Copy an argument ; Accepts: A/ destination pointer ; B/ current argument pointer ; C/ maximum length (negative if wholeline) ; CALL ARGCPY ; Returns: +1 Failed ; +2 Success, A, B/ updated pointer or 0 if end of line, ; C/ argument length (also stored in ATOM) ARGCPY: SAVEAC STKVAR TLC A,-1 ; is LH -1? TLCN A,-1 HRLI A,() ; make byte pointer ILDB D,B ; sniff at first byte CAIE D,"{" ; extended argument? IFSKP. MOVEM A,DEST ; save destination pointer MOVMM C,ATOM ; save maximum size MOVE A,B ; source string for size string MOVX C,^D10 ; decimal radix NIN% ERJMP SYNERR ; syntax error if bad SKIPLE B ; value must be .GE. 0 CAMLE B,ATOM ; and not too large IFNSK. TAGMSG RET ENDIF. MOVEM B,ATOM ; save argument length LDB C,A ; check for termination CAIE C,"}" JRST SYNERR MOVEM A,PTR ; save pointer ILDB C,A ; get next command byte JUMPN C,SYNERR ; better be end of line TMSG <+ Ready for argument> CALL CRLF ; Get argument MOVX A,.PRIIN ; from primary input MOVE B,DEST ; where to put the string MOVN C,ATOM ; size of string to read SIN% ; read it in ERJMP INPEOF IDPB C,B ; tie off string with null MOVE B,PTR ; get return pointer MOVE C,CMDCNT ; and free characters CALL GETCMD ; get more of command RET ; failed ILDB C,B ; see what that character was CAIN C,.CHSPC ; more arguments to come? IFSKP. JUMPN C,SYNERR ; no, better be end of line then SETZ B, ; flag that the line ends here ENDIF. ; Parse atomic argument ELSE. SETZM ATOM ; zap argument length CAIE D,"""" ; argument quoted this way? IFSKP. MOVMS C ; if so then always atomic DO. ILDB D,B ; get next byte JUMPE D,SYNERR ; if buffer ends then command is sick CAIN D,"""" ; end of string? IFSKP. IDPB D,A ; no, stuff the buffer AOS ATOM ; bump argument length SOJG C,TOP. ; get more bytes if we can TAGMSG RET ELSE. SETZ D, ; yes, tie off string IDPB D,A ; stuff the buffer ENDIF. ILDB D,B ; see if an argument follows CAIN D,.CHSPC ; argument delimiter? IFSKP. JUMPN D,SYNERR ; no, error if not end of buffer SETZ B, ; no more arguments ENDIF. ENDDO. ; Atomic unquoted argument ELSE. DO. SKIPN D ; end of string? SETZ B, ; yes, clear argument pointer IFG. C ; atomic argument? CAIN D,.CHSPC ; yes, have argument delimiter? SETZ D, ; yes, end of string ENDIF. IDPB D,A JUMPE D,ENDLP. ; done if end of string AOS ATOM ; bump argument length ILDB D,B ; get next byte IFG. C ; what kind of argument? SOJG C,TOP. ; otherwise get more bytes TAGMSG ELSE. AOJL C,TOP. ; otherwise get more bytes TAGMSG ENDIF. RET ENDDO. ENDIF. ENDIF. MOVE C,ATOM ; return argument length RETSKP ENDSV. SUBTTL Sequence handling routines ; Store sequence ; Accepts: B/ sequence ; C/ sequence bit vector ; CALL STOSEQ ; Returns: +1: Failure ; +2: Success STOSEQ: SAVEAC IFG. B ; must be .GE. 1 CAMLE B,MBXMGS ; and .LE. number of messages ANSKP. ; was it? ELSE. ; clearly not! TAGMSG RET ENDIF. MOVEI A,-1(B) ; copy sequence IDIVI A,^D36 ; split into vector index and bit number ADD A,C ; get vector address MOVE B,BITS(B) ; get the bit IORM B,(A) ; set the bit RETSKP ; Dispatch to command service routines based on a sequence ; Accepts: A/ pointer to type string ; B/ dispatch address ; SEQLST/ message sequence bit vector ; CALL SEQDSP ; Returns +1: Failure ; +2: Success, must output OK message SEQDSP: SAVEAC ACVAR <,SEQ,PTR> STKVAR MOVEM A,TYPE ; save type MOVEM B,DSP MOVE A,[OWGP. 7,OUTBFR] ; initialize buffer pointer SETZ PTR, ; and sequence pointer MOVE VEC,SEQLST ; get first word from bit vector DO. JFFO VEC,.+2 ; find a bit out of it IFSKP. MOVE SEQ,PTR ; get vector index IMULI SEQ,^D36 ; times number of bits in vector element ADDI SEQ,1(VEC+1) ; plus bit position gives this sequence ANDCM VEC,BITS(VEC+1) ; flush this bit for next time HRROI B,[ASCIZ/* /] ; mark unsolicited CALL BFSOUT MOVE B,SEQ ; get sequence again CALL BFNOUT ; output sequence MOVE B,TYPE ; output type CALL BFSOUT MOVE B,SEQ ; get sequence again CALL @DSP ; dispatch to it LOOP. ; ok, get next in list RET ; sequence aborted prematurely ELSE. CAIN PTR,SEQLSN ; at end? EXIT. ; yes, done with sequence MOVE VEC,SEQLST+1(PTR) ; get next word from bit vector AOJA PTR,TOP. ; charge on ENDIF. ENDDO. LDB C,[POINT 30,A,35] ; get trailing address SUB C,[OUTBFR] ; compute number of fullwords comsumed IMULI C,5 ; number of characters in word LDB A,[POINT 6,A,5] ; get position of final byte ADDI C,-61(A) ; add residual byte count MOVX A,.PRIOU ; now blat the buffer MOVE B,[OWGP. 7,OUTBFR] SOUT% ERJMP .+1 RETSKP ; done ENDSV. ENDAV. ; Get a message sequence list ; Accepts: B/ pointer to string ; CALL GETSEQ ; Returns: +1: Failed ; +2: Success, A/ delimiter, B/ updated string pointer GETSEQ: SAVEAC STKVAR SETZM SEQLST ; initialize sequence list MOVE A,[SEQLST,,SEQLST+1] BLT A,SEQLST+SEQLSN-1 MOVE A,B ; copy string pointer DO. MOVX C,^D10 ; get a sequence NIN% ERJMP SYNERR ; barf if bad LDB C,A ; get delimiter CAIE C,":" ; multiple sequence? IFSKP. MOVEM B,SEQTMP ; yes, save starting sequence temporarily MOVX C,^D10 ; get trailing sequence NIN% ERJMP SYNERR EXCH B,SEQTMP ; get starting sequence DO. XMOVEI C,SEQLST CALL STOSEQ ; store the sequence RET CAMN B,SEQTMP ; end of sequence? EXIT. ; yes, done CAMG B,SEQTMP ; sequence going up? AOJA B,TOP. ; yes, increment sequence SOJA B,TOP. ; no, decrement sequence ENDDO. ELSE. XMOVEI C,SEQLST CALL STOSEQ ; store this sequence RET ENDIF. LDB C,A ; get delimiter IFN. C CAIN C,.CHSPC ; end of list? ANSKP. CAIN C,"," ; another sequence coming? LOOP. ; yes, get it! JRST SYNERR ENDIF. ENDDO. MOVE B,A ; return updated pointer MOVE A,C ; and delimiter RETSKP ENDSV. SUBTTL Attribute parsing ; Get a message attribute name ; Accepts: B/ pointer to string ; CALL GETATT ; Returns +1: Failed ; +2: Success, A/ delimiter, B/ updated string pointer, ; C/ dispatch vector GETATT: STKVAR MOVEM B,ATTPTR ; save attribute pointer MOVSI C,-ATTTBL ; length of command table DO. HLRO A,ATTTAB(C) ; point to command string MOVE B,ATTPTR ; point to base STCMP% ; compare strings JUMPE A,ENDLP. ; match? IFXN. A,SC%SUB ; if subset ILDB A,B ; get delimiting byte CAIE A,")" ; is it the end of a list? CAIN A,.CHSPC ; was it a space? EXIT. ; yes, win with another argument coming ENDIF. AOBJN C,TOP. ; try next command TAGMSG RET ENDDO. HRRZ C,ATTTAB(C) ; get address of dispatch pair RETSKP ENDSV. ; Attribute names DEFINE ATT (NAME,FETCH,STORE) <[ASCIZ/'NAME'/],,[FETCH,,STORE]> ATTTAB: ATT Envelope,.FTENV,.STBAD ATT +Flags,.FTFLG,.STPFL ATT -Flags,.FTFLG,.STMFL ATT Flags,.FTFLG,.STFLG ATT InternalDate,.FTDAT,.STBAD ATT RFC822,.FT822,.STNIM ATT RFC822.Header,.FTHDR,.STNIM ATT RFC822.Size,.FTSIZ,.STBAD ATT RFC822.Text,.FTTXT,.STNIM ATTTBL==.-ATTTAB SUBTTL File management routines ; Return size of file ; Accepts: A/ JFN of file ; CALL FILSIZ ; Returns: +1 Always, A/ file size FILSIZ: SAVEAC STKVAR <>> MOVE B,[<.FBSIZ+1-.FBBYV>,,.FBBYV] ; file size MOVEI C,MBXSIZ ; into MBXSIZ GTFDB% LOAD B,FB%BSZ,MBXSIZ ; get file byte size CAIE B,7 ; already the right byte size? IFSKP. MOVE A,<.FBSIZ-.FBBYV>+MBXSIZ ; yes, use exact byte count ELSE. MOVEI A,^D36 ; compute total bytes per word IDIVI A,(B) EXCH A,<.FBSIZ-.FBBYV>+MBXSIZ IDIV A,<.FBSIZ-.FBBYV>+MBXSIZ ; compute number of words IMULI A,5 ; compute # of characters ENDIF. RET ENDSV. ; Load mailbox, output number of messages ; CALL GETMBX ; Returns +1: Failure ; +2: Success GETMBX: CALL MAPMBX ; map in mailbox RET ; percolate error SETZM MBXMGS ; initially no messages SETZM MBXNMS MOVE A,[OWGP. 7,MBXBUF] ; starting pointer MOVE B,MBXBSZ ; number of bytes to parse CALL MBXPRS ; parse mailbox IFNSK. TAGMSG CALLRET CLSMBX ENDIF. TMSG <* > MOVEI A,.PRIOU ; output number of messages we have now MOVE B,MBXMGS MOVX C,^D10 NOUT% ERCAL FATAL TMSG < EXISTS * > MOVEI A,.PRIOU ; output number of messages we have now MOVE B,MBXNMS MOVX C,^D10 NOUT% ERCAL FATAL TMSG < RECENT > RETSKP ; Map mailbox ; CALL MAPMBX ; Returns +1: Failure ; +2: Success MAPMBX: SAVEAC STKVAR HRRZ A,MBXJFN ; page 0,,JFN FFFFP% ; find size of contiguous file pages ERCAL FATAL HRRZM A,MBXPGS ; save # of mailbox pages MOVE A,MBXBSZ IDIVI A,5000 ; make into pages SKIPE B ; if a remainder ADDI A,1 ; count one more page CAMG A,MBXPGS ; is byte size reasonable? IFSKP. TAGMSG CALLRET CLSMBX ; close file off ENDIF. HRLZ A,MBXJFN ; source JFN,,start at section 0 MOVE B,[.FHSLF,,MBXSEC] ; our process,,mailbox section LDB C,[POINT 9,MBXPGS,26] ; get number of sections of file ADDI C,1 ; plus 1 for fractional section CAIG C,MBXSCN ; too many sections? IFSKP. TAGMSG CALLRET CLSMBX ENDIF. TXO C,SM%RD ; read access,,this many sections SMAP% ERCAL FATAL RETSKP ENDSV. ; Parse a mailbox ; Accepts: A/ pointer to mailbox to parse ; B/ number of bytes to parse ; CALL MBXPRS ; Returns: +1 Bad format file ; +2 Success, MBXMGS incremented appropriately HDRBFL==^D20 ; length of header buffer MBXPRS: SAVEAC ACVAR ; holds current message STKVAR > JUMPLE B,RSKP ; sanity check ADJBP B,A ; determine trailing pointer in B MOVEM B,TPTR DO. MOVE M,MBXMGS ; current message number IMULI M,MSGLEN ; times length of block DO. CAMN A,TPTR ; gotten to end of file yet? RETSKP ; yes, all done MOVEM A,MSGIPT(M) ; save start of internal pointer ILDB C,A ; sniff past any nulls JUMPE C,TOP. ENDDO. MOVE B,[POINT 7,HDRBUF] ; set up header copy buffer IDPB C,B ; store this first byte there MOVX D,<5*HDRBFL>-2 ; number of bytes left in header buffer DO. CAMN A,TPTR ; gotten to end of file? RET ; yes, garbage at end of file! ILDB C,A ; get next byte JUMPE C,TOP. ; ignore nulls CAIN C,.CHCRT ; saw terminating CR yet? IFSKP. IDPB C,B ; no, copy this byte to buffer SOJG D,TOP. ; continue if more to go RET ; totally bogus line ENDIF. SETZ C, ; tie off string IDPB C,B ENDDO. CAMN A,TPTR ; end of file? RET ; yes, bad format ILDB C,A ; get expected LF CAIE C,.CHLFD ; well? RET ; bad format mail file MOVEM A,MSGPTR(M) ; save current pointer ; Parse time HRROI A,HDRBUF ; parse header SETZ B, ; parse date/time in normal format IDTIM% ERJMP R ; bad date/time MOVEM B,MSGTAD(M) ; save date/time LDB B,A ; get delimiter CAIE B," " ; numeric timezone? IFSKP. ILDB B,A ; yes, get next character CAIE B,"-" ; negative timezone? CAIN B,"+" ; positive timezone? SKIPA S,B ; yes to either RET ; error ILDB T,A ; get zone byte CAIL T,"0" ; is it numeric? CAILE T,"9" RET ; bad zone character SUBI T,"0" ; make numeric IMULI T,^D10 ; and 10s of hours ILDB C,A ; get zone byte CAIL C,"0" ; is it numeric? CAILE C,"9" RET ; bad zone character ADDI T,-"0"(C) ; add in new byte IMULI T,^D60 ; convert hours to minutes ILDB C,A ; get zone byte CAIL C,"0" ; is it numeric? CAILE C,"9" RET ; bad zone character SUBI C,"0" ; make numeric IMULI C,^D10 ; make 10s of minutes ADD T,C ; add to minutes-converted hours ILDB C,A ; get zone byte CAIL C,"0" ; is it numeric? CAILE C,"9" RET ; bad zone character ADDI T,-"0"(C) ; add in new byte HRLZ B,T ; get minutes,,0 IDIVI B,^D24*^D60 ; convert into fixed point day,,fraction CAIE S,"-" ; East or West of UTC? MOVNS B ; East of UTC, negatate ADDM B,MSGTAD(M) ; offset with timezone ILDB B,A ; get delimiter byte ENDIF. CAIE B,"," ; was it what we expected? RET ; bad delimiter MOVE B,MSGTAD(M) ; get date/time again CAMLE B,MBXRDT ; later than the file read time? AOS MBXNMS ; yes, bump number of recent messages ; Parse size SETZB B,MSGHSZ(M) ; start sizes at 0 DO. ILDB C,A ; get possible size byte CAIN C,";" ; saw terminator? IFSKP. CAIL C,"0" ; no, is it numeric? CAILE C,"9" RET ; bad size character IMULI B,^D10 ; numeric, bump size a decade ADDI B,-"0"(C) ; add in new byte LOOP. ; get next byte ENDIF. ENDDO. MOVEM B,MSGSIZ(M) ; save size ; Parse flags SETZ B, ; start flags at 0 DO. ILDB C,A ; get possible flags byte CAIL C,"0" ; no, is it numeric? CAILE C,"7" IFSKP. LSH B,3 ; numeric, bump flags a octade ADDI B,-"0"(C) ; add in new byte LOOP. ; get next byte ENDIF. ENDDO. MOVEM B,MSGFLG(M) ; save flags IFN. C ; if non-null after flags DO. CAIE C,.CHSPC ; ignore spaces inserted by Hermes RET ; else it is a bogon ILDB C,A ; get next byte JUMPN C,TOP. ; continue if non-null ENDDO. ENDIF. MOVE A,MSGSIZ(M) ; get length of message ADJBP A,MSGPTR(M) ; get pointer after end of this message LDB B,[POINT 30,A,35] ; get address of this pointer LDB C,[POINT 30,TPTR,35] ; and of trailing pointer CAMLE B,C ; message extends past end of file? RET ; sorry, this file is bogus CAME B,C ; at same address as end of file? IFSKP. LDB B,[POINT 6,A,5] ; yes, get position of this pointer LDB C,[POINT 6,TPTR,5] ; and of trailing pointer CAMLE B,C ; if .LE. trailing still could be ok RET ; extends beyond end of file ENDIF. SETZM MSGENV(M) ; don't have any envelope yet AOS B,MBXMGS ; count up another message CAIG B,MAXMGS ; more than we support? LOOP. RET ; too many messages! ENDDO. ENDSV. ENDAV. ; Find header size for message indexed in B FNDHSZ: SAVEAC ACVAR MOVE M,B ; set up index MOVE A,MSGPTR(M) ; get pointer for header SETZM MSGHSZ(M) MOVE B,MSGSIZ(M) ; get size of message DO. ; look for end of header REPEAT 2,< AOS MSGHSZ(M) ; bump header size ILDB C,A ; sniff at next byte CAIE C,.CHCRT ; found CR? SOJG B,TOP. ; no, sniff further SOJLE B,ENDLP. ; yes or end of message, continue or exit AOS MSGHSZ(M) ; bump header size ILDB C,A ; sniff at next byte CAIE C,.CHLFD ; found LF? SOJG B,TOP. ; no, sniff further SOJLE B,ENDLP. ; yes or end of message, continue or exit >;REPEAT 2 ENDDO. MOVE C,MSGHSZ(M) ; return header size RET ENDAV. ; Open current mailbox for write ; CALL MBXWRT ; Returns +1: Failed ; +2: Success, A/ write JFN ; Note: This routine inserts its own unwind mechanism on the stack; ; consequently, any prior STKVAR context is invalidated. TRVAR's are ; okay though. MBXWRT: IFQN. F%RON ; always fail if read-only TAGMSG RET ENDIF. POP P,A ; get return PC of caller SAVEAC ; silly STKVAR > MOVEM A,RETADR ; save return address HRROI A,FILBUF ; get copy of mailbox file name MOVE B,MBXJFN MOVX C,JS%SPC ; entire spec please JFNS% ERCAL FATAL MOVX A,GJ%OLD!GJ%SHT ; now get a write JFN on it HRROI B,FILBUF GTJFN% IFJER. TAGMSG CALL ERROUT JRST @RETADR ENDIF. MOVEM A,MBXJF2 ; save JFN ; Now open the file DO. MOVX B,<!OF%RD!OF%WR!OF%DUD> ; now open for write OPENF% IFJER. CAIE A,OPNX9 ; file busy is probably okay IFSKP. MOVX A,^D2000 ; wait two seconds and try again DISMS% MOVE A,MBXJF2 ; get back JFN LOOP. ENDIF. TAGMSG CALL ERROUT MOVE A,MBXJF2 ; flush the JFN RLJFN% ERJMP .+1 JRST @RETADR ENDIF. ENDDO. AOS CX,RETADR ; file open, set up for "skip" return CALL (CX) ; "return" to caller as coroutine TRNA ; caller wants non-skip AOS (P) ; caller wants skip ; Here to force any file data or FDB updates that were done before HRLZ A,MBXJF2 ; write JFN,,page 0 MOVX B,MBXSCN*^D512 ; all possible file pages UFPGS% ; write the pages ERCAL FATAL GTAD% ; get the time now MOVE C,A ; put it in C for CHFDB% below MOVE A,MBXJF2 ; get back our JFN HRLI A,.FBREF ; prepare to step on read time SETO B, ; change all bits CHFDB% ; set the new read time and update FDB ERCAL FATAL CLOSF% ; close the file ERJMP .+1 ; error shouldn't happen SETZ A, ; trash this AC RET ; return ENDSV. ; Close current mailbox CLSMBX: SAVEAC SETO A, ; unmap the file MOVE B,[.FHSLF,,MBXSEC] ; from mailbox section MOVX C,MBXSCN ; this many sections SMAP% ERCAL FATAL MOVX A,.DEQID ; get rid of any locks we got MOVX B,REQID DEQ% ERJMP .+1 SKIPE A,MBXJFN ; close file off CLOSF% ERJMP .+1 SETZM MBXJFN ; no mailbox selected any more SETO A, ; delete the index page SKIPA B,.+1 ; MACRO is a noisome pile of reptile dung LODIPG:! .FHSLF,,IDXPAG MOVX C,PM%CNT!1 ; 1 page PMAP% ; pffft ERJMP .+1 SKIPE A,IDXJFN ; close index off CLOSF% ERJMP .+1 SETZM IDXJFN ; no index any more SETZM IDXADR SETZM FLGTAB ; clear old keywords MOVE A,[FLGTAB,,FLGTAB+1] BLT A,FLGTAB+NKYFLG-1 MOVE A,[FREE] ; re-initialize free storage pointer MOVEM A,FSFREE RET SUBTTL Miscellaneous subroutines ; Outputs a CRLF CRLF: SAVEAC MOVX A,.PRIOU ; use SOUTR% for non-TTY primary I/O HRROI B,[ASCIZ/ /] SETZ C, SOUTR% ; this pushes the text on networks ERJMP .+1 RET ; Convert a 32-bit quantity in A from squoze to ASCII SQZTYO: IDIVI A,50 ; divide by 50 PUSH P,B ; save remainder, a character SKIPE A ; if A is now zero, unwind the stack CALL SQZTYO ; call self again, reduce A POP P,A ; get character ADJBP A,[POINT 7,[ASCII/ 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ.$%/],6] LDB A,A ; convert squoze code to ASCII PBOUT% RET SUBTTL Error handling ; Common routine called to output last error code's message ERROUT: TMSG < - > MOVX A,.PRIOU HRLOI B,.FHSLF ; dumb ERSTR% SETZ C, ERSTR% JRST ERRUND ; undefined error number NOP ; can't happen RET ERRUND: TMSG MOVX A,.FHSLF ; get error number GETER% MOVX A,.PRIOU ; output it HRRZS B ; only right half where error code is MOVX C,^D8 ; in octal NOUT% ERJMP R ; ignore error here RET ; Various error messages DMPTAG: MOVX A,.PRIOU ; dump current command's tag HRROI B,CMDBUF MOVN C,TAGCNT SOUT% RET BADCOM: TAGMSG DMPCOM: HRROI A,CMDBUF PSOUT% RET BADARG: TAGMSG CALLRET DMPCOM MISARG: TAGMSG CALLRET DMPCOM NOMBX: TAGMSG RET NOTLOG: TAGMSG RET SYNERR: TAGMSG CALLRET DMPCOM ; Fatal errors arrive here FATAL: MOVEM 17,FATACS+17 ; save ACs in FATACS for debugging MOVEI 17,FATACS ; save from 0 => FATACS BLT 17,FATACS+16 ; ...to 16 => FATACS+16 MOVE 17,FATACS+17 ; restore AC17 MOVX A,.PRIIN ; flush TTY input CFIBF% ERJMP .+1 TMSG < * BYE Fatal system error> CALL ERROUT ; output last JSYS error TMSG <, > MOVE A,(P) ; get PC MOVE A,-2(A) ; get instruction which lost CALL SYMOUT ; output symbolic instruction if possible TMSG < at PC > POP P,A SUBI A,2 ; point PC at actual location of the JSYS CALL SYMOUT ; output symbolic name of the PC JRST IMPERR ; Clever symbol table lookup routine. For details, read "Introduction to ; DECSYSTEM-20 Assembly Language Programming", by Ralph Gorin, published by ; Digital Press, 1981. Called with desired value in A. SYMOUT: ACVAR MOVEM A,VAL ; save value SETZB C,SYM ; no current program name or best symbol MOVE D,PDV+.PVSYM ; symbol table vector pointer MOVE A,(D) ; get length of vector DO. CAIGE A,4 ; another block? EXIT. ; no - can't find symbol table LDB B,[POINT 6,1(D),5] ; get type of this table CAIN B,1 ; Radix-50 defined symbols? IFSKP. SUBI A,3 ; no, try next block ADDI D,3 LOOP. ENDIF. LDB C,[POINT 30,1(D),35] ; found it, get table length MOVE D,2(D) ; and table address DO. LDB A,[POINT 4,(D),3] ; symbol type IFN. A ; 0=prog name (uninteresting) CAILE A,2 ; 1=global, 2=local ANSKP. MOVE A,1(D) ; value of the symbol CAME A,VAL ; exact match? IFSKP. MOVE SYM,D ; yes, select it as best symbol EXIT. ENDIF. CAML A,VAL ; smaller than value sought? ANSKP. SKIPE B,SYM ; get best one so far if there is one CAML A,1(B) ; compare to previous best MOVE SYM,D ; current symbol is best match so far ENDIF. ADDI D,2 ; point to next symbol SUBI C,2 ; and count another symbol JUMPG C,TOP. ; loop unless control count is exhausted ENDDO. IFN. SYM ; if a best symbol found MOVE A,VAL ; desired value SUB A,1(SYM) ; less symbol's value = offset CAIL A,200 ; is offset small enough? ANSKP. MOVE A,(SYM) ; symbol name TXZ A, ; clear flags CALL SQZTYO ; print symbol name SUB VAL,1(SYM) ; difference between this and symbol's value JUMPE VAL,R ; if no offset then done MOVX A,"+" ; add + to the output line PBOUT% ENDIF. ENDDO. MOVX A,.PRIOU ; and copy numeric offset to output MOVE B,VAL ; value to output MOVX C,^D8 NOUT% ERJMP R RET ENDAV. SUBTTL Interrupt stuff ; PSI blocks PSITAB: PSIBLN ; length of block 1,,LEVTAB ; level table 1,,CHNTAB ; channel table PSIBLN==.-PSITAB LEVTAB: LEV1PC ; priority level table LEV2PC LEV3PC CHNTAB: PHASE 0 ; channel table COFCHN:!1B5+<1,,COFINT> ; carrier off channel TIMCHN:!2B5+<1,,TIMINT> ; timer channel REPEAT ^D36-.,<0> DEPHASE ; Set up PSIs SETPSI: MOVX A,.FHSLF ; set level/channel tables XMOVEI B,PSITAB XSIR% ERCAL FATAL EIR% ; enable PSIs ERCAL FATAL MOVX B,<1B!1B> ; on these channels AIC% ERCAL FATAL MOVE A,[.TICRF,,COFCHN] ; arm for carrier off interrupts ATI% ; CALLRET SETTIM ; Initialize the timer SETTIM: MOVE A,[.FHSLF,,.TIMEL] ; tick the timer every 5 seconds MOVX B,^D5*^D1000 MOVX C,TIMCHN TIMER% ERCAL FATAL RET ; Timer interrupt TIMINT: DMOVEM A,IN2ACS ; save ACs MOVEM C,IN2ACS+2 AOSGE TIMOUT ; has timer run out yet? IFSKP. MOVX A,.PRIIN ; flush TTY input CFIBF% ERJMP .+1 TMSG < * BYE Autologout; idle for too long> XMOVEI A,IMPERR ; dismiss to quit code TXO A,PC%USR MOVEM A,LEV2PC+1 ELSE. CALL SETTIM ; reinitialize the timer ENDIF. DMOVE A,IN2ACS ; restore ACs MOVE C,IN2ACS+2 DEBRK% ; Carrier-off interrupt COFINT: CALL HANGUP ; hang up the connection DEBRK% ; back out if continued SUBTTL Other randomness ; File defaults POBOX: ASCIZ/POBOX/ ; post office box device BBOARD: ASCIZ/BBOARD/ ; bulletin board directory INBOX: ASCIZ/INBOX/ ; operating-system independent INBOX MAIL: ASCIZ/MAIL/ ; mail file filename TXT: ASCIZ/TXT/ ; mail file extension ; Bits, indexed by their bit position ...BIT==-1 ; init mechanism BITS: REPEAT ^D36,<1B<...BIT==...BIT+1>> ; Literals ...LIT: XLIST ; save trees during LIT LIT ; generate literals ...VAR:!VAR ; generate variables (there shouldn't be any) IFN .-...VAR,<.FATAL Variables illegal in this program> LIST ; Entry vector EVEC: JRST MAPSER ; START address JRST MAPREE ; REENTER address MAPVER ; version EVECL==.-EVEC .ENDPS ; Program Data Vector - filled in by LINK .PSECT PDV,PDVORG ; define PDV psect .ENDPS ; Define start address and version in PDV DEFINE DEFPDV (NAME,DATA) < .TEXT "/PVDATA:'NAME':#'DATA" >;DEFINE DEFPDV DEFPDV START,\CODORG ; define start address DEFPDV VERSION,\MAPVER ; define version END EVECL,,EVEC ; establish entry vector