TITLE MAILST List queued mail files from MAILQ: and user's directory
SUBTTL Written by Tom Miles from QDMAIL
SEARCH MACSYM,MONSYM ;System definitions
SALL ;Suppress macro expansions
.DIRECTIVE FLBLST ;Sane listings for ASCIZ, etc.
.REQUIRE HSTNAM ;Host name routines
.REQUIRE SYS:MACREL ;MACSYM support routines
.TEXT "MAILST/SAVE" ;Save as MAILST.EXE
.TEXT "/SYMSEG:PSECT:CODE" ;Put symbol table and patch area in CODE
VWHO==0
VMAJOR==6 ;TOPS-20 release 6.1
VMINOR==1
VMLST==^D11 ;MAILST's version number
; *******************************************************************
; * *
; * QDMAIL is a program to scan the connected directory for various *
; * queued mail files and to print out the file type and *
; * destination host. It is adapted from MMAILR. *
; * *
; * MAILST is the server portion of the mail status program and runs*
; * in conjunction with MSTAT. See MSTAT.MAC for further description*
; * of mail status operating modes. MAILST is a modified version of *
; * QDMAIL. *
; * *
; *******************************************************************
; Routines invoked externally
EXTERN $GTLCL
SUBTTL Conditional Assembly
IFNDEF FTOMLR,<FTOMLR==1> ; Non-zero to process old queue files
IFNDEF DATORG,<DATORG==1000> ;Data on page 1
IFNDEF CODORG,<CODORG==10000> ;Code on page 10
IFNDEF PAGORG,<PAGORG==30000> ;Paged data on page 30
IFNDEF FREORG,<FREORG==40000> ;Free storage starts at page 40
SUBTTL Definitions
F==0
A=1
B=2
C=3
D=4
E=5
T=6
TT=7
M=10
N=11
O=12
X=14
Y=15
Z=16
P=17
; Character definitions
CHDEL==177 ;Delete
EOL=.CHCUN ;End of line for PRINT UUO
; Local UUO's
OPDEF PRINT [1B8]
OPDEF UTYPE [2B8]
OPDEF UETYPE [3B8]
OPDEF UERR [4B8]
; The following print macros do output only if PRINTP is set
DEFINE TYPE (X)
< UTYPE [ASCIZ /X/] ; Just type string
>
DEFINE CTYPE (X)
< UTYPE 10,[ASCIZ /X/] ; Do crlf and type string
>
DEFINE CITYPE (X)
< UTYPE 1,[ASCIZ /X/] ; Conditional crlf and type string
>
DEFINE ETYPE (X)
< UETYPE [ASCIZ /X/] ; Type string (fmt codes)
>
DEFINE CETYPE (X)
< UETYPE 10,[ASCIZ /X/] ; Do crlf and type string (fmt codes)
>
DEFINE CIETYP (X)
< UETYPE 1,[ASCIZ /X/] ; Conditional crlf and type str (fmt codes)
>
DEFINE DEFERR (X,Y)
< DEFINE X (Z)
< IFIDN <Z>,<>,<UERR Y,0>
IFDIF <Z>,<>,<UERR Y,[ASCIZ /Z/]>
>
>
DEFERR WARN,3
DEFERR JWARN,7
DEFERR FATAL,12
DEFERR JFATAL,16
SUBTTL Impure storage
LOC 41
JSR UUOH
.PSECT PAGDAT,PAGORG ;Declare PAGDAT PSECT
.ENDPS
.PSECT FRESTG,FREORG ;Declare FRESTG PSECT
FSPAG==FREORG/1000
.ENDPS
.PSECT DATA,DATORG ;Enter data area
CORBEG==. ;Start of core initialized at startup
PRINTP: BLOCK 1 ;If messages should print out
NPDL==177 ;Size of stack
PDL: BLOCK NPDL ;Pushdown list
MPP: BLOCK 1 ;Saved stack ptr for SAVACS/RSTACS
SAVEP: BLOCK 1 ;Place to save stack ptr in local rtns
PGTBLL==<1000-FSPAG+^D35>/^D36
PAGTBL: BLOCK PGTBLL ;Bit table
FREPTR: BLOCK 1 ;Tail,,head for free block list
PLINBP: BLOCK 2 ;Start of line in parser
PWSPBP: BLOCK 2 ;Byte pointer of start of line after whitespace
PCLNBP: BLOCK 2 ;Where there was a colon
PDELBP: BLOCK 2 ;Where there was a rubout
PDELB2: BLOCK 2 ;Where it ends
;;; Structure of a mail file set up block
DEFINE DFMBLK(SYM)<
SYM==MSGLEN
MSGLEN==MSGLEN+1
>;End DEFINE
MSGLEN==0 ;Initialize length of block
DFMBLK(MSGPAG) ;Starting -# pgs,,starting core page
DFMBLK(MSGJFN) ;File JFN
DFMBLK(MSGWRT) ;Time msg was queued
DFMBLK(MSGAFT) ;Time to attempt delivery
DFMBLK(MSGNTF) ;Time to tell sender of delivery status
DFMBLK(MSGDEQ) ;Time to dequeue the msg -- dead letter
MSGBLK: BLOCK MSGLEN
DIRNUM: BLOCK 1 ;Directory being hacked
FILIDX: BLOCK 1 ;File tbl index for queued file type
IFN FTOMLR,<
OMLRBF: BLOCK 20 ;Buffer for address strings (old MAILER)
>;IFN FTOMLR
INUUO: BLOCK 1 ;Safety check to prevent recursive UUO's
TEMPAC: BLOCK 1 ;Temp ac storage
NUPDL==20 ;Size of UUO PDL
UUOPDL: BLOCK NUPDL ;Pushdown list for processing UUO's
UUOACS: BLOCK 20 ;ACs saved over UUO
INTPC: BLOCK 1 ;Interrupt PC
INTACS: BLOCK 4 ;ACs saved over interrupt
LHOST: BLOCK 1 ;Address of site entry for local host
NCKNMF: BLOCK 1 ;Non-zero if host name was a nickname
HSTBFL==30
HSTBUF: BLOCK HSTBFL ;Put string of a host here
STRBUF: BLOCK 1000 ;String buffer, used globally
STRBF1: BLOCK 1000 ;Alternative string buffer, used locally
USRMCH: BLOCK 1 ;User name match flag (0=no match, -1=match)
FNDFLG: BLOCK 1 ;File found flag (0=none found, -1=found)
MQDIR: BLOCK 1 ;MAILQ: directory number
SPECBF: BLOCK 1000 ;Buffer for creating a dummy header for
; Special network queue-file
MSDIR: BLOCK 1 ;MAILS: directory number
RCVFLG: 0 ;IPCF receive PDB - flags word
SNDPID: 0 ;Sender's PID
RCVPID: 0 ;Receiver's PID
RCVBF: 0 ;Buffer length,,Address
USRDIR: BLOCK 1 ;User's login user number
PRVFLG: BLOCK 1 ;User has WHL!OPR priv's if -1
USRSTR: BLOCK 8 ;User's name string
TTYNUM: BLOCK 1 ;User's controlling TTY number
BLOCK 2 ;Dummy
COREND==.-1 ;End of core initialized at startup
; Storage for IPCF communications with User portion
PIDGET: IP%CPD ;Create a PID to use as sender's PID
PIDNUM: 0 ;PID of sender
0 ;PID of receiver (0 for INFO)
END1-.,,.+1 ;length,,addr of message
1,,.IPCII ;assign name to PID
0 ;no duplicates to receive INFO response
PIDNAM: ASCIZ/[SYSTEM]MAILST/ ;name to assign
END1==.-1
RCVACK: ASCIZ/ACK/ ;Response to User portion
DEBUG: 0 ;If debugging
;; Routine to save AC's
SAVACS: 0 ;JSR here to save all ACs on stack
JRST [ PUSH P,MPP
ADJSP P,17
MOVEM P,MPP
MOVEM 16,(P)
MOVEI 16,-16(P)
BLT 16,-1(P)
JRST @SAVACS]
;; Routine to restore AC's
RSTACS: 0 ;JSR here to restore ACs
JRST [ MOVSI 16,-16(P)
BLT 16,16
ADJSP P,-17
POP P,MPP
JRST @RSTACS]
.ENDPS
SUBTTL Pure storage
.PSECT CODE,CODORG
BITS:
..BIT==0
REPEAT <^D36>,<
1B<...BIT>
...BIT==...BIT+1
>;REPEAT <^D36>
; Following are definitions and a table of file names/processing
; functions to handle delivery of various queued mail formats:
DEFINE FILXX(GSTR,PSTR,PRCHDR,PRCTXT,FLGS)<
FL%STR==0
[ASCIZ `GSTR`],,[ASCIZ `PSTR`] ; File group name string and
; printing descriptor
FL%PRC==1
PRCHDR,,PRCTXT ; Setup routines for processing
; header/text
FL%FLG==2
FLGS
FL%LEN==3
>;DEFINE FILXX
; Control flags for processing names
FF%OML==1B0 ;Old style queue file (adr in extension)
FILTBL:
FILXX(<[--QUEUED-MAIL--].NEW*>,<[New Queued Mail]>,GQUEKY,GQUEH1,0)
FILXX(<[--QUEUED-MAIL--].NETWORK>,<[Network Queued Mail]>,GQUEKY,GQUEH1,0)
FILXX(<[--QUEUED-MAIL--].RETRANSMIT>,<[Retransmit Queued Mail]>,GQUEKY,GQUEH1,0)
FILXX(<[--RETURNED-MAIL--].>,<[Nondelivery Reply]>,GQUEKY,GQUEH1,0)
FILXX(<[--RETURNED-MAIL--].NETWORK>,<[Network Nondelivery Reply]>,GQUEKY,GQUEH1,0)
FILXX(<[--RETURNED-MAIL--].RETRANSMIT>,<[Retransmit Nondelivery Reply]>,GQUEKY,GQUEH1,0)
FILXX(<[--BAD-QUEUED-MAIL--].>,<[Bad Mail]>,GQUEKY,GQUEH1,0)
FILXX(<[--BAD-QUEUED-MAIL--].RETRANSMIT>,<[Retransmit Bad Mail]>,GQUEKY,GQUEH1,0)
FILXX(<[--BAD-RETURNED-MAIL--].>,<[Bad Nondelivery Reply]>,GQUEKY,GQUEH1,0)
FILXX(<[--BAD-RETURNED-MAIL--].RETRANSMIT>,<[Retransmit Bad Nondelivery Reply]>,GQUEKY,GQUEH1,0)
IFN FTOMLR,<
FILXX(<[--UNSENT-MAIL--].*>,<[Old Style Queued Mail]>,GQUEUN,GQUEH0,FF%OML)
FILXX(<]--UNSENT-NEGATIVE-ACKNOWLEDGEMENT--[.*>,<[Old Style Nondelivery Reply]>,GQUEUN,GQUEH0,FF%OML)
FILXX(</UNDELIVERABLE-MAIL/.>,<[Old Style Dead Mail]>,GQUEUN,GQUEH0,FF%OML)
>;IFN FTOMLR
FILXX(<-MAIL.*>,<[Special Domain Queued Mail]>,GQUEUS,GQUEH0,0)
NFTBL==<.-FILTBL>/FL%LEN
LCLNAM: ASCIZ/TOPS-20/ ;Gets clobbered at initialization time
BLOCK LCLNAM+20-.
LCLNME==. ;End of local name (for padding purposes)
SUBTTL Main program
; Definition of program entry vector
ENTVEC: JRST GO ; Normal entry
JRST GO ; REENTER
BYTE(3)VWHO(9)VMAJOR(6)VMINOR(18)VMLST ;QDMAIL version
ENTVCL==.-ENTVEC
GO: RESET
MOVE F,[A,,B] ;Clear out ACs (paranoia)
SETZ A,
BLT A,P
MOVE P,[IOWD NPDL,PDL] ;Set up stack
SETZB F,CORBEG ;Clear out impure storage
MOVE A,[CORBEG,,CORBEG+1]
BLT A,COREND
SETOM INUUO ;Init recursive UUO flag
MOVX A,.PRIOU ;Use our terminal for any I/O
MOVEM A,TTYNUM ; until we detach
MOVEI A,.FHSLF
RPCAP% ;Get our capabilities
IOR C,B ;Enable everything we've got
EPCAP%
HRROI A,LCLNAM ;Try to get local host name
CALL $GTLCL
WARN <No local hostname information>
MOVEI A,4 ;Get a PID from INFO and assign name
MOVEI B,PIDGET
MSEND%
JFATAL <Couldn't get a PID from INFO>
SETOM PRINTP ;Print all messages
MOVX A,RC%EMO ;Get MAILQ: name string
HRROI B,[ASCIZ/MAILQ:/]
RCDIR
TXNE A,RC%NOM!RC%AMB ;MAILQ: not there?
JFATAL <Couldn't find MAILQ:>
MOVEM C,MQDIR ;Save dir number for DODIR
MOVX A,RC%EMO
HRROI B,[ASCIZ/MAILS:/]
RCDIR%
TXNE A,RC%NOM!RC%AMB
SETZ C, ;Don't blow up if no special domain
MOVEM C,MSDIR
JRST GETMES ;Go wait for a message
INIT: MOVE A,[USRSTR,,USRSTR+1]
SETZM USRSTR ;Clear out User name string,
BLT A,PRVFLG ; TTY number and priv's flag
SETZM USRMCH ;Init user name match flag
; Loop waiting for messages from User portion
GETMES: SETZM RCVFLG ;Set up receive message PDB
SETZM SNDPID
MOVE A,PIDNUM
MOVEM A,RCVPID
MOVE B,[^D11,,USRSTR]
MOVEM B,RCVBF
MOVEI A,6
MOVEI B,RCVFLG
MRECV% ;Wait for a message
ERJMP %FATAL ;Something went wrong...
HLRZ B,RCVBF ;Check the message length
CAIE B,^D11 ;Ignore it if wrong length
JRST GETMES
MOVX A,SC%WHL!SC%OPR
TDNE A,PRVFLG
IFNSK.
SETOM PRVFLG
ELSE.
SETZM PRVFLG
ENDIF.
MOVX A,3
MOVX B,3
MOVX 3,.MUFOJ
MOVE 4,SNDPID
MUTIL%
ERJMP GETMES
MOVE A,5
HRROI B,TTYNUM
MOVX C,.JITNO
GETJI%
ERJMP GETMES
HRROI A,USRSTR
MOVE B,USRDIR
DIRST%
ERJMP GETMES
SETZ A,
RCDIR% ;Get directory number
MOVEM C,USRDIR ;And store for check below
; Process a user's request
MOVX A,.TTDES ;Set up TTYNUM as device
IORM A,TTYNUM ; designator for SOUT, BOUT, etc.
MOVE B,MQDIR ;Set up for DODIR
CALL DODIR ;Go scan MAILQ:
CALL CHKFND ;Tell user if no files found
SKIPE B,MSDIR
IFNSK.
CALL DODIR
CALL CHKFND
ENDIF.
MOVE B,USRDIR ;Set up for user's directory
CALL DODIR ;Go scan user's directory
CALL CHKFND ;Tell user if no files found
CALL CLRPTB ;Unmap all remaining pages
MOVEI A,.FHSLF
CLZFF ;Close all files
TELUSR: MOVE A,SNDPID ;Send acknowledgment to User
MOVEM A,RCVPID
MOVE A,PIDNUM
MOVEM A,SNDPID
SETZM RCVFLG
MOVE B,[1,,RCVACK]
MOVEM B,RCVBF
MOVEI A,4
MOVEI B,RCVFLG
MSEND%
ERJMP TELUSR ;This shouldn't happen if IPCF is working
JRST INIT ;Set up for new message
; Here to scan files in a directory
DODIR: CIETYP <Trying %2U...>
MOVEM B,DIRNUM ;Save directory number
MOVE A,[-NFTBL,,FILTBL] ;Init file type index
CAMN B,MSDIR
MOVE A,[-1,,FILTBL+<<NFTBL-1>*FL%LEN>] ;KLUDGE!!! But it's faster...
TFLUP: MOVEM A,FILIDX
HRROI A,STRBUF ;Set up name string for file sought
MOVE B,DIRNUM
DIRST%
ERJMP FILUPX ;No go, try next file type
CAME B,MSDIR
IFSKP.
MOVEI B,"." ;Smash delimiter
DPB B,A
MOVEI B,"*" ;Make wild
IDPB B,A ;<
MOVEI B,">" ;and make a new
IDPB B,A
ENDIF.
MOVE B,FILIDX ;b =: ptr to current file type string
HLRZ B,FL%STR(B)
CALL MOVST0
MOVE A,[GJ%IFG!GJ%OLD!GJ%SHT+<0,,-3>]
HRROI B,STRBUF
GTJFN%
ERJMP FILUPX ;No go, try next file type
MOVE X,A ;Save JFN
SKIPN PRVFLG ;Skip next output if not priv'd
JRST FILUP
MOVE A,FILIDX
HRRZ A,FL%STR(A) ;Pointer to file descriptor string
CETYPE <%1W>
FILUP: MOVE A,PRVFLG ;Set USRMCH depending on priv's
MOVEM A,USRMCH ; if -1 will list all files
MOVEI A,(X)
CALL DQFIL ;Scan the file
CIETYP < %1J ...can't map file> ;+1, can't map file
NOP ;+2, error processing file
MOVE A,X ;Step to next file in this group
GNJFN%
ERJMP FILUPX ;No more, try next type
JRST FILUP
;; Here to step to the next file type
FILUPX: MOVE A,FILIDX ;No, a =: current file type index
ADDI A,FL%LEN-1 ;Step to next one
AOBJN A,TFLUP
RET
SUBTTL Queued Mail File Handling
;;; Scan a queued mail file and print out relevant information
;;; about its queue status and destination.
; Entry: a = wild card jfn for file
; Call: CALL DQFIL
; Return: +1, error mapping file
; +2, error processing file
; +3, success
DQFIL: JSR SAVACS ;Save all ACs
MOVEI B,(A) ;Make copy of the name
HRROI A,STRBUF
SETZ C,
JFNS%
HRROI B,STRBUF ;Must get another JFN
CALL MAPQFL
JRST RSTRET ;Failed, return
MOVEI M,MSGBLK ;m := pointer to msg block
MOVEM A,MSGJFN(M) ;Save JFN
MOVEM D,MSGPAG(M) ;Save starting copy
CALL PARINI ;Initialize parser (ptr to msg text)
SETZM MSGAFT(M) ;Clear default retransmission time
SETZM MSGNTF(M) ;Clear delivery status notification time
SETZM MSGDEQ(M) ;Clear default dequeue time for msg
HRRZ A,MSGJFN(M) ;Get file write date
CALL .GFWDT
MOVEM B,MSGWRT(M)
MOVE A,MPP ;Return at least +2 from here
AOS -20(A)
MOVE A,FILIDX ;a := current file type index
HLRZ A,FL%PRC(A) ;a := processing dispatch for header
JRST 0(A) ;Do it
GQUEUS: PUSH P,X
PUSH P,Y
MOVE A,X
HRROI B,STRBUF ;Read sender line
MOVX C,^D120
MOVX D,.CHCRT
SIN%
SETZ D,
DPB D,B ;Smash CR
MOVEM A,T ;Save new ptr
HRROI A,STRBF1
HRRZ B,MSGJFN(M) ;Get directory of file
MOVX C,FLD(.JSAOF,JS%DIR)
JFNS%
MOVE A,[POINT 7,STRBF1]
MOVEM A,C
GQUES1: ILDB B,A ;Find last dot
JUMPE B,GQUES0
CAIN B,"."
MOVEM A,C
JRST GQUES1
GQUES0: MOVE A,[POINT 7,STRBF1]
MOVE B,C ;Ptr to <to-host>
MOVX C,^D120
SETZ D,
SOUT%
MOVX D,^D120
SUB D,C
MOVEM D,Y ;Save length
MOVE A,[POINT 7,STRBUF] ;Ptr to sender
MOVE B,A
SETZ X, ; Init host ptr
DO.
ILDB C,B ;Get next char
JUMPE C,ENDLP. ;Quit on null
IDPB C,A ;Store char
CAIN C,"@" ;Atsign seen?
MOVE X,A ;Yes, save ptr to host
AOJA Y,TOP. ;Count char and loop
ENDDO.
SKIPE X ;"@" seen?
CAMN A,X ;Yes, host null?
IFSKP.
DPB C,X ;No, clobber @ with null
SUBI Y,1 ;Fix up count
ELSE.
MOVE B,[POINT 7,LCLNAM] ;No, get local name
MOVE X,A ;Update host ptr (in case no "@")
DO.
ILDB C,B ;Get next char
JUMPE C,ENDLP. ;Quit on null
IDPB C,A ;Store char
AOJA Y,TOP. ;Count char and loop
ENDDO.
ENDIF.
MOVE B,A ;Ok, terminate edited string
IDPB C,B
;Now fake a header
MOVE A,[POINT 7,SPECBF] ;Write here
MOVX B,.CHFFD ;FF
IDPB B,A
MOVEI B,"_" ;Sender spec follows
IDPB B,A
MOVE B,X ;<Host>
SETZ C,
SOUT
MOVEI B,CRLF0 ;CRLF
CALL MOVSTR
MOVEI B,STRBUF ;<User>
CALL MOVSTR
MOVEI B,CRLF0 ;CRLF
CALL MOVSTR
MOVEI B,.CHFFD ;FF
IDPB B,A
MOVE C,[POINT 7,STRBF1] ;<To-host>
GQUES4: ILDB B,C
IFN. B
IDPB B,A
AOJA Y,GQUES4
ENDIF.
; MOVEI B,CRLF0 ;CRLF
; CALL MOVSTR
MOVX B,.CHCRT
IDPB B,A
MOVE B,T ;Get next line of file (addresse)
MOVX C,^D120
MOVX D,.CHFFD ;End on FF
SOUT%
MOVEI B,CRLF0
CALL MOVST0
MOVX D,^D120
SUB D,C
ADD Y,D
ADDI Y,^D<2+4+1+2>+1
MOVE X,[POINT 7,SPECBF]
JRST GQUEKY
IFN FTOMLR,<
;; Here to fake a header for xxx.<addressee> files
GQUEUN: PUSH P,X ;Save the current msg string info
PUSH P,Y
HRROI A,STRBUF ;a := buffer for the extension info
HRRZ B,MSGJFN(M) ;b := msg file JFN
MOVSI C,000100 ;Print extension only
JFNS%
MOVE A,[POINT 7,STRBUF] ;Now scan the string for the host name
MOVE B,A
SETZB X,Y ;Init host ptr and string length
GQUEN0: ILDB C,B ;c := next char
JUMPE C,GQUEN1 ;Quit on null
CAIN C,.CHCNV ;^V?
JRST GQUEN0 ;Yes, ignore it
CAIN C,"@" ;Start of host?
JRST [ SETZ C, ;Yes, clobber the "@" with a null
IDPB C,A
MOVE X,A ;Save start of host string
JRST GQUEN0 ]
IDPB C,A ;Store the char
AOJA Y,GQUEN0 ;Count the char and do the next
; Here we have the end of the addressee string
GQUEN1: SKIPE X ;"@" seen?
CAMN A,X ;Yes, host null?
JRST [MOVE B,[POINT 7,LCLNAM] ;No, use local name
MOVE X,A ;Update host ptr (in case no "@")
JRST GQUEN0 ]
MOVE B,A ;OK, terminate edited string
IDPB C,B
; Now we create a fake header (as if [--QUEUED-MAIL--])
MOVE A,[POINT 7,OMLRBF] ;a := place to build it
MOVEI B,.CHFFD ;Start with ^L<host><crlf>
IDPB B,A
MOVE B,X ;b := ptr to host string
SETZ C,
SOUT ;(Have to SOUT - not word boundary)
MOVEI B,CRLF0
CALL MOVSTR
MOVEI B,STRBUF ;Add <addressee><crlf>
CALL MOVSTR
MOVEI B,CRLF0
CALL MOVSTR
MOVEI B,.CHFFD ;And finish with ^L<CRLF>
IDPB B,A
MOVEI B,CRLF0
CALL MOVST0
MOVE X,[POINT 7,OMLRBF] ;Now set to scan the string
ADDI Y,^D8+1 ;Account ^L's and <crlf>'s in length
;(and 1 so PARLIN thinks a msg follows)
JRST GQUEKY ;Make like it's [--QUEUED-MAIL--]
>;IFN FTOMLR
;; Parse the head of the file
GQUEKY: CALL PARLIN ;Get a line from the file
JRST QUEEOF ;Premature eof
TRNN F,FP%FF ;Was a formfeed seen?
JRST [ CETYPE < ?Invalid queued mail file format in line ">
JRST QUEBK0] ;Toss the losing file out
;; Now parse the message recipients
GQUERC: TRNE F,FP%EOL ;Empty line?
JRST [ TRNE F,FP%EQU ;Control parameter specification?
JRST QUEBPM ;Yes, must be error
TRNN F,FP%BKA ;Sender specification?
JRST GQUEHD ;No, must be start of actual message
MOVE A,[POINT 7,HSTBUF] ;Yes, substitute local name
MOVEI B,LCLNAM
CALL MOVST0
JRST GQURC0] ;Process it
TRNE F,FP%EQU ;Control parameter specification?
JRST [ MOVEI A,QUEPTB ;Yes, lookup in parameter keyword table
CALL PARKEY
JRST QUEBPM ;Bad luck...
JRST GQURC1] ;Got it, continue processing
CALL PARSTR ;Get pointers for this line
MOVE B,[POINT 7,HSTBUF]
DO.
ILDB A,C ;Make uppercase
IDPB A,B
CAIE A,.CHNUL ;Quit on null
SOJG D,TOP. ;Or count
ENDDO.
SETZ A, ;Fill out with nulls
DO.
IDPB A,B
TLNE B,760000
LOOP.
ENDDO.
GQURC0: TRNN F,FP%BKA ;Sender spec?
JRST GQURC1 ;No - get another line
CALL PARLIN ;Get sender name
JRST QUEEOF ;Premature EOF
SKIPN PRVFLG ;Priv'd user?
IFSKP.
MOVE A,PLINBP ;Yes, get string pointer
CETYPE < From: %1W>
MOVEI A,HSTBUF ;Get host portion
ETYPE <@%1W>
ELSE.
HRRZI A,USRSTR ;Set up for name match test
HRLI A,(<POINT 7,0>)
MOVE B,PLINBP
CALL STRCMP ;Compare the strings
IFNSK.
CALL RELQUE ;No match - free this storage
JRST RSTSKP ;Skip to next file
ENDIF.
SETOM USRMCH ;Set user name match flag
SKIPE FNDFLG ;Have we found a file already?
ANSKP.
CTYPE <You have mail in the queue:> ;No, output this
CTYPE < >
SETOM FNDFLG
ENDIF.
;; Here to process the next input line...
GQURC1: CALL PARLIN ;Get a line
JRST QUEEOF ;Premature eof
TRNE F,FP%FF ;Started with form?
JRST GQUERC ;Yes, next host then
SKIPN USRMCH ;We should never get here without
JRST GQURC1 ; a match, but just in case...
MOVE A,PLINBP ;Get string pointer to sender's name
CETYPE < To: %1W>
MOVEI A,HSTBUF ;Get host portion
ETYPE <@%1W>
JRST GQURC1 ;Go get next line
;; Now finish up, remembering where the headers start
GQUEHD: MOVE A,FILIDX ;a := index to current file type
HRRZ A,FL%PRC(A) ;a := processing dispatch for msg
JRST 0(A) ;Do it
IFN FTOMLR,<
GQUEH0: POP P,Y ;Recover ptr info for msg text itself
POP P,X
>;IFN FTOMLR
GQUEH1: CALL PARLIN ;Process msg text headers
JRST GQUEH9 ;EOF before Subject: field found
TRNN F,FP%CLN ;Colon seen?
JRST GQUEH1 ;No - get next line
MOVEI A,QUEPTB ;Yes - scan keyword table
CALL PARKEY
JRST GQUEH1 ;No match - keep looking
; Successful return after Subject: found falls through to finish processing
; This will have to be changed if more than one message header keyword is
; used
GQUEH9: MOVE A,MSGWRT(M) ;Print date/time msg queued
CETYPE < Queued: %1T>
SKIPE A,MSGAFT(M) ;Print date/time of delivery
CETYPE < Delivery after: %1T>
SKIPE A,MSGNTF(M) ;When to notify
CETYPE < Notify after: %1T>
SKIPE A,MSGDEQ(M) ;Print date/time to de-queue
CETYPE < Message expires after: %1T>
CALL CRIF
CALL RELQUE ;Release the file
JRST RSTSKP ;Skip return from it all
;;; Table of parameter keywords and processing routines
QUEPTB: -NQPRMS,,.+1
[ASCIZ/AFTER/],,QUEAFT ;Formerly RETRANSMIT
[ASCIZ/DELIVERY-OPTIONS/],,QUEDEL
[ASCIZ/DEQUEUE/],,QUEDEQ
[ASCIZ/DISCARD-ON-ERROR/],,QUEDER
[ASCIZ/ERROR/],,QUEERR
[ASCIZ/NET-MAIL-FROM-HOST/],,QUEHST
[ASCIZ/NOTIFY/],,QUENTF
[ASCIZ/RETURN-PATH/],,QUERPT
[ASCIZ/SUBJECT/],,SUBTXT
NQPRMS=.-QUEPTB-1
;;; Here to process (no-op) "NET-MAIL-FROM-HOST" line
QUEHST: RETSKP
;;; Here to fetch time to attempt network retransmissions
QUEAFT: CALL GQUTIM ;Decode the time value
RET ;No go
MOVEM B,MSGAFT(M) ;Save it
RETSKP ;And success return
;;; Here to fetch time to notify sender of transmission status
QUENTF: CALL GQUTIM ;Decode the time value
RET ;No go
MOVEM B,MSGNTF(M) ;Save it
RETSKP ;And success return
;;; Here to fetch time to notify sender of transmission status
QUEDEQ: CALL GQUTIM ;Decode the time value
RET ;No go
MOVEM B,MSGDEQ(M) ;Save it
RETSKP ;And success return
;;; Here to fetch return path
QUERPT: RETSKP
;;; Here to fetch return delivery options
QUEDEL: RETSKP
;;; Here to set flag for discarding msg without notifying sender if
;;; failed or dequeued (no-op)
QUEDER: RETSKP ;Success return
;;; Here to fetch error log file name
QUEERR: RETSKP
;;; Routine to decode a time value for a control parameter
;;; Return: +1, error
;;; +2, success - value in b
GQUTIM: DMOVE C,PCLNBP ;Rest of line after colon
CALL PARST1
MOVE A,[POINT 7,STRBF1] ;Temp buffer for time string
GQUTI0: ILDB B,C
CAIE B," " ;Skip starting spaces and tabs
CAIN B,.CHTAB
JRST [SOJG D,GQUTI0 ;Look some more
RET] ;Unless string exhausted
SKIPA
GQUTI1: ILDB B,C ;Next char
IDPB B,A ;Copy it
CAIN B,.CHNUL ;Quit on null
JRST GQUTI2
SOJG D,GQUTI1 ;If not end of string, continue
MOVEI B,0 ;Else end with null
IDPB B,A
GQUTI2: HRROI A,STRBF1 ;Now convert the time string
IDTIM
RET
RETSKP
;; Premature EOF
QUEEOF: CETYPE < ?Premature end of file>
QUEBRT: CALL RELQUE ;Free entry
JRST RSTRET ;Single return
;; Bad keyword
QUEBKY: CETYPE < ?Unrecognized keyword in line ">
QUEBK0: MOVE A,TTYNUM ;User's TTY device designator
CALL PARSTR ;Set up line ptr/length
MOVE B,C
MOVN C,D
SOUT
ERJMP QUEBRT
SETZ C,
QUEBK1: HRROI B,[ASCIZ /"
/]
SOUT
ERJMP .+1
JRST QUEBRT
;; Bad control parameter specification
QUEBPM: CETYPE < ?Bad control parameter in line ">
JRST QUEBK0
;; Subject: field in message text output
SUBTXT: MOVE A,PLINBP
CETYPE < %1W>
RETSKP
;;; Release storage from queue entry in M
RELQUE: HLRZ A,MSGPAG(M) ;a := # pages mapped
JUMPE A,RELQUR ;Quit if none touched
HRRZ B,MSGPAG(M) ;b := starting page
CALL PAGDAL ;Unmap the msg file pages
RELQUR: HRRZ A,MSGJFN(M) ;Close the file
CLOSF
JFATAL <RELQUE: >
RET
;;; Map in a file
; Entry: b = ptr to name
; Call: CALL MAPQFL
; Return: +1, error
; +2, success
; a = fresh file jfn
; b = starting core address
; c = # of bytes
; d = # pages,,starting core page
MAPQFL: PUSH P,[OF%RD!OF%PDT] ;Open read and leave access dates
MOVSI A,(GJ%OLD!GJ%SHT)
GTJFN
IFJER.
POP P,B
RET
ENDIF.
PUSH P,A ;Save the jfn
MOVE B,-1(P) ;Get OPENF flags and open the file
OPENF
JRST MPFLOE ;No go
SIZEF ;Fetch its size information
JRST MPFLSE ;No go
PUSH P,B ;Save number of bytes
MOVEI A,(C) ;Number of pages needed for whole file
CALL PAGALC ;Allocate them
JRST MPFLPE ;No go???
HRLZ A,-1(P) ;Start with page 0 of file
HRLI B,.FHSLF
HRLI C,(PM%CNT!PM%RD!PM%CPY)
PMAP
ERJMP MPFLPE ;???
MAPFI1: HRLI C,(B)
MOVS D,C ;d := # pgs,,starting pg
LSH B,9 ;b := core address of first page
POP P,C ;c := # of bytes
POP P,-1(P) ;Move the jfn down on the stack
POPA1J: POP P,A
RETSKP
;; Here on error preparing file map
MPFLPF: ADJSP P,-1 ;Clear page count from stack
MPFLPE: ADJSP P,-1 ;Clear byte count from stack
MPFLSE: POP P,A ;Close the file
CLOSF
ERJMP .+1
MPFLSR: ADJSP P,-1 ;Clear OPENF bits
RET
;; Here if OPENF fails for file
MPFLOE: POP P,A ;Release the jfn
RLJFN
ERJMP .+1
JRST MPFLSR ;Fail return
SUBTTL Parser
;;; Parser flags
FP%FF==1 ;Formfeed seen at start of line
FP%CLN==2 ;Colon seen
FP%EOL==4 ;Blank line (after any formfeed, that is)
FP%DEL==10 ;Rubout on line
FP%EQU==20 ;Equal sign seen (control parameter)
FP%BKA==40 ;Backarrow seen (sender spec)
FP%WSP==100 ;Whitespace at start
;;; Initialize parser, called with starting address in B, byte count in C
PARINI: HRLI B,(<POINT 7,0>)
DMOVE X,B
RET
;;; Parse a single line
PARLIN: TRZ F,FP%FF!FP%CLN!FP%EOL!FP%DEL!FP%WSP
SETZM PDELB2 ;Filter for malformed <del> pairs
PARLN0: DMOVEM X,PLINBP ;Save start of line
PARLN1: DMOVEM X,PWSPBP
SOJL Y,CPOPJ
ILDB D,X ;Get first character
CAIN D,.CHFFD ;Formfeed?
JRST [ TRO F,FP%FF
TRZ F,FP%BKA!FP%EQU ;Clear special flags
JRST PARLN0]
CAIN D,"=" ;Equal sign?
JRST [ TRO F,FP%EQU ;Yes
JRST PARLN0 ]
CAIN D,"_" ;Backarrow?
JRST [ TRO F,FP%BKA ;Yes
JRST PARLN0 ]
CAIE D,.CHTAB
CAIN D,.CHSPC
JRST [TRO F,FP%WSP
JRST PARLN1]
CAIE D,.CHCRT ;End of line?
JRST PARLN3 ;No, normal character
TRO F,FP%EOL
JRST PARLN4
PARLN2: SOJL Y,CPOPJ
ILDB D,X
CAIN D,.CHCRT
JRST PARLN4
PARLN3: CAIN D,.CHDEL
JRST PARLN5
CAIN D,":"
TROE F,FP%CLN
JRST PARLN2
DMOVEM X,PCLNBP ;Save pointers when got to colon
JRST PARLN2
PARLN4: SETZ A, ;Put null in CR byte so string
DPB A,X ; prints will work right
SOJL Y,CPOPJ
ILDB D,X ;Skip lf too
SKIPG PDELB2 ;Matching <del> set?
TRZ F,FP%DEL ;No, ignore any seen
RETSKP
PARLN5: TROE F,FP%DEL ;Rubout within line is start of host
JRST [ SKIPE PDELB2 ;Matching pair?
JRST [ SETOM PDELB2 ;No, flag error
JRST PARLN2]
DMOVEM X,PDELB2
JRST PARLN2]
DMOVEM X,PDELBP
JRST PARLN2
PARLNE=. ;Bound for interrupt handling
;;; Parse a keyword from table in A
;;; Returns +1 failure, else calls routine pointed to by table
PARKEY: TRNE F,FP%CLN ;Line had a colon in it?
JRST [ MOVE D,PCLNBP ;Yes, use byte pointer of colon then
JRST PARKY1]
SETO D,
ADJBP D,X
PARKY1: LDB TT,D ;Get character that terminates atom
SETZ T,
DPB T,D ;Replace it with null
MOVE T,0(A) ;t := aobjn ptr to lookup table
PARKY2: HLRZ A,0(T) ;a := ptr to next table entry
HRLI A,(<POINT 7,0>)
MOVE B,PLINBP ;Start of line
CALL STRCMP ;Match?
AOBJN T,PARKY2 ;No, try the next
DPB TT,D ;Replace character
JUMPGE T,CPOPJ ;If no match, return
HRRZ A,(T) ;Get entry
JRST (A) ;Go call that routine
;;; get pointers for this line
PARSTR: DMOVE C,PLINBP
PARST1: SUB D,Y
SUBI D,2 ;Number of chars less CRLF
RET
RSTSKP: MOVE P,MPP ;Be sure stack is reset
AOSA -20(P) ;Skip return
RSTRET: MOVE P,MPP ;Be sure stack is reset
JSR RSTACS
RET
CPOP2J: AOS (P)
CPOP1J: AOS (P)
CPOPJ: RET
SUBTTL Core Allocation
;;; Bit table hacking, page number in A for all
PAGSBT: PUSH P,[IORM B,(A)] ;Set bit
JRST PAGHBT
PAGCBT: PUSH P,[ANDCAM B,(A)] ;Clear bit
JRST PAGHBT
PAGTBT: PUSH P,[TDNE B,(A)] ;Skip if bit clear
PAGHBT: PUSH P,A
PUSH P,B
SUBI A,FSPAG ;Make relative to start of bit table
IDIVI A,^D36
MOVEI A,PAGTBL(A) ;Point to right word
MOVE B,BITS(B) ;Get right bit
XCT -2(P)
SKIPA
AOS -3(P)
POP P,B
POP P,A
ADJSP P,-1
RET
;;; Allocate number of pages in A, returns +1 failure, +2 page number in B
PAGAL1: MOVEI A,1 ;Allocate one page
PAGALC: PUSH P,C
PUSH P,A ;Save number of pages we need
MOVEI B,FSPAG ;Starting free page
PAGALB: CALL PAGFFP ;Fast search for first free page
JRST POPACJ ;Failure, just return
MOVEI A,1(B)
MOVE C,(P) ;Get number of pages to hack again
PAGALL: SOJLE C,PAGALW ;Got enough, return address from b
CAIL A,1000 ;Page number too big?
JRST POPACJ ;Yes, fail
CALL PAGTBT ;Is this bit set?
JRST [ MOVEI B,1(A) ;Try for next free page
JRST PAGALB]
AOJA A,PAGALL ;Try for next match
PAGALW: MOVE C,(P)
MOVEI A,(B)
PAGAW1: CALL PAGSBT ;Allocate one page
SOJLE C,POPAC1
AOJA A,PAGAW1
POPAC1: AOS -2(P) ;Winning return
POPACJ: POP P,A
POP P,C
RET
;;; Deallocate pages, number in A, starting page in B
PAGDA1: MOVEI A,1 ;Deallocate one page
PAGDAL: PUSH P,A
PUSH P,B
PUSH P,C
EXCH A,B ;Setup for page number in A
PAGDA2: SOJL B,PAGDA3
CALL PAGCBT ;Clear one bit
AOJA A,PAGDA2
PAGDA3: SETO A,
MOVE B,-1(P) ;Starting page
HRLI B,.FHSLF
MOVE C,-2(P) ;Count
HRLI C,(PM%CNT)
PMAP ;Flush those pages
POPCBA: POP P,C
POPBAJ: POP P,B
CPOPAJ: POP P,A
RET
;;; Fast search for the first free bit, starting page in B
;;; Returns +1 failure, +2 with page number in B
PAGFFP: SUBI B,FSPAG ;Make relative to start of bit table
IDIVI B,^D36
SETCM A,PAGTBL(B) ;Get first word to check
LSH A,(C)
MOVNI C,(C)
LSH A,(C) ;Clear out random bits to left
SKIPA C,B ;Starting word index
PAGFF1: SETCM A,PAGTBL(C) ;Get word to check
JFFO A,PAGFF2 ;Got any ones?
CAIL C,PGTBLL ;No - beyond last word?
RET ;Failed
AOJA C,PAGFF1 ;No, search for next word
PAGFF2: IMULI C,^D36 ;Number of bits passed
ADDI B,FSPAG(C) ;Final winning page number
CAIL B,1000 ;Was page valid?
RET ;No
RETSKP
; Routine to unmap core buffer pages currently in use
; Entry: pagtbl = bitmap for pages in use
; Call: CALL CLRPTB
; Return: +1
CLRPTB: SETO A, ;Unmap special prebuffer pages
MOVSI B,.FHSLF
SETZ C,
MOVSI T,-PGTBLL ;t =: aobjn ptr to PAGTBL
CLRPT0: SKIPE A,PAGTBL(T) ;Any bits in this entry?
JFFO A,CLRPT1 ;Yes, scan for 1st one
AOBJN T,CLRPT0 ;No more, try next word
RET ;Done
; Here to unmap a page flagged in PAGTBL
; Entry: t = ptr to PAGTBL word for page
; b = count of flag bit position for page
CLRPT1: MOVEI C,0(T) ;c =: PAGTBL word index
IMULI C,^D36 ;c =: page count for prior wds in table
ADDI B,FSPAG(C) ;b =: core page number
CAIL B,1000 ;Legal page?
FATAL <CLRPTB: Invalid page table bit set>
CALL PAGDA1 ;Deallocate this page
JRST CLRPT0 ;Look for more to do
SUBTTL UUO Handler
; UUO enters here via JSR UUOH
UUOH: 0 ;Ret adr for JSR entry
AOSE INUUO ;Recursive call?
JRST [ MOVEM A,TEMPAC ;Yes???
HRROI A,[ASCIZ/Recursive UUO call illegal!/]
CALL PSOUT
MOVE A,TEMPAC
JRST %FATAL]
MOVEM A,UUOACS+A ;Save an ac
MOVEM P,UUOACS+P ;And the stack
MOVE P,[IOWD NUPDL,UUOPDL] ;Set up local stack
PUSH P,UUOH ;Save the calling pc
PUSH P,[UUORTP] ;Put stack restore entry on
LDB A,[POINT 9,40,8] ;a := opcode field
JRST @UUOS(A) ;Dispatch to handler routine
; Here to save whole ac block and set up for RET to restore acs and
; return. Entered by JSR UUOSV
UUOSV: 0
MOVE A,UUOACS+A ;Restore entry a
MOVEM 16,UUOACS+16 ;Save all ACs (P done on entry)
MOVEI 16,UUOACS
BLT 16,UUOACS+15
PUSH P,[UUORT] ;Put ac restore entry on stack
JRST @UUOSV
; Here to restore ac block and return +1 to user.
UUORT: MOVSI 16,UUOACS ;Restore ACs
BLT 16,16
RET
; Here to restore single ac and return +1 to user.
UUOFRT: MOVE A,UUOACS+A ;Recover ac
RET
; Here to restore return adr and caller's stack ptr
UUORTP: POP P,UUOH ;UUOH := return adr
MOVE P,UUOACS+P ;p := caller's stack
SOS INUUO ;Reset the entry flag
JRST @UUOH
; UUO handler dispatch table
UUOS: 0
%PRINT
%TYPE
%ETYPE
%ERROR
;; Print a character
%PRINT: HRRZ A,40 ;Get byte
CAIN A,EOL ;PRINT EOL means do CRLF
JRST [ CALL CRLF ;Do it
JRST UUOFRT ]
CALL PBOUT
JRST UUOFRT ;Take fast return
;; Type a string after crlf if needed
%TYPE: SKIPN PRINTP
JRST UUOFRT
CALL TYCRIF ;Check if we should do a CRLF
%TYPE0: HRRO A,40 ;Get string
CALL PSOUT
JRST UUOFRT
;; Do a conditional crlf
TYCRIF: MOVE A,40 ;Get instruction
TLNE A,(<10,0>) ;Wants CRLF all the time?
JRST CRLF ;Yes
TLNE A,(<1,0>) ;Wants fresh line?
JRST CRIF ;Yes
RET
;; Do crlf if not at start of line currently
CRIF: PUSH P,A
PUSH P,B
CALL CRIF1 ;Do it
JRST POPBAJ
CRIF1: MOVE A,TTYNUM
RFPOS
ERJMP R ;Return now if error
TRNE B,-1 ;If not at start of line,
CALL CRLF1 ;Type CRLF
RET
;; Do crlf unconditionally
CRLF: PUSH P,A
CALL CRLF1
JRST CPOPAJ
CRLF1: HRROI A,CRLF0
CALL PSOUT
RET
CRLF0: ASCIZ/
/
;; Print error messages
%ERROR: JSR UUOSV ;Save the ac context
CALL CRIF ;Get a fresh line
MOVE B,40 ;Get instruction
TLNE B,(<10,0>) ;Wants %?
SKIPA A,["?"] ;No
MOVEI A,"%"
CALL PBOUT
%ERR1: TRNN B,-1 ;Any message to print?
JRST %ERR2 ;No
CALL %ETYE0 ;Yes, print it out
MOVE B,40 ;And recover instruction
%ERR2: TLNN B,(<4, 0>) ;Wants JSYS error message?
JRST %ERR3
HRROI A,[ASCIZ / - /]
TRNE B,-1 ;If a previous message, type delimiter
CALL PSOUT
MOVE A,TTYNUM
HRLOI B,.FHSLF ;This fork
SETZ C,
ERSTR
ERJMP .+1
ERJMP .+1
%ERR3: CALL CRLF
LDB A,[POINT 2,40,12] ;Get low order bits of ac field
JRST %ERRS(A)
%ERRS: JRST %FATAL ;0 - not used
%ERRET: JRST %FATAL ;1 - not used
JRST %FATAL ;2 - return to EXEC
RET ;3 - return to user
;; Here on fatal error
%FATAL: HALTF
HRROI A,[ASCIZ /?Can't continue
/]
CALL PSOUT
JRST %FATAL
;; Here to print a string, filling in escape sequences
%ETYPE: JSR UUOSV ;Save the ac context
SKIPN PRINTP
RET
CALL TYCRIF ;Type a CRLF maybe
%ETYE0: HRRZ N,40
%ETYS0: HRLI N,(<POINT 7,0>) ;Get byte pointer to string
%ETYP1: ILDB A,N ;Get char
JUMPE A,CPOPJ ;Done
CAIE A,"%" ;Escape code?
JRST %ETYP0 ;No, just print it out
SETZ O, ;Reset AC
%ETYP2: ILDB A,N
CAIL A,"0" ;Is it part of addr spec?
CAILE A,"7"
JRST %ETYP3 ;No
IMULI O,^D8 ;Yes, increment address
ADDI O,-"0"(A)
JRST %ETYP2
%ETYP3: CAIG A,"Z"
CAIGE A,"A"
JRST %ETYP0
CALL @%ETYTB-"A"(A) ;Do dep't thing
JRST %ETYP1
%ETYP0: CALL PBOUT
JRST %ETYP1
%ETYTB: %ETYPA ;A - print time
%ETYPB ;B - print date
%ETYP0 ;C
%ETYPD ;D - print decimal
%ETYER ;E - error code
%ETYPF ;F - floating
%ETYP0 ;G
%ETYPH ;H - RH as octal
%ETYP0 ;I
%ETYPJ ;J - filename
REPEAT 4,<%ETYP0> ;K, L, M, N
%ETYPO ;O - octal
%ETYPP ;P - pluralizer
REPEAT 2,<%ETYP0> ;Q, R
%ETYPS ;S - string with escape sequences
%ETYPT ;T - date and time
%ETYPU ;U - user name
%ETYP0 ;V
%ETYPW ;W - string with no escapes
REPEAT 3,<%ETYP0> ;X, Y, Z
;; Print time only
%ETYPA: MOVSI C,(OT%NDA) ;No day, just time
JRST %ETYB0
;; Options for printing just day or date/time
%ETYPT: TDZA C,C ;Both date and time
%ETYPB: MOVX C,OT%NTM ;No time, just day
%ETYB0: JUMPE O,.+2 ;If AC field spec'd
SKIPA B,UUOACS(O) ;Use it
SETO B, ;Else use now
MOVE A,TTYNUM
ODTIM%
ERJMP .+1
RET
;; Print decimal and octal numbers
%ETYPD: SKIPA C,[^D10] ;Decimal
%ETYPO: MOVEI C,^D8 ;Octal
MOVE B,UUOACS(O) ;Get data
%ETYO0: MOVE A,TTYNUM
NOUT%
ERJMP .+1
RET
;; Print string for specified error code
%ETYER: MOVE A,TTYNUM
MOVSI B,.FHSLF ;This fork
HRR B,UUOACS(O) ;Get error code
SETZ C,
ERSTR%
ERJMP .+1
ERJMP .+1
RET
;; Print floating point number
%ETYPF: MOVE A,TTYNUM
MOVE B,UUOACS(O)
SETZ C,
FLOUT%
ERJMP .+1
RET
;; Print RH of number in octal
%ETYPH: MOVEI C,^D8
HRRZ B,UUOACS(O)
JRST %ETYO0
;; Print file name from jfn
%ETYPJ: MOVE A,TTYNUM
HRRZ B,UUOACS(O)
MOVE C,[001110,,1]
JFNS%
ERJMP .+1
RET
;; Add "S" depending on the value of a number
%ETYPP: MOVEI A,"s"
MOVE B,UUOACS(O)
CAIE B,1
CALL PBOUT ;Make plural unless just one
RET
;; Recursive string output with escape sequence handling
%ETYPS: PUSH P,N
SKIPE N,UUOACS(O)
CALL %ETYS0 ;Recursive call
CPOPNJ: POP P,N
RET
;; Print directory or user name
%ETYPU: MOVE A,TTYNUM
MOVE B,UUOACS(O)
DIRST%
ERJMP .+1
RET
;; String output without further escape sequence handling
%ETYPW: MOVE A,UUOACS(O)
TLNN A,-1
HRLI A,(<POINT 7,0>)
CALL PSOUT
RET
SUBTTL Utility Routines
; Routine to do PSOUT simulation - outputs to device designated
; in TTYNUM
; Entry: a = string pointer (HRROI A,[...] form)
; Call: CALL PSOUT
; Return: +1, AC1 trashed
PSOUT: SAVEAC <B,C>
MOVE B,A ;String pointer in AC2
MOVE A,TTYNUM ;Device Designator in AC1
SETZ C,
SOUT%
ERJMP .+1 ;Ignore failure
RET
; Routine to do PBOUT simulation - outputs to device designated
; in TTYNUM
; Entry: a = byte
; Call: CALL PBOUT
; Return: +1, AC1 trashed
PBOUT: SAVEAC <B>
MOVE B,A ;Byte to AC2
MOVE A,TTYNUM ;Device Designator in AC1
BOUT%
ERJMP .+1
RET
; Routine to tell user if no files were found in directory scanned
; Entry: <none>
; Call: CALL CHKFND
; Return: +1, b trashed
CHKFND: MOVE B,DIRNUM ;Set up for CTYPE
SKIPN PRVFLG
SKIPE FNDFLG ;Tell user if there were no files
SKIPA
CIETYP <You have no outgoing mail in %2U>
TYPE <
>
SETZM FNDFLG
RET
; Routine to fetch the write date/time of a file
; Entry: a = file JFN
; Call: CALL .GFWDT
; Return: +1, b = file write date/time
GFWDT: PUSH P,C ;Save an ac
MOVEI B,B ;Answer into b
MOVEI C,1 ;Only the write date/time
RFTAD
POP P,C ;Recover ac
RET
;;;Move a string from B to A
MOVSTR: HRLI B,(<POINT 7,0>)
MOVST1: ILDB D,B
JUMPE D,MOVST3
IDPB D,A
JRST MOVST1
;;;Move string and terminating null
MOVST0: HRLI B,(<POINT 7,0>)
MOVST2: ILDB D,B
IDPB D,A
JUMPN D,MOVST2
MOVST3: RET
; Routine to compare two strings ignoring case differences
; Entry: a,b = ptrs to strings
; Call: CALL STRCMP
; Return: +1, match failed
; +2, strings match
STRCMP: PUSH P,C ; Save some ac's
PUSH P,D
STRCM0: ILDB C,A ; c := next char from a
CAIL C,"a" ; Raise it if necessary
CAILE C,"z"
CAIA
SUBI C,"a"-"A"
ILDB D,B ; d := next char from b
CAIL D,"a" ; Raise it if necessary
CAILE D,"z"
CAIA
SUBI D,"a"-"A"
CAIN D,15 ;<CR> in D?
SETZ D, ;Yes, mark end of string
CAME C,D ; Same?
JRST STRCM1 ; No
JUMPN C,STRCM0 ; If not end of strings, continue
AOS -2(P) ; Match, return +2
STRCM1: POP P,D ; Recover ac's
POP P,C
RET
..LIT: XLIST
LIT
LIST
END <ENTVCL,,ENTVEC> ; Set up entry vector
; Local Modes:
; Mode: MACRO
; Comment Start:;
; Comment Begin:;
; End:
