github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-01-18 01:02:15 +00:00
Code Issues Releases Wiki Activity
PDP-10.its/src/sysnet/comsat.583

11865 lines
379 KiB
Plaintext
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;-*- Mode: Midas; Fonts: MEDFNT -*-
SUBTTL Basic symbol defs and insrts
.SYMTAB 5001.,7000.
;; WARNING: This is the experimental version of COMSAT using the DQ:
;; resolver device. Among other things, this code assumes
;; that RESOLV"HSTADR will -always- return the Chaosnet
;; address of a machine over the Internet address if there
;; is a choice (the alternative is to do twice as many resolves
;; and do string comparisons). Yukko scuz. Should be fixed
;; as soon as somebody has a better method.
TITLE NEW COMSAT
; System Communications Satellite
;(analogy pat. pend.-- running job has various actual sat. names)
F=0 ; Flags
A=1 ; A-E consecutive utility regs
B=2 ; ( routines save all not used for value returning,
C=3 ; so as to minimize clobberage)
D=4
E=5
;=6 ; Someday...
MF=7 ; Message flags (perhaps flush this)
N=10 ; Index to current net host
L=11 ; Base register into index table for LSE addressing
OC=12 ; Output Channel - used by OUT package.
U1=13 ; UU UU UU UU OOOOO
U2=14 ; UU UU UU UU OO OO HANDLER
U3=15 ; UU UU UU UU OO OO ACCS
U4=16 ; UUUUU UUUUU OOOOO
P=17 ; PDL ptr
; "Hard" channel assignments
LOCKCH==0 ; LOCK device channel for inbox locking
NETD==1 ; Net data channel for ICP and MLFL
NETI==2 ; Net input (telnet) channel
NETO==3 ; Net output(telnet) channel
DKIC==4 ; Disk input
DKOC==5 ; Disk output
SC==6 ; Stats disk output
DMPCH==7 ; Disk output channel for pdump'ing self.
CLIC==10 ; CORE link channel (output only).
ERRCHN==11 ; ERR device channel.
USRI==12 ; Inferior input.
USRO==13 ; Inferior output.
DBC==14 ; Debugging output channel.
LSR1C==15 ; Channel open to LSR1 file.
DQCH==16 ; Channel to DQ: resolver device
;; UUO "channels"
TMPC==17 ; Temporary UUO chan for short jobs.
; Is theoreticly a UUO channel only, but in fact
; is used as a real channel in a few places, sigh.
SAOCH==20 ; Another UUO channel for output into String LN's.
; (That's right, channel 20, so don't use elsewhere!)
; Perhaps merge the two, or better yet introduce
; DEFCHN, DEFCHX macros?? (Latter for #'s > 17)
;LH flag vars
;==1
;==2
%QULOS==200 ; Set when flushing messages for bad host from queue
%PGMRN==400 ; Set while running inferior job.
%INCLI==1000 ; Set when inside CLISND (realt flag)
%MSTMD==2000 ; Set when MASTER modified.
%LSRIN==4000 ; Set when LSR full-name data mapped into core.
%SCOPN==10000 ; Set when SC channel open
%MSGMD==20000 ; Set when current MSG-LSE modified
%QMLMD==40000 ; Set when QML modified.
%SCHED==100000 ; Set when scheduler is sleeping; flag for REALT interrupt.
;==200000 ;
%RMLMD==400000 ; Set when RML modified.
; RH flag vars
%RBFH==1
%RNOQC==2 ; in RSND50, indicates sender doesn't want queue-confirm.
%NETDV==4 ; Set by DEVCHK if device name is net-type
%RBHD==10
%NOTEL==20 ; Used by NOTEW/NOTEL
;==40
;==100
%NDATO==200 ; Used by ntout to tell whether outputting on neto or netd
%DSKDV==400 ; Set by DEVCHK if device name is dsk-type
%NOCOM==1000 ; RCPPUT statistics output uses to help avoid extra commas
%TMP==2000 ; Temp flag for various stuffs.
;==4000
%LMAPN==10000 ; Used by WRTMSG for 'append-msg' flag.
%MAPC==20000 ; To distinguish MAPCA/MAPCAR.
%BRKT==40000 ; LREADR when reading bracketed atom
%LRLIT==100000 ; " when reading quoted string or bracketed atom.
%IOCER==200000 ; Used by XCTIOC uuo
%ILOPR==400000 ; Used by XCTILO uuo
; .OPTION user variable bits that COMSAT needs.
%OPALL==%OPINT+%OPOPC+%OPLOK+%OPLKF
; %OPINT gets new interrupt scheme, and
; %OPOPC says set interrupted PC properly.
; %OPLOK gets switch and lock hacking so that only one COMSAT
; is ever active, and
; %OPLKF says unlock locks if top-level fatal int. happens,
; so a new COMSAT can be started to replace previous.
; First thing is purification macros...
PURPGB==3 ; Start pure on page 3, have lots of impure.
.INSRT KSC;IVORY >
; Define our own error handling macros for PAGSER library.
DEFINE PAGSER"PSRERR ERRCOD
CALL [ PUSH P,U4
MOVEI U4,ERRCOD
JSR PAGLUZ ]
TERMIN
DEFINE PAGSER"CORLUZ
JSR CORLOS
TERMIN
; Time manipulating routines
DATIME"$$DSTB==1 ; DST bit in time words
DATIME"$$ABS==1 ; Absolute days/seconds conversions
DATIME"$$OUTT==1 ; Tables for pretty output
DATIME"$$UPTM==1 ; Rtns for system time-in-30'ths conversions
;DATIME"$$OUT==0 ; Don't need output rtns since OUT pkg has em
.INSRT DSK:SYSENG;DATIME >
; Routines for hacking hostnames table (formerly NETWRK stuff)
T==:U1 ; Alternate names for smashable ACs.
TT==:U2 ; This is mostly for NETWRK/RESOLV.
IFE U2-OC,.ERR RESOLV temp ACs lose!!
$$DQ==1 ; Domain interface code in use (mostly for NETRTS)
$$DQRN==1 ; Use RENMWO hack to cut down on resolver overhead
;; These are IFNDEFs for now so that I can play with them without
;; editing the sources every time.
IFNDEF $$DQCH,$$DQCH==1 ; RESOLV is allowed to find Chaosnet addresses
IFNDEF $$DQIN,$$DQIN==1 ; RESOLV is allowed to find Internet addresses
;; $$DQIN should be turned off as soon as the NAMES > files etc can be
;; fixed to use "foo@bar" syntax for everything.
.INSRT SYSNET;RESOLV >
; UUO Handler and routines
ULISTS==1 ; Assemble list hackery UUOS
USCALL==1 ; and special .CALL hackery (ugh)
UAREAS==1 ; Area-hacking UUOS too.
$$OUT==1 ; Ask for winning new OUT package!!
$$OUUO==0 ; Turn off old output UUOs!!!
$$OBUF==1 ; Ask OUT package for buffered-output option.
$$OERR==1 ; and for ERR output type.
$$OHST==1 ; and for host-name output frobs.
$$OTIM==1 ; and for time output items.
$$PDBG==1 ; Include debugging stuff for PAGSER.
$$CHMX==21 ; Need at least this many "channels" for OUT, sigh**2.
.INSRT DSK:KSC;NUUOS >
; LSR1 (INQUIR) database package
$$HSNM==1 ; Do assemble HSNAME cruft.
.INSRT DSK:SYSENG;LSRTNS >
IFNDEF $.ARPA,$.ARPA==0 ; No longer use .ARPA kludge by default
CONSTANTS ; Dump out any accumulated literals.
; Patch area and PDL hackery.
BVAR
PATLEN==100
PAT:
PATCH: BLOCK PATLEN
PDLLEN==500.
PDL: BLOCK PDLLEN+1
JUNK: 0 ;for infinite-sink random writes, as in POP P,JUNK
EVAR
POPBA1: POP P,B
POPAJ1: POP P,A
POPJ1: AOS (P)
APOPJ: RET
PPCBAJ: POP P,C
POPBAJ: POP P,B
POPAJ: POP P,A
CPOPJ: RET
POPDC1: AOSA -2(P)
POPCJ1: AOSA -1(P)
POPDCJ: POP P,D
POPCJ: POP P,C
RET
PPDCBJ: POP P,D
POPCBJ: POP P,C
POPBJ: POP P,B
RET
POPBJ1: POP P,B
AOS (P)
RET
SUBTTL Main Calling Paths
IFN 0,[
MAIN ;top level loop
IRQGET ;get and process an input request (e.g. from QMAIL)
SPCFND ;get all the specifications
IPATTR ;input one attribute (name plus argument as raw text)
PARRCP ;hairiest attribute parsing routine - for recipients
LREADR ;Lispish reader
APRCPT ;Process list structure after it has been read in
EQRCPL ;Recipient parsing routine (used also by NAMES file readin)
RCPEQV ;look up recipient in EQV list (NAMES file)
;called here only to hack sender's NOQC option (weird)
HPARSE ;parse header if mail from foreign host
MAIL ;takes a message expressed as an LSE and mails it off
RCPEXP ;Expand recipient list (doing eqvs and so forth)
RCPPUT ;Process one rcpt and his attribute list
RCPE ;See if rcpt with same name already on list
RCPOPT ;Get rcpt's options from NAMES file
RCPEQV ;look up rcpt in EQV list (NAMES file)
RXPNAM ;Expand local name not on EQV list (look in INQUIR and so forth)
RXPBUG ;Expand BUG-type rcpt not on EQV list
RXPAFL ;Expand @FILE-type rcpt
RCPEXT ;Shove expansions into the rcpt-list of the message
RCPPUT ;Recursively called here
RCPSRT ;Once all rcpts have been found, sort and remove duplicates
HEADER ;Format the necessary headers
RCPSND ;Send message to all recipients
SNDMSG ;Send message to one recipient
SNDNET ;send over the net
SNDFIL ;simply send to a file
WRTMSG ;actually writes into mail files
SNDBUL ;send to a .MSGS. file
WRTMSG ;write it
SNDNAM ;send to local user
WRTMSG ;actually writes into mail files
SNDPGM ;send to a program (run in inferior)
MAIL ;calls MAIL recursively to report program lossage
MAIL ;calls MAIL recursively if permanent error
QUEUE ;if temporary error, queue the message
REMSND ;send a reminder
MAIL ;calls MAIL to actually send the stuff
QUESND ;try again to send queued messages to a particular host
QSTSND ;subroutine to send one queued message
SNDMSG ;as above
NOTEW ;send positive acknowledge
MAIL
NOTEL ;send negative acknowledge
MAIL
];IFN 0
SUBTTL Attribute Definitions
; Macro to define attributes:
; ATTRIB <internal #>,<assembly sym>:,<P-name>,<input routine if external>
DEFINE ATTRIB COD,SYMC,*NAME*,IRTN
IF1 [IRPS SYM,,[SYMC]
SYM==COD
TERMIN
IFGE COD-ATRLIM,.ERR Attribute code too large!
IRP N,,[102,103,104] ; List of unused codes.
IFE N-COD,.ERR Using "unused" attribute?!
TERMIN
IFE N,.ERR Using attribute 0?!
]
%%S==.
LOC ATTRTB+COD ? ASCNT [NAME]
LOC ATTRIR+COD ? IRTN
LOC %%S
TERMIN
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ATTRIBUTE DEFINITIONS
;;;
;;; Attributes declared are all "internal" unless an input routine
;;; exists for them. Flags can be stored in the LH of ATTRIR if this
;;; later proves desirable. See doc file for more info. To add an
;;; attribute, first check the list of Unused Codes in the ATTRIB
;;; macro definition to see if there's one to assign. If none,
;;; increment the ATRLIM definition and use its old value. 0 should
;;; never be used as a code!!
;;;
;;; Some of these attributes have read-in dispatch entries for the NAMES file,
;;; and others for "ATTRIBUTE:" in IRQ files.
ATRLIM==110 ; Current limit for attrib codes. All must be less than this!!
A$==,,-1 ; For bit-typeout mode
ATTRTB: BLOCK ATRLIM ; Table indexed by <code>, holds ASCNT ptr to name.
ATTRIR: BLOCK ATRLIM ; Table to hold routine addr for xct'ing on input.
; General Purpose Attributes
ATTRIB 1,A$ATTR:,|ATTRIBUTE| ; S Name of attribute for succeeding A$AVAL (if any)
ATTRIB 2,A$AVAL:,|ATTRIBVAL| ; * Holds value for preceding A$ATTR
ATTRIB 3,A$XATR:,|X-ATTRIBUTE| ; S Like A$ATTR but used for Net-header attribs.
ATTRIB 4,A$XVAL:,|X-ATTRIBVAL| ; * Like A$AVAL.
ATTRIB 5,A$PREQ:,|SPECIAL-REQ|, APQTL ; L Indicates special (non-mail) processing.
;ATTRIB 6,A$PARG:,|SPECIAL-ARG|, APLST ; L Holds list of args for A$PREQ.
; Message Attributes
ATTRIB 10,A$ID:, |MESSAGE-ID| ; S Message ID for message.
ATTRIB 11,A$SNM:, |SENDER|, APSTR ; S sender's name
ATTRIB 12,A$CSN:, |SENT-BY|, APSTR ; S sender's claimed-to-be name.
ATTRIB 107,A$FFM:, |FAKE-FROM|, APSTR ; S sender's name for "From"
ATTRIB 100,A$SNH:,|SENDER-HOST| ; V sender's host (for net mail)
ATTRIB 105,A$SRTP:,|RETURN-PATH|,APSTR ; S SMTP return path spec
;; this used to be called MAINT-PATH, hence the odd name
ATTRIB 106,A$SMRP:,|ERRORS-TO|,APSTR ; S sender's error return path
ATTRIB 13,A$MTXT:,|TEXT|, APSTR ; S input message-text
ATTRIB 7, A$MTXF:,|TEXT-FLAG| ; V flag saying if ^_ or crlf.crlf in message.
ATTRIB 14,A$MHDR:,|HEADER| ; S Header for message.
ATTRIB 15,A$KHDR:,|KLUDGE-HEADER| ; S Kludge to prevent ITS headers from going out
ATTRIB 16,A$NMH:, |NET-MAIL-HOST| ; V Host # origin of network-input.
ATTRIB 17,A$SBJ:, |SUBJECT|, APSTR ; S Subject if any
ATTRIB 20,A$TIM:, |DATE| ; V Time msg created on dsk
ATTRIB 101,A$UHDR:,|USER-HEADER|,APSTR ; S User-specified header line.
ATTRIB 21,A$HFRC:,|HEADER-FORCE|,APSTR ; S Type of header force if any
ATTRIB 22,A$RLN:, |RCPT-LIST-NAME|,APSTR; S Rcpt list name for "To":
ATTRIB 23,A$XPIR:,|EXPIRES|, APNUM ; V # days until this MSG expires
ATTRIB 24,A$MFN1:,|MSG-FN1|, AP6W ; V Sixbit FN1 for type *MSG.
ATTRIB 25,A$MFN2:,|MSG-FN2|, AP6W ; V Sixbit FN2 for *MSG.
ATTRIB 26,A$CNF:, |CONFIRMATION|,APSTR ; S Confirmation option (ALL, or FAIL only)
ATTRIB 36,A$IDRM:,|ID-REMINDER| ; S Holds ID of parent, when msg generated from reminder
ATTRIB 30,A$TEXP:,|REM-EXPIRES|,APNUM ; V Time or count for Reminder expiration
ATTRIB 31,A$TNXT:,|REM-NEXT|, APNUM ; V Abs time for very next sending of this reminder.
ATTRIB 32,A$TLST:,|REM-SPEC-LIST|,APLST ; L Holds list for 1 reminder time specification.
; Remind-time Attributes, stored under a REM-SPEC-LIST.
ATTRIB 33,A$TBAS:,|REM-TIME-BASE|,APNUM ; V Holds time base to start from (optional)
ATTRIB 34,A$TINC:,|REM-TIME-INC|,APNUM ; V Holds repeat-increment specifications.
ATTRIB 35,A$TSPC:,|REM-TIME-SPEC|,APNUM ; V Holds date/time repeat specifications.
; Message Attributes - Recipient nodes
ATTRIB 54,A$RCP:, |RCPT-LIST| ; L Holds active RCPT attribs.
ATTRIB 55,A$RCPF:,|RCPT-LIST-FAIL| ; L ditto but marks as failed.
ATTRIB 56,A$RSNT:,|RCPT-LIST-SENT| ; L ditto but marks as sent.
ATTRIB 27,A$RDON:,|RCPT-LIST-DONE| ; L ditto but marks "done", inactive.
; Recipient Attributes
ATTRIB 40,A$RTYP:,|R-TYPE|, APSTR ; S Type of recipient (BUG, PGM, etc)
ATTRIB 41,A$RHST:,|R-HOST|, APHST ; V Destination host # for rcpt
ATTRIB 42,A$RNAM:,|R-NAME|, APSTR ; S Name of rcpt
ATTRIB 43,A$RPSN:,|R-PSEUDO| ; V Existence indicates rcp name is psuedo.
ATTRIB 37,A$RHDR:,|R-HEADER| ; S Rcpt's very own header.
ATTRIB 57,A$RHFC:,|R-HEADER-FORCE|,APSTR; S Header force, for this rcpt.
ATTRIB 44,A$RRES:,|R-RESULT| ; S Result of SNDMSG (failed, queue, sent)
ATTRIB 45,A$RRMG:,|R-RESULT-MSG| ; S Err msg if A$RRES==failed.
ATTRIB 74,A$RFCT:,|R-FAILURE-COUNT| ; V Number of times tried to send and lost
ATTRIB 47,A$RMDS:,|R-MODE-SEND|,APNUM ; V Sending mode (see comments for SENDSW, MAILSW)
ATTRIB 50,A$RMDM:,|R-MODE-MAIL|,APNUM ; V Mailing mode
ATTRIB 51,A$RPMR:,|R-PGM-MNTNR|,APRCPT ; L If type = PGM, specifies maintainer to notify.
ATTRIB 67,A$RPGD:,|R-PGM-DISOWN|,APNUM ; V If type = PGM, control bits for job.
ATTRIB 73,A$RPGU:,|R-PGM-USET|, AP2NUM ; L List holds two values, .USET sym and value.
ATTRIB 52,A$ROPT:,|R-OPTION|, APSTRS ; S Recipient Option name
ATTRIB 53,A$RNK:, |R-NOT-KNOWN| ; V Existence means rcpt not known.
ATTRIB 46,A$RHSN:,|R-HSNAME| ; V Holds 6bit HSNAME of local rcpt without a dir.
; Attribs for Scheduler List.
ATTRIB 60,A$S:, |SCHED-ITEM-LIST| ; L List holding schedule requests
ATTRIB 61,A$STIM:,|SCHED-TIME| ; V System time at which to execute.
ATTRIB 62,A$SRTN:,|SCHED-RTN| ; V Routine to execute.
ATTRIB 63,A$SARG:,|SCHED-ARG| ; V Argument for routine.
; Attribs for Master List.
ATTRIB 64,A$I:, |MASTER-ITEM-LIST| ; L List holding Message-ID/Disk addr correspondence.
ATTRIB 65,A$IDAD:,|DISK-ADDR| ; V Disk addr of LSE for this message.
ATTRIB 66,A$IDBL:,|DISK-LENGTH| ; V Length of its LSE on disk.
; Attribs for Queued Message List.
ATTRIB 70,A$Q:, |QUEUE-SITE-LIST| ; L List holding Site/Message-ID correspondence.
ATTRIB 76,A$QFL:, |QUEUE-FINALIZE-LIST| ; L List holding ID's to finalize.
ATTRIB 71,A$QHST:,|QUEUE-SITE| ; V Site # which following ID's are queued for.
ATTRIB 77,A$QFCT:,|QUEUE-FAILURE-CNT| ; V # times this site failed.
; Attribs for Reminder Message List.
ATTRIB 75,A$T:, |REMINDER-LIST| ; L Entry on the RML.
; Attribs for EQV list
ATTRIB 72,A$E:, |EQV-LIST|, APEQVL ; L Equivalence list for recipient.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; IARCOD - Given SLP in A to uppercase string, checks to see if it
; matches a non-internal attribute name, and if so skips with
; internal code in RH(B).
IARCOD: MOVSI B,-ATRLIM
SKIPE ATTRIR(B) ; Skip if internal name (a no-no)
SLNEA A,ATTRTB(B) ; This one is OK, does name match?
AOBJN B,.-2
CAIGE B,0 ; Don't skipret if counted out.
AOS (P)
RET
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Table of known recipient types.
RTYPTB: ASCNT [BUG]
ASCNT [FILE]
ASCNT [NAME]
ASCNT [PGM]
ASCNT [*MSG]
ASCNT [@FILE]
NRTYPS==:.-RTYPTB
; Table of sending routines to dispatch on, corresponding to RTYPTB.
SNDRTB: SNDBUG
SNDFIL
SNDNAM
SNDPGM
SNDBUL
SNDAFL
IFN NRTYPS-<.-SNDRTB>,.ERR SNDRTB loses
; Message-Result definitions
; These values are returned by certain routines such as SNDMSG
; responsible for sending a message. Note that all temporary
; errors are even (low bit zero), and permanent errors are odd.
; When an error message is furnished, it should not begin or
; end with a CRLF; if a CRLF is embedded, a tab should follow it.
; This is just for prettiness when string is put into a receipt msg.
MR$WIN==:0 ; Message won, sent to rcpt. This is the only return
; which is NOT expected to furnish some sort of err msg.
MR$PER==:1 ; Perm Err for Rcpt. This rcpt failed forever, but
; can keep trying site for other rcpts.
; This is most often the result of a 450 reply from remote
; host, but might also result from rare local errors.
MR$TER==:2 ; Temp Err for Rcpt, must queue. Can keep trying site for
; other rcpts.
; This return happens for such things as "dir full" (local)
; or "mailbox busy", "job cap exceeded", etc. (remote)
MR$PEH==:3 ; Perm Err for Host; this host failed forever.
; Should never happen for local site (!). Will happen for
; remote sites which have been getting MR$TEH's for too long.
; Can also be generated "by hand" to flush a queue.
MR$TEH==:4 ; Temp err for Host; don't bother trying site further at
; moment. This return can happen if disk space gronked
; (local) or remote host dies during sending (IOC error,
; timeout, failed ICP, etc.)
MR$MAX==:4 ; Max possible MR$ value
MR$TAB==:MR$MAX+1 ; For checking dispatch tables.
comment |
MR$TEM ? - Temp Err for Msg; implies some temporary error associated with
the message itself, rather than with the host or a specific rcpt.
This might possibly happen for weirdness in a message such as
^C's or the like, but that is supposed to be circumvented
by MLFL or quoting. May happen for overly long msg text,
if a remote site has a very low length tolerance; in this case
we won't want to keep re-trying for every rcpt!!
MR$PEM ? - Perm Err for Msg; Ditto, but permanent.
Same mumblings as for MR$TEM.
|
SUBTTL Various variables and standard filenames
;; Hostname strings are 63 words (255. bytes) long, per RFC883.
BVAR
DEBUG: -1 ;non-z means (mainly) to stop on errors instantly.
XVERS: -1 ; Version type -
; 0 - Normal operational mailer
; 1 - "New" mailer, operational but not completely tested.
;-1 - Experimental mailer, for debugging/development.
OWNHST: 0 ;Our own host address on the network we're really connected to.
OWNHS2: 0 ;Alternate host address to consider local .SEE TCPGAT
;With domains, we always need this if we are dual-net. Foo.
MYUIND: -1 ;COMSAT's user index, used by SUNAME
OWNNAM: BLOCK 63 ;holds asciz string which is name of own site
GATNAM: BLOCK 63 ;holds asciz string which is name of TCP relay host
TMPNAM: BLOCK 63 ;holds asciz string which is name of random host
PRGNAM: .FNAM1 ; FN1, FN2 of source file assembled from.
VERSHN: .FNAM2
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Names for mail directory files
; SATF "<norm>",<xper>,<new> - specifies a SIXBIT filename
; which varies depending on whether COMSAT is running as
; the normal, experimental, or new-operational mailer.
NSTFLS==0
DEFINE SATF &NORM&,XPER,NEW
%%SLOC==.
IF1 ? [SIXBIT |XPER|],,[SIXBIT |NEW|] ; Goddam constants lossage
IF2 [ SIXBIT NORM
TMPLOC XVARTB+NSTFLS,{%%SLOC,,[SIXBIT |XPER|]}
TMPLOC NXVRTB+NSTFLS,{%%SLOC,,[SIXBIT |NEW|]}
]
NSTFLS==NSTFLS+1
TERMIN
SATDEV: SIXBIT /DSK/ ; Satellite Device
SATDIR: SIXBIT /.MAIL./ ; Satellite Directory
; Directory is .BULK. for bulk mailer
MSTFN1: SATF " LIST",XLIST,NLIST ; MASTER LSE file
MSTFN2: SIXBIT /MASTER/
NMSFN1: SATF " LIST",XLIST,NLIST ; FNM to use when GC'ing MSGS.
SIXBIT /NMASTR/
QMLFN1: SATF " LIST",XLIST,NLIST ; QML LSE file.
QMLFN2: SIXBIT / QUEUE/
RMLFN1: SATF " LIST",XLIST,NLIST ; RML LSE file.
RMLFN2: SIXBIT /REMIND/
MSGFN1: SATF " LISTS",XLIST,NLIST ; File of MSG LSEs.
MSGFN2: SIXBIT / MSGS/
NMGFN1: SATF " LISTS",XLIST,NLIST ; FNM to use when GC'ing MSGS.
SIXBIT / NMSGS/
EQAFN1: SATF "NAMES",XNAMES,NNAMES ; ASCII name equivalence/options file
EQAFN2: SIXBIT />/
EQAFR1: 0 ; Used to hold real translated filenames.
EQAFR2: 0
EQRFIL:: ; Holds file blk for compilation-report file.
EQRDEV: 0
EQRDIR: 0
EQRFN1: SATF "NAMED",XNAMED,NNAMED
EQRFN2: 0
EQVFN1: SATF " LIST",XLIST,NLIST ; Binary name equivalence/options file.
EQVFN2: SIXBIT / EQV/
LSRFN1: SIXBIT / FROM/ ; Indicator file left by INQUIR, fresh
LSRFN2: SIXBIT /INQUIR/ ; file means fresh LSR waiting to be gobbled.
HSTDEV: SIXBIT /DSK/ ; File name of the host tables.
SIXBIT /SYSBIN/
SIXBIT /HOSTS3/
SIXBIT />/
IRQFN1: SATF "MAIL",XMAIL,NMAIL ; Filename of mail requests.
IRQFN2: SIXBIT /</ ; note FIFO sequence!
IRIFN1: SATF "MAILIN",XMAILI,NMAILI ; Filename of recognized mail requests.
IRIFN2: SIXBIT />/ ; note FILO sequence!
IREFN1: SATF "BADREQ",XBADRQ,NBADRQ ; Erroneous input reqs renamed to this.
IREFN2: SIXBIT />/
IRRFIL: 0 ? 0 ; Used by RFNAME call to find true input-req FN.
IRRFN1: 0
IRRFN2: 0
IDFN1: SATF " ID",XID,NID ; Name used to obtain unique Message-ID number.
IDFN2: SIXBIT />/
; Names for statistics files
STFN1: SATF "STATS",XSTATS,NSTATS ; Name of actual stats file
STFN2: SIXBIT />/
STOFN1: SATF "OSTATS",XOSTAT,NOSTAT ; Name for old stats files
STOFN2: SIXBIT />/
; Names for locked switch file (to ensure uniqueness)
LCKFN1: SATF " LOCK",XLOCK,NLOCK
LCKFN2: SIXBIT /UNIQUE/
UNMPRF: SIXBIT /COMSAT/ ; Preferred UNAME
JNMPRF: SATF "IV",XPER,NEW ; " JNAME (major version #, sort of)
; JNAME is BULK for bulk mailer
EVAR
; Table of vars to change when running in experimental mode!
XVARTB: BLOCK NSTFLS ; To hold sat filenames which change.
; Can have other vars here in form
; <addr>,,[<new value>]
NXVARS==:.-XVARTB
; Vars to change when running in "New operational" mode!
NXVRTB: BLOCK NSTFLS ; To hold sat filenames which change.
; Can have other vars here in form
; <addr>,,[<new value>]
NNXVRS==:.-NXVRTB
XVRSRT: SKIPN XVERS ; If normal,
RET ; don't change anything.
PUSHAE P,[A,B,C]
MOVE C,[-NXVARS,,XVARTB]
SKIPL XVERS ; Use XVARTB if experimental
MOVE C,[-NNXVRS,,NXVRTB] ; Else use "new operational" vars.
XVRSR1: MOVE A,(C)
HLRZ B,A
MOVE A,(A) ; Get xper. value to use
MOVEM A,(B) ; Store in indicated loc
AOBJN C,XVRSR1
POPAE P,[C,B,A]
RET
SUBTTL Initializations for bulk mailer kludge
.scalar bootxj ; Original XJNAME (for RESET, ugh)
bulkck: push p,a
.suset [.rxjname,,bootxj]
move a,bootxj
came a,[sixbit /VDNBRG/]
jrst popaj
move a,[sixbit /.BULK./]
movem a,satdir
move a,[sixbit /BULK/]
movem a,jnmprf
;; need to break local delivery
jrst popaj
SUBTTL Statistics file routines
; Macro to write stats with. (see SCOPN)
; Generates a <CRLF><time><TAB> before writing given OUT-style list.
; Saves and restores OC output channel so it can appear anywhere;
; this isn't usually necessary, but better safe than sorry.
DEFINE STAT (LIST)
PUSH P,OC
CALL STTLIN
OUT!LIST
CALL STTFIN
TERMIN
; ditto, but no <CRLF><time><TAB> insertion.
DEFINE CSTAT (LIST)
PUSH P,OC
MOVEI OC,SC
OUT!LIST
CALL STTFIN
TERMIN
; Like STAT, but can be skipped over.
DEFINE PSTAT (LIST)
CALL [ PUSH P,OC
CALL STTLIN
OUT!LIST
CALL STTFIN
RET ]
TERMIN
; STTLIN - Start stat report with time line
; Assumes that C/STAT macros are saving/restoring OC.
STTLIN: OUT(,CH(SC),EOL) ; Set std output chan, and do a CRLF.
SOS SCLCNT ; Decrement line cnt, but don't put date cruft in yet.
.RTIME U4, ; Get hhmmss in U4
OUT(,6F(U4),TAB) ; Output time plus indentation.
RET
; STTFIN - force stats channel and also restore saved OC
STTFIN: OUT(,FRC)
POP P,OC
EXCH OC,(P)
RET
SCMAXL: 5*50.*2000 ; Max length of stats file before renaming, in chars.
LVAR SCLCNT: 0 ; Cntdn of lines - when < 0, put full date in stats.
STTLIM==40. ; # of lines to count down.
STBFLN==50. ; Use 50 wds for SC output buffer.
LVAR STBUF: BLOCK STBFLN ; Need fixed buffer because a dynamically
; allocated one could be screwed by various lossages.
; SCOPN - Open SC channel to STATS file
SCOPN: PUSHAE P,[A,B]
TLZ F,%SCOPN ; Clear flag
; Try to open stats file in write-over mode.
MOVE B,[%DOWOV+.UAO,,SC]
ECALL SCOBLK,[[4,SCOPN4],[*,23,SCOPN1]]
JSR SYSLOS ; If 4 = File not found, create it at SCOPN4
; If 23= File locked, hack it at SCOPN1
; Else horrible error!
SYSCAL FILLEN,[CIMM SC ? CRET A] ; Got it, find current length.
JSR SYSLOS ; gasp choke?
.ACCESS SC,A ; Point to end of file.
OUT(SC,OPEN(UC$BUF,,[-STBFLN,,STBUF])) ; Open buffered UUO chan.
TLO F,%SCOPN ; Indicate SC channel now open!
CAMG A,SCMAXL ; Have length. Is current file too long?
JRST SCOPN5 ; It's OK, continue blissfully.
JRST SCOPN0 ; Too long, have to close and rename.
; Entry point from MAIN loop when file is too long.
SCROPN: PUSHAE P,[A,B] ; Real programmers don't use co-routines....
; STATS file too long, time to rename it and start another.
SCOPN0: STAT (,("Renaming stats file..."),TIM(MDYT))
OUT(SC,CLS) ; Close channel, making sure all's output.
TLZ F,%SCOPN ; (must close to let RENAME below win.)
; Some cretin has the STATS file locked, but let's outsmart the loser.
; This stuff also done when STATS file too long.
SCOPN1: SYSCAL RENAME,[['DSK,,] ? STFN1 ? [SIXBIT /</] ; Rename oldest STATS
SATDIR ? STOFN1 ? STOFN2 ; to newest OSTATS
CERR A]
JRST [ CAIE A,4 ; Didn't rename? File still there?
CAIN A,23 ; or file locked (must be for writing)?
JRST SCOPN4 ; One of these, renaming done.
JSR SYSLOS] ; Neither 4 nor 23? Argh, horrible error?!
JRST SCOPN1 ; If rename successful, continue til all gone.
; Here to create new STATS file. Comes here if none exists, or after
; all STATS files have been renamed to OSTATS (same thing).
SCOPN4: MOVE B,[.UAO,,SC]
ECALL SCOBLK,[[5,SCOPNX]] ; watch out for dir full.
JSR SYSLOS ; Foo?
OUT(SC,OPEN(UC$BUF,,[-STBFLN,,STBUF])) ; Open buffered UUO chan.
TLO F,%SCOPN ; Say stats file open!
STAT (,("TELEMETRY FILE CREATED, DATE "),TIM(F1))
STAT (,("This is version "),6F(PRGNAM),(" "),6F(VERSHN))
STAT (,(";;; NOTE!!! If you are reading this file with ^R or :PRINT,
please type ^S or ^G to stop at once!
You are damaging mailer response!"))
JRST SCOPN8 ; Skip writing full date again
SCOPN5: SKIPLE SCLCNT ; Now have SC open, must we insert full date?
JRST SCOPN9 ; Nope, that's all.
OUT(SC,CRLF,EOL)
STAT (,("Date is now: "),TIM(MDYT))
SCOPN8: MOVEI A,STTLIM ; This many lines per full-date insertion
MOVEM A,SCLCNT
SCOPN9: POPAE P,[B,A]
RET
; Come here if get DIR FULL error trying to open stats file.
SCOPNX: CALL SDFULL ; Attempt to fix, die if can't.
TLNE F,%SCOPN
JRST SCOPN5 ; recovered! continue depending on %SCOPN state.
JRST SCOPN4
SCOBLK: SETZ ? SIXBIT /OPEN/ ? B ? SATDEV ? STFN1 ? STFN2 ? SETZ SATDIR
CONSTANTS
SUBTTL ERROR system call analyzer macro
; Example:
; SYSCAL OPEN,[[.UAI,,DKIC] ? [SIXBIT /DSK/] ? [SIXBIT /MICKEY/]
; [SIXBIT /MOUSE/] ? [SIXBIT /USERS/] ? CERR MMERR]
; ERROR [[%ENSFL,FOO20],[ERR,MMERR],[CALL,%ENADV,FOO40]]
; ERROR - Macro to put in non-skip error returns from system calls.
; The easiest way to explain this is to explain the above
; example, which is trying to open DSK:USERS;MICKEY MOUSE is
; unit ascii input mode, and asking for an explicit error
; code returned in MMERR. Here is what the ERROR macro following
; it will do: first, it will find the error code in MMERR
; because of the [ERR,MMERR] clause. (Had there been no ERR
; clause it would have used the STATUS of the .BCHN channel).
; Then if there were a "File not found" (%ENSFL) it would
; JRST to FOO20. If there were a "Device not availible", it
; would have gone to FOO40 leaving the stack set up to
; point at the saved ACs D, C, B, and A in that order, and
; below that the address of the SYSCAL. In other words,
; the routine at FOO40 would retry the SYSCAL by doing
; a "POPAE P,[D,C,B,A] ? RET" . The routine is passed
; one argument (in A) which is the error code.
; The ERR is optional, and there may be an arbitrary
; number of handlers for error codes, each of which may be
; a plain JRST (i. e. [%ENSFL,FOO20]) or a CALL (i. e.
; [CALL,%ENADV,FOO40]) depending on which the programmer
; thinks is cleaner for the occasion.
; The ERROR macro expands into a call to CALERR.
DEFINE ERROR LIST
%%ERCT==0
CALL [PUSH P,[[
IRP ITEM,,[LIST]
%%ERCT==%%ERCT+1
IRP ERRCOD,VECTOR,[ITEM]
IFSE ERRCOD,ERR,{ C$ECL_C%OPSH,,VECTOR
.ISTOP}
IFSE ERRCOD,CALL,{ IRP ERCD,VECT,[VECTOR]
C$CAL_C%OPSH+ERCD,,VECT
.ISTOP
TERMIN
.ISTOP}
ERRCOD,,VECTOR
.ISTOP
TERMIN
TERMIN
](-%%ERCT)]
PJRST CALERR]
TERMIN
; CALERR - Routine called by ERROR (see above). Figure out how to use
; ERROR before you read this...
; ERROR will generate a calling sequence of the form
; .CALL FOO
; CALL [PUSH P,[-n,,[param1 ? param2 ? ... ]]
; PJRST CALERR]
; There is one parameter for each clause in the ERROR call.
; n is the number of parameters. A parameter is decoded by opcode:
C%OPCD==410300 ; Byte spec for the opcode field
C%OPSH==17 ; (LH shift amount)
; Here are the currently defined opcodes:
;OPCODE: WHAT THE PARAMETER WORD MEANS
;==0 ; Bits 3.6-3.1 are an error code, and the
; RH is an address to jump to if that
; error occurs (the simple ERROR clause).
C$ECL==1 ; RH is loc of word containing error code (for ERR)
C$CAL==2 ; Like 0, except generates the hairier
; calling sequence (CALL)
CALERR: PUSHAE P,[A,B,C,D]
SKIPGE C,-4(P) ; Get argument off stack.
JSR AUTPSY ; If nothing, die.
HRLI A,-3(P) ; Now move the three saved ACs up one slot
HRRI A,-4(P) ; on the stack. (if you think THIS is bad,
BLT A,-1(P) ; take a look at TRANTR sometime.)
SUBI P,1 ; And adjust the stack pointer.
MOVE A,C ; Get a copy of the AOBJN pointer.
CALR10: LDB B,[C%OPCD,,(A)] ; Now search for a parameter with opcode
CAIE B,C$ECL ; C$ECL, loc of err code.
AOBJN A,CALR10
JUMPL A,CALR20 ; Found it.
.SUSET [.RBCHN,,A] ; Not found, figure it out.
SYSCAL STATUS,[MOVEI A ? MOVEM A]
JSR AUTPSY
LDB A,[220600,,A] ; Magic field which holds the error code is 3.6-3.1)
CAIA
CALR20: HRRZ A,@(A) ; Now have err code in A.
CALR30: LDB B,[220600,,(C)] ; Check each param. for this code.
CAIE B,(A)
AOBJN C,CALR30
JUMPL C,CALR40 ; Found!
JSR AUTPSY ; Not there, die horribly.
CALR40: HRRZ B,(C) ; Get the address in B.
LDB D,[C%OPCD,,(C)] ; Get opcode.
CAIE D,C$CAL ; Is it a CALL clause?
JRST CALR50
SOS -4(P) ; Fix the saved return address to point
SOS -4(P) ; at the .CALL instruction itself.
JRST (B) ; Dispatch to handler.
CALR50: MOVEM B,-4(P) ; Slight kludge to restore ACs and
POPAE P,[D,C,B,A] ; jump to given location.
RET
SUBTTL Interrupt handlers - IOC, MPV, PDLOV, ILOPR
%BADPI==%PIIOC+%PIMPV+%PIPDL+%PIILO+%PIWRO ; Bad conditions
;;; Interrupt vector table for new style ITS interrupts.
TMPLOC 42,{-LINTBLK,,INTBLK} ; New mode interrupt vector
%NINTS==400000 ; 4.9 bit means push .JPC, .SUUOH, LSPCL also
INTBLK: %NINTS,,INTPDP ; PDL ptr addr
; .REALT interrupt vector, defer more RLT's
%PIRLT ? 0
%PIRLT ? 0
INTRLT
; IOC error interrupt vector. defer all but MPV and PDL OV.
%PIIOC ? 0
-1#<%PIMPV\%PIPDL> ? -1
INTIOC
; PDL overflow int vec. Defer all but MPV.
%PIPDL ? 0
-1#<%PIMPV> ? -1
INTPDL
; MPV int vec. defer everything.
%PIMPV ? 0
-1 ? -1
INTMPV
; WRO int vec. defer everything.
%PIWRO ? 0
-1 ? -1
INTWRO
; Illegal Operation int vec, defer more ILOPR's
%PIILO ? 0
%PIILO ? 0
INTILO
; Inferior Interrupt int vec. defer more of same.
0 ? 377,,0
0 ? 377,,0
INTUSR
; ; Sys going down int vec. defer more of same.
; %PIDWN ? 0 ? %PIDWN ? 0 ? INTDWN
LINTBLK==.-INTBLK
BVAR
LIPDL==50. ; Enough for 6 or so nestings of ints.
INTPDP: -LIPDL,,IPDL-1 ; Interrupt PDL pointer.
IPDL: BLOCK LIPDL ; " " stack.
EVAR
; Macro to ease dismissing interrupts. DISMIS restores with old PC,
; DISMIS [addr] restores with given new PC.
DEFINE DISMISS (ADDR)
.CALL [SETZ ? 'DISMIS ? CTLI %NINTS
IFB [ADDR] SETZ INTPDP
.ELSE INTPDP ? SETZ ADDR
]
TERMIN
; Macros to ease saving/restoring stuff for stats output.
; Basically saves/restores UUO vars.
DEFINE IUSAVE
PUSHAE P,[U40,U1,U2,U3,U4]
IFN OC-U2, PUSH P,OC
IFE $$UCAL,PUSH P,UUORPC
TERMIN
DEFINE IUREST
IFE $$UCAL,POP P,UUORPC
IFN OC-U2, POP P,OC
POPAE P,[U4,U3,U2,U1,U40]
TERMIN
;*********************** IOC INTERRUPT *********************************
; I/O Channel Error
BVAR
IOCBCH: 0 ; BCHN, # of channel IOC happened on.
IOCIOS: 0 ; IOS word for channel, holds error code.
IOCDEV: 0 ; Word 1 returned by RFNAME, usually device name.
IOCFN1: 0 ; Word 2 "
IOCFN2: 0 ; Word 3 "
IOCDIR: 0 ; Word 4 " , usually directory name
IOCMOD: 0 ; Word 5 " , mode channel open in.
EVAR
INTIOC: TRNE F,%IOCER ; "Expected" IOC? (i.e. XCTIOC)
JRST IOCLUZ ; Yep, whew... let XCTIOC code handle safely.
PUSHAE P,[A,B,C]
.SUSET [.RBCHN,,IOCBCH] ; Get # of bad channel
SYSCAL STATUS,[IOCBCH ? CRET IOCIOS] ; and IOS word for it.
JSR SYSLOS
SYSCAL RFNAME,[IOCBCH ? CRET IOCDEV
CRET IOCFN1 ? CRET IOCFN2 ? CRET IOCDIR]
JSR SYSLOS ; shouldn't happen.
MOVE A,IOCBCH ; Now getum channel into AC.
CAIN A,SC ; Before we try any reporting, see if 'twas
TLZ F,%SCOPN ; the stats channel itself that's zapped!!!
LDB B,[330500,,IOCIOS] ; Isolate IOC error #.
; Check for outright and obvious bugs
CAIE B,5 ; Over-IOPOP,
CAIN B,6 ; or IOPUSH?
JRST IIOC90
; Passed initial checking, now see if it happened while hacking net;
; Network IOC errors are facts of life and ok...
CAIN A,NETD ; Net data channel?
JRST IIOC10
CAIE A,NETO ; Net output channel?
CAIN A,NETI ; Net input channel?
JRST IIOC10 ; Dispatch if hacking net.
; Ugh, error is very likely fatal... see if it's anything that is
; a recognized problem.
CAIE B,11 ; Device full?
CAIN B,14 ; or directory full?
JRST IIOC20 ; Yep, storage problems.
CAIN B,15 ; (DM only??) Dir alloc exhausted?
JRST IIOC20
; Error is completely unrecognized, scream loudly.
; Also come here if no way to resolve some known problem.
IIOC90: JSR PRESRV ; Save stuff, swap PDL, etc.
CAIN A,SC ; Of course, if SC was at fault,
JRST [ JSR BURY ; screaming is unlikely to win.
JSR UDEATH]
TLNN F,%SCOPN ; If SC simply not open,
JRST AUTPY1 ; let AUTPSY do the re-open attempt & reporting
STAT (,(" ==="),RABR,(" IOC ERR, BCHN="),OCT(A),(", IOS="),H(IOCIOS),("
DEV=|"),6F(IOCDEV),("|
FN1=|"),6F(IOCFN1),("|
FN2=|"),6F(IOCFN2),("|
DIR=|"),6F(IOCDIR),("|
MOD="),H(IOCMOD))
DISMISS [AUTPY1] ; Get out of int. level.
; Network IOC. Dismiss to net ioc handler, if one exists.
IIOC10: SKIPN NTIOCV ; So does a handler exist?
JRST IIOC90 ; Foo, a wild IOC has burst loose! Go faint...
POPAE P,[C,B,A]
DISMISS NTIOCV ; Win, leave int level & punt to handler.
; Storage-exhaustion IOC. See if it's for COMSAT's own dir.
IIOC20: MOVE B,IOCDIR
CAMN B,SATDIR ; Same dir as Comsat?
JRST IIOC30 ; Yes, there's still a slim hope...
; Here, problem is essentially an unguarded IOT to some
; loser's directory. There is basically nothing to do besides
; ensuring that the cruft we're writing doesn't contribute
; to the lossage, and making sure that an XCTIOT is slapped
; around the guilty instruction in the source.
MOVE B,IOCFN1
CAME B,[SIXBIT /_MAIL_/]
JRST IIOC90 ; Sigh
MOVE B,IOCFN2
CAME B,[SIXBIT /OUTPUT/]
JRST IIOC90 ; also sigh
SYSCAL DELETE,[IOCDEV ? IOCFN1 ? IOCFN2 ? IOCDIR]
JRST IIOC90 ; Well, it was worth a try.
JRST IIOC90
; Here, ran out of storage on COMSAT's own sacred directory!
IIOC30: POPAE P,[C,B,A]
CALL SDFULI ; Attempt desperation measures at interrupt level.
DISMISS ; If we return at all, we've won!!
; Stuff for handling expected IOC errors
UUODFE XCTIOC,UXCTIO ; skip unless IOCER occurs
UXCTIO: TRO F,%IOCER
IFE $$UCAL,PUSH P,UUORPC ; Ensure ret addr on stack since may xct UUO.
PUSH P,U40 ; Must also save due to interrupt lossage (40 zapped)
MOVEM P,XIOCP ; Save PDL pointer...
XCT @(P) ; Execute instruction...
CAIA
AOS -1(P)
AOS -1(P)
IOCRET: TRZ F,%IOCER
SUB P,[1,,1] ; Flush saved loc 40
RET ; Return from UUO.
.SCALAR XIOCP ; Place to save PDL pointer for XCTIOC.
; Here when IOCERR happens with flag set
IOCLUZ: SKIPE MAKING ; IOCERR under DEBUG is expected in MAKMST
SKIPN DEBUG
CAIA
.VALUE ; Halt here with expected IOC error in DEBUG mode.
MOVE P,XIOCP ; Restore PDL pointer...
DISMISS [IOCRET]
;************************* RLT INTERRUPT ******************************
; Real-Time Clock Interrupt
; The new way to do real time interrupts is to put the address of the handler
; you want to use into RLTVEC; when a real-time interrupt occurs, the
; routine will be jumped to. If the sign bit is set, the dispatch
; will happen at interrupt level, and the handler is responsible for
; DISMISS'ing!
; Be sure to CLKOFF and SETZM RLTVEC in the handler, and also
; if you decide the timeout is no longer in effect.
LVAR RLTVEC: 0 ; (See above)
INTRLT: SKIPGE RLTVEC ; Does a int-level handler exist?
JRST @RLTVEC ; Yes, jump there! Handler must DISMISS.
SKIPE RLTVEC ; Does a prog-level handler exist?
DISMISS RLTVEC ; Yes, dismiss and dispatch there!
; Unknown cause of RLT interrupt.
PUSH P,A
IUSAVE ; Save UUO vars since doing stats output.
MOVE A,INTPDP
MOVE A,-3(A)
STAT (,(" ==="),RABR,(" BUG: Random REALT int, PC="),RHV(A),(", continuing."))
IUREST ; Restore UUO vars.
POP P,A
DISMISS ; Returns normally
; PDL OV, MPV, and ILOPR Interrupt handlers.
INTPDL: JSR PRESRV
TLNN F,%SCOPN
JRST AUTPY1
STAT (,(" ==="),RABR,(" BUG: PDL OVERFLOW!"))
JRST AUTPY1 ; Jump into autopsy routine
INTMPV: JSR PRESRV
TLNN F,%SCOPN
JRST AUTPY1
STAT (,(" ==="),RABR,(" BUG: MPV!"))
JRST AUTPY1 ; Jump into autopsy routine
INTWRO: JSR PRESRV
TLNN F,%SCOPN
JRST AUTPY1
STAT (,(" ==="),RABR,(" BUG: WRO!"))
JRST AUTPY1
INTILO: TRNE F,%ILOPR ; Skip if error not foreseen,
DISMISS [ILORET] ; else was predicted, return to special loc!
JSR PRESRV ; Perform autopsy, unexpected ILOPR.
TLNN F,%SCOPN
JRST AUTPY1
STAT (,(" ==="),RABR,(" BUG: ILOPR!"))
JRST AUTPY1
UUODFE XCTILO,UXCTIL ; Like XCT but will skip unless ILOPR occurs.
UXCTIL: TRO F,%ILOPR ; Set flag telling ILOPR handler it's OK.
XCT @U40 ; Do whatever.
CAIA ; a non-skipping instr really skips once
AOS UUORPC ; a skipping instr really skips twice
AOS UUORPC
ILORET: TRZ F,%ILOPR
UUOXRT ; Return (w/o skipping if ILOPR occurred)
;******************* USR INTERRUPT **********************
; Inferior Job Interrupt
INTUSR: TLNN F,%PGMRN ; Running a pgm?
JRST [ IUSAVE ; Nope, random int. Save UUO vars
STAT (,("Note: Spurious USR int")) ; since doing stats output.
IUREST
DISMIS]
PUSHAE P,[A,B]
MOVE A,INTPDP
MOVE B,INFBIT
IORM B,-4(A) ; Set bit in old .DF2 so more inf. ints are deferred.
POPAE P,[B,A]
DISMIS [SNDP60] ;and dismiss to non-int-level handler.
;; INTDWN - %PIDWN interrupt handler.
;
;INTDWN: PUSHAE P,[A,B]
; SYSCAL SSTATU,[MOVEM A] ; See what's going on.
; JSR AUTPSY
; JUMPGE A,[SETOM GODOWN ; If sys going down, signal main loop.
; DISMISS]
; CAMN A,[-1] ; Sys up normally?
; JSR AUTPSY ; (shouldn't happen, not in OPTLIV mode).
; SKIPE GODOWN ; Was it once going to go down?
SUBTTL Error handlers - AUTPSY, SDFULL
; AUTPSY - Called by a one-way JSR AUTPSY for purposes of leaving a trail,
; saves info about bug and writes out on stat file, dumping job
; if permissible. Nearly ALL fatal errors wind up here.
; really should have some different levels of bugs-- system type,
; call type, soft type, etc. to replace filbug/corbug and furnish
; more specificity for other types as well.
LVAR AUTPSY: 0 ? JRST AUTPY0 ; Jump to pure
AUTPY0: JSR PRESRV ; Save state of job (hopefully in sufficient detail)
AUTPY1: TLNE F,%SCOPN ; And now if STATS channel is open,
JRST AUTPY2 ; Jump to report lossage.
MOVE B,[%DOWOV+.UAO,,SC]
.CALL SCOBLK ; Not open??? Try gingerly to open...
JRST AUTPY7 ; And quit immediately on any error.
SYSCAL FILLEN,[CIMM SC ? CRET A]
JRST AUTPY7 ; Also quit if can't find length???
.ACCESS SC,A ; Set length to EOF
OUT(SC,OPEN(UC$IOT)) ; And open UUO channel so hairy output works.
TLO F,%SCOPN ; and indicate open!
AUTPY2: STAT (,(" ==="),RABR,(" BUG: FATAL ERROR "),LABR,("=== Date: "),TIM(MDYT),("
Autopsy from "),RHV(AUTPSY),(" Preserved from "),RHV(PRESRV),("
Last UUO = "),H(U40SAV),(" at "),RHV(UUHSAV),EOL)
; Do this part if interrupt was triggered.
STAT (,(" INT. FROM "),RHV(IPCSAV),(" .JPC/"),RHV(JPCSAV),("
Registers:
"))
PUSH P,A
MOVSI A,-20
AUTPY4: CSTAT (,RHV(A),("/ "),H(ACCSAV(A)),EOL)
AOBJN A,AUTPY4
POP P,A
JSR RNMREQ ; Try to rename current input request!
JRST [ STAT (,("No "),6F(IRIFN1),(" "),6F(IRIFN2),(" file present during burnup."))
JRST AUTPY6]
STAT (,("Input req file "),6F(IRRFN1),(" "),6F(IRRFN2),(" renamed to "),6F(BRQFN1),(" "),6F(BRQFN2))
AUTPY6: JSR BURY ; Now try to dump self...
STAT (,("Job dumped to CRASH;"),6F(DMPFN1),(" "),6F(DMPFN2))
JSR UDEATH ; And now die.
; Here after preserving state, if STATS channel can't be opened.
AUTPY7: JSR RNMREQ ; As above, but without stats.
JFCL
JSR BURY
JSR UDEATH
; SYSLOS - for use when ITS does something wrong, eg when system
; call inexplicably fails or returns strange error code.
LVAR SYSLOS: 0 ? JSR AUTPSY
; CORLOS - Suport routine for PAGSER; JSRd to when a CORBLK fails.
; CBKERR/ error code from failing .CALL
; If arg not provided, checks most recent erring channel.
LVAR CORLOS: 0 ? JRST CORLS0
CORLS0: PUSH P,A
SKIPE A,PAGSER"CBKERR ; Error code present?
JRST CORLS2 ; Yes, go check it.
.SUSET [.RBCHN,,A] ; Else ask recent erring channel for error.
SYSCAL STATUS,[A ? CRET A]
JSR SYSLOS
LDB A,[$ERRCD,,A] ; Get # of error
CORLS2: CAIE A,37 ; Error = no core available?
JSR AUTPSY ; Nope, something horrible. die.
TLNN F,%SCOPN ; Hurray, can re-try! If stats open, say so.
JRST CORLS5
IUSAVE ; Save UUO vars since doing stats output.
STAT (,(" ==="),RABR,(" CORBLK HUNG, SLEEPING..."))
IUREST ; Then restore.
CORLS5: MOVEI A,30. ; Now prepare to
.SLEEP A, ; sleep for a second.
POP P,A
SOS CORLOS ; Then adjust return addr so that
SOS CORLOS ; it points to call which failed.
JRST @CORLOS ;and go try again.
;;; PAGLUZ - JSRd to by the PSRERR macro, which is used inside PAGSER.
LVAR PAGLUZ: 0 ? JRST PAGLU0 ; Jump to pure
LVAR PAGLCD: 0 ; Error code.
PAGLU0: MOVEM U4,PAGLCD ; Remember the PAGSER lossage code.
JSR PRESRV ; Preserve COMSAT state.
CAIN U4,PAGSER"EROOM ; Examine PAGSER error code.
JRST PAGLU2
PAGLU1: POP P,U4 ; If random error jump to our death.
JSR AUTPSY
PAGLU2: POP P,U4
TLNE F,%SCOPN ; Else COMSAT ran out of address space.
JRST PAGLU3 ; Ensure STATS file is open.
MOVE B,[%DOWOV+.UAO,,SC]
.CALL SCOBLK
JRST PAGLU7 ; And quit immediately on any error.
SYSCAL FILLEN,[CIMM SC ? CRET A]
JRST PAGLU7 ; Also quit if can't find length???
.ACCESS SC,A ; Set length to EOF
OUT(SC,OPEN(UC$IOT)) ; And open UUO channel so hairy output works.
TLO F,%SCOPN ; and indicate open!
PAGLU3: STAT (,(" ==="),RABR,(" BUG: FATAL ERROR "),LABR,("=== Date: "),TIM(MDYT),("
Autopsy from "),RHV(AUTPSY),(" Preserved from "),RHV(PRESRV),("
Last UUO = "),H(U40SAV),(" at "),RHV(UUHSAV))
STAT (,(" INT. FROM "),RHV(IPCSAV),(" .JPC/"),RHV(JPCSAV))
STAT (,(" ==="),RABR,(" Out of address space! "),LABR,("==="),EOL)
PAGLU7: OUT(SC,CLS) ; Close stats channel, forcing out any buffered stuff.
IFN 0, JSR DEATH ; Die without leaving any kind of corpse.
SKIPN DIDONE ;If we haven't won even once yet
JSR RNMREQ ; then current input file is probably the troublemaker.
NOP
JSR RESET ;Flush.
BVAR
OPRSRV: 0 ; To prevent clobberage by nested lossage.
PRESRV: 0 ; JSR'd to, so accs not disturbed
JRST PRSRV0 ; Jump to pure.
EVAR
PRSRV0: SKIPE DEBUG
JSR DEATHV
SKIPE OPRSRV
JSR UDEATH ; If err within error handling, die instantly.
MOVEM P,PDLSAV ; Save P (must be ac 17!)
MOVE P,PRESRV
MOVEM P,OPRSRV ; Save return loc as clobberage protection.
MOVE P,[0,,ACCSAV]
BLT P,PDLSAV-1 ; Save all accs
MOVE P,[-XPDLLN,,XPDLOC]
PUSHAE P,[A,B]
IFE $$UCAL,MOVE A,UUORPC ? MOVEM A,UUHSAV
MOVE A,U40
MOVEM A,U40SAV
.SUSET [.RBCHN,,BCHSAV]
MOVSI A,-20
SYSCAL STATUS,[MOVEI (A) ? CRET STASAV(A)]
JFCL
AOBJN A,.-2
.SUSET [.RMPVA,,MPVA]
MOVE B,[SQUOZE 0,USER]
.EVAL B,
.VALUE
MOVSS B
HRRI B,B
.GETLOC B, ; B gets my user index
IRP SYM,,[LSPCL,LEXFDR]
MOVE A,[SQUOZE 0,SYM]
.EVAL A,
.VALUE
ADD A,B
MOVSS A
HRRI A,SYM
.GETLOC A,
TERMIN
SETZM IPCSAV
SETZM JPCSAV
MOVE B,INTPDP ; Get interrupt PDL ptr
CAMN B,[-LIPDL,,IPDL-1] ; Were we interrupted?
JRST PRESR2 ; Nope, don't try to read interrupt stack.
MOVE A,-3(B) ; Yes! Get loc interrupted from.
MOVEM A,IPCSAV
MOVE A,-2(B) ; and loc of last jump instr.
MOVEM A,JPCSAV
PRESR2: POPAE P,[B,A]
JRST @PRESRV
;;; STUFF SAVED FOR DEBUGGING CRASHES
BVAR
ACCSAV: BLOCK 17 ; All accs including...
PDLSAV: 0 ; saved P (17).
UUHSAV: 0 ; value at UUOH if using JSR (loc of last UUO)
U40SAV: 0 ; value at U40 (last UUO)
JPCSAV: 0 ; loc of last jump instr (if interrupted)
IPCSAV: 0 ; loc interrupted from if any
BCHSAV: 0 ; saved .BCHN
STASAV: BLOCK 20 ; saved STATUS of all channels
MPVA: 0 ; Referencing address of last MPV/WRO
LSPCL: 0 ; Last two exec PCs pclsred at
LEXFDR: 0 ; fault bits,,PC of last error page fault from exec mode
XPDLLN==25
XPDLOC: BLOCK XPDLLN ; Emergency PDL - avoid clobbering regular.
EVAR
; RNMREQ - Renames input request file (if any) to signify bad request.
; Called by JSR.
LVAR RNMREQ: 0 ? JRST RNMRQ0
RNMRQ0: SYSCAL RENAME,[SATDEV ? IRRFN1 ? IRRFN2 ? SATDIR
IREFN1 ? IREFN2]
JRST @RNMREQ ; Assume nothing to rename.
SYSCAL OPEN,[[.UII,,DMPCH] ? ['DSK,,]
IREFN1 ? IREFN2 ? SATDIR]
JSR UDEATH
SYSCAL RFNAME,[CIMM DMPCH ? CRET JUNK ? CRET BRQFN1 ? CRET BRQFN2]
JSR UDEATH
AOS RNMREQ
JRST @RNMREQ
BVAR
BRQFN1: 0
BRQFN2: 0
EVAR
; BURY - PDUMP's self to DSK:CRASH;BURNUP >
; Called by JSR
.SCALAR BURNSV,BURYF,BURYP
LVAR BURY: 0 ? JRST BURY0 ; PDUMP corpse so have something to look at.
BURY0: SKIPE DEBUG
JSR DEATHV
SYSCAL OPEN,[[.BIO,,DMPCH] ? ['DSK,,0]
['BURNUP] ? [SIXBIT />/] ? [SIXBIT /CRASH/]]
JSR UDEATH
MOVEM A,BURNSV ; Save acc
MOVE A,[DMPCH,,DMPDAT]
.RCHST A,
MOVEM F,BURYF
MOVEM P,BURYP
MOVSI 17,ACCSAV ; restore ACs so PDUMP can save them
BLT 17,17
SETZM DMPDAT
SYSCAL PDUMP,[CIMM %JSELF ? CIMM DMPCH ? DMPDAT] ;Dump self.
JSR UDEATH
MOVE A,[-8,,[
JUMPA MAIN ; First start address
-4,,2 ; Indirect symbol table pointer
SIXBIT/DSK/ ? SIXBIT/COMSAT/ ? SIXBIT/LAUNCH/ ? SIXBIT/.MAIL./
0 ; Hopefully no one cares about the checksum
JUMPA MAIN ]] ; Second start address
.IOT DMPCH,A
.CLOSE DMPCH,
MOVE A,BURNSV
MOVE F,BURYF
MOVE P,BURYP
JRST @BURY
BVAR
DMPDAT: 0 ;returned by .rchst to get true dump file names.
DMPFN1: 0
DMPFN2: 0
0 ? 0
EVAR
; UDEATH - Kill Unique COMSAT. Does special hacks to relinquish
; uniqueness, and decides whether to disappear or stay around.
; (If not unique, just disappears.)
LVAR UDEATH: 0 ? JRST UDEAT0 ; Jump to pure.
UDEAT0: SKIPE DEBUG ; If debugging, just halt.
JSR DEATHV
OUT(SC,CLS) ; Close stats channel, forcing out any buffered stuff.
.CLOSE LSR1C,
.close lockch,
.CLOSE DKIC,
.CLOSE DKOC,
.CLOSE NETD,
.CLOSE NETI,
.CLOSE NETO,
; Decide whether to log out or leave corpse around.
SKIPN HAVLKS ; Do we have the locks set up?
JSR DEATHV ; No, horrors... should always be able to get
; at locks. Hang around system for hacker to inspect.
SKIPN UNIQUE ; If have locks, but job is not unique,
JSR DEATH ; die, period.
; Job is the one and only system comsat, and we have locks.
; See if already too many dead comsats around for leaving corpse
MOVEM A,DIESVA
MOVE A,LOCK2 ; Not really a lock; used as count.
CAIL A,3 ; Less than 3 so far?
JSR DEATH ; Too many, disappear.
; Hang around. Unlock switch 1 so other comsats can be started.
MOVEM P,DIESVP
MOVEI P,PATCH+PATLEN-10 ; Set up small PDL to make sure we win.
MOVEI A,LOCK1
CALL LKFREE ; Free the lock! A new COMSAT can now run...
AOS LOCK2 ; Increment count of dead comsats
JSR DEATHV ; and start swinging in the breeze
.SCALAR DIESVA,DIESVP
BVAR ; JSR here when all ready to pull trigger.
DEATH: 0
.LOGOUT
CAIA
; JSR here if only want to stop, or if trigger is jammed.
DEATHV: 0
.VALUE ;if not toplevel, this will have to do.
JRST .-1 ;insist.
EVAR
; SDFULL - Satellite Directory Full. Called when something happens
; (IOC error, OPEN lossage) that indicates .MAIL. needs
; to get more room before COMSAT can proceed at all.
; Note that this routine must distinguish between true directory
; gronkage, and general system disk shortage.
; SDFULI - same, but called at Interrupt level.
LVAR SDFISW: 0 ; -1 if SDFULI, 0 if SDFULL.
LVAR SDFCNT: -1 ; Set -1 if all is well at top-level .HANG,
; AOS'd each time SDFULL called. Used to
; detect SDFULL looping.
SDFULI: SETOM SDFISW ; Interrupt level.
IUSAVE ; Save UUO vars.
CAIA
SDFULL: SETZM SDFISW ; Not at interrupt level.
AOS SDFCNT ; Bump cnt of calls.
PUSHAE P,[A,B,C]
; First thing is to determine independently what the problem is.
.SUSET [.RBCHN,,C] ; Find bad channel #
SYSCAL STATUS,[C ? CRET B] ; and get IOS word.
JSR SYSLOS
LDB A,[330500,,B] ; Find IOC error code.
CAIN A,11 ; Device full?
JRST SDFL20 ; Yes, system running out of disk space.
CAIN A,14 ; Directory full?
JRST SDFL40 ; Yes, satellite directory gronked.
LDB A,[$ERRCD,,B] ; Hmm, no IOC error matched, try normal err.
CAIN A,5 ; Directory full?
JRST SDFL40 ; Yes, go handle.
; Come here when error cannot be recognized as either device full
; (no disk space) or dir full (no room in comsat's dir). For now,
; and probably for ever, die.
JSR AUTPSY
; Return!! - jump here if one of the routines below thinks it's
; succeeded (heh) in resolving the problem.
SDFL90: POPAE P,[C,B,A] ; Hurray...
SKIPN SDFISW ; If at interrupt level,
RET
IUREST ; also restore UUO handler stuff.
RET
; Device Full - system is running out of disk space, and COMSAT
; can't get enough disk to write something it needs. Never die;
; keep trying, and wait until room opens up.
LVAR QDSKN: 0 ; Holds address of QDSKN table in system
LVAR QSFT: 0 ; Holds address of QSFT table in system
SDFL20:
; Try examining actual space left on drive being used by channel.
LDB A,[000600,,B]
CAIE A,43 ; Is physical device code 43 = DSK?
JSR AUTPSY ; If not, something's screwy.
HRLZ A,C
ADD A,[.RIOC,,A] ; Cons up appropriate cruft to get IOCHNM+ch
.SUSET A
HLRZ A,A ; Get LH = disk channel #.
SKIPN B,QDSKN ; Get system address of QDSKN table,
JRST [ MOVE B,[SQUOZE 0,QDSKN]
.EVAL B, ; And get from system if haven't already.
JSR SYSLOS
MOVEM B,QDSKN
JRST .+1]
ADDI A,(B) ; Get address in system to inspect (index by dsk ch #)
HRLZ A,A
HRRI A,A ; Now have <sys addr>,,<result addr>
.GETLOC A, ; Examine it - now have physical drive # in A.
SKIPN B,QSFT ; Now do similar kludgery for QSFT (tracks free on drive)
JRST [ MOVE B,[SQUOZE 0,QSFT]
.EVAL B,
JSR SYSLOS
MOVEM B,QSFT
JRST .+1]
ADDI A,(B)
HRLZ A,A
HRRI A,A
.GETLOC A, ; Now have # tracks free in A!
; If very small number free, shout. Otherwise perhaps there's
; now enough room...
CAML A,SDFLIM
JRST [ MOVE A,SDFCNT ; Should be enough, but check count of calls
CAILE A,3 ; and be highly suspicious of prognosis
JRST SDFL35 ; if calls are repetitive - try sleeping.
JRST SDFL90] ; Else bravely return.
; Try shouting.
CALL DATIME"TIMGT ; Find current time,
CALL DATIME"TIMSEC ; convert to abs # secs,
MOVE B,A
SUB B,LSHTIM ; And subtract last shout time.
CAMGE B,SDFTLM ; Enough time since then to send another?
JRST SDFL35 ; No, wait.
; OK, we'll shout...
MOVEM A,LSHTIM ; Save as new last-shout-time.
SYSCAL PGWRIT,[CIMM LCKPAG] ; and make sure it's written on disk.
JSR SYSLOS
MOVEI A,3
MOVEM A,CLITYP ; Specify "TTY message from ..."
MOVE A,[ASCNT [COMSAT]]
MOVEM A,CLIANC ; "...COMSAT".
SETZB A,CLIZSW ; With character limit of
HLLOM A,CLIZMX ; 0,,-1 (effectively infinite).
SETZM CLIHDR ; Don't bother with header, and use following
MOVE A,[ASCNT [EVERYBODY: Disk space very low, please delete unnecessary files!]]
MOVEM A,CLITXT ; as message text.
SETZ A, ; Send to all HACTRN's...
MOVEI B,CLISND ; using standard routine.
CALL XCTALU ; Do it!
; Now drop thru to sleep for a while...
SDFL35: MOVE A,SDFSLP ; Get time to sleep
.SLEEP A,
JRST SDFL90 ; Return and re-try whatever it was that lost.
LVAR SDFLIM: 50. ; # dsk blocks below which to shout about.
LVAR SDFTLS: 0 ; Time (.rdtime) of last SHOUT
LVAR SDFTLM: 15.*60. ; Time to wait between shouts. (15 min)
SDFSLP: 30.*30. ; Half minute naps while waiting.
; Directory Full - COMSAT's directory has been stuffed to the gills,
; and nothing can be done (no matter how much disk the system has)
; until some files are flushed!
; In no case should COMSAT simply give up and die. Persevere!
; If problem is .MAIL. directory itself:
; o SHOUT at selected people?
; o Flush a special "buffer" file, giving enough room
; to finish and yell for help
; o Write a MAIL > file directed to mail-maintainers
; o Examine OSTATS, NAMES, NAMED for possible flush candidates;
; don't flush most recent good NAMES, and don't flush an
; OSTATS if not dumped, etc. nor if down to very last OSTATS.
; o Can try some sleeping so someone can respond to cry for help.
; If problem persists, very last resort should be to die without freeing locks.
SDFL40: JSR AUTPSY ;For now, just die!
IFN 0,[ ;; Shout out knowledgable people to clean up .MAIL.; directory.
;; Then go to sleep.
;; If complete loss after a while, die without freeing locks.
MOVE A,[ASCNT [MAIL-DIR-MAINT]]
SETZ B, ; Match to any type.
CALL RCPEQV ;get ptr to option list if any
JRST SDFL49
];IFN 0
SUBTTL *------------------- Entry & Init ---------------------------*
SUBTTL PURIFY$G - Purification
LVAR PURESW: 0 ; If -1, program has been purified.
;;; PURIFY$G entry point - use when setting up a just-assembled comsat
;;; for dumping as appropriate file on .MAIL.
PURIFY: MOVE A,[<PURPGB-PURPGE>,,PURPGB] ; Get page AOBJN
SYSCAL CORBLK,[CIMM %CBNDR ? CIMM %JSELF ? A ? CIMM %JSELF]
.LOSE 1000
SETOM PURESW ; Set flag saying pgm is pure.
MOVEI A,[ASCIZ /:PDUMP DSK:.MAIL.;COMSAT LAUNCH/]
SKIPGE XVERS ; Experimental mailer?
MOVEI A,[ASCIZ /:PDUMP DSK:.MAIL.;COMSAT XPER/]
SKIPLE XVERS ; New mailer?
MOVEI A,[ASCIZ /:PDUMP DSK:.MAIL.;COMSAT NEW/]
.VALUE (A) ; Valret appropriate string.
JRST INIT ; and go start up if continued.
; IPURIF - Internal Purify routine.
IPURIF: PUSH P,A
MOVE A,[<PURPGB-PURPGE>,,PURPGB] ; Get page AOBJN
SYSCAL CORBLK,[CIMM %CBNDR ? CIMM %JSELF ? A ? CIMM %JSELF]
JSR SYSLOS ; Shouldn't happen.
SETOM PURESW ; declare pure.
POP P,A
RET
; Network code - must be here because NETRTS uses STAT and DISMISS.
.INSRT DSK:SYSNET;NETRTS >
SUBTTL MFINIT$G - Emergency File Directory Initialization
; The following code initializes the satellite's data
; directory, and will never be executed unless started here
; manually. The reasoning is that if a file required by the
; mailer is lost or garbaged, it is far better to halt and
; await human intervention than attempt to fix things automatically.
; If the lossage is impossible to remedy, this code will try
; to create a new set of files.
; Interrupts are NOT enabled, and return is by .VALUE.
; This will re-create all existing mailer files, (except if ID exists
; it will increment it instead of creating it.) So be careful.
MFINIT: MOVE P,[-PDLLEN,,PDL] ; Set up PDL
SETZB F,MF ; and clear all flags.
SETOM DEBUG ; Always indicate debugging.
SYSCAL USRVAR,[CIMM %JSELF ? CIMM .ROPTION ? CIMM ; Set up options: Locked switch
[TLO 0,%OPALL]] ; feature and winning new interrupts.
.LOSE 1000
CALL MYADDR ; Set our address(es)
SKIPE XVERS
CALL XVRSRT ; Set up right filenames if not normal!
SKIPN PURESW ; and make sure
CALL IPURIF ; that what can be pure is pure!
; The following routines need to be in the order given. Since
; it is desirable to enable the SC stats channel ASAP, the
; first order of business is to determine if this incarnation
; of the mailer is unique, i.e. can it reference & write to
; the directory?
CALL DATIME"UPINI
CALL MTMHNG ; UPINI lost, do something appropriate.
CALL MLINIT ; And ensure uniqueness.
SETZM LSHTIM ; (after grabbing locks, clear last shout time)
CALL SCOPN ; Now initialize statistics file!
CALL MCINIT ; Initialize core management.
; Essential initializations done, now to create new data files.
SYSCAL DELETE,[SATDEV ? NMGFN1 ? NMGFN1+1
SATDIR ? CERR A] ; Delete NMSGS if it exists.
JRST [ CAIN A,4
JRST .+1
JSR AUTPSY]
SYSCAL DELETE,[SATDEV ? NMSFN1 ? NMSFN1+1
SATDIR ? CERR A] ; Ditto NMASTR.
JRST [ CAIN A,4
JRST .+1
JSR AUTPSY]
SYSCAL OPEN,[[.BIO,,DKOC] ? SATDEV ? MSGFN1 ? MSGFN2 ? SATDIR]
.VALUE [ASCIZ /: Can't create MSGS file! 
/]
.CLOSE DKOC, ; Close it, now exists with length 0.
SYSCAL RENAME,[SATDEV ? IDFN1 ? IDFN2 ? SATDIR
IDFN1 ? IDFN2] ; Attempt to produce new ID file
CAIA ; Skip to create if lost.
JRST MFINI5 ; Jump if won, need not start over.
SYSCAL OPEN,[[.BIO,,DKOC] ? SATDEV ? IDFN1 ? IDFN2 ? SATDIR]
.VALUE [ASCIZ /: Can't create ID file! 
/]
.CLOSE DKOC, ; Close, now ID file exists...
; Now create MASTER file. First set up LSE...
MFINI5: CALL MSTNIL ; Create nil MASTER.
CALL MSTPUT ; Now write out, creating file!
; Now have new MASTER file, must create RML and QML files.
CALL MAKQFI ; Special routine to generate RML/QML given MASTER.
; Now compile the EQV file...
CALL EQVGOB ; Compile it!
.VALUE [ASCIZ /: Error(s) during EQV file compilation! Read STATS or error file.
/] ; Foo? Error during compilation, STATS should show why.
; Now all done!
.VALUE [ASCIZ /: File Directory Initialization successfully completed...
Proceeding will launch Comsat. 
/]
MOVEI A,LOCK1 ; Unlock switch 1 so can re-grab later.
CALL LKFREE
JRST INIT ; Go!
$LHMFG==$LHSIZ+0 ; Define these to be located at end of LSE HDR area.
$LHMFL==$LHSIZ+1
SUBTTL MAKMST$G, etc - Emergency regeneration of MASTER and/or QML/RML files.
; Note: This is NOT FULLY DEBUGGED!!!
; ********** Cant work without STATS open. Fix. **********
; MAKMST - Re-creates the MASTER file from the MSGS file. This code
; is never executed unless started here manually, and after it is
; run, it should be killed and a new COMSAT started. (On the fatal
; day 7/9/77 the MC MASTER file got clobbered and this code was
; typed into DDT by hand (by MOON and DLW), and we created MASTER all
; right but accidentally clobbered MSGS! I don't ever want that to
; happen again, so... --dlw)
; Instructions: Save the old LIST MASTER (if it's worth it), and delete LIST
; MASTER. Then start at MAKMST. If anything is wrong, it will tell you.
; When done, kill this and start another COMSAT.
LVAR MAKING: 0 ; Flag that we were started in this code.
MAKMST: SETOM MAKING ; Flag.
MOVE P,[-PDLLEN,,PDL]
SETZ F,
SETOM DEBUG
SYSCAL USRVAR,[CIMM %JSELF ? CIMM .ROPTION ? CIMM ; Set up options: Locked switch
[TLO 0,%OPALL]] ; feature and wining new interrupts.
.LOSE 1000
CALL MYADDR ; Set address(es)
SKIPE XVERS
CALL XVRSRT
CALL DATIME"UPINI ; Get the time for MLINIT.
CALL MTMHNG
CALL MLINIT ; Will go to MAKMNU if we are not unique.
CALL MCINIT ; We need area hacking, etc.
CALL MSTNIL ; Initialize MASTER LSE to NIL.
MOVEI A,MSGFN1 ; Open MSGS.
CALL OPNMFI
.VALUE
.SUSET [.SIMASK,,[%PIIOC]] ; Enable IOC handler for XCTIOC in LSEIN
.SUSET [.SPICLR,,[-1]] ; And turn on interrupt system.
MAKM10: MOVEI A,TMPAR ; Read the next message into MSGS.
SETO B,
CALL LSEIN
JRST MMCONT ; Got an IOC error, we must have hit the end.
MOVE L,$ARLOC+TMPAR
FINDA A,[A$ID,,[$LLLST(L)]] ; Get message ID.
.VALUE [ASCIZ \: ERROR! The current msg has no ID!!! \]
MOVE L,$ARLOC+MASTER
LNCOPY A,[$ARLOC+TMPAR ? A] ; And copy it into MASTER area.
MAKELN B,[A$IDBL,,0 ; Now get the disk length and addresses. LSEIN handily
%LTVAL,,[ULSDBH]] ; leaves them in these convenient locations.
MAKELN B,[A$IDAD,,[B]
%LTVAL,,[ULSIPT]]
HRRM B,LISTAR(A) ; NCONC these two onto the ID (order of these LNs is critical.)
MAKELN A,[A$I,,[$LLLST(L)] ; And put this info onto one big list.
%LTLST,,[A]]
MOVEM A,$LLLST(L)
JRST MAKM10
; LSEIN got an IOC error.
MMCONT: SYSCAL STATUS,[CIMM DKIC ? CRET A]
.LOSE 1000
LDB B,[330500,,A] ; Get the IOC error code.
CAIE B,2 ; Is it EOF?
.VALUE [ASCIZ \: ERROR: IOC error not EOF. STATUS of DKIC in A. \]
SYSCAL OPEN,[[.BIO,,DKOC] ? SATDEV ? [SIXBIT /_MAKMO/] ? [SIXBIT />/] ? SATDIR]
.LOSE %LSFIL
MOVEI A,MASTER ; Write out MASTER to temporary file name.
SETO B,
CALL LSEOUT
SYSCAL RENMWO,[CIMM DKOC ? MSTFN1 ? MSTFN2]
.LOSE %LSFIL
.CLOSE DKOC,
.VALUE [ASCIZ \: Super win. Now kill this job, and start another COMSAT. \]
JRST .-1 ; In case loser proceeds.
MAKMNU: .VALUE [ASCIZ \: ERROR -- There is ANOTHER COMSAT running! Stop it!!!
(Then start all over.)\]
JRST .-1
;;; This routine, intended to be called by hand, will delete from
;;; MASTER any entries which aren't in QUEUE. Ought to know about
;;; REMIND at some point also.
;;; This routine is not recommended for use except in dire emergency,
;;; because almost always MASTER contains valid stuff and the QML list
;;; is missing some messages it should have. If called, the procedure should
;;; be to first call MAKQFS, to make sure that everything which can
;;; possibly be queued is definitely on the QML (or RML). Then CLNMST
;;; can be called to flush anything which has no business being there at all.
CLNMST: MOVE P,[-PDLLEN,,PDL]
SETZ F,
SETOM DEBUG
SYSCAL USRVAR,[CIMM %JSELF ? CIMM .ROPTION ? CIMM ; Set up options: Locked switch
[TLO 0,%OPALL]] ; feature and wining new interrupts.
.LOSE 1000
CALL MYADDR ; Set our address(es)
SKIPE XVERS
CALL XVRSRT
CALL DATIME"UPINI ; Get the time for MLINIT.
CALL MTMHNG
CALL MLINIT ; Will go to MAKMNU if we are not unique.
CALL MCINIT ; We need area hacking, etc.
.OPEN DBC,[.UAO,,'TTY] ; Will type-out about deleted msgs on DBC
.VALUE
OUT(DBC,OPEN(UC$IOT))
CALL QMLGET ; Get QUEUE into core
CALL MSTGET ; Get MASTER into core
;; Go over MASTER, deleting guys not in QUEUE
MOVE L,$ARLOC+MASTER ; Make it current LSE
MOVE A,$LLLST(L) ; Point to whole list as arg for MAPC
MOVEI B,CLNMS1 ; Apply this routine to each entry in MASTER.
CALL MAPC ; Do it!
.VALUE ; won't ever happen
.VALUE [ASCIZ/: Type $P to write it out 
/]
.VALUE [ASCIZ/: Are you SURE? Examine your conscience... 
/]
.VALUE [ASCIZ/: All right, you have this one last chance...
/]
.VALUE [ASCIZ/: So be it... 
p/]
CALL MSTPUT ; Next GC will clean up MSGS
.VALUE [ASCIZ/: Done 
/]
;A has a MASTER element, B and C may be clobbered
CLNMS1: PUSHAE P,[L,D,E]
FINDA C,[A$ID,,[LISTAR(A)+1]] ; Find ID of this MASTER entry
.VALUE
MOVE C,LISTAR(C)+1 ; Get SPT
ADD C,$LSLOC(L) ; Make absolute
MOVE L,$ARLOC+QMLAR ; Select QUEUE area
HRRZ D,$LLLST(L) ; Loop over hosts
JUMPE D,CLNMS9
CLNMS2: FINDA E,[%HSIGN+A$ID,,[LISTAR(D)+1] ? C] ; See if this ID is on this site
JRST CLNMS4 ; No, keep looking
CLNMS3: POPAE P,[E,D,L] ; Yes, this guy is OK, return
JRST POPJ1 ; Success return to MAPC
CLNMS4: HRRZ D,LISTAR(D) ; CDR to next host
JUMPN D,CLNMS2
CLNMS9: EXCH A,C ; A gets ASCNT to message-ID
CALL MSGGTA ; Get message into core
.VALUE ; Should be there
EXCH A,C
MOVE L,$ARLOC+MSGAR
FINDA B,[A$MHDR,,[$LLLST(L)]] ;Get message header
.VALUE ; Should be there
HLRZ D,LISTAR(B)+1 ; Get length of header
JUMPN D,CLNMS8 ; Jump if OK
FINDA B,[A$MTXT,,[$LLLST(L)]] ;Extract network header from message text
.VALUE
MOVE D,LISTAR(B)+1 ;Convert to absolute SPT
ADD D,$LSLOC(L)
HLRZ E,D
HRLI D,440700
PUSHAE P,[A,B]
CLNMS7: ILDB A,D
LSH B,7
IOR B,A
TLZ B,776000
CAMN B,[<<<<<15*200>+12>*200>+15>*200>+12]
JRST [ POPAE P,[B,A]
HLRZ D,LISTAR(B)+1 ;Make shorter
SUB D,E
HRLM D,LISTAR(B)+1
JRST CLNMS8 ]
SOJG E,CLNMS7
POPAE P,[B,A]
CLNMS8: OUT(DBC,("Deleting message:"),EOL,TLS(B))
MOVE L,$ARLOC+MASTER ; Delete from MASTER (code copied from IDDELE)
FINDA B,[A$IDBL,,[LISTAR(A)+1]] ; Get length of LSE-blk on disk.
.VALUE
MOVE B,LISTAR(B)+1 ; Get # words used by LSE.
ADDM B,$LHMFG(L) ; Increment cnt of garbage wds.
LNDEL A,$LLLST(L) ; Now kill it.
JRST CLNMS3 ; And return to MAPC
;;; Routine to print the QML onto a disk file.
;;; Useful when queue is so bloated that SHOW-Q can't work.
SHOWQ: MOVE P,[-PDLLEN,,PDL]
SETZ F,
SETOM DEBUG
SYSCAL USRVAR,[CIMM %JSELF ? CIMM .ROPTION ? CIMM
[TLO 0,%OPALL]] ; Locked switch and New Interrupts.
.LOSE 1000
CALL MYADDR ; Set our address(es)
SKIPE XVERS
CALL XVRSRT
CALL DATIME"UPINI ; Get the time for MLINIT.
CALL MTMHNG
CALL MLINIT ; Will go to MAKMNU if we are not unique.
CALL MCINIT ; We need area hacking, etc.
TLNN F,%SCOPN
CALL SCOPN ; Make sure stats channel is open!
STAT (,("Service stopped for SHOWQ - listing QML to disk file."))
SKIPN $AROPN+QMLAR
CALL QMLGET ; Get QUEUE into core
SKIPN $AROPN+MASTER
CALL MSTGET ; Get MASTER into core
.CALL [SETZ ? SIXBIT/OPEN/ ? [.UAO,,DBC] ? [SIXBIT/DSK/]
[SIXBIT/GUBBLE/] ? SETZ [SIXBIT/>/] ]
.LOSE %LSSYS
OUT(DBC,OPEN(UC$IOT)) ; Open output file as standard-output.
OUT(,CH(DBC))
CALL PRTQML ; Try SHOW-Q routine now.
JFCL
TLZ F,%MSTMD ; Get rid of in-core copy of MASTER.
UARCLS MASTER
UARCLS TMPAR
TLZ F,%QMLMD ; Get rid of in-core copy of QUEUE.
UARCLS QMLAR
UARCLS TMPAR
OUT(DBC,CLS) ; Close channels, making sure all's output.
OUT(SC,CLS)
.VALUE [ASCIZ /:Done
/]
; Hand-callable routine to GC the QUEUE and MASTER files.
GCQ: MOVE P,[-PDLLEN,,PDL]
SETZ F,
SETOM DEBUG
;; Set up options: Locked switch feature and wining new interrupts.
SYSCAL USRVAR,[CIMM %JSELF ? CIMM .ROPTION ? CIMM [TLO 0,%OPALL]]
.LOSE 1000
CALL MYADDR ; Set our address(es)
SKIPE XVERS
CALL XVRSRT
CALL DATIME"UPINI ; Get the time for MLINIT.
CALL MTMHNG
CALL MLINIT ; Will go to MAKMNU if we are not unique.
CALL MCINIT ; We need area hacking, etc.
TLNN F,%SCOPN
CALL SCOPN ; Make sure stats channel is open!
CALL GCQ0
.VALUE [ASCIZ/: Done! 
/]
GCQ0: STAT (,("Garbage collecting QUEUE and MASTER"))
SKIPN $AROPN+QMLAR
CALL QMLGET ; Get QUEUE into core
SKIPN $AROPN+MASTER
CALL MSTGET ; Get MASTER into core
MOVEI A,TMPAR ; Make TMPAR be new MASTER (code from MSTNIL)
CALL LSEOPN
MOVEI A,2
UAREXP A,TMPAR ; Expand HDR area by 2, to make sure
MOVE L,$ARLOC+TMPAR ; that there's room for storage of
MOVE A,$ARLOC+MASTER
MOVE B,$LHMFG(A) ; Copy MSGS garbage data
MOVEM B,$LHMFG(L)
MOVE B,$LHMFL(A)
MOVEM B,$LHMFL(L)
MOVE B,$LLLST(A)
LNCOPY A,[MASTER ? SETZ B]
MOVEM A,$LLLST(L)
MOVE A,[TMPAR,,MSTFN1] ; Output the results
CALL DFPUT
TLZ F,%MSTMD ; And get rid of in-core copy
UARCLS MASTER
UARCLS TMPAR
MOVEI A,TMPAR ; Make TMPAR be new QUEUE
CALL LSEOPN
MOVE L,$ARLOC+TMPAR
MOVE A,$ARLOC+QMLAR
MOVE B,$LLLST(A)
LNCOPY A,[QMLAR ? SETZ B]
MOVEM A,$LLLST(L)
MOVE A,[TMPAR,,QMLFN1] ; Output the results
CALL DFPUT
TLZ F,%QMLMD ; And get rid of in-core copy
UARCLS QMLAR
UARCLS TMPAR
RET
;;; Routine to convert a MSGS file into ascii (more or less)
;;; Patch MSTFN1 and MSGFN1 to appropriate file names first
ASCMSG: MOVE P,[-PDLLEN,,PDL]
SETZ F,
SETOM DEBUG
;; Set up options: Locked switch feature and wining new interrupts.
SYSCAL USRVAR,[CIMM %JSELF ? CIMM .ROPTION ? CIMM [TLO 0,%OPALL]]
.LOSE 1000
CALL MYADDR ; Set our address(es)
SKIPE XVERS
CALL XVRSRT
CALL DATIME"UPINI ; Get the time for MLINIT.
CALL MTMHNG
CALL MLINIT ; Will go to MAKMNU if we are not unique.
CALL MCINIT ; We need area hacking, etc.
CALL MSTGET ; Get master LSE, used to drive this stuff
;Note that we don't enable interrupts
.CALL [SETZ ? SIXBIT/OPEN/ ? [.UAO,,DBC] ? [SIXBIT/DSK/]
[SIXBIT/GUBBLE/] ? SETZ [SIXBIT/>/] ]
.LOSE %LSSYS
OUT(DBC,OPEN(UC$IOT))
MOVE L,$ARLOC+MASTER
HRRZ D,$LLLST(L)
ASCMS1: JUMPE D,ASCMS9
FINDA A,[A$IDAD,,[LISTAR(D)+1]]
.VALUE
MOVE A,LISTAR(A)+1 ;Disk address
MOVEM D,MASTRP
PUSH P,D
CALL MLSGET
.VALUE
MOVE L,$ARLOC+MSGAR
SETZM DEBLEV
MOVE A,$LLLST(L)
CALL DEBPL
POP P,D
MOVE L,$ARLOC+MASTER
HRRZ D,LISTAR(D)
OUT(,CH(DBC),C(^L),CRLF) ; Separator between messages
JRST ASCMS1
ASCMS9: .CLOSE DBC,
.VALUE
;;;;;;;;;;;;;;;;;;;;
; Emergency re-initialization of QUEUE and REMIND!!
; You can run this standalone by starting at the usual place
; with a breakpoint at WAKEUP, then CALL MAKQFSX
MAKQFI: PUSH P,A ; Entry point to completely re-initialize
MOVEI A,QMLAR ; the QML.
CALL LSEOPN ; Create empty QML
POP P,A
CAIA
MAKQFS: CALL QMLGET ; Don't initialize QML, use existing.
TLNE F,%SCOPN
CALL SCOPN ; STATS file must be open.
PUSHAE P,[A,B,L]
SETOM MKQFLG' ; Flag to decrease file i/o so goes fast
SKIPN SCHDAR+$AROPN
CALL SCHINI ; Need this for QUEUE-ing.
MOVEI A,RMLAR
CALL LSEOPN ; Same thing for
CALL MSTGET ; Ensure MASTER loaded.
MOVE L,$ARLOC+MASTER ; Make it current LSE
MOVE A,$LLLST(L) ; Point to whole list as arg for MAPC
MOVEI B,MAKQMG ; Apply this routine to each entry in MASTER.
CALL MAPC ; Do it!
.VALUE ; won't ever happen, MAKQMG catches own errs.
CALL QMLPUT ; Done, write stuff out
CALL RMLPUT
CALL MSTPUT
SETZM MKQFLG
POPAE P,[L,B,A]
RET
MAKQMG: PUSH P,D ;not protected by MAPC
FINDA A,[A$ID,,[LISTAR(A)+1]] ; Find the ID for entry
.VALUE [ASCIZ /: MASTER bad?? No message-ID for entry! 
/]
CALL MSGGET ; Get this message into core
.VALUE [ASCIZ /: Can't retrieve message MASTER claims to have!! 
/]
PUSH P,L
MOVE L,$ARLOC+MSGAR
FINDA A,[A$TLST,,[$LLLST(L)]] ; Reminder?
JRST [ CALL QUEUE ; No, Queue all live rcpts in it!
JRST MAKQM7]
CALL REMIND
MAKQM7: POP P,L
POP P,D
AOS (P) ; MAPC wants win return
RET
; MSTNIL - Set MASTER LSE to nil. Used whenever creating new MASTER.
; Note it doesn't actually write out the LSE, use MSTPUT for that.
MSTNIL: PUSHAE P,[A,L]
MOVEI A,MASTER
CALL LSEOPN ; Open a fresh LSE as new MASTER.
MOVEI A,2
UAREXP A,MASTER ; Expand HDR area by 2, to make sure
MOVE L,$ARLOC+MASTER ; that there's room for storage of
SETZM $LHMFG(L) ; <# garbage wds in MSGS file>, and
SETZM $LHMFL(L) ; <length of MSGS file>.
POPAE P,[L,A]
RET
SUBTTL RESET INITIALIZATION
;;; RESET - This can be JSRd to when COMSAT runs out of address space.
;;; Shuts down everything and starts all over.
;;; About as subtle as a tank, we just close everything down and reload
;;; from well-known filename. Since this is essentially a controlled
;;; crash, it ought to be safe from just about any point in the code.
;;; If this still doens't work right, we can always just log out and
;;; let Puff reboot us in an hour....
LVAR RESET: 0 ? JRST RESET0 ; Jump to pure
RESET0: IFN 0, JSR DEATH ;Doesn't work yet...
TLNE F,%SCOPN
PSTAT (,("Note: RESET called from "),RHV(RESET),(", reloading."),EOL)
TLZE F,%SCOPN ; Shutdown stats channel cleanly.
OUT(SC,CLS)
MOVEI A,LOCK1 ; Unlock switch 1 so can re-grab later.
CALL LKFREE
.IOPDL ; Flush the IOPDL
REPEAT 20,[ ? .CLOSE .RPCNT, ] ; Close channels with sledgehammer.
SYSCAL OPEN,[[.UII,,DKIC] ? [SIXBIT 'DSK'] ? [SIXBIT 'COMSAT']
[SIXBIT 'LAUNCH'] ? [SIXBIT '.MAIL.']]
.LOSE %LSFIL ; Well known file, must be present
.SUSET [.SXJNAME,,BOOTXJ] ; Barf, COMSAT BULK crock
MOVSI 17,RSTACS ; Set up AC block
BLT 17,17
JRST 0 ; And dispatch to it, reload or bust.
;; Stuff to load into ACs to reload self from file open on DKIC.
RSTACS: OFFSET -.
.CALL RSTLOD ; 0/ Load self
.LOSE %LSSYS ; 1/ Huh?
.IOT DKIC,RSTSTA ; 2/ Get start address
.CLOSE DKIC, ; 3/ Done with disk channel
JUMPN RSTSTA,@RSTSTA ; 4/ Dispatch
.LOSE ; 5/ Oops
RSTSTA: 0 ; 6/ Filled in with start address
RSTLOD: SETZ ; 7/ .CALL block
SIXBIT 'LOAD' ; 10/
MOVEI %JSELF ; 11/ Job is self
MOVEI DKIC ; 12/ Shiny new disk channel
SETZ .+1 ; 13/ Address range to load
20,,-1 ; 14/ Everything but ACs
REPEAT <17-.>,[ ? 0] ; Fill
OFFSET 0 ; End of AC block.
;; This stuff dates from CStacy, I think, and has never been used.
;; It was a nice try, though....
IFN 0,[
TLNE F,%SCOPN
PSTAT (,(" ==="),RABR,(" RESET FROM "),RHV(RESET),LABR,("==="),EOL)
SKIPE DEBUG ; If debugging just die.
JSR DEATHV
TLZE F,%SCOPN ; Shutdown stats channel.
OUT(SC,CLS)
.CLOSE LSR1C, ; Shutdown other I/O channels.
.close lockch,
.CLOSE DKIC,
.CLOSE DKOC,
.CLOSE NETD,
.CLOSE NETI,
.CLOSE NETO,
MOVSI C,-NAREAS ; Shutdown all dynamic areas.
RESET1: MOVE B,ARPTBL(C)
UARCLS (B)
AOBJN C,RESET1
MOVEI B,SCHDAR ; Even zap the scheduler list!
UARCLS (B)
MOVE P,[-PDLLEN,,PDL] ; Reset PDL.
SETZB F,MF ; Clear all flags
.CORE LCKPAG+1 ; Flush all dynamic and system core.
JSR DEATHV ; Leaves the locks intact!
SETZM LSRTNS"LSRADR
MOVEI A,400
MOVEM A,LSYSPG
SETZM SYSFPG
SETZM FSYSWD
SETZM NQMFWR
SETZM FFPAG
SETZM MAPPNT
SETZM ARPAGS
CALL SCOPN ; Reopen for business.
OUT(SC,EOL)
STAT (,("RESTARTING! THE DATE IS "),TIM(F1),("
BOOSTER WAS: "),6F(PRGNAM),(" #"),6F(VERSHN),EOL)
CALL MCINIT ; Map core.
SETOM GCQFLG ; Say GC when convenient.
CALL SCHINI ; Init scheduler list.
CALL SCHREM ; Init reminder list.
CALL SCHNTA ; Schedule net sites on QML.
JRST WAKEUP ; Go wakeup!
];0
SUBTTL INIT$G - NORMAL STARTUP INITIALIZATION
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;; ;;;;;;;;
;;;;;;;; STARTUP INITIALIZATION ;;;;;;;;
; First, enable bad-condition interrupts as fast as possible.
INIT: MOVE P,[-PDLLEN,,PDL] ; Set up PDL
SETZB F,MF ; Clear all flags
MOVE A,[-6,,[
.ROPTION ? TLO 0,%OPALL ; Use new mode ints & lock hacking.
.RMASK ? IOR 0,[%BADPI] ; Specify interruptable bad conditions,
.RPICLR ? MOVE 0,[-1]]] ; and enable them.
SYSCAL USRVAR,[CIMM %JSELF ? A]
JSR SYSLOS ; ??
CALL MYADDR ; Set our address(es)
CALL BULKCK ; Figure out if we are the bulk mailer
SKIPE XVERS ; New or experimental version?
CALL XVRSRT ; If so, change various parameters before touching files
SKIPN PURESW ; And now, make sure
CALL IPURIF ; that pages are pure!
CALL DATIME"UPINI ; Now initialize time routines for MLINIT.
CALL MTMHNG ; If can't get, hang waiting for time!!
CALL MLINIT ; Now ensure uniqueness!
; OK, this process is unique - now committed to coming up!
; Decide whether need to disown self or not.
SKIPE DEBUG ; If debugging,
JRST INIT10 ; don't disown.
.SUSET [.RINTB,,A] ; See if we are top-level
JUMPL A,INIT10 ; If so, no need to disown!
.SUSET [.ROPTION,,A] ; If not top-level, see if superior is DDT.
TLNE A,%OPDDT ; Skip if superior not DDT.
.VALUE [ASCIZ /
5 : Launched! T plus 1 msec 
/] ; Disown as top-level demon.
; Now assume we're disowned... open stats and print
; startup message.
INIT10: CALL SCOPN ; Initialize SC statistics channel.
.SUSET [.RUNAM,,A] ; Get UNAME (here same as uname of creator)
.SUSET [.RJNAM,,B] ; and JNAME
OUT(SC,EOL)
STAT (,("POWERING UP! THE DATE IS "),TIM(F1),("
BOOSTED BY "),6F(PRGNAM),(" #"),6F(VERSHN),(" LAUNCHED BY "),6F(A),(" AS "),6F(B),EOL)
; OK, can now run assured that any lossage from this
; point on will be recorded in stats file!
CALL MCINIT ; Initialize core mappage and management.
CALL MTINIT ; Check out time to ensure correct!
CALL SUNAME ; Now that core is mapped, set name.
; Initialize files if necessary, to recover from possible crash
; during GC'ing of MSGS.
CALL MGCFIX ; Fix whatever.
SETOM GCQFLG ; Garbage collect the queues when convenient
; Must initialize Schedule List. This implies setting up
; initial requests for any reminders or network sites which
; are queued.
CALL SCHINI ; Create initial schedule list.
CALL SCHREM ; Find first reminder time due and schedule it.
CALL SCHNTA ; Find and schedule delivery sites.
; All done with initialization! Now proceed as if waking up from
; sleep...
JRST WAKEUP
SUBTTL INIT - Time checking
;;; The following performs follow-up checking on system time, after
;;; DATIME"UPINI has been called. Attempts to perform an error check -
;;; This can be done in 2 ways:
;;; [1] Compare given time with other network sites.
;;; [2] Compare given time with last reference date of a file.
;;; First we try [1]. If more agree than disagree, return quietly.
;;; Else if more disagree, attempt to get a human to fix it, and halt.
;;; If there is a tie (which happens when all hosts are down, also)
;;; then use [2] as a tiebreaker.
;;; This code is a bad idea. ALAN, JTW, & SRA, 21 March 86.
MTINIT: IFE 0,RET ; Code loses, disable it.
.ELSE { ; For posterity...
PUSHAE P,[A,B,C,D]
SETOM MTINIF' ; Set no call for assistance yet flag
MTINI0: SETZ D, ; Clear match-mismatch counter
MOVSI B,-NTMSIT ; Loop thru time-site table
MTINI3: MOVE A,MTMSTB(B)
CAMN A,OWNHST ; Don't do own site.
JRST MTINI5
CALL NETIM ; Find time at that site.
JRST MTINI5 ; Site down or can't get.
MOVE C,A
CALL DATIME"TIMGTN ; Get net-style time here.
JSR AUTPSY
SUB A,C ; Find difference in time.
MOVMS A ; Get magnitude
CAMLE A,MTOKDF ; Compare with allowable difference.
AOSA D ; Ugh, bad! mark 1 mismatch.
ADD D,[1,,0] ; Aha, mark 1 match.
MTINI5: AOBJN B,MTINI3
; Now compare matches with mismatches. The majority rules!
JUMPE D,MTINI9 ; If neither match nor mismatch, try a file
HLRZ A,D ; Get # matches in A
CAILE A,(D) ; More matches than mismatches?
JRST MTINI6 ; Yup, all clear!
; Ugh, network time hacking says our time is wrong!
MTINI7: PUSH P,A ; Save for ease in debugging
.SUSET [.RINTB,,A] ; See if toplevel
JUMPL A,MTINI8 ; Jump if so
.SUSET [.ROPTION,,A] ; Not toplevel, see if under DDT
TLNN A,%OPDDT ; Skip if under DDT.
JRST MTINI8 ; Nope
POP P,A
.VALUE [ASCIZ /: System time is wrong or inaccessible!
/]
JRST MTINI0 ; If proceeded, try again.
; Time no good, and we are disowned.
; Call for help! Maybe someone just brought the system up with
; the time wrong and is near the system console.
; Clobber instruction at MTINI8 to JSR AUTPSY if you think you
; are having problems.
MTINI8: POP P,A ;Get back debugging info
.OPEN TMPC,[.UAO,,'T00]
JRST MTIN8A
AOSE MTINIF ;Only call for help once
JRST MTIN8A
OUT(TMPC,OPEN(UC$IOT),("
"),C(7),C(7),("Hey! The time is messed up. Fix it! (:PDSET?)
Yr mst obdt svt,"),C(7),("
"),6F(UNMPRF),SP,6F(JNMPRF),("
"))
MTIN8A: .CLOSE TMPC,
MOVEI B,30.*30. ;Wait half a minute then try again
.SLEEP B,
JRST MTINI0
MTINI9: SYSCAL OPEN,[[.UAI,,NETD] ; No info from network, try a local file
SATDEV ? STFN1 ? STFN2 ? SATDIR]
JRST MTINI6 ; Oh well
SYSCAL RFDATE,[CIMM NETD ? CRET A]
JSR SYSLOS
.CLOSE NETD,
CALL DATIME"TIMSEC ; Abs seconds that file last written
MOVE C,A
CALL DATIME"TIMGTN ; Abs seconds current time
JSR AUTPSY
SUB A,C ; Number of seconds elapsed since last wrote
JUMPL A,MTINI7 ; Hmm, time must have run in reverse
CAML A,[7*24.*60.*60.]
JRST MTINI7 ; No mail sent for a week? I doubt it
MTINI6: POPAE P,[D,C,B,A] ; Win. time is satisfactory.
RET
MTOKDF: 15.*60. ; # seconds of tolerable difference between site times.
; Table of sites running TIMSRV's.
MTMSTB: HN$MC ; MC
; HN$AI ; AI
; HN$DM ; DM
; HN$ML ; ML
; HN$A67 ; AMES-67
; HN$SAI ; SAIL
NTMSIT==.-MTMSTB
};.ELSE IFE 0
;;; Well known addresses. This should be removed someday, or at least
;;; replaced with cells initialized at boot time....
DEFINE HNARP IMP,HOST
<RESOLV"NW%ARP>+<IMP>+<HOST_16.>!TERMIN
DEFINE HNCHA NUM
<RESOLV"NW%CHS>+<NUM>!TERMIN
; Arpanet is gone (well, almost gone), most of this is useless.
;HN$AI=<HNARP 6,2>
;HN$MC=<HNARP 54,3>
;HN$SAI==:<HNARP 13,0>
;HN$DM==:<HNARP 6,1>
;HN$ML==:<HNARP 6,3>
;HN$A67==:<HNARP 20,0>
;HN$MX==:<HNARP 6,1>
;HN$XX==:<HNARP 54,0>
; Let's try chaosnet addresses for the moment
HN$AI==:<HNCHA 3130> ; ITS machines
HN$MC==:<HNCHA 3131>
HN$MD==:<HNCHA 3132>
HN$ML==:<HNCHA 3133>
HN$LCS==:<HNCHA 15044> ; LCS.MIT.EDU mail relay machine
; Magic address to drop into TCPGAT if we're a chaos-only machine.
GATHST: HN$LCS
; MTMHNG - Time Hanger... called immediately after determining that system
; doesn't know time. If running under DDT, will .VALUE appropriate
; string and halt, else will attempt to wait it out.
MTMHNG: PUSH P,A
.SUSET [.RINTB,,A] ; See if toplevel
JUMPL A,MTMHN5
.SUSET [.ROPTION,,A] ; No, see if under DDT.
TLNN A,%OPDDT ; Skip if so.
JRST MTMHN5
.VALUE [ASCIZ /: System doesn't know proper time!! 
/]
JRST .-1
; Not under DDT, wait til we win.
MTMHN5: CALL DATIME"UPINI
CAIA
JRST POPAJ ; Aha, have the time now!
MOVEI A,30.*15. ; Else sleep 15 sec
.SLEEP A,
JRST MTMHN5 ; and try again.
;;; MYADDR - Set OWNHST and OWNHS2.
MYADDR: MOVE A,[RESOLV"NW%ARP] ; Normally use Arpanet
CALL RESOLV"OWNHST ; Find # of host we're on
SETZ A, ; Don't appear to have Arpanet
MOVEM A,OWNHST ; Store what we got
MOVE B,GATHST ; Address of the default relay machine
; CAME A,[HN$MX] ; Make Gumby happy by faking this for MX
JUMPN A,.+3 ; Are we on the Arpanet?
SKIPN HDRGAT ; No, if there isn't a patched in value
MOVEM B,HDRGAT ; Use the default.
JUMPN A,.+3 ; This doesn't happen for MX though
SKIPN TCPGAT ; Unless there's a patched in TCP relay
MOVEM B,TCPGAT ; Store the default relay.
JUMPN A,.+3 ; MX doesn't exist anymore anyway
SKIPN DOMGAT ; Unless there's a patched in domain relay
MOVEM B,DOMGAT ; Store the default relay.
MOVE A,[RESOLV"NW%CHS] ; Now check Chaosnet
CALL RESOLV"OWNHST ; Try Chaosnet now
SETZ A, ; No chaosnet
SKIPN OWNHST ; No arpanet?
EXCH A,OWNHST ; Well, use Chaos as primary, then
MOVEM A,OWNHS2 ; Store secondary address
SKIPN OWNHST ; No networks at all???
JSR AUTPSY ; Hopeless case, punt
RET ; On Arpanet, win.
SUBTTL INIT - Memory management (allocation, mapping)
; Core in mailer satellite is arranged as follows:
; Beg of address space
; PGM Impure
; PGM Pure 20-some pages
; LOCKS 1 page for lock switch vars, global impure.
; NQMFWR 1 page mapped into sys for read access to NQMFWR variable
; LSR1 Approx 10 pages for mapping the paged LSR1 file.
; HOSTS3 Approx 60 (!) pages for mapping the entire HOSTS3 file.
; FFPAG Freespace controlled by core manager (for areas, etc.)
; SYSCOR Enough core to pure-read-map into all system user-var storage.
; End of address space
BVAR
FFPAG: 0 ; Number of the first truly FREE page to be given to CORSER.
MAPPNT: 0 ; Argument to MAPIN. (Core page AOBJN).
ARPAGS: 0 ; Core page AOBJN defining free, dynamically useable pages.
SYSFPG: 0 ; # of first page mapped into system
FSYSWD: 0 ; Address of first word mapped into system (SYSFPG*2000)
LSYSPG: 400 ; # of page following last sys-mapped page.
NQMFWR: 0 ; Our address to access system NQMFWR at.
EVAR
; MCINIT - initializes core areas with exception of
; locked-switch mapping.
MCINIT: PUSHAE P,[A,B]
CALL MAPSYS ; Get system pages mapped into high core.
CALL MAPNQM ; Map in single page for system NQMFWR variable.
MOVEI B,FREEPG ; Now generate a word with -<SYSFPG-FREEPG>,,FREEPG
SUB B,SYSFPG ; as the initial "argument" to MAPIN.
HRLZ B,B ; The real value of MAPPNT will get generated
HRRI B,FREEPG ; later, after we know how much space they want.
MOVEM B,MAPPNT ; Hopefully LSR1 won't grow too much
CALL MAPIN ; during the life of the COMSAT.
MOVEM A,FFPAG ; And this is the first page we will give to CORSER.
SUBI A,FREEPG+1
MOVN A,A
HRLZ A,A
HRRI A,FREEPG ; Now have a "page aobjn" to space for LSR1, HOSTS3.
MOVEM A,MAPPNT ; Update ptr for MAPIN to use in the future.
MOVE A,FFPAG
SUB A,SYSFPG
ADDI A,1
HRLZ A,A
HRR A,FFPAG ; Now we have a "page aobjn" to the dynamically
MOVEM A,ARPAGS ; allocated space i.e. -<SYSFPG-FFPAG-1>,,FFPAG
TLNE F,%SCOPN
PSTAT (,("Note: Dynamic freespace is: "),LHS(A),(",,"),RHV(A))
UARINIT ARPAGS ; Initialize area UUOs and CORSER.
MOVSI A,-NAREAS ; Make sure all ARBLKs declared closed,
MOVE B,ARPTBL(A) ; by getting ARPT to each
SETZM $AROPN(B) ; and zapping.
AOBJN A,.-2
MCINI9: POPAE P,[B,A]
RET
;Kludge to get maximal response to files on .mail. -- ITS has
;variable "NQMFWR" which is aos'ed each time write files are closed on
;.MAIL. directory. The COMSAT maps a page into the proper area of
;system to access this variable, and .hangs on it, so that satellite
;is unhung and "started" as soon as something is written.
MAPNQM: PUSHAE P,[A,B]
MOVE A,[SQUOZE 0,NQMFWR]
.EVAL A, ; Find location of NQMFWR in system.
JSR SYSLOS
IDIVI A,2000 ; Get page # in A, addr within page in B
ADDI B,SYSWPG*2000 ; Find address within own core to reference.
SYSCAL CORBLK,[CIMM %CBRED+%CBNDR ; Must get read acc to syscor.
CIMM %JSELF ;for us
CIMM SYSWPG ;at spec'd page
CIMM %JSABS ;from system (absolute),
A] ;from specified absolute page.
JSR SYSLOS
MOVEM B,NQMFWR ; Store addr to reference for NQMFWR access.
POPAE P,[B,A]
RET
; MAPIN - Map in the LSRTNS stuff.
; MAPPNT/ page aobjn
; Returns in A: the number of the first page NOT used.
; LSR1C channel is left open so we can page that database.
; For historical reasons, we also set up things that used to be related
; to HOSTS3 (OWNNAM et al).
MAPIN: PUSHAE P,[B,D]
MOVE D,FFPAG ; Assume free space isn't changing.
.IOPUSH DKIC, ; Don't clobber chan.
;; See if we need a new LSR1 database.
SKIPN LSRTNS"LSRADR ; If LSR1 database is not mapped in
JRST MAPI10 ; we need to get it.
MOVEI A,LSRFN1 ; Already mapped in, but may be out of date.
CALL OPNMFI ; Check for update notification file.
JRST MAPI20 ; None, so current version is fine.
MAPI10: ;; Let's just assume this works right, ok?
; TLNE F,%SCOPN
; PSTAT (,("Note: Gobbling LSR1 database"))
MOVEI A,LSR1C
MOVE B,MAPPNT
CALL LSRTNS"LSRMAP ; Map in LSR1 database, LSR1C remains open!
JSR AUTPSY
HRRZ D,B ; New begining of free space
ADDI D,3 ; Allow some slop into which LSR1 can grow
;; We have the latest LSR1 data, so delete the update notification.
SYSCAL DELEWO,[%CLIMM,,DKIC]
NOP
MAPI20: .CLOSE DKIC,
PUSH P,D ; Stash # of 1st page not used up
MOVE A,[440700,,OWNNAM] ; Get primary hostname (asciz string)
MOVE B,OWNHST ; (Chaos and IP names are identical, by fiat)
CALL RESOLV"HSTSRC ; Get string
JSR AUTPSY ; We don't know about ourselves?
SKIPN B,HDRGAT ; Same for gateway if present
JRST MAPI90 ; Guess not
MOVE A,[440700,,GATNAM] ; Is there, get its name for header munging
CALL RESOLV"HSTSRC
JSR AUTPSY ; Better find it if are using it!
MAPI90: POP P,A ; Return # of 1st page not used up.
MAPI99: .IOPOP DKIC, ; Restore chan.
POPAE P,[D,B]
RET
; MAPSYS - hair which maps right section of system into our high
; core, so that can access the user variables for all jobs, without
; mapping in entire system.
MAPSYS: PUSHAE P,[A,B,C,D]
MOVE A,ITSYMC
CALL EVALER ;evaluate constant syms
MOVE A,ITSYML
CALL EVALER ;and random locations
MOVE A,ITSYMX
CALL EVALER ;and indexable user var locations.
.SUSET [.RUIND,,C] ;Set up MYUIND for SUNAME
IMUL C,LUBLK
MOVEM C,MYUIND
MOVE C,MAXJ ;get max # jobs allowable
IMUL C,LUBLK ;multiply by storage/luser to get # wds total storage
ADD C,USRSTG ;add addr of first user var blk, to get highest sys addr
MOVE A,USRHI ;now get addr of only non-user loc we must map.
TRZ A,1777 ;get addr of page containing usrhi.
SUB C,A ;now get # wds we need mapped
ADDI C,1777
LSH C,-10. ;now have total # pages required, starting from (a).
MOVEI B,400 ;get total # pages avail in job
SUB B,C ;get page # in us to start sys mapping at.
MOVEM B,SYSFPG ;store as # of first sysmap page (400 is last+1)
LSH B,10. ;get addr for it
MOVEM B,FSYSWD ;also store
SUB B,A ;find difference, <our mapping>-<its mapping>
ADDM B,USRHI ;get our mapping for usrhi
MOVE C,ITSYMX ;now get mappings for user vars
HRLI B,C ;make them indexed by c!
ADDM B,1(C) ;map
ADDI C,1 ;get next sym
AOBJN C,.-2
; a has first sys addr we want, lsyspg-sysfpg is # pages to insert at sysfpg.
LSH A,-10. ;get system page # to start mapping at
MOVE B,LSYSPG
SUB B,SYSFPG ;get # pages desired
IMUL B,[-1,,0]
HRR B,SYSFPG ;now have -<# pgs>,,<sysfpg>
SYSCAL CORBLK,[CIMM %CBRED+%CBNDR ;get read access, fail if can't
CIMM %JSELF ;for us
B ;starting at sysfpg, for n pages
CIMM %JSABS ;from system
A] ;at abs location in a.
JSR AUTPSY ;fooey?!? must be bad args.
POPAE P,[D,C,B,A] ;whew, all done!
RET
; XSRFND - given xuname in a, skips if hactrn exists with that xuname,
; and returns actual uname in a.
XSRFND: PUSHAE P,[B,C,D]
MOVE D,XUNAME ;addr to indirect thru for xuname user var.
JRST USRFN1 ;jump into finder
; USRFND - given uname in a, skips if <uname> hactrn exists.
USRFND: PUSHAE P,[B,C,D]
MOVE D,UNAME ;addr to indirect thru for uname user var.
USRFN1: MOVE B,[SIXBIT /HACTRN/] ;jname to look for
MOVE C,@USRHI ;get current first free user-var index
USRFN2: SUB C,LUBLK
JUMPLE C,USRFN7 ; 0 is sys job... jump if no more jobs to check
CAME A,@D ;check uname
JRST USRFN2 ;nope
CAME B,@JNAME ;right uname, does he have hactrn?
JRST USRFN2 ;nope
MOVE A,@UNAME ;ah, won! get real uname in case xuname was checked.
AOS -3(P) ;skipping return
USRFN7: POPAE P,[D,C,B]
RET
;macro to generate table of its symbols so evaler can munch and
;syms can then be accessed by name or indirected thru to sys core.
;first wd of table is aobjn to rest, each sym has 1 wd for squoze repres.
;and second labelled as that sym.
DEFINE SYMS LIST
%%S==. ? 0
IRPS SYM,,[LIST]
SQUOZE 0,/SYM/
SYM: 0
TERMIN
%%N==<.-%%S-1>/2 ; # syms
TMPLOC %%S,{ -%%N,,%%S+1 }
TERMIN
; EVALER - routine to .eval a table of its symbols
; A has first entry of table generated by syms macro, which is aobjn ptr.
EVALER: PUSHAE P,[A,B]
EVALR1: MOVE B,(A) ;get squoze for symbol
.EVAL B, ;find value
JSR AUTPSY ;any failures are assumed fatal.
MOVEM B,1(A) ;store
ADDI A,1 ;increment since each sym takes 2 wds
AOBJN A,EVALR1
POPAE P,[B,A]
RET
; ITS symbols necessary for access to user variables
BVAR
ITSYMC: SYMS [MAXJ LUBLK USRSTG] ; Constants. MAXJ is max # jobs,
; LUBLK length of a user var block,
; USRSTG address of start of user var blocks.
ITSYML: SYMS [USRHI] ; Locations.
; USRHI is first non-existent user var block index.
ITSYMX: SYMS [UNAME XUNAME JNAME USYSNM SUPPRO] ; User var locs, indexed into.
EVAR
; SUNAME - Come here to try to set UNAME, JNAME, and SNAME.
; If this job is top-level, try to set UNAME to UNMPRF, and
; JNAME to JNMPRF; SNAME is set to JNMPRF whether top-level or not.
; Uses the fact that the user variables are mapped in to avoid doing
; anything if the name is already OK.
SUNAME: PUSHAE P,[A,B,C]
MOVE C,MYUIND
MOVE A,@USYSNM ; Get own SNAME
CAME A,JNMPRF ; If not what we want, then
XCTILO [.SUSET [.SSNAME,,JNMPRF]] ; Set it.
JFCL ; Should always win, but who knows.
MOVE A,@UNAME ;get own UNAME
MOVE B,@JNAME ;and own JNAME
CAMN A,UNMPRF
CAME B,JNMPRF
SKIPL @SUPPRO
JRST SUNAM9 ;Name OK or not top-level, exit
.CLOSE DQCH, ;Gross kludge, make sure DQDEV has our UNAME
.SUSET [.SXUNAME,,UNMPRF]
.SUSET [.SHSNAME,,SATDIR] ;Make file author kludge happier
XCTILO [.SUSET [.SUNAME,,UNMPRF]]
JRST SUNAM0 ;Can't set UNAME
XCTILO [.SUSET [.SJNAME,,JNMPRF]]
JRST SUNAM1 ;Set UNAME OK but need different JNAME
SUNAM9: POPAE P,[C,B,A] ;Set both OK, return
RET
SUNAM0: XCTILO [.SUSET [.SJNAME,,JNMPRF]]
JRST SUNAM9 ;Can't set anything, try again later
XCTILO [.SUSET [.SUNAME,,UNMPRF]]
JRST SUNAM1 ;Try a different JNAME
JRST SUNAM9 ;winning now
SUNAM1: MOVE A,JNMPRF
MOVSI B,770000 ;B mask for appended zero.
SUNAM3: TDNN A,B
JRST SUNAM4
LSH B,-6
JUMPN B,SUNAM3
MOVEI B,77 ;6 character name, clobber right-most
SUNAM4: ANDCM A,B ;flush any existing digit in that place
AND B,[010101010101] ;multiplier for that place
PUSH P,B
IMULI B,'0
ADD A,B ;put in a zero
POP P,B
MOVEI C,10.
SUNAM5: XCTILO [.SUSET [.SJNAME,,A]] ;Try this JNAME
JRST [ ADD A,B ? SOJG C,SUNAM5 ? JRST SUNAM9 ] ;and successive ones
XCTILO [.SUSET [.SUNAME,,UNMPRF]] ;Make sure UNAME is right
JRST @.-2 ;lose, try another JNAME
JRST SUNAM9 ;win
SUBTTL INIT - Locks (establish uniqueness)
; MLINIT - initializes global-impure map for lock switches.
; Has special function of checking the switches and dying instantly
; if it determines that it is a duplicate.
LVAR HAVLKS: 0 ;set when page with locks is initialized and accessible
LVAR UNIQUE: 0 ;set when have locked switch 1 = job is unique.
;(others will die instantly)
MLINIT: PUSHAE P,[A,B,C]
SETZM UNIQUE ; Clear flag indicating whether unique
SETZM HAVLKS ; Ditto for flag saying whether have page and locks
MLINI1: .CALL LKFOPN ; Try to get dsk chan to lock-sw file
CAIA ; If failed, skip and try to create it.
JRST MLINI3 ; Have chan to lock-sw file... gobble locks!
CAIE A,%ENSFL
JSR DEATH ; Error other than non-existent file
.CALL LKFMAK ; If failed, try to create
JSR DEATH ; If even that fails, die instantly.
MOVE A,[-2,,[0 ? 0]] ; Output 2 zero wds to clear LSWREQ, LSWDON.
.IOT DKOC,A
.CLOSE DKOC, ; Close, creating file
.CALL LKFOPN ; Now try again to get channel.
JSR DEATH ; If failed after writing file....????
MLINI3: SYSCAL CORBLK,[CIMM %CBNDW+%CBPUB ; Make public with write access.
CIMM %JSELF ; put into self
CIMM LCKPAG ; at page reserved for it
CIMM DKIC] ; map from dsk file.
JSR DEATH ; Ugh?????
CALL LKINIT ; Initialize switches
SETOM HAVLKS ; Have the page and locks!
MOVEI A,LOCK1 ; Concentrate on switch 1
CALL LKGRAB ; Try once to gobble it
JRST [ SKIPE MAKING ; Are we in the MAKMST routine?
JRST MAKMNU ; Yes, if not unique yell at hacker!
JSR DEATH] ; Normal failure. Die.
SETOM UNIQUE ; Ah, we have locks and are unique, set flag.
POPAE P,[C,B,A] ; We've gobbled it and won, stay alive and continue.
RET
LKFOPN: SETZ ? SIXBIT /OPEN/ ? [.BII,,DKIC] ? ['DSK,,0] ? %CLERR,,A
LCKFN1 ? LCKFN2 ? SETZ SATDIR
LKFMAK: SETZ ? SIXBIT /OPEN/ ? [.BIO,,DKOC] ? ['DSK,,0]
LCKFN1 ? LCKFN2 ? SETZ SATDIR
TMPLOC 43,{ 0 } ;pointer to locked switch list for lock hacking
TMPLOC 44,{ -LCCBLK,,CCBLK } ;aobjn ptr to critical code table for lock hacking
; Critical code table pointed to by word 44 !
CCBLK: LKINI2,,LKINI3 ;for crashing in LKINIT
MOVEM A,LSWREQ
LKGRB1,,LKGRB2 ;for crashing in LKGRAB
SETOM @A
LKFRE1,,LKFRE1+1 ;for crashing in LKFREE
SETOM @A
LCCBLK==.-CCBLK
; LKINIT - Initialize Lock Switches (as per LOCKS documentation)
LKINIT: PUSHAE P,[A,B]
SYSCAL RQDATE,[CRET A ? CRET A]
JSR SYSLOS
CAMN A,[-1]
JSR AUTPSY ; Foo? System doesn't know time...
MOVE B,A ; Save date/time sys started
LKINI1: EXCH A,LSWREQ ;claim right of initializing (nop if already claimed)
LKINI2: CAMN A,LSWREQ ;did we get it?
JRST LKINI5 ;no, check 2nd word to see if other guy fulfilled duty
; Got access, we must initialize! LKINI2 to LKINI3-1 is critical code
SETOM LOCK1 ; Clear the lock(s)
SETZM LOCK2 ; Not really a lock... count of dead comsats.
LKINI3: MOVEM B,LSWDON ; Indicate init done
LKINI9: POPAE P,[B,A]
RET
LKINI5: CAMN B,LSWDON ;didn't get init rights, see if other finished it.
JRST LKINI9 ;yes, nothing left to do.
MOVEI A,30. ;no, he's still at it...hang around, he might die.
.SLEEP A,
MOVE A,B
JRST LKINI1 ;try to claim again.
; LKGRAB - takes A as addr of switch to swipe at; skips if
; successfully grabbed switch for very own, doesn't skip if
; it was locked. tries only once!!!
LKGRAB: AOSE (A) ;try to get it
RET ;lost
LKGRB1: PUSH P,B ;got it! now put it on
MOVE B,43 ;locked switch list
HRLI B,(SETOM)
MOVEM B,1(A)
MOVEM A,43
LKGRB2: POP P,B ; LKGRB1 to LKGRB2-1 is critical code
AOS (P) ;skip, we got it
RET
; LKFREE - takes A as addr of switch to free.
; (assumes that same switch is first item on locked switch list)
LKFREE: PUSH P,B
HRRZ B,1(A)
MOVEM B,43 ;remove from lsw list
LKFRE1: SETOM (A) ;and unlock (LKFRE1 is critical instr.)
POP P,B
RET
SUBTTL EQV - File description (NAMES >)
IFN 0,[
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Format of ASCII EQV file is as follows:
;;; (see actual file for more general details...)
A recipient spec or RSPEC in standard form is:
(<rtyp> <rnam> X <attr> <attr> ... <attr> )
If <rspec> is an atom, it is read as (<rspec>), which
(see below) turns into (NAME <rspec>).
Where:
<rtyp> - Recipient type, such as NAME, FILE, RUN, BUG.
If <rtyp> is not a recognized type, it is interpreted
as being the <rnam>, of type NAME.
<rnam> - Recipient string, such as KLH, INFO-ITS, [SYS;TS FOO].
<attr> - Attributes, each of which is parsed as:
(ATTR AVAL)
Where ATTR - Attribute name.
AVAL - Attribute value.
If A is an atom rather than a list, it is read as
(ATTR). I.e. it exists but has no value.
X - Also an Attribute, but interpreted crockishly. If
X is a list, it is a normal Attribute;
Otherwise if an atom,
1) If "@" is the first character, interpretation is (SITE X)
2) If a number or site name, interpretation is as above.
3) Else as for atomic <attr>.
Equivalence entries are in the format
(<name> <attr> ... <attr> (EQV-LIST <rspec> ... <rspec>))
<name> - A recipient name for which the following information applies.
Only recipients of type NAME will be matched up in
the EQV file.
<attr> - Attribute, exactly as described above, which applies for this name.
<rspec> - Recipient spec to which the message should be sent, in lieu of
the <name> itself. To actually send to <name> there should
either be no (EQV-LIST ... ), or <name> should be one of
the <rspec>s within it.
THE FOLLOWING IS OUT OF DATE, AND NOT AT ALL CORRECT!!!!
Current Internal Format:
Each equivalence is parsed into a LLN and all the LLNs strung
together into the main list, with initial LP in $LLLST(L). Each LLN
(of attrib A$ELST) points to a list, the first LN of which must have
attrib A$ENAM and which is followed by normal recipient-attribute LN's.
However, within these following LN's can occur those of type A$RCP, which
are LLN's pointing to a recipient list of their own. These A$RCP's
represent the EQV-LIST for the given A$ENAM.
Later, there will be no main list nor A$ELST LLN's. Rather,
a sorted table will exist in the HDR area, each word representing one
equivalence and containing <LP to A$ENAM LN>,,<LP to "following LN's">.
]
SUBTTL EQVCHK - Equivalence file loading
LVAR EQVTIM: 0 ;has creation time of last ascii file for which compilation attempted.
;Note that this can close all areas except SCHDAR
EQVCHK: PUSHAE P,[A,B]
MOVEI A,EQAFN1 ; See if a new ascii file was written.
CALL OPNMFI ; Try to open it.
JRST [ STAT (,("No ascii EQV file exists??"))
JSR AUTPSY]
SYSCAL RFDATE,[CIMM DKIC ? CRET A] ; Get creation time.
JSR SYSLOS
CAMN A,EQVTIM ; Compare with time of last file gobbled
JRST EQVCH9 ; OK, still same
EXCH A,EQVTIM ; Not same!!! Store new, get old time.
JUMPN A,EQVCH3 ; Jump if cause is new ASCII file.
;; Initialization, see if really need to re-compile.
;; Get creation time for existing bin file and compare.
.IOPUSH DKIC, ; Save chan.
MOVEI A,EQVFN1
CALL OPNMFI ; Open eqv bin file
JRST [ .IOPOP DKIC, ; If no EQV file, definitely must recompile!
JRST EQVCH3]
SYSCAL RFDATE,[CIMM DKIC ? CRET A] ; Get creation time.
JSR SYSLOS
.IOPOP DKIC,
CAML A,EQVTIM ; Bin created before ascii file?
JRST EQVCH9 ; Nope, created after, win! Needn't compile.
;; New ASCII file has appeared, must try to compile it.
EQVCH3: CALL EQVGOB ; Attempt compile
CAIA ; Compilation lost?
JRST EQVCH7 ; Won...
STAT (,("Note: LOST on compilation of ascii EQV file, trying backup binary..."))
CALL EQVBIN ; Try to get bin.
CAIA ; Binary lost too???
JRST [STAT (,("Note: Backup won."))
JRST EQVCH7]
STAT (,("Note: Backup failed... dying."))
JSR AUTPSY ; Refuse to run without beloved EQV file!
EQVCH7: STAT (,("Note: EQV file compiled."))
EQVCH9: POPAE P,[B,A]
.CLOSE DKIC,
RET
;;; EQVBIN/EQVGET - Slurp binary up into core.
EQVBIN: PUSH P,A
MOVE A,[EQVAR,,EQVFN1]
CALL DFGET ; Get compiled EQV data file.
JRST POPAJ ; Not there?
JRST POPAJ1
EQVGET: PUSH P,A ; Same but no erret provision
MOVE A,[EQVAR,,EQVFN1]
CALL DFGET
JSR AUTPSY
POP P,A
RET
SUBTTL EQVGOB - Compilation of NAMES > ascii equivalence file
; Compile ASCII EQV file, produce "binary" LSE file.
; Note that this can close all areas except SCHDAR
EQVGOB: PUSHAE P,[A,B,C,D,E,L]
CALL MAPIN ; Ensure latest HOSTS3 and LSR1 databases.
STAT (,("Note: Compiling EQV file "))
MOVSI C,-NAREAS ; Flush any and all areas in core.
EQVGO1: MOVE B,ARPTBL(C) ; Get ARPT to each area in turn.
CAIE B,SCHDAR ; Sparing only the Schedule list!
UARCLS (B) ; Closeum!
AOBJN C,EQVGO1 ; Loop for all areas to flush when coring down.
MOVE A,[IMSAR,,EQAFN1]
CALL OPNMFI
JRST [ CSTAT (,("!! Couldn't open !!"))
JRST EQVG99] ; Fail.
SYSCAL RFNAME,[CIMM DKIC ? CRET JUNK ? CRET EQAFR1 ? CRET EQAFR2]
JSR SYSLOS
SYSCAL FILLEN,[CIMM DKIC ? CRET B]
JSR AUTPSY
CSTAT (,6F(EQAFR1),(" "),6F(EQAFR2),(" "),LPAR,N10(B),(" wds"),RPAR,("..."))
CALL TXFIN ; Get ascii file
; Do heuristics on file length to set EQV LSE initial size.
; This minimizes thrashing caused by infinite expansions.
MOVE C,B
LSH C,1 ; Double file length
IDIVI C,3 ; Div by 3, and
MOVE D,C ; Use (2*len)/3 as length of SA
LSH C,1 ; and remaining 2/3 as length of LA.
MOVEI B,[0 ? C ? D] ; Furnish these values to LSE open routine.
MOVEI A,EQVAR
CALL LSEOPX ; Open a fresh EQV LSE with given sizes.
MOVE L,$ARLOC+EQVAR ; Set current LSE to EQV.
MOVEI A,IMSAR ; Indicate input area.
CALL RCPGOB ; Gobble them up!
; Done compiling, now write out report file
MOVEM A,$LLLST(L) ; store returned LP to list.
CAIN B,0
UAROPN [%ARTCH+%ARTZM,,ETXTAR ? [40]] ; Open very small area for error text collection.
OUT(TMPC,OPEN(UC$UAR,ETXTAR))
JUMPE B,EQVG95 ; Jump if no errors.
FWRITE TMPC,[N9,B,[ Errors detected, file ],6F,EQAFR1,[ ],6F,EQAFR2,[ Rejected.
]]
CSTAT (,N9(B),(" Errors, rejected. "))
CALL EQRPUT
JRST EQVG99
; No errors.
EQVG95: FWRITE TMPC,[[No errors detected for file ],6F,EQAFR1,[ ],6F,EQAFR2,[
]]
CSTAT (,(" No errors. "))
CALL EQRPUT
MOVE A,[EQVAR,,EQVFN1]
CALL DFPUT ;write out the LSE
AOS -6(P) ;won, skip on return
EQVG99: POPAE P,[L,E,D,C,B,A] ;return
UARCLS ETXTAR ; Flush report-text area.
UARCLS IMSAR ; Flush input-text area.
RET
; Write out report file. Main hair is producing elegant FN2.
EQRPUT: PUSH P,A
SKIPA A,EQAFR2 ; Get true FN2 of input
EQRPT2: LSH A,-6
TRNN A,77 ; Anything in last char position?
TLNN A,-1 ; Or is LH gone?
CAIA ; Aha, ready to smash.
JRST EQRPT2 ; Nope, go shift it.
HRLI A,'ERR ; Make ERR the first 3 chars.
MOVEM A,EQRFN2
CSTAT (,("Writing report file "),6F(EQRFN1),(" "),6F(EQRFN2))
; MOVE A,[ETXTAR,,EQRFN1]
MOVE A,SATDEV ; Make sure we use the correct
MOVEM A,EQRDEV ; device and directory.
MOVE A,SATDIR
MOVEM A,EQRDIR
MOVEI A,EQRFIL
MOVEI B,ETXTAR
CALL ARDSKO
JSR AUTPSY
JSR AUTPSY
POP P,A
RET
SUBTTL *------------------- Mainline -----------------------*
SUBTTL Scheduler main loop
; Come here to execute a request, so that control drops
; back through to MAIN when done. A has LP to entry, B has time requested.
MAINX: MOVE C,A ; Save LP for later deletion.
MOVE A,LISTAR(A)+1 ; Get LP to list for entry.
MOVE A,LISTAR(A) ; Skip A$STIM LN.
MOVE B,LISTAR(A)+1 ; Get A$SRTN value (addr of rtn to XCT)
MOVE A,LISTAR(A) ; Get LP to A$SARG, and
MOVE A,LISTAR(A)+1 ; Finally have it in A!
LNDEL C,$LLLST(L) ; Now have all info, flush request from schedule list!
CALL (B) ; Execute request!
TLNE F,%SCOPN ; At end of each request,
OUTCAL(SC,FRC) ; make sure that buffered stats are forced out.
; Fall through when done.
MAIN: ;; First make sure the locks haven't been mysteriously unlocked
;; so we don't get two Comsats running at the same time
SKIPGE LOCK1
JRST [ STAT (,("*** LOCK1 not locked! ***"))
JSR AUTPSY ]
;; Next, truncate the STATS file so that Penny and Alan can
;; get some sleep.
TLNE F,%SCOPN ; Is it open?
CALL [ SYSCAL FILLEN,[CIMM SC ? CRET A]
JSR SYSLOS ; Yeah, get its length
CAMG A,SCMAXL ; Current file too long?
RET ; It's ok, out of here
JRST SCROPN ] ; Too long, handle it and return from there.
;; Now see if anything immediately urgent to do.
CALL SCHGT ; Get first request.
JUMPL B,MAINX ; Requests with negative time are urgent!
;; Nothing urgent to do, see if need to GC or update NAMES, etc.
;; These things are sometimes done now to defeat infinite input
;; requests that otherwise would never let COMSAT reach idle state.
SOSGE EQVQCT
JRST [ CALL EQVCHK ; Ensure currency of NAMES equivalences.
MOVE U1,EQVQLM ; Checked for NAMES, reset count.
MOVEM U1,EQVQCT
PUSH P,A
CALL MAPIN
POP P,A
JRST .+1 ]
SOSGE GCRQCT ; Bump count, and
JRST MAIN42 ; Go directly to GC-test if must.
;; See if there are any left-over MAILIN files around.
;; Process these before new input requests to preserve FIFO ordering.
CALL IRQGOT ; Try getting one, process if found.
CAIA ; Nope, nothing. Just continue.
JRST MAIN ; Whoops, hacked one! Return to sched loop!
;; Are there any input requests (MAIL files)?
CALL IRQGET ; Gobble and process if one exists.
CAIA ; No request files, continue.
JRST MAIN ; Else when done, back to schedule loop!
;; Nothing urgent and no input requests. Is first
;; schedule request semi-immediate? (Criteria is whether
;; time specified is present or past)
.RDTIME C, ; Get current system time
CAMG B,C ; How does request time compare?
JRST MAINX ; Less than or eq to! Must do!
;; Nothing that scheduler has to do NOW.
;; This is a good place to do nebbish little things,
;; like writing cruft to the STATS file...
SKIPG SCLCNT ; Have we written enough lines yet?
JRST [ MOVEI A,STTLIM ; Yep, reset the counter,
MOVEM A,SCLCNT
STAT (,("Date is now: "),TIM(MDYT)) ; and put out the date.
JRST .+1]
;; Here, there's really nothing to do but go to sleep.
;; B, having time of first schedule request, defines time
;; of next necessary action. See how far off it is...
.RDTIME C, ; Get system time again
MOVE A,B
SUB A,C ; Find 30'ths til next necessary action.
CAMG A,NAPLIM ; Sooner than limit for napping?
JRST MAIN60 ; Yes, go directly to take short nap.
;; Next request too far off to take nap. So, strip down stuff,
;; free core, close channels, GC and whatnot to prepare for
;; long hibernation.
;; Check to see if MSGS ought to be GC'd.
MAIN42: PUSH P,L
SKIPN $AROPN+MASTER ; Make sure in core
CALL MSTGET
MOVE L,$ARLOC+MASTER
MOVE A,$LHMFG(L) ; Get # wds garbage
MOVE B,$LHMFL(L) ; And length of MSGS thus far.
CAIG B,2000 ; If garbage is 1K or less,
JRST MAIN46 ; Don't bother.
CAML A,B ; If garbage is .GE. length,
JRST MAIN45 ; Then certainly GC!
IDIV B,A ; Well, see what Length/Garbage ratio is.
CAIGE B,4 ; If smaller than 4:1, then
MAIN45: CALL MSGSGC ; GC the MSGS file!
MAIN46: MOVE A,GCRQLM ; GC check done. Reset count, so that
MOVEM A,GCRQCT ; another check guaranteed to happen somtime.
AOSN GCQFLG ; Garbage collect queue?
CALL GCQ0
POP P,L ; SCHDAR
;; Flush all areas in core.
MOVSI C,-NAREAS
MAIN51: MOVE B,ARPTBL(C) ; Get ARPT to each area in turn.
CAIE B,SCHDAR ; Sparing only the Schedule list!
UARCLS (B) ; Closeum!
AOBJN C,MAIN51
;; Cleanup done, now should check schedlist again
;; in case something happened.
CALL SCHGT ; Get first on list.
.RDTIME C,
CAMG B,C ; Compare request time with current,
JRST MAINX ; and jump if necessary, else fall through...
;; Final checks before sleeping. B has time to wake up.
MAIN60: MOVE C,@NQMFWR ; Get current NQMFWR var.
CALL IRQCHK
CAIA ; Ah, OK to sleep!
JRST MAIN ; Uh-oh. Must go process input request.
.RDTIME A, ; OK to .HANG - Now get current time,
SUB B,A ; find # of 30'ths to sleep, and drop thru
JUMPLE B,MAIN ; to sleep, unless must execute NOW.
;; OK, go to sleep.
;; No. of 30'ths to sleep is in B, NQMFWR to test in C.
MAIN70: TLZE F,%SCOPN ; Now close stats channel....
JRST [ OUT(SC,CLS) ; If twas open
AOJA C,.+1] ; must AOS C since closing bumps NQMFWR.
SETZM LSRTNS"LSRADR ; Close down LSR1, which doesn't affect NQMFWR.
.CLOSE LSR1C,
CAMLE B,SLPLIM ; Don't sleep longer than maximum allowed.
MOVE B,SLPLIM
LSH B,1 ; Turn 30'ths into 60'ths for .REALT
.SUSET [.SAMASK,,[%PIRLT]] ; Turn off .REALT enable
.SUSET [.SAPIRQC,,[%PIRLT]] ; And any pending ints.
MOVE A,[600000,,B]
.REALT A, ; Start real-time clock interrupt
MOVEI A,WAKEUP ; Set dispatch vector for
MOVEM A,RLTVEC ; waking up...
.SUSET [.SIMASK,,[%PIRLT]] ; and now enable it.
MAIN80: .SUSET [.SADF1,,[%PIRLT]] ; Clear defer bit.
.SUSET [.SPICLR,,[-1]] ; I think something zeros this
CALL SUNAME ; Try to keep name up to date
CAMN C,@NQMFWR ; Until clock or file-write wakes us,
.HANG ; hang!
;; If here, something was written to .MAIL. - check to see if
;; it was a request, and if not go back to sleep.
;; Important that this be doable without opening stats file, since
;; otherwise parallel comsats can activate each other forever!
.SUSET [.SIDF1,,[%PIRLT]] ; Defer alarm clock...
MOVE C,@NQMFWR ; Get new NQMFWR value.
CALL IRQCHK ; Anything there?
JRST MAIN80 ; Nope, resume our peaceful snooze.
WAKEUP: MOVE L,$ARLOC+SCHDAR ; SCHDAR is always MAIN's current LSE.
.SUSET [.SAMASK,,[%PIRLT]] ; Stop realt's, and for PEEK's sake
.SUSET [.SAPIRQC,,[%PIRLT]] ; also remove any pending one.
.SUSET [.SADF1,,[%PIRLT]] ; and clear defer bit in case was set.
MOVSI A,400000
.REALT A, ; Clear and release the REALT clock.
SETZM RLTVEC ; Clear RLT dispatch vector.
SETZM SDFCNT ; Clear times-called-SDFULL.
TLNN F,%SCOPN
CALL SCOPN ; Ensure sure STATS channel is open,
CALL MAPIN ; Ensure latest LSR1 and HOSTS3.
CALL EQVCHK ; Get latest NAMES too.
MOVE U1,EQVQLM ; Checked for NAMES, reset count.
MOVEM U1,EQVQCT
JRST MAIN ; and go back to beg of scheduler loop.
NAPLIM: 30.*60. ; Max # of 30'ths allowed to "nap", without cleanup
SLPLIM: 30.*60.*20. ; Max # of 30'ths scheduler allowed to sleep
GCRQLM: 50. ; Max # of sched rqsts allowed between forced GC checks
LVAR GCRQCT: 0 ; Countdown for above, reset with each GC check
EQVQLM: 7. ; <ax # of sched rqsts before checking for new NAMES.
LVAR EQVQCT: 0
SUBTTL Scheduler routines
IFN 0,[
Scheduler description
Entries on the Schedule List are sublists of 3 items:
A$STIM, A$SRTN, and A$SARG. The first specifies time at which
the request is scheduled, the second specifies routine to
execute at that time, and the third provides an argument for
the routine. Time is specified in 30'ths of a second since
system startup (what .RDTIME returns), and the routine
is specified by address (called via PUSHJ). The argument can
be anything that fits into a word.
Notes:
1) The items must occur on the sublist in the exact
order specified, eg. A$STIM is always first. This
allows better efficiency.
2) The list is always assumed non-empty. To achieve
this, initialization inserts a "sink" request that
claims to desire execution 36 years from now.
];IFN 0
; SCHINI - Initializes Schedule List. Should be called before
; any other schedule operations are done.
SCHINI: PUSHAE P,[A,L]
MOVEI A,SCHDAR
CALL LSEOPN ; Open up a fresh LSE.
MOVE L,$ARLOC+SCHDAR ; Make it current.
MAKELN A,[A$SARG,,0 ? 0]
MAKELN A,[A$SRTN,,[A]
%LTVAL,,[[SCHBUG]]] ; In unlikely event this is ever XCT'd!
MAKELN A,[A$STIM,,[A] ; Set requested time to max. pos #.
%LTVAL,,[[SETZ-1]]]
MAKELN A,[0 ? %LTLST,,[A]] ; Now put all under LLN
MOVEM A,$LLLST(L) ; And make it first thing on schedule list.
POPAE P,[L,A]
RET
SCHBUG: JSR AUTPSY ; Comes here if initial request ever XCT'd!
; SCHDIT - Takes in A, B, and C the A$STIM, A$SRTN, AND A$SARG of
; an item to be put on the schedule list. All 3 are taken
; to be values.
; SCHDI - Similar but uses time c(A) from now, rather than AT c(A).
; Schedule time units are 30'ths of sec, and 0 is time system
; started, just as returned by .RDTIME.
SCHDIT: PUSH P,A
JRST SCHDI2
SCHDI: PUSH P,A
.RDTIME A, ; Get system time in 30'ths
ADD A,(P) ; Get time to schedule at.
SCHDI2: PUSHAE P,[B,C,L]
MOVE L,$ARLOC+SCHDAR ; Set up current LSE to right one.
MAKELN C,[A$SARG,,0 ; Gobble routine argument to start list.
%LTVAL,,[C]]
MAKELN C,[A$SRTN,,[C] ; Push routine onto list
%LTVAL,,[B]]
MAKELN C,[A$STIM,,[C] ; and conclude with A$STIM as FIRST thing on list.
%LTVAL,,[A]]
MAKELN A,[A$S,,0 ? %LTLST,,[C]] ; And put all under a LLN.
CALL SRTINS ; And stick entry into sorted schedule list.
POPAE P,[L,C,B,A]
RET
; SCHGET - Get highest priority schedule entry. Simply gets first
; thing on list, since it's sorted. Returns in A the LP to entry's
; LLN, and its A$STIM value in B.
; SCHGT - Similar but assumes current LSE is already SCHDAR.
SCHGET: PUSH P,L
MOVE L,$ARLOC+SCHDAR ; Make schedule list current LSE.
CALL SCHGT
POP P,L
RET
SCHGT: MOVE A,$LLLST(L) ; Get LP to first LLN.
MOVE B,LISTAR(A)+1 ; Get LP to list for entry.
MOVE B,LISTAR(B)+1 ; Get A$STIM (val of first thing on list).
RET
; SRTINS - Insert entry on sorted list. Auxiliary for SCHDIT, REMIND.
; Given an LLP in A and current LSE, assumes that the LSE's list is
; composed of entries of the format:
; --> entry LLN --> entry LLN --> ...
; \ \
; Value ->... Value ->...
; The LLN pointed to by A is a similar "entry". The list must
; be sorted by the value of the first element on the entry sublists;
; lowest and oldest first. This is accomplished by inserting
; the new item immediately in front of the first greater value -
; those of equal value are skipped over.
SRTINS: PUSHAE P,[B,C,D]
SKIPN B,$LLLST(L) ; Get LP to sorted list.
JRST SRTIN7 ; If nothing there, do special case.
PUSH P,A
MOVE A,LISTAR(A)+1 ; Get LP to LN holding value to sort on
MOVE A,LISTAR(A)+1 ; and get value.
SETZ C, ; Initialize "LP to LLN to insert after"
SRTIN3: MOVE D,LISTAR(B)+1 ; Loop - Get LP to VLN for this entry on list.
CAMGE A,LISTAR(D)+1 ; Compare values.
JRST SRTIN5 ; Aha, this entry is greater - insert!
MOVE C,B ; Not yet. Save LP to this LLN.
HRRZ B,LISTAR(C) ; and get CDR to next.
JUMPN B,SRTIN3 ; Go process unless nothing there.
; Found place to insert new schedule entry. C has LP to previous LLN,
; B has LP to current LLN, which new entry must precede.
SRTIN5: POP P,A ; Restore LP to new entry.
HRRM B,LISTAR(A) ; Make its CDR-> current entry.
JUMPE C,SRTIN7 ; If at beg of list, do special store.
HRRM A,LISTAR(C) ; and make previous entry's CDR-> new entry.
JRST SRTIN9 ; Done!
SRTIN7: HRRZM A,$LLLST(L) ; Come here if entry must be inserted as 1st item.
SRTIN9: POPAE P,[D,C,B]
RET
; SCHREM - Schedule Reminder. Looks at first (earliest) reminder
; on RMLAR and generates a schedule request to send that
; reminder. Does nothing if no reminders exist.
SCHREM: PUSHAE P,[A,B,C,L]
SKIPN $AROPN+RMLAR ; Ensure reminder list exists.
CALL RMLGET
MOVE L,$ARLOC+RMLAR ; Make reminder list current.
HRRZ A,$LLLST(L) ; Get LP to first entry.
JUMPE A,SCHRM9 ; If none, return.
MOVE A,LISTAR(A)+1 ; Get LP to entry's list.
MOVE A,LISTAR(A)+1 ; Get A$STIM for entry - internal time wd.
CALL DATIME"UPTIME ; Convert to system time.
MOVEI B,REMSND ; Execute REMSND rtn then.
SETZ C, ; No argument at moment.
CALL SCHDIT ; Schedule the request.
SCHRM9: POPAE P,[L,C,B,A]
RET
; SCHNTA - Schedule Network, All of. Searches through QML list
; and generates a schedule request for each site found.
; Since only called on initialization, schedules to run immediately.
SCHNTA: PUSHAE P,[A,B,L]
SKIPN $AROPN+QMLAR ; Ensure QML there.
CALL QMLGET
MOVE L,$ARLOC+QMLAR ; Make it current LSE.
; Pluck each site # off QML and generate schreq for it.
MOVE A,$LLLST(L) ; Get LP to first thing on QML list.
MOVEI B,SCHNTX ; Execute this rtn for each site LLN...
SETZ C, ; Arg for SCHNTX - schedule for NOW.
CALL MAPC ; Munch list!
JSR AUTPSY ; Will never happen.
POPAE P,[L,B,A]
RET
; SCHNTX - Given LP in A to a QML LLN, generates schedule request for
; connecting to that site. B should contain time in 30'ths from now
; to execute request. Always skips.
SCHNTX: PUSHAE P,[A,B,C]
MOVE A,LISTAR(A)+1 ; Get LP to site-# LN (first thing on list!)
MOVE C,LISTAR(A)+1 ; Get site # as A$SARG to sched.
MOVE A,B ; Use given time for relative A$STIM
MOVEI B,QUESND ; And specify standard un-queuer rtn.
CALL SCHDI ; Schedule, using A as relative time-from-now.
POPAE P,[C,B,A]
AOS (P)
RET
SUBTTL IRQCHK, IRQMRK, IRQGET - Process Input Requests.
LVAR DIDONE: 0 ;-1 iff we have processed first input request.
; IRQCHK - Checks for existence of a MAIL < input request. If
; one found, skips on return, otherwise no skip. No
; other function...
IRQCHK: .CALL IRQOPN ; At moment, fail for any reason.
RET
AOS (P) ; Win, skip return.
IRQNOP: .CLOSE DKIC, ; Tidily flush channel.
RET
IRQOPN: SETZ ? SIXBIT /OPEN/ ? [.BII,,DKIC] ? SATDEV
IRQFN1 ? IRQFN2 ? SETZ SATDIR
; IRQGET - Looks for a MAIL < input request, and processes it if one found.
; IRQGOT - Similar, but looks for an existing MAILIN > request instead.
; Both skip unless no request existed.
; The rename of MAIL < to MAILIN > is done for two
; reasons: to reduce access conflicts and improve robustness.
; Once renamed to MAILIN, it is COMSAT's property
; and nobody can touch it; this indicates pretty obviously
; what it's working on at the moment. The use of MAIL < processes
; messages in reasonably chronological order, since they are
; written as MAIL >.
; However, > is used for MAILIN because
; this helps ensure that if anything was wrong with previous MAILIN
; (such as causing a crash), it will be processed only
; after all existing MAIL requests are done. Thus, a bug so horrible
; that it doesn't even let COMSAT rename the file to BADREQ will
; still be bypassed to some extent.
; IRQGET - Tries to gobble and process a request.
; Tries hard to open input file, but returns if none found or
; it gives up, without skipping. If read in, will always
; skip on return, regardless of processing results.
; This is the routine that vectors off such requests.
BVAR
IRTLFG: 0 ; Length of file if too long, else zero.
SPRQFG: 0 ; -1 if hacking special request.
IROFIL: BLOCK 4 ; Filblk for original request filename.
EVAR
IRQMIN==10. ;Minimum length of messages we handle (6).
IRQMLN: IRQMIN*PG$SIZ ;This is about 50KB long. (30KB)
IF1,{
ORADIX==10
RADIX 10.
INFORM IRQMIN Input request size = ,\IRQMIN
RADIX ORADIX
};IF1
LVAR IRQRST: 0 ; -1 when this COMSAT reset for a big input request
IRQGET: .CALL IRQOPN ; Open MAIL <
RET
SYSCAL RFNAME,[CIMM DKIC ? CRET IROFIL ? CRET IROFIL+2
CRET IROFIL+3 ? CRET IROFIL+1]
JRST IRQNOP
SYSCAL RENMWO,[CIMM DKIC ? IRIFN1 ? IRIFN2]
JRST IRQNOP
SETZM IRQRST ; Not looping on "too big" on a new request
STAT (,("InReq: "),6F(IROFIL+3),(" "),RABR,(" "))
PUSH P,A
JRST IRQG05 ; Go process the file.
IRQGOT: PUSH P,A
MOVEI A,IRIFN1 ; Point to filblk to try opening.
CALL OPNMFI ; Open, trying hard.
JRST POPAJ ; Couldn't open it? Failure return.
SETOM IRQRST ; Don't allow "too big" oldreq (don't loop)
STAT (,("OldReq: ")) ; Open! Drop thru to do rest.
; Common entry for IRQGET and IRQGOT; DKIC is open for
; file to be processed.
IRQG05: AOS -1(P) ; Now committed to skipping...
PUSHAE P,[B,C,D,L]
SETZM IRTLFG ; Clear flags
SETZM SPRQFG
MOVEI A,IRRFIL ; Point to "real" filename block.
SYSCAL RFNAME,[CIMM DKIC ; Find true filename.
CRET (A) ? CRET 2(A)
CRET 3(A) ? CRET 1(A)]
JSR SYSLOS
CSTAT (,6F(3(A)),("; ")) ; Say which MAILIN it is.
SYSCAL RFDATE,[CIMM DKIC ? CRET C] ; Get creation time of request
JSR SYSLOS
SYSCAL FILLEN,[CIMM DKIC ? CRET B]
JSR SYSLOS ; Now check its length...
SKIPG B ; Zero length file?
JRST [ STAT (,("Note: InReq file of zero length - ignoring."))
JRST IRQG85 ] ; Just flush it quietly.
MOVEI A,MSGAR ; OK, will need LSE for sure...
CALL LSEOPN ; Open a fresh one as the current MSG-LSE.
MOVE L,$ARLOC+MSGAR ; Make it current LSE.
CAIGE B,PG$SIZ*2. ; Always attempt to process messages
JRST IRQG10 ; which are around 10K characters long.
MOVE U1,B ; Let's see if this sucker might fit.
CALL EQVLEN ; EQV file may be read into core soon.
ADD U1,U2 ; Add it in it's approx len.
CALL PSRP ; Is this frob going to fit?
CAIA
JRST IRQG10
MOVEM B,IRTLFG ; Nope, indicate too-long request.
MOVE A,B ; Get # blocks in A, # remaining wds in B.
IDIVI A,PG$SIZ
STAT (,("Note: Inreq file too big! Length="),N9(A),("+"),N9(B))
MOVE B,IRTLFG
CAMGE B,IRQMLN ; Is this a reasonable request?
JRST [ AOSN IRQRST ; Yes, but if we already lost once
JRST IRQG06 ; don't keep trying forever.
SETOM IRQRST
JSR RESET ] ; Try REAL hard for this request!!
;; Input request seems unreasonable...flush it.
IRQG06: SETZM IRQRST ; Reset the reset flag.
HRLZI A,IMSAR ; Specify area to read into.
MOVEI B,PG$SIZ ; Just a page's worth.
CALL TXFINL ; Read in the file, using limit in B.
MOVEI A,IMSAR ; Indicate which area holds input.
CALL SPCFND ; Parse request into current LSE!
NOP ; Ignore any errors.
MOVE A,[ASCNT [Request too large.]]
JRST IRQG49 ; Now go send error receipt.
;; Message will fit, so let's get it into the database.
IRQG10: .RYEAR U1,
TRZ C,DATIME"TM%DST ; Assume Standard Time in effect.
TLNN U1,100000 ; Now if Daylight Savings in effect,
TRO C,DATIME"TM%DST ; set flag.
MAKELN A,[A$TIM,,0 ? %LTVAL,,[C]]
MOVEM A,$LLLST(L) ; Time message file created is first LN!
HRLZI A,IMSAR ; Specify area to read into.
CALL TXFIN ; Read in the file, using limit in B.
MOVEI A,IMSAR ; Indicate which area holds input.
CALL SPCFND ; Parse request from there into current LSE!
JRST IRQG50 ; Error in specs? go handle
FINDA C,[A$SNM,,[$LLLST(L)]] ; Should have found sender name.
CAIA
JRST IRQG25
FINDA C,[A$CSN,,[$LLLST(L)]] ; Else had better be claimed-from.
JRST [ STAT (,("Note: No sender for request!"))
JRST IRQG80 ] ; Else cant report errors!
MOVEI A,A$SNM ; Only claimed-from exists.
DPB A,[$LAFLD,,LISTAR(C)] ; Turn it into A$SNM.
; Now have msg-attrib list in MSG-LSE. Check to ensure that
; it's a message, rather than a special request.
IRQG25: FINDA A,[A$PREQ,,[$LLLST(L)]] ; Does list have special-req attrib?
JRST IRQG30 ; Nope, treat as normal message.
SETOM SPRQFG ; Yes! Set flag, drop through.
; Input request is not a MAIL-style message, but rather a special
; processing request!
CALL SPRXCT ; Execute the request.
JRST [ JUMPN A,IRQG50 ; non-skip signals error, save request.
JRST IRQG80] ; Just rename if no err msg.
JUMPE A,IRQG85 ; Successful return, jump if no message.
JRST IRQG35 ; Message, go process it!
; Guaranteed to have rcpt, txt, sender.
; Not a Special Request; just plain vanilla mail.
IRQG30: FINDA A,[A$RCP,,[$LLLST(L)]] ; Were any rcpts found?
JRST [ MOVE A,[ASCNT [At least one recipient must be specified! None were seen.]]
JRST IRQG49]
FINDA A,[A$MTXT,,[$LLLST(L)]] ; Message text?
JRST [ MOVE A,[ASCNT [Message text must be specified! None was seen.]]
JRST IRQG49]
;; Normal message has been read into MSG-LSE. Now assign it an ID...
IRQG35: CALL IDSET ; Cons up an ID and stick onto list.
;; Now all ready to mail or queue!
FINDA B,[A$TLST,,[$LLLST(L)]]
CAIA ; Is it a reminder?
IFN 0, JRST [CALL REMIND ; Yep! Go queue in RML.
IFN 0, JRST IRQG85] ; and flush disk request.
JRST [MOVE A,[ASCNT [Reminders do not work, please don't try them.]]
JRST IRQG49] ; In fact they blow COMSAT away.
;; Mail it!
PUSH P,MF
SETZ MF, ; Completely normal message.
CALL MAIL ; This does any queueing & updating necessary
NOP
SETOM DIDONE
POP P,MF
JRST IRQG85 ; Through with request, flush from disk.
;; Rename bad input file.
IRQG80: STAT (,("Note: Renaming bad input file to "))
SYSCAL RENAME,[SATDEV ? IRRFN1 ? IRRFN2 ? SATDIR
IREFN1 ? IREFN2]
JRST [ CSTAT (,("<Couldn't???>"))
JRST IRQG90]
MOVEI A,IREFN1
CALL OPNMFI
JRST [ CSTAT (,("<Can't re-open??>"))
JRST IRQG90]
SYSCAL RFNAME,[CIMM DKIC ? CRET A ? CRET A ? CRET B]
JSR SYSLOS
CSTAT (,6F(A),(" "),6F(B))
.CLOSE DKIC,
JRST IRQG90
;; Through with input request, delete it from dsk!
IRQG85: MOVEI A,IRRFIL
SYSCAL DELETE,[(A) ? 2(A) ? 3(A) ? 1(A) ? CERR B]
JRST [ CAIE B,4 ; If lost, make sure it's because
JSR AUTPSY ; file was already gone.
JRST .+1]
JRST IRQG90 ; Return.
IRQG90: UARCLS IMSAR
POPAE P,[L,D,C,B,A]
RET
; Here when request error discovered. Try to return msg to sender
; if any exists, as well as to comsat wizard for inspection.
; A contains SLP to error string.
; Unresolved question: when to report BADREQ file name? How?
; Should file (esp too-large) be moved to sender's dir?
IRQG49: MAKELN A,[0 ? %LTSTR,,[A]] ; Entry pt to use ASCNT err string.
IRQG50: STAT (,("Note: Error during parse of input request."))
MOVE C,L ; Save current LSE
MOVE B,A ; and save err-msg SLP.
MOVEI A,EMSGAR
CALL LSEOPN ; Open error-message LSE
MOVE L,$ARLOC+EMSGAR ; Make it current LSE.
OUT(TMPC,OPEN(UC$SAO),("Error in input request file."),EOL)
OUT(TMPC,SL(B,C)) ; Note SLN is in previous LSE!
OUT(TMPC,EOL,("Message not sent and not queued;"))
SKIPN IRTLFG ; Include failed msg in receipt if possible.
JRST [ OUT(TMPC,("text of bad file follows:"),EOL,("--------"))
OUT(TMPC,EOL,TA(IMSAR))
JRST IRQG56 ]
PUSHAE P,[D,E] ; Failed msg was too big.
MOVE D,IRTLFG ; Get msg length in words.
IMULI D,5 ; Cvt to chars.
IDIVI D,PG$SIZ ; Cvt approximate KB.
OUT(TMPC,SP,D(D),(" Kbytes is far too large for me."),EOL,("Please use the FTP program to transfer huge files around the network."),EOL)
POPAE P,[E,D]
IRQG56: MAKELN B,[A$MTXT,,0 ? %LTSAO,,0] ; Hack up msg-txt LN in B
EXCH L,C ; Restore previous L
CALL SNMRCP ; Cons up a rcpt from sender-name, return in A.
JRST IRQG59 ; Couldn't find sender? sigh, just rename.
EXCH L,C
LNCOPY A,[C ? A] ; Copy it into this LSE.
HRRM B,LISTAR(A) ; Make existing list the CDR of new LN.
MOVEM A,$LLLST(L) ; Store ptr to consed-up list.
STAT (,(" Input-request error, msg sent:"))
PUSH P,MF
MOVEI MF,M%CORG+M%EMSG+M%ERR ; Say comsat-originated, EMSGAR, CC.
CALL MAIL ; Send it!
NOP
POP P,MF
MOVE L,C ; Restore original LSE.
IRQG59: UARCLS EMSGAR
JRST IRQG80 ; Return, renaming file.
; IDSET - Obtains an ID string and puts it on list of current LSE.
; $LLLST(L) will thus contain LP pointing at it.
IDSET: PUSH P,A
CALL IDGET
HRL A,$LLLST(L) ; Get LP to current list
HLRM A,LISTAR(A) ; Make it CDR of the A$ID LN
HRRZM A,$LLLST(L) ; and make A$ID LN the start of list.
POP P,A
RET
; IDGET - Obtains an ID string for message, guaranteed to be unique
; for that particular message. Returns LP to the SLN in A.
; Expects current message LSE in L.
IDGET: PUSH P,B
MOVEI A,IDFN1
CALL OPNMFI ; Open highest ID file.
JSR AUTPSY
SYSCAL RFNAME,[CIMM DKIC ? CRET IDRFIL ; Find real name of ID file.
CRET IDRFIL+2 ? CRET IDRFIL+3 ? CRET IDRFIL+1]
JSR SYSLOS
.CLOSE DKIC,
MOVEI B,IDRFIL ; Rename file B (real) to file A ( > )
SYSCAL RENAME,[(B) ? 2(B) ? 3(B) ? 1(B) ; Existing file
(A) ? 1(A) ; To next higher file
CERR A] ; With provision for non-existence.
JRST [ CAIN A,4 ; Error, File not found?
JRST IDGET ; Yes, repeat process.
JSR AUTPSY] ; Foo.
MOVE A,IDRFIL+3 ; Aha, rename won. Get old real FN2.
; Now have unique ID number for this system. Add site name string
; and a few other things to ensure net-wide uniqueness.
OUT(TMPC,OPEN(UC$SAO))
OUT(TMPC,LABR,6F(A),("."),TIM(YMD))
SKIPE XVERS ; If not normal COMSAT, add more junk.
OUTCAL(TMPC,("*"),6F(JNMPRF),("*"))
FINDA B,[A$NMH,,[$LLLST(L)]] ; If message is not from outside
JRST [ FINDA B,[A$SNM,,[$LLLST(L)]] ; Even hairier ID string
CAIA ; since we may output it.
OUTCAL(TMPC,("."),TLS(B)) ; ID includes sender name.
JRST .+1 ]
OUT(TMPC,C(100),TZ(OWNNAM),RABR)
MAKELN A,[A$ID,,0 ? %LTSAO,,]
CSTAT (,(" ID="),TLS(A),(" "))
POP P,B
RET
LVAR IDRFIL: BLOCK 4
CONSTANTS ; Someplace in the middle, to avoid midas gronkage.
SUBTTL *------------ Parsing -------------*
SUBTTL Parser for input request files (MAIL <'s)
; SPCFND - This is the top level parser for input request files.
; It takes in A the ARPT of an area which contains the text of the
; file in standard IRQ format, and it conses up the results
; onto the front of the current LSE.
; It skips if the parsing worked. At the moment, no error
; message is returned; any errors are sent to the STATS file.
BVAR
ATRLEN: 0 ;holds length of attrib last found
MXATRL==24. ;max. attribute-name length in chars
ATRBUF: BLOCK <MXATRL+4>/5 ;holds attrib name last found
IPLNPT: 0 ;holds ptr (temp) for IPLING
IPLNCH: 0 ;holds count of chars left in ims area (also for IPLING)
IPLAST: 0 ;holds ptr to start of last line parsed
IPLTCH: 0 ;holds char count for ditto
EVAR
.SCALAR OFRMFG ; Crock to help track down obsolete FROM's.
SPCFND: PUSHAE P,[B,C,D,E]
CSTAT (,(" SPECS:"))
MOVE E,A ; Set up index to input area
SETZM OFRMFG ; Crock to help remove other crocks.
SETZM CNFALL ; Zero crocks to decide which confirm option
SETZM CNFERR ; (if any) to use.
SETZM RCPNUM ; Initialize rcp vars
SETZM RRCPS
HRLZI A,440700 ; Set up initial relative ptr into input area
MOVEM A,IPLNPT ; Initialize for IPLING.
HRR A,$ARLOC(E) ; Make abs.
PTRDIF A,$ARWPT(E) ; Get total chars in IMS area
MOVEM A,IPLNCH ; and initialize for IPLING.
SPCF10: CALL IPATTR ; Get an attrib and its argument
JRST [ JUMPG A,SPCF60 ; If err message, handle error.
JRST SPCF20] ; Else simply EOF...
; Found attrib;
; A = # chars in text of argument,
; B = index to attrib in table,
; $ARRPT(E) = BP to start of argument text.
CAIGE B,ATRTAS-ATRTAB ; Remove leading spaces for this item?
JRST SPCF15 ; No, forget it.
JUMPE A,SPCF15 ; If no chars, all done.
SPCF14: ILDB C,$ARRPT(E) ; Get character.
CAIN C,40 ; Is it a space?
SOJG A,SPCF14 ; Yes, count it and loop.
D7BPT $ARRPT(E) ; Either it isn't or we ran out. Put it back.
SPCF15: HRRZ B,ATRTAB(B)
CALL (B) ; Do attribute's routine.
JRST SPCF60 ; Ugh, error in attrib routine.
JUMPE A,SPCF10 ; If rtn returned nothing, that's ok.
LNAPP [A ? $LLLST(L)] ; Add to main list with append,
MOVEM A,$LLLST(L) ; because rtn may have returned a list!
JRST SPCF10 ; Attrib done, get another.
; All done, do a few checks before returning.
SPCF20: SETZ A, ; Stick in appropriate confirm option
SKIPE CNFERR
MOVE A,[LITSTR [FAIL]]
SKIPE CNFALL ; if any is indicated.
MOVE A,[LITSTR [ALL]]
JUMPE A,SPCF21 ; Win return.
MAKELN A,[A$CNF,,[$LLLST(L)]
%LTSTR,,A]
MOVEM A,$LLLST(L)
SPCF21: CALL SPCF66 ;Figure out who it's from
JRST SPCF80 ;Take win return
SPCF60: CAIN A,
MAKELN A,[0 ? %LTSTR,,[LITSTR [Random lossage.]]]
STAT (,("Parsing aborted: "),C(42),TLS(A),C(42)) ; Error in attrib processing.
MOVE B,IPLAST
ADD B,$ARLOC+IMSAR ; Get abs. ptr to bad line.
OUT(TMPC,OPEN(UC$SAO),("Parsing error: "),SL(A),EOL)
OUT(TMPC,("Line stopped at is:"),EOL,S(IPLTCH,B))
MAKELN A,[0 ? %LTSAO,,]
PUSH P,A
CALL SPCF66 ;Try to figure out who it's from, if possible
POP P,A
CAIA
SPCF80: AOS -4(P)
POPAE P,[E,D,C,B]
RET
SPCF66: FINDA C,[A$NMH,,[$LLLST(L)]] ;Network mail?
RET
CALL HPARSE ;Yes, try to parse header
JRST SPCF67 ;Can't, pretend came from "NET-ORIGIN"
FINDA C,[A$SNM,,[$LLLST(L)]]
JSR AUTPSY
FINDA B,[A$SNH,,[$LLLST(L)]]
JSR AUTPSY
CSTAT (,LBRC,("HDR-FROM:"),TLS(C),("@"),HST(LISTAR(B)+1),RBRC)
RET
SPCF67: MAKELN A,[A$SNM,,[$LLLST(L)] ;Cannot parse header, fake sender name.
%LTSTR,,[LITSTR [NET-ORIGIN]]]
MOVEM A,$LLLST(L)
RET
; IPATID - Input attribute identification... uses ATRLEN and
; ATRBUF, returns index in B to matching entry in attribute table.
.SCALAR COMPT1,COMPT2
IPATID: PUSHAE P,[A,C,D]
MOVEI B,NIATTR-1 ;Get index to last entry
IPAID1: HLRZ C,ATRTAB(B) ;Get addr--> cnt,, [ptr]
HLRZ D,(C) ;Get char cnt of this entry
CAMN D,ATRLEN ;If matches length of input attrib
JRST IPAID3 ; found entry of same length!
IPAID2: SOJG B,IPAID1 ;Serial loop thru table
STAT (,("UNKNOWN ATTR FOUND="),RABR,LBRC,TZ(ATRBUF),RBRC)
JRST IPAID9
;; Found same-length entry, now check text equality
IPAID3: MOVE A,[440700,,ATRBUF]
MOVEM A,COMPT1
MOVE A,(C) ;Addr of text string pointed to by our table.
HRLI A,440700
MOVEM A,COMPT2 ;Now have two ptrs set up.
IPAID4: ILDB A,COMPT1
CAIL A,"a ;Convert to uppercase.
CAILE A,"z
CAIA
SUBI A,40
ILDB C,COMPT2 ;Assume strings in ref table all uppercase.
CAIE A,(C) ;Match?
JRST IPAID2 ; Nope.
SOJG D,IPAID4 ;Yes, keep going.
IPAID9: POPAE P,[D,C,A]
;; Return # of attrib. (always returns something, even if nil)
RET
; LIPNUM - Takes SLP in A, tries to parse as oct or dec # & skips with
; value in A if successful.
LIPNUM: PUSH P,B
MOVE B,LISTAR(A)+1 ; Get SPT
ADD B,$LSLOC(L) ; Make abs
HLRZ A,B ; Get cnt in A, and
HRLI B,440700 ; make BP in B.
CALL IPNUM ; Try to parse.
JRST POPBJ ; Foo, lost.
JRST POPBJ1 ; Won!
; IPNUM - takes BP in B, # chars to gobble in A, and
; tries to parse as a number (oct or dec). returns value in A,
; doesn't skip if bad parse. Updates BP.
IPNUM: PUSHAE P,[C,D,E]
SETZB C,D ;zero octal and decimal accumulators
JUMPLE A,IPNU20 ;if nothing to parse, return zero
IPNU05: ILDB E,B ;Now flush leading whitespace.
CAIE E,40
CAIN E,^I
CAIA
JRST [ CAIE E,"- ; Is non-whiespace a minus sign?
TRZA F,%TMP ; No, it's a digit or something.
TROA F,%TMP ; Yes, remember to negate.
JRST IPNU11 ; Either way we're done with whitespace.
JRST IPNU40]
SOJG A,IPNU05
JRST IPNU20 ;Return zero if nothing there but whitespace.
IPNU10: ILDB E,B ;Get ascii digit.
IPNU11: CAIL E,"0 ;Check to be sure it's a digit.
CAILE E,"9
JRST IPNU30 ;Foo! Non-numeric char.
LSH C,3 ; Octal*8
IMULI D,10. ; Decimal*10
ADDI C,-"0(E)
ADDI D,-"0(E)
IPNU40: SOJG A,IPNU10
IPNU20: MOVE A,C ;If no decimal pt, number is octal.
JRST IPNU90 ;Return.
IPNU30: CAIE E,". ;Is non-numeric a decimal pt?
SOJA A,IPNU61 ; No, go flush blanks/tabs
MOVE C,D ;Ah yes, use decimal accumulator.
SOJLE A,IPNU80 ;If this was last char, we're done.
IPNU60: ILDB E,B ;Else flush blanks/tabs.
IPNU61: CAIE E,40
CAIN E,^I
CAIA
JRST IPNU70 ;Foo? Can't do fractions.
SOJG A,IPNU60
IPNU80: MOVE A,C ;Put number into A.
IPNU90: TRNE F,%TMP
MOVN A,A ;Negate if minus-sign seen.
AOS -3(P)
IPNU70: POPAE P,[E,D,C]
RET
; IPNUMA - Variant of IPNUM that uses $ARRPT(E).
IPNUMA: PUSH P,B
MOVE B,$ARRPT(E)
CALL IPNUM
CAIA
AOS -1(P)
MOVEM B,$ARRPT(E) ; Restore updated BP.
POP P,B
RET
; NUMCVT - Takes SP in A to a numerical string, returns value in A.
NUMCVT: PUSH P,B
MOVE A,LISTAR(A)+1 ;get SPT
HRRZ B,A ; Get SA address, and
ADD B,$LSLOC(L) ; make absolute
HRLI B,440700 ; BP.
HLRZ A,A ;cnt
CALL IPNUM
SKIPA
AOS -1(P)
POP P,B
RET
; IPATTR - looks for attribute name and argument, using IPLING for input.
; Win return skips:
; A = # chars in argument
; B = index to attribute in table (0 if couldn't identify)
; $ARRPT(E)= ptr to beg of argument text
; Failure (nonskip):
; A - if zero, means normal EOF
; else SLP to error message.
IPATTR: PUSHAE P,[C,D]
CALL IPLING ;get a line... returns in a= # chars in line
JRST IPAEOF ;eof, none left
; Copy attr name into atrbuf...
MOVEI C,MXATRL ; Max length of attrib name
MOVE D,[440700,,ATRBUF]
IPATR1: ILDB B,$ARRPT(E) ; Get char
CAIE B,":
CAIN B,"; ; Attrib names are ended by colon or semicolon.
JRST IPATR2 ; Aha!
SOJL C,[MOVE A,[ASCNT [Attribute too long.]]
JRST IPAERR]
IDPB B,D ;deposit in ATRBUF
SOJG A,IPATR1
MOVE A,[ASCNT [EOF before attribute finished.]]
JRST IPAERR
; Found an attribute name.
IPATR2: SUBI C,MXATRL ; Find -#chars in name
MOVNM C,ATRLEN ; Store #
PUSH P,B
SETZ B,
IDPB B,D ; Make atrbuf name ASCIZ.
POP P,B
SOJ A, ; Decrement # chars left on line.
CAIE B,"; ; Was terminator a semicolon?
JRST IPATR3 ; No, a colon...rest of line is argument.
; Semicolon arg... rest of line is char cnt, text starts on next line.
CALL IPNUMA ; Parse number
IPATR4: JRST [ MOVE A,[ASCNT [Semicolon arg not numerical or otherwise bad.]]
JRST IPAERR]
JUMPL A,[CAME A,[-1]
JRST IPATR4
MOVE A,IPLNCH ; -1 means gobble rest of world...
JRST .+1]
MOVE B,IPLNCH
SUB B,A ; Subtract that many chars from rest of input
JUMPL B,[MOVE A,[ASCNT [Semicolon arg truncated by EOF.]]
JRST IPAERR] ; Sigh, ain't that many chars to read!
MOVEM B,IPLNCH ; Else store decremented count
MOVE B,IPLNPT ; Find ptr to next line
ADD B,$ARLOC(E) ; Make abs.
MOVEM B,$ARRPT(E) ; Stick in.
PTSKIP A,IPLNPT ; Update ptr to first char after arg.
IPATR3: CALL IPATID ; Identify the attribute in table.
POPAE P,[D,C] ; Win even if not really identified.
AOS (P)
RET
IPAERR: MAKELN A,[0 ? %LTSTR,,[A]] ; Error - return err message.
CAIA
IPAEOF: SETZB A,IPLNCH ; EOF - indicate no more chars
POPAE P,[D,C]
RET
; IPLING - sets $ARRPT(E) to beg of line, returns in A = # chars in line.
; sets IPLNPT and IPLNCH for next call; former is ptr to next line, latter is
; total chars left in input. to initialize, set IPLNPT=beg of input
; (relative), IPLNCH= # chars.
IPLING: PUSHAE P,[C,D]
MOVE C,IPLNPT ;get rel ptr to next start
MOVE D,IPLNCH ;get # chars left from this point onward
ADD C,$ARLOC(E) ;make ptr abs.
MOVEM C,$ARRPT(E) ;set rartab. guaranteed to be on start of line, or end of one.
JUMPLE D,IPLNG7 ;leave here if no more input.
;see if at end of a line; flush blank lines.
IPLNG1: ILDB A,$ARRPT(E) ;search for next line
CAIE A,^M
JRST IPLNG2
SOJLE D,[STAT (,("FOO? NO ^J (EOF) BUT CONTINUING"))
JRST IPLNG7]
IPLNG5: ILDB A,$ARRPT(E)
CAIE A,^J ;check for next char=lf
JRST [STAT (,("FOO? NO ^J AFTER ^M, ASSUMED TO EXIST."))
JRST IPLNG2]
SOJG D,IPLNG1 ;search til find non-nil line.
JRST IPLNG7 ;eof, no more.
;found non-nil line. find length.
IPLNG2: D7BPT $ARRPT(E) ;decrement ptr back to beg of line
MOVE C,$ARRPT(E) ;put in acc.
MOVE B,D ;save count at beg of line
IPLNG3: ILDB A,C
SOJLE D,[STAT (,("FOO? EOF IN MIDDLE OF LINE"))
JRST IPLNG7]
CAIE A,40 ;blank character?
CAIN A,11
JRST IPLNG3
CAIE A,^M
JRST IPLNG4 ;non-blank line, proceed
MOVEM C,$ARRPT(E) ;Turned out to be blank line, skip it
JRST IPLNG5
IPLNG4: ILDB A,C
CAIE A,^M
SOJG D,IPLNG4
JUMPLE D,[STAT (,("FOO? EOF BAD, BUT CONTINUING"))
JRST IPLNG8]
SUB B,D ;found EOL. get # chars in line
SOJLE D,[STAT (,("FOO? EOF BAD, BUT CONTINUING"))
JRST IPLNG8]
ILDB A,C
CAIE A,^J
JRST [ STAT (,("FOO? NO ^J AFTER ^M, ASSUMED TO EXIST"))
D7BPT C
JRST .+2 ]
SOJ D,
SUB C,$ARLOC(E) ;get relative ptr
MOVEM C,IPLNPT ;store back for next call
IPLNG6: MOVEM D,IPLNCH ;ditto for char cnt
MOVE A,B ;return in a= # chars on line
MOVEM A,IPLTCH ;store for error typeout also
MOVE C,$ARRPT(E)
SUB C,$ARLOC(E)
MOVEM C,IPLAST ;ptr to last line processed, and # chars on it.
POPAE P,[D,C]
AOS (P)
RET
;graceful exit when eof found before any material.
IPLNG7: POPAE P,[D,C]
RET
;exit when eof found before crlf, but material exists.
IPLNG8: SETZ D,
JRST IPLNG6
DEFINE INPATR *NAME*,ROUT
[ASCNT [NAME]],,ROUT
TERMIN
; Input attrib dispatch table. Attrib names must be less than
; MXATRL chars!
ATRTAB:
INPATR ||,PARNIL ;default for unknown names. must be 1st entry.
INPATR |SUBJECT|,PARSBJ
INPATR |TEXT|,PARTXT
INPATR |RCPT-LIST-NAME|,PARRLN
INPATR |FAKE-TO|,PARRLN ; New form of RCPT-LIST-NAME.
INPATR |FAKE-FROM|,PARFFM
INPATR |ERRORS-TO|,PARMRP ; Another SMTP hack.
INPATR |USER-HEADER|,PARUHD
ATRTAS: ;;; Below here, leading spaces are NOT ignored.
INPATR |CLAIMED-FROM|,PARCSN ;sender claims to be this instead
INPATR |FROM|,PARSND ;message sent from this uname
INPATR |SENT-BY|,PARSBY ; " " " " "
INPATR |FROM-JOB|,PARFJB ; Program that sent message.
INPATR |TO|,PARRTO
INPATR |AUTHOR|,PARCSN
INPATR |FROM-UNAME|,PARSBY ; New form of sent-by.
INPATR |FROM-XUNAME|,PARNIL ; XUNAME of sending process
INPATR |FROM-PROGRAM|,PARFJB ; Program that sent message.
INPATR |RCPT|,PARRCP
INPATR |NET-MAIL-FROM-HOST|,PARNTS
INPATR |HEADER-FORCE|,PARHDF ;header force
INPATR |REGISTERED|,PARREG ;confirmation options
INPATR |EXPIRES|,PAREXP
INPATR |MSG-FN1|,PARMFN
INPATR |MSG-FN2|,PARMF2
INPATR |ATTRIBUTE|,PARATR ; Arbitrary attribute/value pair.
INPATR |RETURN-PATH|,PARRTP ; SMTP hack.
NIATTR==.-ATRTAB
; PARATR - Implements arbitrary attribute/value input.
; argument must be a list, (ATTRIB ATTRIBVAL), or in ordered pairs.
PARATR: SETOM LRDLEV ; Set reading at top-level.
SETZM LRDLIN ; Initialize LREADR to top line.
CALL LREADR ; Read in the structure.
JRST [ MOVE A,B ; Foo. return error SLN.
RET]
JUMPG A,APOPJ ; Later add err msgs for these too.
JUMPE B,APOPJ
MOVE A,B
CALL EVALA ; "Evaluate" it...
JRST APOPJ ; Blew up.
AOS (P)
RET
; PARSTR - Common subroutine of following rtns. Pops string into
; a SLN with attrib type as specified in B, returns SLP in A.
PARSTR: HRLZ A,A
HRRI A,$ARRPT(E) ;set up ptr to string
MAKELN A,[0 ? %LTBPT,,[A]]
DPB B,[$LAFLD,,LISTAR(A)]
AOS (P) ; Always wins.
RET
; PARNIL - This routine gives unknown attribs a home.
PARNIL: SETZ A,
PJRST POPJ1 ; Make them win for time being
; SUBJECT - parse subject line.
PARSBJ: MOVEI B,A$SBJ
PJRST PARSTR
; TEXT - stores text of message.
PARTXT: CSTAT (,LBRC,("TL="),DEC(A),RBRC)
MOVEI B,A$MTXT
PJRST PARSTR
; Recipient List Name - String to use in header of message as substitute for
; list of recipients.
PARRLN: MOVEI B,A$RLN
CALL PARSTR
JSR AUTPSY
CSTAT (,LBRC,("RLN="),TLS(A),RBRC)
AOS (P)
RET
; Fake From - String to use in header of message as "From" line.
PARFFM: MOVEI B,A$FFM
CALL PARSTR
JSR AUTPSY
CSTAT (,LBRC,("FAKE-FROM="),TLS(A),RBRC)
AOS (P)
RET
;PARHDF - parses "HEADER-FORCE:<string>"
PARHDF: MOVEI B,A$HFRC
CALL PARSTR
JSR AUTPSY
AOS (P)
PJRST SLNUPR ; Force to uppercase and return.
; USER-HEADER - parse user-specified header line.
PARUHD: MOVEI B,A$UHDR
PJRST PARSTR
; PAREXP - parses expiration date for a MSG
PAREXP: CALL PARNUM
JUMPG A,PARNER ; If still chars left, failed.
CAILE B,365.
MOVEI B,365. ;no more than 1 year.
ADDI B,1 ;plus 1 for good measure (consider sending at 11:59 pm)
MAKELN A,[A$XPIR,,0
%LTVAL,,[B]]
AOS (P)
RET
PARNER: MAKELN A,[0 ? %LTSTR,,[LITSTR [Bad parse of number.]]]
RET
PARFER: MAKELN A,[0 ? %LTSTR,,[LITSTR [Bad format.]]]
RET
; PARMFN - parses FN1 or FN2 for a MSG
PARMFN: SKIPA B,[A$MFN1] ; FN1 attrib
PARMF2: MOVEI B,A$MFN2 ; FN2 attrib
HRLZ A,A
HRRI A,$ARRPT(E) ;set up <cnt>,,[<bp>]
CALL CVT6PC ;cvt to 6bit
CAIN A,0
JRST POPJ1 ;bad arg, but will just add default later.
MAKELN A,[0 ? %LTVAL,,[A]]
DPB B,[$LAFLD,,LISTAR(A)] ;deposit attrib type.
AOS (P)
RET
; NET-MAIL-FROM-HOST - finds where net msg came from.
PARNTS: CALL IPNUMA ; Crunch host number
JRST PARNER ; Blah, go return err msg.
CALL RESOLV"STDHST ; Standardize the number.
CSTAT (,LBRC,("NET-MAIL-FROM: "),HST(A),RBRC)
MAKELN A,[A$NMH,,0 ; Form LN to store host # in
%LTVAL,,[A]]
SETOM CNFERR ;confirm errors only
AOS (P)
RET
; PARREG - parses "REGISTERED:<char>"
PARREG: JUMPLE A,[SETZ A, ? JRST POPJ1] ;if nothing, win anyway.
PUSHAE P,[B,C]
PARRG2: ILDB B,$ARRPT(E)
CAIL B,141 ; This uppercasify will suffice.
TRZ B,40
CAIN B,"A
SETOM CNFALL ;set switch indicating "ALL" seen
CAIN B,"F
SETOM CNFERR ;set switch indicating "only errors" seen
SOJG A,PARRG2
SETZ A,
POPAE P,[C,B]
AOS (P)
RET
BVAR
CNFALL: 0 ;when set, means "ALL" seen
CNFERR: 0 ;when set, means "only errors" seen
EVAR
; PARFJB - Parses "FROM-JOB:<jname>"
; Only function at moment is to report in stats.
PARFJB: SETZ B,
CALL PARSTR
JSR AUTPSY
CSTAT (,LBRC,("J:"),TLS(A),RBRC)
LNDEL A,
SETZ A,
PJRST POPJ1
; PARSBY - parses "SENT-BY:<uname>"
PARSBY: MOVEI B,A$SNM
CALL PARSTR
JSR AUTPSY
CSTAT (,LBRC,TLS(A),RBRC)
AOS (P)
RET
; PARMRP, PARRTP - SMTP "Return-Path" values.
; A$SRTPs are real SMTP return paths from foreign hosts.
; A$SMRP is a hack to allow users to specify them for outgoing mail.
PARMRP: SKIPA B,[A$SMRP]
PARRTP: MOVEI B,A$SRTP
CALL PARSTR
JSR AUTPSY
CSTAT (,LBRC,("RTP:"),TLS(A),RBRC)
JRST POPJ1
; PARCSN - parses "CLAIMED-FROM:<name>"
; "Claimed-From" - sender claims to really be this name, rather than
; that which "From" gives.
PARCSN: MOVEI B,A$CSN
CALL PARSTR
JSR AUTPSY
CSTAT (,LBRC,("CLAIMS-TO-BE:"),TLS(A),RBRC)
AOS (P)
RET
; PARSND - parse FROM:<chars>"<sender-name> (OBSOLETE)
PARSND: CAIG A,1 ; Must be at least 1 char (quote mark)
JRST PARFER ; Bad format, complain.
CSTAT (,("<Obsolete FROM>")) ; Crock to help track down.
SETOM OFRMFG ; Indicate obsolete FROM seen.
PUSHAE P,[B,C,D]
MOVE B,A ;put count into b
MOVEM B,PRSNCT ; and save it for quote-less kludge.
SETZ A, ;clear (holds accum. ptr)
SETZM CNFQ
SETZM CNFX
PARSN5: SOJL B,PARSN3 ;If never find quotemark, use whole str as name
ILDB C,$ARRPT(E) ;get char
CAIL C,141 ; This uppercasify will suffice
TRZ C,40
CAIN C,"" ;quote mark=terminates options, begins name
JRST PARSN2 ;exit option loop
CAIE C,"N ; Requesting NET-style header?
CAIN C,"T ; (old way used T)
MAKELN A,[A$HFRC,,[A]
%LTSTR,,[LITSTR [NET]]]
CAIN C,"I ;requesting ITS-style header?
MAKELN A,[A$HFRC,,[A]
%LTSTR,,[LITSTR [ITS]]]
CAIN C,"R ;requesting quote of text (null header)?
MAKELN A,[A$HFRC,,[A]
%LTSTR,,[LITSTR [NULL]]]
CAIN C,"Q
SETOM CNFQ ;indicate Q seen
CAIN C,"X
SETOM CNFX ;indicate X seen
JRST PARSN5
; Fond no quote-mark in arg. Assume whole string intended.
PARSN3: LNDEL A ; Flush any randomness mistakenly done.
SETZM CNFQ
SETZM CNFX
MOVN B,PRSNCT ; get back original count (negative)
PTSKIP B,$ARRPT(E) ; and original bp
MOVMS B ; Now set up psitive cnt & drop thru.
; Cons up SLN for name string.
PARSN2: HRLZ B,B ;put char cnt in lh
HRRI B,$ARRPT(E) ;and addr of ptr in rh
MAKELN A,[A$SNM,,[A] ;store sender-name string
%LTBPT,,[B]] ;note arg is byte-ptr type
CSTAT (,LBRC,TLS(A),RBRC)
MOVE B,CNFQ
ADD B,CNFX
JUMPE B,[SETOM CNFALL ;if neither option seen, confirm all.
JRST PARSN7]
SKIPE CNFX ;if it was X that got set,
SETOM CNFERR ;confirm errors only.
PARSN7: POPAE P,[D,C,B]
AOS (P)
RET
.SCALAR CNFQ,CNFX,PRSNCT
.SCALAR PARFSW
.SCALAR PRCPH ; # of site
;PRCPH is also looked at by EQRCPL due to bad modularity
;PRCPH is also looked at by RCPHST due to bad modularity
; PARRTO - parses "TO" attribute.
; PARRCP - parses "RCPT" attribute.
PARRCP: SETZM PRCPH
CAIA
PARRTO: SETOM PRCPH
JUMPLE A,PARFER ; Make sure something there.
PUSHAE P,[B,C,D]
SETZ C,
SKIPN PRCPH ; TO, or RCPT?
JRST PARR40 ; RCPT attrib.
SETZM PRCPH ; TO. Clear # of site to send to
; See what syntax we're crunching. Can assume that leading
; spaces already flushed.
MOVE B,$ARRPT(E) ; Get scratch copy of BP.
ILDB B,B ; Get 1st char.
CAIL B,"0
CAILE B,"9 ; See if numeric char...
JRST [CAIE B,"( ; If not, reading structured rcpt?
JRST PARR12 ; No, use local host and enter mode-switch loop
SETZ C, ; Yes, indicate no mode-switch LN's, and
JRST PARR40] ; go hack structured rcpt.
; Assume old style - get host #
CALL PARNUM ; Read a number, return # in B.
EXCH A,B
CALL RESOLV"STDHST ; Standardize the host #
EXCH A,B
CAMN B,OWNHST
PARR12: SETZ B, ; Use 0 if local.
MOVEM B,PRCPH
; Enter kludgy mode-switch loop.
SETZ C,
SETZM PARFSW
PARR20: ILDB B,$ARRPT(E)
CAIN B,""
SOJA A,PARR3
CAIN B,"C ;cc?
JRST [MAKELN C,[A$ROPT,,[C]
%LTSTR,,[LITSTR [CC]]]
JRST PARR25]
CAIN B,"+
JRST [ MOVEI B,1
MOVEM B,PARFSW
JRST PARR26]
CAIN B,"-
JRST [ SETOM PARFSW
JRST PARR26]
CAIN B,"S
JRST [ MAKELN C,[A$RMDS,,[C]
%LTVAL,,[PARFSW]]
JRST PARR25]
CAIN B,"M
JRST [ MAKELN C,[A$RMDM,,[C]
%LTVAL,,[PARFSW]]
JRST PARR25]
JRST PARRLS ; Error, report bad format.
PARR25: SETZM PARFSW
PARR26: SOJG A,PARR20
PARR3: JUMPLE A,PARRLS ; Ran out? Also error, bad format.
; C must be set up with LP to any mode-switch LN's read.
PARR40: SETOM LRDLEV ; Read at top level...
SETZM LRDLIN ; Initialize LREADR to top line.
CALL LREADR ; Read in a structure.
JRST [ MOVE A,B ; Ugh?! Return err-msg SLN.
JRST PARR90]
JUMPE B,PARRLS ; Error if no structure was read!
JUMPG A,[CALL PARR50 ; If anything left, look for host
JRST PARRLS
JRST .+1]
MOVE A,B
PUSH P,C
MOVEI C,A$RCP
CALL APRCPT ; Process rcpt structure.
JRST [POP P,C ? JRST PARR90] ; Bleah.
POP P,C
FINDA B,[A$RHST,,[LISTAR(A)+1]] ; Specified a host?
JRST [ SKIPN PRCPH ; No, was any old-style site specified?
JRST .+1
MAKELN B,[A$RHST,,[LISTAR(A)+1]
%LTVAL,,[PRCPH]]
MOVEM B,LISTAR(A)+1
JRST .+1]
LNAPP [LISTAR(A)+1 ? C]
AOS -3(P)
PARR90: POPAE P,[D,C,B]
RET
PARRLS: POPAE P,[D,C,B]
PJRST PARFER ; Return "bad format" err msg.
;Read list in B, have number of characters left in A, presuambly
;after a close parenthesis.
;Normally this is an error, but allow "@HOST" here and drop host
;into PRCPH if so.
PARR50: PUSHAE P,[B,C,D]
MOVE B,$ARRPT(E)
ILDB D,B
CAIE D,"@
JRST PARR59
SUBI A,1 ; A has number of chars in SITE name.
; And B has the BP to the site name.
CALL HMATC ; Call host-name analyze rtn
JRST PARR59 ; Foo? Fail.
MOVEM A,PRCPH ; Win, save site number
AOS -3(P)
PARR59: POPAE P,[D,C,B]
RET
; Maybe someday make IPNUM general enough to
; flush this routine. Could simply test for succ/fail by
; seeing if any chars left, etc.
PARNUM: PUSHAE P,[C,D]
SETZB B,C
PARNM0: JUMPLE A,PARNM9
ILDB D,$ARRPT(E)
CAIL D,"0
CAILE D,"9
JRST PARNM3
LSH B,3
IMULI C,10.
ADDI B,-"0(D)
ADDI C,-"0(D)
SOJA A,PARNM0
PARNM3: CAIN D,". ; Must cvt to decimal?
SKIPA B,C ; use other sum if so, and skip BP restoration.
D7BPT $ARRPT(E)
PARNM9: POPAE P,[D,C]
RET
SUBTTL RCPGOB - Ascii Rcpt-List Parser
; RCPGOB - Takes an ARPT in A, which is taken as an ascii input.
; The input is as in the NAMES > file or inside "@FILE" files.
; An LP to a list of A$RCP LNs is returned in A, and the number
; of errors encountered is returned in B. If there were any errors,
; they were written to the ETXTAR area.
; This calls LREADR to read the ascii, and APRCPT (which calls
; EQRCPL to make sense out of what LREADR returns.
; RCPGBA - The same, except it takes a byte pointer in B and a character count
; in A. (Special entrypoint for RNETAD).
LVAR RPGERR: 0 ; The number of errors so far.
LVAR RPGIBP: 0 ; BP storage for special non-area reading.
RCPGBA: PUSHAE P,[C,D,E]
MOVEM B,RPGIBP
MOVEI E,RPGIBP-$ARRPT
JRST RCPGB0
RCPGOB: PUSHAE P,[C,D,E]
MOVE E,A ; E = ARPT to input area.
MOVE A,$ARRPT(E)
PTRDIF A,$ARWPT(E) ;get # chars in area.
RCPGB0: SETZ D, ; D = LP to collected rctps
MOVEM A,IPLNCH
SETZM LRDLIN ; zero # lines read
SETZM RPGERR ; and # errors.
; Parse lists.
RCPG10: SETOM LRDLEV ; Set input level to top-level.
MOVE A,IPLNCH
CALL LREADR ; Read in a list-structure or atom. A has # chs left.
JRST RCPG50 ; Failed due to some lossage. B has SP to errmsg.
JUMPE B,RCPG90 ; Done when returned LP is 0.
MOVEM A,IPLNCH ; Save current char cntdown.
SETZM PRCPH ; Always local host!
MOVE A,B ; Put LP in A.
MOVEI C,A$RCP ; Attrib type to use in C.
CALL APRCPT ; Crunch as if rcpt spec. (returns LP in A)
JRST RCPG60 ; Foo?
HRRM D,LISTAR(A) ; Point its CDR at current list of rcpts
MOVE D,A ; and now current list points to it!
JRST RCPG10 ;loop
; Error during parse of a list.
RCPG50: MOVEM A,IPLNCH
AOS C,RPGERR ; Increment count of errs.
CAIG C,1 ; If first one,
UAROPN [%ARTCH+%ARTZM,,ETXTAR ? [40]] ; Open small area for error text collection.
OUT(TMPC,OPEN(UC$UAR,ETXTAR),(" --L"),D(LRDLIN),(" Parse error: "),SL(B),EOL)
JRST RCPG10 ; Continue gobbling.
; Error during evaluation of a list
RCPG60: AOS C,RPGERR ; Bump cnt of errors
CAIG C,1 ; If first one,
UAROPN [%ARTCH+%ARTZM,,ETXTAR ? [40]] ; Open very small area for error text collection.
OUT(TMPC,OPEN(UC$UAR,ETXTAR),(" --L"),D(LRDLIN),(" EVAL error: "),SL(A),("
In list: "))
MOVE B,IPLNCH ; Find # chars left
SUB B,LRDBGL ; Subtract # chars left at time list began
SUBI B,1 ; Plus 1 to include left paren
MOVE C,$ARRPT(E) ; to get -<length of list read>. Then get read ptr
PTSKIP B,C ; And adjust BP to point at beg of string,
MOVMS B
OUT(TMPC,S(B,C),EOL) ; Output the bad list text
JRST RCPG10 ; Now continue...
RCPG90: MOVE A,D ; Return LP to collected list in A
MOVE B,RPGERR ; and cnt of errors in B
POPAE P,[E,D,C]
RET
SUBTTL LREADR - LISP-style reader
; LREADR - LISP-style reader. A has char count, E has ARPT to
; area holding input text ($ARRPT is used). S-exp is
; read into a list structure of LLN's and SLN's; a String
; corresponds to an atom, and a LLN IS a list.
; Returns LP in B to resulting structure, but B = 0 if
; input terminated and nothing was read.
; If an error occurs, it will fail to skip, but
; will try to set up recovery so that the next call will
; proceed normally. A failure message will be returned
; in B as a LP to SLN holding message.
BVAR
LRDLEV: 0 ; Holds paren level reading at. -1 = top level.
LRDLIN: 0 ; Holds line # reading at.
LRDBGL: 0 ; Holds current char cnt at point list begins.
EVAR
LREADR: JUMPLE A,LRDRZW
TRZA F,%BRKT ;clear bracket-literal flg and skip into loop.
LRDR05: SOJLE A,LRDRZW ; decrement char cnt and jump if all gone.
ILDB B,$ARRPT(E)
CAIE B,40 ; Ignore spaces
CAIN B,^I ; and tabs.
JRST LRDR05
CAIE B,^J ; Also ignore LF's
CAIN B,", ; and commas.
JRST LRDR05
CAIE B,^L ; And ignore form feeds
CAIN B,^K ; and vertical tabs!
JRST LRDR05
CAIN B,^M ; CR's must be treated specially..
JRST LRDR60 ; off to hack CR.
CAIN B,"; ; Also hack ";" specially, as comment.
JRST LRDR50
CAIN B,"(
SOJA A,LRDR70 ; Beginning of list!
CAIN B,")
SOJA A,LRDR80 ; End of list!
CAIE B,^Q
CAIN B,"/ ; Either ^Q or / quotes next char...
JRST [SOJLE A,LRDRZW
ILDB B,$ARRPT(E)
TRO B,200 ; Quote next char, whatever it is
JRST LRDR30]
; Have something substantial - now process atom! By special
; hack, brackets will enclose an atom, including themselves!
TRZ F,%BRKT+%LRLIT ; Clear flags...
CAIN B,""
JRST [ TRO F,%LRLIT ; If beginning a literal string,
SAOBEG TMPC, ; must start up chan this way
JRST LRDR32] ; to avoid deposit of the ".
CAIE B,"{ ; See whether to set.
CAIN B,"[
TRO F,%BRKT+%LRLIT ; Set flag if bracket-literal.
LRDR30: SAOBEG TMPC, ; Start up SA output channel.
LRDR31: OUT(TMPC,C((B))) ;store char
LRDR32: SOJLE A,LRDR38 ;ran out?
ILDB B,$ARRPT(E) ;get another
TRNN F,%LRLIT ; Collecting literal string?
JRST LRDR35 ; Nope...
TRNE F,%BRKT ; Collecting a bracketed literal?
JRST [ CAIE B,"] ;end of bracketed literal?
CAIN B,"}
CAIA
JRST LRDR31 ;no, gobble til find end.
OUT(TMPC,C((B)))
MOVEI B,40
SOJA A,LRDR38] ;store and break. (pretend broke on 40)
CAIE B,""
JRST LRDR31 ; If not terminator, just gobble.
SOJLE A,LRDR38
ILDB B,$ARRPT(E) ; Get next char to test for another "
CAIE B,"" ; Well, is it?
JRST LRDR37 ; Nope. Break on this.
JRST LRDR31 ; Hmm, so it is! Gobble that & continue.
LRDR35: CAIE B,^Q
CAIN B,"/ ;quoter?
JRST [MOVEI B,^Q ;yes, quoting. replace with ^Q
TRNE F,%BRKT ;in case hacking brackets.
OUTCAL(TMPC,C((B))) ;since if so, store the ^Q.
SOJLE A,LRDR38 ;get quoted char.
ILDB B,$ARRPT(E)
JRST LRDR31] ;store it with no questions
CAIE B,40
CAIN B,^I
JRST LRDR37 ;string break.
CAIE B,")
CAIN B,";
JRST LRDR37 ;also break.
JUMPE B,LRDR37 ;Null must be a break for NETAD fields.
CAIE B,^M
CAIN B,^J
JRST LRDR37 ;and break.
CAIE B,"(
CAIN B,",
JRST LRDR37 ;and break again.
JRST LRDR31 ; Didn't break, get more chars.
; Hit break char, atom finished! Break char in B.
LRDR37: D7BPT $ARRPT(E) ;back up over brk char, so it gets read again
LRDR38: MAKELN B,[0,,0
%LTSAO,,0] ;and make string LN for it
JRST LRDRW ;and win.
; ";" found, flush to CR.
LRDR50: SOJLE A,LRDRZW
ILDB B,$ARRPT(E)
CAIE B,^M ; Skip and drop through when CR found.
JRST LRDR50 ; Until then, flush chars.
; Here when find CR and no atom string yet
LRDR60: AOS LRDLIN ;increment # lines seen
SKIPGE LRDLEV ;are we in toplevel?
JRST LRDR05 ;yes, ignore CR.
LRDR62: SOJLE A,LRDRZW ;no, must check beginning of next line.
ILDB B,$ARRPT(E)
CAIN B,^J
JRST LRDR62 ;check again for LF with new char
CAIE B,40 ;now check first char on new line.
CAIN B,^I
JRST LRDR05 ;space and tab win.
CAIN B,";
JRST LRDR50 ;so does a comment line
CAIN B,^M
JRST LRDR60 ;another CR needs another check.
; If none of above, lose!! Flush up to next line to be safe.
SAOBEG TMPC,
FWRITE TMPC,[[Illegal continuation, Line ],N9,LRDLIN,[ - perhaps missing ")"]]
LRDR64: AOS LRDLIN
LRDR65: SOJLE A,LRDR95 ; Now flush to first line with something on it.
ILDB B,$ARRPT(E)
CAIE B,^M
JRST LRDR65 ; Flush til CR seen.
LRDR66: SOJLE A,LRDR95
ILDB B,$ARRPT(E)
CAIN B,^J ; and if necessary til all LF's gone.
JRST LRDR66
CAIE B,40 ;now check first char on new line.
CAIN B,^I
JRST LRDR65 ;space and tab lose.
CAIN B,"; ;so does a comment line,
JRST LRDR65
CAIN B,^M ; and another CR.
JRST LRDR64
D7BPT $ARRPT(E) ; Aha, flush done. Now point to first char of new line,
FWRITE TMPC,[[
Resuming at line ],N9,LRDLIN]
JRST LRDR95 ; and bomb out gracefully.
; Here when "(" seen, must start collecting list.
LRDR70: PUSHAE P,[C,D]
AOSG LRDLEV ; Increment level we're at.
MOVEM A,LRDBGL ; If reader was at top level, store char cnt at beg.
SETZB C,D
LRDR71: CALL LREADR ;get whatever is next in list
JRST POPDCJ ; Error. Pass it on.
JUMPL B,LRDR75 ;if ")", end list.
JUMPE B,[MOVE B,[ASCNT [EOF and no ")"]]
POPAE P,[D,C]
JRST LRDR90] ;out of chars?? lose, need ")" to terminate.
JUMPE C,[HRRZ C,B ; If no LP to whole list yet, store first as such.
HRRZ D,B
JRST LRDR71]
HRRM B,LISTAR(D) ;store ptr to returned LN in CDR of last in list.
HRRZ D,B ;save ptr to it.
JRST LRDR71 ;get next item.
LRDR75: MOVE B,C ;ended with ")". return ptr to start of.
SOS LRDLEV ; and bump level one up.
POPAE P,[D,C]
MAKELN B,[0 ? %LTLST,,[B]] ;make a List-LN for it.
JRST LRDRW ;and go win.
; Here when ")" seen - end of list.
LRDR80: SKIPL LRDLEV ; at top level?
JRST [ SETO B, ; No, ")" is legal... set B to -1 and return to self!
JRST LRDRW]
SAOBEG TMPC,
FWRITE TMPC,[[Line ],N9,LRDLIN,[: Stray ")" seen at top level!]]
JRST LRDR64 ; Go flush to first line with something on.
; Failure return with error message in B.
LRDR90: SAOBEG TMPC,
FWRITE TMPC,[[Line ],N9,LRDLIN,[: ],TC,B]
LRDR95: MAKELN B,[0 ? %LTSAO,,0]
RET
LRDRZW: SETZ B, ; Return here when A counted out and nothing read yet.
LRDRW: AOS (P)
RET
SUBTTL EQRCPL - Single rcpt evaluation
; EQRCPL - Recipient parsing routine.
; See ASCII EQV file description for syntax it parses.
;
; The idea here is that EQRCPL is a prelude to EVALA. EVALA wants to
; see ((ATTRIB VAL) (ATTRIB VAL) ...). EQRCPL deals with the special
; hacks at the front of such a list, to save lots of typeing, and then
; goes to ERCP40 which calls EVALA on the rest of the list. Returns
; result in A, or else an SLP to an error message in A (like EVALA).
;
; Due to bad modularity this also has to look at PRCPH which if non-zero
; is an implicit host that has not yet been put into the data structure.
EQRCPL: PUSHAE P,[B,C,D,E,EQRGUB]
SETOM EQRGUB' ;No magic for special rcpt type yet
MOVE C,LISTAR(A) ; Make sure given LLN is chopped
HLLZS LISTAR(A) ; off from its CDR.
TLNE C,%LTLST ; Is input a list?
JRST ERCP10 ; Yup, go handle major case.
;; We simply have an atom.
MAKELN D,[0 ? %LTLST,,0] ; Make a recipient list.
MOVEI B,A$RNAM ; Assume it will be a NAME.
DPB B,[$LAFLD,,LISTAR(A)]
CALL RCPHST ; Try parsing as Foo@Site.
SETZ B, ; If fail, just ignore.
SKIPE B ; Got a host?
JRST [ HRLM C,LISTAR(A)+1 ; Yes, zap string to given length.
MAKELN B,[A$RHST,,[LISTAR(D)+1] ? %LTVAL,,[B]]
MOVEM B,LISTAR(D)+1 ; Store rcpt!
JRST .+1]
CALL RCPTYP ; Check for magical names.
JUMPN B,[ HRL B,A ; Save old node,,new node
MOVEM B,EQRGUB ; for later when we know what host.
JRST .+1 ]
LNAPP [LISTAR(D)+1 ? A]
JRST ERCP90
;; We have a list.
ERCP10: MOVE D,A ; Save LP to LLN in D.
HRRZ A,LISTAR(D)+1 ; Get LP to its list for munching.
SETZM LISTAR(D)+1 ; And zap the LLN to start anew.
JUMPE A,[SAOBEG TMPC, ; Make sure something in list
FWRITE TMPC,[[Nil recipient spec!]]
JRST ERCP95]
MOVE C,LISTAR(A) ; Something there. Look at 1st LN
TLNN C,%LTSTR ; must be atomic.
JRST ERCP40 ; Else start hacking attribs already!
; Come here when the first item is atomic - see if it
; matches any known recipient type.
MOVSI C,-NRTYPS
USLNEA A,RTYPTB(C) ; Try matching.
AOBJN C,.-1
JUMPGE C,ERCP14 ; Jump if NOT a type...
CALL SLNUPR ; It's a type! Make it uppercase.
MOVEI B,A$RTYP
DPB B,[$LAFLD,,LISTAR(A)] ; and insert proper attribute.
HRRZ B,LISTAR(A) ; Now get next LN in list.
HLLZS LISTAR(A)
LNAPP [LISTAR(D)+1 ? A]
MOVE A,B
JUMPE A,[SAOBEG TMPC,
FWRITE TMPC,[[Type specified without recipient name!]]
JRST ERCP95]
MOVE B,LISTAR(A)
TLNN B,%LTSTR ; Must be atomic also (recipient name).
JRST ERCP40 ; If not, start attrib collection.
; Come here if the first item is atomic and not a type, or if the first
; item was a type and the second item is atomic.
ERCP14: MOVEI B,A$RNAM ; Item must be interpreted as a NAME,
DPB B,[$LAFLD,,LISTAR(A)] ; but we try parsing it too:
CALL RCPHST ; See if can parse as Foo@Site
SETZ B, ; If fail, just ignore.
JUMPN B,[HRLM C,LISTAR(A)+1 ; Can! Zap string to given length.
MAKELN B,[A$RHST,,[LISTAR(D)+1]
%LTVAL,,[B]]
MOVEM B,LISTAR(D)+1
JRST .+1]
CALL RCPTYP ; And see if name has type-indicator...
JUMPN B,[ HRL B,A ;Save old node,,new node
MOVEM B,EQRGUB ;for later when we know what host
JRST .+1 ]
MOVE B,A ;Assuming this is R-name put SLP in B
HRRZ A,LISTAR(B) ; Save CDR
HLLZS LISTAR(B) ; Zap within LN.
LNAPP [LISTAR(D)+1 ? B]
; Here we have finished up with the first atomic item (or first two
; if the first was a type and the second was atomic.
; Are there more atomic special cases?
ERCP25: JUMPE A,ERCP90 ; End of list is OK now.
MOVE B,LISTAR(A) ; Find type.
TLNN B,%LTSTR ; Atomic?
JRST ERCP40 ; No, list... it's an attribute!
; Yes, more special case stuff. There are three cases:
; 1) It is "@", which means the next thing had better be an
; atom parsable as a site name.
; 2) It starts with an @, so it had better be parsable as a site name.
; 3) It is an atom parseable as a site name.
; If it is just a random atom, it is passed to EVALA.
SLNEA A,[ASCNT [@]]
JRST ERCP30 ; Not "@", continue.
HRRZ B,LISTAR(A) ; Save the CDR
LNDEL A, ; Flush the "@".
SKIPN A,B ; Get LP into A. Is it NIL?
JRST ERCPBA ; Yes, error
MOVE B,LISTAR(A) ; If next LN is non-atomic, error.
TLNN B,%LTSTR
JRST ERCPBA
ERCP30: PUSH P,A ; Save the LP
MOVE B,LISTAR(A)+1 ; Get SPT.
HRLI B,440700 ; set up BP in B.
ADD B,$LSLOC(L) ; Make absolute.
ILDB C,B ; Get first char.
CALL HMATCH ; And go analyze the string.
JRST [ POP P,A ; Foo, lost. Restore LP
CAIE C,"@ ; and see if this was SUPPOSED to win.
JRST ERCP40 ; No, go parse merrily as atomic attribute.
SAOBEG TMPC, ; Ugh! definitely an error.
FWRITE TMPC,[[Bad SITE spec - "],TLS,A,["]]
JRST ERCP95]
POP P,B ; Aha, winning site spec. Restore LP, into B.
MAKELN A,[A$RHST,,0 ; Now create new LN...
%LTVAL,,[A]]
LNAPP [LISTAR(D)+1 ? A]
HRRZ A,LISTAR(B) ; Now get CDR to next thing on input list,
LNDEL B, ; Before flushing the site-string LN.
; Here, ready to evaluate rest of list as attributes... A has LP to,
; D has LLP to a LLN containing sublist collected thus far.
ERCP40: JUMPE A,ERCP90 ; If NIL, all done.
ERCP45: CALL EVALA ; Evaluate rest!
JRST ERCP99 ; Bleah, failed. Err SLP in A.
CAIE A,0
LNAPP [LISTAR(D)+1 ? A]
; Here, recipient-spec processing all done! LP in D to completed list.
ERCP90: SKIPGE EQRGUB ; Did RCPTYP find something interesting?
JRST ERCP94
FINDA A,[A$RHST,,[LISTAR(D)+1]] ;Yes, is host an ITS?
JRST [ SKIPN A,PRCPH ; Implicit host?
JRST ERCP91 ; Local host is always ITS
JRST .+2 ]
MOVE A,LISTAR(A)+1
CALL NHITS
JRST [ HRRZ A,EQRGUB ; Not ITS, discard RCPTYP result
LNDEL A,
JRST ERCP94 ]
ERCP91: HLRZ A,EQRGUB ; ITS, discard original name
LNDEL A,LISTAR(D)+1
HRRZ B,EQRGUB ; and insert new name and attributes
LNAPP [LISTAR(D)+1 ? B]
ERCP94: FINDA A,[A$RNAM,,[LISTAR(D)+1]] ; Make sure name exists!
JRST [ MAKELN A,[0 ? %LTSTR,,[LITSTR [No recipient name was specified? ]]]
JRST ERCP99]
HRRZ A,D
AOSA -5(P) ; Skip on return, and skip over nastiness.
; Returns here when error seen.
ERCP95: MAKELN A,[0 ? %LTSAO,,] ; Put error message into SLN.
ERCP99: POPAE P,[EQRGUB,E,D,C,B] ; Returns here if error message furnished.
RET
ERCPBA: SAOBEG TMPC, ; (ERCP-Bad-Atsign) Shared error routine.
FWRITE TMPC,[["@" not followed by host name!]]
JRST ERCP95
SUBTTL EVALA - Input Attrib "evaluation" processing routines
; EVALA - Attribute "Evaluation". Takes LP in A to a list which it
; crunches and returns result as LP in A. For syntax of
; list, see description of NAMES > format (general version,
; not specifically rcpt type)
EVALA: PUSHAE P,[B,C,D]
SETZ D, ; Initialize LP to accumulated result list.
TLZA A,-1 ; Enter loop, clearing LH.
EVAL40: HRRZ A,LISTAR(A) ; Get next LN.
EVAL41: JUMPE A,EVAL90 ; done?
EVAL42: MOVE B,LISTAR(A) ; get type
TLNN B,%LTSTR
JRST EVAL50 ; List! must be (ATTR AVAL).
; Atomic attribute! Merely a ATTRIB has been seen. It implicitly
; has no arguments.
EVAL45: CALL SLNUPR ; Make uppercase.
CALL IARCOD ; Try to match attrib name with internal code.
JRST [ MOVEI B,A$ATTR ; If failure, just use general-purpose code.
DPB B,[$LAFLD,,LISTAR(A)] ; Set it up.
HRRZ B,LISTAR(A) ; Save CDR
HLLZS LISTAR(A) ; Before zapping it
LNAPP [D ? A] ; For appending to result list.
MOVE A,B ; Now the CDR is start of arg list...
JRST EVAL41] ; Get another!
PUSH P,A ; Save SLP
MOVE C,B
SETZ A,
CALL @ATTRIR(C) ; Hack coded attribute, with null arg.
JRST [ SUB P,[1,,1] ; Error!
SAOBEG TMPC,
FWRITE TMPC,[[Error while processing attribute "],TC,ATTRTB(C),["
],TLS,A]
JRST EVAL95]
JRST EVAL70 ; Won, go add result to list.
;;;;;;;;;;;;;;;;;;;;;;;;;
; List Attribute!
; Comes in form of (ATTRIB VAL VAL VAL ... )
; If attrib name is known, LP to rest of list is passed along to its
; input routine and crunched thereby. If not known, control
; goes to general-purpose hacking (see A$ATTR part)
EVAL50: PUSH P,A ; Save LP to LLN holding list attrib.
HRRZ B,LISTAR(A)+1 ; Get LP to list pointed to.
JUMPE B,[ SETZ A, ; If "( )", ignore this LLN.
JRST EVAL70]
SETZM LISTAR(A)+1 ; Clear the sublist ptr.
MOVE A,B ; A is now only trace to sublist.
MOVE B,LISTAR(A) ; Find type of first thing on sublist.
TLNN B,%LTSTR ; Must be atomic...
JRST [ SUB P,[1,,1]
SAOBEG TMPC,
FWRITE TMPC,[[Attrib name not atomic!]]
JRST EVAL95]
CALL SLNUPR ; Make uppercase
CALL IARCOD ; See if code & input routine exists for this attrib.
JRST EVAL60 ; Doesn't have one, must use A$ATTR construct.
; Attrib has code & input routine! Dispatch to process list
; as desired. A should have LP to rest of list; processing
; should return LP in A to crunched list.
MOVE C,A
HRRZ A,LISTAR(C) ; Get CDR to next LN as argument list for attrib.
LNDEL C, ; And flush the SLP for attrib name.
HRRZ C,B ; Get attrib type into C
CALL @ATTRIR(C) ; Now process it! Should smash list and return LP in A.
JRST [ SUB P,[1,,1] ; Error! reset PDL & restore original LLN ptr.
SAOBEG TMPC,
FWRITE TMPC,[[Error while processing attribute "],TC,ATTRTB(C),["
],TLS,A]
JRST EVAL95]
JRST EVAL70 ; Done, jump to store returned list.
; Attrib has no internal code! Must use A$ATTR general-purpose
; construction. (ugh blech). For each following item in the list,
; 2 LN's are generated:
; A$ATTR --------> A$AVAL
; <name string> <item string>
; All item couplets are merely strung together, with the resulting LP in A
; pointing to the whole slew. The way it works is that a copy of the
; attrib-name SLN is inserted in front of each item LN.
EVAL60: MOVEI B,A$ATTR ; Set up general-purpose code.
DPB B,[$LAFLD,,LISTAR(A)] ; Make it so.
PUSH P,A ; Save LP to start of list (and to attrib name)
HRRZ A,LISTAR(A) ; Get CDR
JUMPE A,EVAL69 ; If no more items, done.
JRST EVAL67 ; Else enter loop.
EVAL65: MOVE B,(P) ; Aha, an item. Copy original attrib-name.
LNCOPY B,[0 ? B] ; (UUO shouldn't ref PDL)
HRRM B,LISTAR(C) ; Plug onto previous LN,
HRRM A,LISTAR(B) ; And stick item onto new attrib-name LN.
EVAL67: MOVEI B,A$AVAL
DPB B,[$LAFLD,,LISTAR(A)] ; Make item general-purpose attrib value.
MOVE C,A ; Save old LP
HRRZ A,LISTAR(C) ; Get CDR to next item (value)
JUMPN A,EVAL65 ; If more items, jump and getum.
EVAL69: POP P,A ; All items gone! Restore LP to whole slew.
; And drop thru to store on accumulated list.
; Finished attrib-list construction, LP in A to result list. Must
; append it to accumulated list, and flush the LLN that held the
; whole attrib specification.
EVAL70: POP P,B ; Restore LP to original LLN.
CAIE A,0 ; Skip if nothing returned.
LNAPP [D ? A]
HRRZ A,LISTAR(B) ; Get CDR of LLN we just hacked,
LNDEL B, ; And flush the LLN. Bye, bye.
JUMPN A,EVAL42 ; Go munch next. (That is, unless nothing there).
; In which case drop through to end.
EVAL90: AOS -3(P)
SKIPA A,D
EVAL95: MAKELN A,[0 ? %LTSAO,,0]
EVAL99: POPAE P,[D,C,B]
RET
; Routines are given LP in A to a (possibly nil) list of arguments,
; with internal attribute code in C. B should be regarded as a
; "free" clobberable AC.
; APNUL - for attribs that take no arguments. Simply flushes
; anything given.
APNUL: JUMPE A,APNILV ; If nothing there, don't bother.
LNDEL A ; Flush whole list, and drop thru.
APNILV: MAKELN A,[0 ? %LTVAL,,0] ; Return nil Value
CAIA
APNILS: MAKELN A,[0 ? %LTSTR,,0] ; Return nil String
DPB C,[$LAFLD,,LISTAR(A)] ; with proper attrib code.
AOS (P)
RET
APOVFL: MAKELN A,[0 ? %LTSTR,,[LITSTR [Too many arguments for attribute!]]]
RET
; APSTR - for attribs that take a single string as argument.
; Sets SPT to 0 if none given.
APSTR: JUMPE A,APNILS ; If nothing, return nil string.
HRRZ B,LISTAR(A) ; Check for only 1 arg...
JUMPN B,APOVFL ; Jump if too many!
MOVE B,C ; Set up for routine ordinarily MAPC'd.
PJRST APSTR5 ; Hack it and return...
; APSTRS - for attribs that lend their code to any number of
; string arguments.
APSTRS: JUMPE A,APNILS
MOVEI B,APSTR5 ; Set up addr of rtn to apply (arg in C = attrib code)
PJRST MAPC ; Apply rtn to given list - sets attrib type to given.
; Routine for MAPC utilization... to slap attrib type onto atoms.
; Given LP in A and argument (attrib code) in B.
APSTR5: HLL A,LISTAR(A) ; Get type.
TLNN A,%LTSTR ; Check - must be atomic.
JRST [ MAKELN A,[0 ? %LTSTR,,[LITSTR [Non-atomic argument for attribute!]]]
RET] ; If not, return immediately as loss.
DPB B,[$LAFLD,,LISTAR(A)] ; Else force to given attrib type.
AOS (P) ; And skip on return.
RET
; APEQVL - Equivalence list. Takes any # of arguments,
; each of which must be a list of recipient attribs.
APEQVL: MOVEI B,EQRCPL ; apply this routine to each CAR
PUSH P,C
MOVEI C,A$RCP ; And insert this attrib type (not A$EQVL!)
CALL MAPCA ; And return resulting list, with attrib type stuck in!
JRST POPCJ
JRST POPCJ1
; APLST - Single List. Takes 1 arg which is a list,
; evaluates, and puts attrib type onto single LLN returned.
APLST: JUMPE A,APNONE
MOVE B,A ; Save LP to LLN
MOVE A,LISTAR(A) ; Get 1st wd
TLNN A,%LTLST ; Make sure a list.
PJRST APNOTL
MOVE A,LISTAR(B)+1 ; Get 2nd wd, ptr to list.
CALL EVALA ; Evaluate it...
RET ; Disaster...
MOVEM A,LISTAR(B)+1 ; Restore back
DPB C,[$LAFLD,,LISTAR(B)] ; Won, make it proper type.
MOVE A,B
AOS (P)
RET
; APQTL - Quote following stuff and make it a list.
APQTL: JUMPE A,APNONE ; Need an argument.
MAKELN A,[0 ? %LTLST,,[A]] ; Make a LLN to rest of list.
DPB C,[$LAFLD,,LISTAR(A)]
PJRST POPJ1
; APRCPT - Recipient. Takes LP to either a string or list of
; rcpt attribs and returns LP to a rcpt-LLN.
APRCPT: JUMPE A,APNONE ; Must have an argument!
HRRZ B,LISTAR(A) ; And must be only one...
JUMPN B,APOVFL ; If non-Z, bah - too many.
CALL EQRCPL ; Parse it...
RET ; Blew it.
DPB C,[$LAFLD,,LISTAR(A)] ; Won. deposit given attrib type.
AOS (P)
RET
; APNUM - for attribs parsing single string as a number (oct or dec)
APNUM: JUMPE A,APNILV ; If no arg, return 0.
HRLM A,(P) ; Save arg on stack.
MOVE B,LISTAR(A)
TLNN B,%LTSTR
JRST APNOTA ; Make sure it's string.
TRNE B,-1
JRST APOVFL ; If more than 1 arg, barf.
CALL LIPNUM ; Try parsing...
JRST APBNUM ; Indicate bad number.
MAKELN A,[0 ? %LTVAL,,[A]]
DPB C,[$LAFLD,,LISTAR(A)]
HLRZ B,(P)
LNDEL B,
AOS (P)
RET
; AP2NUM - Each item is a list of 2 numbers...
AP2NUM: MOVEI B,AP2NM ; Routine to apply...
PJRST MAPCA
AP2NM: MOVE B,LISTAR(A) ; Make sure arg is list
TLNN B,%LTLST
PJRST APNOTL
HRLM A,(P) ; Save LP in LH on stack.
MOVE A,LISTAR(A)+1 ; Get LP to first
MOVE B,LISTAR(A)
TLNN B,%LTSTR
PJRST APNOTA ; Not a string...
CALL LIPNUM ; Parse as #
PJRST APBNUM ; Ugh.
EXCH B,A
HRRZS A
JUMPN A,[CALL LIPNUM ; Parse 2nd too.
PJRST APBNUM
JRST .+1]
MAKELN A,[0 ? %LTVAL,,[A]] ; LN-ify 2nd.
MAKELN A,[0,,[A] ? %LTVAL,,[B]] ; and now 1st.
MAKELN A,[0 ? %LTLST,,[A]] ; And return list.
HLRZ B,(P) ; Recover original LP,
LNDEL B, ; And flush the list of strings.
AOS (P)
RET
APNOTL: MAKELN A,[0 ? %LTSTR,,[LITSTR [Argument not list!]]]
RET
APBNUM: MAKELN A,[0 ? %LTSTR,,[LITSTR [Bad numerical arg!]]]
RET
APNOTA: MAKELN A,[0 ? %LTSTR,,[LITSTR [Argument not atomic!]]]
RET
APNONE: MAKELN A,[0 ? %LTSTR,,[LITSTR [No argument furnished!]]]
RET
; AP6W - for attribs that want a single string arg converted to
; one SIXBIT word value.
AP6W: JUMPE A,APNILV ; Return 0 if no arg
MOVE B,LISTAR(A)
TLNN B,%LTSTR ; Make sure it's string.
JRST APNOTA ; Foo.
TRNE B,-1
JRST APOVFL ; Make sure only 1 arg.
MOVE B,A ; Save LP in B
CALL CVLS6
LNDEL B, ; Flush old SLN
MAKELN A,[0 ? %LTVAL,,[A]]
DPB C,[$LAFLD,,LISTAR(A)]
AOS (P)
RET
; APHST - For attribs (i.e. SITE) that take arg as being
; a site spec. (can have "@" in front)
APHST: JUMPE A,APNONE ; Error if nothing given.
MOVE B,LISTAR(A)
TLNN B,%LTSTR ; It must be an atom.
JRST APNOTA
TRNE B,-1 ; Only one argument is allowed.
JRST APOVFL
MOVE B,A
CALL HMATCH ; Try...
JRST [ MAKELN A,[0 ? %LTSTR,,[LITSTR [Bad SITE spec!]]]
RET]
LNDEL B, ; Win. The host number is in A.
MAKELN A,[0 ? %LTVAL,,[A]]
DPB C,[$LAFLD,,LISTAR(A)]
AOS (P)
RET
; RCPTYP - special subroutine that, given SLP in A to
; a recipient-name, tries to figure out if it should
; be given a special TYPE. If so, returns in B a
; LP to a new R-NAME LN, linked to its proper R-TYPE LN. (ie 2 element list)
; Does NOT mung original SLN!
; Must check for these: 1) BUG-xxx 2) *name 3) [file]
RCPTYP: PUSHAE P,[A,C,D]
MOVE C,LISTAR(A)+1 ; Get SPT
ADD C,$LSLOC(L) ; Make abs.
HLRZ D,C ; Get cnt
HRLI C,440700 ; Make BP
JUMPE D,RCPTY8 ; nil string?
ILDB B,C ; Get 1st char
CAIE B,"* ; *MSG ?
JRST RCPTY3 ; Nope
; Handle *-recipient.
MAKELN B,[A$RTYP,,0 ; Set appropriate type.
%LTSTR,,[LITSTR [*MSG]]]
JRST RCPTY7 ; And go create LN copy of name.
; Check for [<filename>] recipient.
RCPTY3: CAIE B,"[ ; A [file] ?
CAIN B,"{ ; or {file}?
CAIA ; yep
JRST RCPTY5 ; nope
MAKELN B,[A$RTYP,,0 ; Yep, set type to FILE.
%LTSTR,,[LITSTR [FILE]]]
JRST RCPTY7 ; and finalize.
; Check for BUG-X recipient.
RCPTY5: CAIG D,4 ; Enough chars to have a "BUG-X" in there?
JRST RCPTY8 ; Nope, it's a plain regular name after all.
IRPC CH,,[BUG]
CAIE B,"CH
CAIN B,40+"CH ; Add 40 bit for lowercase.
CAIA
JRST RCPTY8
ILDB B,C
TERMIN
CAIE B,"-
JRST RCPTY8
; It's a BUG-X!!
HRLZI D,-4(D) ; Put updated cnt in LH
HRRI D,C ; And addr of BP in RH
;; (Following instructions are in this order to avoid getting
;; screwed by area relocation.)
MAKELN C,[A$RNAM,,0 ; Slurp into name SLN
%LTBPT,,[D]]
MAKELN B,[A$RTYP,,0 ; Now create TYPE for it
%LTSTR,,[LITSTR [BUG]]]
HRRM B,LISTAR(C) ; Cons type onto name SLN
MOVE B,C ; And return LP in B to pair
JRST RCPTY9
RCPTY7: LNCOPY C,[0 ? A] ; Copy name
HRRM B,LISTAR(C) ; Link TYPE to it
SKIPA B,C ; And return LP in B.
RCPTY8: SETZ B,
RCPTY9: POPAE P,[D,C,A]
RET
; RCPHST - Parse Recipient and Host
; A/ SLP to rcpt name
;
; Tries to parse as "Foo@Site".
; If host turns out to be us, checks the recipient name
; for percent-sign (%) delimiter in case "Foo%Bar@ThisSite".
;
; Returns <# chars in name> in C, <site #> in B, and skips.
; If it couldn't be parsed, skips but returns 0 in B.
; Fails to skip if it parsed correctly and there was no such host.
; Garbage in C in latter two cases.
; Also have to strip our own name off the end, can be there sometimes.
;
; Due to bad modularity this also has to look at PRCPH which if non-zero
; is an implicit host that has not yet been put into the data structure.
LVAR RCPHS%: 0 ; Nonzero when parsing "local part".
RCPHST: PUSHAE P,[A,D,E]
SETZM RCPHS% ; Initially try parsing the "domain part".
RCPH10: MOVE B,LISTAR(A)+1
ADD B,$LSLOC(L) ; B has ASCNT to string to parse.
HLRZ C,B
JUMPE C,RCPH85 ; If zero length, can't parse.
SKIPE A,PRCPH ; See if host number already known another way
JRST RCPH80 ; Don't look for % in address at foreign host
MOVE E,C ; Original length
HRLI B,440700
PTSKIP C,B ; B is now a BP to the end of the string.
CALL RCPH40 ; See a host there?
JRST [ SKIPE RCPHS% ; No, so there is only a "local part".
JRST RCPH85 ; If already did it, return 0.
SETOM RCPHS% ; Else reparse entire string as local part.
MOVE A,-2(P) ; Recover SLP and go reparse.
JRST RCPH10 ]
CAMN A,OWNHS2 ; If this our alternate address
MOVE A,OWNHST ; mutate it into our real address.
CAME A,OWNHST ; Is this host us?
JRST RCPH70 ; No, all done.
MOVE E,C ; We are the "domain part" host.
SETOM RCPHS% ; Say we are parsing the "local part" now.
CALL RCPH30
JRST [ MOVE C,E ; Nothing else in local part, host is just us.
MOVE A,OWNHST ; Return our own host.
JRST RCPH80 ]
RCPH70: D7BPT B ; Strip possible blanks before host name
LDB D,B
CAIN D,40
SOJG C,RCPH70
RCPH80: SKIPA B,A ; Return winning site number in B.
RCPH85: SETZ B, ; Else return 0 as site if no site found.
AOS -3(P) ; Skip.
POPAE P,[E,D,A] ; Don't skip if parsed bad host name.
RET
RCPH30: D7BPT B ; Search backwards for @.
RCPH40: LDB D,B
CAIN D,40 ; First skip backwards over spaces.
SOJG C,RCPH30
JUMPLE C,APOPJ ; No non-blanks.
SKIPA E,C ; Strip trailing blanks.
RCPH50: D7BPT B ; Now search for host delimiter.
LDB D,B
CAIN D,"@
JRST RCPH20
SKIPE RCPHS% ; Parsing the local part yet?
CAIE D,"% ; Yes, so can grok "%" here.
CAIA ; Don't parse them to left of the "@".
JRST RCPH20 ; Okay, kludgey relay feature.
SOJG C,RCPH50
RET ; No host present
RCPH20: MOVE A,E
SUBI A,(C) ; A has number of chars in SITE name.
SUBI C,1 ; C has number of chars in NAME.
; And B has the BP to the site name.
RCPH60: ILDB D,B ; Strip leading spaces
CAIN D,40
SOJA A,RCPH60
JUMPLE A,CPOPJ ; Fail if no host name present
D7BPT B
CALL HMATC ; Call host-name analyze rtn
JRST RPCH65 ; Looks like a host name, but not one we know
AOS (P) ; Success return
RET
RPCH65: SKIPN A,DOMGAT ; Send through domain-aware gateway
RET ; Just fail if no gateway
MOVE C,E ; Length includes the host name
JRST POPJ1 ; Success
LVAR DOMGAT: 0 ; Non zero to relay on unknown hostnames
SUBTTL HEADER PARSING
.VECTOR HPTOK(2),SVTOK(2) ;Current and previous token in %LTBPT form
;Parse header embedded in message text, if any, into A$SNM, A$SNH, and A$SBJ
;attributes. This only parses the most common headers, not all headers.
;Skips if it succeeds in finding a sender
HPARSE: PUSHAE P,[A,B,C,D,E] ;First set up $LSRPT(L) and $LSCHL(L)
FINDA B,[A$MTXT,,[$LLLST(L)]] ; to the message text, if any.
JRST HPARS9 ;No text
MOVE B,LISTAR(B)+1
HLRZ A,B ;Length
ADD B,$LSLOC(L)
HRLI B,440700 ;Byte pointer
MOVEM B,$LSRPT(L) ;Put where will be relocated by UABUMP
MOVEM A,$LSCHL(L)
HPARS1: CALL HPTOKN ;Get next token
CAIN B,15 ;Skipping leading blank lines
JUMPE A,HPARS1
CAIN B,": ;Colon => NET or RFC733 header
JRST HPARS4
CAIE B,"@ ;Atsign => ITS header
JRST HPARS9 ;Otherwise not parseable
CALL SVTOKN ;Save sender name
CALL HPHOST ;Host should be next
JRST HPARS9 ;Garbage, cannot parse
MAKELN B,[A$SNM,,[$LLLST(L)] ;Store sender
%LTBPT,,[SVTOK]]
MAKELN A,[A$SNH,,[B] ;Put sender's host on
%LTVAL,,[A]]
MOVEM A,$LLLST(L)
HPARS2: CALL HPTOKN ;Look for subject
CAIN B,15
JRST HPARS8 ;End of line, no subject
JUMPL B,HPARS8 ;End of message, no subject
CAMN A,[SIXBIT/RE/]
CAIE B,":
JRST HPARS2 ;Some other token (part of date or sent-by)
CALL HPARS7 ;Gobble subject
HPARS8: AOS -5(P) ;Success return
HPARS9: POPAE P,[E,D,C,B,A]
RET
;Network and RFC733 header processing
HPARS4: CAMN A,[SIXBIT/SUBJEC/]
JRST [ CALL HPARS7 ;Swallow subject
JRST HPRS5A ] ;Check next line
CAME A,[SIXBIT/FROM/]
JRST HPARS5 ;Some other attribute, ignore it
;; This is very simple-minded. We only recognize token AT host
;; and don't even look for angle brackets and parentheses.
;; It works for all the commonly-sent header types other than
;; screw cases such as people named "At".
CALL HPTOKN ;Expecting user name
HPARS6: CAIE B,15 ;If end of line reached, die
CAIGE B,0 ;Or end of message
JRST HPRS5B
CALL SVTOKN ;Save putative sender name
CALL HPSKSP ;Skip spaces, find real delimiter
CAIN B,"@ ;Some hosts may send @ rather than AT
JRST HPRS6B
CALL HPTOKN ;Look for "at" as next word
CAME A,[SIXBIT/AT/]
JRST HPARS6 ;Well, maybe this was a sender name
HPRS6B: CALL HPHOST ;Is next token a valid host name?
JRST HPARS6 ;No, perhaps it is a sender name then
CAMN A,OWNHST ;Is the host me?
CALL HPRS6C ;If so, recognize kludgey %
MAKELN C,[A$SNM,,[$LLLST(L)] ;Store sender
%LTBPT,,[SVTOK]]
MAKELN A,[A$SNH,,[C] ;Put sender's host on
%LTVAL,,[A]]
MOVEM A,$LLLST(L) ;Ho, ho! Got sender, keep looking for subject
CAIN B,15
JRST HPRS5A
HPARS5: SOSGE $LSCHL(L) ;Swallow remainder of line
JRST HPRS5B ;End of message
ILDB A,$LSRPT(L)
CAIE A,15
JRST HPARS5
HPRS5A: CALL HPTOKN ;Get first token on next line
CAIN B,":
JRST HPARS4 ;Go analyze it if it is an attribute
HPRS5B: FINDA A,[A$SNH,,[$LLLST(L)]] ;Done
JRST HPARS9 ;Failed
JRST HPARS8 ;Succeeded
; Address in header turned out to be on my host. Probably it is really
; some other host indirecting through me with the goddamn kludgey percent.
; SVTOK has the sender, A has the host (equal to OWNHST), B has delimiter
; This only allows a single level of %. Tell it to the marines!
HPRS6C: PUSH P,B
HLRZ A,SVTOK ;Number of characters
MOVE B,SVTOK+1 ;Byte pointer
ILDB C,B ;Search for %
CAIE C,"%
SOJG A,.-2
SOJLE A,HPRS6E ;Jump if not found
HLRZ C,SVTOK ;Compute number of characters before %
SUBI C,1(A)
CALL HMATC ;Rest of string a host name?
HPRS6E: SKIPA A,OWNHST ;Nope, host is still me
HRLM C,SVTOK ;Yes, shorten token
POP P,B
RET
;Remainder of current line is subject
HPARS7: MOVE B,$LSRPT(L) ;Byte pointer to start of subject
MOVEI C,0 ;Character count
HPRS7A: SOSGE $LSCHL(L)
JRST HPRS7B
ILDB A,$LSRPT(L)
CAIE A,15
AOJA C,HPRS7A
HPRS7B: MOVSS C
HRRI C,B
MAKELN A,[A$SBJ,,[$LLLST(L)] ? %LTBPT,,[C]]
MOVEM A,$LLLST(L)
RET
;Save the current token into SVTOK
SVTOKN: PUSH P,A
MOVE A,HPTOK
HRRI A,SVTOK+1
MOVEM A,SVTOK
MOVE A,HPTOK+1
MOVEM A,SVTOK+1
JRST POPAJ
;Parse next token, if it is a host skip and return host number in A.
;Return delimiter in B.
HPHOST: CALL HPTOKN
PUSH P,B ;Delimiter
HLRZ A,HPTOK ;Number of characters
MOVE B,HPTOK+1 ;Byte pointer
CALL HMATC ;Is it a host name?
CAIA ;No
AOS -1(P) ;Yes, skip
POP P,B ;Delimiter
RET
;Parse next token, skipping spaces and line feeds. Return sixbit in A,
;delimiter character in B (negative at end of text), and %LTBPT pointer
;(which becomes invalid if you cons) in HPTOK. Valid characters in tokens
;are everything except space, colon, atsign, angle bracket, parenthesis,
;and controls (especially carriage return).
;Doesn't know about quoted strings, for instance.
HPTOKN: PUSHAE P,[C,D]
MOVEI A,0 ;Blank sixbit
MOVE C,[440600,,A]
SETZM HPTOK ;No characters
HPTOK1: SOSGE B,$LSCHL(L) ;First skip spaces and line feeds
JRST HPTOK9 ;End of message, no token
MOVE B,$LSRPT(L) ;In case token starts here
MOVEM B,HPTOK+1
ILDB B,$LSRPT(L) ;Next character
CAIE B,40
CAIN B,12
JRST HPTOK1
HPTOK2: CALL HPDELP
JRST HPTOK9 ;Delimiter ends token
AOS HPTOK ;Okay, this is part of token
CAIL B,140 ;This loop accumulates a token
SUBI B,40 ;Upper case
SUBI B,40 ;Sixbit
TLNE C,770000
IDPB B,C
SOSGE B,$LSCHL(L)
JRST HPTOK9 ;End of message, end of token
ILDB B,$LSRPT(L) ;Next character
JRST HPTOK2
HPTOK9: HRLZ C,HPTOK ;Length of token
HRRI C,HPTOK+1
MOVEM C,HPTOK
POPAE P,[D,C]
RET
;Skip if character in B is not a delimiter
HPDELP: CAIE B,"<
CAIN B,">
RET
CAIE B,"(
CAIN B,")
RET
CAIE B,"@
CAIN B,":
RET
CAILE B,40
AOS (P) ;Not a delimiter
RET
;Delimiter is in B. If it's space, find real delimiter.
;For hosts that send space-atsign-space.
HPSKSP: CAIN B,40 ;Original delimiter a space?
SOSGE $LSCHL(L) ;More characters?
RET ;No, stop
ILDB B,$LSRPT(L) ;Next character
CAIN B,40
JRST HPSKSP ;Space, skip it
CALL HPDELP ;Other delimiter?
RET ;Yes, return him
AOS $LSCHL(L) ;Delimiter really space, back up
MOVSI B,070000
ADDM B,$LSRPT(L)
MOVEI B,40
RET
;Skip if this is net-mail-from-host with no discernible sender
;Returns host number sent from in A if it skips
SKPNMH: FINDA A,[A$SNH,,[$LLLST(L)]]
FINDA A,[A$NMH,,[$LLLST(L)]]
RET ;Had parsed header or is local mail
MOVE A,LISTAR(A)+1 ;Get host number
JRST POPJ1
SUBTTL MAPCAR and friends
; MAPCAR - Takes LP in A to a list, address in B of a routine to
; apply to each CAR in succession, and returns in A an LP to
; list of the results. Skips on succesful completion and
; returns immediately w/o skip if an apply fails.
; MAPCA - Like MAPCAR but C should contain an attrib code, which each
; LN of the returned list is smashed to.
; MAPC - Like above, but returns nothing; merely executes given
; routine for each thing on list. C should contain an "argument"
; which is given to the called routine in B.
; Routines called are given LP in A to a single LN of
; the list, and must return LP in A to resulting LN, and skip
; on successful return. B and C can be clobbered, but any
; other ACs should be saved. Routines for MAPC need not return anything.
MAPCAR: TRZA F,%MAPC ; Set flag indicating which variety of MAPCAR.
MAPCA: TRO F,%MAPC
PUSHAE P,[B,C,D,E] ; B and C args saved on stack.
HRRZS A ; LP to input list given in D.
JUMPE A,MAPCA8 ; If nothing in input, done - return nil ptr.
HRRZ D,LISTAR(A) ; Get CDR in prep for next pass.
HLLZS LISTAR(A) ; Isolate arg.
CALL @-3(P) ; Do first one.
JRST MAPCA7 ; Error! Pass it on.
MOVE E,A
PUSH P,E ; Save as ptr to first LN of result list.
JRST MAPCA4 ; Jump into loop.
MAPCA2: HRRZ D,LISTAR(D) ; Get CDR in prep for next loop.
HLLZS LISTAR(A) ; Isolate argument.
CALL @-4(P) ; Execute routine.
JRST MAPCA9 ; If error, pass on.
JUMPE A,MAPCA9 ; Make sure something returned.
HRRM A,LISTAR(E) ; Link result list to new LN.
HRRZ E,A ; and make new LN last one.
MAPCA4: TRNE F,%MAPC ; Should the LN's attrib-type get clobbered?
JRST [ MOVE B,-3(P) ; Yes, get attrib
DPB B,[$LAFLD,,LISTAR(E)] ; And set it.
JRST .+1]
MOVE A,D ; Now get next LN
JUMPN A,MAPCA2 ; And process if it's there,
POP P,A ; Else return LP to result and fall thru to end.
MAPCA8: AOSA -4(P)
MAPCA9: SUB P,[1,,1] ; If error, flush LP to result from stack.
MAPCA7: POPAE P,[E,D,C,B]
RET
MAPC: PUSHAE P,[A,B,C,D]
HRRZ D,A ; LP to input list kept in D.
JUMPE D,MAPC8 ; If nothing in input, done.
MAPC2: HRRZ D,LISTAR(D) ; Get CDR in preparation for next loop.
MOVE B,-1(P) ; Set up arg to routine.
CALL @-2(P) ; Execute routine...
JRST MAPC9 ; If error, pass it on.
SKIPE A,D ; Now get LP to next LN, skip if none.
JRST MAPC2 ; crunch it.
MAPC8: AOS -4(P)
MAPC9: POPAE P,[D,C,B,A]
RET
SUBTTL RLPAS, HMATCH,and RPARNM parsing routines.
IFN 0,[
; These routines are not used now because it turned out possible to use
; EVALA and EQRCPL. But the code should be kept around anyway...
; RLPARS - takes a BP in RLPARG, and # of chars in A, and
; parses it as rcpt list in usual form name@site,name1@site1...
; Returns in A the LN ptr to resulting rcpt list, and skips.
; (no skip if parse error)
; slightly odd in that <item> without a @<site> is interpreted
; as <site> and not <name>@<local site> as QMAIL would do.
; B contains LN ptr to name string when called from RCPP80.
RLPCNT: 0 ;char cnt for the ptr
RLPARG: 0 ;contains addr of ptr; indirected thru this.
RLPARS: PUSHAE P,[B,C,D]
SETZ D, ;D maintains ptr to whole list
RLPAR1: CALL RPARNM ;read name up to "@" or "," or EOF
JRST RLPAR9 ;error?
JUMPE A,RLPAR8 ;eof?
MOVE C,A ;save ptr to name LN
CAIN B,"@ ;terminated by @?
JRST RLPAR2 ;yes, go munch rest as site name
MOVE C,-2(P) ;no rcpt name specified, use that given in B
LNCOPY C,[0 ? C] ; (can't make ref to PDL)
JRST RLPAR3 ;and skip further gobbling of text
RLPAR2: CALL RCOM ;read up to comma or EOF into a SLN (LP in A)
JRST RLPAR5 ;nothing there, assume local site.
RLPAR3: MOVE B,A ;save LP to sitename LN
CALL HMATCH ;try to match it
JRST RLPAR9 ;lost, couldn't parse as site name/number
LNDEL B, ; A site! free up sitename SLN.
CAMN A,OWNHST ; If site is local, jump
JRST RLPAR5 ; and don't form
MAKELN A,[A$RHST,,0 ; a site-# LN.
%LTVAL,,[A]]
CAIA ; Now skip into rest of stuff
RLPAR5: SETZ A, ;clear LP to site-# LN if no site specified
HRRM A,LISTAR(C) ;cons site-# with rcpt name
JUMPE A,[EXCH A,C ;if local, must force name to uppercase.
CALL SLNUPR ;smash string.
EXCH A,C
JRST .+1]
MAKELN D,[A$RCP,,[D]
%LTLST,,[C]] ;and put under a LLN, and cons onto whole list.
JRST RLPAR1 ;now go get another in list if any.
RLPAR8: MOVE A,D ;return ptr to whole list
AOS -3(P)
RLPAR9: POPAE P,[D,C,B]
RET
; RPARNM - takes and returns char cnt in RLPCNT, BP in RLPARG, reads up
; to "@" or "," or eof into a SLN. Flushes any spaces before
; or after text. Space within text, or odd chars, is error signaled by non-skip.
; win return skips with ptr in A to the LN, break char (,@^c) in B.
; RCOM - as above, but doesn't break on @.
.SCALAR RPARNT,RPARSW
RCOM: SETOM RPARSW ;switch to not break on @
JRST .+2
RPARNM: SETZM RPARSW ;do break on @.
PUSHAE P,[C,D]
SKIPG B,RLPCNT
JRST RPARN4 ;null string
RPARN1: ILDB C,RLPARG
CAIE C,40 ;flush spaces
CAIN C,^I ;or tabs
SKIPA
JRST RPARN2 ;not space or tab
SOJG B,RPARN1
RPARN4: SETZM RLPCNT
SETZ A,
JRST RPARN7 ;null string
RPARN2: D7BPT RLPARG
MOVE D,RLPARG
MOVEM D,RPARNT ;save--ptr to start.
MOVE D,B ;save cnt
RPARN3: ILDB C,RLPARG
CAIN C,", ; break if separator
JRST [ SUBI D,(B)
SOJA B,RPARN5] ;reached terminating char
SKIPE RPARSW ;skip if checking @ too
JRST .+3 ;nope
CAIN C,"@
JRST [ SUBI D,(B)
SOJA B,RPARN5]
SOJG B,RPARN3
IBP RLPARG ;so d7bpt will win with both types of endings
RPARN5: MOVE A,RLPARG ;get for backwards look
MOVEM B,RLPCNT ;store back cnt
MOVE B,C ;save char broken on
RPARN6: D7BPT A ;decrement ptr
LDB C,A ;get char pted to
CAIE C,40
CAIN C,^I
SKIPA
JRST RPARN8 ;done, finalize.
SOJG D,RPARN6 ;else loop til all terminating blanks flushed
JRST RPARN9 ;null string, lose
RPARN8: HRLZ C,D ;put cnt in lh
HRRI C,RPARNT ;addr of ptr in rh
MAKELN A,[A$RNAM,,0
%LTBPT,,[C]]
RPARN7: AOS -2(P)
RPARN9: POPAE P,[D,C]
RET
]; end of ifn 0,
; HMATCH - takes ptr to SLN in A, tries to match up as a network
; host name or number. Skips and returns site # in A if successful,
; else doesn't skip. Is OK to have @ preceding name/number.
; HMATC same but takes cnt in A, BP in B directly. and skips @ test.
HMATC: PUSHAE P,[B,C]
JRST HMATC0
HMATCH: PUSHAE P,[B,C]
MOVE B,LISTAR(A)+1 ;get SPT
HLRZ A,B ; Put cnt in A
ADD B,$LSLOC(L) ; Make addr absolute,
HRLI B,440700 ; set up BP in B,
ILDB C,B ; Test first char
CAIN C,"@
SOSA A ; If it's there, decrement cnt.
HRLI B,440700 ; If not, restore BP.
HMATC0: JUMPLE A,HMATC9 ; Null host name is a loser (:BUG @)
PUSHAE P,[A,B] ; Save in case IPNUM fails.
CALL IPNUM
JRST HMATC5 ; Failed.
CALL RESOLV"STDHST ; Won, standardize host #.
SUB P,[2,,2] ; If numerical parse won, flush stack & return.
JRST HMATC8
HMATC5: POPAE P,[B,A]
CALL HANLYZ ; and go analyze.
CAIA ; Foo?
HMATC8: AOS -2(P) ; Hurray!
HMATC9: POPAE P,[C,B]
RET
SUBTTL *--------- Mailing -----------*
SUBTTL Special-Request processing routines
; All stuff on this page is preliminary!!!
COMMENT |
*** NEW SCHEME ***
(SPECIAL-PROC CMD ARG1 ARG2 ARG3 ... )
A$PREQ is LLN to a list,
1st thing on list is a SLN specifying command.
Succeeding things on list are arguments.
Arguments to special-processing routines are furnished by
A$PARG. This attribute may be either a string or a list containing
several arguments, as returned by EVALA - thus a fully parsed
A$RCP may be in this argument list. Note that if it is desired to
have arguments that correspond to no existing attribute, these
must be distinguished by position in the list and QUOTE used to prevent
"evaluation".
For example:
((SPECIAL-PROC DELETE) (SPECIAL-ARG FOO))
; A$PARG is the string "FOO".
((SPECIAL-PROC DELETE)
(SPECIAL-ARG ((MESSAGE-ID 123456)
(QUOTE (THIS IS QUOTED LIST)) )) )
; A$PARG is a list containing one A$ID string and one A$QUOT
; list which is the 2nd thing specified.
|
; SPCPRC - Special-Processing execution vector.
; A - LP to A$PREQ type list
; Returns like routines it invokes.
SPRXCT: PUSHAE P,[B,C]
MOVE B,LISTAR(A) ; Get 1st word
TLNN B,%LTLST ; Confirm that it's a list!
JSR AUTPSY ; No, Yeech!
MOVE A,LISTAR(A)+1 ; Okay, get list it points to.
STAT (,("Note: Special req:"),C(42),TLS(A),C(42))
MOVSI B,-NSPRQS
SPRXC1: HLRZ C,SPRQTB(B) ; Get addr to a spec-req name
USLNEA A,(C) ; Uppercase compare
AOBJN B,SPRXC1
JUMPGE B,[STAT (,("Note: Above request is UNKNOWN; assumed bad."))
MAKELN A,[0 ? %LTSTR,,[LITSTR [Unknown special request.]]]
JRST SPRXC9] ; Error if can't identify.
HRRZ B,SPRQTB(B) ; Aha, found it! Get routine addr
HRRZ A,LISTAR(A) ; and set up ptr to arg list.
CALL (B) ; and call it!
JRST SPRXC9 ; Lossage, return whatever A contains.
JUMPE A,SPRXC8 ; Skip text mung if nothing to use.
FINDA B,[A$MTXT,,[$LLLST(L)]] ; Any existing msg text?
CAIA
LNDEL B,$LLLST(L) ; Delete existing msg text.
MOVEI B,A$MTXT
DPB B,[$LAFLD,,LISTAR(A)] ; Use request results as new msg text.
MOVE B,$LLLST(L)
HRRM B,LISTAR(A) ; Cons it onto list.
MOVEM A,$LLLST(L)
FINDA A,[A$SBJ,,[$LLLST(L)]] ; Has any subject?
JRST [ MAKELN A,[A$SBJ,,[$LLLST(L)] ; If not, make one.
%LTSTR,,[LITSTR [Request results]]]
MOVEM A,$LLLST(L)
JRST .+1]
FINDA A,[A$RCP,,[$LLLST(L)]] ; Has any rcpts?
JRST [ CALL SNMRCP ; Nope, make rcpt out of sender name.
JSR AUTPSY ; Should have checked previously!
MOVE B,$LLLST(L) ; Cons it onto msg list.
HRRM B,LISTAR(A)
MOVEM A,$LLLST(L)
JRST .+1]
SPRXC8: AOS -2(P) ; Win return, A non-zero if should send a msg.
SPRXC9: POPAE P,[C,B]
RET
; Dispatch table identifying known special-processing routines
; and their addresses.
SPRQTB: [ASCNT [TEST]],,SPRTST
[ASCNT [SHOW-Q]],,SPRSHQ
[ASCNT [SHOW-MSG]],,SPRSHM
[ASCNT [KILL-MSG]],,SPRKMG
NSPRQS==.-SPRQTB
; Special-processing routines. All are given a single argument in A which is
; a LP to the 1st argument in a list of arguments,
; or zero if none exists. All must skip if "successful";
; a failure return implies that an error message is waiting to be returned to
; originator of request. (actually, this may turn out not to be right thing)
; Possible outcomes:
; No skip:
; Return error msg to sender (A if non-zero has LP to text)
; Skip:
; If A zero, that's all.
; Else return results to recipients
; (include sender if no rcpts specified?)
SPRTST: MAKELN A,[0 ? %LTSTR,,[LITSTR [This is result of A$PREQ "TEST".]]]
PJRST POPJ1
; "Show Queue" - Currently ignores arguments.
SPRSHQ: MAKELN A,[0 ? %LTSAO,,[[OUTCAL(,CALL(PRTQML))]]]
PJRST POPJ1 ; Howja like them super instructions???!!
; "Show Message" - takes message-ID argument.
SPRSHM: JUMPLE A,POPJ1 ; If no arg, just do nothing.
OUT(,CH(TMPC),OPEN(UC$SAO))
UARPUSH MSGAR
CALL MSGGET
JRST [ OUT(,("Can't retrieve message"))
JRST SPSHM7]
; Output msg stuff here.
PUSH P,L
MOVE L,$ARLOC+MSGAR ;Use new LSE for FINDAs.
SPRKM1: FINDA A,[A$MHDR,,[$LLLST(L)]]
JRST [ OUT(,("No message header for message!!"))
JRST SPSHM7]
OUT(,SL(A))
FINDA A,[A$MTXT,,[$LLLST(L)]]
JRST [ OUT(,("No text for message!!"))
JRST SPSHM7]
OUT(,SL(A))
POP P,L
AOS (P)
SPSHM7: UARPOP MSGAR
MAKELN A,[0 ? %LTSAO,,]
RET
;Kill Message
SPRKMG: JUMPLE A,POPJ1 ; If no arg, just do nothing.
OUT(,CH(TMPC),OPEN(UC$SAO))
UARPUSH MSGAR
CALL MSGGET
JRST [ OUT(,("Can't retrieve message"))
JRST SPSHM7]
PUSH P,L
MOVE L,$ARLOC+MSGAR
;Change A$RCP to A$RCPF
MOVE A,$LLLST(L)
MOVEI B,SPRKM2
CALL MAPC
JSR AUTPSY
MOVEI A,MF%SNT+MF%QUD+MF%FAI+MF%KIL
CALL MSGFIN ;Send failure notification
CALL MSGDEL ;Get rid of message
CALL MGQDEL ;Remove from queue
EXCH L,(P)
OUT(,CH(TMPC),OPEN(UC$SAO)) ; when it sees there are no rcpts left
OUT(,("Message deleted:"),CRLF())
EXCH L,(P)
JRST SPRKM1 ;Return copy of message
SPRKM2: LDB B,[$LAFLD,,LISTAR(A)] ; Get attrib
CAIE B,A$RCP
JRST POPJ1
MOVEI B,A$RCPF
DPB B,[$LAFLD,,LISTAR(A)]
TLO F,%MSGMD
PJRST POPJ1
;Delete current message from all queue entries it may be on
MGQDEL: PUSHAE P,[A,B,C,D,E,L]
SKIPN $AROPN+QMLAR ; Check, and
CALL QMLGET ; make sure that QML is loaded.
MOVE L,$ARLOC+MSGAR ; Set to MSG-LSE
FINDA A,[A$ID,,[$LLLST(L)]] ; Find MSG-ID
JSR AUTPSY
MOVE E,LISTAR(A)+1 ; Get SPT (add $LSLOC to make ASCNT ptr)
MOVE L,$ARLOC+QMLAR ; Select QML, search all site lists
HRRZ D,$LLLST(L) ; Get LP to first LLN
JUMPE D,MGQDL9 ; List exhausted
MGQDL1: MOVE C,LISTAR(D)+1 ; get LP to site's list.
MGQDL2: HRRZ C,LISTAR(C) ; List of message IDs
JUMPE C,MGQDL4 ; End of list
MGQDL3: LDB A,[$LAFLD,,LISTAR(C)]
CAIE A,A$ID
JRST MGQDL2 ; Not an ID, try next
MOVE B,$ARLOC+MSGAR
MOVE B,$LSLOC(B)
ADD B,E ; ASCNT to ID of message being killed
SLNEA C,B
JRST MGQDL2 ; Not right ID, try next
HRRZ B,LISTAR(C)
TLO F,%QMLMD
LNDEL C,LISTAR(D)+1 ; Remove this from list
MOVE C,B
JUMPN C,MGQDL3
MGQDL4: FINDA A,[A$ID,,[LISTAR(D)+1]] ; Any messages left?
SKIPA C,LISTAR(D)+1
JRST MGQDL6 ; Yes
MOVE A,LISTAR(C)+1 ; Host
HRRZ B,LISTAR(D)
TLO F,%QMLMD
LNDEL D,$LLLST(L) ; No, flush LLN from QML!
STAT (,("All queued msgs gone for "),HST(A))
SKIPA D,B
MGQDL6: HRRZ D,LISTAR(D) ; Get next site LLN.
JUMPN D,MGQDL1 ; Do next host in queue
MGQDL9: TLNE F,%QMLMD
CALL QMLPUT
POPAE P,[L,E,D,C,B,A]
RET
; Routine to verify consistency of MASTER and QML/RML.
; For each message in MASTER, makes sure it exists on QML/RML;
; For each message in QML/RML, makes sure it exists on MASTER.
; (this isn't too important though, since it can legitimately
; happen that QML/RML contain deleted messages)
; Prints out 1-line summary for each offending message.
; Note carefully that output goes to the standard output!!
; VERLST - Verify Lists.
; VERMST - Verify MASTER
; VERRML - Verify RML
; VERQML - Verify QML
VERQML: MOVE P,[-PDLLEN,,PDL]
SETZB F,MF
SETOM DEBUG
MOVE A,[-6,,[
.ROPTION ? TLO 0,%OPALL ; Use new mode ints & lock hacking.
.RMASK ? IOR 0,[%BADPI] ; Specify interruptable bad conditions,
.RPICLR ? MOVE 0,[-1]]] ; and enable them.
SYSCAL USRVAR,[CIMM %JSELF ? A]
.LOSE %LSFIL
CALL MYADDR ; Set our address(es)
SKIPN PURESW ; And now, make sure
CALL IPURIF ; that pages are pure!
CALL DATIME"UPINI
CALL MTMHNG ; What the hell, be consistant...
CALL MLINIT ; Now ensure uniqueness!
CALL MCINIT
TLNN F,%SCOPN
CALL SCOPN
.CALL [SETZ ? SIXBIT/OPEN/ ? [.UAO,,DBC] ? [SIXBIT/DSK/]
[SIXBIT/GUBBLE/] ? SETZ [SIXBIT/>/] ]
.LOSE %LSSYS
OUT(DBC,OPEN(UC$IOT))
OUT(,CH(DBC))
SETZ E, ; Count of LNs flushed.
SKIPN $AROPN+QMLAR
CALL QMLGET
MOVE L,$ARLOC+QMLAR ; L points to QML.
HRRZ B,$LLLST(L) ; B will point to QML nodes.
CAIA
VERQM3: HRRZ B,LISTAR(B)
JUMPE B,VERQM9
LDB A,[$LAFLD,,LISTAR(B)] ; Check type of QML node.
CAIE A,A$Q
JRST [ OUT(,("QML node bad??"),EOL)
JRST VERQM3]
MOVE A,LISTAR(B)+1 ; Host sublist.
LDB C,[$LAFLD,,LISTAR(A)]
CAIE C,A$QHST
JRST [ OUT(,("Bad QML entry!!"),EOL)
JRST VERQM3 ]
OUT(,HST(LISTAR(A)+1),(":")) ; Output host-name for site.
HRRZ A,LISTAR(A) ; CDR is to failure count.
LDB C,[$LAFLD,,LISTAR(A)]
CAIN C,A$QFCT ; Failure-count for host?
JRST [ OUT(,(" failure cnt "),D(LISTAR(A)+1))
HRRZ A,LISTAR(A)
JRST .+1]
OUT(,EOL)
CAIA
VERQE3: HRRZ A,LISTAR(A) ; CDR is to msg-ID list.
VERQE4: SKIPE A
JRST [ LDB C,[$LAFLD,,LISTAR(A)]
CAIN C,A$ID
JRST [ MOVE C,LISTAR(A)+1
ADD C,$LSLOC(L)
OUT(,("Message: "),TC(C),EOL)
JRST VERQE3 ]
OUT(,("Flushing bad LN in list, type is "),D(C))
HRRZ C,LISTAR(A) ; Get CDR before flushing...
OUT(,(" ...CDR is: "),O(C),EOL)
AOS E
LNDEL A,LISTAR(B)+1 ; Flush from list.
MOVE A,C
TLO F,%QMLMD ; Indicate QML modified!
JRST VERQE4 ]
JRST VERQM3
VERQM9: TLNE F,%QMLMD ; QML modified?
.VALUE [ASCIZ ":QML munged"]
CALL QMLPUT
TLZ F,%QMLMD ; And get rid of in-core copy
UARCLS QMLAR
OUT(,("Flushed "),D(E),(" nodes."))
.VALUE [ASCIZ ": Done."]
OUT(SC,CLS)
OUT(DBC,CLS)
MOVEI A,LOCK1
CALL LKFREE ; First, make damn sure launch lock is free,
JSR DEATHV ; then start swinging in the breeze
; PRTQML - Output QML, nicely formatted, on std output.
PRTQML: PUSHAE P,[A,B,L]
SKIPN $AROPN+QMLAR
CALL QMLGET
MOVE L,$ARLOC+QMLAR
HRRZ B,$LLLST(L)
CAIA
PRTQM3: HRRZ B,LISTAR(B)
JUMPE B,PRTQM9
LDB A,[$LAFLD,,LISTAR(B)]
CAIE A,A$Q
JRST [ OUT(,("QML node bad??"),EOL)
JRST PRTQM3]
MOVE A,LISTAR(B)+1
CALL PRTQME ; Print a QML entry.
JRST PRTQM3
PRTQM9: POPAE P,[L,B,A]
RET
; PRTQME - Output QML Entry, on standard output.
; A - LP to the start of a site's queue-list.
; L - QML LSE
PRTQME: PUSHAE P,[B]
LDB B,[$LAFLD,,LISTAR(A)] ; Get attrib of 1st LN
CAIE B,A$QHST ; It better be this.
JRST [ OUT(,("Bad QML entry!!"),EOL)
JRST PRTQE9]
OUT(,HST(LISTAR(A)+1),(":")) ; Output host-name for site.
HRRZ A,LISTAR(A) ; Get CDR, move up.
LDB B,[$LAFLD,,LISTAR(A)] ; Get attrib for next LN.
CAIN B,A$QFCT ; Failure-count for host?
JRST [ OUT(,(" failure cnt "),D(LISTAR(A)+1))
HRRZ A,LISTAR(A)
JRST .+1]
OUT(,EOL)
UARPUSH MSGAR ; Must save current msg!
CAIA
PRTQE3: HRRZ A,LISTAR(A)
JUMPE A,[UARPOP MSGAR ; Done, can restore MSGAR.
JRST PRTQE9]
LDB B,[$LAFLD,,LISTAR(A)]
CAIE B,A$ID ; Should be message-ID
JRST [ OUT(,(" Bad LN in list!"),EOL)
JRST PRTQE3]
CALL MSGGET ; Try to get message, clobbers MSGAR.
JRST [ OUT(,(" Can't retrieve message "),TLS(A),EOL)
JRST PRTQE3]
PUSH P,L
MOVE L,$ARLOC+MSGAR
OUT(,(" ")) ; Indent a couple spaces.
CALL PRTSUM ; Output info about msg.
POP P,L
JRST PRTQE3
PRTQE9: POPAE P,[B]
RET
; PRTSUM - Show two-line message summary. Outputs to std output.
; L - LSE holding message list.
PRTSUM: PUSHAE P,[A,B,C]
FINDA A,[A$ID,,[$LLLST(L)]] ; Find message ID
JRST [ OUT(,(" <No msg ID!!> "))
JRST PRTSM1]
OUT(,TLS(A)) ; Output ID
PRTSM1: FINDA A,[A$TIM,,[$LLLST(L)]] ; Find message time
JRST [ OUT(,(" <no time!> "))
JRST PRTSM2]
OUT(,(" "),TIM(F1,LISTAR(A)+1),(" ")) ; Output time.
; Now print originator... this one is funny.
PRTSM2: CALL SKPNMH ; Net-mail-from-host?
JRST PRTSM3
OUT(,("@"),FMT(HST(A),-7.))
JRST PRTSM4
PRTSM3: FINDA A,[A$SNM,,[$LLLST(L)]] ; Find sender's name.
JRST [ OUT(,(" <> "))
JRST PRTSM4]
OUT(,(" "),FMT(TLS(A),-7.))
FINDA A,[A$SNH,,[$LLLST(L)]] ;Sender at foreign host?
JRST PRTSM4
OUT(,("@"),FMT(HST(LISTAR(A)+1),-7.))
; Now hack length.
PRTSM4: FINDA A,[A$MTXT,,[$LLLST(L)]]
TDZA A,A
HLRZ A,LISTAR(A)+1 ; Get length
OUT(,(" "),D(A,5),(" "))
; Now finalize first line by printing subject.
PRTSM5: FINDA A,[A$SBJ,,[$LLLST(L)]]
JRST PRTSM6
OUT(,("S:"),FMT(TLS(A),,20.)) ; Output up to 20 chars.
;List queued recipients, one to a line
PRTSM6: SKIPA C,$LLLST(L)
PRTSM7: HRRZ C,LISTAR(C)
FINDA C,[A$RCP,,[C]] ; Find next queued rcpt
JRST PRTSM9 ; No more
FINDA A,[A$RPSN,,[LISTAR(C)+1]] ; Is it a pseudo?
CAIA
JRST PRTSM7 ; Ignore it if so.
OUT(,EOL,(" -> ")) ; Start line for this rcpt
FINDA A,[A$RTYP,,[LISTAR(C)+1]] ; Doesn't work to call NSRNAM
JRST PRTS7A ; Recursive %LTSAO I guess is bug
OUT(,SL(A),(" "))
PRTS7A: FINDA A,[A$RNAM,,[LISTAR(C)+1]]
JSR AUTPSY
FINDA B,[A$RHST,,[LISTAR(C)+1]]
TDZA B,B ; Local host
MOVE B,LISTAR(B)+1
OUT(,SL(A),(" at "),HST(B))
FINDA A,[A$RFCT,,[LISTAR(C)+1]] ;Look for rcpt's failure count
JRST PRTSM8
OUT(,("; Failed "),D(LISTAR(A)+1),(" times"))
PRTSM8: FINDA A,[A$RRMG,,[LISTAR(C)+1]] ; See if err msg there
JRST PRTSM7
OUT(,("; ERR="),SL(A))
JRST PRTSM7
PRTSM9: OUT(,EOL)
POPAE P,[C,B,A]
RET
SUBTTL Main mailing routine
;;; MAIL - Main mailing routine.
;;; MF/ control flags
;;; A/ ptr to msg attrib list
;;; B/ (optional) time of event this message is about
;;;
;;; Composes header, eqv's rcpts, sends msg and any error
;;; msgs that arise, and queues if temporary error encountered.
M%CORG==1 ;rh flag, set when msg originated by comsat.
M%SSBJ==2 ;" set when b has time to generate "msg of" subject about.
M%ERR==4 ; Indicates error message, must CC to MAIL-MAINTAINERS.
M%EMSG==10 ; Indicates message LSE is in EMSGAR.
.SCALAR MSBJTM ; May hold a time.
.SCALAR NRXPER ; # errors seen during rcpt expansion etc.
MAIL: PUSHAE P,[A,B,C,D,L,N,LSTSUP,NRXPER]
PUSHAE P,[NTSITE,NTHOST,NDHOST,NTCCON,NTRTSW,NTTYPE,XRSQQ,XRSQPS,XRSQRS]
MOVEM B,MSBJTM ; Remember time of subject message.
TRNN MF,M%EMSG ; Message in EMSGAR?
JRST MAIL04
; Must make EMSGAR the MSGAR, by swapping ARBLKs!
UARPUSH MSGAR ; Save MSGAR
UARPUSH EMSGAR ; and transfer EMSGAR -> MSGAR via push/pop.
UARPOP MSGAR
MAIL04: MOVE L,$ARLOC+MSGAR ; Make current with right address.
MOVE A,$LLLST(L)
TRNN MF,M%ERR ; Error message that must be CC'd to Comsat?
JRST MAIL06
MAKELN B,[A$RNAM,,0
%LTSTR,,[LITSTR [MAIL-MAINTAINERS]]]
MAKELN B,[A$ROPT,,[B]
%LTSTR,,[LITSTR [CC]]]
MAKELN A,[A$RCP,,[A]
%LTLST,,[B]] ; now have at least "MAIL-MAINTAINERS" as dest.
MAIL06: TRNN MF,M%CORG ; Did COMSAT originate this message?
JRST MAIL30
.IOPUSH NETI, ; Yes, we're recursing. Save net chans.
OUT(NETO,PUSH)
OUT(NETD,PUSH)
SETZB N,NTHOST ; And clear "current site".
FINDA B,[A$ID,,[$LLLST(L)]] ; Make sure msg has an ID.
JRST [ MOVE B,A
CALL IDGET ; Get one
HRRM B,LISTAR(A) ; Tack rest of list onto it.
JRST .+1]
TRNE MF,M%SSBJ ; If so, form subject given time?
MAKELN A,[A$SBJ,,[A] ; Yes, make it.
%LTSAO,,[[OUTCAL(,("Msg of "),TIM(DOW,MSBJTM),(", "),TIM(F2,MSBJTM))]]]
MAKELN A,[A$SRTP,,[A] ? %LTSTR,,0] ; Prevent any SMTP looping.
MAKELN A,[A$SNM,,[A] ? %LTSTR,,[LITSTR [COMSAT]]]
MAIL30: MOVE B,A
CALL DATIME"TIMGET
MAKELN A,[A$TIM,,[B] ? %LTVAL,,[A]]
MOVEM A,$LLLST(L) ; Now store ptr to consed-up list.
SETZM NRXPER ; Zero error count
CALL SNMEXP ; Hack sender name and options.
CALL RCPEXP ; Crunch rcpt list into expanded form (can generate err)
CALL HEADER ; Now form headers for message.
CALL TXTCHK ; Check out text for ^_'s or CRLF.CRLF
SKIPE NRXPER ; If any errors,
CALL RXPERR ; generate preliminary err msg.
CALL RCPSND ; now send!
; Done, see if must restore MSGAR.
TRNN MF,M%EMSG ; Was EMSGAR swapped?
JRST MAIL90 ; Nope, OK.
UARPOP MSGAR ; Restore old MSGAR.
MAIL90: TRNN MF,M%CORG ; And now, if twere in recursion,
JRST MAIL95
OUT(NETD,POP) ; Restore net channels.
OUT(NETO,POP)
.IOPOP NETI,
MAIL95: POPAE P,[XRSQRS,XRSQPS,XRSQQ,NTTYPE,NTRTSW,NTCCON,NDHOST,NTHOST,NTSITE]
POPAE P,[NRXPER,LSTSUP,N,L,D,C,B,A]
RET
SUBTTL Sender name & option hacking.
SNMEXP: PUSHAE P,[A,B]
FINDA A,[A$SNH,,[$LLLST(L)]]
CAIA
JRST SNXP90 ;Don't do if sender at foreign host
FINDA A,[A$SNM,,[$LLLST(L)]] ; Find sender name
JRST [ FINDA A,[A$CSN,,[$LLLST(L)]]
JSR AUTPSY
JRST .+1]
MOVE A,LISTAR(A)+1
ADD A,$LSLOC(L) ;make abs ascnt ptr to name
SETZ B, ; Match to any type.
CALL RCPEQV ;get ptr to option list if any
JRST SNXP90 ;none
PUSH P,L
MOVE L,$ARLOC+EQVAR ; Temporarily set LSE to EQV for searching.
FNDSTR A,A,A$ROPT,[NOQC]
TDZA B,B
SETO B,
POP P,L
JUMPE B,SNXP90 ; Jump if no "NOQC" option.
MAKELN A,[A$CNF,,[$LLLST(L)]
%LTSTR,,[LITSTR [FAIL]]]
MOVEM A,$LLLST(L) ; Found it, store confirm-option on list.
SNXP90: POPAE P,[B,A]
RET
; SNMRCP - Cons up RCPT for sender name. Called by various things
; that want to return some message or error to sender.
; L - current LSE must have message attribs in it.
; Failure return .+1 if can't find sender name.
; Returns .+2
; A - LP to an A$RCP LLN.
;
; Nowadays prefer an SMTP return path to a parsed FROM field!
; We add ourselves to the virtual routing path at transmission time;
; the first host in an SMTP reverse path is the host we received the
; message from. This means we can simply hand the entire path back
; to the most recent relay host as the forward path for an error
; receipt. SU-SCORE appears to be trying to parse the path though!
SNMRCP: PUSHAE P,[B,C]
FINDA A,[A$SMRP,,[$LLLST(L)]] ; Explicit maintainer specified?
CAIA ; Give them the error receipt.
JRST SNMRC6
FINDA A,[A$CSN,,[$LLLST(L)]] ; Maybe claimed by someone?
CAIA ; Give them the error receipt.
JRST SNMRC6
FINDA A,[A$SRTP,,[$LLLST(L)]] ; Maybe SMTP path available?
JRST SNMRC5
MOVE B,LISTAR(A)+1 ; Get spt to return path.
TLNN B,-1 ; See if it's explicitly null
JRST SNMRC9 ; Yeah, punt this recipient.
LNCOPY A,[0 ? A] ; Copy the reverse-path.
MOVEI B,A$RNAM ; Becomes forward-path.
DPB B,[$LAFLD,,LISTAR(A)] ; Mutate into rcpt name.
FINDA B,[A$NMH,,[$LLLST(L)]] ; Find most recent netmail host.
JRST SNMRC5 ; Eh?
JRST SNMRC7 ; Source routed rcpt.
SNMRC5: FINDA A,[A$SNM,,[$LLLST(L)]] ; Maybe parsed the header?
JRST SNMRC9 ; Ugh, no rcpt!
SNMRC6: LNCOPY A,[0 ? A] ; Begin with copy of name LN.
MOVEI B,A$RNAM ; Create rcpt name attribute.
DPB B,[$LAFLD,,LISTAR(A)] ; Munge our copy.
FINDA B,[A$SNH,,[$LLLST(L)]] ; If sender was at foreign host
CAIA ; use that information too.
SNMRC7: MAKELN A,[A$RHST,,[A] ? %LTVAL,,[LISTAR(B)+1]] ; Make copy of host LN.
MAKELN A,[A$RCP,,0 ? %LTLST,,[A]] ; Cons host, recipient.
AOS -2(P) ; Success!
SNMRC9: POPAE P,[C,B] ; All done.
RET
SUBTTL Message header formation
; HEADER - Using current MSG-LSE, and any argument flags etc,
; generates headers for each recipient, as well as a standard
; default A$MHDR for the whole message. (If a rcpt has no
; A$RHDR, the A$MHDR is used instead.)
HEADER: PUSHAE P,[A,B,C,D]
CALL HDRINI ; Initialize header vars...
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This is a special kludge for net mail; when (if) network headers are
;;; parseable, the new scheme will be to extract the network header
;;; exactly and put it in HDRPN (to preserve comment fields) but
;;; generate the ITS headers etc. as appropriate. But since they can't
;;; be parsed, instead we put in the following "header force" which OVERRIDES
;;; R-HEADER-FORCEs, so that people who use R-HEADER-FORCE won't complain.
FINDA B,[A$NMH,,[$LLLST(L)]] ; Is this net mail?
JRST HEAD05 ; No, avoid kludge.
SETOM HDRNMH ; Make other code do different things
;;; Now, look at the first line of the message text. If it looks like an
;;; ITS header, make up a network header from it and put it on as A$KHDR.
FINDA B,[A$MTXT,,[$LLLST(L)]] ; Get message text
JRST HEAD05 ; None?
MOVE B,LISTAR(B)+1
HLRZ A,B ; Length
ADD B,$LSLOC(L)
HRLI B,440700 ; Byte pointer
MOVEM B,$LSRPT(L) ; Put where will be relocated by UABUMP
HDRK1: ILDB C,$LSRPT(L) ; See if there's an @ before
CAIN C,"@ ; the first : or CR
JRST HDRK3
CAIE C,":
CAIN C,^M
JRST HEAD05
SOJG A,HDRK1
JRST HEAD05
;;; Next space after the @ terminates the from-name, unless there is a parenthesized
;;; thingamajig after that.
HDRK3: SOJLE A,HEAD05
ILDB C,$LSRPT(L)
CAIN C,^M
JRST HEAD05
CAIE C,40
JRST HDRK3
SOJLE A,HEAD05
MOVE C,$LSRPT(L) ;LOOK AHEAD 1 CHARACTER
ILDB C,C
CAIE C,"(
JRST HDRK5
HDRK4: ILDB C,$LSRPT(L)
CAIN C,^M
JRST HEAD05
SOJLE A,HEAD05
CAIE C,")
JRST HDRK4
ILDB C,$LSRPT(L)
SOJLE A,HEAD05 ;WE HAVE JUST READ THE SPACE
HDRK5: SAOBEG TMPC, ;Make network header
FWRITE TMPC,[[From: ]] ; Do any bumping before ASCNT formed.
FINDA C,[A$MTXT,,[$LLLST(L)]]
JSR AUTPSY
MOVE C,LISTAR(C)+1
ADD C,$LSLOC(L)
HLRZ D,C
SUBI D,1(A)
HRL C,D ;ASCNT to from-name not counting trailing sp.
OUT(TMPC,TC(C),EOL)
;Next 17. characters are the date
FWRITE TMPC,[[Date: ]]
MOVEI D,17.
HDRK6: ILDB C,$LSRPT(L)
OUT(TMPC,C((C)))
SOJG D,HDRK6
SUBI A,17.
OUT(TMPC,EOL)
;The rest of the line, if anything, is the subject.
;In that case there is a Re: before it.
HDRK7: SOJLE A,HDRK10
ILDB C,$LSRPT(L)
CAIN C,^M
JRST HDRK10
CAIE C,":
JRST HDRK7
FWRITE TMPC,[[Subject]]
HDRK8: OUT(TMPC,C((C)))
SOJLE A,HDRK9
ILDB C,$LSRPT(L)
CAIE C,^M
JRST HDRK8
HDRK9: OUT(TMPC,EOL)
HDRK10: OUT(TMPC,EOL) ;Blank line separates header from text
MAKELN A,[0 ? %LTSAO,,0] ; Return accumulated stuff.
MOVEI B,A$KHDR
DPB B,[$LAFLD,,LISTAR(A)] ; Set up attrib
MOVE B,$LLLST(L)
HRRM B,LISTAR(A)
HRRZM A,$LLLST(L) ; Cons onto message-attrib list.
;drop into HEAD05
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; First, find out what sort of header the sender wants to use.
HEAD05: MOVEI A,3 ;Null header if NET-MAIL-FROM-HOST
SKIPE HDRNMH
JRST HEAD20
FINDA B,[A$HFRC,,[$LLLST(L)]] ;header force option exists?
JRST HEAD10 ;no, hack default stuffs.
MOVSI A,-NHDRFS
USLNEA B,HDRFTB(A) ; Search thru header force table.
AOBJN A,.-1
JUMPL A,HEAD20 ; Jump if found!
; Default header munching, decide if want ITS or Network style.
; If completely intra-ITS, use ITS style; else must use Network style.
HEAD10: SETZM RCSQCT ;initialize
HEAD12: CALL RCPSEQ ;get one rcpt
IFN 0,[ JRST [ SETZ A, ? JRST HEAD20] ;none left, ITS-style header is ok.
FINDA A,[A$RHST,,[A]] ;see if foreign host
JRST HEAD12 ; None, local...
MOVE A,LISTAR(A)+1 ;yes, get #
CALL NHITS ; an ITS site?
CAIA
JRST HEAD12 ;yes, continue
];IFN 0
NOP
MOVEI A,4 ; Non-ITS site found, default to RFC822 header.
HEAD20: CALL @HDRTB(A) ; Form whatever style header is desired, return SLP in A
MOVEM A,HDRPDF ; Store it as default and future A$MHDR.
SKIPA D,$LLLST(L) ; Begin loop thru rcpts...
HEAD30: HRRZ D,LISTAR(D) ; Get next
FINDA D,[A$RCP,,[D]] ; Find one.
JRST HEAD90 ; When done, finalize & return.
MOVE B,LISTAR(D)+1 ; Get ptr to list
FINDA A,[A$RPSN,,[B]] ; Make sure it's not a pseudo.
CAIA
JRST HEAD30 ; It was, ignore it.
; Here, can hack each rcpt's header separately.
FINDA A,[A$HFRC,,[$LLLST(L)]] ; Ignore R-header-force if header-force
SKIPE HDRNMH ; ...or if NET-MAIL-FROM-HOST
JRST HEAD40
FINDA A,[A$RHFC,,[B]] ; Does rcpt have a R-header-force?
JRST HEAD40 ; Nope, so skip that.
MOVSI C,-NHDRFS ; Has a R-header-force! Find IDX for it.
USLNEA A,HDRFTB(C)
AOBJN C,.-1
JUMPGE C,HEAD30 ; Jump if can't understand it.
CALL @HDRTB(C) ; Else execute...
JRST HEAD45 ; and go put onto rcpt's list.
HEAD40: FNDSTR A,B,A$RTYP,[*MSG] ; Is this a *MSG rcpt?
JRST HEAD30 ; Nope, don't form any special header.
CALL HDRMSG ; Uh-oh! Form *MSG-style header!
HEAD45: MOVEI C,A$RHDR
DPB C,[$LAFLD,,LISTAR(A)] ; Set attrib
LNAPP [B ? A] ; Put header on rcpt list.
JRST HEAD30 ; Back for more.
; Return after header adventures.
HEAD90: SKIPN A,HDRPDF ; Get default header.
JSR AUTPSY ; MUST ALWAYS BE ONE!
LNCOPY A,[0 ? A] ; Copy it...
MOVEI B,A$MHDR
DPB B,[$LAFLD,,LISTAR(A)] ; Set up attrib
MOVE B,$LLLST(L)
HRRM B,LISTAR(A)
HRRZM A,$LLLST(L) ; Cons onto message-attrib list.
HEAD99: POPAE P,[D,C,B,A]
RET
; Header-Force table.
HDRFTB: ASCNT [ITS]
ASCNT [NET]
ASCNT [*MSG]
ASCNT [NULL]
ASCNT [RFC733]
NHDRFS==.-HDRFTB
; Header-routine table, holds rtns corresponding to HDRFTB above.
HDRTB: HDRITS ; 0 - ITS header.
HDRNET ; 1 - NET header.
HDRMSG ; 2 - *-MSG header.
HDRNUL ; 3 - Null header. (This number is known by HEAD05)
HDRSTD ; 4 - ARPAnet standard header (RFC822)
BVAR ; Header-routine variables.
HDRTIM: 0 ; Time of message
HDRFRM: 0 ; SLP to "FROM" name to use.
HDRSBY: 0 ; SLP to "SENT-BY" name to use, if any.
HDFFLG: 0 ; -1 when "@" exists within FROM name.
HDRPI: 0 ; SLP to ITS-style header if one formed yet.
HDRPN: 0 ; SLP to NET-style header if one formed yet.
HDRPS: 0 ; SLP to RFC733-style header if one formed yet.
HDRPMG: 0 ; SLP to *MSG-style header if one formed yet.
HDRPDF: 0 ; SLP to default header if one (used for A$MHDR).
HDRLCL: 0 ; -1 if all recipients are local (i.e. on OWNHST)
HDRNMH: 0 ; non-zero if NET-MAIL-FROM-HOST and header is in text
HDRFNB: BLOCK 14 ; Buffer for storing unscrambled full name.
EVAR
; HDRINI - Initialize Header routine variables.
; MUST be called before any HDRITS, HDRNET, etc to produce valid
; results for current message!
HDRINI: PUSHAE P,[A,B,C]
SETZM HDRFRM ; Clear various variables
SETZM HDRSBY
SETZM HDFFLG
SETZM HDRPI
SETZM HDRPN
SETZM HDRPS
SETZM HDRPMG
SETZM HDRLCL
SETZM HDRNMH
FINDA A,[A$TIM,,[$LLLST(L)]] ; Find time of msg
JRST [ CALL DATIME"TIMGET ; If doesn't exist, get current time.
JRST HDRIN0]
MOVE A,LISTAR(A)+1
HDRIN0: MOVEM A,HDRTIM ; Save for later ref.
; Now straighten out which sender name(s) to use
SETZB B,C ;B holds claimed name ptr, C the sent-from name ptr
FINDA C,[A$SNM,,[$LLLST(L)]] ;find the sent-from name if any
JFCL
FINDA B,[A$CSN,,[$LLLST(L)]] ;find claimed-from name
CAIE C, ;if neither exists, skip and die
CAIA ;one exists, skip and live
JSR AUTPSY
USLNE B,C ;compare strings
CAIA ;unequal
SETZ C, ;equal, so flush sent-from and use claimed-from.
CAIN B, ;if claimed-from doesn't exist,
EXCH B,C ;use sent-from as claimed-from.
MOVEM B,HDRFRM ; Store who it's from
MOVEM C,HDRSBY ; And who actually sent it.
SETZM RCSQCT ; initialize RCPSEQ coroutine
HDRIN1: CALL RCPSEQ ; get a recipient
JRST [ SETOM HDRLCL ; none left, all recipients are local
JRST HDRIN2
]
FINDA A,[A$RHST,,[A]] ; get recipient's host
JRST HDRIN1 ; none, i.e. local, go check next
MOVE A,LISTAR(A)+1 ; get host no.
CAMN A,OWNHST ; is host us?
JRST HDRIN1 ; yes, keep looking at recipients
;minor check here ... if "@" exists within claimed-from name,
;set flag saying not to add "@ <ownsite>" (but always add that to
;sent-from name! Generate sent-from in this case if it didn't exist?)
; Later should allow optional host spec for FROM: in input file.
HDRIN2: SETZM HDFFLG
JUMPE C,HDRIN5 ; meaningless to check if no sent-from.
MOVE A,LISTAR(B)+1 ; get SPT to sender name.
ADD A,$LSLOC(L) ; Make abs.
HLRZ B,A
HRLI A,440700
JRST HDRIN4
ILDB C,A
CAIN C,"@
SOSA HDFFLG ;make -1 and skip out of loop
HDRIN4: SOJGE B,.-3
HDRIN5: POPAE P,[C,B,A]
RET
SUBTTL Individual header routines.
; These routines are called to generate a specific type of header.
; They take no explicit arguments: they just assume that the current LSE
; is the message for which the header must be generated. Also, to
; save time, certain decoding of the LSE which is common to several
; header types is prepared by HDRINI (i.e., HDRTIM, HDRSBY, etc).
; They are expected to return in A an SLN (no attribute) to the header
; text.
; Form a null header
HDRNUL: MAKELN A,[0 ? %LTSTR,,0] ; Fast...
RET
; Form an ITS-style header.
HDRITS: SKIPE HDRPI ; If one already formed,
JRST [ LNCOPY A,[0 ? HDRPI] ; Copy and return that.
RET]
SAOBEG TMPC,
FWRITE TMPC,[TLS,HDRFRM] ; Write FROM name.
SKIPN HDFFLG ; If he has own ideas
JRST [ FWRITE TMPC,[[@],TZ,OWNNAM] ; skip "@<localsite>".
JRST .+1] ; Else (default) add it.
SKIPN HDRSBY ; And skip to add Sent-by if different.
JRST HDRI20
FWRITE TMPC,[[ (Sent by ],TLS,HDRSBY] ; Different, add "Sent-by"
SKIPN HDFFLG
JRST [ FWRITE TMPC,[[@],TZ,OWNNAM] ; Add local-site if not given in FROM.
JRST .+1]
OUT(TMPC,RPAR)
HDRI20: FWRITE TMPC,[[ ],WA,HDRTIM] ; Now, time of message.
FINDA A,[A$SBJ,,[$LLLST(L)]] ;find subject if any
JRST HDRI30 ;nope
FWRITE TMPC,[[ Re: ],TLS,A] ;add the subject string
HDRI30: OUT(TMPC,EOL)
MOVE A,RCPNUM
SKIPE HDRLCL ; if any recipients are foriegn then force a To: line
CAILE A,1 ; only one recipient?
CALL TOPUT ; if so, skip 'to:' lines...else do.
CALL UHDPUT ; Output user-specified header lines, if any.
MAKELN A,[0 ? %LTSAO,,0] ; Return accumulated stuff.
MOVEM A,HDRPI ; Save SLP in case called again.
RET
; NET style header
HDRNET: SKIPE HDRPN ; If one already formed,
JRST [ LNCOPY A,[0 ? HDRPN] ; Copy & return that.
RET]
PUSH P,B
SAOBEG TMPC,
FWRITE TMPC,[[Date: ],WB,HDRTIM,[
From: ],TLS,HDRFRM] ; SIMPLE!!!
SKIPE HDFFLG ; If FROM has a "@site" in it,
JRST HDRN22 ; Skip "at <site>" & fullname.
FWRITE TMPC,[[ at ],TZ,OWNNAM]
; Now try to put the full name of the sender, in parentheses.
MOVE B,HDRFRM
MOVE A,LISTAR(B)+1
ADD A,$LSLOC(L) ; Get abs ASCNT to sender's name.
HLRZ B,A ; Get length of FROM field.
CAILE B,6 ; If longer than 6 letters, loser probably
JRST HDRN22 ; put his fullname in From: field.
CALL CVT76C ; LSRTNS won't get the right thing, so skip it.
MOVE B,A ; Get SIXBIT UNAME.
MOVEI A,LSR1C
CALL LSRTNS"LSRUNM
JRST HDRN22 ; Not in LSR1, skip full-name hack.
MOVEI A,LSRTNS"I$NAME
CALL LSRTNS"LSRITM
JRST HDRN22 ; No full name given, skip it.
; A/ BP to the fullname in ASCIZ, last-name-first.
MOVE B,A
ILDB B,B ; (Get first char of full name)
JUMPE B,HDRN22 ; Full name is null, skip it.
MOVE B,[440700,,HDRFNB]
CALL LSRTNS"LSRNAM ; Unscramble the order.
JRST HDRN22 ; This should not ever happen.
MOVE A,[440700,,HDRFNB]
FWRITE TMPC,[[ (],TPZ,A,[)]] ; SIMPLE!!!
HDRN22: OUT(TMPC,EOL)
SKIPE HDRSBY ; Sent-by exists?
JRST [ FWRITE TMPC,[[Sent-by: ],TLS,HDRSBY,[ at ],TZ,OWNNAM,[
]]
JRST .+1] ;add sent-from name if necessary
FINDA A,[A$SBJ,,[$LLLST(L)]] ;find subject if any
JRST HDRN30 ;no
FWRITE TMPC,[[Subject: ],TLS,A,[
]] ;output line
HDRN30: CALL TOPUT ; Output recipients.
CALL UHDPUT ; Output any user-specified hdr lines.
OUT(TMPC,EOL) ; Extra CR separates header from text
MAKELN A,[0 ? %LTSAO,,0]
MOVEM A,HDRPN ; Save SLP in case called again.
POP P,B
RET
; DARPA Internet standard header (RFC822)
LVAR HDRQUP: -1 ; -1 if want names with periods are to be quoted.
LVAR HDRIDS: -1 ; -1 if want message IDs stuck in headers.
LVAR HDRGAT: 0 ; Non-zero: addr of foo%bar@baz relay (headers only)
HDRSTD: SKIPE HDRPS ; If one already formed
JRST [ LNCOPY A,[0 ? HDRPS] ; then just copy and return it.
RET]
PUSHAE P,[B,C] ; Else accumulate header in string.
OUT(TMPC,OPEN(UC$SAO)) ; Begin string.
OUT(TMPC,("Date: "),TIM(RFC2,HDRTIM),EOL,("From: "))
FINDA A,[A$FFM,,[$LLLST(L)]] ; Maybe FAKE-FROM spec.
CAIA
JRST [ OUT(TMPC,TLS(A),EOL)
JRST HDRS30 ]
SKIPE HDFFLG ; If FROM specification has a "@" in it
JRST [ OUT(TMPC,TLS(HDRFRM),EOL) ; then put it out verbatim.
JRST HDRS30 ]
MOVE B,HDRFRM ; Try to find author's fullname.
MOVE A,LISTAR(B)+1
ADD A,$LSLOC(L) ; Get abs ASCNT to sender's name.
CALL CVT76C ; Convert it to sixbit.
MOVE B,A
MOVEI A,LSR1C
CALL LSRTNS"LSRUNM ; Look up in LSR1 database.
JRST HDRS10 ; If missing or no core, don't bother.
MOVEI A,LSRTNS"I$NAME
CALL LSRTNS"LSRITM ; Found luser - get fullname.
JRST HDRS10 ; Oh, well, no fullname given.
MOVE B,A ; Bp to last-name-first string.
ILDB B,B ; Check first char of fullname.
JUMPE B,HDRS10 ; If fullname is null, skip it.
MOVE B,[440700,,HDRFNB]
CALL LSRTNS"LSRNAM ; Unscramble the order.
CAIA
JRST HDRS20
; Here when fullname is unavailable.
HDRS10: SKIPE HDRGAT
JRST [ OUT(TMPC,TLS(HDRFRM),("%"),TZ(OWNNAM),("@"),TZ(GATNAM),EOL)
JRST HDRS30 ]
OUT(TMPC,TLS(HDRFRM),("@"),TZ(OWNNAM),EOL)
JRST HDRS30
; Here when we have the fullname.
HDRS20: MOVE A,[440700,,HDRFNB] ; Bp to fullname.
HDRS21: ILDB C,A ; Must check to see if it's cool.
JUMPE C,HDRS24 ; If no weirdness, we can output it.
CAIN C,". ; Periods may be special
SKIPN HDRQUP ; depending on latest RFC (sigh).
CALL SCHK4 ; Is this a special char?
CAIA
JRST HDRS21 ; If not special, get another.
HDRS22: MOVE A,[440700,,HDRFNB] ; Uh-oh, name contains a losing char.
OUT(TMPC,C("")) ; Must surround the name with quotes.
HDRS23: ILDB B,A
JUMPE B,[ OUT(TMPC,C(""))
JRST HDRS29 ]
CAIE B,"" ; If we run into a null
CAIN B,"\ ; or a backslash
OUTCAL(TMPC,C("\)) ; quote it with a backslash.
OUT(TMPC,C((B))) ; Output char of name.
JRST HDRS23 ; Go back for more chars.
HDRS24: OUT(TMPC,TZ(HDRFNB)) ; Output luser's full name.
HDRS29: OUT(TMPC,SP,LABR,TLS(HDRFRM))
SKIPE HDRGAT
JRST [ OUT(TMPC,("%"),TZ(OWNNAM),("@"),TZ(GATNAM),RABR,EOL)
JRST HDRS30 ]
OUT(TMPC,("@"),TZ(OWNNAM),RABR,EOL)
HDRS30: SKIPE HDRSBY ; Do SENDER if there is one.
OUTCAL(TMPC,("Sender: "),TLS(HDRSBY),("@"),TZ(OWNNAM),EOL)
HDRS40: FINDA A,[A$SBJ,,[$LLLST(L)]]
CAIA ; Do SUBJECT if there is one.
OUTCAL(TMPC,("Subject: "),TLS(A),EOL)
HDRS50: CALL STOPUT ; Add TO: to header
CALL SCCPUT ; Add CC: to header
CALL UHDPUT ; Do user-specified header lines, if any.
SKIPE HDRIDS ; Maybe put MESSAGE-ID in header.
JRST [ FINDA A,[A$ID,,[$LLLST(L)]]
JSR AUTPSY
OUTCAL(TMPC,("Message-ID: "),TLS(A),EOL)
JRST .+1 ]
OUT(TMPC,EOL) ; Extra CRLF separates header from text.
MAKELN A,[0 ? %LTSAO,,0]
MOVEM A,HDRPS ; Save SLP in case called again.
POPAE P,[C,B]
RET
; HDRMSG - forms header line for a MSG of format
; DISTRIB: *<site1>,*<site2>...
; EXPIRES: <date>
; <FROM> <TIME> <SUBJECT>
; tricky part is putting only the right names in DISTRIB.
HDRMSG: SKIPE HDRPMG ; Already have a *MSG header?
JRST [ LNCOPY A,[0 ? HDRPMG] ; Use it if so.
RET]
PUSH P,B
SAOBEG TMPC,
FWRITE TMPC,[[DISTRIB: ]]
TRO F,%NOCOM
SETZM RCSQCT ;initialize RCPSEQ
HDRM10: CALL RCPSEQ
JRST HDRM20 ;no more
FNDSTR B,A,A$RTYP,[*MSG] ; Find all which are of type *MSG.
JRST HDRM10 ; Not right type, ignore.
FNDSTR B,A,A$ROPT,[NOTDIST] ; Make sure it's OK to include in DISTRIB.
CAIA
JRST HDRM10 ; Nope, it doesn't want to be in there.
FINDA B,[A$RNAM,,[A]] ;yep, get the name
JSR AUTPSY
TRZN F,%NOCOM ; Output comma if anything precedes this.
OUTCAL(TMPC,(","))
FWRITE TMPC,[[ ],TLS,B] ; Output name
JRST HDRM10 ; & get another.
HDRM20: FWRITE TMPC,[[
EXPIRES: ]]
FINDA A,[A$XPIR,,[$LLLST(L)]] ;get ptr to expiration time
SKIPA B,[7] ; Use 7 days if none specified.
MOVE B,LISTAR(A)+1 ; Get # days since msg creation date.
IMUL B,[24.*60.*60.] ; Produce # secs
MOVE A,HDRTIM
CALL DATIME"TIMSEC ; Convert creation time to # secs,
ADD A,B ; Add in to get future time,
CALL DATIME"SECTIM ; And convert back from secs.
FWRITE TMPC,[WA,A,[
]]
CALL SKPNMH ; Don't make bogus ITS header
CAIA
JRST HDRM90
FWRITE TMPC,[TLS,HDRFRM]
SKIPE HDFFLG ; If has "@" within name,
JRST HDRM29 ; leave it.
FINDA A,[A$SNH,,[$LLLST(L)]] ; Sender have host?
JRST [ FWRITE TMPC,[[@],TZ,OWNNAM] ; No, use local host
JRST HDRM29 ]
FWRITE TMPC,[[@],HST,LISTAR(A)+1] ; Yes, use sender's host
HDRM29: FWRITE TMPC,[[ ],WA,HDRTIM]
FINDA A,[A$SBJ,,[$LLLST(L)]] ; See if subject spec...
JRST HDRM30 ; Nope
FWRITE TMPC,[[ Re: ],TLS,A]
CALL UHDPUT ; Output user-specified header lines, if any.
HDRM30: OUT(TMPC,EOL)
HDRM90: MAKELN A,[0 ? %LTSAO,,0]
MOVEM A,HDRPMG
POP P,B
RET
; TOPUT - forms 'to:' lines from existing A$RCP's.
; ignores those rcpts with attribs of OPTION NOSHOW.
.SCALAR TOPASS ; Flag for TO or CC.
TOPUT: PUSHAE P,[A,B,C,D,E]
FINDA A,[A$RLN,,[$LLLST(L)]] ;see if rcpt list name exists
CAIA
JRST TOPUT7
SETZM TOPASS ; Indicate pass 1 (to's)
TOPUT1: SETZM RCSQCT ; Initialize rcpseq routine
SETZ E, ; Zero cnt of chars on line
TOPUT2: CALL RCPSEQ ; Get ptr to rcp attrib list
JRST TOPUT8 ; No more rcpts to get
FNDSTR B,A,A$ROPT,[NOSHOW]
CAIA ; Supposed to suppress?
JRST TOPUT2 ; Yes, don't do it.
FNDSTR B,A,A$ROPT,[CC] ; Cc?
JRST [ SKIPE TOPASS ; No, if "to" pass, do it.
JRST TOPUT2
JRST .+2]
JRST [ SKIPN TOPASS ; Yes, if "to" pass, don't do.
JRST TOPUT2
JRST .+1]
FINDA B,[A$RHST,,[A]] ; Get dest attrib
SKIPA C,OWNHST ; No A$RHST means local
MOVE C,LISTAR(B)+1 ; Get host #
EXCH A,B
PUSH P,B ; HSTSRC clobbers
MOVE A,[440700,,TMPNAM] ; Buffer in which to stick hostname
MOVE B,C ; Host#
CALL RESOLV"HSTSRC ; Get ASCIZ string in A (horribly inefficient
; with domains, oh well, fix it later)
SKIPA A,[6] ; Unknown, will use number, assume 6 chars long
CALL LASCIZ ; Get length
POP P,B
EXCH A,B ; Now have # chars in hostname in B.
FINDA D,[A$RNAM,,[A]] ; Get rcp name attrib
JSR AUTPSY
MOVEM D,TPTMP1 ; Save for printout
HLRZ D,LISTAR(D)+1 ; Get # chars in rcpt name
ADD B,D ; Add into cnt.
FINDA D,[A$RTYP,,[A]] ; See if type exists.
JRST TOPUT3 ; Nope, no need to count that.
SLNEA D,[ASCNT [NAME]]
CAIA
JRST TOPUT3
HLRZ D,LISTAR(D)+1 ; Count rcpt type string. Get # chars
ADDI B,3(D) ; Plus 3 for parens & separating space.
TOPUT3: ADDI B,4 ; Plus 4 for " at "
JUMPLE E,TOPUT4 ; If nothing on line, jump...
ADDI E,2(B) ; Add 2 for ", " and add into total for line
CAIGE E,72. ; Line too big now?
JRST TOPUT6 ; Nope, is OK... go output.
OUT(TMPC,EOL) ; Must start new line... give CRLF.
TOPUT4: MOVEI E,4(B) ; Install new count.
SKIPE TOPASS
OUTCAL(TMPC,("CC: "))
SKIPN TOPASS
OUTCAL(TMPC,("To: "))
CAIA
TOPUT6: OUTCAL(TMPC,(", "))
CALL RTOS ; Output short form of rcpt.
JRST TOPUT2 ; get another item
;; Items all gone.
TOPUT8: CAILE E,0 ; If anything was on line,
OUTCAL(TMPC,EOL) ; CRLF it.
SKIPN TOPASS
JRST [SETOM TOPASS ? JRST TOPUT1]
TOPUT9: POPAE P,[E,D,C,B,A]
RET
;; RCPT LIST NAME exists.
TOPUT7: FWRITE TMPC,[[To: ],TLS,A,[
]]
SETOM TOPASS
JRST TOPUT1
; RTOS - Recipient Type-Out, Short. Takes LP in A to a rcpt's list
; and outputs on TMPC its short representation:
; If type NAME, outputs "NAME at SITE."
; Otherwise, "(TYPE NAME) at SITE".
; RTOSS - RTOS, Shorter. Similar, but uses "@" instead of " at ".
RTOS: TRZA F,%TMP ; Use random flag for distinction.
RTOSS: TRO F,%TMP
PUSHAE P,[B,C]
FINDA C,[A$RNAM,,[A]]
JSR AUTPSY
FINDA B,[A$RTYP,,[A]]
JRST RTOS10 ; No type, don't need to parenthesize!
SLNEA B,[ASCNT [NAME]] ; Has one, check it.
CAIA
JRST RTOS10 ; If NAME, also don't need parens.
FWRITE TMPC,[[(],TLS,B,[ ],TLS,C,[)]]
JRST RTOS11
RTOS10: FWRITE TMPC,[TLS,C]
RTOS11: TRNE F,%TMP
OUTCAL(TMPC,C("@))
TRNN F,%TMP
OUTCAL(TMPC,(" at "))
FINDA B,[A$RHST,,[A]]
SKIPA B,OWNHST
MOVE B,LISTAR(B)+1
FWRITE TMPC,[HST,B]
POPAE P,[C,B]
RET
; RTOL - Recipient Type-Out, Long form. Given LP to rcpt's list in A,
; outputs on TMPC its representation in long form as follows:
; (TYPE NAME @SITE (ATTRIB X) (ATTRIB Y)...)
; This may get used in an internal ITS sending scheme, but at the moment
; it is not called from anywhere.
RTOL: PUSHAE P,[B,C]
OUT(TMPC,LPAR)
FINDA B,[A$RTYP,,[A]]
JRST [ OUT(TMPC,("NAME"))
JRST .+2]
OUT(TMPC,TLS(B),SP)
FINDA B,[A$RNAM,,[A]]
JSR AUTPSY
OUT(TMPC,TLS(B),SP) ; Output name...
FINDA B,[A$RHST,,[A]]
SKIPA B,OWNHST
MOVE B,LISTAR(B)+1
FWRITE TMPC,[[@],HST,B,]
; Now the messy part - must have rtn that slobbers through a list
; outputting all input-able attributes in right format. In this
;case, must use a suppress-list including A$RHST, A$RNAM, and A$RTYP.
OUT(TMPC,RPAR) ; For time being...
POPAE P,[C,B]
RET
; STOPUT - forms 'To:' lines from existing A$RCP's.
; Ignores those recipients with attributes of OPTION NOSHOW.
LVAR STCC: 0 ; nonzero if doing cc:'s
STOPUT: PUSHAE P,[A,B,C,D,E]
SETZM STCC ; Do To:'s
FINDA A,[A$RLN,,[$LLLST(L)]] ;see if recipient list name exists
JRST STPUT1
OUT(TMPC,("To: "),TLS(A),EOL)
JRST STPUT9
; SCCPUT - Like STOPUT but for cc:'s.
.SCALAR TPTMP1
SCCPUT: PUSHAE P,[A,B,C,D,E] ; save ACs
SETOM STCC ; do cc:'s
STPUT1: SETZM RCSQCT ; initialize RCPSEQ routine
MOVEI E,0 ; zero count of characters on line
STPUT2: CALL RCPSEQ ; get ptr to recipient attribute list
JRST STPUT8 ; no more recipients to get
FNDSTR B,A,A$ROPT,[NOSHOW] ; supposed to suppress?
CAIA
JRST STPUT2 ; yes, skip this recipient
FNDSTR B,A,A$ROPT,[CC] ; cc?
JRST [ SKIPE STCC ; no, if "To" pass then do it
JRST STPUT2
JRST .+2]
JRST [ SKIPN STCC ; yes, if "To" pass then ignore it
JRST STPUT2
JRST .+1]
FINDA B,[A$RHST,,[A]] ; Get destination attribute
SKIPA C,OWNHST ; No A$RHST means local
MOVE C,LISTAR(B)+1 ; Get host no.
EXCH A,B
PUSH P,B ; HSTSRC clobbers
MOVE A,[440700,,TMPNAM] ; Put ASCIZ string here
MOVE B,C ; Host#
CALL RESOLV"HSTSRC ; Get addr of ASCIZ string in A (ha, ha)
SKIPA A,[6] ; Unknown, will use number, assume 6 chars long
CALL LASCIZ ; Get length
POP P,B
EXCH A,B ; Now have # chars in hostname in B.
FINDA D,[A$RNAM,,[A]] ; Get recipient name attribute
JSR AUTPSY
MOVEM D,TPTMP1 ; Save for printout
HLRZ D,LISTAR(D)+1 ; Get no. characters in recipient name
ADD B,D ; Add into count
FINDA D,[A$RTYP,,[A]] ; See if type exists
JRST STPUT3 ; Nope, no need to count that
SLNEA D,[ASCNT [NAME]]
CAIA
JRST STPUT3
SLNEA D,[ASCNT [BUG]]
CAIA
SKIPA D,[1] ; hacky way of getting BUG- to be length 4
HLRZ D,LISTAR(D)+1 ; Count recipient type string. Get no. of characters
ADDI B,3(D) ; Plus 3 for parens and separating space
STPUT3: ADDI B,3 ; Plus 3 for " at "
JUMPN E,STPUT4 ; If nothing on line, jump...
SKIPN STCC
OUTCAL(TMPC,("To: "))
SKIPE STCC
OUTCAL(TMPC,("cc: "))
MOVEI E,4(B) ; Install new count
JRST STPUT7
STPUT4: ADDI E,2(B) ; Add 2 for ", " and add into total for line
CAIL E,72. ; Line too big now?
JRST STPUT5 ; Nope, is OK... go output.
OUT(TMPC,(", "))
JRST STPUT7
STPUT5: OUT(TMPC,(",
"))
MOVEI E,4(B) ; Install new count
STPUT7: CALL SRTO ; Output short form of recipient
JRST STPUT2 ; get another item
; Items all gone.
STPUT8: CAILE E,0 ; if anything was on line
OUTCAL(TMPC,EOL) ; then CRLF
STPUT9: POPAE P,[E,D,C,B,A]
RET
; SRTO - RFC822 recipient Type-Out. Takes LP in A to a recipient's list
; and outputs on TMPC its short representation:
; If type NAME, outputs "NAME@SITE".
; If type BUG, outputs "BUG-NAME at SITE".
; Otherwise, "(TYPE NAME) at SITE".
SRTO: PUSHAE P,[B,C]
FINDA B,[A$RNAM,,[A]]
JSR AUTPSY
CALL SCHECK
TRNE F,%TMP ; need to quote string?
OUTCAL(TMPC,C("")) ; yes, output openning quote
FINDA C,[A$RTYP,,[A]]
JRST SRTO3 ; No type, don't need to parenthesize!
SLNEA C,[ASCNT [NAME]] ; Has one, check it.
CAIA
JRST SRTO3 ; If NAME, also don't need parens.
SLNEA C,[ASCNT [BUG]]
CAIA
JRST SRTO2
;Putting quotes around complex (list form) recipients is a misfeature.
;It makes the syntax more standard but it makes it impossible to
;reply-parse it. Presumably complex recipients don't normally go to
;random non-ITS hosts anyway.
; TRON F,%TMP ; already output a quote?
; OUTI TMPC,"" ; no, output a quote now
FWRITE TMPC,[[(],TLS,C,[ ],TLS,B,[)]]
JRST SRTO4
SRTO2: OUT(TMPC,("BUG-"))
SRTO3: TRNN F,%TMP
JRST [ OUT(TMPC,TLS(B))
JRST SRTO4 ]
CALL STLS
SRTO4: TRNE F,%TMP ; need to close quote?
OUTCAL(TMPC,C("")) ; yes, output closing quote
FINDA B,[A$RHST,,[A]]
SKIPA B,OWNHST
MOVE B,LISTAR(B)+1 ;Get host address in B.
CAME B,OWNHST ;If this is some random host
JRST SRTO5 ; output normally
SKIPE HDRGAT ;Else may want to do the % hack.
JRST [ OUT(TMPC,("%"),HST(B),("@"),TZ(GATNAM))
JRST SRTO9 ]
SRTO5: OUT(TMPC,("@"),HST(B))
SRTO9: POPAE P,[C,B]
RET
; SCHECK - Set %TMP if the string in B contains special characters.
SCHECK: PUSHAE P,[A,B,C] ; save ACs
TRZ F,%TMP
MOVE A,LISTAR(B)+1
ADD A,$LSLOC(L)
HLRZ B,A ; length
HRLI A,440700 ; B.P.
JUMPE B,SCHK2 ; the null string contains no specials
SCHK1: ILDB C,A ; get next character
CALL SCHK4 ; test character
TROA F,%TMP ; character is special
SOJG B,SCHK1
CAIN C,"@ ; If the string ends in an atsign
TRO F,%TMP ; quote it (for BUG-@ to non-ITS hosts)
SCHK2: POPAE P,[C,B,A] ; restore ACs
RET
; SCHK4 - Skips if character in C is not special.
SCHK4: CAIE C,"<
CAIN C,">
RET
CAIE C,"(
CAIN C,")
RET
CAIE C,":
CAIN C,";
RET
CAIE C,"@
CAIN C,",
RET
CAIE C,";
CAIN C,":
RET
CAIE C,""
CAIN C,"\
RET
CAIE C,"[
CAIN C,"]
RET
AOS (P)
RET
; STLS - Output string in B with quoting for \ and ".
STLS: PUSHAE P,[A,B,C] ; save ACs
MOVE A,LISTAR(B)+1
ADD A,$LSLOC(L)
HLRZ B,A ; length
HRLI A,440700 ; B.P.
JUMPE B,STLS2
STLS1: ILDB C,A
CAIE C,""
CAIN C,"\
OUTCAL(TMPC,C("\))
OUT(TMPC,C((C)))
SOJG B,STLS1
STLS2: POPAE P,[C,B,A]
RET
; TXTCHK - Routine to quickly munch through text looking for either ^_'s or
; CRLF.CRLF's, and set message-text flag (A$MTXF) appropriately.
TXTCHK: PUSHAE P,[A,B]
MOVEM 16,AC16S
MOVE 16,[1,,ACSAV]
BLT 16,AC16S-1 ;save accs
FINDA A,[A$MTXT,,[$LLLST(L)]]
JSR AUTPSY
MOVE A,LISTAR(A)+1 ;cnt and ptr
ADD A,$LSLOC(L) ;absolute addr
HLRZ B,A
ADDI B,4
IDIVI B,5
MOVN B,B
HRL A,B ;aobjn complete.
PUSH P,A ; Save it.
MOVE C,[TXTCKR,,E]
BLT C,E+TXTCKL-1
SETZ C,
JRST E
TXTCH3: PUSH P,A
PUSH P,B
HRRZ A,A ;get addr
ADD A,TXTCTB(B) ;get ptr to offending period
MOVEI B,", ;get replacement char
DPB B,A ;replace it
POP P,B
POP P,A
JRST E+6 ;continue
TXTCH2: MOVE 16,[ACSAV,,1]
BLT 16,16 ;restore accs
MOVE 16,AC16S
POP P,A ; Restore AOBJN ptr to text.
MOVE B,(A) ; Check for a message starting with ".<CRLF>"
AND B,[777777,,700000]
CAME B,[ASCII/.
/]
JRST TXTC30
MOVSI B,(ASCII/./#ASCII/,/)
XORM B,(A) ; CLOBBER THE "." TO A "," VIA GROSS KLUDGE!
; Loop to see if any ^_'s exist in text.
TXTC30: MOVE B,(A)
XOR B,[.BYTE 7 ? ^_ ? ^_ ? ^_ ? ^_ ? ^_ ]
TLNN B,774000
JRST TXTC35 ; Yup, found one.
TLNN B,3760
JRST TXTC35 ; etc
TDNN B,[17,,700000]
JRST TXTC35
TRNN B,77400
JRST TXTC35
TRNN B,376
JRST TXTC35
AOBJN A,TXTC30
JRST TXTC40 ; None found...
TXTC35: MAKELN A,[A$MTXF,,[$LLLST(L)]
%LTVAL,,0]
MOVEM A,$LLLST(L)
TXTC40: POPAE P,[B,A]
RET
TXTCKR:
OFFSET E-. ; Start following code at E.
TXTLUP::MOVEI B,5 ;at e, set up char cnt
MOVE D,(A) ;e+1 get a word from txt
TXTLP2::LSHC C,7 ;e+2 shift a char into c
TLZ C,400000 ;e+3 bump off sign bit
CAMN C,TXTCMS ;e+4 found nasty string yet? (crlf.crlf)
JRST TXTCH3 ;e+5 arg! yes, go correct it
SOJG B,TXTLP2 ;e+6 no, shift all of new word in (eventually)
AOBJN A,TXTLUP ;e+7 try all wds of msg txt
JRST TXTCH2 ;e+10 (15) finally exit
TXTCMS::<ASCII /
.
/>_-1 ;e+11 (16) comb. to search for, right adjusted=crlf.crlf
OFFSET 0 ; Restore normal Loc Counter.
TXTCKL==.-TXTCKR
TXTCTB: 0 ;add-in ptrs to get ptr to period, period in 3rd char position
170700,,0 ;b=1, period was in 3rd pos. of d
260700,,0 ;b=2, . was in 2nd pos. of d
350700,,0 ;b=3, . in 1st pos. of d
010677,,-1 ;b=4, . in 5th pos. of c (this gives 10700,,.-1)
100677,,-1 ;b=5, . in 4th pos. of c (this gives 100700,,.-1)
BVAR
ACSAV: BLOCK 15 ;saves only acs 1-16
AC16S: 0 ;need to save the blt-ptr acc. 'manually'
EVAR
SUBTTL Recipient list crunchers
; RCPSRT - sorts rcpts on a msg list by destination site, so
; that local are 1st, and rcpts are bunched by site. bubble sorts...
RCPSRT: PUSHAE P,[A,B,C,D,E]
RSORT1: SETZ A, ; Clear exch flag
FINDA E,[A$RCP,,[$LLLST(L)]]
JRST RSORT7 ; No rcpts at all? Tolerate...
FINDA C,[A$RHST,,[LISTAR(E)+1]]
SKIPA C,[0]
MOVE C,LISTAR(C)+1
CAMN C,OWNHST
SETZ C, ; Make sure all local site refs are made zero
RSORT2: MOVE B,C
MOVE D,E ; Make previous n+1th now nth.
HRRZ E,LISTAR(D) ; Get ptr to next
FINDA E,[A$RCP,,[E]] ; And advance to next rcpt
JRST RSORT7 ; Hmm, none left this pass
FINDA C,[A$RHST,,[LISTAR(E)+1]] ; Now get ptr for n+1-th rcpt site
SKIPA C,[0]
MOVE C,LISTAR(C)+1 ; Get site #
CAMN C,OWNHST
SETZ C,
; Now compare!
CAMG B,C ; Skip to exchange if nth greater than n+1th
JRST RSORT2 ; Else continue.
; Aha, exchange.
MOVE A,LISTAR(D)+1 ; Get A$RCP list ptr
EXCH A,LISTAR(E)+1 ; Swap with n+1th
MOVEM A,LISTAR(D)+1 ; Ptrs now swapped!
EXCH B,C ; And exch site #'s.
JUMPN A,RSORT2 ; Continue, unless
JSR AUTPSY ; gross error in A$RCP LN!
RSORT7: JUMPN A,RSORT1 ; Do another pass, til nothing exchanged.
POPAE P,[E,D,C,B,A]
RET
; RCPSEQ - returns ptr to a rcp attrib list. successive calls
; after initializing will return rcps in sequence. since list is
; supposed to have been sorted, first are returned all rcpts with
; lowest dest host numbers, then next lowest, etc.
; skips on success, fails when none left
BVAR
RCSQCT: 0 ; When this (current LP) zeroed, RCPSEQ initializes self.
RCSQLT: 0 ;holds ptr to next LN (cdr of rcsqct)
EVAR
RCPSEQ: SKIPN RCSQCT
JRST [ MOVE A,$LLLST(L) ;initialize
MOVEM A,RCSQLT
SETOM RCSQCT
JRST .+1]
SKIPG A,RCSQLT
RET ;0, none left.
FINDA A,[A$RCP,,[A]]
RET ;none left
PUSH P,B
HRRZ B,LISTAR(A) ;get cdr for next call
MOVEM B,RCSQLT
MOVE A,LISTAR(A)+1 ;return ptr to rcpt list
POP P,B
AOS (P)
RET
; UHDPUT - Output user-specified header lines, verbatim.
; By including a USER-HEADER: line in the request file, the user program
; sending the mail can have an arbitrary line inserted into the header.
; This lets it send mail containing header fields of types that COMSAT
; does not especially know about, such as In-Reply-To. There can be any
; number of USER-HEADER lines in a single mail request. (Here we output
; them in reverse order so that they appear in the same order as the
; user specified originally.)
UHDPUT: PUSHAE P,[B,C] ;Return LP value in A.
MOVE A,$LLLST(L) ;Get LP to message.
SETZ B, ;Count of user-headers.
UHDP10: FINDA A,[A$UHDR,,[A]] ;Look for a user-header SLP.
JRST UHDP20 ; Not found.
PUSH P,A ;Stack it up.
AOS B ;Count it.
HRRZ A,LISTAR(A) ;CDR ptr to next.
JRST UHDP10 ;Go after it.
UHDP20: JUMPE B,UHDP90 ;If there were any USER-HEADERs
MOVE C,A ; stash ptr to rest of message.
UHDP21: POP P,A ; Unwind stack of SLPs, outputting them.
FWRITE TMPC,[TLS,A,[
]]
SOJG B,UHDP21 ; All the way.
MOVE A,C ; Recover LP.
UHDP90: POPAE P,[C,B]
RET
SUBTTL Recipient Name Equivalencing
;;; Equivalence-table hackery
; RCPEXP - Routine that attacks current LSE as a list of message attribs
; and expands all rcpt LN's as specified by such things as EQV
; and LSR file data.
RCPEXP: PUSHAE P,[A,B,C,D]
MOVE D,$LLLST(L) ;put LP in D to step thru
CSTAT (,("EXP-"),RABR)
TRO F,%NOCOM ;set helping flag for stats
RCPXP1: FINDA D,[A$RCP,,[D]] ;find rcpt from this pt
JRST RCPXP9 ;no more, done
MOVE C,D ; Found one. Put LP in C, and
HRRZ D,LISTAR(D) ; get CDR for next pass
; C has LP to a rcpt LLN to be expanded. Take it off attrib list,
; and stuff resulting rcpts back on front of attrib list.
MOVE A,LISTAR(C)+1 ;get ptr to attrib list of the rcpt.
SETZM LISTAR(C)+1 ; and flush main list's pointer to it,
LNDEL C,$LLLST(L) ; So that it's not flushed along with A$RCP LN!
SETZM LSTSUP ;set flag to deafult to suppress listing of eqvlist
SETZM RCPSLF ;clear forced-rcpt ptr
SETZM RCPSLT ;and ptr to its type
SETZM RCPSLP ;and ptr to its list qb
SETZM RCPSLA ;and ptr to any list needing copying for descendants
CALL RCPPUT ;crunch it onto msg attrib list!
JRST RCPXP1 ;continue...
RCPXP9: CALL RCPSRT ;sort the resulting msg-attrib list.
POPAE P,[D,C,B,A]
RET
.SCALAR LSTSUP ; Flag to suppress listing of rcpts
; RCPPUT - Takes rcp attrib list, and stuffs it onto rcp-list
; if it checks out via equivalence table.
; Has side effects such as checking for *<site> MSG
; distribution specs and BUG-'s.
; Also, if recipient is on ONWHS2, mutates A$RHST to OWNHST.
; Recursive, so must save everything on stack!
RCPPUT: PUSHAE P,[A,B,C,D,RCPSLF,RCPSLT,RCPSLP,RCPSLA,RCPTRC]
MOVEI B,(P) ; Saved RCPTRC
HRL B,A
MOVEM B,RCPTRC
FINDA B,[A$RNAM,,[A]]
JSR AUTPSY
FINDA C,[A$RHST,,[A]] ; Get host.
SKIPA C,OWNHST ; If none, use OWNHST.
MOVE C,LISTAR(C)+1 ; Else get host address.
CAMN C,OWNHS2 ; Identity crisis?
MOVE C,OWNHST ; Yes, change host to connected net.
EXCH A,B
CAMN C,OWNHST ; Our own host?
CALL SLNUPR ; If rcpt on local host, make name uppercase.
EXCH A,B
TRZN F,%NOCOM
OUTCAL(SC,(","))
FINDA D,[A$RTYP,,[A]] ; If special rcpt type, so indicate in stats.
JRST RCPP20
SLNEA D,[ASCNT [NAME]]
CAIA
JRST RCPP20
CSTAT (,LPAR,TLS(D),(" "),TLS(B),RPAR,("@"),HN(C))
JRST RCPP21
RCPP20: CSTAT (,TLS(B),("@"),HN(C)) ; Record name@host#
SETZ D, ; Type is ordinary "NAME"
RCPP21: CALL RCPE ; Rcpblk name already in rcplist?
CAIA ; Yes.
JRST RCPP25
SKIPE RCPSLF ; Found it. Must check parent?
CAME C,OWNHST ; Must check, see if local first.
JRST RCPP99 ; No, ignore.
SLNE B,RCPSLF ; Matching names?
JRST RCPP99 ; No, ignore.
JUMPN D,[SKIPE RCPSLT ; Match types also
SLNE D,RCPSLT ; If not same type,
JRST RCPP99 ; ignore.
JRST .+1]
SKIPE RCPSLT ; If matched, force this rcpt into list.
JRST RCPP99
RCPP25: ;; From here on D is a flag: -1 => This is pseudo-recipient, expand it.
SETZ D, ; Zero D as flag
CAME C,OWNHST ; Local?
JRST RCPP10 ; No, store it and return. D=0.
RCPP30: ;; Local rcpt (ptr in A to rcpt's attrib list, in B to name-string LN)
;; Check options and equivalency.
PUSH P,A ; Save rcpt. attrib. list
FINDA B,[A$RTYP,,[A]] ; Find type of rcpt
JRST [ SETZ B, ? JRST RCPP31]
MOVE B,LISTAR(B)+1
ADD B,$LSLOC(L) ; Get abs SPT or zero for type.
RCPP31: FINDA A,[A$RNAM,,[A]] ; Now get name.
JSR AUTPSY
MOVE A,LISTAR(A)+1
ADD A,$LSLOC(L) ; Make abs SPT to that too.
CALL RCPEQV ; Find if on EQV list.
JRST [ POP P,A ; Nope...
JRST RCPP39]
MOVE B,A ; Save returned pointer in B
POP P,A ; and restore LP to rcpt's list.
JRST RCPP60 ; Go handle EQV list.
;; Not found on EQV. (Sometimes, fake up an EQV entry
;; and continue as if he HAD been found on EQV!)
RCPP39: FINDA B,[A$RTYP,,[A]] ; Find its type...
JRST RCPP72 ; None, assume NAME, go check INQUIR.
SLNEA B,[ASCNT [NAME]]
CAIA ; nope.
JRST RCPP72 ; Type NAME, go check INQUIR.
SLNEA B,[ASCNT [BUG]] ; BUG?
JRST RCPP42
CALL RXPBUG ;no option or eqv list. try BUG translation
JSR AUTPSY ; Should always eqv to something!!
JRST RCPP60 ; Ah so.
RCPP42: SLNEA B,[ASCNT [@FILE]] ; Indirect through file?
JRST RCPP09 ; Give up if not this either.
CALL RXPAFL ; Aha, go to expand file!
JRST RCPP6 ; Make indirect-file spec a pseudo, and
; go handle returned eqv-list in B if any.
;; Come here when we have managed to EQV to something.
;; Original rcpt. attrib. list in A, EQV list in B.
;; The first order of business is to take random options at the
;; top level of the list in B, and put them on to A.
;; Note: B is not the a$rcp but its car, i.e. a chain of both
;; options and A$RCP LLN's which are EQV-LISTs.
;; Note further that if B = 0 it means that the recipient is to
;; be made pseudo, but not expanded. (and likewise it has no options).
RCPP60: JUMPE B,RCPP6 ; Check for explicit flushing, jump if so.
PUSHAE P,[B,D]
MOVE D,$ARLOC+EQVAR ; Reference EQVAR now...
EXCH D,L ; Save current area, reference EQVAR.
CAIA
RCPP61: HRRZ B,LISTAR(B) ; Get CDR to next thing on EQV list.
JUMPE B,RCPP69
LDB C,[$LAFLD,,LISTAR(B)]
CAIE C,A$RTYP ; Ignore type attribute.
CAIN C,A$RCP ; Ignore EQV-LISTs, they get hacked later.
JRST RCPP61 ;
CAIE C,A$RNAM ; Also ignore recipient-name,
CAIN C,A$RHST ; and site spec.
JRST RCPP61
EXCH D,L ; Restore normal LSE
LNCOPY C,[D ? B] ; Copy from EQVAR to normal LSE.
HRRM A,LISTAR(C)
HRRZ A,C
EXCH D,L ; Restore EQV for reference...
JRST RCPP61 ;continue after consing onto attr list
RCPP69: EXCH D,L ; When done, restore right LSE reference.
POPAE P,[D,B]
;--------------------
; Now we have the enhanced rcpt attrib list in A, and the original
; EQV list in B. Now decide whether to actually do expansion or not.
; Currently this is a half hearted attempt to do "right" thing when
; some loser does :QSEND BUG-FOO.
RCPP05: FINDA C,[A$RMDS,,[A]] ;does rcpt have send-switch?
JRST RCPP04
SKIPLE LISTAR(C)+1 ; has switch... always mailing too?
JRST RCPP04 ; Yes, so expand list.
FINDA C,[A$RTYP,,[A]] ; May not ever mail; check type
JRST RCPP10 ; Default to NAME - don't expand list.
SLNEA C,[ASCNT [NAME]]
JRST RCPP04 ; Not type NAME, so DO expand list.
JRST RCPP10 ; NAME - don't expand list further.
;get both ptr to a name's eqvlist and its options, whichever.
;first insert options then expand eqvlist;
;if eqv-list exists, 1)gives it attrib of psuedo-name,
;2) if showlist attrib exists, gives it no-show.
RCPP04: PUSH P,L
MOVE L,$ARLOC+EQVAR ; Temporarily set LSE to EQV for search.
FINDA C,[A$RCP,,[B]] ;see if it has eqv-list
JRST [ POP P,L ? JRST RCPP70] ;no, tis atomic w/options, check INQUIR
POP P,L
FINDA C,[A$RNAM,,[A]] ;get name of current rcpt to check with parent
JSR AUTPSY
SLNE C,RCPSLF ;compare with parent
JRST RCPP6 ;nope, not same, continue.
FINDA D,[A$RTYP,,[A]] ;also compare the types
JRST .+3
SLNEA D,[ASCNT [NAME]]
JRST [ SKIPE RCPSLT
SLNE D,RCPSLT
JRST RCPP6 ;not same type
JRST .+3 ] ;winning, skip FIND-failed case
SKIPE RCPSLT
JRST RCPP6 ;not same type
SETZM RCPSLF ;ah, same! parent refers to self...clear,
MOVE D,RCPSLP ;get ptr to parent's A$RCP,
MOVE D,LISTAR(D)+1 ;get its list ptr to attribs,
MAKELN C,[A$ROPT,,0 ;and make a flag LN to add on, such that
%LTSTR,,[LITSTR [NO-CLI]]] ;it means "no cli" for this name.
LNAPP [D ? C] ; Append onto its attrib list.
SETZM RCPSLP ;clear ptr used just in case (like rcpslf)
SETZ D, ;indicate atomic
;and go store the rcpt as atomic, with given options.
;if found again, won't be stored again since rcpslf cleared.
; Come here for an atomic rcpt which needs to be checked out
; in the INQUIR database.
RCPP70: FINDA C,[A$RTYP,,[A]] ; Here when rcpt was seen in EQV; "known".
JRST RCPP71 ; Must make sure that it's type NAME.
SLNEA C,[ASCNT [NAME]]
JRST RCPP09 ; Nope, don't check INQUIR!!
RCPP71: SKIPA B,[-1] ; Indicate to RXPNAM that name was in EQV.
RCPP72: SETZ B, ; Here when rcpt not in EQV - "unknown".
CALL RXPNAM ; Check it out.
JRST RCPP09 ; Now truly atomic, store it.
JRST RCPP60 ; Hmm, got eqv'd! Go process returned eqv-list.
RCPP6: JUMPE B,[CSTAT (,("::={IGNORED}")) ; Pseudo-ing without eqv'ing.
JRST RCPP6Y]
CSTAT (,("::="),LPAR)
TRO F,%NOCOM ;don't output comma in next stat stuff
RCPP6Y: SETO D, ;set flag to process eqv-list later.
MAKELN A,[A$RPSN,,[A] ;indicate rcp is psuedo - attach pseudo attrib
%LTVAL,,[JUNK]]
FNDSTR C,A,A$ROPT,[SHOWLIST] ;does psuedo have showlist option?
JRST RCPP10 ;no, means show psuedoname, suppress its list
;yes, don't show psuedo (but show list)
JRST RCPP11 ;skip any duplicate noshow option
;; Store attrib list for this rcpt on rcp list
RCPP09: SETZ B, ; No EQV list.
RCPP10: SKIPE LSTSUP ; Hack suppression option.
RCPP11: MAKELN A,[A$ROPT,,[A] ? %LTSTR,,[LITSTR [NOSHOW]]]
SKIPE RCPSLA ;anything need copying onto it?
JRST [ LNCOPY C,[0 ? SETZ RCPSLA]
LNAPP [A ? C] ; Copy & append on.
JRST .+1]
MOVEM A,RCPTR ;save for later use
MAKELN A,[A$RCP,,[$LLLST(L)] ;make list LN for it and plug on list
%LTLST,,[A]]
MOVEM A,$LLLST(L) ;now officially on list.
AOS RCPNUM ;increment # of names in area
JUMPN D,RCPP50 ;if d=-1 then psuedo, don't increment rrcps,hack further.
AOS RRCPS ;increment # of atomic recipients
RCPP99: POPAE P,[RCPTRC,RCPSLA,RCPSLP,RCPSLT,RCPSLF,D,C,B,A]
RET
.SCALAR RCPTR ; Temp var
;here, handle a psuedo-name. b contains ptr to eqv list.
RCPP50: JUMPE B,RCPP99 ; ignore totally if nothing.
MOVEM A,RCPSLP ;store ptr to pseudo's A$RCP LN.
MOVE C,RCPTR ;get ptr to attrib-list back.
FINDA D,[A$RNAM,,[C]]
JSR AUTPSY
MOVEM D,RCPSLF ;store ptr to name of parent of this list.
SETZM RCPSLT ;also store type (ptr or zero if NAME)
FINDA D,[A$RTYP,,[C]]
CAIA
JRST [ SLNEA D,[ASCNT [NAME]]
MOVEM D,RCPSLT
JRST .+1 ]
FINDA D,[A$RMDS,,[C]] ;see if A$RMDS attrib exists, if so must
JRST RCPP51 ; ensure that it gets copied for descendants.
LNCOPY D,[0 ? D]
HRL D,RCPSLA ;push onto RCPSLA list.
HLRM D,LISTAR(D)
HRRZ D,RCPSLA
RCPP51: FINDA D,[A$RMDM,,[C]] ;see if A$RMDM attrib exists, if so must
JRST RCPP53 ; ensure that it gets copied for descendants.
LNCOPY D,[0 ? D] ;just like A$RMDS
HRL D,RCPSLA ;push onto RCPSLA list etc
HLRM D,LISTAR(D)
RCPP53: SKIPE LSTSUP ;under suppression?
JRST RCPP52 ;yes, don't bother trying to suppress again
FNDSTR C,C,A$ROPT,[SHOWLIST] ;supposed to show list?
JRST [ SETOM LSTSUP
CALL RCPEXT ;no, hence set 'noshow' for expansion items
SETZM LSTSUP ;restore
JRST RCPP55]
RCPP52: CALL RCPEXT ;takes arg in a, puts the eqv blocks into rcp list.
RCPP55: CSTAT (,RPAR)
; SKIPE A,RCPSLA ;if a list was being copied from RCPSLA,
; CALL QBFREE ;free it. (but not yet.. this will lose by clobbering
;parent's version of RCPSLA!)
JRST RCPP99 ;(note rcpext calls rcpput recursively!)
BVAR
RCPSLF: 0 ;if non-z holds ptr to name which (if found) is to be forced into list
;irregardless of previous existence or psuedoness.
RCPTRC: 0 ;linked list of A$RCP LN,,thread for rcpt expansion recursion
RCPSLT: 0 ;ptr to type of name in RCPSLF (zero if type=NAME)
RCPSLP: 0 ;holds ptr to A$RCP LN of above pseudo.
RCPSLA: 0 ;holds ptr to list of stuff which needs copying onto attrib list of
EVAR ;descendants for a rcpt. (if it is eqv'd)
; RCPEXT - takes LP to eqvlist in B, inserts all the A$RCP's into the
; attrib list. Mainly involves copying.
RCPEXT: PUSHAE P,[A,B,C]
MOVE C,$ARLOC+EQVAR ; Set up for swapping LSE's
EXCH C,L ; L gets EQVAR, C gets ex-current
CAIA
RCPXT1: HRRZ B,LISTAR(B) ; CDR to next thing on EQV list
FINDA B,[A$RCP,,[B]] ;pluck one off list
JRST RCPXT9 ;done when no more
EXCH C,L ; Get normal LSE back
LNCOPY A,[C ? SETZ LISTAR(B)+1] ; Copy what EQV-rcpt points to and leave LP in A
CALL RCPPUT ;and put it in. (yup, corecursive)
EXCH C,L ; Get EQV back.
JRST RCPXT1
RCPXT9: EXCH C,L ; Restore normal LSE.
POPAE P,[C,B,A]
RET
; Set SHITSW==1 to use HSNAME hackery.
IFNDEF SHITSW,SHITSW==1
IFE SHITSW,[
; The RXPNAM routine is called when sending to a NAME-type rcpt who is
; not found in the EQV. The algorithm is:
; 0) If the name has > 6 characters, goto 3.
; 1) If he is a UNAME in the LSR file,then
; A) If he has has a net address field, translate to that,
; B) else just send to him.
; 2) If he has a file in (INIT), a file in _MSGS_, or a directory,
; then send to him.
; 3) Look him up as a lastname in LSR1. If found, translate to all
; entries in LSR1 with that last name.
; 4) Else sender probably mistyped. Send the mail, but also send a warning
; to the sender and to "FAILED".
] ;END IFE SHITSW
IFN SHITSW,[
COMMENT |
The RXPNAM routine is called during equivalence-expansion of
the recipient list of a message, for each NAME-type rcpt
which is not found in the EQV file, so as to determine ultimate
mailbox name. Algorithm is:
[1] If name has > 6 chars, it can't be a UNAME, so:
1a. If name exists as a lastname in LSR, return eqv-list for it.
1b. Recipient unknown, send error message. Note no attempt to
send it anywhere.
[2] If UNAME is not in LSR file, then
2a. If directory exists for that UNAME, return OK.
2b. If UNAME exists as a lastname in LSR, return eqv-list for it.
2c. Find default HSNAME, append to rcpt list.
2d. See if any traces of loser (init files etc), if so return OK.
Else jump to [8] to send error message.
[3] UNAME is in LSR; if it has valid net-addr entry, return eqv-list for it.
[4] If directory exists for that UNAME, return OK.
[5] If LSR entry has "Fildir" for local machine, set that as HSNAME, return OK.
[6] Determine default HSNAME using tables, append to rcpt list, & return OK.
------
[8] Recipient is totally unknown. Unless msg is send-only, or
error msg already sent at [1b], send error message then return OK.
|] ;END IFN SHITSW
; If it skips, then B contains the EQV stuff. Else just send the message.
BVAR
RXPNRL: 0 ; LLP to rcpt list.
RXPNSP: 0 ; SLP to rcpt name
RXPNSL: 0 ; # chars in name
RXPNS6: 0 ; SIXBIT name of rcpt, even if > 6 letters in name.
RXPNEA: 0 ; LSR entry addr if any.
RXPNEX: 0 ; -1 if exists in EQV, 0 otherwise.
EVAR
RXPNAM: PUSHAE P,[RXPNEX,RXPNEA,RXPNRL,RXPNSP,RXPNSL,RXPNS6,C,D,A]
MOVEM A,RXPNRL
MOVEM B,RXPNEX ; Save EQV-existence argument.
SETZB D,RXPNS6 ; Initialize.
SETZM RXPNEA
FINDA A,[A$RNAM,,[A]]
JSR AUTPSY
MOVEM A,RXPNSP
MOVE A,LISTAR(A)+1
ADD A,$LSLOC(L)
HLRZM A,RXPNSL ; Save char cnt of name
CALL CVT76C
MOVEM A,RXPNS6 ; Save SIXBIT UNAME.
; Setup finished, start the algorithm.
MOVE B,RXPNSL ; STEP 1: Get # of chars in name.
CAIG B,6 ; If > 6, try lastname check.
JRST RXPN20 ; else can skip straight to uname check.
CALL RXPLNM ; Try looking up name as lastname...
JRST RXPN90 ; Successful, return eqv-list in B.
SETZM RXPNS6 ; Ugh, zap 6bit so RXPNER does right thing.
CALL RXPNER ; Sigh, send msg saying failed.
SETZ B, ; And return with B=0 to indicate
JRST RXPN90 ; it's considered pseudo, but doesn't expand.
RXPN20: MOVE B,RXPNS6 ; STEP 2: looks up as UNAME in LSR1.
MOVEI A,LSR1C
RXPN21: CALL LSRTNS"LSRUNM
CAIA
JRST RXPN30 ; Found as UNAME, go hack LSR entry.
JUMPE B,RXPN25 ; Not found
CAIA ; Wait for core to be available
JRST RXPN21 ; Go CORBLK sleeping...
JSR CORLOS
RXPN25: MOVE A,RXPNS6 ; STEP 2A: Not in LSR file, does it
CALL HASDIR ; have a directory?
CAIA
JRST RXPN99 ; Yes, return OK, will write to that dir.
CALL RXPLNM ; STEP 2B: check to see if lastname.
JRST RXPN90 ; Yes, return eqv-list in B!
MOVE A,RXPNS6 ; No, so on to
; STEP 2C: Look for any record of existence.
IFN SHITSW,[
SETZ B,
CALL RXPNHS ; Find HSNAME & append to rcpt list.
JRST RXPN80 ; Failed????
]
CALL HASREC ; Hunt for clues that user exists.
JRST RXPN80 ; Failed, send error message.
JRST RXPN99 ; Found loser's grimy tracks, so assume exists.
; STEP 3: Here when LSRTNS"LSRUNM has just won, i.e. loser exists
; in LSR file. Look for a NET ADDRESS.
RXPN30: MOVEM B,RXPNEA ; Save LSR entry address.
MOVEI A,LSRTNS"I$NETA
CALL LSRTNS"LSRITM ; Try to find the net address.
JRST RXPN40 ; None, so go try fildir.
MOVE B,A ; Save arg to RNETAD.
CALL LBPASZ ; Get the length of the ASCIZ string.
JUMPE A,RXPN40 ; If entry is null, ignore it.
MOVE C,RXPNSP
MOVE C,LISTAR(C)+1
ADD C,$LSLOC(L) ; Last arg is ASCNT to rcpt name.
PUSH P,L
MOVE L,$ARLOC+EQVAR ; Do any CONSing in EQVAR.
CALL RNETAD ; Try to parse it.
SETZ B, ; If loser has bad field, just ignore it.
JUMPE B,[POP P,L ; Jump if no net address.
JRST RXPN40]
;; Copy only 1 rcpt!! This hack is necessary due to inter-machine
;; INQUIR which can deliver a netaddr with two sites to BOTH sites
;; in question, causing infinite loop!
;; so, restricted to 1 site per net address.
HRRZ A,LISTAR(B) ; Is there more than 1 rcpt in list?
JUMPE A,RXPN36 ; Nope, no hair.
HLLZS LISTAR(B) ; Ugh, yes, disconnect 1st from rest of list
LNDEL A ; and delete rest of list.
RXPN36:
;; Must check for netadr exactly same as name, so that can
;; go check directory etc; if we just handed back to EQV rtns,
;; duplicate would be suppressed & we'd never come back to RXPNAM.
FINDA C,[A$RHST,,[LISTAR(B)+1]]
SKIPA A,OWNHST ; If no host, using local; OK.
MOVE A,LISTAR(C)+1 ; Get right host #
CAMN A,OWNHS2 ; Identity crisis?
JRST [ MOVE A,OWNHST ; Yes, change host to connected net.
MOVEM A,LISTAR(C)+1
JRST .+1 ]
CAME A,OWNHST ; If non-local host, return to EQV.
JRST RXPN39
FINDA C,[A$RNAM,,[LISTAR(B)+1]] ; local, so check name.
JSR AUTPSY
MOVE C,LISTAR(C)+1
ADD C,$LSLOC(L) ; Get abs ascnt ptr to new rcpt name string.
POP P,L ; now can restore LSE
MOVE A,RXPNSP ; and can use SLP to old rcpt name
USLNEA A,C ; and compare strings.
JRST RXPN90 ; If not equal, off to return EQV list.
PUSH P,L ; Equal! Must ignore...
MOVE L,$ARLOC+EQVAR ; Point back at LSE we consed the list in.
LNDEL B ; and flush it.
POP P,L ; And go to check out directory, etc.
JRST RXPN40
RXPN39: POP P,L
JRST RXPN90 ; Win return.
; STEP 4: Check for a file directory.
RXPN40: MOVE A,RXPNS6 ; Get 6bit
CALL HASDIR ; Has a directory?
CAIA
JRST RXPN99 ; Yes, return OK (will write to this dir).
; STEP 6: Determine default HSNAME when no netaddr specified, but
; user exists in INQUIR data.
RXPN60:
IFN SHITSW,[
MOVE A,RXPNS6
MOVE B,RXPNEA
CALL RXPNHS ; Eeny, meeny, miny, mo!
JFCL ; Ignore lossage.
JRST RXPN99 ; And return OK.
];SHITSW
; Here we have lost totally. We must send a warning message to the
; sender, and perhaps also to the dead-letter box. (STEP 4).
; But first, check some stuff and maybe punt the warning.
RXPN80: SKIPE RXPNEX ; Perhaps name existed in EQV?
JRST RXPN99 ; Yes, so technically "known"...
MOVE A,RXPNRL ; Get back ptr to rcpt's list.
CALL SETMSM ; Decode MAIL/QSEND modes.
SKIPE SORMSW
SKIPLE SENDSW
CAIA
JRST RXPN99 ; Not really mailing, don't bother.
TRNE MF,M%CORG ; One other thing...did we originate the msg?
JRST [ STAT (,TAB,("COMSAT-originated msg LOST TO "),TLS(RXPNSP),EOL)
JRST RXPN99] ; and do nothing if so.
MOVE A,RXPNSL
CAILE A,6
JRST RXPN82 ; (Ignore this check if name > 6 chars.)
MOVE A,RXPNS6 ; Get the SIXBIT name.
CALL USRFND ; Is he logged in at the moment?
CAIA ; No, continue.
JRST RXPN99 ; Do common-sense thing, just send...
; Here we are fully committed to sending warning, etc.
RXPN82: CALL RXPNER ; Send error message.
CAIA
RXPN90: AOS -11(P)
RXPN99: POPAE P,[A,D,C,RXPNS6,RXPNSL,RXPNSP,RXPNRL,RXPNEA,RXPNEX]
RET
; RXPNER - Auxiliary for RXPNAM that sends error message
; warning sender that recipient name is unknown.
.SCALAR RCHKTM,RXPNH6 ; Temp stuffs
RXPNER: MAKELN B,[A$RNK,,0
%LTVAL,,0]
LNAPP [RXPNRL ? B] ; Append "not known" attrib to rcpt's list.
FINDA B,[A$RHSN,,[RXPNRL]] ; See if HSNAME carried along.
SKIPA B,[SIXBIT /COMMON/] ; If not, use default.
MOVE B,LISTAR(B)+1 ; Uh huh, get it.
MOVEM B,RXPNH6 ; Save in temp variable.
OUT(TMPC,OPEN(UC$SAO),(|"|),SL(RXPNSP),(|" at |),TZ(OWNNAM),(" is an unknown recipient."))
SKIPE B,RCPTRC ; Backtrace of rcpt expansion available?
SKIPN B,(B) ; Skip the innermost (self)
JRST RXPNR1
OUT(TMPC,EOL,(" This name came from the expansion of
"))
RXPNR0: HLRZ A,B
OUT(TMPC,CALL(NSRNMO)) ; Output rcpt name
SKIPN B,(B) ; Get next
JRST RXPNR1
OUT(TMPC,(", from "))
JRST RXPNR0
RXPNR1: SKIPE RXPNS6 ; If name not too long, will try anyway
OUTCAL(TMPC,EOL,TAB,(|Will try sending to the file "|),6F(RXPNH6),(";"),6F(RXPNS6),(| MAIL".|))
MAKELN B,[A$RRMG,,0 ? %LTSAO,,] ; Pack up output into a LN
LNAPP [RXPNRL ? B] ; Append onto list of rcpt.
AOS NRXPER ; Increment cnt of errors.
RET
; RXPLNM - Auxiliary to RXPNAM, sees if rcpt name is a lastname and
; if so conses up an eqv-list for it. References RXPNSP,
; clobbers A,B,C,D. Returns eqv-list ptr in B and DOESN'T skip if
; successful.
RXPLNM: SAOBEG TMPC,
OUT(TMPC,TLS(RXPNSP)) ; Copy name,
OUT(TMPC,TC([5,,[0]])) ; followed by 5 nulls to ensure fully asciz'd.
MAKELN C,[0 ? %LTSAO,,] ; Make SLN of it.
MOVE A,LISTAR(C)+1
ADD A,$LSLOC(L) ; get abs ascnt to string,
CALL UPPRZ ; uppercasify it,
HRRZ B,A ; and give location as arg to LSRLNM.
MOVEI A,LSR1C
CALL LSRTNS"LSRLNM
JRST [ LNDEL C, ; Too bad. Make sure temp SLN flushed.
AOS (P) ; and take failure (skipping!) return.
RET]
LNDEL C,
; Now B/ AOBJN to words with file addresses of LSR1 entries.
PUSH P,L ; CONS up fake EQV in EQVAR!
MOVE L,$ARLOC+EQVAR
MOVE C,B
RXPLN3: MOVEI A,LSR1C
HRRZ B,(C) ; Get address in file of this entry.
CALL LSRTNS"LSRGET ; Returns core address in B.
JSR AUTPSY
MOVEI A,LSRTNS"I$UNAM ; We want the UNAME.
CALL LSRTNS"LSRITM ; Gets B.P. in A to string.
JSR AUTPSY
MOVE B,A ; Save the BP in B.
CALL LBPASZ ; Get length of ASCIZ string in A.
HRLZ A,A
HRRI A,B ; A / <# chars>,,[BP to string]
MAKELN A,[A$RNAM,,0 ; Make an SLP of the name,
%LTBPT,,[A]]
MAKELN D,[A$RCP,,[D] ; and CONS it onto the list.
%LTLST,,[A]]
AOBJN C,RXPLN3
MOVE B,D ; And return the EQV stuff in B.
POP P,L
RET ; Win return doesn't skip!
IFN SHITSW,[
; RXPNHS - RXPNAM utility; Append HSNAME attrib onto rcpt list.
; A/ UNAME
; B/ <LSR entry addr> ; if 0 assumes tourist.
; Skips on success, with HSNAME in B.
RXPNHS: PUSHAE P,[C,D]
SETZ C,
MOVEI D,DKIC ; Use this as temp chan if need to.
CALL LSRTNS"LSRHSN ; Look up HSNAME, hacking fildir etc.
JRST RXPNH9
MAKELN C,[A$RHSN,,0 ; Got it in D, store in a LN.
%LTVAL,,[D]]
LNAPP [RXPNRL ? C] ; Append "Hsname" attrib to rcpt's list.
AOS -2(P)
RXPNH9: POPAE P,[D,C]
RET
]
SUBTTL Auxiliary routines for RXPNAM: RNETAD, HASREC, etc.
; RNETAD - Routine given ASCNT ptr in C to a rcpt name, with
; count in A, BP in B to a string
; which is to be parsed as an INQUIR NETADR field,
; i.e. a standard rcpt list with exception that
; names without @'s are taken to be site names!
; Skip returns in B a LP to list of whatever rcpts result,
; consed in the current LSE. If B/ 0, no rcpts.
RNETAD: PUSHAE P,[A,C,D,E]
CALL RCPGBA ; Enter RCPGOB at special place.
CAIE B,0
JRST RNTD95 ; Return unsuccessfully - error.
JUMPE A,[SETZ B,
JRST RNTD90] ; Nothing there? Succeed anyway.
MOVE B,A ; Aha, save stuff
MOVE D,A ; Keep current in D
CAIA
RNTD10: HRRZ D,LISTAR(D)
JUMPE D,RNTD90
MOVE A,LISTAR(D)+1 ; Get LP to rcpt's list
MOVE E,LISTAR(A) ; Get 1st wd of 1st LP pointed to
TRNE E,-1 ; Is there a CDR, i.e. more than one LN?
JRST RNTD10 ; Yes, it must be OK.
LDB E,[$LAFLD,,E] ; Only one! Make sure it's an RNAM...
CAIE E,A$RNAM
JSR AUTPSY ; Glub? EQRCPL returned no-name rcpt??
CALL HMATCH ; Try to get site #.
JRST RNTD95 ; Uh-oh, error!
PUSH P,B
CAMN A,OWNHST
JRST [ HRRZ B,LISTAR(B)+1 ;Just points to self,
JUMPE B,.+1 ;don't count (makes JPG happy)
POP P,B
JRST RNTD95 ]
POP P,B
LNDEL LISTAR(D)+1 ; Flush the list for this rcpt
MAKELN A,[A$RHST,,0 ? %LTVAL,,[A]] ; Make a RHST LN and
MAKELN A,[A$RNAM,,[A] ; plug onto a new RNAM LN, using name given.
%LTSTR,,[C]]
MOVEM A,LISTAR(D)+1 ; And make THAT the rcpt list!
JRST RNTD10 ; Back for another.
RNTD90: AOS -4(P)
RNTD95: POPAE P,[E,D,C,A]
RET
; HASREC - Takes 6bit name in A, tries to find evidence of presence
; on system by looking for file dir, INIT file, _MSGS_ file.
; B/ HSNAME (only if SHITSW on)
; Skips if found something.
; Note: err codes 23 (File locked), 27 (Link depth exceeded)
; and 47 (Link to non-ex file) all imply some kind of existence,
; but no others.
HASREC: PUSH P,C
IFE SHITSW, MOVE C,[-3,,[FILINI ? FILDIN ? FILMSG]]
IFN SHITSW, MOVE C,[-1,,[FILHSN]]
HASRC2: ECALL @(C),[[23,HASRC7],[27,HASRC7],[47,HASRC7]]
CAIA
JRST HASRC7
AOBJN C,HASRC2
PJRST POPCJ ; Lose, none worked.
HASRC7: .CLOSE DKIC, ; Win, found something.
PJRST POPCJ1
IFN SHITSW,[
FILHSN: SETZ ? SIXBIT/OPEN/ ? [DKIC] ? ['DSK,,0]
A ? [SIXBIT />/] ? SETZ B
]
FILINI: SETZ ? SIXBIT/OPEN/ ? [DKIC] ? ['DSK,,0]
A ? [SIXBIT />/] ? SETZ [SIXBIT /(INIT)/]
FILDIN: SETZ ? SIXBIT/OPEN/ ? [DKIC] ? ['DSK,,0]
A ? [SIXBIT />/] ? SETZ [SIXBIT /DDTINI/]
FILMSG: SETZ ? SIXBIT/OPEN/ ? [DKIC] ? ['DSK,,0]
[SIXBIT /_MSGS_/] ? A ? SETZ [SIXBIT /_MSGS_/]
; HASDIR - Takes sixbit name in A, skips if has a file dir.
HASDIR: .CALL FILDIR
RET ; Any error means nope.
.CLOSE DKIC,
AOS (P)
RET
FILDIR: SETZ ? SIXBIT/OPEN/ ? [DKIC] ? ['DSK,,0]
[SIXBIT /.FILE./] ? [SIXBIT/(DIR)/] ? SETZ A
; RXPAFL - Routine to hack a name of type @FILE, which reads
; specified file and interprets as a distribution list.
; Errors are put into an A$RRMG SLN for the indirect-file rcpt spec.
; Shares routines with EQVGOB!!
; A/ LLP to rcpt attrib list
; Returns
; B/ LLP to list of rcpt LLNs (an EQV list), or 0 if none.
RXPAFL: PUSHAE P,[A,C,D]
MOVE C,A ; Save ptr
FINDA A,[A$RNAM,,[C]]
JSR AUTPSY
MOVE A,LISTAR(A)+1
ADD A,$LSLOC(L)
MOVE B,[LMFDEF,,LMFDEV]
CALL FILPAR
MOVEI A,LMFDEV
CALL OPNFLI
JRST [OUT(TMPC,OPEN(UC$SAO),("Could not open the file "),6F(LMFDEV),(":"),6F(LMFDIR),(";"),6F(LMFFN1),(" "),6F(LMFFN2),( "because "),ERR)
SETZ A, ; Say no list to return.
JRST RXPA70]
MOVSI A,IMSAR
CALL TXFIN ; Read the file into IMSAR
MOVEI A,IMSAR
PUSH P,L
MOVE L,$ARLOC+EQVAR ; Parse the file contents into EQV list area
; (this eventually causes gronkage, so
; maybe change someday to use temp list area?)
CALL RCPGOB ; Gobble up the rcpts!
POP P,L ; Restore list area for rcpt attribs
JUMPE B,RXPA90 ; If no errors, can just return!
; If any errors, preserve them.
OUT(TMPC,OPEN(UC$SAO),("------ "),D(B),(" error"))
CAILE B,1
OUTCAL(TMPC,("s"))
OUT(TMPC,(" trying to parse the file "),6F(LMFDEV),(":"),6F(LMFDIR),(";"),6F(LMFFN1),(" "),6F(LMFFN2),EOL,TA(ETXTAR),(" ------"))
; There was an error processing this @FILE.
RXPA70: MAKELN B,[A$RRMG,,0 ? %LTSAO,,] ; Pack up output into a LN.
LNAPP [C ? B] ; Append onto rcpt's attrib list.
AOS NRXPER ; Increment count of errors.
RXPA90: MOVE B,A ; Return parsed list if any.
POPAE P,[D,C,A]
RET
; RCPE - Find recipient on EQV.
; A/ ptr to rcpt attrib list
; Doesn't skip if it finds another rcpt attrib list with same A$RNAM,
; A$RTYP, and A$RHST. (A$RNAM forced to uppercase unless A$RHST is Multics)
; Skips if unique, i.e. didn't find.
.SCALAR RCPECT ; Flag for type of compare
RCPE: PUSHAE P,[A,B,C,D,E]
MOVE B,A ;save ptr in b
FINDA C,[A$RHST,,[B]] ;ptr to site #
SKIPA A,OWNHST
MOVE A,LISTAR(C)+1 ;get host #
MOVE D,A ;save host number for compare later
SETOM RCPECT ;If Host is Multics, compare type -1=no uc force
CALL NHMLTX ;Skip if host is Multics
SETZM RCPECT ;set compare type 0=uc force
MOVE A,B ;restore A in case used below
FINDA C,[A$RNAM,,[B]] ;ptr to name
JSR AUTPSY
FINDA E,[A$RTYP,,[B]] ;ptr to type
TDZA E,E ;zero if type is missing
JRST [ SLNEA E,[ASCNT [NAME]] ;or NAME
JRST .+1
SETZ E,
JRST .+1 ]
SETZM RCSQCT ;initialize rcpseq
RCPE1: CALL RCPSEQ ;get ptr to a rcpt attr-list
JRST RCPE8 ;won, didn't find
FINDA B,[A$RHST,,[A]] ;get ptr to host
SKIPA B,OWNHST
MOVE B,LISTAR(B)+1 ;get #
CAME B,D ;compare
JRST RCPE1 ;diff.
FINDA B,[A$RTYP,,[A]] ;compare types
JRST [ JUMPE E,RCPE2 ;both missing (default to NAME)
JRST RCPE1 ] ;unequal
JUMPE E,[ SLNEA B,[ASCNT [NAME]]
JRST RCPE1 ;unequal
JRST RCPE2 ] ;equal
SLNE B,E
JRST RCPE1 ;unequal
RCPE2: FINDA B,[A$RNAM,,[A]] ;ptr to name
JRST RCPE1
SKIPE RCPECT ;skip if uc force.
JRST [ SLNE B,C ;no, avoid uppercase force
JRST RCPE1 ;unequal
JRST RCPE9] ;equal
USLNE B,C ;compare strings, with uppercase force
JRST RCPE1 ;no match, keep looking
JRST RCPE9 ;match, return w/o skipping (not unique)
RCPE8: AOS -5(P) ;unique
RCPE9: POPAE P,[E,D,C,B,A] ;not unique
RET
; RCPEQV - takes ASCNT ptr in A to rcpt name, ASCNT ptr in B to rcpt type
; (or 0 for default normal) and searches EQV-list for match.
; If finds entry, skips with LP in A to its list.
RCPEQV: PUSHAE P,[B,C,D,E,L]
SKIPN $AROPN+EQVAR ; Ensure open.
CALL EQVGET
MOVE L,$ARLOC+EQVAR ; Make it current LSE
JUMPE B,[SETZ D,
MOVE B,[ASCNT [NAME]]
JRST RCPEQ0]
HLRZ D,B ; See if type is NAME.
CAIN D,4
JRST [ MOVE D,(B)
TRZ D,377
CAME D,[ASCII/NAME/]
JRST .+1 ; nope.
SETZ D,
JRST RCPEQ0] ; Yep...
SETO D,
RCPEQ0: HRRZ E,$LLLST(L) ;get ptr to eqv list
CAIA
RCPEQ1: HRRZ E,LISTAR(E) ; Get CDR to next to try.
JUMPE E,RCPEQ9 ; None left? Fail.
FINDA C,[A$RNAM,,[LISTAR(E)+1]] ;find ptr to name
JRST RCPEQ1 ; No name? Oh well
USLNEA C,A ; Compare strings
JRST RCPEQ1 ; No match, try another.
FINDA C,[A$RTYP,,[LISTAR(E)+1]] ; Else find type
JRST [JUMPE D,RCPEQ7 ; If no type, win if desired is NAME.
JRST RCPEQ1]
USLNEA C,B ; Compare types.
JRST RCPEQ1 ; Uh-oh, not same type.
RCPEQ7: MOVE A,LISTAR(E)+1 ; Match! get ptr to all of eqv list
AOS -5(P)
RCPEQ9: POPAE P,[L,E,D,C,B]
RET
; RXPBUG - kludge routine, called when BUG type rcpt has no entry in eqv table.
; Conses up an extra rcpt that points to (BUG RANDOM-PROGRAM).
; This ensures all BUG's wind up someplace...
RXPBUG: PUSHAE P,[C,D,L]
MOVE B,L ; Save LSE pointer in B for LNCOPY later.
FINDA C,[A$RNAM,,[A]] ; First make sure we aren't recursing.
JSR AUTPSY
SLNEA C,[ASCNT [RANDOM-PROGRAM]]
CAIA
JRST [SETZ B, ? JRST RXPB90] ; Yikes, recursing! Just ignore...
MOVE L,$ARLOC+EQVAR ; All stuff must be CONSed in EQVAR.
MOVE D,BUGHST ; Are we the magic host on which most program
CAME D,OWNHS2
CAMN D,OWNHST ; maintainers reside?
JRST RXPB50 ; Yes, send to (BUG RANDOM-PROGRAM)
LNCOPY C,[B ? C] ; No, forward the mail to that host.
MAKELN C,[A$RHST,,[C]
%LTVAL,,[BUGHST]]
MAKELN C,[A$RTYP,,[C]
%LTSTR,,[LITSTR [BUG]]]
JRST RXPB60 ; Cons up A$RCP and return.
RXPB50: MAKELN C,[A$RTYP,,0 ; This is the host. Forward to various people.
%LTSTR,,[LITSTR [BUG]]]
MAKELN C,[A$RNAM,,[C]
%LTSTR,,[LITSTR [RANDOM-PROGRAM]]]
RXPB60: MAKELN B,[A$RCP,,0
%LTLST,,[C]]
RXPB90: AOS -3(P)
POPAE P,[L,D,C]
RET
;; Kludge -- magic host address which can deal with BUG-RANDOM-PROGRAM
BUGHST: HN$MC ; MC.LCS.MIT.EDU this week...
SUBTTL RXPERR - send error message after expansion/header.
; RXPERR - Scans through MSG LSE and generates an error message
; addressed to sender, incorporating all errors encountered
; during rcpt expansion and header generation. Should
; only be called if NRXPER (# errs seen) is positive.
; Errors are stored in A$RRMG attribs of rcpts.
; The way to express an error, but not send anything, is to
; make the rcpt pseudo; such rcpts will be converted to A$RDON.
RXPERR: PUSHAE P,[A,B,C,D,E]
UARPUSH EMSGAR ; Might as well be robust.
SKIPA E,$LLLST(L)
RXPE10: HRRZ E,LISTAR(E)
FINDA E,[A$RCP,,[E]] ; Find a rcpt.
JRST RXPE70 ; No more? Go hack rest of msg.
FINDA A,[A$RRMG,,[LISTAR(E)+1]] ; Has err msg?
JRST RXPE10 ; Nope, get another rcpt.
; Have rcpt with err msg...
SKIPN $ARLOC+EMSGAR ; If nec, open EMSGAR LSE and chan thereto.
OUTCAL(TMPC,CALL(EMSOPN),("============ A copy of your message is being returned, because: ============"),EOL)
OUT(TMPC,SL(A),EOL) ; Simply output the text.
FINDA A,[A$RPSN,,[LISTAR(E)+1]] ; Is this "rcpt" a pseudo?
JRST RXPE10 ; No, just leave alone. Get another...
MOVEI A,A$RDON ; Yes, so smash it right here...
DPB A,[$LAFLD,,LISTAR(E)] ; Smash!
JRST RXPE10 ; Now go get another.
RXPE70: SKIPN $ARLOC+EMSGAR
JRST RXPE90 ; No message at all, just return.
FINDA A,[A$MTXT,,[$LLLST(L)]] ; Find ptr to msg-txt LN
JSR AUTPSY
FINDA B,[A$MHDR,,[$LLLST(L)]] ; and ptr to default header
SETZ B,
OUT(TMPC,("============ Failed message follows: ============
"),SL(B),SL(A))
CALL EMSSND ; Now go send the message!
RXPE90: UARPOP EMSGAR
POPAE P,[E,D,C,B,A]
RET
SUBTTL RCPSND - send message to all rcpts on list
;;; Takes ptr in L to a msg attrib list and sends to all rcpts listed,
;;; with no equivalencing nor header. Will queue unless otherwise
;;; specified if temporarily unable to send. After each result, adds the
;;; feature of "failed" or "sent" or "queued" to that rcpt.
.SCALAR RSNDQD,RSNDFL,NDLAST
RCPSND: PUSHAE P,[A,B,C,D,E,RSNDQD,RSNDFL]
TRZ F,%RBHD
SETZM RSNDQD ; Clear 'a msg queued' flag
SETZM RSNDFL ; Clear 'a msg failed' flag.
SETZ N,
SETOM NDLAST
SKIPA E,$LLLST(L)
RSND01: HRRZ E,LISTAR(E) ; Get CDR to next msg attrib
FINDA E,[A$RCP,,[E]] ; Get recipient list there.
JRST RSND50 ; No more, all done.
MOVE D,LISTAR(E)+1 ; Get ptr to rcpt's list.
FINDA A,[A$RPSN,,[D]] ; Is this a psuedo?
JRST RSND05 ; No, OK to send.
;; Here we have a psuedo recipient. (Probably going to CLI to it.)
FNDSTR B,A,A$ROPT,[NO-CLI] ; First, look for "no CLI" flag.
CAIA
JRST RSND01
FINDA A,[A$RNAM,,[D]] ; Get LN to recipient name.
JSR AUTPSY
HLRZ B,LISTAR(A)+1 ; How long is the name?
CAILE B,6 ; If it is longer than six chars
JRST RSND01 ; it can't possibly be a UNAME.
FINDA B,[A$RTYP,,[D]] ; Get recipient type.
JRST RSND02
USLNEA B,[ASCNT [NAME]] ; It should be NAME.
JRST RSND01
RSND02: FINDA B,[A$SNM,,[$LLLST(L)]] ; Get the sender's name.
JSR AUTPSY
USLNE A,B ; Check for sending to sender...
CAIA
JRST RSND01 ; Names equal, don't send. KLH mailing to KLH.
FINDA B,[A$CSN,,[$LLLST(L)]] ; Another check for sending to sender!
JRST RSND04 ; If no CLAIMED-FROM, go ahead.
USLNE A,B ; Else must check it too.
CAIA ; Don't send. KLH0 is mailing to KLH.
JRST RSND01
RSND04: CALL CVLS6 ; Cvt list string into 6bit in A.
MOVE B,D ; B holds LP to rcpt's list.
CALL CLIOPT ; Now send to all matching x/unames
NOP
JRST RSND01 ; Done.
;; Here we have an active recipient!
RSND05: MOVE A,D ; Get recipient list in A.
CALL SETMSM ; Find service required (mail or send).
FINDA N,[A$RHST,,[D]] ; Find recipient's host.
SKIPA N,[0] ; Zero = local.
MOVE N,LISTAR(N)+1 ; Get host #.
CAMN N,OWNHS2 ; Last chance for schizophrenia.
MOVE N,OWNHST
CAMN N,OWNHST ; If this host is ourselves
SETZ N, ; force to special "local" # of zero.
CALL NETPTH ; Find path to host.
JRST [ SKIPN N ; Already connected!
PSTAT (,(" Local-"),RABR,HST(OWNHST))
JRST RSND20 ]
CAMN N,NDLAST ; Need reconnection.
JRST RSND01 ; But don't try same site twice in a row.
RSND10: CALL NTDISC ; Disconnect.
MOVEM N,NDLAST ; Remember most recent host tried.
CALL NETICP ; Attempt connection to host N.
JRST [ AOS RSNDQD ; Net failure, bah. Ensure stuff queued.
JRST RSND01] ; and go round again.
RSND20: CALL NETSND ; Send to all rcpts this host and say byebye.
NOP ; Net failure doesn't matter here.
MOVE A,NSCTQ ; Get # queued
ADDM A,RSNDQD ; Add into sum.
MOVE A,NSCTF ; Get # failed
ADDM A,RSNDFL ; Likewise.
JRST RSND01 ; Then go back for another round.
;; All done with sending. See if anything needs to be queued, etc.
RSND50: CALL NTDISC ; Close any open net conns
; This little instruction is VERY IMPORTANT - it limits
; recursion to one level only, thus allowing the hack of MSGAR and
; EMSGAR to win! Since MAIL sends all its stuff with RCPSND,
; this will catch all such recursive attempts. (e.g. if a failure
; message itself gets an error) Any attempt to enable more
; levels must use a more flexible "current message LSE" scheme.
MOVEI A,MF%SNT+MF%QUD+MF%FAI
TRNN MF,M%CORG ; If comsat originated, don't
CALL MSGFIN ; "finalize" message by sending receipts.
SKIPLE RSNDQD ; If any msgs were queued,
CALL QUEUE ; then queue the MSG-LSE.
RSND95: POPAE P,[RSNDFL,RSNDQD,E,D,C,B,A]
RET
-
SUBTTL Message Finalization (receipt generation/sending)
; MSGFIN - Scan msg rcpts and compose a confirmation msg if
; necessary, according to flags.
; A - flags. Ask for maximum; sender options may limit what
; actually can be used.
MF%SNT==:1 ; Sent.
MF%QSNT==:2 ; Queued-sent.
MF%QUD==:4 ; Queued.
MF%FAI==:10 ; Failed.
MF%KIL==:20 ; Manually killed
MSGFIN: PUSHAE P,[A,B,C,D,NSCTS,NSCTQ,NSCTF]
; First see what flags need censoring.
FNDSTR B,$LLLST(L),A$CNF,[ALL]
JRST [ FNDSTR B,$LLLST(L),A$CNF,[FAIL] ; ALL not allowed. FAIL only?
TRZA A,MF%SNT ; Neither ALL nor FAIL, only QUD/FAI allowed.
ANDI A,MF%FAI+MF%KIL ; Only FAIL allowed.
JRST .+1]
MOVE C,A ; Get flags out of way.
UARPUSH EMSGAR ; Crock, ensure closed since will check later.
IRP FLG,,[SNT,QSNT,QUD,FAI]ATTR,,[A$RSNT,A$RSNT,A$RCP,A$RCPF]MSG,,[Sent to,Queued msg sent to,Queued,FAILED]
TRNE C,MF%!FLG ; Flag set?
CALL [ MOVEI A,ATTR
MOVE B,[ASCNT [MSG: ]]
CALRET RSNREP]
TERMIN
TRNN C,MF%KIL
JRST MSGF40
SKIPN $AROPN+EMSGAR
OUTCAL(TMPC,CALL(EMSOPN)) ; Open EMSGAR LSE & setup channel.
OUT(TMPC,("This message was manually killed by Comsat maintainers."),CRLF())
MSGF40: TRNE C,MF%FAI ; If hacked failed rcpts
CAIG A, ; and at least one DID fail, include msg text.
JRST MSGF50 ; Nope, needn't include text.
FINDA A,[A$MTXT,,[$LLLST(L)]] ; Find ptr to msg-txt LN
JSR AUTPSY
FINDA B,[A$MHDR,,[$LLLST(L)]] ; and ptr to default header
SETZ B,
OUT(TMPC,(" Failed message follows:
-------
"),SL(B),SL(A))
MSGF50: SKIPN $AROPN+EMSGAR ; Now send the confirmation msg if any
JRST MSGF90 ; Not there, nothing to send.
CALL EMSSND ; Send EMSGAR, with stuff from current LSE.
MSGF90: UARPOP EMSGAR
CALL MSGFDN ; Change appropriate stuff to "done".
POPAE P,[NSCTF,NSCTQ,NSCTS,D,C,B,A]
RET
; MSGFDN - Mark all A$RCPF's and A$RSNT's "done"; ditto pseudos.
; L - message LSE.
MSGFDN: PUSHAE P,[A,B]
MOVE A,$LLLST(L)
MOVEI B,MSGFD2
CALL MAPC
JSR AUTPSY
POPAE P,[B,A]
RET
MSGFD2: LDB B,[$LAFLD,,LISTAR(A)] ; Get attrib
CAIE B,A$RSNT
CAIN B,A$RCPF
JRST MSGFD5
CAIE B,A$RCP
PJRST POPJ1
FINDA B,[A$RPSN,,[LISTAR(A)+1]] ; See if pseudo; hack it too!
PJRST POPJ1
MSGFD5: MOVEI B,A$RDON
DPB B,[$LAFLD,,LISTAR(A)]
TLO F,%MSGMD
PJRST POPJ1
; RSNREP - Subroutine for MSGFIN. Given an attribute, output a header string
; followed by the names of all rcpts with that attribute, plus each
; rcpt's A$RRMG if any.
; A - Attrib code
; B - ASCNT ptr to heading string
; Returns
; A - # rcpts that matched.
.SCALAR RSNTY ; Save ASCNT heading string.
.SCALAR RSNCMP ; Used to compose FINDA arg.
.SCALAR RSNCNT ; # rcpts found.
.SCALAR RSNSW ; switch for prettification (comma etc)
; -1 nothing on line, 0 header only, +n header & rcpts.
RSNREP: PUSHAE P,[B,C,D,E,L]
SETOM RSNSW
SETZM RSNCNT
MOVEM B,RSNTY ; Save heading string
HRLZS A ; put attrib in LH
HRRI A,[D] ; and addr of addr of LP in RH.
MOVEM A,RSNCMP
SKIPA D,$LLLST(L)
RSNRP1: HRRZ D,LISTAR(D)
FINDA D,RSNCMP
JRST RSNRP2 ; No more...
FINDA A,[A$RPSN,,[LISTAR(D)+1]] ; Is it a pseudo?
CAIA
JRST RSNRP1 ; Ignore it if so.
; Have a rcpt, make sure set up for output.
SKIPN $AROPN+EMSGAR
OUTCAL(TMPC,CALL(EMSOPN)) ; Open EMSGAR LSE & setup channel.
AOS RSNCNT ; Bump cnt of # rcpts hit.
FINDA B,[A$RRMG,,[LISTAR(D)+1]] ; See if err msg there
TDZA B,B
JRST [SKIPLE RSNSW ; If something already on line,
OUTCAL(TMPC,EOL) ; must get new one.
SETOM RSNSW
JRST .+1]
SKIPGE RSNSW
OUTCAL(TMPC,TC(RSNTY)) ; First time, show heading.
AOSLE RSNSW ; Say heading there; if already a rcpt,
OUTCAL(TMPC,(", ")) ; split off from it.
MOVE A,LISTAR(D)+1
CALL NSRNAM ; This will do for now.
FINDA C,[A$RHST,,[LISTAR(D)+1]]
SKIPA C,[0]
MOVE C,LISTAR(C)+1
OUT(TMPC,SL(A),(" at "),HST(C))
CAIGE A, ; Must flush the SLN if NSRNAM says temporary.
LNDEL A,
JUMPE B,RSNRP1
OUTCAL(TMPC,("; "),SL(B),EOL)
SETOM RSNSW ; Moved to new line.
JRST RSNRP1
RSNRP2: SKIPL RSNSW
OUTCAL(TMPC,EOL)
MOVE A,RSNCNT ; Return # rcpts output.
POPAE P,[L,E,D,C,B]
RET
; EMSOPN - Auxiliary to open EMSGAR LSE and string-area output channel.
; Uses standard output chan for generality.
EMSOPN: PUSHAE P,[A,L]
MOVEI A,EMSGAR
CALL LSEOPN
MOVE L,$ARLOC+EMSGAR
OUT(,OPEN(UC$SAO)) ; Open std output for string-area output.
POPAE P,[L,A]
RET
; EMSSND - Assumes EMSGAR contains a LSE which has been accumulating SAO
; type output. Finalizes and sends text to "sender" as determined
; by attribs of current LSE.
;;; (Should DEAD-MAIL-RECEIPTS be an optional list? Could check RCPEQV...)
EMSSND: PUSHAE P,[A,B,C,D]
FINDA D,[A$TIM,,[$LLLST(L)]]
JSR AUTPSY
MOVE D,LISTAR(D)+1 ; Save time of msg in question
CALL SNMRCP ; Find someone to give error receipt to.
CAIA
JRST EMSS10
;; Final sink used when nobody to give the receipt to.
MAKELN B,[A$RNAM,,0 ? %LTSTR,,[LITSTR [DEAD-MAIL-RECEIPTS]]]
MAKELN A,[A$RCP,,[A] ? %LTLST,,[B]]
EMSS10: MOVE B,A ; Save LP to A$RCP in B.
PUSH P,L
MOVE C,L ; Also save L in C
MOVE L,$ARLOC+EMSGAR
MAKELN A,[A$MTXT,,0 ; Create message text. make text LN
%LTSAO,,] ; of output thus far.
LNCOPY B,[C ? SETZ B] ; Copy A$RCP(s) to use from old LSE.
HRRM B,LISTAR(A) ; Append onto 1st LN (text).
MAKELN A,[A$CNF,,[A] ; Inhibit sent-confirmations if it gets queued
%LTSTR,,[LITSTR [FAIL]]]
MOVEM A,$LLLST(L) ; All set now... finalize list.
STAT (,(" CMSG "))
MOVE B,D ; Set up time
;; Save state of RCPEXP.
PUSHAE P,[MF,RCPSLF,RCPSLT,RCPSLP,RCPSLA,RCPTRC,LSTSUP]
SETZM RCPTRC
MOVEI MF,M%CORG\M%SSBJ+M%EMSG
CALL MAIL
JFCL
POPAE P,[LSTSUP,RCPTRC,RCPSLA,RCPSLP,RCPSLT,RCPSLF,MF]
POP P,L
EMSS99: POPAE P,[D,C,B,A]
RET
; QUEUE - Queues message in MSGAR.
; What this does is to call QUEHST once for every host for which
; some rcpt got a temporary error.
; This is only called from RCPSND. So at this point all
; expansion has been done, and some RCPT-LISTs have been changed to
; RCPT-LIST-FAILED and RCPT-LIST-SENT.
LVAR QUEUEN: -1 ; Last host for which we called QUEHST
QUEUE: PUSHAE P,[A,B,C,L]
MOVE L,$ARLOC+MSGAR
CALL RCPSRT ; (KLH is paranoid) (so am I -- dlw)
SETOM QUEUEN ; Presumably there is not host "-1"...
SKIPA C,$LLLST(L)
QUEUE2: HRRZ C,LISTAR(C)
FINDA C,[A$RCP,,[C]]
JRST QUEUE6 ; No more rcpt's
FINDA A,[A$RPSN,,[LISTAR(C)+1]] ; Make sure it's a "live" one,
CAIA ; not pseudo.
JRST QUEUE2 ; Bleah, a pseudo. Ignore.
FINDA A,[A$RHST,,[LISTAR(C)+1]]
TDCA A,A
MOVE A,LISTAR(A)+1
CAMN A,OWNHST ;If local host, send locally.
SETZ A, ;This is important to avoid looping with server.
CAMN A,QUEUEN ; Same host as last time?
JRST QUEUE2 ; Yes, don't do it twice!! (Depends on RCPSRT working)
MOVEM A,QUEUEN ; (Remember for next time).
FINDA B,[A$ID,,[$LLLST(L)]]
JSR AUTPSY
CALL QUEHST ; Make QML entry for this site.
JRST QUEUE2
QUEUE6: TLNE F,%QMLMD ; QML modified?
SKIPE MKQFLG ; And in normal mode?
JRST QUEUE9 ; No, no writing necessary
CALL MSGPUT
CALL QMLPUT
QUEUE9: POPAE P,[L,C,B,A]
RET
; QUEHST - Given site # in A, SLP in B to MSG ID in current LSE,
; makes entry on QML for specified site and MSG.
QUEHST: PUSHAE P,[A,B,C,D,L]
MOVE B,LISTAR(B)+1 ; Get SPT
ADD B,$LSLOC(L) ; Make abs.
SKIPN $AROPN+QMLAR ; Ensure that
CALL QMLGET ; QML is in core.
MOVE L,$ARLOC+QMLAR ; Make it current LSE
MAKELN B,[A$ID,,0 ? %LTSTR,,[B]] ; Cons up LN for ID.
STAT (,("Queued: "),TLS(B),(" for "),HST(A))
HRRZ D,$LLLST(L) ; Get LP to start of QML
JUMPN D,QUEHS3
JRST QUEHS7
QUEHS2: HRRZ D,LISTAR(D) ; Get CDR to next
JUMPE D,QUEHS7 ; Not found?
QUEHS3: MOVE C,LISTAR(D)+1 ; Get LP to sitelist.
MOVE C,LISTAR(C)+1 ; Get site #
CAME A,C ; Check...
JRST QUEHS2 ; Nope, try another site.
; Found existing sitelist for host. Append to that...
LNAPP [LISTAR(D)+1 ? B]
JRST QUEHS9 ; No need to schedule since request msut already exist.
; No existing sitelist, must make one.
QUEHS7: MOVE C,A ; Save site # in C
MAKELN A,[A$QHST,,[B] ; Cons up LN for site # as first thing in sitelist.
%LTVAL,,[C]]
MAKELN A,[A$Q,,[$LLLST(L)] ; And now a LLN for whole thing.
%LTLST,,[A]]
MOVEM A,$LLLST(L) ; Store LP back, new sitelist is now consed onto front.
MOVE A,QTMLEN ; Now must generate schedule request for unqueueing.
MOVEI B,QUESND ; And routine addr to XCT in B. Arg already in C.
CALL SCHDI ; Schedule for c(QTMLEN) 30'ths from now.
QUEHS9: TLO F,%QMLMD ; Indicate QML modified.
POPAE P,[L,D,C,B,A]
RET
SUBTTL Sending of queued messages
; QUESND - Routine to send queued messages.
; Given in A the site # to try un-queueing for, tries to send
; all messages queued for that site. Checks after each for
; existence of any input request, and aborts recoverably if one exists.
QTMLEN: 30.*60.*15. ; Length of time to wait between unqueue attempts.
QUESND: PUSHAE P,[A,B,C,D,E,L]
TLZ F,%QULOS
SKIPN $AROPN+QMLAR ; Check, and
CALL QMLGET ; make sure that QML is loaded.
MOVE L,$ARLOC+QMLAR ; Make it current LSE.
;; Now must find list for specified site.
HRRZ D,$LLLST(L) ; Get LP to first LLN
CAIA
QSND10: HRRZ D,LISTAR(D) ; Get next site LLN.
JUMPE D,QSND90 ; If exhaust list, ignore unqueue request.
MOVE C,LISTAR(D)+1 ; Get LP to its list.
MOVE B,LISTAR(C)+1 ; Get site # this list is for.
CAME A,B ; If this is not the site we are unqueing for
JRST QSND10 ; get next site LLN.
HRRZ C,LISTAR(C) ; Else see if any queued msgs here.
JUMPE C,QSND65 ; Jump to flush the LLN if not.
;; Found site list! D has LP to its LLN, C the LP to start of list
;; which is either A$QFCT or A$ID; rest of list is A$ID. There is
;; one A$ID for each queued message. A$QFCT is present if there
;; have been failures to connect to the host, it holds the count.
;; B holds this start of list so we can find the A$QFCT later.
MOVE B,C ; Remember head of list.
MOVE N,A ; Get host in N.
CALL HFLS ; See if site is on losers list.
JRST [ STAT (,("Flushing messages queued to host "),HST(A))
TLO F,%QULOS ; Make all message fail.
JRST QSND20 ]
STAT (,("Unqueueing to host "),HST(A))
TLZ F,%MSGMD ; Say no messages in core yet.
;; Begin loop thru list of queued msgs for this host.
QSND20: LDB A,[$LAFLD,,LISTAR(C)]
CAIE A,A$ID ; CDR down list until find an ID.
JRST [ HRRZ C,LISTAR(C)
JUMPE C,QSND60
JRST QSND20 ]
MOVE A,C ; Set up SLP to message ID.
CALL MSGGET ; Pull in that message.
JRST [ STAT (,("Note: Qmsg "),C(42),TLS(C),C(42),(" not found in MASTER, flushing."))
JRST QSND50] ; Couldn't find it, ignore and flush from QML.
TLNE F,%QULOS ; If flushing these messages
JRST QSND22 ; don't bother connecting to the host.
CALL SETMSM ; Find out if mailing or sending.
CALL NETPTH ; Find path to host.
JRST QSND22 ; Maybe already connected.
CALL NETICP ; Try to connect.
JRST QSND80 ; If lost, reschedule a request for this site.
;; Site is alive; update the site list's failure count.
LDB A,[$LAFLD,,LISTAR(B)]
CAIN A,A$ID ; If are we at looking at msg-id list
JRST QSND22 ; there was no failure count yet.
CAIE A,A$QFCT ; Is there a failure count?
JSR AUTPSY ; Else random cruft - QML trashed?
SETZM LISTAR(B)+1 ; Zap failure count.
TLO F,%QMLMD ; QML modified.
QSND22: ;; Now send to all rcpts queued for this site.
CALL QSTSND ; Tries all. Skips if still connected.
JRST QSND40 ; Connections gone!
SKIPN QSFCNT ; Check for any valid remaining rcpts
JRST QSND49 ; Nope, flush current msg.
JUMPL N,QSND40 ; If net was zapped, always requeue!!
TLNE F,%MSGMD ; Was MSG modified?
CALL MSGPUT ; Yes, write back out.
JUMPN A,QSND55 ; Some left - jump if that includes this site.
JRST QSND50 ; If not, go flush from this part of QML.
; Network lossage while sending. Re-queue, but first rotate the
; message so another one gets its chance at first shot. This
; prevents a wedged msg from blocking all mail to that host.
QSND40: LNCOPY B,[0 ? C] ; Copy SLN for this msg
LNAPP [C ? B] ; Append copy to list for site.
LNDEL C,LISTAR(D)+1 ; Flush original from list.
TLO F,%QMLMD
JRST QSND70 ; And now re-schedule for unqueueing.
; Here when message is to be flushed from QML.
QSND49: CALL MSGDEL ; Here to flush whole msg also.
QSND50: HRRZ B,LISTAR(C) ; Get CDR before flushing...
LNDEL C,LISTAR(D)+1 ; Flush from list.
TLO F,%QMLMD ; Indicate QML modified!
MOVE C,B ; Next message after the flushed one
MOVE B,LISTAR(D)+1 ; Recover head of list (LNDEL may have changed)
HRRZ B,LISTAR(B)
JRST QSND56
; Here when done with one message... check to see if OK to do another.
QSND55: HRRZ C,LISTAR(C) ; Get CDR to next.
QSND56: JUMPE C,QSND60 ; If none left, exit.
TLNN F,%QULOS ; If flushing, do them all at once
CALL IRQCHK ; Else, check for input requests first.
JRST QSND20 ; None, OK to continue!
JRST QSND75 ; Foo, must interrupt. Reschedule unqueueing...
; Here when all (?) messages have been sent to site; see if
; anything left, and flush site LLN if not.
QSND60: FINDA B,[A$ID,,[LISTAR(D)+1]] ;See if any messages on list.
JRST QSND65 ; None, flush list
JRST QSND70 ; Some, reschedule
QSND65: LNDEL D,$LLLST(L) ; Else flush LLN from QML!
CALL QMLPUT
STAT (,("All qmsgs gone for "),HST(N))
JRST QSND90 ; Write out new QML and return.
;Lost trying to ICP to site. Keep count of failures. If lost
;700 times in a row, give up on the site. (i.e. down for a week)
QSND80: FINDA B,[A$QFCT,,[B]]
CAIA
JRST QSND81 ; Found failure count.
HRRZ C,LISTAR(D)+1 ; List for host.
MAKELN B,[A$QFCT,,[LISTAR(C)]
%LTVAL,,0] ; Patch in failure count after host number.
HRRM B,LISTAR(C)
QSND81: TLO F,%QMLMD
AOS A,LISTAR(B)+1 ; Increase failure count.
CAMGE A,HDOWN ; If not too many
JRST QSND70 ; try again in a while
CSTAT (,("...Site down for a week, abandoning..."))
HRRZ C,LISTAR(B) ; Get list of message IDs
TLO F,%QULOS ; Flag to cause errors on all messages
JRST QSND20
; Must reschedule unqueue request for this site. Entry at QSND75
; reschedules for as soon as conveniently possible.
QSND70: MOVE A,QTMLEN ; Try again in 15 min. (later, be smarter)
CAIA
QSND75: SETZ A,
TLNE F,%MSGMD ; Make SURE that everything's safe!
CALL MSGPUT
TLNE F,%QMLMD
CALL QMLPUT
MOVEI B,QUESND ; Rtn to xct.
MOVE C,-5(P) ; Site to crunch. (original arg in A)
CALL SCHDI ; schedule at c(A) from now.
QSND90: CALL NTDISC ; Close net connections if any.
POPAE P,[L,E,D,C,B,A]
TLZ F,%QULOS
RET
; Kludge routine to flush messages for hosts in the HFLUSH table.
; Skip return if site in N is not on losers list, else return.
HFLS: PUSHAE P,[A,N]
MOVSI A,-HFLUSN ; Get table of losing sites.
HFLS1: CAMN N,HFLUSH(A) ; Is this site a loser?
JRST HFLS2 ; Yes, failure return.
AOBJN A,HFLS1
AOS -2 (P)
HFLS2: POPAE P,[N,A]
RET
; QSTSND - Takes current MSG-LSE, sends to all of its recipients at site
; specified by N. Skips on return if still connected to site.
; Sets A 0 if no rcpts are left for this site, -1 if some are.
.SCALAR QSFREQ,QSFCNT
QSTSND: PUSHAE P,[B,C,L]
MOVE L,$ARLOC+MSGAR ; use MSG-LSE as current.
FINDA A,[A$ID,,[$LLLST(L)]]
JSR AUTPSY
STAT (,("QID="),TLS(A))
CALL NETSND ; Do it.
CAIA ; Net broken, no skip on return.
AOS -3(P) ; Still there, skip.
SKIPN NSCTF ; Anything failed?
SKIPE NSCTS ; or anything sent?
CAIA
JRST QSTS95 ; Nope, just count # rcpts left and return.
MOVEI A,MF%QSNT+MF%FAI ; Yes, go finalize message
TLZE F,%QULOS
JRST [ CALL MSGFIN ; Stupid crock.
TLO F,%QULOS ; To simulate push/pop of flag.
JRST QSTS95]
CALL MSGFIN ; for sents/fails only.
QSTS95: CALL MSGRCK ; Get # of active rcpt's.
MOVEM A,QSFCNT
MOVE A,NSCTQ ; Return in A the # of rcpts queued for site.
POPAE P,[L,C,B]
RET
; MSGRCK - Counts # of active rcpts for LSE in MSGAR.
; MSGAR - LSE holding message
; Returns .+1
; A - # of active rcpts seen (non-pseudo A$RCP's).
MSGRCK: PUSHAE P,[B,C,L]
MOVE L,$ARLOC+MSGAR
SETZ A,
SKIPA B,$LLLST(L)
MSGRC2: HRRZ B,LISTAR(B)
FINDA B,[A$RCP,,[B]]
JRST MSGRC4
FINDA C,[A$RPSN,,[LISTAR(B)+1]]
AOJA A,MSGRC2
JRST MSGRC2
MSGRC4: POPAE P,[L,C,B]
RET
; New XRCP-hacking routines.
.INSRT SYSNET;NETSND >
SUBTTL Reminder Queueing
;;; REMIND - Queue a (new) reminder. Given current MSG-LSE that has reminder
; specs, puts it into appropriate place on RML list. Does not generate
; a schedule request unless nothing was previously on the RML, since
; one is always pending for the first thing on RML.
REMIND: PUSHAE P,[A,B,L]
SKIPN $AROPN+MSGAR ; Make sure there's a current MSG-LSE
JSR AUTPSY
MOVE L,$ARLOC+MSGAR ; Make it current
CALL RTMFND ; Find next (actually, first) time to send it
SETZ A, ; If no next time, send right away - either not
; a reminder, or time's already past!
FINDA B,[A$TNXT,,[$LLLST(L)]] ; Find A$TNXT LN to save in.
JRST [ MAKELN B,[A$TNXT,,[$LLLST(L)] ; make it if necessary.
%LTVAL,,0]
MOVEM B,$LLLST(L)
TLO F,%MSGMD ; If added LN, msg obviously modified.
JRST .+1]
CAME A,LISTAR(B)+1 ; If about to change value in LN,
TLO F,%MSGMD ; indicate msg modified, must be written out.
MOVEM A,LISTAR(B)+1 ; Save next-time-to-send.
; Now create a RML entry for this message. LP to next-time-to-send
; is in B.
FINDA A,[A$ID,,[$LLLST(L)]] ; Get LP to msg-ID
JSR AUTPSY
SKIPN $AROPN+RMLAR ; Make sure RML loaded.
CALL RMLGET
MOVE L,$ARLOC+RMLAR ; Make RML current...
LNCOPY B,[$ARLOC+MSGAR ? B] ; And create copy of msg-ID in RML LSE
LNCOPY A,[$ARLOC+MSGAR ? A] ; Likewise for A$TNXT.
HRRM B,LISTAR(A) ; Make A$TNXT first, pointing to msg-ID.
MAKELN A,[A$T,,0 ; And finally stick under a LLN.
%LTLST,,[A]]
; Have created RML entry (LLP in A) ready for insertion into
; RML... now stick it in the right place.
HRRZ B,$LLLST(L) ; Save RML pointer for checking after insert.
CALL SRTINS ; Takes LLN in A, inserts into sorted RML list
SKIPE MKQFLG
JRST REMIN0
CALL RMLPUT ; Now write out new RML.
TLNE F,%MSGMD ; And MSG-LSE if necessary. (see notes below)
CALL MSGPUT
REMIN0: CAIN B,0 ; If RML was empty before adding entry,
CALL SCHREM ; Then go schedule the remind-list!
POPAE P,[L,B,A]
RET
;;; NOTE about sequence of file updates:
; The basic philosophy is that anything entered in MASTER must
; reflect the complete current state of the message, so that
; reconstruction of both RML, QML, etc can be done from MASTER and
; its messages alone. Beyond that, some efficiency considerations:
; Were the MSG-LSE (and MASTER) written out first and the system
; crashed before the RML was updated as well, then
; MASTER's info would be correct, but RML's would be incomplete as no
; entry for that message would exist, and no reminder-sending processing
; would be initiated for it. The solution is to completely recreate the
; RML from MASTER after each COMSAT startup... ugh.
; However, if the RML is written out before MASTER, then if a crash
; intervenes between writing RML and MASTER, the message will not have
; been stored although the RML contains an entry pointing to that
; message ID. This is easily solvable by the strategy of ignoring any
; RML reference to a message not on the MASTER list, and requires no
; computational overhead.
; Hence, RML is put out before the MSG-LSE is.
SUBTTL Reminder Sending
; REMSND - Send a reminder, invoked by scheduler when it thinks time has come
; for first reminder on list. Must check truth of this, then:
; Must first pull into current MSG-LSE, find next time to send
; and include this information in message if desired, then do a
; normal-priority sending (all local, but queue if anything for net)
; Then pop it off RML list and put new time back on in right place,
; and write out new RML, etc... Then re-schedule self for next
; due reminder.
; Throughout this routine,
; E holds LLP to LLN for activated RML entry, and
; D holds LP to first LN on the entry's sublist, ie LISTAR(E)+1.
; C holds next-time-to-send, or 0 if no more.
REMSND: PUSHAE P,[A,B,C,D,E,L]
SKIPN RMLAR ; Ensure RML in core.
CALL RMLGET
MOVE L,$ARLOC+RMLAR
HRRZ E,$LLLST(L) ; Get LP to first LLN
JUMPE E,REMS90 ; If nothing on RML, ignore activation completely.
MOVE D,LISTAR(E)+1 ; Get LP to first LN of first RML node.
CALL DATIME"TIMGT ; Get current time for use by remind rtns
MOVEM A,RTMCUR ; Save. See note at RTMCUR.
MOVE A,LISTAR(D)+1 ; And now get time for earliest reminder!
CAMLE A,RTMCUR ; Less than or eq to current time??
JRST REMS80 ; No, still in future? Must re-schedule,
; somehow got triggered too soon.
; Time to process a RML entry - take it off RML, and
; get msg it points to.
HRRZ A,LISTAR(E) ; Get CDR to next entry, and make it
HRRM A,$LLLST(L) ; new head of RML - current entry now off.
FINDA A,[A$ID,,[D]] ; Find ID SLN in entry's list.
JSR AUTPSY ; Bleah??
CALL MSGGET ; Now snarf up message.
JRST REMS75 ; Ugh, not found. Flush RML entry, assuming MASTER is right.
; Message read in, first check that it really wants to be sent.
MOVE L,$ARLOC+MSGAR ; Make MSG-LSE current
FINDA A,[A$IDRM,,[$LLLST(L)]] ; Is this message actually offspring of a reminder?
JRST REMS75 ; If so, ignore this RML entry and flush it.
FINDA A,[A$TNXT,,[$LLLST(L)]] ; Get next-time-to-send accding to message
JRST REMS75 ; Foo, it has none?? ignore & flush RML entry.
MOVE A,LISTAR(A)+1 ; Get value of next-time-to-send
CAMLE A,RTMCUR ; Less or eq to current time?
JRST [ MOVE L,$ARLOC+RMLAR ; In future! must reset RML entry.
MOVEM A,LISTAR(D)+1 ; by storing updated time-to-send
JRST REMS50] ; and re-inserting on RML, and scheduling.
; Yes, definitely sending message. Before doing so, determine
; next time this reminder will be sent.
CALL RTMFND ; Now find next time to send.
JRST REMS30 ; None - go inform that this is last reminder.
MOVE C,A ; Save next-time in C.
FINDA A,[A$TEXP,,[$LLLST(L)]] ; Find expiration spec.
JRST REMS40 ; None? then don't bother with any status report.
MOVE B,LISTAR(A)+1 ; Get it
TLNE B,-1 ; If anything in LH, it's an expiration time.
JRST [ CAMGE B,C ; Compare with next time
JRST REMS30 ; Ugh, next time is greater than expiration. No more.
JRST REMS40] ; Is OK...
SOSLE LISTAR(A)+1 ; Expiration count. Decrement count
JRST REMS40 ; And jump if still OK.
; No more reminders after this one. Generate note to add onto
; front of message.
REMS30: SETZ C, ; First indicate no next-time.
FINDA B,[A$MTXT,,[$LLLST(L)]]
JSR AUTPSY
SAOBEG TMPC,
FWRITE TMPC,[[Note: this is the final message for this reminder.
],TLS,B]
LNDEL B,$LLLST(L) ; Flush old message-text
MAKELN A,[A$MTXT,,[$LLLST(L)] ; make SLN of new text
%LTSAO,,0]
HRRM A,$LLLST(L) ; Store on msg list.
; Must rename A$ID to A$IDRM and generate new unique A$ID for
; message before sending.
REMS40: FINDA A,[A$ID,,[$LLLST(L)]]
JSR AUTPSY
MOVEI B,A$IDRM ; Turn ID into parent-reminder ID.
DPB B,[$LAFLD,,LISTAR(A)]
CALL IDSET ; Now create a new ID, tack onto list.
TLO F,%MSGMD ; And indicate it's modified.
SETZ MF,
CALL MAIL ; Send it! This will queue if necessary.
JFCL
; Reminder sent, now see what time if any to resend.
JUMPE C,REMS60 ; If no more, flush from master & RML.
MOVE L,$ARLOC+RMLAR ; Else must fix up next time.
FINDA A,[A$ID,,[D]] ; Get back ID to reminder
JSR AUTPSY
CALL MSGGET ; recover message.
JSR AUTPSY ; Huh? we did this OK before!
FINDA B,[A$TNXT,,[$LLLST(L)]] ; Find LN to hold time-of-next-sending
JSR AUTPSY
MOVEM C,LISTAR(B)+1 ; Store time to send next.
FINDA B,[A$TEXP,,[$LLLST(L)]] ; see if have expiration count
CAIA
JRST [MOVE A,LISTAR(B)+1 ; have expiration spec,
TLNN A,-1 ; skip unless it's a count
SOS LISTAR(B)+1 ; in which case decrement it!
JRST .+1]
CALL MSGPUT ; Now write back reminder.
; Now pop RML entry off RML list, and put back in right place.
MOVE L,$ARLOC+RMLAR ; Make RML current
HRRZ A,LISTAR(E) ; Get CDR to next entry, and make it
HRRM A,$LLLST(D) ; first thing on list.
MOVEM C,LISTAR(D)+1 ; Now store new time to hack this rmdr!
; Now re-insert entry onto RML, and write list back.
; RML must be current.
REMS50: MOVE A,E ; arg - LLP to entry.
CALL SRTINS ; In it goes.
CALL RMLPUT
JRST REMS80 ; Now schedule next reminder.
; Here when reminder isn't to be sent any more. Flush.
; Assumes MSG-LSE current.
REMS60: FINDA B,[A$ID,,[$LLLST(L)]]
JSR AUTPSY
MOVE A,LISTAR(A)+1 ; Get SPT for MSG ID.
ADD A,$LSLOC(L) ; Abs.
CALL MSGDEL ; Glurgle! Down it goes. (see note below)
REMS75: MOVE L,$ARLOC+RMLAR ; Here to flush current entry from RML.
LNDEL E,$LLLST(L)
CALL RMLPUT ; Out with RML, and that's it.
REMS80: CALL SCHREM ; Schedule next reminder.
REMS90: POPAE P,[L,E,D,C,B,A]
RET
; NOTE about sequencing of file writes:
; As opposed to REMIND, REMSND writes out the MSG/MASTER before the
; updated RML. This is optimal because at worst an old RML will initiate
; a reminder-send request immediately for the message in question, which may
; even be deleted - if deleted, the rule about "ignore it" wins here, and if
; not then the information in the MSG-LSE itself (specifically A$TNXT) will
; serve to correct RML's backwardness quite satisfactorily, and the message will
; not be sent again until it is actually time to do so.
IFN 0,[
Algorithm for finding next time to send is simply to calculate the earliest
possible time for each time-spec, and use the earliest one found. To actually
find the earliest time for an individual time spec:
1) Get current time (or base time if given)
2) Plug given time into all wild slots.
3) Later than current time? If so, go to 7!
4) not late enough. If using a base time, use current time instead and go to 2.
5) using current time. Increment, using LOWEST wild item or given abs increment.
(Must check to ensure that eventual winnage is actually possible.
obviously if year is '65, we'll never get anywhere)
6) Go back to 3 and so forth, until get a time in the future.
7) Check: is obtained time past specified expiration date if any?
8) If not, found it... stop and rest.
]
DATIME"TM%DOW==700000 ; 2.9-2.7 0-7 1-7
DATIME"TM%HR== 76000 ; 2.6-2.2 0-31 0-23
DATIME"TM%MIN== 1760 ; 2.1-1.5 0-63 0-59
DATIME"TM$DOW==(.BP DATIME"TM%DOW,)
DATIME"TM$HR== (.BP DATIME"TM%HR,)
DATIME"TM$MIN==(.BP DATIME"TM%MIN,)
DATIME"TM$YR2==(.BP <DATIME"TM%YR&<DATIME"TM%YR#DATIME"TM%YR_2>>,) ; Byte ptr to bottom 2 bits of DATIME"TM%YR.
; Wildness is indicated by an 0 value for all of YEAR, MONTH, DAY.
; DOW is special; the following cases exist.
; DAY DOW
; * * DAY is wild and message is sent every day.
; * n Message sent only on given DOW.
; n * Message sent only on given DOM.
; n n Message is sent only when both DOM and DOW agree. This
; is great for things like "Friday the 13th"!
; RTMFND - Given current MSG-LSE, finds next (future) time to send.
; Hacks all time-specs, returns time in A and skips.
; non-skip indicates no more reminders to be sent.
; Does NOT hack any of: Expiration count/date or Next-send time.
RTMFND: PUSH P,B
SETZM RTMNXT ; Clear "best-so-far" variable.
CALL DATIME"TIMGT ; Get current time
MOVEM A,RTMCUR
SKIPA B,$LLLST(L) ; Get LP to MSG-LSE list.
RTMFN2: HRRZ B,LISTAR(B) ; on loop, get CDR to next.
FINDA A,[A$TLST,,[B]] ; Try to find spec list
JRST RTMFN5 ; No more.
CALL RTMFN ; Get next-time for this spec.
JRST RTMFN2 ; None available.
SKIPE RTMNXT ; If no spec stored yet, always store it.
CAMG A,RTMNXT ; Aha, compare with currently best (earliest)
MOVEM A,RTMNXT ; New time is less, use that!
JRST RTMFN2 ; Try the rest.
RTMFN5: SKIPE A,RTMNXT ; Return this...
AOS -1(P) ; And skip if returning a real time.
POP P,B
RET
; RTMFN - Given LP in A to a reminder-time-spec LLN, figures out next
; time to send according to that spec. RTMCUR must have been set up.
; Returns time in A and skips if found.
RTMFN: PUSH P,B
FINDA B,[A$TBAS,,[LISTAR(A)+1]] ; See if base time specified.
TDCA B,B
MOVE B,LISTAR(B)+1 ; Get it if so, else set 0.
MOVEM B,RTMBAS
FINDA B,[A$TINC,,[LISTAR(A)+1]] ; See if time increment specified.
TDCA B,B
MOVE B,LISTAR(B)+1 ; Same as above.
MOVEM B,RTMINC
FINDA B,[A$TSPC,,[LISTAR(A)+1]] ; Now find the time spec!
JSR AUTPSY ; Foo! must always have!!
MOVE A,LISTAR(B)+1 ; Get it, and
POP P,B
PJRST RTMF ; Now figure out next time!
BVAR
RTMNXT: 0 ; Holds computed time for next reminder.
RTMCUR: 0 ; Holds current time in standard format. (only Y/M/D used)
RTMBAS: 0 ; Holds base time to use, also standard format. ( " )
RTMINC: 0 ; Holds desired incr, if no wild specs. Val in minutes.
EVAR
; RTMF - Messy monster to figure out next time to send a reminder,
; given a reminder-time spec and the assumption a reminder has
; just been sent (so no need to worry about sending one in the past)
; RTMCUR must be set up with current time, RTMBAS with base time
; to use, RTMINC with increment if any, A with time-spec.
RTMF: PUSHAE P,[B,C,D,E]
SKIPN B,RTMBAS ; If base time given, use it initially.
MOVE B,RTMCUR ; Else use current time.
RTMF05: AND B,[DATIME"TM%YR+DATIME"TM%MON+DATIME"TM%DAY]
TLNE A,(DATIME"TM%YR) ; Has year specification?
TLZ B,(DATIME"TM%YR) ; Yes, wipe from base time.
TLNE A,(DATIME"TM%MON) ; Has month?
TLZ B,(DATIME"TM%MON) ; Yes, wipe from base.
TLNE A,(DATIME"TM%DAY) ; This is getting
TLZ B,(DATIME"TM%DAY) ; monotonous.
IOR B,A ; Now IOR them together to produce complete spec!
LDB C,[DATIME"TM$HR,,B] ; Start getting time
LDB D,[DATIME"TM$MIN,,B] ; into
IMULI C,60.
ADDI C,(D)
IMULI C,60.*2. ; Standard halfsec form.
HRR B,C ; Now have specified time in standard format!
RTMF10: CAMG B,RTMCUR ; Is resultant greater than current time?
JRST [ SKIPN RTMBAS ; No. Were we using a base time?
JRST RTMF30 ; If not, just go increment since time is already past.
SETZM RTMBAS ; If using base time, zap it and don't use any more.
MOVE B,RTMCUR
JRST RTMF05]
; Time is greater than current! Now must check esoteric stuff
; like DOW, unless using RTMINC.
SKIPE RTMINC ; Using RTMINC?
JRST RTMF70 ; Yeah, ignore all else and return.
TRNN A,DATIME"TM%DOW ; Is DOW specified?
JRST RTMF70 ; No, all's well.
LDB C,[DATIME"TM$DOW,,A] ; Bleah. Get DOW to check for.
PUSHAE P,[A,B]
MOVE A,B ; Set up current stuff for munching.
CALL DATIME"TIMADY ; Get time in abs # days
IDIVI A,7 ; Get DOW-1 in B
MOVEI D,1(B) ; Get DOW in D
POPAE P,[B,A] ; Restore stuffs.
CAIN C,(D) ; Compare with desired DOW.
JRST RTMF70 ; Hurray!
SUBI D,(C) ; Foo. Find difference in days.
CAIL D,0
SUBI D,7 ; If pos, adjust, to get # days in future for DOW.
MOVMS D ; It really works...
JRST RTMF32 ; and jump into increment-day rtn.
; Day increment! Any attempt to find a more future date must start here!
; If RTMINC is specified, it is applied without question.
RTMF30: MOVEI D,1 ; Before testing wildness, set up increment.
RTMF32: SKIPE RTMINC
JRST RTMF60 ; Uh-oh. RTMINC non-Z means simply add increment.
TLNE A,(DATIME"TM%DAY) ; Wild day?
JRST RTMF40 ; Nope, try incrementing month.
LDB C,[DATIME"TM$DAY,,B] ; Get current day
ADDI C,(D) ; Increment
CAIG C,28. ; If less than final DOM for smallest month,
JRST [ DPB C,[DATIME"TM$DAY,,B] ; Win! put back into time
JRST RTMF10] ; and continue.
; Ugh, must check out day increment.
LDB D,[DATIME"TM$MON,,B] ; Find what month it is.
CAIN D,2 ; February?
JRST [ LDB E,[DATIME"TM$YR2,,B] ; Pouah! Why can't the world be simple?
CAMG C,(E)[29. ? 28. ? 28. ? 28.]
JRST RTMF10 ; Is OK...
JRST RTMF37] ; NOT OK!
CAMG C,DATIME"TMONLN(D) ; Check max month length.
JRST RTMF10 ; OK...
; Day-increment went into next month!
RTMF37: MOVEI C,1
DPB C,[DATIME"TM$DAY,,B] ; Reset to 1, and drop thru to try incrementing month!
; Increment month!
RTMF40: TLNE A,(DATIME"TM%MON) ; Wild month?
JRST RTMF50 ; Nope, try incrementing year.
LDB C,[DATIME"TM$MON,,B] ; Get current month
ADDI C,1
CAIG C,12. ; Within year bounds?
JRST [ DPB C,[DATIME"TM$MON,,B] ; Yep, success.
JRST RTMF10] ; Go back & try again.
MOVEI C,1 ; Oops, overstepped! Must reset to 1 and increment year
DPB C,[DATIME"TM$MON,,B] ; Drop through...
; Increment year!
RTMF50: TLNE A,(DATIME"TM%YR) ; Last chance! wild year?
JRST RTMF90 ; No, no hope... can't find any more times to send.
; Wild year - Increment year. This loses only if going past 2027.
LDB C,[DATIME"TM$YR,,B] ; Get year of current spec
ADDI C,1
CAILE C,177 ; Overflow?
JRST RTMF90 ; Yeah, this reminder is a goner.
DPB C,[DATIME"TM$YR,,A] ; Put back.
JRST RTMF10 ; Back to check...
; Increment via RTMINC.
RTMF60: PUSH P,A
MOVE A,B
CALL DATIME"TIMSEC ; Convert current spec to abs # secs
MOVE C,RTMINC
IMULI C,60. ; Get # of secs to add as increment.
ADD A,C ; Not ADDI, may be very large.
CALL DATIME"SECTIM ; Convert back now.
MOVE B,A
POP P,A
JRST RTMF10 ; Now try again.
RTMF70: MOVE A,B ; Return in A the time obtained.
AOSA -4(P)
RTMF90: SETZ A, ; Return here when failed to find another time.
POPAE P,[E,D,C,B]
RET
SUBTTL SNDMSG - General Message Sending
; SNDMSG - Given LP to an A$RCP in A, (assumes current LSE is MSG)
; site # in N (0 for local), sends locally or over net. If
; net connections not yet open, tries to ICP.
; Never skips. A has return code; 0=win, 1=temp loss, 2=perm loss,
; 3= temp loss but keep sending to this host (e.g. disk full).
; Whether successful or not, B if nonzero will contain a SLP to
; an informational message, which should be passed along to sender.
SNDMSG: PUSHAE P,[C,D]
MOVE A,LISTAR(A)+1 ; Replace LLP by LP to list in A.
FINDA B,[A$RNAM,,[A]] ; Find name, and
JSR AUTPSY
STAT (,(" TO-"),RABR,TLS(B)) ; Announce we're sending to it.
CALL SETMSM ; Set Mail/Send modes.
JUMPN N,[MOVEI B,SNDNET ; Check site #, jump if sending over net.
JRST SNDMS4]
FINDA B,[A$RTYP,,[A]] ; Not net, find rcpt type.
JRST [ MOVEI B,SNDNAM ; If no type, assume NAME.
JRST SNDMS4]
MOVSI C,-NRTYPS ; Some type, loop to find idx.
SLNEA B,RTYPTB(C)
AOBJN C,.-1
JUMPGE C,[MOVEI B,SNDNAM ; If no match, use NAME.
JRST SNDMS4]
MOVE B,SNDRTB(C) ; Get appropriate rtn for this type.
SNDMS4: POPAE P,[D,C]
PJRST (B) ; Execute - try to send.
BVAR
SENDSW: 0 ; If sending, -1 don't mail. 0 mail if failed. 1 always mail.
MAILSW: 0 ; If mailing, -1 don't notify. 0 notify if rcpt wants. 1 always notify.
SORMSW: 0 ; 0 mail, -1 send. Existence of A$RMDS sets SORMSW to -1, else 0.
EVAR
; Given LP in A to rcpt list, sets mail/send modes.
SETMSM: SETZM MAILSW
SETZM SENDSW
SETZM SORMSW
PUSH P,B
FINDA B,[A$RMDS,,[A]]
JRST SETMS3
MOVE B,LISTAR(B)+1
MOVEM B,SENDSW
SETOM SORMSW
SETMS3: FINDA B,[A$RMDM,,[A]]
JRST SETMS7
MOVE B,LISTAR(B)+1
MOVEM B,MAILSW
SETMS7: POP P,B
RET
SUBTTL SNDNET - Send message out over net.
; Send message over net. Hack ICP later if necessary.
SNDNET: PUSHAE P,[C]
MOVE C,A ; Save LP in C
FINDA B,[A$RHST,,[C]] ; Find site
JSR AUTPSY ; If not sending over net, what are we doing here?
MOVE B,LISTAR(B)+1
CAME B,N ; Make sure we're sending to current site!
JRST [ MOVEI A,MR$TEH ; Hmm, site we want isn't current!
JRST SNDN95] ; Don't ret err msg but do fail temporarily.
CALL NTSBEG ; Initiate message
JRST SNDN90 ; Failed, investigate.
; Rcpt accepted! send message.
MOVEI A,(C) ; Get back ptr to rcpt's list.
CALL NTSMID ; Send message text.
JRST SNDN90 ; Error?
CALL NTMEND ; Terminate msg (but don't disconnect)
JRST SNDN95 ; Foo, temp error
SETZB A,B ; Success return
JRST POPCJ
SNDN90: CAIE A,MR$TER ; Investigate failure return.
CAIN A,MR$TEH
CAIA
JRST POPCJ ; SLP to message in B.
SNDN95: MOVEI B,0 ; Temporary return.
JRST POPCJ
SUBTTL SNDPGM - Send to Program, running as inferior.
;;; Send to Program. Arrgh! In default mode, routine
;;; only has responsibility for loading and starting, after
;;; which it returns successfully. Failure return happens when
;;; the program cannot be found; temporary return when program
;;; is inaccessible for temp reasons.
; Routine given A$RCP of type PGM (LP in A to rcpt list) holding filename spec
; of program to load up and run, using message text as JCL.
; Default actions are to stick with the job, serving any JCL requests
; and handling interrupts, until either it has used 2 sec of run time
; or 1 minute of real time, whereupon it is disowned with BUMRTL set and
; left to its own devices. These actions can be altered with the
; following attribute:
; The A$RPGD (R-PGM-DISOWN) value is interpreted as follows:
; RH - corresponds to the ctl bits for the DISOWN symbolic call, which
; will be used when and if the job is disowned. These bits are all
; passed on directly, with the following special actions:
; Bit 1.4 is ALWAYS complemented - i.e. you must specify it to avoid the
; "default" of setting BUMRTL (system guns job if it does nothing for 1/2 hr)
; Bit 1.3 will cause immediate disowning. Obviously no JCL can be supplied
; for this case, and the LH bits are ignored.
; LH - bits specify mailer actions.
; Bit 3.1 Says job never wants JCL. This allows the mailer to proceed
; asynchronously, handling interrupts as they occur.
; Bit 3.2 Says job will want JCL again even after it manages to read
; it all successfully. This forces mailer to "stick with" job
; until it gets disowned.
; Bit 3.3 Says if disowning is attempted, job should instead be KILLED
; and an error reported.
; Bit 3.4 Says that bits 4.9-4.1 contain the # secs of runtime job should
; be allowed - real time is ignored. Dangerous!!
; Bit 3.5 Says job should not be run if another already exists with
; identical UNAME/JNAME. Note that this is checked BEFORE any
; USET's are done (so setting JNAME that way will lose). JNAME is
; FN1 unless that is "TS", in which case it's the FN2.
; Future options? - disown after n secs runtime, never disown?
; Use a special Batch-job to actually run a given program??
; Disown on lossage instead of killing (for debugging)?
P%NVRJ==1
P%KEPJ==2
P%KILL==4
P%RTIM==10
P%UNIQ==20
BVAR
PGMQPS: 0 ; Holds LP to rcpt's list.
PGMDSN: 0 ; Holds value of R-PGM-DISOWN attrib
PGMJOB: 0 ; -1 when inferior exists.
PGMJCL: 0 ; -1 if have JCL for inferior.
PGMTXL: 0 ; Holds # words of JCL we have in PGMAR.
PGMRTM: 0 ; Runtime countdown
PGMSLP: 0 ; Time to sleep
PGMSTA: 0 ; Starting address of pgm.
EVAR
SNDPGM: PUSHAE P,[C,D,E,L] ; Routine requires L be last pushed.
MOVEM A,PGMQPS ;save LP pointing to rcpt's list.
FINDA B,[A$RPGD,,[PGMQPS]]
TDCA B,B
MOVE B,LISTAR(B)+1 ; Get value for PGM-DISOWN.
MOVEM B,PGMDSN
FINDA A,[A$RNAM,,[A]]
JSR AUTPSY
STAT (,("Running program-"),RABR,TLS(A))
SETZM PGMJOB ;not yet created inferior
MOVE A,LISTAR(A)+1 ;get the ascnt ptr
ADD A,$LSLOC(L) ;make abs
MOVE B,[PGFDEF,,PGFDEV] ; set up default block
CALL FILPAR ;parse it
MOVE A,[SIXBIT /DSK/]
MOVEM A,PGFDEV ; Force device to DSK, so LOAD will win.
; Hack JCL...
SETZM PGMJCL ;Assume will be no JCL
MOVE A,PGMDSN
TLNN A,P%NVRJ ; Can we ignore JCL?
TRNE A,4 ; Bit 1.3 means we certainly won't need any JCL.
JRST SNDP04 ; Ah, yes! Skip it...
FINDA A,[A$MTXT,,[$LLLST(L)]] ; Must furnis JCL. Get msg text
JSR AUTPSY
HLRZ B,LISTAR(A)+1 ; Get char cnt
ADDI B,4
IDIVI B,5 ; and # words
CAIN B,0 ; If nothing there,
JRST SNDP04 ; Say we don't have any JCL.
UAROPN [%ARTZM+%ARTCH,,PGMAR ? B] ; Open area for it.
OUT(TMPC,OPEN(UC$UAR,PGMAR))
OUT(TMPC,TLS(A)) ; Stuff message text into it...
MOVEM B,PGMTXL ; Save # wds of jcl
SETOM PGMJCL ;indicate JCL available!
SNDP04: ECALL OPNPGM,[[4,SNDP05],[11,SNDP05],[20,SNDP05],[27,SNDP05],[46,SNDP05]]
JRST SNDP95 ; Any error not known perm. is assumed temp...
JRST SNDP10 ; Opened!
SNDP05: MOVE A,[ASCNT [Couldn't open pgm file]]
JRST SNDP79
; Now try to create inferior...
SNDP10: MOVE A,PGFFN1 ;use FN1 as jname, unless it
CAMN A,[SIXBIT /TS/] ; is "TS", in which case use FN2 as jname
MOVE A,PGFFN2
SNDP11: ECALL OPNJB0,[[4,SNDP30]]
JRST SNDP95 ;unknown type error, assume temporary.
.UCLOSE USRI, ;hmph, it already exists. flush it if direct inferior.
MOVE B,PGMDSN ; Check bit to see if OK to AOS
TLNE B,P%UNIQ ; This bit set if wants unique job.
JRST SNDP90 ; Already exists, doesn't want AOS'd, win return.
AOS A ;"AOS" the jname in A (for now, really do AOS!)
JRST SNDP11 ;try again
SNDP30: SYSCAL OPEN,[[.UIO,,USRO] ? ['USR,,0] ? [0] ? A ? CERR C]
JRST [ CAIN C,12 ;was specified job somehow created meanwhile?
JRST SNDP11 ; Try again.
CAIE C,37 ; No core available?
CAIN C,6 ; or no slots available?
JRST SNDP95 ; temp error, queue.
JSR SYSLOS] ; ?? none of these, fail.
SETOM PGMJOB ;indicate inferior created.
SYSCAL OPEN,[[.UII,,USRI] ? ['USR,,0] ? [0] ? A ? CERR C]
JSR SYSLOS
.USET USRI,[.RUNAME,,B]
CSTAT (,(" Job-"),RABR,6F(B),(" "),6F(A))
; Load the program from file
SYSCAL LOAD,[CIMM USRI ? CIMM DKIC]
JRST [ MOVE A,[ASCNT [Couldn't load pgm file]]
CSTAT (,(", couldn't load program file, killed."))
JRST SNDP79]
.IOT DKIC,PGMSTA ;get starting address
HRRZS PGMSTA ;flush random PC flags, esp. FPD!
.CLOSE DKIC, ;no further need for dsk chan
.USET USRI,[.SUPC,,PGMSTA] ;set inferior's starting address
.USET USRI,[.RINTB,,INFBIT] ;find interrupt bit for this inferior
FINDA A,[A$CSN,,[$LLLST(L)]] ; Find sender's name
JRST [ FINDA A,[A$SNM,,[$LLLST(L)]]
JSR AUTPSY
JRST .+1]
CALL CVLS6 ; Convert to 6bit
XCTILO [.USET USRI,[.SXUNAME,,A]] ; and set job's XUNAME to that.
JFCL
SKIPE PGMJCL ;If program has JCL, tell it
.USET USRI,[.SOPTION,,[%OPCMD,,]]
; Now hack optional USETs if any.
SKIPA D,PGMQPS
SNDP36: HRRZ D,LISTAR(D)
FINDA D,[A$RPGU,,[D]] ; Look for R-PGM-USET
JRST SNDP38 ; None or none left, let's go!
SKIPN C,LISTAR(D)+1 ; Get LP to list
JRST SNDP36 ; Ignore if nothing.
MOVE A,LISTAR(C)+1 ; Get LH/Symbol to .USET.
HRRZ C,LISTAR(C)
CAIE C,0
MOVE C,LISTAR(C)+1 ; Get value to .USET to.
HRLZS A
JUMPGE A,SNDP36 ; Ignore if reading!!
HRRI A,C ; Get USET word in A
XCTILO [.USET USRI,A] ; Do it, carefully...
JRST [ CALL PGMBGE ; Ugh!
FWRITE TMPC,[[ILOPR while XCT'ing a USET for job!
USET type ],LHV,A,[, attempted setting to ],HV,C]
JRST SNDP76]
JRST SNDP36
; Ready to start program....
SNDP38: MOVE A,PGMDSN
TRNE A,4 ; Is bit 1.3 set - immediate disown?
JRST SNDP70 ; Yep, go off & do it.
MOVEI B,2 ; Get default # secs runtime.
TLNE A,P%RTIM ; But if explicitly specified,
LDB B,[331100,,A] ; Pluck it out.
IMUL B,[1000000./4] ; & get # of 4-usec ticks.
MOVEM B,PGMRTM ; Store run-time countdown.
TLNE A,P%RTIM ; Another test of same bit.
SKIPA A,[SETZ-1] ; If set, stick with job forever.
MOVEI A,12. ; Else only for 12*5 seconds.
MOVEM A,PGMSLP
TLO F,%PGMRN ;tell int. handler to handle the ints, and
.SUSET [.SIMSK2,,INFBIT] ;enable ints from inferior
SNDP40: .USET USRI,[.SUSTP,,[0]] ;start it!
SNDP41: SOSGE PGMSLP
JRST SNDP70 ;disown after just so long
.SUSET [.SADF2,,INFBIT] ;clear defer bit
MOVEI C,30.*5 ;sleep for 5 sec
.SLEEP C,
.SUSET [.SIDF2,,INFBIT] ;defer... don't let it interrupt.
.USET USRI,[.RRUNT,,C] ;read run-time so far
CAML C,PGMRTM ; Greater than allowed?
JRST SNDP70 ;indeed. disown it.
JRST SNDP41 ;not yet, keep waiting
; Dismiss to here upon inferior interrupt!
SNDP60: .USET USRI,[.RPIRQC,,C] ; (Used below)
.USET USRI,[.RSV40,,A] ;get .BREAK inst or whatever it is...
LDB B,[$OPCOD,,A] ;What instruction caused it
CAIN B,<.BREAK_-33>
JRST SNDP62 ;Go handle a .BREAK .
CAIE B,<.LOGOUT_-33>
JRST SNDP75 ;Not a .LOGOUT either, kill noisily.
LDB B,[$ACFLD,,A]
JUMPE B,SNDP75 ;.LOGOUT 0, is an error, kill noisily.
JRST SNDP77 ;Else it wants to die, kill quietly.
; Come here if the job did some .BREAK .
SNDP62: LDB B,[$ACFLD,,A]
CAIE B,12 ;request-info type .BREAK?
JRST [ CAIN B,16 ;type asking for death?
JRST SNDP77 ;yes, die quietly
JRST SNDP75] ;nope, die noisily.
.ACCESS USRI,A ;point to effective address of .BREAK
.IOT USRI,A ;get the command word [*** Should protect from MPV ***]
LDB B,[221100,,A] ;see what type
CAIE B,5 ;JCL related?
JRST SNDP75 ;nope, ugh
.USET USRI,[.SAPIRQC,,[%PIBRK]] ;turn off the interrupt for inferior
JUMPL A,[SETZM PGMJCL ;if type=write, indicate JCL no longer avail.
.USET USRI,[.ROPTION,,A]
TLZ A,%OPCMD
.USET USRI,[.SOPTION,,A]
JRST SNDP40]
SKIPN PGMJCL ;if JCL not avail, ignore request to read.
JRST SNDP40
;now write JCL into place specified by RH of A.
MOVN B,PGMTXL ;make aobjn pntr to jcl
HRLZ B,B
HRR B,$ARLOC+PGMAR ; Get RH = loc of text.
.ACCESS USRI,A
.ACCESS USRO,A
SNDP64: .IOT USRI,C ;read to ensure zero
JUMPN C,SNDP40
MOVE C,(B) ;if zero, get string word
.IOT USRO,C ;and write into inf.
AOBJN B,SNDP64
;that's all-- no need to write terminating zero wd since wd is already
;zero if such writing is possible!
STAT (,("Program gobbled all JCL..."))
JRST SNDP40
;come here to disown job and let it run by itself.
SNDP70: MOVE A,PGMDSN
TRC A,10 ; Complement 1.4 ...
TRNE A,4 ; Is 1.3 (start after disown) set?
JRST SNDP72 ; Yup, go do that.
TLNN A,P%KILL ; Well, is bit set to kill on disown attempt?
JRST SNDP72 ; Nope, go ahead.
CALL PGMBGE ; Ugh! Must kill it.
FWRITE TMPC,[[Program timed out, killing instead of disowning!]]
CSTAT (,("Timed out, killing."))
JRST SNDP76
SNDP72: SYSCAL DISOWN,[CTLI (A) ? CIMM USRI]
JSR SYSLOS ;glub?
.SUSET [.SAMSK2,,INFBIT] ;disable inferior ints.
CSTAT (,(" Disowned."))
JRST SNDP90 ;done...
;come here to kill job for some reason, noisily. send message back
;detailing circumstances.
SNDP75: CALL PGMBGE ; Init for err processing.
FWRITE TMPC,[[RUN-invoked job hit fatal interrupt. File run was
],TI,133,6F,PGFDEV,[:],6F,PGFDIR,[;],6F,PGFFN1,[ ],6F,PGFFN2,TI,135,[ Relevant info follows:
]]
MOVSI B,-20 ;Dump ACs
.ACCESS USRI,[0]
SNDP74: .IOT USRI,A
FWRITE TMPC,[RHV,B,[/ ],HV,A,[
]]
AOBJN B,SNDP74
IRP VAR,,[UPC,JPC,MPVA,PIRQC,IFPIR,DF1,DF2,PICLR,RUNT,UUOH]
.USET USRI,[.R!VAR,,A]
FWRITE TMPC,[[.!VAR!/ ],HV,A,[
]]
TERMIN
.USET USRI,[.RBCHN,,B]
HRLZ A,B
ADD A,[.RIOS,,A]
.USET USRI,A
FWRITE TMPC,[[.BCHN/ ],OCT,B,[
.IOS (of above)/ ],HV,A,[
]]
TRNN C,%PIIOC ; If stopped on an IOC,
JRST SNDP76
SYSCAL RFNAME,[CIMM USRI ? B ; find filenames for channel.
CRET A ? CRET C ? CRET D ? CRET B]
JSR SYSLOS
FWRITE TMPC,[[LOSING FILE: ],6F,A,[:],6F,B,[;],6F,C,[ ],6F,D,[
]]
SNDP76:
;now kill it
AOSN PGMJOB
.UCLOSE USRI,
CSTAT (,(" Killed."))
.SUSET [.SAIFPIR,,INFBIT]
JRST SNDP85 ;go send text
;here, kill job quietly.
SNDP77: AOSN PGMJOB
.UCLOSE USRI, ;die.
CSTAT (,(" Qilled."))
.SUSET [.SAIFPIR,,INFBIT]
JRST SNDP90 ; we won!
SNDP79: MOVE B,A
CALL PGMBGE ; Initialize for error processing.
FWRITE TMPC,[TC,B,[ - ],ERR,,] ; Get err msg
JRST SNDP85
;Bad condition of some sort during startup. try to complain by
;sending message. ASCNT ptr in A to text.
SNDP80: CSTAT (,(" Lost somehow"))
CALL PGMBGE ; Init for err stuff.
FWRITE TMPC,[TC,A,[
]]
;send message to specified recipient detailing circumstances of
;lossage. Create subject, sender name, etc.
SNDP85: .CLOSE DKIC, ;program file may still be open
AOSN PGMJOB ;skip if no job.
.UCLOSE USRI, ;else flush it.
SKIPN $AROPN+PGMAR
JRST SNDP86
FWRITE TMPC,[[Message follows:
-------
],TA,PGMAR]
SNDP86: MAKELN A,[A$MTXT,,0 ? %LTSAO,,]
PUSH P,L
MOVE L,$ARLOC+MSGAR
FINDA D,[A$TIM,,[$LLLST(L)]]
JSR AUTPSY
MOVE D,LISTAR(D)+1 ; Set up time
FINDA C,[A$RPMR,,[PGMQPS]] ; Find name of maintainer if any.
SETZ C, ; None...
POP P,L
JUMPN C,[LNCOPY C,[$ARLOC+MSGAR ? C]
MOVEI B,A$RCP
DPB B,[$LAFLD,,LISTAR(C)] ; Copy into an A$RCP LN.
JRST .+1]
HRRM C,LISTAR(A) ; Cons onto message text.
MOVEM A,$LLLST(L)
MOVE B,D
PUSH P,MF
MOVEI MF,M%CORG+M%SSBJ+M%EMSG+M%ERR
CALL MAIL
JFCL
POP P,MF
JRST SNDP99
; For time being, loss return is actually win, since
; err msg has already been sent and we don't need helpful
; calling routine sending another one for us!
SNDP95: MOVEI A,MR$TER ; Temp. error return.
SETZ B, ; Indicate no message.
JRST SNDPRT
SNDP90: SNDP99:
SETZB A,B ; No return of messages.
SNDPRT: TLZ F,%PGMRN
UARCLS PGMAR ;Flush copy of message made for JCL, if it's still around
POPAE P,[L,E,D,C]
RET
REMMSK: 0
3777,,-1 ; 1 char in wd, mask out last 4
17,,-1 ; 2, zap last 3
77777 ; last 2
377 ; last 1
;default file blk for pgm running
PGFDEF: SIXBIT /DSK/
SIXBIT /SYS/
SIXBIT /TS/
SIXBIT /FOO/
BVAR
PGFDEV: 0
PGFDIR: 0
PGFFN1: 0
PGFFN2: 0
INFBIT: 0 ;holds interrupt bit for inferior
EVAR
OPNPGM: SETZ ? SIXBIT /OPEN/ ? [.UII,,DKIC] ? PGFDEV
PGFFN1 ? PGFFN2 ? SETZ PGFDIR
UBPFJ==10 ;fail with 4 if no such job exists anywhere.
OPNJB0: SETZ ? SIXBIT /OPEN/ ? [UBPFJ+.UII,,USRI] ? ['USR,,0]
[0] ? A ? SETZ CERR C
; Initialize for error when hit one in pgm.
PGMBGE: PUSH P,A
MOVEI A,EMSGAR
CALL LSEOPN ; Open LSE for err message.
MOVE L,$ARLOC+EMSGAR
SAOBEG TMPC, ; Open chan for outputting on.
POP P,A
RET
SUBTTL SNDBUG, SNDBUL, SNDFIL, SNDAFL - various msg senders
; For rcpts of type BUG.
SNDBUG: PJRST SNDNAM ; For time being.
; For rcpts of type @FILE.
SNDAFL: JSR AUTPSY ; Shouldn't try to send.
; For rcpts of type FILE.
SNDFIL: PUSH P,C
MOVE C,A
FINDA A,[A$RNAM,,[C]]
JSR AUTPSY
MOVE A,LISTAR(A)+1
ADD A,$LSLOC(L)
MOVE B,[LMFDEF,,LMFDEV]
CALL FILPAR
MOVEI A,LMFDEV
MOVE B,C
POP P,C
PJRST WRTMSG
; Rcpt type *MSG - Send Bulletin-board *MSG.
SNDBUL: CALL BBDDFS ; Set up defaults for filename into LMFDEV.
MOVEI B,LMFDEV
EXCH A,B ; FILPT in A, LP to rcpt list in B.
PJRST WRTMSG
BBDDFS: PUSH P,B
MOVE B,[LMBDEF,,LMFDEV] ; Set up defaults for filename.
BLT B,LMFDEV+3
FINDA B,[A$MFN1,,[$LLLST(L)]] ; First FN1 specified?
CAIA
JRST [MOVE B,LISTAR(B)+1 ; If so, plug in.
MOVEM B,LMFDEV+2
JRST .+1]
FINDA B,[A$MFN2,,[$LLLST(L)]] ; Second FN2 specified?
CAIA
JRST [MOVE B,LISTAR(B)+1
MOVEM B,LMFDEV+3
JRST .+1]
POP P,B
RET
LMBDEF: SIXBIT /DSK/
SIXBIT /.MSGS./
SIXBIT /*MSG/
SIXBIT />/
SUBTTL SNDNAM - Local Message sending
; SNDNAM - Sends normal NAME-type local message.
; A has LP to rcpt's list.
; returns in A, B like SNDMSG
LVAR LMPRCP: 0 ; Holds LP to rcpt's list.
SNDNAM: PUSHAE P,[C,D,E,LMPRCP]
MOVEM A,LMPRCP ; Save LP to rcpt list
FINDA A,[A$RNAM,,[LMPRCP]]
JSR AUTPSY
MOVE E,LISTAR(A)+1
ADD E,$LSLOC(L) ; Get ASCNT name in E.
HLRZ D,E ; Check length of name.
JUMPN D,SNDN10 ; Null recipient?
;; Hmmm, this message does not appear to be addressed to anyone.
;; (Possibly this is a COMSAT error receipt failing.)
;; We will generate an error receipt with no recipients, so that
;; this will be routed to DEAD-MAIL-RECEIPTS.
STAT (,(" Null UNAME for local recipient!"))
FINDA B,[A$RHDR,,[LMPRCP]]
JRST [ FINDA B,[A$MHDR,,[$LLLST(L)]]
JSR AUTPSY
JRST .+1]
MOVE B,LISTAR(B)+1 ; B gets ASCNT to message header.
ADD B,$LSLOC(L)
FINDA C,[A$MTXT,,[$LLLST(L)]]
JSR AUTPSY
MOVE C,LISTAR(C)+1 ; C gets ASCNT to message text.
ADD C,$LSLOC(L)
UARPUSH EMSGAR ; Let's cons up an error receipt.
OUTCAL(TMPC,CALL(EMSOPN)) ; Open
PUSH P,L ; Stash LSE ptr.
MOVE E,L ; Make copy for UUO rtns.
MOVE L,$ARLOC+EMSGAR ; Switch to error message LSE.
CALL IDSET ; Create ID for error receipt.
CALL DATIME"TIMGET ; CDR holds message time.
MAKELN A,[A$TIM,,0 ? %LTVAL,,[A]]
HRRM A,$LLLST(L) ; Receipt will have no recipient!
OUT(TMPC,("Message apparently addressed to local nobody??"),EOL)
OUT(TMPC,("Text of bad message follows:"),EOL,("--------"),EOL)
OUT(TMPC,TC(B),EOL,TC(C),EOL) ; Simply output the text.
CALL EMSSND ; Now go send the message!
UARPOP EMSGAR ; Recover LSE.
POP P,L ; Recover ptr to it.
JRST LMSN90 ; Make like we delivered the message.
;; Okay, apparently we actually have some kind of local recipient.
SNDN10: MOVE D,[LMFDEF,,LMFDEV]
BLT D,LMFDEV+4-1 ; Set up defaults
MOVE A,E ; Recipient name.
CALL CVT76C ; Get SIXBIT name in A.
HLRZ D,E ;get char cnt of name
CAILE D,6
JRST [ STAT (,(" Name too long-- "),C(42),,TC(E),C(42),("."))
FINDA D,[A$RNK,,[LMPRCP]] ;is recipient known?
JRST [ CSTAT (,(" Rcpt known, message not sent."))
JRST LMSN90] ;return as "win" if known.
CSTAT (,(" Rcpt not known, converted to "),C(42),6F(A),C(42))
JRST .+1] ;not known, so send to truncation.
MOVEM A,LMFFN1 ;store into file block
FINDA D,[A$RHSN,,[LMPRCP]] ; Must rcpt use a special dir?
CAIA ; Nope, assume <name>;<name> MAIL.
MOVE A,LISTAR(D)+1 ; Yes, get 6bit dir name to use.
CALL HASDIR ; Make sure dir really exists...
MOVE A,['COMMON] ; No, must use COMMON;<name> MAIL.
MOVEM A,LMFDIR ; Store final choice in file block,
CAME A,LMFFN1 ; and if different from FN1 (usual case),
JRST [ CSTAT (,LPAR,6F(A),(";"),RPAR) ; document it in STATS.
MOVE A,LMFFN1 ; and ensure A has rcpt uname.
JRST .+1]
;now send as specified (push, append, cli-only, etc)
LMSN20: SKIPN SORMSW
JRST LMSN50 ;just mailing.
; Sending. UNAME in A, LP to rcpt's list in B.
MOVE B,LMPRCP
CALL CLIMSG
CAIA
JRST [SKIPLE SENDSW ; Won. if > 0 then
JRST LMSN50 ; also mail,
JRST LMSN90] ; else done.
SKIPGE SENDSW ; Failed. If < 0, then
JRST LMSN90 ; nothing else to do.
; Here, a mail-if-failed SEND just failed, and we have to mail it!
; Ugh, bletch, puke, phooey.
; Must cons up new rcpt, sender, and message text.
PUSH P,L
MOVEI A,EMSGAR
CALL LSEOPN ; Create new LSE for new message
MOVE L,$ARLOC+EMSGAR ; Point at it
EXCH L,(P)
FINDA A,[A$RNAM,,[LMPRCP]] ; Find rcpt name
JSR AUTPSY
FINDA B,[A$RNAM,,[LMPRCP]] ; and type
SETZ B,
FINDA C,[A$SNM,,[$LLLST(L)]] ; and sender's name
JRST [ FINDA C,[A$CSN,,[$LLLST(L)]]
JSR AUTPSY
JRST .+1]
EXCH L,(P)
MOVE D,(P) ; Set up ptr to LSE (UUO's shouldn't ref PDL)
LNCOPY A,[D ? A] ; Copy rcpt name
LNCOPY B,[D ? B] ; and type.
LNCOPY C,[D ? C] ; and sender's name.
HRRM B,LISTAR(A) ; Link type to name,
MAKELN A,[A$RCP,,[C] ; and put under A$RCP, linking to
%LTLST,,[A]] ; sender's name all at once.
MOVEI B,A$CSN
DPB B,[$LAFLD,,LISTAR(C)] ; Force sender name to claimed-from
EXCH L,(P)
FINDA B,[A$RHDR,,[LMPRCP]] ; Now find rcpt's header
JRST [ FINDA B,[A$MHDR,,[$LLLST(L)]]
JSR AUTPSY
JRST .+1]
MOVE B,LISTAR(B)+1 ; Get absolute ascnt ptr
ADD B,$LSLOC(L)
FINDA C,[A$MTXT,,[$LLLST(L)]] ; and message text.
JSR AUTPSY
MOVE C,LISTAR(C)+1 ; Get absolute ascnt ptr
ADD C,$LSLOC(L)
EXCH L,(P)
; Now form message text, and send the message. What happens
; here is that we just include the old header as part of the
; message text, because we hve no way of knowing what sort
; of header the rcpt(s) may want, and still have to show who
; the original QSEND was addressed to!
SAOBEG TMPC, ; Now form text of message.
FWRITE TMPC,[TI,133,[COMSAT: This was a failing QSEND.],TI,135,[
],TC,B,TC,C]
MAKELN A,[A$MTXT,,[A]
%LTSAO,,]
MOVEM A,$LLLST(L) ; Finalize.
PUSH P,MF
MOVEI MF,M%CORG+M%EMSG
CALL MAIL ; Mail it!!
JFCL
POP P,MF
POP P,L
JRST LMSN90 ; Gasp wheeze pant, finally finished.
; Mail.
LMSN50: MOVEI A,LMFDEV
MOVE B,LMPRCP ; Set up LP to rcpt list.
CALL WRTMSG ;mail message!
CAIE A,0
JRST LMSNRT ; If failed, return.
; Now decide whether or not to CLI to the rcpt.
SKIPE SORMSW ; If we were intended to SEND,
JRST LMSN90 ; then all's done.
SKIPGE MAILSW ; If suppressing notification,
JRST LMSN90 ; also done.
TRNE MF,M%CORG ; If the message is from COMSAT, then skip the check
JRST LMSN85 ; (this is kind of random, but I found it here...)
FINDA A,[A$SNM,,[$LLLST(L)]] ;find sender's name
JSR AUTPSY
CALL CVLS6 ; Convert to 6bit
CAMN A,LMFFN1 ;compare unames
JRST LMSN90 ;equal, don't send!
LMSN85: MOVE A,LMFFN1 ; Get uname
MOVE B,LMPRCP ; Get LP to rcpt's list.
CALL CLIOPT ; Notification is up to rcpt...
JFCL
LMSN90: SETZB A,B
LMSNRT: POPAE P,[LMPRCP,E,D,C]
RET
;file to write message to.
BVAR
LMFDEV: 0 ;default of "dsk"
LMFDIR: 0 ;default of "common"
LMFFN1: 0 ;default of "failed"
LMFFN2: 0 ;default of "mail"
EVAR
LMFDEF: SIXBIT /DSK/ ;defaults
SIXBIT /COMMON/
SIXBIT /FAILED/
SIXBIT /MAIL/
BCHPTB: 350700,,B
260700,,B
170700,,B
100700,,B
010700,,B
SUBTTL Actual local mailing
; WRTMSG - A has FILPT, B has LP to rcpt's list. Writes msg to given file.
; This returns the same kind of error code as all the SNDxxx routines.
; See the dispatch table at RSND09.
.SCALAR WRFFAP ; -1 when FAST-APPEND; means DKOC open in write-over mode.
WRTMSG: PUSHAE P,[C,D]
MOVEM A,WFILPT ; Save FILPT.
MOVEM P,WRTLEV'
MOVEI C,WRTRLT ; Set up addr to return to if we time out.
MOVEM C,RLTVEC
CLKSET [5*60.*60.] ; Set up the clock for 5 minutes
CLKON ; And enable interrupts
call mbxlok ; Try for inbox lock
jrst wrtlkd ; Lost: temporary error
CALL DEVCHK ; Set flags as to type of device.
OUT(DKOC,OPEN(UC$BUF)) ; And set up UUO chan for buffered output.
; Check for FAST-APPEND option.
TRZ F,%LMAPN ; Say not appending
SETZM WRFFAP ; and not doing it fast-append way either.
FNDSTR C,B,A$ROPT,[FAST-APPEND] ; Rcpt has the option?
JRST WRTM20 ; Nope, do regular append or push.
TRO F,%LMAPN ; Has it! Proclaim append-mode.
TRNN F,%DSKDV ; Device a DSK-type frob?
JRST WRTM20 ; Nope, must hack regular way.
; OK to try write-over mode!
MOVE C,B ; Save rcpt-list ptr (B gets err code)
CALL OPNAPP ; Attempt opening in append mode.
JRST [ EXCH B,C
JUMPGE C,WRTM95 ; Jump if temporary error
JRST WRTM99] ; Else permanent...
MOVE B,C
SETOM WRFFAP ; WIN! Definitely doing fast-append. Set flag
SKIPLE EOFREC ; to avoid rename, and if not at beg
OUTCAL(DKOC,EOL) ; then prefix with CRLF,
JRST WRTM50 ; and go output message.
; Regular mode (push or append) comes here to open output file.
WRTM20: MOVEI D,WRTMO ; Default .CALL blk for DSK devs (for RENMWO).
TRNN F,%DSKDV
MOVEI D,WRTMVO ; Else use this blk for true filespec.
; Open output, to WRTM95 if temporary error
ECALL (D),[[5,WRTM95],[6,WRTM95],[7,WRTM95],[10,WRTM95]]
JRST WRTM99 ; Permanent errors - return with no skip.
; Output file opened, now see if need to read input (existing) file.
; Sometimes can skip completely.
MOVE C,3(A) ; Get FN2
CAME C,[SIXBIT /</]
CAMN C,[SIXBIT />/] ; FN2 special?
JRST WRTM49 ; Yes, no need to read existing file.
FNDSTR C,B,A$ROPT,[NEW-FILE] ; Does rcpt have make-new-file option?
CAIA
JRST WRTM49 ; If so, ignore any input, etc.
; Open input, to WRTM95 if temporary error
; to WRTM49 if file does not exist
ECALL WRTMI,[[4,WRTM49],[6,WRTM95],[7,WRTM95],[10,WRTM95],[16,WRTM95],[23,WRTM95]]
JRST WRTM99 ; Some other error: permanent error
; Have both input and output open! See if must append or push...
TRNE F,%LMAPN ; Already decided to append?
JRST WRTM30 ; Yup, go do it.
FNDSTR C,B,A$ROPT,[APPEND] ; See if rcpt has APPEND option.
JRST WRTM50 ; Nope, go "push" the msg by writing first.
TRO F,%LMAPN ; Appending, set flag.
; Appending...
WRTM30: CALL DKIOUT ; Copy text from DKIC to current output chan!
JRST WRTM95 ; IOC error or something, assume temp.
JRST WRTM50 ; Then go write message.
; Write message!
WRTM49: TRO F,%LMAPN ; Entry pt for things that ignore input file.
WRTM50: FNDSTR C,B,A$ROPT,[SUPER-QUOTE] ; Is message being super-quoted
CAIA ; for this rcpt?
JRST [FINDA C,[A$MTXT,,[$LLLST(L)]] ; Yes, output msg txt directly.
JSR AUTPSY
XCTIOC [OUTCAL(DKOC,TLS(C))]
JRST WRTM95 ; IOC? temporary.
JRST WRTM70] ; Done with message!
FINDA C,[A$RHDR,,[B]] ; Normal processing. Find rcpt's header if any.
JRST [ FINDA C,[A$MHDR,,[$LLLST(L)]]
JSR AUTPSY
JRST .+1]
XCTIOC [OUTCAL(DKOC,TLS(C))] ; Output if there.
JRST WRTM95 ; IOC? temporary.
FINDA C,[A$MTXT,,[$LLLST(L)]] ; Get SLP to message text.
JSR AUTPSY
FINDA D,[A$MTXF,,[$LLLST(L)]] ; Is there a flag for msg?
JRST WRTM56 ; NO
SKIPE LISTAR(D)+1 ; Check flag
JRST WRTM56 ; Flag not 0, OK.
MOVE A,C ; UGH!
XCTIOC [CALL QBKAO] ; Output quoted-type ^_'s.
JRST WRTM95 ; IOC - temp err.
JRST WRTM60
WRTM56: XCTIOC [OUTCAL(DKOC,TLS(C))] ; Output whichever msg text is necessary.
JRST WRTM95
; Now add the "^_^M^J". Insert CRLF in front if seems necessary.
WRTM60: MOVE C,LISTAR(C)+1 ; Examine last char
ADD C,$LSLOC(L)
HLRZ D,C ; Cnt into D,
HRLI C,440700 ; BP in C.
PTSKIP D,C ; Get pointer to last+1 char!
LDB C,C ; Snarf last char.
MOVE A,[ASCNT [
]]
CAIE C,^J ; Unless it's a LF,
MOVE A,[ASCNT [

]] ; add a crlf.
XCTIOC [OUTCAL(DKOC,TC(A))]
JRST WRTM95
; Message writing done, now see if "pushing".
; Must add previous file if so.
WRTM70: TRNE F,%LMAPN ; Skip if pushing.
JRST WRTM90 ; Nope, all done.
CALL DKIOUT ; Output stuff from DKIC over std output chan.
JRST WRTM95 ; IOC, take temp-err return.
WRTM90: XCTIOC [OUTCAL(DKOC,FRC)] ; Ensure output forced out.
JRST WRTM95 ; Sigh, so close...
TRNE F,%DSKDV ; Was output to a DSK device?
SKIPE WRFFAP ; Yes, was fast-append specified?
CAIA ; Not disk, or using fast-append, skip rename.
JRST [MOVE A,WFILPT ; Must rename output file!
SYSCAL RENMWO,[CIMM DKOC
2(A) ? 3(A)] ; Rename to proper names if so.
JRST WRTM99 ; Glub, failed for some reason?
JRST .+1]
OUT(DKOC,CLS) ; Close the channel (both UUO and actual)
SETZB A,B
JRST WRTMRT ; Win return.
WRTRLT: MOVE P,WRTLEV ; Timed out trying to write local message
CSTAT (,("...TIMEOUT"))
JRST WRTM96
; Temporary errors come here. Message will be queued,
; and re-tried later.
WRTM95: CSTAT (,("...TEMP ERR="),LBRC,ERR,RBRC) ; Return here for temp err.
WRTM96: OUT(DKOC,RST,CLS) ; Reset and close the buffered chan.
MOVEI A,MR$TER ; Code for temp error but don't give up on this host!
SETZ B, ; Not returning any err message.
TRNN F,%DSKDV ; Was output to dsk-type dev, hence to fake fnm?
JRST WRTMRT ; No, leave things as they are.
MOVE C,WFILPT ; It was! Must be public-spirited and
SYSCAL DELETE,[(C) ? [SIXBIT /_MAIL_/] ? [SIXBIT /OUTPUT/] ? 1(C)]
JFCL
JRST WRTMRT ; Flush the abortive output file.
; Failure to lock inbox is a temporary error too:
wrtlkd: cstat (,("... Inbox locked."))
MOVEI A,MR$TER ; Code for temp error but don't give up on this host!
SETZ B, ; Not returning any err message.
jrst wrtmrt
; Permanent errors come here. The message will not be queued, and
; COMSAT will try to return it to the sender, along with an
; appropriate error string (given by SLP in B)
WRTM99: CSTAT (,("...LOST, ERR="),LBRC,ERR,RBRC) ; Return here for perm err.
MOVE A,WFILPT
SAOBEG TMPC,
FWRITE TMPC,[[Couldn't write message to file;
"],6F,(A),[:],6F,1(A),[;],6F,2(A),[ ],6F,3(A),[" - ],ERR,,]
MAKELN B,[0 ? %LTSAO,,] ; Make output into a SLN, with SLP in B.
OUT(DKOC,RST,CLS) ; Reset and close the buffered chan.
MOVEI A,MR$PER ; Code for perm error
WRTMRT: CLKOFF
SETZM RLTVEC
.close lockch, ; Release inbox lock
POPAE P,[D,C] ; Losing return.
RET
.SCALAR WFILPT ; For holding argument FILPT while hacking stuff.
WRTMVO: SETZ ? SIXBIT/OPEN/ ? [.UAO,,DKOC]
(A) ? 2(A) ? 3(A) ? SETZ 1(A)
WRTMO: SETZ ? SIXBIT /OPEN/ ? [.UAO,,DKOC] ; Unit Ascii out (for SIOT)
(A) ? [SIXBIT /_MAIL_/] ? ['OUTPUT] ? SETZ 1(A)
WRTMI: SETZ ? SIXBIT /OPEN/ ? [.BII,,DKIC]
(A) ? 2(A) ? 3(A) ? SETZ 1(A)
; MBXLOK - Seize lock for inbox from FILPT in A. Skips on success.
mbxlok: pushae p,[b,c]
move b,2(a)
rot b,1
add b,3(a)
rot b,1
add b,1(a)
idivi b,777773
hrli c,(sixbit /MBX/)
syscal open,[moves b ? movsi .uao ? movei lockch
[sixbit /LOCK/] ? move c]
jrst [ caie b,%enafl
jsr autpsy ; %ENSDV or %EFLDV ?
jrst .+2 ]
aos -2(p)
popae p,[c,b]
ret
; QBKAO - Takes an SLP in A, and outputs the string to DKOC, converting ^_'s to
; ^ followed by _.
QBKAO: PUSHAE P,[B,C]
MOVE A,LISTAR(A)+1
ADD A,$LSLOC(L)
HLRZ B,A
HRLI A,440700 ; BP in A, char count in B
JRST QBKAO6
QBKAO4: ILDB C,A
CAIN C,^_
JRST [ OUT(DKOC,C("^),C("_))
JRST QBKAO6]
OUT(DKOC,C((C)))
QBKAO6: SOJGE B,QBKAO4
POPAE P,[C,B]
RET
; ARDSKO - takes ptr to filblk in A, area # to output in B.
; skips if written, fails if unable to open file. outputs
; text in area. Returns error string (SLP in A) if open fails.
; This routine differs from WRTMSG primarily in that it simply
; writes a file, wheras WRTMSG appends to an existing file.
; This is used to procude the "NAMED ERRxxx" files.
ARDSKO: PUSHAE P,[C,D]
CALL DEVCHK ;set flags for device name (addr in A)
MOVEI D,ARDVPN
TRNE F,%DSKDV ;use ardopn if dsk dev,(renmwo hack)
MOVEI D,ARDOPN
.CALL (D) ;try opening file with that dev, dir
JRST ARDKO6 ;failure, hack error code/string
OUT(DKOC,OPEN(UC$IOT),TA((B))) ; Set up chan as UUO chan, and output.
TRNE F,%DSKDV ;done unless dsk dev, if so then
JRST [ .CALL ARDRNM ;rename while still open
JRST ARDKO7 ;failed for some reason; any failure here is permanent.
JRST .+1]
.CLOSE DKOC, ;and close to complete write.
POPAE P,[D,C]
AOS (P)
AOS (P)
RET
; check out err code, decide if temporary or not and return error
;string if permanent.
; Temporary errors for writing on DSK devices are:
; 5 - DIR FULL, 10 - DEV NOT AVAIL, 23 - FILE LOCKED (For W-O mode only)
;perhaps also 17 - DIR NOT AVAIL?
ARDKO5: TRNN F,%DSKDV ;skip if dsk dev, for checking known codes
JRST ARDKO8 ;ugh lossage
ARDKO6: CAIE C,5
CAIN C,10
JRST POPDC1 ; Aha, temporary lossage only.
CAIN C,17 ; Test for this too, I guess.
JRST POPDC1
;not dsk dev, or perm. disk error.
ARDKO7: .CLOSE DKOC,
ARDKO8: MOVE D,A
SAOBEG TMPC,
FWRITE TMPC,[6F,(D),[:],6F,1(D),[;],6F,2(D),[ ],6F,3(D),[ - ],ERR,]
MAKELN A,[0 ? %LTSAO,,0]
POPAE P,[D,C]
RET
ARDVPN: SETZ ? SIXBIT/OPEN/ ? [.UAO,,DKOC]
CERR C
(A) ? 2(A) ? 3(A) ? SETZ 1(A)
ARDOPN: SETZ ? SIXBIT /OPEN/ ? [.UAO,,DKOC] ; Unit Ascii out (for SIOT)
CERR C ;get error code if any into acc c
(A) ? [SIXBIT /_MAIL_/] ? ['OUTPUT] ? SETZ 1(A)
ARDRNM: SETZ ? 'RENMWO ? CIMM DKOC ? 2(A) ? SETZ 3(A)
; DEVCHK - Device Name checker
; Addr in A to 6bit device name,
; sets %DSKDV if it is dsk-type device,
; also %NETDV if it is dsk-type and actually a net site (e.g. ML:)
DEVCHK: PUSH P,A
TRZ F,%DSKDV+%NETDV
CAMN A,[SIXBIT /SECOND/]
JRST DVCHK5
HLRZ A,(A) ;get 3 chars 6bit device name, right justified
CAIE A,'DSK
CAIN A,'COM
JRST DVCHK5
CAIE A,'AI_6
CAIN A,'ML_6
JRST DVCHK6
CAIE A,'MC_6
CAIN A,'MD_6
JRST DVCHK6
CAIN A,'MX_6
JRST DVCHK6
CAIN A,'SYS
JRST DVCHK5
TRZ A,77
CAIE A,'AR_6
JRST POPAJ
DVCHK5: TROA F,%DSKDV ;come here when dsk device only
DVCHK6: TRO F,%DSKDV+%NETDV ;come here when also net device
POP P,A
RET
SUBTTL CLI sending routines
; CLIOPT - This is for telling a person that he has mail; it is used
; both for notifying real and pseudo recipients. Errors in CLIing
; are not reported.
; Option-dependent TTY message sender. A has 6bit of rcpt name (to make
; things easier); B has LP to rcpt's list.
.SCALAR CLIRPT
CLIOPT: PUSHAE P,[B,C,D]
MOVEM B,CLIRPT
FNDSTR C,B,A$ROPT,[NO-CLI] ; First things first... absolutely
CAIA ; no notification?
JRST CLIOP9 ; Nope, just return.
FINDA C,[A$NMH,,[$LLLST(L)]]
JRST CLIOP3
MOVE C,LISTAR(C)+1 ;get foreign originating site if any.
MOVEM C,CLIANC
MOVEI C,2
MOVEM C,CLITYP
JRST CLIOP4
; Local-originated message.
CLIOP3: FNDSTR D,CLIRPT,A$ROPT,[NO-LOCAL-CLI]
SKIPA
JRST CLIOP9 ;don't cli if he doesn't want local
FINDA C,[A$SNM,,[$LLLST(L)]] ; Find sender name
JSR AUTPSY
MOVE C,LISTAR(C)+1
ADD C,$LSLOC(L)
MOVEM C,CLIANC ; And store ASCNT ptr as arg.
MOVEI D,1 ; Say "You have mail from <sender>"
MOVEM D,CLITYP
; Find how big rcpt wants it.
CLIOP4: FNDSTR D,CLIRPT,A$ROPT,[SMALL-CLI]
SKIPA
JRST [SETZM CLIZMX ? JRST CLIOP6] ;give tiny msg if that's what he wants.
FNDSTR D,CLIRPT,A$ROPT,[INFINITE-CLI]
JRST [ MOVEI D,10. ; Default - use smarts.
MOVEM D,CLIZMX
MOVEI D,4
MOVEM D,CLIZMD
JRST CLIOP6]
HRLOI D,377777 ; Wants everything in msg...
MOVEM D,CLIZMX
CLIOP6: SETOM CLIZSW ; For now, always use lines.
MOVE B,CLIRPT
CALL CLIMS
CLIOP9: POPAE P,[D,C,B]
RET
; CLIMSG - Send a "TTY message" type message to all users with a given
; UNAME/XUNAME (in A). B has the rcpt's attrib list.
CLIMSG: PUSH P,C
MOVEI C,3 ; Use type 3, and
MOVEM C,CLITYP
FINDA C,[A$SNM,,[$LLLST(L)]] ; Find sender name
JSR AUTPSY
MOVE C,LISTAR(C)+1
ADD C,$LSLOC(L)
MOVEM C,CLIANC ; And store ASCNT ptr as arg.
SETZM CLIZSW ; Indicate char limit (faster)
HRLOI C,377777 ; Very big # to send all of msg.
MOVEM C,CLIZMX
SETZM CLIWIN
POP P,C
CALL CLIMS ; Send it...
SKIPE CLIWIN
AOS (P)
RET
; CLIMS - Sends a CLI message to all users with a given UNAME/XUNAME (in A).
; Each user gets the kind of header he wants.
; This is used when CLIing a piece of mail (which at the moment is
; all we ever CLI). It sets up the CLIHDR and CLITXT from the mail.
CLIMS: PUSH P,C
FINDA C,[A$RHDR,,[B]]
JRST [ FINDA C,[A$MHDR,,[$LLLST(L)]]
JSR AUTPSY
JRST .+1]
MOVE C,LISTAR(C)+1
ADD C,$LSLOC(L)
MOVEM C,CLIHDR
FINDA C,[A$MTXT,,[$LLLST(L)]]
JSR AUTPSY
MOVE C,LISTAR(C)+1
ADD C,$LSLOC(L)
MOVEM C,CLITXT
MOVEI B,CLISND
CALL XCTALU ; Call routine for all matching (X)UNAMEs.
POP P,C
RET
; takes ascnt ptr in a, returns in a the # lines in string.
NLINES: PUSHAE P,[B,C,D]
HLRZ D,A
JUMPE D,[SETZ A, ? JRST NLINS9]
HRLI A,440700
MOVE C,A
MOVEI A,1
NLINS1: ILDB B,C
CAIN B,^J
JRST [SOJLE D,NLINS9
AOJA A,NLINS1] ;only add to cnt if something after a lf.
SOJG D,NLINS1
NLINS9: POPAE P,[D,C,B]
RET
; XCTALU - Execute for All Users/Unames. (I know, delete the "for")
; Given a UNAME in A, and a routine address in B, executes
; the routine once for each HACTRN on the system with a UNAME
; or XUNAME matching the given one. Furnishes the routine
; with specific UNAME in A, but nothing else. Does not touch
; regs D or E, so these can be used for arguments.
; Note - if A is zero, it will match every X/UNAME!
XCTALU: PUSHAE P,[A,B,C]
MOVE B,['HACTRN]
MOVE C,@USRHI
XCTAL1: SUB C,LUBLK
JUMPLE C,XCTAL7
CAME B,@JNAME ; Is Jname = HACTRN?
JRST XCTAL1 ; If not, don't even test uname.
JUMPE A,XCTAL5 ; If arg = 0, match any HACTRN.
CAME A,@UNAME
CAMN A,@XUNAME
CAIA
JRST XCTAL1 ;neither uname nor xuname matches.
XCTAL5: MOVE A,@UNAME ;get real uname
CALL @-1(P) ; Execute given routine.
MOVE A,-2(P) ; Restore uname to look for...
JRST XCTAL1
XCTAL7: POPAE P,[C,B,A]
RET
SUBTTL CLI Sending Primitive Routine.
; CLISND - Hairy primitive for sending CLI messages. Args are given in the following
; block of variables. CLITYP & CLIANC determine what will be in the beginning of
; the message. Then the header (ASCNT in CLIHDR) is sent, andthen the message
; (ASCNT in CLITXT). CLIZSW, CLIZMX and CLIZMD determine how much of the
; message is cut off; the actual number left unsent (in either characters or lines
; depending on CLIZSW) is returned in A. The other "returned value" is in CLIWIN, which
; is AOSed every time a successful CLI message gets through.
; Types (in CLITYP) Arg wanted (in CLIANC)
; 0 (no prelude) (no arg)
; 1 (You have mail from) (ASCNT name of "from")
; 2 (You have net mail from) (host number)
; 3 (TTY message from) (ASCNT name of "from")
BVAR
CLITYP: 0 ; Specify type of CLI-message. Determines announcement given.
CLIANC: 0 ; Argument if any needed for announcement.
CLIHDR: 0 ; Give ASCNT string as "header"
CLITXT: 0 ; Give ASCNT string as text of message.
CLIZSW: 0 ; Switch indicating type of limiting values. (0 chars, -1 lines)
CLIZMX: 0 ; Maximum limiting value
CLIZMD: 0 ; Modulus if maximum exceeded.
CLIWIN: 0 ; AOS'd whenever CLISND succeeds.
CLILEV: 0 ; Value of P when CLISND was entered.
EVAR
CLIDEV: SIXBIT /CLI/ ; For laziness.
CLITMO: 180.*60. ; 3 minute timeout (sounds good...)
; Send CLI message using params above. Takes UNAME in A to send to.
CLISND: PUSHAE P,[B,C,D,E,CLILEV]
MOVEM P,CLILEV
MOVEI B,CLIRLT ; Set up addr to return to if we time out.
MOVEM B,RLTVEC
CLKSET CLITMO ; Set up the clock.
CLKON ; And enable interrputs
SYSCAL OPEN,[[.UAO,,CLIC] ? CLIDEV ? A ? ['HACTRN]]
JRST CLISN9 ; If failed, just return.
OUT(CLIC,OPEN(UC$IOT)) ; Aha! Onward!
OUT(CLIC,C(177)) ; Initial rubout tells DDT not to print "Message from"
SKIPN B,CLITYP ; Get type of msg
JRST CLISN2 ; Skip announcements if type = 0
CAIN B,1
JRST [ OUT(CLIC,("You have mail from "),TC(CLIANC))
JRST CLISN2]
CAIN B,2
JRST [ OUT(CLIC,("You have net mail from "),HST(CLIANC))
JRST CLISN2]
CAIN B,3
JRST [ OUT(CLIC,("TTY message from "),TC(CLIANC),("@"),HST(OWNHST))
JRST CLISN2]
CLISN2: SETZ D,
SKIPE CLIZSW ; Now see whether to hack chars or lines.
MOVEI D,1 ; Do it this way to be SURE of index.
MOVE A,CLIHDR ; First count header
XCT (D)[HLRZS A ? CALL NLINES]
MOVE B,A ; Save result, and then
MOVE A,CLITXT ; count text.
XCT (D)[HLRZS A ? CALL NLINES]
ADD A,B ; Now have total in A!
SKIPG CLIZMX ; If Max limit is LE 0,
JRST [ OUT(CLIC,SP,LPAR,D(A)) ; Just furnish length on single line.
MOVE C,(D)[ ASCNT [ Chars)]
ASCNT [ Lines)]]
OUT(CLIC,TC(C))
JRST CLISN8]
OUT(CLIC,(":"),EOL)
CAMG A,CLIZMX ; Well, now compare our count with maximum...
JRST [ OUT(CLIC,TC(CLIHDR),TC(CLITXT)) ; Win, just output all.
JRST CLISN8]
MOVE C,CLIZMD
CAMG B,C ; Foo, too much. See if HDR fits within limit...
JRST [ OUT(CLIC,TC(CLIHDR)) ; HDR fits, output it
SUB C,B ; And get limited count for Text.
MOVE B,CLITXT
JRST CLISN4]
MOVE B,CLIHDR ; Not enough for HDR even...
; Output up to c(C) units from string in B, saying there are c(A) left.
CLISN4: SUB A,C ; Find # units that will be left over.
JUMPE D,[HRL B,C ; If units are chars, it's easy.
OUT(CLIC,TC(B),SP,LPAR,D(A),(" more chars"),RPAR)
JRST CLISN8]
SETZ D, ; Clear cnt of chars (don't need type-of-limit now)
PUSHAE P,[A,B]
HRLI B,440700
CLISN5: ILDB A,B ; Get char
CAIN A,^J ; Each ^J is one line.
SOJLE C,.+2 ; For each line, decr cnt and jump if done.
AOJA D,CLISN5 ; Else incr cnt of chars seen.
POPAE P,[B,A]
HRLI B,1(D) ; Put right count into LH of ASCNT ptr
OUT(CLIC,TC(B),SP,LPAR,D(A),(" more lines"),RPAR)
CLISN8: OUT(CLIC,EOL)
.CLOSE CLIC,
AOS CLIWIN ; Increment cnt of wins!
CLISN9:
CLIRLT: SKIPL B,CLILEV
JSR AUTPSY ; That was no pdl pointer
CLKOFF
SETZM RLTVEC
MOVE P,B
POPAE P,[CLILEV,E,D,C,B]
RET
SUBTTL MASTER Manipulation routines
; IDFIND - Given ASCNT ptr in A to a Message ID, looks up on MASTER
; and skips if found, else doesn't skip. Returns LP to LLN in A.
IDFIND: PUSHAE P,[B,C,L]
SKIPN $AROPN+MASTER ; Make sure
CALL MSTGET ; MASTER is in core!
MOVE L,$ARLOC+MASTER ; Make MASTER the current LSE
HRRZ B,$LLLST(L) ; Initialize B = current node
CAIA
IDFND2: HRRZ B,LISTAR(B) ; Get next LN to check.
JUMPE B,IDFND9 ; If LP = 0, search failed.
FINDA C,[A$ID,,[LISTAR(B)+1]] ; Search list of this node.
JSR AUTPSY ; Huh? All should have this.
SLNEA C,A ; Compare strings
JRST IDFND2 ; No match, get next.
MOVE A,B ; Aha, match. return LP to it.
AOS -3(P)
IDFND9: POPAE P,[L,C,B]
RET
; IDDELE - Takes current MASTRP and deletes the message
; pointed to. Writes out MASTER file so as to finalize the
; deletion.
IDDELE: PUSHAE P,[A,L]
MOVE L,$ARLOC+MASTER
MOVE A,MASTRP ; Get LP to doomed LN.
FINDA A,[A$IDBL,,[LISTAR(A)+1]] ; Get length of LSE-blk on disk.
JSR AUTPSY
MOVE A,LISTAR(A)+1 ; Get # words used by LSE.
ADDM A,$LHMFG(L) ; Increment cnt of garbage wds.
MOVE A,MASTRP
LNDEL A,$LLLST(L) ; Now kill it.
CALL MSTPUT ; Write out MASTER file.
POPAE P,[L,A]
RET
SUBTTL MASTER and MSG-LSE Readin/Writeout
; MSGGET - Given SLP in A to a Message-ID string, brings that
; MSG-LSE into core provided it exists; doesn't skip if not.
; Checks to avoid reading in a MSG-LSE already in core.
; MSGGTA - Same, but A has ASCNT ptr instead of SLP.
MSGGTA: PUSH P,A
JRST MSGGT0
MSGGET: PUSH P,A
MOVE A,LISTAR(A)+1
ADD A,$LSLOC(L)
MSGGT0: PUSHAE P,[B,L]
SKIPN $AROPN+MSGAR ; Is MSG-LSE open or not?
JRST MSGGT5 ; Nope, obviously not in core!
MOVE L,$ARLOC+MSGAR ; Set current LSE to MSG.
FINDA B,[A$ID,,[$LLLST(L)]]
JRST MSGGT5 ; If not ID, clearly also not in core.
SLNEA B,A ; Compare requested ID with current, if any.
CAIA
JRST MSGGT8 ; Already in! Trivial return.
; Not currently in core, must look up on MASTER.
MSGGT5: MOVE B,A ; Save ID string.
CALL IDFIND ; Look up... Leaves MASTER-ptr in A.
JRST MSGGT9 ; But if couldn't find, tough. Don't skip.
MOVEM A,MASTRP
MOVE L,$ARLOC+MASTER ; Found! Make MASTER the current LSE.
FINDA A,[A$IDAD,,[LISTAR(A)+1]] ; Get the disk-address LN.
JSR AUTPSY ; none??
MOVE A,LISTAR(A)+1 ; Now get the disk address itself!
CALL MLSGET ; and now slurp up the LSE.
JRST MSGGT7 ; lost
MSGGT8: AOS -3(P) ; Won, skip on return.
MSGGT9: POPAE P,[L,B,A]
RET
MSGGT7: STAT (,(" =="),RABR,(" CAN'T READ IN MSG "),LBRC,TC(B),RBRC,(" BECAUSE "),LBRC,ERR,RBRC,(", FLUSHING "),LABR,("=="))
CALL IDDELE
JRST MSGGT9
; MSGDEL - Message Deletion. Deletes current message from MASTER
; and writes MASTER out, effectively flushing all traces of message.
MSGDEL: PUSHAE P,[A,B,L]
MOVE L,$ARLOC+MSGAR ; Set to MSG-LSE
FINDA A,[A$ID,,[$LLLST(L)]] ; Find MSG-ID
JSR AUTPSY
MOVE A,LISTAR(A)+1 ; Get SPT
ADD A,$LSLOC(L) ; Abs ASCNT ptr
CALL IDFIND ; Look up in MASTER
JRST MSGDL9 ; Not there, nothing to do.
MOVEM A,MASTRP ; Found it, store LP.
CALL IDDELE ; and go flush it.
MSGDL9: POPAE P,[L,B,A]
TLZ F,%MSGMD ; Certainly no modified message
RET
; MSGPUT - Writes out current MSG-LSE and MASTER, to effect either a
; new or changed MSG-LSE. Inserts proper disk address into
; MASTER entry and leaves LP to it in MASTRP.
MSGPUT: PUSHAE P,[A,B,C,L]
SKIPN $AROPN+MASTER ; Ensure that MASTER
CALL MSTGET ; is in core.
MOVE L,$ARLOC+MSGAR
SKIPN $AROPN+MSGAR
JSR AUTPSY ; Called with no message around (%MSGMD randomly on?)
FINDA A,[A$ID,,[$LLLST(L)]]
JSR AUTPSY
MOVE A,LISTAR(A)+1
ADD A,$LSLOC(L)
MOVE B,A ; Save ascnt ptr
CALL IDFIND ; Find LP to MSG-ID node, leaves in A.
CAIA
JRST MSGPT5
MOVE L,$ARLOC+MASTER ; Doesn't have one, must create one!
MAKELN A,[A$IDBL,,0 ? 0]
MAKELN A,[A$IDAD,,[A] ? 0]
MAKELN A,[A$ID,,[A] ? %LTSTR,,[B]]
MAKELN A,[A$I,,[$LLLST(L)] ? %LTLST,,[A]]
MOVEM A,$LLLST(L)
MSGPT5: MOVEM A,MASTRP
MOVE C,A ; Save in C
CALL MLSPUT ; Write out MSG-LSE; disk addr returned in A, len in B.
PUSH P,B ; Save length.
MOVE B,A
MOVE L,$ARLOC+MASTER ; Set MASTER as current LSE
FINDA A,[A$IDAD,,[LISTAR(C)+1]] ; Find LP to the disk-addr LN.
JSR AUTPSY
MOVEM B,LISTAR(A)+1 ; Store the disk address.
POP P,B ; Recover length
FINDA A,[A$IDBL,,[LISTAR(C)+1]]
JSR AUTPSY
ADDM B,$LHMFL(L) ; Add into length of MSGS (as seen by MASTER).
EXCH B,LISTAR(A)+1 ; Store disk-block length.
ADDM B,$LHMFG(L) ; Add previous length to garbage
SKIPN MKQFLG
CALL MSTPUT ; Now output the MASTER LSE.
POPAE P,[L,C,B,A]
RET
; MLSGET - Message LSE Readin. Given .ACCESS ptr in A to use, reads
; LSE from there into MSG-LSE, clears %MSGMD.
; Skip return if win.
MLSGET: PUSHAE P,[A,B,L]
MOVE B,A ; Put .ACCESS ptr in B.
MOVE A,[MSGAR,,MSGFN1]
CALL DFGETA ; Get the LSE, using .ACCESS hack.
CAIA ; Hmm, investigate.
AOS -3(P) ; won, skip
MLSGT9: TLZ F,%MSGMD ; Clear modify flag.
POPAE P,[L,B,A]
RET
; MLSPUT - Message LSE writeout. Writes current MSG-LSE onto top
; of MSGS file and returns in A its disk address, in B its length.
MLSPUT: MOVEI A,MSGFN1
CALL OPNMFW ; Open in write-over mode, trying hard.
MLSPT: SYSCAL FILLEN,[CIMM DKOC ? CRET B]
JSR AUTPSY
MOVEI A,MSGAR ; Now have args for LSEOUT...
CALL LSEOUT ; Put out the LSE! Returns addr in A,length in B.
TLZ F,%MSGMD ; Clear modification flag.
RET
; MSGSGC - GC's the MSGS file... both MSGAR and MASTER should have been
; written out before this is called.
; Sequence of file operations goes as follows:
; 1) Open <output> for writing, MSGS for reading.
; 2) copy from MSGS to <output>, updating MASTER internally.
; 3) When done, write out new MASTER as NMASTR.
; 4) RENMWO <output> -> NMSGS, and close to finalize.
; 5) Delete MASTER and MSGS in any order.
; 6) Rename NMASTR -> MASTER and NMSGS -> MSGS, also any order.
; If, on initialization, one of MASTER or MSGS is missing, it should be
; replaced by NMASTR or NMSGS as appropriate; error if new version doesn't exist!
; If one wants to be picky, it is possible to recover from crash between
; steps 4 and 5 by checking for existence of both NMASTR and NMSGS even when
; MASTER and MSGS both exist, but why bother?
BVAR
MGCNPT: 0 ; To hold new disk address while copying.
MGCECT: 0 ; Expected length of new file, should = MGCNPT at end.
EVAR
MSGSGC: PUSHAE P,[A,B,C,D,L]
SKIPN $AROPN+MASTER
CALL MSTGET ; Ensure MASTER in core
MOVE L,$ARLOC+MASTER
MOVE A,$LHMFL(L) ; Get length of MSGS
SUB A,$LHMFG(L) ; Sub # garbage wds...
MOVEM A,MGCECT ; Save as expected length of new file.
STAT (,("Note: GC'ing MSGS, "),OCT($LHMFL(L)),("-"),OCT($LHMFG(L)),("="),OCT(A))
SETZ A,
CALL OPNMFO ; Open NMSGS for writing, (standard output fnm)
SETZM MGCNPT ; Set write pointer to 0.
MOVEI A,MSGFN1
CALL OPNMFI ; And MSGS for reading.
JSR AUTPSY
UAROPN [TMPAR ? [2000]] ; Allocate a 1K buffer.
HRRZ D,$LLLST(L) ; D contains LP for stepping through MASTER.
CAIA
MSGC10: HRRZ D,LISTAR(D)
JUMPE D,MSGC50 ; Jump when finished.
FINDA A,[A$IDAD,,[LISTAR(D)+1]] ; Get LP to disk address
JSR AUTPSY
FINDA B,[A$IDBL,,[LISTAR(D)+1]] ; & length.
JSR AUTPSY
; Simply copy block specified from MSGS on top of current NMSGS.
.ACCESS DKIC,LISTAR(A)+1 ; Read from given address
MOVE B,LISTAR(B)+1 ; Get cnt
MSGC20: SUBI B,2000 ; Sub 1K from cnt
MOVNI C,2000 ; and use -2000 for IOT
CAIGE B,0 ; unless we subtracted too much,
MOVNI C,2000(B) ; in which case add back and use -cnt.
HRLZS C
HRR C,$ARLOC+TMPAR ; AOBJN set up.
PUSH P,C
.IOT DKIC,C ; Read in.
POP P,C
.IOT DKOC,C ; Write out.
JUMPG B,MSGC20
; Fall through when done.
MOVE C,MGCNPT ; Get back new address, within NMSGS.
MOVEM C,LISTAR(A)+1 ; Store it in A$IDAD (Disk-addr) LN.
SYSCAL RFPNTR,[CIMM DKOC ; Find next address within NMSGS
CRET MGCNPT] ; I know I can keep a count, this makes SURE.
JSR AUTPSY
JRST MSGC10 ; Get another msg.
; All done with copying, now for file shell game.
MSGC50: SETZM $LHMFG(L) ; Zero cnt of garbage wds
MOVE A,MGCNPT
MOVEM A,$LHMFL(L) ; And set new length of MSGS.
CAME A,MGCECT ; Same as that expected?
JRST [ CSTAT (,(", *Err?* NL="),OCT(A))
JRST .+1]
MOVE A,[MASTER,,NMSFN1] ; Now write out NMASTR.
.IOPUSH DKOC,
CALL DFPUT
.IOPOP DKOC,
TLZ F,%MSTMD
SYSCAL RENMWO,[CIMM DKOC ? NMGFN1 ? NMGFN1+1] ; Actually rename to NMSGS.
JSR AUTPSY ; Bleah?
.CLOSE DKOC, ; And finalize. Now have NMASTR, NMSGS.
; Begin Step # 5.
SYSCAL DELETE,[SATDEV ? MSTFN1 ? MSTFN1+1 ? SATDIR ? CERR A]
JRST [ CAIN A,4 ; If already vanished, that's odd...
JRST .+1 ; but OK anyway.
JSR AUTPSY]
SYSCAL DELETE,[SATDEV ? MSGFN1 ? MSGFN1+1 ? SATDIR ? CERR A]
JRST [ CAIN A,4 ; If already vanished, that's odd...
JRST .+1 ; but OK anyway.
JSR AUTPSY]
; Now do Step # 6
SYSCAL RENAME,[SATDEV ? NMSFN1 ? NMSFN1+1 ? SATDIR
MSTFN1 ? MSTFN1+1]
JSR AUTPSY
SYSCAL RENAME,[SATDEV ? NMGFN1 ? NMGFN1+1 ? SATDIR
MSGFN1 ? MSGFN1+1]
JSR AUTPSY
CSTAT (,(", Done!"))
POPAE P,[L,D,C,B,A] ; Done.....
RET
LVAR GCQFLG: 0 ; Flag for when to GC queues.
; MGCFIX - Called at startup to check for crashing during MSGS GC'ing,
; & thereby fix it.
MGCFIX: PUSH P,A
SYSCAL OPEN,[[.UII,,DKIC] ? SATDEV
MSGFN1 ? MSGFN1+1 ? SATDIR ? CERR A]
JRST [ CAIN A,4
JRST .+2
JSR AUTPSY] ; Random file error?
JRST MGCFX5
STAT (,("Note: No MSGS file, using NMSGS"))
SYSCAL RENAME,[SATDEV ? NMGFN1 ? NMGFN1+1 ? SATDIR
MSGFN1 ? MSGFN1+1]
JSR AUTPSY
MGCFX5: SYSCAL OPEN,[[.UII,,DKIC] ? SATDEV
MSTFN1 ? MSTFN1+1 ? SATDIR ? CERR A]
JRST [ CAIN A,4
JRST .+2
JSR AUTPSY]
JRST MGCFX8
STAT (,("Note: No MASTER file, using NMASTR"))
SYSCAL RENAME,[SATDEV ? NMSFN1 ? NMSFN1+1 ? SATDIR
MSTFN1 ? MSTFN1+1]
JSR AUTPSY
MGCFX8: .CLOSE DKIC, ; All's well...
SYSCAL DELETE,[SATDEV ? NMGFN1 ? NMGFN1+1 ? SATDIR]
JFCL
SYSCAL DELETE,[SATDEV ? NMSFN1 ? NMSFN1+1 ? SATDIR]
JFCL
MGCFX9: POP P,A
RET
; MSTGET - Reads in MASTER.
MSTGET: PUSH P,A
MOVE A,[MASTER,,MSTFN1]
CALL DFGET
JSR AUTPSY
TLZ F,%MSTMD
POP P,A
RET
; MSTPUT - Writes out MASTER.
MSTPUT: PUSH P,A
MOVE A,[MASTER,,MSTFN1]
CALL DFPUT
TLZ F,%MSTMD
POP P,A
RET
; QMLGET - Reads in QML.
QMLGET: PUSH P,A
MOVE A,[QMLAR,,QMLFN1]
CALL DFGET
JSR AUTPSY
TLZ F,%QMLMD
POP P,A
RET
; QMLPUT - Writes out QML.
QMLPUT: PUSH P,A
MOVE A,[QMLAR,,QMLFN1]
CALL DFPUT
TLZ F,%QMLMD
POP P,A
RET
; RMLGET - Reads in RML.
RMLGET: PUSH P,A
MOVE A,[RMLAR,,RMLFN1]
CALL DFGET
JSR AUTPSY
TLZ F,%RMLMD
POP P,A
RET
; RMLPUT - Writes out RML.
RMLPUT: PUSH P,A
MOVE A,[RMLAR,,RMLFN1]
CALL DFPUT
TLZ F,%RMLMD
POP P,A
RET
SUBTTL Data File primitives
; DFGET - Data File Readin. A = <ARPT>,,<filblk addr>
; Opens specified file, and reads it into a LSE, using given ARPT.
; Skips unless file not found.
DFGET: PUSH P,B
SETO B, ; Indicate not interested in .ACCESS hacking.
CALL DFGETA ; Get it.
JRST POPBJ ; No such file?
POP P,B
AOS (P)
RET
; DFGETA - Data File Readin, with .ACCESS. A = <ARPT>,,<filblk addr>
; and B = .ACCESS ptr.
; Opens specified file, and reads from specified location into
; a LSE, using given ARPT. Skips unless file not found,
; or IOC error while trying to read (e.g. access pointer off end of file)
DFGETA: CALL OPNMFI ; Open it, trying hard.
RET ; there isn't any such file?
MOVSS A ; Get ARPT into RH.
CALL LSEIN ; Read in LSE, using .ACCESS ptr in B.
SOSA (P) ; lost, non-skip return
.CLOSE DKIC, ; If lost, don't close so as to leave error code around
; in STASAV if it burns up because of this IOC error
MOVSS A ; restore A.
AOS (P)
RET
; DFPUT - Data File writeout. A = <ARPT>,,<FN1/2 addr>
; Writes LSE specified by ARPT to specified file.
DFPUT: PUSHAE P,[A,B,C]
MOVE C,A ; Save for later.
SETZ A, ; Actually open temporary file.
CALL OPNMFO ; Open for output, trying hard.
HLRZ A,C ; Put ARPT in RH of A.
SETO B, ; Indicate not interested in .ACCESS hacking.
CALL LSEOUT ; Write out the LSE.
HRRZ A,C ; Restore addr to FN's
.CALL RNMMFO ; and rename output file to right thing.
JSR AUTPSY
.CLOSE DKOC,
POPAE P,[C,B,A]
RET
RNMMFO: SETZ ? 'RENMWO ? CIMM DKOC ? (A) ? SETZ 1(A)
; OPNMFO - Given addr of FN1/2 in RH of A, tries hard to open
; for Block Image Output, and skips. Assumption is that it
; MUST be possible to write the file.
; Only error should be 5 = DIR FULL, which is handled.
; If A = 0, uses a standard temporary output FN.
; OPNMFW - Similar, but in write-over mode without A=0 hack.
OPNMFO: CAIN A,0
MOVEI A,TMPFN1
SYSCAL OPEN,[[.BIO,,DKOC] ? SATDEV ? (A) ? 1(A) ? SATDIR ? CERR OMFERR]
CAIA ; Error?? Must skip to inspect.
RET ; Normally win - return.
PUSH P,[OPNMFO] ; Hack - set up like PUSHJ and drop in.
OPNMLS: PUSH P,B
MOVE B,OMFERR
CAIN B,%ENAFL ; 23 = File locked?
JRST [ MOVEI B,30. ; Some loser has file open! Wait it out...
.SLEEP B, ; Maybe later take more active action.
PJRST POPBJ] ; Re-try.
CAIE B,5 ; 5 = DIR FULL is only other reasonable error.
JSR AUTPSY ; all others barf instantly.
POP P,B
CALL SDFULL ; Call on magic routine... if it returns at all,
RET ; we can win! Return to routines to try again.
; Don't replace by PJRST, for easier debug tracing.
CALL OPNMLS
OPNMFW: SYSCAL OPEN,[[%DOWOV+%DORWT+.BIO,,DKOC] ? SATDEV ? (A) ? 1(A) ? SATDIR ? CERR OMFERR]
JRST OPNMFW-1
RET
LVAR OMFERR: 0 ; If error happens, code gets stuck here.
TMPFN1: SIXBIT /_SATEL/
SIXBIT /OUTPUT/
; OPNMFI - Similar, but opens for .BII instead and skips.
OPNMFI: SYSCAL OPEN,[[.BII,,DKIC] ? SATDEV ? (A) ? 1(A) ? SATDIR]
CAIA
AOS (P)
RET
; General purpose opener
OPNFLI: SYSCAL OPEN,[[.BII,,DKIC] ? (A) ? 2(A) ? 3(A) ? 1(A)]
CAIA
AOS (P)
RET
SUBTTL File getters -- FILGET, FILIN, TXFGET, TXFIN
; FILGET - File Getter. A has <ARPT>,,<FILPT>; specified file
; is opened and read into specified area; if <ARPT>=0 then
; an area is created. In either case the ARPT is returned in A,
; and routine skips. If the OPEN fails, its error code is
; returned instead with no skip.
; FILIN - similar, but assumes DKIC already open on channel, and never skips,
; since no lossage is possible. (!)
; FILINL - Like FILIN but takes a limit in B of max # wds to read.
FILINL: PUSH P,B
JRST FILIN0
FILGET: .CALL OPNBII ; Try to open FILBLK specified.
JRST [ MOVE A,OPNERR ; For failure, return error code.
RET]
AOS (P)
FILIN: PUSH P,B
HRLOI B,377777 ; Read up to maximum!
FILIN0: PUSH P,C
MOVE C,B
MOVE B,[DKIC,,FGTDEV]
.RCHST B, ; Get channel status for possible later ref.
SYSCAL FILLEN,[CIMM DKIC ? CRET B ? CERR OPNERR]
JRST [ MOVE B,OPNERR ; Failed? Should only happen if
CAIE B,34 ; error = wrong type dev.
JSR SYSLOS ; No. this shouldn't happen.
MOVEI B,400 ; If no length available, use 1/4 page.
JRST .+1]
ADDI B,1 ; Add 1 so .IOT ptr won't count out completely
CAMLE B,C ; If length greater than limit,
MOVE B,C ; Force to limit!!
HLRZS A ; Put ARPT into RH.
UAROPN A,[(A) ? B] ; Open area, with length at least that of file/
MOVN B,B ; Negate.
HRLZ B,B ; For .IOT ptr.
HRR B,$ARLOC(A) ; Get addr to store it...starting addr of area.
FILGT5: PUSH P,B
HLRE B,B
ADD C,B
POP P,B
JUMPL C,FILGT8 ; Stop if past limit.
.IOT DKIC,B ; grab
HRRZM B,$ARWPT(A) ; set write ptr for area.
JUMPGE B,[MOVEI B,400 ; If counted completely out,
UAREXP B,(A) ; expand and get more.
HRRZ B,$ARWPT(A)
HRLI B,-400
JRST FILGT5]
FILGT8: .CLOSE DKIC,
POP P,C
POP P,B
RET
OPNBII: SETZ ? SIXBIT /OPEN/ ? [.BII,,DKIC] ? CERR OPNERR
(A) ? 2(A) ? 3(A) ? SETZ 1(A)
BVAR
OPNERR: 0
FGTDEV: BLOCK 10 ;channel status info
EVAR
; TXFGET - Text File Getter. Like FILGET, but assumes file is text
; and converts area to text, adjusting EOF properly.
; TXFIN - similar conversion but like FILIN assumes DKIC is open and
; never skips.
TXFGET: CALL FILGET ; Open and get file into area.
RET ; Failed.
AOSA (P) ; Won, skip into conversion & skip on return.
TXFIN: CALL FILIN
UARTYP [%ARTCH,,(A)] ; Convert area to text,
RET ; adjusting EOF automatically.
TXFINL: CALL FILINL ; Like TXFIN but takes limit in B.
UARTYP [%ARTCH,,(A)] ; Convert area to text,
RET ; adjusting EOF automatically.
;;; EQVLEN - Return in U2 the length of the equivalences binary file.
;;; This is used by IRQGET to estimate how much space is available.
EQVLEN: PUSH P,A
.IOPUSH DKIC, ; Save chan.
SETZ U2, ; Return size in U2.
SKIPE $AROPN+EQVAR ; If already in core
JRST EQVLE9 ; don't count it.
MOVEI A,EQVFN1 ; EQV binary file.
CALL OPNMFI ; Try to open it up.
JRST EQVLE9 ; Lost!
SYSCAL FILLEN,[CIMM DKIC ? CRET U2]
NOP
ADDI U2,22.*PG$SIZ ; Measurements seem to be off by this much?
EQVLE9: .IOPOP DKIC,
POP P,A
RET
SUBTTL Disk Input copy
; DKIOUT - Copies from DKIC to DKOC until reaches EOF on DKIC.
; Tries to be clever about finding "true" EOF, by using only
; the byte-count length if the input file has byte-size 7,
; and if not examines the last input word to flush trailing
; padding chars (^C, ^L, ^@).
DKIOUT: PUSHAE P,[A,B,C,D]
MOVE B,[DKIC,,FGTDEV] ; Arg to RCHST
.RCHST B, ; Get chan status for possible later ref.
UAROPN A,[OMFAR ? [PG$SIZ+1]] ; Open buffer area.
SYSCAL FILLEN,[CIMM DKIC ? CERR OPNERR
CRET JUNK ? CRET B ? CRET C ? CRET D]
JRST [ MOVE B,OPNERR ; Failed? Should only happen if
CAIE B,34 ; error = wrong type dev.
JSR SYSLOS ; Shouldn't ever be anything else.
JRST DKIOU4] ; Hmm, just proceed as for word-mode files.
JUMPE C,DKIOU8 ; Optimize for zero-length pathological case...
CAIE D,7 ; If file wasn't written with byte-size 7 (text),
JRST DKIOU4 ; go handle word-mode.
IDIVI C,5 ; Text! Find how many words, and get only that many.
CAIN D, ; If exact multiple of 5,
SKIPA D,[5] ; then say 5 chars in last word.
ADDI C,1 ; else leave D correct, and make sure we read last wd.
DKIOU2: SKIPG B,C
JRST DKIOU9
CAILE B,PG$SIZ ; If # words to go is too large,
MOVEI B,PG$SIZ ; stick to limit.
SUBI C,(B) ; Update count
MOVNI B,(B)
MOVSI B,(B)
HRR B,$ARLOC(A) ; Set up IOT aobjn-type ptr.
XCTIOC [.IOT DKIC,B] ; Slurp up.
JRST DKIOU9 ; Probably a data error if get here.
JUMPL B,DKIOU6 ; If didn't complete, length was wrong!!
JUMPLE C,DKIOU3 ; Jump if this was the last slurp.
MOVE B,$ARLOC(A) ; Not last, output full buffer
HRLI B,PG$SIZ*5
XCTIOC [OUTCAL(DKOC,TC(B))] ; Output it,
JRST DKIOU9 ; Failure of some sort.
JRST DKIOU2 ; and go slurp some more.
; Have last slurp in buffer, B has addr+1 of last wd.
; D has # chars in the last wd.
DKIOU3: MOVEI B,-1(B) ; Get addr of last word
SUB B,$ARLOC(A) ; Find # words
IMULI B,5 ; Get # chars
ADDI B,(D) ; and include last partial word.
MOVSI B,(B)
HRR B,$ARLOC(A)
XCTIOC [OUTCAL(DKOC,TC(B))] ; Output it!
JRST DKIOU9 ; Failure of some sort.
JRST DKIOU8 ; Done...
; Here, file is of indeterminate length. Read it in
; and always keep the last word of previous input
; around for reference; it only gets output if there
; is in fact more stuff following it.
DKIOU4: MOVE B,$ARLOC(A)
HRLI B,-<PG$SIZ+1> ; Get stuff plus one extra wd.
DKIOU5: XCTIOC [.IOT DKIC,B] ; Gobble gobble
JRST DKIOU9
JUMPL B,DKIOU6 ; Snarfed last stuff?
MOVE C,-1(B) ; Nope, recover last word input
MOVE B,$ARLOC(A) ; and output all but that last word.
HRLI B,PG$SIZ*5
XCTIOC [OUTCAL(DKOC,TC(B))]
JRST DKIOU9
MOVE B,$ARLOC(A)
MOVEM C,(B) ; Store the remaining word as 1st in buffer
HRLI B,-PG$SIZ ; and set new count accordingly
AOJA B,DKIOU5 ; so as to IOT above that word.
; Read in last stuff. B has addr+1 of last word read.
DKIOU6: HRLI B,350700 ; Make ptr to 1st non-ex char
MOVE D,$ARLOC(A) ; And get fence for backing up.
DKIOU7: DBP7 B ; Decrement it, point at previous char.
CAILE D,(B) ; Continue as long as still in buffer.
JRST DKIOU8 ; Backed too far, none to output! win.
LDB C,B ; Get it
CAIE C,^L ; Test for any of several garbage chars.
CAIN C,^C
JRST DKIOU7
JUMPLE C,DKIOU7
HRLI D,440700
PTRDIF D,B ; Find # chars, B-D
MOVSI D,(D)
HRR D,$ARLOC(A) ; Make ASCNT ptr to string
XCTIOC [OUTCAL(DKOC,TC(D))] ; and output forthwith.
JRST DKIOU9
; Fall through when done.
DKIOU8: AOS -4(P) ; Win return.
DKIOU9: .CLOSE DKIC, ; Don't need any more.
UARCLS (A) ; Likewise flush area buffer.
POPAE P,[D,C,B,A]
RET
SUBTTL Open DKOC in Append Mode
; Unfortunately ITS has no way to set file length nor to
; keep length at original setting until channel closed.
; OPNAPP - Open DKOC in Append mode.
; A - addr of filblk
; Skips on success,
; else B - RH has error code for last sys call (or 0 for general lossage)
; Sign bit set for "permanent" errors.
.SCALAR EOFFIL ; True file EOF, in 7-bit bytes
.SCALAR EOFREC ; "Record" EOF, in ditto.
EOFMRK: 037 ; ctl underscore, normal MAIL file record separator.
OPNAPP: PUSH P,C
SETZM EOFFIL ; Clear file EOF
SETZM EOFREC ; and record EOF
OPNAP0: SYSCAL OPEN,[[.UAI,,DKIC] ; First, try opening for read...
(A) ? 2(A) ? 3(A) ? 1(A) ; Use true filespec.
CERR B]
CAIA
JRST OPNAP3
CAIE B,%ENSFL ; No such file?
JRST OPNAP7 ; Any other error, fail with check.
MOVE C,3(A) ; See if AOS'd version exists...
AOS C
SYSCAL RENAME,[(A) ? 2(A) ? C ? 1(A)
2(A) ? 3(A) ? CERR B]
CAIA
JRST OPNAP0 ; Success, try reading with original name!
CAIN B,%ENSFL ; No such file here either?
JRST OPNAP6 ; Yup, just create file.
CAIN B,%EEXFL ; Or File already exists?
JRST OPNAP0 ; Well, well, try again.
JRST OPNAP7 ; Anything else means just fail, with temp/perm chk.
; File opened for reading, now find EOF's.
OPNAP3: SYSCAL FILLEN,[CIMM DKIC ? CRET C ? CERR B]
JRST OPNAP9 ; Any error is permanent, since should only happen for
; non-disk devices.
; We know that bytesize of chan will be 7. Perhaps later
; some hair could depend on whether file was written in byte
; or word mode, but current brutalgorithm works either way.
MOVEM C,EOFFIL ; Store file's true EOF
MOVEM C,EOFREC
; Now read backwards thru file until hit record-EOF mark.
OPNAP4: SOSG C,EOFREC
JRST OPNAP6 ; Backed to start, re-create.
.ACCESS DKIC,C
.IOT DKIC,B
CAME B,EOFMRK ; Char = to EOF mark?
JRST OPNAP4 ; Nope, keep backing up.
AOS EOFREC ; Win! Set final record-EOF value.
OPNAP6: .CLOSE DKIC,
MOVE C,[.UAO,,DKOC]
SKIPLE EOFREC ; If record EOF is for real,
TLO C,%DOWOV+%DORWT ; use write-over mode.
SYSCAL OPEN,[C ; OK, try opening!
(A) ? 2(A) ? 3(A) ? 1(A) ; Use true filespec.
CERR B]
JRST OPNAP7 ; Error now? Sigh...
SKIPLE EOFREC ; Successful open! Need to adjust write ptr?
.ACCESS DKOC,EOFREC ; Yep, just do it.
AOS -1(P) ; Win return!
JRST OPNAP9 ; Value of B doesn't matter.
; Check out err code to see if should advise temp or perm
; (i.e. try again later, or give up.)
OPNAP7: CAIE B,%EFLDR ; Dir full?
CAIN B,%ENADV ; or dev not avail?
JRST OPNAP8 ; either is temp err.
CAIE B,%ENAFL ; File locked?
CAIN B,%ERODV ; Device write-locked? (This one maybe perm)
JRST OPNAP8
CAIE B,%EFLDV ; Device full? (This one maybe impossible)
JRST OPNAP9 ; Anything else is PERMANENT error.
OPNAP8: TLZA B,-1 ; Temp err, return positive B.
OPNAP9: TLO B,(SETZ) ; Perm err, return negative B.
POP P,C
RET
SUBTTL Filename Parsing
; Given ASCNT ptr in A to string, assumes it is bracketed filename and parses
;into block using defaults as specified by <defblk>,,<filblk> in B.
FILPAR: PUSHAE P,[A,B,C,D,E]
MOVE E,B
BLT B,3(E) ;fill block with defaults before parsing
CALL PARFNM ;parse it
CAIE A,
MOVEM A,(E) ;store dev
CAIE B,
MOVEM B,1(E)
CAIE C,
MOVEM C,2(E)
CAIE D,
MOVEM D,3(E)
POPAE P,[E,D,C,B,A]
RET
; given ascnt ptr in a to bracketed filename, returns in a,b,c,d the
;dev/dir/fn1/fn2 with zeros where none found. parses like ddt, i.e.
;single name treated like fn1, not teco-style fn2.
; Flushes first "[" and last "]" if latter exists... ^Q quotes.
BVAR
PRFC: 0 ; cnt for string
PRFP: 0 ; bp to string
PRFDEV: 0 ; DEV if any
PRFDIR: 0 ; DIR "
EVAR
PRCGT: SOSGE PRFC ; Read a char
RET
ILDB A,PRFP
AOS (P)
RET
PARFNM: HLRZM A,PRFC ;store cnt
HRLI A,440700
MOVEM A,PRFP ;and ptr
SETZB C,D ; Clear FNM's
PARFN0: CALL PRCGT
JRST [SETZB A,B ? RET] ;nothing there? Ensure nothing returned.
CAIE A,"{
CAIN A,"[
JRST PARFN1
CAIN A,40 ;flush spaces
JRST PARFN0
AOS PRFC ;else char is beg of filename; back up.
D7BPT PRFP
PARFN1: SETZM PRFDEV
SETZM PRFDIR
PARFN2: SKIPG PRFC
JRST PARFN9 ;done
CALL PRCGET ;get token
CAIN B,":
JRST [MOVEM A,PRFDEV ? JRST PARFN2]
CAIN B,";
JRST [MOVEM A,PRFDIR ? JRST PARFN2]
CAIN B,40
JRST [CALL PRFNPT ? JRST PARFN2]
; Any other terminator = EOF. Falls thru...
PARFN8: JUMPE A,PARFN9
CALL PRFNPT
PARFN9: MOVE A,PRFDEV
MOVE B,PRFDIR
RET
PRFNPT: JUMPE C,[MOVE C,A ? RET]
JUMPE D,[MOVE D,A ? RET]
SKIPN PRFDEV
JRST [MOVEM A,PRFDEV ? RET]
MOVEM A,PRFDIR
RET
.SCALAR PRC6WD ; Holds accumulated 6bit
PRCGET: MOVE B,[440600,,PRC6WD]
SETZM PRC6WD
PRCGT1: CALL PRCGT
JRST PRCGT6
CAIE A,";
CAIN A,":
JRST PRCGT7
CAIE A,40
CAIN A,"]
JRST PRCGT7
CAIN A,"}
JRST PRCGT7
CAIN A,^Q ;quoting?
JRST [ CALL PRCGT ;insert next char whatever it is.
JRST PRCGT6
JRST .+1]
CAIL A,141
CAILE A,172
SKIPA
SUBI A,40
SUBI A,40
TLNE B,770000
IDPB A,B ;don't deposit if already done 6 chars.
JRST PRCGT1
PRCGT6: TDCA B,B ;clear B and skip.
PRCGT7: MOVE B,A
MOVE A,PRC6WD
RET
SUBTTL Random little routines
; LASCIZ - Addr in A to asciz string, returns in A the # chars in string.
; String must obviously start on word boundary.
; Faster than LBPASZ (8 instrs/loop and no ILDB'ing).
LASCIZ: PUSHAE P,[B,C]
MOVE C,A
TDCA A,A ;clear A and skip
LASCZ1: ADDI A,5
SKIPE B,(C)
TLNN B,774000 ; Test 1st char
JRST LASCZ7 ; Null, done.
TLNN B,3760 ; Test 2nd char
AOJA A,LASCZ7 ; Null, add 1 and done.
TDNN B,[17,,700000]
JRST LASCZ6 ; Go add 2, done.
TRNN B,77400
AOJA A,LASCZ6 ; Add 3
TRNE B,376
AOJA C,LASCZ1 ; Not ended yet; increment address and add 5.
ADDI A,4
JRST LASCZ7
LASCZ6: ADDI A,2
LASCZ7: POP P,C
POP P,B
RET
; LBPASZ - Takes a BP to an ASCIZ string in A, and returns the number of chars
; in A. (Like LASCIZ, but allows any BP).
LBPASZ: PUSHAE P,[B,C]
SETZ B,
ILDB C,A
CAIE C,0
AOJA B,.-2
MOVE A,B
POPAE P,[C,B]
RET
; ASZCNT - Takes address of an ASCIZ string (in A), returns ASCNT
; to that string (in A).
ASZCNT: PUSH P,A ; Save addr
CALL LASCIZ ; Get length of asciz string.
HRLM A,(P) ; Store cnt in LH of saved addr.
POP P,A ; restore as ASCNT ptr.
RET
; AZMCNT - Takes addr in A of string which stops on either ^@ or ^M
; and returns ASCNT ptr in A.
AZMCNT: PUSHAE P,[B,C]
HRLI A,440700
HRLZ B,A
ILDB C,A
JUMPE C,.+3
CAIE C,^M
AOJA B,.-3
MOVS A,B
POPAE P,[C,B]
RET
; CVT6PC - Takes <cnt>,,[<bp>] in A, returns SIXBIT in A.
CVT6PC: PUSHAE P,[B,C]
HLRZ B,A
MOVE C,(A)
PJRST CVT6
; CVLS6 - Takes SLP in A, returns SIXBIT in A.
CVLS6: MOVE A,LISTAR(A)+1 ;get SPT
ADD A,$LSLOC(L) ;make abs and drop thru into CVT76C
; CVT76C - Takes an ASCNT in A, returns SIXBIT in A.
CVT76C: PUSHAE P,[B,C]
HLRZ B,A ;cnt in B
MOVE C,A ;bp in C
HRLI C,440700
CVT6: PUSHAE P,[D,E]
JUMPE B,[SETZ A,
JRST CVT762] ;if cnt = 0
CAILE B,6
MOVEI B,6 ;force to 6 if greater than
JRST CVT760
; CVT76 - Takes a BP to an ASCIZ string in A, returns SIXBIT in A.
; Stops when reach 0 or get 6 chars, or hit blank and previous
; chars were nonblank.
CVT76: PUSHAE P,[B,C,D,E]
MOVE C,A
MOVEI B,6
CVT760: SETZ A,
MOVE D,[440600,,A]
CVT761: ILDB E,C
CAIN E,40
JUMPN A,CVT762 ;if hit blank, stop only if something already accumulated
JUMPE E,CVT762
CAIL E,141 ;convert to uppercase
CAILE E,172
CAIA
SUBI E,40
SUBI E,40 ;convert to 6bit
IDPB E,D
SOJG B,CVT761
CVT762: POPAE P,[E,D,C,B]
RET
;;; Various uppercasifiers, all smash the string given in A as argument,
;;; and clobber no ACs.
; SLNUPR - A/ SLP (LP to string)
; UPPRZ - A/ ASCNT pointer
; UPPRZB - A/ <char cnt>,,[<byte ptr>]
SLNUPR: PUSHAE P,[A,B,C]
MOVE B,LISTAR(A)+1 ; Get the SPT for it.
HLRZ C,B ; Get count
ADD B,$LSLOC(L) ; Make absolute addr
HRLI B,440700 ; And BP
PJRST UPRCS7
UPPRZ: PUSHAE P,[A,B,C]
HLRZ C,A ; get count in C
MOVE B,A
HRLI B,440700 ; and BP in B
PJRST UPRCS7
UPPRZB: PUSHAE P,[A,B,C]
MOVE B,(A) ;get byte ptr
HLRZ C,A ;get cnt
JRST UPRCS7
UPRCS4: ILDB A,B
CAIL A,141 ;lower a
CAILE A,172 ;lower z
UPRCS7: SOJGE C,UPRCS4 ; Not lowercase, continue.
JUMPL C,PPCBAJ
SUBI A,40 ;lower, cvt to upper
DPB A,B ;deposit back
SOJGE C,UPRCS4
POPAE P,[C,B,A]
RET
SUBTTL Random variables, data areas.
;;; Table of ARPT's to all standard ARBLK's to be flushed when coring down.
ARPTBL: MASTER
MSGAR
;SCHDAR ;keep this in core
QMLAR
RMLAR
EQVAR
TMPAR
ETXTAR
EMSGAR
PGMAR
OMFAR
IMSAR
NAREAS==.-ARPTBL
BVAR
MASTER: BLOCK $ARSIZ ; Master message-ID list area.
MSGAR: BLOCK $ARSIZ ; Message list area.
SCHDAR: BLOCK $ARSIZ ; Scheduler list area.
QMLAR: BLOCK $ARSIZ ; Queued Message list area.
RMLAR: BLOCK $ARSIZ ; Reminders list area.
EQVAR: BLOCK $ARSIZ ; Equivalence list area.
ETXTAR: BLOCK $ARSIZ ; Error-message text collection area.
EMSGAR: BLOCK $ARSIZ ; Error-message attrib collection area.
OMFAR: BLOCK $ARSIZ ; Area used for forming mail-file output.
PGMAR: BLOCK $ARSIZ ; Area for holding composition of SNDPGM error message.
TMPAR: BLOCK $ARSIZ ; Temporary area for various things.
MASTRP: 0 ; Holds LP to "current" LLN of MASTER list.
IMSAR: BLOCK $ARSIZ ;area containing input from file
IMSTIM: 0 ;creation date of file
RCPNUM: 0 ;# of Rcpts seen.
RRCPS: 0 ;# of real (not psuedo-name) recipients.
HFLUSN==10. ;(How many sites in the following losers list.)
HFLUSH: ;List of sites whose queued mail should be flushed.
REPEAT HFLUSN,-1 ;Use zero to indicate the local host.
HDOWN: 250. ; Number of tries before host permanently down.
; 500. = 1 week
EVAR
LITTER: CONSTANTS ; Now dump out all literals/constants here
VARCHK ; Now dump out all variables, and find
; how big impure and pure really are.
; Memory management definitions (now that we know how big pgm is!)
LCKPAG==<.+2000-1>/2000
SYSWPG==LCKPAG+1 ; Page # to use for mapping into system (for NQMFWR)
FREEPG==SYSWPG+1
LSWLOC=:LCKPAG*2000 ;loc where switch page starts
LSWREQ=:LSWLOC ;init request flag
LSWDON=:LSWLOC+1 ;init done flag
LOCK1=: LSWLOC+<1*2> ;switch 1 (2 wd block)
LOCK2=: LSWLOC+<2*2> ;switch 2 " " " (Note: LOCK2 is not used at present.)
NLCKSW==2 ; # of lock switches.
LSHTIM=:LOCK2+3
END INIT
Reference in New Issue View Git Blame Copy Permalink