Trailing-Edge
-
PDP-10 Archives
-
SRI_NIC_PERM_SRC_3_19910112
-
mm-dom/mapser.mac
There are no other files named mapser.mac in the archive.
TITLE MAPSER TOPS-20 Interim Mail Access Protocol II server
SUBTTL Written by Mark Crispin
; Version components
MAPWHO==0 ; who last edited MAPSER (0=developers)
MAPMAJ==6 ; MAPSER's release version (matches monitor's)
MAPMIN==1 ; MAPSER's minor version
MAPEDT==^D344 ; MAPSER's edit version
SEARCH MACSYM,MONSYM ; system definitions
IFNDEF OT%822,OT%822==:1B35
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
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==^D1000> ; 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
MAPVER==<FLD MAPWHO,VI%WHO>!<FLD MAPMAJ,VI%MAJ>!<FLD MAPMIN,VI%MIN>!VI%DEC!<FLD MAPEDT,VI%EDN>
; Routines invoked externally
EXTERN $GTLCL,$RMREL
; AC definitions
F==:0 ; flags
A=:1 ; JSYS, temporary ACs
B=:2
C=:3
D=:4
CX=:16 ; scratch
P=:17 ; stack pointer
; Flags
MSKSTR F%LOG,F,1B0 ; logged in
MSKSTR F%REE,F,1B1 ; reenter
MSKSTR F%NVT,F,1B2 ; on a network terminal, must log out when done
MSKSTR F%EOL,F,1B3 ; EOL seen
MSKSTR F%ELP,F,1B4 ; buffer began with EOL
MSKSTR F%RON,F,1B5 ; read-only file
MSKSTR F%NCL,F,1B6 ; suppress close parenthesis
; Substitute TMSG
DEFINE TMSG (STRING) <
HRROI A,[ASCIZ ~STRING~]
PSOUT%
>;DEFINE TMSG
DEFINE TAGMSG (STRING) <
CALL DMPTAG
TMSG <STRING>
>;DEFINE TAGMSG
; Here's a macro that really should be in MACSYM!
DEFINE ANNJE. <..TAGF (ERJMP,)>
; Fatal assembly error macro
DEFINE .FATAL (MESSAGE) <
PASS2
PRINTX ?'MESSAGE
END
>;DEFINE .FATAL
.CHLPR==:"(" ; work around various macro lossages
.CHRPR==:")"
.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
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
.ENDPS
.PSECT BUFSEC,<PRVSEC,,0>
ARGBUF: BLOCK 400000 ; argument buffer
ARGBSZ==.-ARGBUF
OUTBFR: BLOCK 400000 ; output buffer
.ENDPS
.PSECT FREE,<<PRVSEC+1>,,0>
BLOCK 777777 ; free storage
.ENDPS
.PSECT MBXBUF,<MBXSEC,,0>
BLOCK 1 ; mailbox buffer
.ENDPS
SUBTTL Start of program
.PSECT CODE,CODORG ; pure code
MAPSER: TDZA F,F ; clear flags
MAPREE: MOVX F,F%REE
RESET% ; flush all I/O
MOVE P,[IOWD PDLLEN,PDL] ; init stack context
SETZM INICBG ; clear once-only area
MOVE A,[INICBG,,INICBG+1]
BLT A,INICEN
MOVE A,[FREE] ; initialize free storage pointer
MOVEM A,FSFREE
MOVNI A,TIMOCT ; reset timeout count
MOVEM A,TIMOUT
MOVNI A,LOGMAX ; reset logout count
MOVEM A,LOGCNT
MOVE A,[FLGINI,,FLGTAB+NKYFLG] ; copy initial flags
BLT A,FLGTAB+NKYFLG+NFLINI-1
SETZ A, ; create private section
MOVE B,[.FHSLF,,PRVSEC] ; this process,,our private sections
MOVX C,SM%RD!SM%WR!2 ; read/write access
SMAP%
ERCAL FATAL
CALL SETPSI ; set up PSIs
; Get host info
HRROI A,LCLHST ; get local host name
CALL $GTLCL
IFNSK.
TMSG <* BYE Unable to get local host name>
JRST IMPERR
ENDIF.
HRROI A,LCLHST ; remove relative domain from name we got
CALL $RMREL
; See if top-level fork, and if so assume we're a network server on an NVT.
; Note that all I/O is done via primary I/O. This allows several ways we can
; be set up, e.g.:
; . traditional CRJOB% style running as a job on an NVT
; . on a physical terminal, as in a "TTY network" environment
; . with primary I/O remapped to the network JFN's
GJINF% ; get job info
MOVEM A,MYUSRN ; save my user number
DMOVEM C,MYJOBN ; save job number/TTY number for later use
IFGE. D ; can be NVT server only if attached
MOVX A,.FHSLF ; see what my primary I/O looks like. If
GPJFN% ; AC2 isn't -1 (.CTTRM,,.CTTRM), then we
..TAGF (<AOJN B,>,) ; can assume setup process init'd TTY
MOVX A,.FHTOP ; top fork
SETZ B, ; no handles or status
MOVE C,[-4,,CMDBUF] ; fork structure area
GFRKS% ; look at fork structure
ERJMP .+1 ; ignore error (probably GFKSX1)
HRRZ A,CMDBUF+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 < Interim Mail Access Protocol II Service >
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
DEFINE COMMANDS <
CMD NOOP
CMD LOGIN
CMD LOGOUT
CMD SELECT
CMD CHECK
CMD EXPUNGE
CMD COPY
CMD FETCH
CMD STORE
CMD SEARCH
>;DEFINE COMMANDS
DEFINE CMD (CM) <[ASCIZ/'CM'/],,.'CM>
CMDTAB: COMMANDS ; command names
CMDTBL==.-CMDTAB
BADCOM
SUBTTL Command service routines
; NOOP - no-operation
.NOOP: TAGMSG <OK No-op 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
TAGMSG <OK > ; start acknowledgement
HRROI A,LCLHST ; output our host name
PSOUT%
TMSG < Interim Mail Access Protocol Service logout
* BYE IMAP II terminating connection>
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
; SELECT - select a mailbox
.SELEC: 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
HRROI A,MBXNAM ; compare user's argument
HRROI B,[ASCIZ/INBOX/] ; with special name INBOX
STCMP%
IFE. A ; if user wants the INBOX
MOVX A,<ASCII/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>MAIL.TXT as default to user's argument
MOVSI A,[GJ%OLD!1 ; require extant file, default gen 1
.NULIO,,.NULIO ; only use the string
-1,,[ASCIZ/POBOX/] ; default device
-1,,LGUSRS ; will fill this in
0 ; no default filename
-1,,[ASCIZ/TXT/] ; default extension
0 ; no special default protection
0 ; no special default account
0] ; no special JFN
HRRI A,GTJBLK ; prepare to copy block
BLT A,.GJJFN+GTJBLK ; do it
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 wants the INBOX
HRROI A,FILBUF ; create POBOX:<user>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:<user>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 Select complete>
IFQN. F%RON ; read-only file?
TMSG <, mailbox is read-only>
ENDIF.
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,[ASCIZ/INBOX/] ; with special name INBOX
STCMP%
IFE. A ; if user wants the INBOX
MOVX A,<ASCII/MAIL/> ; he really wants MAIL.TXT
MOVEM A,MBXNAM
ENDIF.
MOVSI A,[1 ; default generation
.NULIO,,.NULIO ; only use the string
-1,,[ASCIZ/POBOX/] ; default device
-1,,LGUSRS ; will fill this in
0 ; no default filename
-1,,[ASCIZ/TXT/] ; default extension
0 ; no special default protection
0 ; no special default account
0] ; no special JFN
HRRI A,GTJBLK ; prepare to copy block
BLT A,.GJJFN+GTJBLK ; do it
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.
MOVEM A,CPYJFN
MOVEM A,.CKAUD+CHKBLK ; JFN of file to check
; Verify access and open for write
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
ENDSV.
; Fetch all for message in B
.FTALL: TQO <F%NCL>
CALL .FTFLG
CALL .FTDAT
CALL .FTSIZ
TQZ <F%NCL>
CALLRET .FTENV
; Fetch all fast attributes for message in B
.FTFST: TQO <F%NCL>
CALL .FTFLG
CALL .FTDAT
TQZ <F%NCL>
CALLRET .FTSIZ
; Fetch envelope for message indexed in B
.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
ENDSV.
ENDAV.
DEFINE SRC (NAME,DSP,ARG) <[ASCIZ/'NAME'/],,[ARG,,DSP]>
SRCTAB: SRC All,RSKP
SRC Answered,.SEANS
SRC Before,.SEBEF,.SEDAT
SRC Deleted,.SEDEL
SRC Flagged,.SEFLG
SRC Keyword,.SEKEY,.SEFLA
SRC New,.SENEW
SRC Old,.SEOLD
SRC On,.SEON,.SEDAT
SRC Recent,.SEREC
SRC Seen,.SESEE
SRC Since,.SESIN,.SEDAT
SRC Text,.SETEX,RSKP
SRC Unanswered,.SEUAN
SRC Undeleted,.SEUDE
SRC Unflagged,.SEUFL
SRC Unkeyword,.SEUKE,.SEFLA
SRC Unseen,.SEUSE
SRCTBL==.-SRCTAB
; Parse a date
.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 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
; The routines in this section are the only routines in the entire IMAP II
; system that know about RFC 822.
; 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,ARGBUF ; point to header line
POINT 7,HEADER] ; and to where we store the item
DMOVEM A,HDRPTR
SETZM HEADER ; init item
SETZM 1+HEADER
SETZM 2+HEADER
MOVEI A,^D15 ; maximum header item length
DO.
ILDB C,HDRPTR ; copy string, converting to uppercase
JUMPE C,ENDLP. ; with appropriate terminating cases...
CAIE C,.CHSPC
CAIN C,.CHTAB
EXIT.
CAIN C,":"
EXIT.
CAIL C,"a"
CAILE C,"z"
TRNA
SUBI C,"a"-"A"
IDPB C,1+HDRPTR
SOJG A,TOP.
ENDDO.
JUMPLE A,TOP. ; can't possibly win if ran out
CAIN C,":" ; saw the delimiter
IFSKP.
CALL SKIPWS
ILDB C,HDRPTR ; get delimiter
CAIE C,":" ; saw appropriate delimiter?
LOOP. ; no, this line can't possibly win then
ENDIF.
; Do appropriate processing for this header line
CALL SKIPWS
DMOVE A,HEADER ; now, get the header item
MOVE C,2+HEADER
CAME A,[ASCII/DATE/]
IFSKP.
MOVE A,HDRPTR ; text to copy
CALL CPYSTR
MOVEM A,ENVDAT(D) ; store the date we parsed
LOOP.
ENDIF.
CAMN A,[ASCII/SUBJE/]
CAME B,[ASCII/CT/]
IFSKP.
MOVE A,HDRPTR ; text to copy
CALL CPYSTR
MOVEM A,ENVSUB(D) ; save pointer to subject in envelope
LOOP.
ENDIF.
CAME A,[ASCII/FROM/]
IFSKP.
MOVE A,HDRPTR ; string to parse
XMOVEI B,ENVFRM(D) ; location to store address list
CALL GETADR ; parse address
LOOP.
ENDIF.
CAMN A,[ASCII/SENDE/]
CAME B,[ASCII/R/]
IFSKP.
MOVE A,HDRPTR ; string to parse
XMOVEI B,ENVSDR(D) ; location to store address list
CALL GETADR ; parse address
LOOP.
ENDIF.
CAMN A,[ASCII/REPLY/]
CAME B,[ASCII/-TO/]
IFSKP.
MOVE A,HDRPTR ; string to parse
XMOVEI B,ENVREP(D) ; location to store address list
CALL GETADR ; parse address
LOOP.
ENDIF.
CAME A,[ASCII/TO/]
IFSKP.
MOVE A,HDRPTR ; string to parse
XMOVEI B,ENVTO(D) ; location to store address list
CALL GETADR ; parse address
LOOP.
ENDIF.
CAME A,[ASCII/CC/]
IFSKP.
MOVE A,HDRPTR ; string to parse
XMOVEI B,ENVCC(D) ; location to store address list
CALL GETADR ; parse address
LOOP.
ENDIF.
CAME A,[ASCII/BCC/]
IFSKP.
MOVE A,HDRPTR ; string to parse
XMOVEI B,ENVBCC(D) ; location to store address list
CALL GETADR ; parse address
LOOP.
ENDIF.
CAMN A,[ASCII/IN-RE/]
CAME B,[ASCII/PLY-T/]
IFSKP.
CAME C,[ASCII/O/]
ANSKP.
MOVE A,HDRPTR ; treat as text for now
CALL CPYSTR
MOVEM A,ENVIRT(D) ; save pointer in envelope
LOOP.
ENDIF.
CAMN A,[ASCII/MESSA/]
CAME B,[ASCII/GE-ID/]
IFSKP.
ANDE. C
MOVE A,HDRPTR ; treat as text for now
CALL CPYSTR
MOVEM A,ENVMID(D) ; save pointer in envelope
LOOP.
ENDIF.
LOOP.
ENDDO.
; Default parts of the envelope
MOVE B,ENVFRM(D) ; default Sender and Reply-to
SKIPN ENVSDR(D) ; set default Sender if none in header
MOVEM B,ENVSDR(D)
SKIPN ENVREP(D) ; set default Reply-to if none in header
MOVEM B,ENVREP(D)
RET
SKIPWS: SAVEAC <A>
DO.
MOVE A,HDRPTR ; skip whitespace
ILDB A,A
CAIE A,.CHSPC
CAIN A,.CHTAB
IFNSK.
IBP HDRPTR
LOOP.
ENDIF.
ENDDO.
RET
ENDTV.
; Get an RFC822 line, called only from GETENV
; Accepts: PTR/ current RFC822 header pointer
; CTR/ number of bytes left in header
; CALL GETLIN
; Returns +1: Didn't get a line
; +2: Got a line in ARGBUF
GETLIN: SAVEAC <A,B,C,D> ; D used as a flag for unparsed text
MOVE A,[OWGP. 7,ARGBUF] ; stash line in here
SETZB D,@[ARGBUF] ; 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,ARGBUF+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,@[ARGBUF] ; 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 @[ARGBUF] ; 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.
; Loop for each address
DO.
DO.
MOVE C,A ; skip leading whitespace
ILDB C,C
CAIE C,.CHSPC
CAIN C,.CHTAB
IFNSK.
IBP A
LOOP.
ENDIF.
ENDDO.
MOVEM A,CURPTR ; init "current pointer"
SETZM NWSPTR ; init "non-whitespace pointer"
; Handle a possible personal name
DO. ; slurp up a phrase
ILDB C,A
JUMPE C,ENDLP. ; end of string
CAIE C,"\" ; quoted character?
IFSKP.
IBP A ; yes, skip next character
MOVEM A,NWSPTR
LOOP.
ENDIF.
CAIE C,"""" ; quoted string?
IFSKP.
DO.
ILDB C,A ; yes, search for unquote
CAIN C,"\" ; in case quoted quote
IBP A
CAIE C,"""" ; found unquote yet?
JUMPN C,TOP. ; nope
ENDDO.
MOVEM A,NWSPTR ; new end of whitespace
ENDIF.
; Deal with the possibility of <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!
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,"<" ; 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?
IFSKP.
MOVX D,ADRLEN ; 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,"<" ; route-addr following?
IFSKP.
SETZ C, ; tie off string we parsed
IDPB C,NWSPTR
MOVE C,CURPTR ; save phrase as personal name
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,">"
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,">" ; 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
ENDTV.
; Flush RFC 822 quotes from string
; Accepts: B/ source/destination string pointer
; CALL FLSQOT
; Returns +1: Always
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
; Output address to buffer
; Accepts: A/ destination buffer poitner
; B/ address
; CALL BFADR
; Returns +1: Always
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
ENDAV.
; Output NIL to buffer
; Accepts: A/ destination buffer poitner
; CALL BFNIL
; Returns +1: Always
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
BFCRLF: IFQE. <F%NCL>
HRROI B,[ASCIZ/)
/]
ELSE.
HRROI B,[ASCIZ/ /]
ENDIF.
; CALLRET BFSOUT
; Output CRLF to buffer, with parenthesis closing if necessary
; Accepts: A/ destination buffer poitner
; B/ source string pointer
; CALL BFSOUT
; Returns +1: Always
BFSOUT: SAVEAC <C>
TXC B,.LHALF ; check for -1 type pointer
TXCN B,.LHALF
HRLI B,<(POINT 7,)>
DO. ; boring string copy...
ILDB C,B
IFN. C
IDPB C,A
LOOP.
ENDIF.
ENDDO.
RET
; Blat a literal from string to buffer
; Accepts: A/ destination buffer pointer
; B/ pointer to string
; C/ length of string
; D/ leading string to output
; CALL BFBLAT
; Returns: +1 Always
BFBLAT: ACVAR <Q0,Q1,Q2,Q3,Q4,Q5> ; get a bunch of AC's
MOVE Q0,C ; source count
MOVE Q1,B ; source byte pointer
SKIPN B,D ; output property name
IFSKP.
CALL BFSOUT
MOVX B,.CHSPC
IDPB B,A
ENDIF.
MOVX B,"{" ; start literal
IDPB B,A
MOVE B,Q0 ; output count
CALL BFNOUT
HRROI B,[ASCIZ/}
/]
CALL BFSOUT
SETZB Q2,Q5 ; we're using 1-word byte pointers
MOVE Q3,C ; destination count
MOVE Q4,A ; destination byte pointer
EXTEND Q0,[MOVSLJ ; blat the string
0] ; with a zero fill
CALL MOVBOG ; this absolutely cannot happen
IFE. Q5 ; got a OWGBP or a GBP?
MOVE A,Q4 ; this microcode gives us a OWGBP back
ELSE.
TLC Q4,000740 ; clear bits for "global POINT 7,0,35"
TXNE Q4,<MASKB 6,35> ; make sure no bozo bits set
CALL MOVBOG
LDB Q0,[POINT 6,Q4,5] ; get position
IDIVI Q0,7 ; divide by bytesize
CAIG Q0,OWG7SZ
CAIE Q1,1 ; is remainder correct?
CALL MOVBOG ; foo
MOVE A,OWG7TB(Q0) ; get correct pointer
DPB Q5,[POINT 30,A,35] ; fill in GBP address
ENDIF.
RET
ENDAV.
RADIX 10
OWG7TB: OWGP. 7,0,34
OWGP. 7,0,27
OWGP. 7,0,20
OWGP. 7,0,13
OWGP. 7,0,6
OWGP. 7,0 ; I don't think this can happen
OWG7SZ==.-OWG7TB
RADIX 8
MOVBOG: TAGMSG <NO Impossible MOVSLJ error -- please report this!!>
JRST IMPERR
SUBTTL Free storage routines
; Carve out a piece of free storage
; Accepts: D/ length of desired block
; CALL FSGET
; Returns +1: Always, with address of block in D
FSGET: SAVEAC <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 pointer
; 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] ; aligned to word boundary already?
CAIN Q1,66
JSP D,SEARQ ; yes, pattern may begin within this word
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
ENDSV.
SUBTTL Sequence handling routines
; Store sequence
; Accepts: B/ sequence
; C/ sequence bit vector
; CALL STOSEQ
; Returns: +1: Failure
; +2: Success
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
; Return size of file
; Accepts: A/ JFN of file
; CALL FILSIZ
; Returns: +1 Always, A/ file size
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
; Map mailbox
; CALL MAPMBX
; Returns +1: Failure
; +2: Success
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
SOJL 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
SOJL 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
ERROUT: TMSG < - >
MOVX A,.PRIOU
HRLOI B,.FHSLF ; dumb ERSTR%
SETZ C,
ERSTR%
JRST ERRUND ; undefined error number
NOP ; can't happen
RET
ERRUND: TMSG <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
BADCOM: TAGMSG <BAD Command unrecognized: >
DMPCOM: HRROI A,CMDBUF
PSOUT%
RET
BADARG: TAGMSG <BAD Argument given when none expected: >
CALLRET DMPCOM
MISARG: TAGMSG <BAD Missing required argument: >
CALLRET DMPCOM
NOMBX: TAGMSG <NO No mailbox selected>
RET
NOTLOG: TAGMSG <NO Not logged in yet>
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
ENDAV.
SUBTTL Interrupt stuff
; PSI blocks
PSITAB: PSIBLN ; length of block
1,,LEVTAB ; level table
1,,CHNTAB ; channel table
PSIBLN==.-PSITAB
LEVTAB: LEV1PC ; priority level table
LEV2PC
LEV3PC
CHNTAB: PHASE 0 ; channel table
COFCHN:!1B5+<1,,COFINT> ; carrier off channel
TIMCHN:!2B5+<1,,TIMINT> ; timer channel
REPEAT ^D36-.,<0>
DEPHASE
; Set up PSIs
SETPSI: MOVX A,.FHSLF ; set level/channel tables
XMOVEI B,PSITAB
XSIR%
ERCAL FATAL
EIR% ; enable PSIs
ERCAL FATAL
MOVX B,<1B<TIMCHN>!1B<COFCHN>> ; on these channels
AIC%
ERCAL FATAL
MOVE A,[.TICRF,,COFCHN] ; arm for carrier off interrupts
ATI%
; CALLRET SETTIM
; Initialize the timer
SETTIM: MOVE A,[.FHSLF,,.TIMEL] ; tick the timer every 5 seconds
MOVX B,^D5*^D1000
MOVX C,TIMCHN
TIMER%
ERCAL FATAL
RET
; Timer interrupt
TIMINT: DMOVEM A,IN2ACS ; save ACs
MOVEM C,IN2ACS+2
AOSGE TIMOUT ; has timer run out yet?
IFSKP.
MOVX A,.PRIIN ; flush TTY input
CFIBF%
ERJMP .+1
CALL CRLF ; output CRLF
TMSG <* BYE Autologout; idle for too long>
MOVE A,[PC%USR!IMPERR] ; dismiss to quit code
MOVEM A,LEV2PC+1
ELSE.
CALL SETTIM ; reinitialize the timer
ENDIF.
DMOVE A,IN2ACS ; restore ACs
MOVE C,IN2ACS+2
DEBRK%
; Carrier-off interrupt
COFINT: CALL HANGUP ; hang up the connection
DEBRK% ; back out if continued
SUBTTL Other randomness
; Bits, indexed by their bit position
...BIT==-1 ; init mechanism
BITS: REPEAT ^D36,<1B<...BIT==...BIT+1>>
; Literals
...LIT: XLIST ; save trees during LIT
LIT ; generate literals
...VAR:!VAR ; generate variables (there shouldn't be any)
IFN .-...VAR,<.FATAL Variables illegal in this program>
LIST
; Entry vector
EVEC: JRST MAPSER ; START address
JRST MAPREE ; REENTER address
MAPVER ; version
EVECL==.-EVEC
.ENDPS
; Program Data Vector - filled in by LINK
.PSECT PDV,PDVORG ; define PDV psect
.ENDPS
; Define start address and version in PDV
DEFINE DEFPDV (NAME,DATA) <
.TEXT "/PVDATA:'NAME':#'DATA"
>;DEFINE DEFPDV
DEFPDV START,\CODORG ; define start address
DEFPDV VERSION,\MAPVER ; define version
END EVECL,,EVEC ; establish entry vector