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==0 ; MAPSER's minor version
MAPEDT==^D352 ; 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 1064, and documented online on the Internet as:
; [NIC.DDN.MIL]RFC:RFC1064.TXT
;
; MAPSER also implements the read-only/read-write notification, FIND, BBOARD,
; and VERSION extensions.
;
; 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,<PDVORG==1,,1000> ; PDV's on page 1001
IFNDEF CODORG,<CODORG==1,,2000> ; code on page 1002
IFNDEF DATORG,<DATORG==1,,30000> ; data on page 1030
IFNDEF PRVSEC,<PRVSEC==2> ; first of two private data sections
IFNDEF MBXSEC,<MBXSEC==PRVSEC+2> ; mailbox section
IFNDEF MBXSCN,<MBXSCN==37-MBXSEC> ; number of mailbox buffer sections
IFNDEF TIMOCT,<TIMOCT==^D<12*60>> ; number of 5-second ticks before autologout
IFNDEF LOGMAX,<LOGMAX==5> ; maximum number of login tries
IFNDEF TXTLEN,<TXTLEN==^D10000> ; length of a text line
IFNDEF ARGLEN,<ARGLEN==^D39> ; length of a string argument
IFNDEF HSTNML,<HSTNML==^D64> ; length of a host name
IFNDEF UXPAG,<UXPAG==20> ; page number of date vector in index file
UXADR==UXPAG*1000 ; address of date vector
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
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 <PDLLEN==:600> ; stack
FRKS: BLOCK <FKSLEN==4> ; readin area for GFRKS%
CMDBUF: BLOCK <TXTLEN/5>+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 <HSTNML/5>+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 <TXTLEN/5>+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 <MAXMGS*MSGLEN> ; space for many many messages
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 (<AOJN B,>,) ; 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!<FLD .TTASC,TT%DAM>!<FLD .TTLDX,TT%DUM>]
SFMOD% ; has formfeed, tab, lowercase, all wakeup,
STPAR% ; no translate ASCII, line half-duplex
DMOVE B,[BYTE (2)2,2,2,0,2,2,2,2,2,2,2,2,2,2,2,2,2,2
BYTE (2)2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2]
SFCOC% ; disable all echoing on controls
MOVX A,TL%CRO!TL%COR!TL%SAB!.RHALF ; break and refuse links
MOVX B,.RHALF
TLINK%
ERCAL FATAL
MOVX A,.PRIIN ; refuse system messages
MOVX B,.MOSNT
MOVX C,.MOSMN
MTOPR%
ERCAL FATAL
MOVE A,[SIXBIT/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 > ; start banner
HRROI A,LCLHST ; output host name
PSOUT%
TMSG < Interactive Mail Access Protocol server >
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+<TXTLEN/5>
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 <A,B,C,D>
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
VERSI: STKVAR <<VERSIO,<<ARGLEN/5>+1>>>
HRROI A,VERSIO ; copy version
MOVX C,ARGLEN+1 ; bounded by this many characters
CALL ARGCPY
RET
JUMPN B,BADARG ; no arguments after this
HRROI A,VERSIO ; parse version
MOVX C,^D10 ; in decimal
NIN%
ERJMP SYNERR
LDB A,A ; sniff at terminator
CAIE A,"." ; in case this is given
JUMPN A,SYNERR ; barf if non-null
JUMPLE B,SYNERR ; versions .LE. 0 are bad
CAIGE B,4 ; versions .GE. 4 are unimplemented
IFSKP.
TAGMSG <NO Unsupported version>
RET
ENDIF.
TAGMSG <OK Version accepted>
RET
; LOGIN - log in to mail service
LOGIN: STKVAR <<ACCBLK,.ACJOB+1>,<USRNAM,<<ARGLEN/5>+1>>,<PASSWD,<<ARGLEN/5>+1>>>
IFQN. F%LOG ; make sure not doing this twice
TAGMSG <NO Already logged in>
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 <NO Error in user name>
CALLRET ERROUT
ENDIF.
IFXN. A,RC%NOM!RC%AMB ; bogus name?
TAGMSG <NO Invalid user name>
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 <NO Too many login failures, go away>
JRST IMPERR
ENDIF.
TAGMSG <NO Login failed>
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 <NO Too many login failures, go away>
JRST IMPERR
ENDIF.
TAGMSG <NO Login failed>
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 <OK User >
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 DEC-20 IMAP server terminating connection
>
TAGMSG <OK > ; start acknowledgement
HRROI A,LCLHST ; output our host name
PSOUT%
TMSG < Interactive Mail Access Protocol server logout>
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 <FNDJFN,TMPPTR,<CHKBLK,.CKAUD+1>,<GTJBLK,.GJJFN+1>,<MBXNAM,<<ARGLEN/5>+1>>,<FILBUF,^D60>>
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:<loginuser>.TXT as default to user's argument for
; FIND MAILBOXES command and POBOX:<BBOARD>{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/:</] ; delimit
SOUT%
HRROI B,BBOARD ; fill in directory name
SOUT%
MOVX B,.CHRAB ; delimit
IDPB B,A
HRROI B,MBXNAM ; fill in filename
SOUT%
MOVX B,"." ; delimit
IDPB B,A
HRROI B,TXT ; fill in extension
SOUT%
HRROI B,[ASCIZ/.1/] ; and generation
SOUT%
MOVX A,GJ%OLD!GJ%IFG!GJ%SHT ; require extant file, wildcards, short
HRROI B,FILBUF
ELSE.
MOVX A,GJ%OLD!GJ%IFG!1 ; require extant file, wildcards, 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
ENDIF.
GTJFN%
IFJER.
TAGMSG <NO Can't FIND anything>
CALLRET ERROUT
ENDIF.
; Have JFN, validate access and report it if OK
IFXN. A,GJ%DEV!GJ%UNT!GJ%DIR ; check for possible crackers...
HRRZ A,FNDJFN ; flush the JFN
RLJFN%
ERJMP .+1
TAGMSG <NO Can't FIND such a mailbox>
RET
ENDIF.
MOVEM A,FNDJFN
MOVE B,[OWGP. 7,OUTBFR] ; initialize buffer pointer
MOVEM B,TMPPTR
DO.
HRRZS A ; only want JFN
MOVX B,.CKADL ; check list 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
IFN. A ; access ok?
MOVE A,TMPPTR ; yes, get buffer pointer
IFQN. F%BBD ; which sort of FIND?
HRROI B,[ASCIZ/* BBOARD /]
CALL BFSOUT
MOVX C,<FLD .JSAOF,JS%NAM> ; 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. <LOOP.> ; 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
HRRZ A,FNDJFN ; flush the JFN
RLJFN%
ERJMP .+1
TAGMSG <OK FIND completed>
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 <<CHKBLK,.CKAUD+1>,INIJFN,<GTJBLK,.GJJFN+1>,<MBXNAM,<<ARGLEN/5>+1>>,<FILBUF,^D60>>
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:<loginuser>.TXT as default to user's argument for
; SELECT command and POBOX:<BBOARD>.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 <NO Can't get mailbox>
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 <NO Can't access mailbox>
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,<<FLD 7,OF%BSZ>!OF%RD> ; now open for read
OPENF%
IFJER.
TAGMSG <NO Can't open mailbox>
CALL ERROUT
MOVE A,MBXJFN ; flush the JFN
RLJFN%
ERJMP .+1
SETZM MBXJFN ; and note no file open
RET
ENDIF.
MOVX A,<ENQBLS,,ENQBLL> ; 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:<user>file-name.IDX
MOVE B,MBXJFN
MOVX C,<<FLD .JSAOF,JS%DEV>!<FLD .JSAOF,JS%DIR>!<FLD .JSAOF,JS%NAM>!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,<FLD .JSAOF,JS%NAM>
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:<directory>file-name.MM-INIT
MOVE B,MBXJFN
MOVX C,<<FLD .JSAOF,JS%DEV>!<FLD .JSAOF,JS%DIR>!<FLD .JSAOF,JS%NAM>!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:<directory>MM.INIT
MOVX C,<<FLD .JSAOF,JS%DEV>!<FLD .JSAOF,JS%DIR>!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,<<FLD 7,OF%BSZ>!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 <OK >
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<NKYFLG+<.-FLGINI>>
-1,,[ASCIZ/\'STRING'/]
>;DEFINE FLAG
FLGINI: FLAG XXXX
FLAG YYYY
FLAG Answered
FLAG Flagged
FLAG Deleted
FLAG Seen
IFN <NFLINI-<.-FLGINI>>,<.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. <TAGMSG <OK Check completed>>
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 <FSTCHK>
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. <RETSKP>
CAML A,MBXBSZ ; did it shrink?
IFSKP.
TAGMSG <BYE Message file byte size appears to have shrunk>
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 <OK EXPUNGE ignored for read-only file>
RET
ENDIF.
ACVAR <M,Q0,Q1,Q2,Q3,Q4,Q5>
TRVAR <MBXJF2,EXPMSG>
; See if there are any deleted messages to expunge
SKIPE A,MBXMGS ; get number of messages
IFSKP.
TAGMSG <OK Mail file empty> ; 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 <OK No messages deleted, so no update needed>
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 <NO Mailbox in use by another process, try again later>
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, ; -<msgs+1>,,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]
SOUTR%
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,<MASKB 6,35> ; 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,<FLD 7,FB%BSZ> ; 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 <OK All messages expunged, file deleted>
ELSE.
CALL FCHECK ; now do a full check
RET
TAGMSG <OK Expunged > ; 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 <<CHKBLK,.CKAUD+1>,CPYJFN,<GTJBLK,.GJJFN+1>,<MBXNAM,<<ARGLEN/5>+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 <NO Can't get destination mailbox>
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 <NO Can't access destination mailbox>
MOVE A,CPYJFN ; flush the JFN
RLJFN%
ERJMP .+1
SETZM CPYJFN ; and note no file open
RET
ENDIF.
MOVE A,CPYJFN
MOVX B,<<FLD 7,OF%BSZ>!OF%APP> ; now open for append
OPENF%
IFJER.
TAGMSG <NO Can't open mailbox>
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. <TAGMSG <OK Copy completed>>
MOVE A,CPYJFN ; now close off the file
CLOSF%
ERCAL FATAL
RET ; all done
; Routine to copy a single message
CPYMSG: SAVEAC <A,B,C>
ACVAR <M>
STKVAR <MSG>
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,<NO%LFL!NO%ZRO!NO%MAG!<FLD ^D12,NO%COL>!<FLD ^D8,NO%RDX>>
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 <NO Unable to copy message >
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 <ATTPTR,<ATTLST,MAXATT+2>>
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 <F%NCL>] ; 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 <address> instruction
MOVEM C,(D) ; store the instruction
AOBJN D,TOP. ; get next attribute
TAGMSG <NO Too many attributes for FETCH>
RET
ENDDO.
CAIE A,")" ; saw a close paren?
JRST SYNERR
MOVE A,[TQZ <F%NCL>] ; this attribute is the last one
MOVEM A,(D) ; store the instruction
HRLI C,<(CALLRET)> ; make a CALLRET <address> 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 <F%NCL> ; 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. <TAGMSG <OK Fetch completed>>
RET
FTENV: SAVEAC <B,C,D>
ACVAR <M>
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 <B,C,D>
ACVAR <M,FLG,FLGX> ; FLGX must be FLG+1
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
ANDN. FLG ; any flags set?
MOVX B,.CHSPC ; yes, output delimiter
IDPB B,A
ENDIF.
IFN. FLG ; any flags set?
DO.
JFFO FLG,.+2 ; get bit position
EXIT. ; last bit in this word
SKIPE B,FLGTAB(FLGX) ; is this flag defined?
IFSKP.
HRROI B,[ASCIZ/\UndefinedFlag#/]
CALL BFSOUT
MOVE B,FLGX ; bit to output
CALL BFNOUT
ELSE.
CALL BFSOUT ; defined flag, output it
ENDIF.
ANDCM FLG,BITS(FLGX) ; clear this flag
IFN. FLG
MOVX B,.CHSPC ; delimit with space
IDPB B,A
LOOP.
ENDIF.
ENDDO.
ENDIF.
MOVEI B,")"
IDPB B,A
CALLRET BFCRLF
ENDAV.
; Fetch internal date in B
FTDAT: SAVEAC <B,C,D>
ACVAR <M>
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 <B,C>
ACVAR <M>
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 <B,C,D>
ACVAR <M>
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 <B,C,D>
ACVAR <M>
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 <B,C,D>
ACVAR <M>
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 <OK STORE ignored for read-only file>
RET
ENDIF.
STKVAR <ARGDSP>
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. <TAGMSG <OK Store completed>>
RET
ENDSV.
STBAD: TAGMSG <BAD Not valid to store this attribute>
RETSKP
STNIM: TAGMSG <NO Store not implemented yet for this attribute>
RETSKP
; Store flags for message in B
STFLG: SAVEAC <C>
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 <C>
ACVAR <M>
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 <C>
ACVAR <M>
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 <NO Mailbox is empty>
RET
ENDIF.
ACVAR <<VEC,2>,SEQ,PTR>
STKVAR <CURPTR>
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 <OK SEARCH completed>
RET
SEDAT: SAVEAC <A,B,C,D>
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 <A,B,C>
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 <NO Undefined flag>
RET
ENDIF.
ENDDO.
MOVE A,BITS(C) ; get the flag
MOVEM A,ATOM
RETSKP
; Skip if text matches
SETEX: SAVEAC <A,B>
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 <A,B,C>
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 <A,B,C,D>
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 <B,D>
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 <B,D>
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 <B,D>
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 <B,D>
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 <ADR>
SKIPN ADR,D ; get address list
RET ; if empty address always fails
SAVEAC <A,B,C,D>
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 <A>
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 <A>
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 <A>
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 <A>
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 <A>
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 <A>
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 <A>
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 <A>
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 <A>
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 <A>
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 <A>
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 <A>
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 <A>
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 <A>
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 <A>
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 <A,B,C>
ACVAR <M,PTR,CTR>
TRVAR <<HDRPTR,2>,<HEADER,3>>
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
; 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 <A,B,C,D> ; 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 <C,D>
TRVAR <CURPTR,NWSPTR,GRPCNT>
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.
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 <group>: <stuff> ;
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. <MOVEM A,NWSPTR> ; 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. <MOVEM A,NWSPTR>
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.
ENDIF.
; 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
JUMPN A,TOP. ; parse remainder of string
ENDDO.
RET
FLSQOT: SAVEAC <A,C>
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
BFADR: ACVAR <ADR>
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
BFNIL: SAVEAC <B>
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 <C,D>
ACVAR <PTR,FLG>
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 <B,C>
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
; 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 <A>
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 <SRC>
MOVEM A,SRC
MOVE A,[OWGP. 7,0] ; copy remainder of line to free storage
ADD A,FSFREE
SAVEAC <A,C> ; 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 <C,D>
ACVAR <M>
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 <A,B,D>
ACVAR <PTR,LST>
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 <NO Undefined flag>
RET
ELSE. ; here if found flag at end of line
ANDN. LST ; was end of list required?
TAGMSG <BAD Unterminated flag list>
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 <A,B,C,D>
ACVAR <M,FLG>
MOVEI M,-1(B) ; determine index into data structure
IMULI M,MSGLEN
TRVAR <JFN>
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 <NO Can't locate flags for this message>
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 <NO Improperly formatted flags for this message>
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,<MBXBUF/1000> ; 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 <B,D>
ACVAR <Q1,Q2,Q3,Q4,Q5,Q6>
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 <D>
STKVAR <DEST,PTR>
TLC A,-1 ; is LH -1?
TLCN A,-1
HRLI A,(<POINT 7,>) ; 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 <BAD Literal argument too long>
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 <BAD Quoted argument too long>
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 <BAD Atomic argument too long>
ELSE.
AOJL C,TOP. ; otherwise get more bytes
TAGMSG <BAD Wholeline argument too long>
ENDIF.
RET
ENDDO.
ENDIF.
ENDIF.
MOVE C,ATOM ; return argument length
RETSKP
STOSEQ: SAVEAC <A,B>
IFG. B ; must be .GE. 1
CAMLE B,MBXMGS ; and .LE. number of messages
ANSKP. ; was it?
ELSE. ; clearly not!
TAGMSG <NO Message sequence not in range>
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 <A,B,C>
ACVAR <<VEC,2>,SEQ,PTR>
STKVAR <TYPE,DSP>
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]
SOUTR%
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 <C>
STKVAR <SEQTMP>
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 <ATTPTR>
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 <BAD Invalid attribute requested>
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
FILSIZ: SAVEAC <B,C>
STKVAR <<MBXSIZ,<.FBSIZ+1-.FBBYV>>>
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 <NO Message file is not in TOPS-20 mail format>
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
MAPMBX: SAVEAC <A,B,C>
STKVAR <MBXPGS>
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 <NO Message file doesn't have valid size>
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 <NO Message file too large>
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 <A,B,C,D>
ACVAR <M> ; holds current message
STKVAR <TPTR,<HDRBUF,HDRBFL>>
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
CAMLE B,MBXRDT ; later than the file read time?
AOS MBXNMS ; yes, bump number of recent messages
LDB B,A ; get delimiter
CAIE B,"," ; was it what we expected?
RET ; bad delimiter
; 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 <A,B>
ACVAR <M>
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 <NO Can't get read-only mailbox for write>
RET
ENDIF.
POP P,A ; get return PC of caller
SAVEAC <B,C> ; silly
STKVAR <RETADR,MBXJF2,<FILBUF,^D60>>
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 <NO Can't get mailbox for write>
CALL ERROUT
JRST @RETADR
ENDIF.
MOVEM A,MBXJF2 ; save JFN
; Now open the file
DO.
MOVX B,<<FLD 7,OF%BSZ>!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 <NO Can't open mailbox for write>
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 <A,B,C>
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 <A,B,C>
MOVX A,.PRIOU ; use SOUTR% for non-TTY primary I/O
HRROI B,[ASCIZ/
/]
SETZ C,
SOUTR% ; this pushes the text on networks
ERJMP .+1
RET
; Convert a 32-bit quantity in A from squoze to ASCII
SQZTYO: IDIVI A,50 ; divide by 50
PUSH P,B ; save remainder, a character
SKIPE A ; if A is now zero, unwind the stack
CALL SQZTYO ; call self again, reduce A
POP P,A ; get character
ADJBP A,[POINT 7,[ASCII/ 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ.$%/],6]
LDB A,A ; convert squoze code to ASCII
PBOUT%
RET
SUBTTL Error handling
; Common routine called to output last error code's message
ERRUND: TMSG <Undefined error >
MOVX A,.FHSLF ; get error number
GETER%
MOVX A,.PRIOU ; output it
HRRZS B ; only right half where error code is
MOVX C,^D8 ; in octal
NOUT%
ERJMP R ; ignore error here
RET
; Various error messages
DMPTAG: MOVX A,.PRIOU ; dump current command's tag
HRROI B,CMDBUF
MOVN C,TAGCNT
SOUT%
RET
SYNERR: TAGMSG <BAD Syntax error in command: >
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
CALL CRLF ; new line first
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 <SYM,VAL>
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,<MASKB 0,3> ; 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
..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