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