! Mailer Executive
const string (3) version= "6a.2"
! Requires privileges 4,8,9,10,12,18,20,24,25,26 + ACR=9
const integer yes= 1
const integer no= 0
const integer kent= yes
const integer name entry size= 36
const integer ad entry size= 128
const integer default max rnames= 3000
const integer abs max rnames= 10000
const integer max components= 30
const integer last component= 19
const integer max recipients= 512
const integer max messages= 1000
const integer max msg file size= 1024; ! Kb
const integer msg total kb= 2048; ! Kb
const integer message entry size= 176
const integer station entry size= 512
const integer name file header= 160
const integer hash length=1023; !must be 2**n -1
const integer max fsys= 99
const integer max server map top= 63; !max servers for one message
const integer ad file version no= 1
const string (6) mailer= "MAILER"
! mailer flags
const integer bad params= 501
const integer duplicate component= 502
const integer unknown component= 503
const integer invalid command= 504
const integer no valid recipients= 505
!%constinteger too many recipients = 506
const integer addr table full= 507
!%constinteger name table full = 508
const integer illegal name= 509
const integer mail service closed= 510
!%constinteger recipient offline = 511
const integer message too long= 512
const integer error report= 513
const integer missing component= 514
const integer no free message descriptors= 515
!%constinteger invalid component = 516
const integer total message kb exceeded= 517
const integer cannot return report file= 518
!%constinteger message stored = 519
!%constinteger forbidden component = 520
const integer create file fails= 521
const integer user not accredited= 522
!%constinteger invalid password = 523
const integer rname not accredited= 524
const integer rname already accredited= 525
const integer rname belongs to another user= 526
const integer uncollected mail for rname= 527
const integer invalid after specification= 528
const integer not available to students= 529
const integer invalid rname option= 530
const string (15) array err mess(507:509)= c
"Addr table full", "Name table full", "Illegal name"
! mailer activities
const integer oper req= 20
const integer open fsys= 21; !from direct
const integer user mess= 22
const integer spoolr reply= 23
const integer return file ack= 24
const integer file from spoolr= 25
const integer alarm call= 26
const integer close fsys= 27
const integer take dbfile= 28
const integer take config file= 29
! message states
const integer sending= 1; !record of a message file
const integer received= 2; !record for each outstanding recipient or remote server
!%constinteger archived = 4
const integer spooling= 8; !awaiting immediate ack from spoolr
const integer spooled= 16; !awaiting ftp complete from spoolr
const integer waiting= 32; !after dt delivery, no recip descriptors
const integer unused= 0
const integer outbound=received!spooling!spooled
const string (8) addrfile= "ADDRFILE"
const string (8) snamefile= "NAMEFIL"
const string (10) addrbackup= "ADDRBACKUP"
const string (6) dbfile= "DBFILE"
const string (5) newdbfile= "DBOUT"
const string (10) conf backup= "CONFBACKUP"
const string (1) snl= "
"
! message components
const string (13) array uc comp name(1:last component)= c
"", "SUBJECT", "FROM", "DATE", "MESSAGEID",
"TO", "CC", "BCC", "SENDER", "AFTER",
"INREPLYTO", "REPLYTO", "KEYWORDS", "FOLDER", "REFERENCES",
"COMMENTS", "ACKNOWLEDGETO","", "VIA"
const string (16) array lc comp name(1:max components)= "
", "Subject: ", "From: ", "Date: ", "Message-ID: ",
"To: ", "cc: ", "bcc: ", "Sender: ", "After: ",
"In-reply-to: ","Reply-to: ", "Keywords: ", "Folder: ", "References: ",
"Comments: ", "Acknowledge-to: ","Via: ", "Via: ", "Via: ",
"Via: ", "Via: ", "Via: ", "Source-key: ", "",
"", "", "", "", ""
! Order of details in message header
const integer body= 1, subject = 2, from = 3, cdate = 4, messid = 5
const integer to= 6, cc = 7, bcc = 8, sender = 9, after = 10
const integer in reply to= 11, replyto = 12, keywords = 13, folder = 14
const integer references= 15, comments = 16, ack to = 17, via = 18
const integer via2= 19, via3 = 20, via4 = 21, via5 = 22, via6 = 23
const integer source key= 24, user1 = 25, user2 = 26, user3 = 27, user4 = 28,
user5 = 29, user6 = 30
! Order of components in a message
const integer array order(1:max components)= c
source key, via,via2, via3, via4, via5, via6, cdate,from, subject, sender,
to, cc,
bcc,reply to,comments, mess id, in reply to, references, keywords,
folder, ack to, after, user1, user2, user3, user4, user5, user6, body
const integer acomf= x'80000000'+48<<18; !address of communications record
const integer not assigned= x'80808080'; !internal unassigned pattern
const integer max via fields= 5
const integer max user fields= 6
const integer already exists= 16; !director flag
const integer does not exist= 32; !director flag
const integer fsys not available= 23; !director flag
const integer user not known= 37; !director flag
const integer process na= 61; !director flag
const integer file header size= 32; !ss standard file header size
const integer r= b'00000001'; !read permission
const integer w= b'00000010'; !write permission
const integer shared= b'00001000'; !allow others access
const integer zerod= b'00000100'; !zero file on creation
const integer tempfi= b'00000001'; !temp file on creation
const integer cherish= 8; !on creation
const integer noarch= 17; !dfstatus arch inhibit entry
const integer set cherish= 1; !dfstatus entry
const integer get index list= 8; !dperm entry
const integer get sfi surname= 18; !dsfi entry
const integer get last logon= 6; !dsfi entry
const integer get config name= 2; !dsfi entry
const integer msg indicator= 43; !dsfi entry
const integer ss char type= 3; !subsystem char filetype
const integer secsin24hrs= 86400; ! secs in day
const integer days70= 25567; ! days from jan1 1900 to jan1 1970
const long integer secs70=x'0000000083AA7E80'; ! secs ditto
const integer secs in year= x'1E13380'
const integer after limit= secs in year; !use for 'after' messages
const integer default return period= secs in 24hrs*100; !return to sender in 3 months
const integer junk return period= secs in 24hrs*7; !one week for junk mail
const integer max outstanding= 100; !before forcing user to accept
const integer apf= x'19A'; !w at 9, r at 10
const integer open= 1
const integer closed= 0
const integer tell= 1
const integer dont tell= 0
const integer spoolr requeue= 1
const integer spoolr delete= 0
const integer report=yes
const integer no report=no
const integer ok= 0
const integer not found= 0
const integer max reply index= 127; !for activity of reply from spoolr
const integer spool log reply=(max reply index+1)<<8!spoolr reply
const integer elapsed int= x'000A0002'; !elapsed interval timer service
const integer local= 1; !origin of message
const integer remote= 2; !origin of message
const integer sfioption= 1; !set if addr table entry = sfi surname
const integer alias option= 2; !set if entry is an alias for user
const integer dlist option= 3; !set if entry is a distribution list
const integer bboard option= 4; !set if entry is a bulletin board
const integer max dlists= 255
!%constinteger open dlist option = b'00001000'
!%constinteger member dlist option = b'00010000'
const integer any vias= 1<<via!1<<via2!1<<via3!1<<via4!1<<via5!1<<via6
const integer reqd local comp=1<<comments!1<<body
const integer valid local comp=~(1<<c date!1<<source key!1<<mess id!1<<sender c
!any vias)
const integer originator comp= 1<<from!1<<sender!1<<reply to
const integer add viastring= 255; !qualifiers for 'process recipients'
const integer jnt header= 254
const integer ignore route= 253
const integer flag bcc= 252
const integer mailer ack= 1; !types of msg mailer sends
const integer mailer report= 2
const integer mailer returned msg= 3
const integer mailer dead letter= 4
const integer mailer ftp failure= 5
const integer update flag=1; !items in the station_flags field
const integer update copy flag=2
const integer route flag=4
const integer this auth flag=8
const integer this host flag=16
const integer local host flag= 32
const integer mail service offered=2; !in station_services
const string (6) this ukac= "UK.AC."
const string (3) array month(1:12)= c
"Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec"
! monitoring:
! 2**0 = poffs + cpu/pts
! 2**1 = viastrings (for reports)
! 2**2 = calls on 'process recipients'
! 2**3 = log descriptors (in 'check descriptors')
! communications record format - extant from chopsupe 20a onwards
record format comf(byte integer b1, b2, b3, ocp type, integer ipldev, sblks, sepgs, ndiscs, ddtaddr,
gpctabsize, gpca, sfctabsize, sfca, sfck, dirsite, dcodeda, suplvn, wasklokcorrect, date0, date1, date2, time0,
time1, time2, epagesize, users, cattad, dqaddr, byte integer nsacs, resv1, sacport1, sacport0, nocps,
systype, ocpport1, ocpport0, integer itint, contypea, gpcconfa, fpcconfa, sfcconfa, blkaddr, dptaddr, smacs,
trans, long integer kmon, integer ditaddr, smacpos, supvsn, pstva, secsfrmn, secstocd, sync1dest, sync2dest,
asyncdest, maxprocs, inspersec, elaphead, commsreca, storeaad, procaad, sfcctad, drumtad, tslice, sp0, sp1,
sp2, sp3, sp4, sp5, sp6, sp7, sp8, lstl, lstb, pstl, pstb, hkeys, hoot, sim, clkx, clky, clkz, hbit, slaveoff,
inhssr, sdr1, sdr2, sdr3, sdr4, sesr, hoffbit, s2, s3, s4, end)
!systype 0 = p series - #0 = s series
record format finff(integer nkb, rup, eep, apf, use, arch, fsys, conseg, cct, codes, codes2, ssbyte,
string (6) offer)
record format archf(string (11) name, integer kbytes, string (8) date, string (6) tape, integer chapter,
flags)
record format c tab f(integer beg, len)
record format cf(integer dest, srce, string (23) s)
record format pe(integer dest, srce, p1, p2, p3, p4, p5, p6)
record format pf(integer dest, srce, string (7) user, integer p3, p4, p5, p6)
record format fhf(integer end, start, size, type, free hole, datetime, sp0, version, sp1, bitcomp,
record (c tab f) array cp(1:max components))
record format ad file f(integer end, start, size, type, free hole, datetime, entries, version, anon link)
record format msg descriptor f(string (31) rname, string (15) managr, server, string (47) mess id,
integer dt sent, dt told, dt received, dt spooled, dt delivered, dt deleted, dt after, status, ident,
recip link, r type, rname link, sp1, sp2, sp3, sp4)
record format pointers f(integer link list displ, ftp table displ, queues, queue entry size, queue displ,
queue name displ, streams, stream entry size, stream displ, remotes, remote entry size, remote displ,
remote name displ, stations, station entry size, station displ, station name displ, station addresses displ,
guest no, byte integer array discs(0:max fsys), string (63) dead letters, this full host,
integer hash len, integer array hash t(0:hash length))
record format ftp station f((byte integer max lines or c
byte integer max ftp lines), byte integer status, (byte integer service or c
byte integer ftp service), byte integer connect retry ptr, fep, address type, services,
(byte integer q lines or byte integer ftp q lines), (integer limit or c
integer ftp limit), integer last call, last response, system loaded, connect attempts, connect retry time,
integer array ispare(0:4), integer seconds, bytes, integer last q response by us, p transfers, q transfers,
p kb, q kb, p mail, q mail, integer name, shortest name, integer array address(1:4), integer pss entry,
integer mail, integer ftp, integer description, (integer queue or c
integer route), integer flags,
byte integer array string space(0:375) {decrement this if more fields added, keep to 512 total})
record format server map f(integer servno, half integer rtable pointer, byte integer flags, bcc,
string (127) name, string (15) short name)
record format recip table f(string (127) rname, string (15) managr, integer type, entry, fsys, link)
record format addr entry f(string (31) rname, department, string (7) password, string (15) server, managr,
integer timestamp, options, dt last told, fsys, dlist index, link)
record format name entry f(string (31) rname, integer soundex)
record format name file f(integer end, start, size, type, free, datetime, sp0, version,
integer array startchar('A':'['), integer extrastart, extraend, sp1, sp2, sp3)
record format usf(string (6) user, byte integer nkb, integer indno)
record format i prms f(string (6) user, byte integer uprm)
record format permf(integer bytes, ownp, eep, spare, record (i prms f) array i prms(0:15))
record format reqf(integer dest, srce, flag, string (6) user, file, integer p6)
record format repf(integer dest, srce, byte integer flag, string (6) file, string (15) ftp source)
record format dtablef(string (31) dname, integer offset, length)
record format dbf(integer end, start, size, filetype, sp0, dt, format, sp1, string (6) bowner,
integer n boards, n dlists, board offset, sp2, string (255) jobtext,
record (dtablef) array dtab(1:max dlists))
system routine spec move(integer length, from, to)
system routine spec fill(integer length, from, filler)
external string fn spec derrs(integer flag)
external integer fn spec dexecmess(string (6) user, integer sact, len, adr)
external integer fn spec dsfi(string (6) user, integer fsys, type, set, address)
external integer fn spec change context
external integer fn spec dpon2(string (6) user, record (pe) name p, integer msgtype, outno)
external routine spec dpoff(record (pe) name p)
external integer fn spec dchsize(string (6) user, string (11) file, integer fsys, newsize)
external routine spec dprintstring(string (255) s)
external routine spec get av fsys(integer name n, integer array name a)
external integer fn spec get usnames2(record (usf) array name nn, integer name n, integer fsys)
external integer fn spec dfsys(string (6) user, integer name fsys)
external integer fn spec dpermission(string (6) owner, user, string (8) date, string (11) file,
integer fsys, type, adrprm)
external integer fn spec ddestroy(string (6) user, string (11) file, string (8) date, integer fsys, type)
external integer fn spec ddisconnect(string (6) user, string (11) file, integer fsys, destroy)
external integer fn spec drename(string (6) user, string (11) oldname, newname, integer fsys)
external integer fn spec dfstatus(string (6) user, string (11) file, integer fsys, act, value)
external integer fn spec dfilenames(string (6) user, record (archf) array name inf, integer name filenum,
maxrec, nfiles, integer fsys, type)
external integer fn spec dfinfo(string (6) user, string (11) file, integer fsys, address)
external integer fn spec dcreate(string (6) user, string (11) file, integer fsys, nkb, type)
external integer fn spec dconnect(string (6) user, string (11) file, integer fsys, mode, apf,
integer name seg, gap)
external integer fn spec dmessage(string (6) user, integer name l, integer act, fsys, adr)
external integer fn spec dnewgen(string (6) user, string (11) file, newgen of file, integer fsys)
external integer fn spec dsubmit(record (pe) name p, integer len, ad, sact, string (6) user)
external integer fn spec dtransfer(string (6) user1, user2, string (11) file, newname, integer fsys1, fsys2,
type)
external routine spec dump(integer start, finish, conad)
external string fn spec h to s(integer value, places)
external string fn spec i to s(integer value)
external integer fn spec s to i(string name s)
external routine spec log print(string (255) s)
external routine spec pt rec(record (pe) name p)
external routine spec send and define(integer strm, size, string (15) q)
! e x t e r n a l v a r i a b l e s
! - - - - - - - - - - - - - - - - -
extrinsic integer com36; !address of restart registers
!%extrinsicinteger oper no
!current oper output console
extrinsic integer my fsys; !mailer file system
extrinsic integer my service number; !mailer service number
extrinsic string (6) my name; !mailer username
external routine control(integer rtable conad)
integer temp, bitcomp, monitoring, e page size, db conad, last fsys
integer rtable top, mailer state, report conad, after linkhead
integer message count, secs now, report fsys, bad bitcomp
integer name file conad, addr file conad, max rnames
integer report full, top spoolr reply, ad ltou trans, discarded entry
integer server map top, config conad, station offset, stat space offset
string (255) viastring
string (31) current configfile
string (11) user reportfile
string (8) name date, time
string (31) this host, this lc host; !used in originator fields
string (15) this short host; !used in ADDR FILE and MSG_SERVER
string (31) this institution, this lc institution; !the name of the institution directory
string (3) root filename
string (3) time zone
record (ad file f) name ad file
record (comf) name com
record (name entry f) array format name table arf(1:abs max rnames)
record (name entry f) array name n table
record (name file f) name name file
record (recip table f) array format rtable arf(1:max recipients)
integer array name startchar
integer array f systems(0:max fsys)
record (recip table f) array name rtable
record (fhf) name report file header
record (pointers f) name pointers
record (ftp station f) name station
integer array name hasht
record (dbf) name db
integer array spool reply index(0:max reply index)
integer array msg cbeg(1:max components); !for start addrs of components in a msg
integer array msg clen(1:max components); !for component lengths
record (server map f) array server map(0:max server map top)
routine spec switchgear
routine spec initialise
routine spec append to report(integer conad, len)
routine spec compose remote message(integer ident, posn, nkb, bits, integer name flag)
integer fn spec connect config file(string (31) filename)
routine spec connect or create(string (6) user, string (11) file, integer fsys, size, flags,
integer name caddr)
routine spec connect tables
routine spec create maillist(integer fsys)
routine spec detachjob for accept(string (6) user, integer fsys, string (255) text)
routine spec discredit entry(integer entry no)
integer fn spec accredit name(string (31) rname, department, string (15) server, managr, integer options,
fsys, secs)
routine spec dispatch to remote(integer ident, string (127) remote, string (6) user, integer name flag)
routine spec close file system(integer fsys)
routine spec deliver after message
routine spec put component(integer comp no, string name place)
integer fn spec lookup name(string (255) rname)
integer fn spec message addr(integer ident)
string fn spec ident to s(integer ident)
string fn spec compress(string (255) rname)
routine spec update tables
routine spec check descriptors(integer fsys spec)
routine spec unlink msg(record (msg descriptor f) name s msg, integer ident, next recip)
routine spec compose message(integer ident, bits, nkb, integer name flag)
routine spec connect dbfile(integer name flag)
integer fn spec current dt in secs
routine spec staticise message(integer beg, end, origin, integer name flag)
routine spec decode spoolr reply(integer reply, flag)
routine spec delete junk(integer fsys spec)
routine spec distribute mail(record (msg descriptor f) name msg, string (6) user, integer sending ident,
fsys, bitcomp, size, integer name flag)
routine spec delete message(integer ident, integer name flag)
routine spec link recipient(record (msg descriptor f) name sent msg, r msg, integer ident, ad entry, fsys,
tell)
routine spec give messages(string (6) user, integer fsys, anon, integer name linkhead, flag)
routine spec killfsys(integer fsys)
routine spec create and connect(string (11) file, integer fsys, nbytes, createmode, connectmode,
integer name caddr)
routine spec add to report(string (255) s)
string fn spec lcstring(string (255) s)
integer fn spec locate dlist entry(string (255) rname)
integer fn spec lookup host(string (127) name)
routine spec mail queue(record (reqf) name p)
routine spec mailer sends message(integer fsys, conad, len, type, integer name flag)
integer fn spec msg for mailer(string (15) srce, string name msg id)
integer fn spec newgen or rename(string (11) newfile, oldfile, integer name conad)
routine spec movefsys(integer from fsys, to fsys)
integer fn spec next fsys
routine spec open file system(integer fsys)
routine spec place alarm call
string fn spec printable(string (255) s)
routine spec process recipients(integer from, to, type, report)
routine spec process name command(string (255) s, string (6) user, integer name flag)
routine spec process remote file(integer caddr, string name file, string (6) user, integer name flag,
string (127) ftp source)
routine spec process user req(record (pf) name p)
routine spec process oper req(record (cf) name p)
routine spec process mail command(string (255) s, string (6) user, integer name ident, flag)
string fn spec dt
routine spec table sort(integer n)
routine spec relink new rnames
routine spec reset message count
routine spec retell recipients
routine spec return report(string (6) user, string (11) reportfile, integer fsys, integer name flag)
routine spec return old messages(string (31) managr, integer return period)
routine spec return to sender(record (msg descriptor f) name msg, integer name flag, integer ident)
string fn spec check filename(string (31) s)
routine spec link after(record (msg descriptor f) name msg, integer ident)
string fn spec secs to dt(integer secs)
routine spec send acknowledgement(record (msg descriptor f) name r msg)
string fn spec short form(string (15) server)
integer fn spec soundex(string (31) name)
string fn spec statstring(integer ad)
integer fn spec s to ident(string (255) s)
integer fn spec get next descriptor(integer fsys)
integer fn spec student user(string (6) user)
routine spec take component(integer component, string name s)
routine spec tidy archive(integer fsys spec)
string fn spec toupper(string (255) s)
routine spec update remote servers(string (15) action, integer loopstart, loopend)
!initial entry here
*stln_temp; !to allow ndiags to exit from control
com36 = temp
temp = change context
print string("Mailer ".version." Started".snl)
!tell operator console we have started
initialise; !set up tables and lists
cycle
switch gear; !if we exit go round again
send and define(1, 64, "LP"); !must have entered diags, print log
repeat
routine switch gear
! Accepts incoming messages to MAILER and switches to the
! appropriate routine. If any errors occur in a subsequently called
! routine the stack is collapsed to the level of this routine and a
! return is made from this routine.
integer temp, dact, pt, ms, pt1, ms1
switch sw(0:31); ! 1 for each activity
record (pe) p
*stln_temp; !store lnb for ndiags to exit
com36 = temp
dact = 0; !hold last activity
pt1 = 0
ms1 = 0
! main loop of the mailer executive
wait:
!sit here waiting for something to do
if monitoring=yes start ; !is poff to be monitored
selectoutput(1); !select log stream
temp = dsfi(myname, myfsys, 24, 0, addr(pt))
temp = dsfi(myname, myfsys, 28, 0, addr(ms))
printstring(dt."Sleeping, last activity cost: ".itos(pt-pt1)."pt, ".itos(ms-ms1)."ms".snl)
pt1 = pt; ms1 = ms
dpoff(p); !suspend if no params
print string(dt."POFF ")
pt rec(p)
selectoutput(0); !back to oper
finish else dpoff(p)
if dact#p_dest&31 start ; !same as previous activity?
dact = p_dest&31
temp = change context
finish
->sw(dact); !go do some thing
sw(oper req):
process oper req(p)
->wait
sw(open fsys):
unless 0<=p_p1<=max fsys then printstring("Bad fsys no".snl) and ->wait
open file system(p_p1)
check descriptors(p_p1) unless mailer state=closed
->wait
sw(user mess):
process user req(p)
->wait
sw(spoolr reply):
log print(dt."FTRANS REPLY - Sident = ".ident to s(p_p2).", flag = ".itos(p_p1).snl)
decode spoolr reply((p_dest>>8)&x'FF', p_p1)
->wait
sw(return file ack): !spoolr ack
sw(file from spoolr): !input file
mail queue(p)
->wait
sw(alarm call):
deliver after message
->wait
sw(close fsys):
close file system(p_p1)
->wait
sw(take dbfile): !new dlist/bboard file
connect dbfile(p_p1)
p_dest = p_srce
p_srce = my service number!take db file
temp = dpon2("", p, 0, 6)
->wait
sw(take config file):
temp = connect config file("")
->wait
sw(*):
print string("BAD DACT "); pt rec(p)
->wait
! end of mailer executive main loop
end ; !of routine switch gear
string (23) fn dt
! Returns the date and time in a fixed format
result = "DT: ".date." ".time." "
end ; !of stringfn dt
integer fn kday(integer d, m, y)
! returns days since 1900 given day month &year(<=99)
if m>2 then m = m-3 else m = m+9 and y = y-1
result = 1461*y//4+(153*m+2)//5+d+58
end
routine kdate(integer name d, m, y, integer k)
! k is days since 1st jan 1900
! returns d, m, y 2 digit y only
! %integer W
! K=K+693902
! DAYS SINCE CEASARS BDAY
! W=4*K-1
! Y=W//146097
! K=W-146097*Y
! D=K//4
! K=(4*D+3)//1461
! D=4*D+3-1461*K
! D=(D+4)//4
! M=(5*D-3)//153
! D=5*D-3-153*M
! D=(D+5)//5
! Y=K
*lss_k; *iad_693902
*imy_4; *isb_1; *imdv_146097
*lss_ tos ; *idv_4; *imy_4; *iad_3
*imdv_1461; *st_(y)
*lss_ tos ; *iad_4; *idv_4
*imy_5; *isb_3; *imdv_153
*st_(m); *lss_ tos
*iad_5; *idv_5; *st_(d)
if m<10 then m = m+3 else m = m-9 and y = y+1
end ; ! of kdate
integer fn current dt in secs
! gives current dt in new packed form
const long integer mill=1000000
*rrtc_0; *ush_-1
*shs_1; *ush_1
*imdv_mill
*isb_secs70; *stuh_ b
!*OR_X'80000000'
*exit_-64
end
routine decwrite2(integer value, ad)
! writes value as two decimal iso digits into ad and ad+1
*lss_value; *imdv_10
*ush_8; *iad_ tos ; *iad_x'3030'
*lda_ad; *ldtb_x'58000002'
*st_(dr )
end ; ! of decwrite2
integer fn i2(integer ad)
! ad points to the first of a pair of decimal characters. the result
! is the numeric value of the chas
result = 10*(byteinteger(ad)&x'F')+(byteinteger(ad+1)&x'F')
end ; !of i2
string (19) fn secs to dt(integer p)
! Converts secs to a date/time string.
integer h, m, at, d, mo, y, ad, secs
string (9) dat
string (8) tim
at = addr(tim)
tim = "00:00:00"
*lss_p; *ush_1; *ush_-1
*imdv_60; *imdv_60; *imdv_24
*lss_ tos ; *st_h
*lss_ tos ; *st_m
*lss_ tos ; *st_secs
decwrite2(h, at+1)
decwrite2(m, at+4)
decwrite2(secs, at+7)
ad = addr(dat)
dat = "00 XXX 00"
p = (p&x'7FFFFFFF')//secs in 24 hrs
kdate(d, mo, y, p+days70)
string(ad+2) = " ".month(mo)
decwrite2(d, ad+1)
decwrite2(y, ad+8)
result = dat." ".tim." ".time zone
end ; !of secs to dt
integer fn check and convert dt(string (255) s)
! Checks that a string contains a date and time and converts to secs.
string (255) t
integer i, ad, j
s = s.t while s->s.(" ").t
s = toupper(s)
if s->s.("GMT") or s->s.("BST") start
finish
unless length(s)=15 then result = -1
move(3, addr(s)+3, addr(t)+1)
length(t) = 3
t = compress(t)
cycle i = 12, -1, 1
if t=compress(month(i)) start
ad = addr(s)
j = kday(i2(ad+1), i, i2(ad+6))-days70
j = j*secsin 24 hrs; !X'80000000'
result = j+3600*i2(ad+8)+60*i2(ad+11)+i2(ad+14)
finish
repeat
result = -1
end ; !of check and convert dt
integer fn get fourth sunday(integer month, year)
integer day, weekday
day = kday(1, month, year)-days70
weekday = (day-3)-((day-3)//7)*7
if weekday=0 then day = day+21 else day = day+28-weekday
result = day*secs in 24 hrs
end ; !of get fourth sunday
string fn check filename(string (255) s)
integer i, j
if length(s)>11 or s="" then result = ""
cycle i = length(s), -1, 1
j = charno(s, i)
unless 'A'<=j<='Z' or (i#1 and ('0'<=j<='9' or j='#')) then result = ""
repeat
result = s
end ; !of check filename
routine process user req(record (pf) name p)
! This routine receives messages from users via DMAIL, either
! requesting MAILSERVER or NAMESERVER operations
record (pe) name pp
string (255) s, t
string (7) user
integer len, flag, ident, f
p_user = "VOLUMS" if p_user="DIRECT"
ident = 0
report conad = 0
bad bitcomp = 0
message count = 0
secs now = current dt in secs
top: len = 255; !max size of message prepared to accept
flag = dmessage("", len, 0, my fsys, addr(s)+1)
!give me next message
if flag=0 start
if len>0 start ; !check there was a message
length(s) = len; !set length of string
if s->t.("**").user.(" ").s and s->t.(": ").s start
!remove info not required
length(s) = length(s)-1 while length(s)>0 and charno(s, length(s))=nl
!strip newlines
length(user) = 6; !remove bell char from username
log print(dt."FROM ".user." ".s.snl)
user = "VOLUMS" if user="DIRECT"
if user#p_user start
log print(dt." ABOVE MESSAGE DISCARDED POFFED MESSAGE FROM ".p_user.snl)
->top
finish
if s->("MAILSERVER ").s then process mail command(s, user, ident, flag) else start
if s->("NAMESERVER ").s then process name command(s, user, flag) else flag = bad params
finish
finish else flag = bad params; !start of message invalid
finish else flag = bad params; !length invalid
finish ; !bad flag from director
if flag#0 start
log print(dt."USER MESSAGE REPLY TO ".p_user." FLAG ".i to s(flag).snl)
finish
if report conad#0 start
if report conad<0 then flag = cannot return report file else start
return report(user, userreportfile, report fsys, f)
if f=0 then flag = error report else flag = f
finish
finish
pp == p
pp_dest = pp_srce
pp_srce = my service number!user mess
pp_p1 = flag
pp_p2 = message count
pp_p3 = secs now
pp_p4 = ident
pp_p5 = bad bitcomp
flag = dpon2("", pp, 0, 6); !reply to user message received
end ; !of process user req
routine process mail command(string (255) s, string (6) user, integer name ident, flag)
! Acts on one of the following user requests:
! ACCEPT <root filename>,<recip names>
! POST <msg file>,<offset>,<length>,<error filename>
! REVOKE <mess id>
! ENQUIRE <mess id>,<report filename>
integer i, seg, gap, fsys, f, entry, offset, len, j, dt after
record (finff) finf
string (31) sfi surname, date time now
string (63) sender name, fromname
string (255) param1, param2, param3, param4
record (addr entry f) name addr entry
record (msg descriptor f) name msg
const integer max mail commands= 4
switch comm(1:max mail commands)
const string (7) array mail command(1:max mail commands)= c
"ACCEPT", "POST", "REVOKE", "ENQUIRE"
if mailer state=closed then flag = mail service closed and return
fsys = -1
flag = dfsys(user, fsys)
report fsys = fsys
if flag=0 start
if s->s.(" ").param1 start
unless param1->param1.(",").param2 then param2 = ""
unless param2->param2.(",").param3 then param3 = ""
unless param3->param3.(",").param4 then param4 = ""
cycle i = max mail commands, -1, 1
if s=mail command(i) then ->comm(i)
repeat
finish else param1 = ""
flag = invalid command
finish
return
comm(1): !user wants his mail
rootfilename <- param1
if length(rootfilename)>2 then flag = invalid command and return
until param2="" cycle
if flag#0 then exit
unless param2->param4.("+").param2 then param4 = param2 and param2 = ""
entry = lookup name(param4)
if entry#0 start
addr entry == record(addr file conad+entry*ad entry size)
if addr entry_managr=user and addr entry_server=this short host start
give messages(user, fsys, no, addr entry_link, flag)
continue
finish
finish
flag = dsfi(user, fsys, getsfisurname, 0, addr(sfisurname))
if compress(param4)#compress(sfisurname) start
if entry=0 then flag = rname not accredited else flag = rname belongs to another user
finish else give messages(user, fsys, yes, ad file_anon link, flag)
repeat
if message count>0 start
i = dsfi(user, fsys, msg indicator, 0, addr(j))
if i=0 start
j = j-message count
if j<0 then j = 0
i = dsfi(user, fsys, msg indicator, 1, addr(j))
finish
finish
return
comm(2): !user posting mail
offset = s to i(param2)
len = s to i(param3)
user reportfile = checkfilename(param4)
flag = dfinfo(user, param1, fsys, addr(finf))
if flag#0 then return
if user reportfile="" or offset<0 or len<=0 or offset+len>finf_nkb<<10 then c
flag = invalid command and return
if finf_nkb>max msg file size then flag = message too long and return
seg = 0; gap = 0
flag = dconnect(user, param1, fsys, r, 0, seg, gap)
if flag=0 start
staticise message(seg<<18+offset, seg<<18+offset+len-1, local, flag)
if flag=0 and bitcomp&reqd local comp=0 start
bad bitcomp = 1<<body
flag = missing component
finish
bitcomp = bitcomp&valid local comp
cycle i = reply to, 5, ack to
if bitcomp&(1<<i)#0 start ; !check syntax
server map top = 0
process recipients(msg cbeg(i), msg clen(i), i, report)
if report conad#0 or server map top=0 start
if i=reply to then bitcomp = bitcomp&(~(1<<reply to)) and report conad = 0 else c
flag = error report and add to report(" invalid Acknowledge-to address")
finish
finish
repeat
if flag=0 start
flag = dsfi(user, fsys, getsfisurname, 0, addr(sfisurname))
fromname = sfisurname
entry = lookup name(sfisurname)
addr entry == record(addr file conad+entry*ad entry size)
if entry#0 and (addr entry_managr#user or addr entry_server#this short host) then entry = 0
if bitcomp&(1<<from)=0 start ; !add "from" component
if entry#0 then sender name = sfisurname." @ ".this lc institution else c
sender name = sfisurname." <".user."@".this lc host.">"
put component(from, sender name)
else ; !check "from" component
take component(from, param3)
if param3->param3.(",").param4 start
finish
if param3->param3.("<").param4 start
finish
param3 = printable(param3)
if param3#"" then fromname = param3
server map top = 0
process recipients(msg cbeg(from), msg clen(from), from, report)
if report conad#0 or server map top=0 start
if bitcomp&(1<<reply to)=0 then i = 1<<reply to else i = 1<<sender
report conad = 0
else
if rtable top>1 or rtable(server map(1)_rtable pointer)_managr#user or c
server map(1)_name#this host then i = 1<<sender else i = 0
finish
if i#0 start
if entry=0 then sender name = sfisurname." <".user."@".this lc host.">" else c
sender name = sfisurname." @ ".this lc institution
put component(sender, sendername)
if i&(1<<reply to)#0 then put component(reply to, sendername)
finish
finish
finish
if flag=0 start
server map top = 0
cycle i = to, 1, bcc
process recipients(msg cbeg(i), msg clen(i), i, report) unless bitcomp&(1<<i)=0
repeat
if server map top=0 then flag = no valid recipients else start
if rtable top*finf_nkb>msg total kb start
if report conad>0 then add to report("Total message size exceeded") else c
flag = total message kb exceeded
finish
finish
if flag=0 start
dt after = 0
take component(after, param2)
if param2#"" start
dt after = check and convert dt(param2)
unless 0<dt after<secs now+after limit then flag = invalid after specification
finish
finish
if flag=0 and report conad#0 then flag = error report
if flag=0 start
if flag=0 start
ident = get next descriptor(fsys)
if ident#0 start
msg == record(message addr(ident))
msg = 0
msg_rname <- fromname
msg_managr = user
msg_server = this short host
date time now = secs to dt(secs now)
msg_mess id = "<".date time now." ".ident to s(ident)."@".this short host.">"
put component(mess id, msg_mess id)
msg_dt sent = secs now
msg_dt received = secs now
put component(c date, date time now)
if dt after<=secs now start
msg_status = sending
log print(dt."Message ".msg_mess id." sent by ".msg_managr.snl)
distribute mail(msg, user, ident, fsys, bitcomp, finf_nkb, flag)
if msg_recip link=0 then msg_status = unused
else ; !after specified
log print(dt."Message ".msg_mess id." sent by ".msg_managr." deliver: ".param2.snl)
msg_dt after = dt after
compose remote message(ident, -1, finf_nkb, bitcomp, flag)
if flag=0 start
msg_status = waiting
link after(msg, ident)
if after linkhead=ident then place alarm call
finish
finish
finish else flag = no free message descriptors
finish
finish
finish
f = ddisconnect(user, param1, fsys, 0)
if f#0 start
log print(dt."Disconnect ".user.".".param1." fails ".derrs(flag).snl)
finish
finish else log print(dt."Connect ".user.".".param1." fails ".derrs(flag).snl)
if message count>0 then dprintstring("USER: ".user." MSGKB: ".i to s((len+1023)>>10)." MSGRECIPS: ".itos c
(message count).snl)
return
comm(3): !revoke mail
comm(4): !inquire
end ; !of process mail command
routine staticise message(integer beg, end, origin, integer name flag)
! Analyses a sequence of bytes, resolving into a series of components.
! Each component has its address and length recorded.
! Variable BITCOMP indicates the components found.
integer pt, char, j, com, n vias, n user fields
string (63) c
msg cbeg(body) = beg; !in case no components
msg clen(body) = end-beg+1
bitcomp = 0
n vias = 0
n user fields = 0
pt = beg; c = ""
while pt<end cycle
char = byteinteger(pt)
if char#':' start
if char=nl and c#"" start ; !no ':' found before the nl
if bitcomp#0 start ; !some fields already found
msg cbeg(body) = beg
msg clen(body) = end-beg+1
finish
bitcomp = bitcomp!(1<<body)
return
finish
if 32<char<127 and length(c)<63 then c = c.tostring(char)
else
c = compress(c); j = 0
cycle com = 2, 1, last component
if c=uc comp name(com) then j = 1<<com and exit
repeat
if j=0 or j&bitcomp#0 start
if origin=local start
if j=0 then flag = unknown component else flag = duplicate component and bad bitcomp = 1<<j
return
finish
if j=1<<via2 and n vias<max via fields start
n vias = n vias+1
com = via2+nvias
else
if n user fields<max user fields start
com = user1+n user fields
n user fields = n user fields+1
pt = beg-1; !include field name
else
bitcomp = bitcomp!(1<<body)
msg cbeg(body) = beg
msg clen(body) = end-beg+1
return
finish
finish
j = 1<<com
finish
if byteinteger(pt+1)=' ' then beg = pt+2 else beg = pt+1
pt = pt+1 until pt>=end or (byteinteger(pt)=nl and pt<end and byteinteger(pt+1)#' ')
msg cbeg(com) = beg
if byteinteger(pt)=nl start
msg clen(com) = pt-beg
if pt+1<end and byteinteger(pt+1)=nl start
msg cbeg(body) = pt+2
msg clen(body) = end-pt-1
bitcomp = bitcomp!(1<<body)
pt = end
finish
finish else msg clen(com) = pt-beg+1
if msg clen(com)>0 then bitcomp = bitcomp!j
beg = pt+1
c = ""
finish
pt = pt+1
repeat
end ; !of staticise message
routine put component(integer comp no, string name place)
! Note the addition of a component to a message
msg cbeg(comp no) = addr(place)+1
msg clen(comp no) = length(place)
bitcomp = bitcomp!1<<comp no
end ; !of put component
integer fn student user(string (6) user)
if kent=no start
if charno(user, 4)='U' then result = not available to students
else
if charno(user, 3)='U' or charno(user, 3)='T' or charno(user, 3)='L' then c
result = not available to students
finish
result = 0
end ; !of student user
routine process recipients(integer beg, len, type, report)
! Resolves a list of recipient names and checks the validity of each name.
! Links together recipients with the same server.
! Expands distribution list rnames and adds each dlist name to a dummy
! server for loop elimination.
record (addr entry f) name addr entry
string (255) rname, lcrname, server
string (15) managr
integer pt, error, comments, tokenstate
integer i, entry, end, fsys, dentry, option, flag, serv flag, save report
integer serv no, posn, host count
string (127) s1, s2
string (202) str
string (31) sfisurname
const byte integer percent marker= 255
const integer none allocated= -1
const integer dlist map posn= 0; !in server map
const integer duplicate=1
const integer not duplicate=0
const integer domain literal ref=0
routine spec make report(string (255) lcrname, s)
integer fn next token
integer cl, act
switch sw(0:12)
const byte integer array next state(0:10, 0:4)= c
0, 2, 0, 1, 0, 0, 3, 0, 3, 4, 0,
1, 1, 1, 0, 1, 1, 1, 0, 1, 1, 1,
2, 2, 2, 2, 2, 2, 2, 0, 2, 2, 2,
0, 0, 0, 0, 0, 0, 3, 0, 3, 0, 0,
4, 4, 4, 4, 4, 4, 4, 0, 4, 0, 0
! special ( ) " comma sp rest end ¬ [ ]
const byte integer array next action(0:10, 0:4)= c
3, 4, 8, 1, 6, 0, 1, 6, 10, 1, 8,
1, 1, 1, 7, 1, 1, 1, 9, 10, 1, 1,
0, 4, 5, 0, 0, 0, 0, 8, 11, 0, 0,
2, 2, 8, 2, 2, 2, 1, 2, 10, 2, 8,
1, 1, 1, 1, 1, 1, 1, 8, 10, 8, 12
! States:
! 0 - scanning for char
! 1 - building quoted string
! 2 - building comment
! 3 - building string
! 4 - building domain literal
const byte integer array adjust(0:7)= 2,255,2,255,255,1,3,4
const byte integer array class(32:126)= c
5,6,3,6(2),0,6(2),1,2,6(2),4,6(13),0,4,0,6,0,6,0,6(26),9,8,10,6(33)
str = ""
cycle
pt = pt+1
if pt>end then cl = 7 else start
if 32<=byteinteger(pt)<=126 then cl = class(byteinteger(pt)) else cl = 5
finish
act = next action(cl, tokenstate)
tokenstate = nextstate(cl, tokenstate)
->sw(act)
sw(0): !do nothing
continue
sw(1): !add to string
str <- str.tostring(byteinteger(pt))
continue
sw(2): !return string
pt = pt-1; !rescan char
if length(str)=2 and to upper(str)="AT" then result = 2
result = 0; !string result
sw(3): !return special
result = adjust((byteinteger(pt)>>1)&7)
sw(4): !inc comments
comments = comments+1
continue
sw(5): !dec comments
if comments=0 then error = 1 else comments = comments-1
if comments=0 then tokenstate = 0
continue
sw(6): !end
result = 5
sw(7): !add to and return
str <- str.""""
result = 0
sw(8): !badly nested brackets
sw(9): !incomplete quoted string
error = act-7
continue
sw(10): !add quoted char to string
if pt=end then continue
str <- str."¬".tostring(byteinteger(pt+1))
sw(11): !skip quoted char
pt = pt+1
continue
sw(12): !add ']' to, and return
str <- str."]"
result = 6; !domain literal
repeat
end ; !of next token
routine get next rname
integer relays, state, token, act, beg
switch sw(0:5)
const byte integer array pstate(0:6, 0:8)= c
1, 99, 99, 6, 99, 0, 99,
1, 2, 4, 6, 99, 0, 99,
8, 99, 99, 6, 99, 0, 99,
3, 99, 4, 99, 99, 0, 3,
3, 99, 99, 99, 99, 99, 3,
5, 99, 6, 99, 7, 99, 5,
5, 99, 99, 99, 99, 99, 5,
99, 99, 99, 99, 99, 0, 99,
8, 99, 4, 6, 99, 0, 99
! string : @ < > end dom-lit
const byte integer array action(0:6, 0:8)= c
1, 5, 5, 3, 5, 4, 5,
1, 3, 2, 3, 5, 4, 5,
1, 5, 5, 3, 5, 4, 5,
1, 5, 2, 5, 5, 4, 1,
1, 5, 5, 5, 5, 5, 1,
1, 5, 2, 5, 0, 5, 1,
1, 5, 5, 5, 5, 5, 1,
5, 5, 5, 5, 5, 4, 5,
1, 5, 2, 3, 5, 4, 5
! States:
! 0 - starting
! 1 - scanning after string
! 2 - reading group (label:)
! 3 - reading address
! 4 - string must follow (@ received)
! 5 - reading address (<> type)
! 6 - string must follow (<> type)
! 7 - reading for end (after <>)
! 8 - reading after label
beg = pt+1
state = 0; error = 0
rname = ""; relays = 0
tokenstate = 0; comments = 0
cycle
token = next token
act = action(token, state)
state = pstate(token, state)
->sw(act)
sw(0): !do nothing
continue
sw(1): !add to string
if length(rname)+length(str)>200 then ->sw(5)
if rname#"" and relays=0 then rname = rname." ".str else rname = rname.str
continue
sw(2): !note '@'
if relays=0 and rname->rname.(" ").str then rname = """".rname." ".str.""""
rname = rname."%"
relays = 1
continue
sw(3): !begin again after label
rname = ""
continue
sw(4): !end of address
if error=0 then exit
sw(5): !error found
token = next token while token#5; !get end
rname = ""
cycle beg = beg, 1, pt
if byteinteger(beg)=nl then continue
rname = rname.tostring(byteinteger(beg))
if length(rname)=65 then rname = rname." etc." and exit
repeat
make report("", "'".rname."' invalid address format") if report=yes
error = 1
exit
repeat
end ; !of get next rname
string fn rightmost host
integer fin, i
host count = host count+1; !postion within address
fin = addr(rname)+length(rname)
for i = fin, -1, addr(rname)+1 cycle
if byteinteger(i)#'%' then continue
byteinteger(i) = fin-i
length(rname) = length(rname)-(fin-i)-1
result = string(i)
repeat
result = ""
end ; !of rightmost host
routine make report(string (255) lcrname, s)
if report conad=0 and type=jnt header then add to report("Cannot deliver to -".snl)
if lcrname#"" start ; !change last '%'
rname = lcrname
server = rightmost host
if server#"" then lcrname = rname." @ ".server
lcrname = "'".lcrname."'"." "
finish
add to report(" ".lcrname.s)
end ; !of make report
string fn type to s(integer type)
const string (12) array process type(flag bcc:add viastring)= c
"flag bcc: ", "originator: ", "jnt header: ", "add vias: "
if 0<type<max components then result = lc comp name(type)
if flag bcc<=type<=add viastring then result = process type(type)
result = ": "
end ; !of type to s
integer fn lookup locally
integer order, f
switch sw(0:2)
if serv flag&this host flag#0 then order = 2 else order = 1
cycle
->sw(order)
sw(*): !lookup directory
entry = lookup name(rname)
if entry>0 start
addr entry == record(addr file conad+entry*ad entry size)
managr = addr entry_managr
server = addr entry_server
rname = addr entry_rname
fsys = addr entry_fsys
option = addr entry_options
result = lookup host(server)
finish
if order#1 then exit
sw(2): !lookup name-number tables
rname = compress(rname); !possible change to check dsfi for perm to receive mail, rather than . .
if length(rname)=6 and mailer#rname#"VOLUMS" and "SPOOLR"#rname#"JOBBER" and c
"VIEWER"#rname#"LIBRAR" and rname#"DIRECT" then f = dfsys(rname, fsys) else f = user not accredited
if f=0 then f = dsfi(rname, -1, getsfisurname, 0, addr(sfisurname))
if f=0 start
server = this host
entry = lookup name(sfisurname)
if entry#0 start
addr entry == record(addr file conad+entry*ad entry size)
if rname=addr entry_managr and addr entry_server=this short host start
rname = sfisurname
managr = addr entry_managr
server = this host
fsys = addr entry_fsys
finish else entry = 0
finish
result = lookup host(server)
finish
if order=1 then exit ; !we have tried both dir and nnt
order = 0; !go back and try directory
repeat
make report(lcrname, "recipient name not known") if report=yes
server = ""
result = -1
end ; !of lookup locally
integer fn check for duplicate(integer pos)
string (127) crname
integer link
posn = pos; !remember where
crname = compress(rname)
link = server map(pos)_rtable pointer
while link#0 cycle
if managr=rtable(link)_managr and crname=compress(rtable(link)_rname) start
if type=flag bcc then rtable(link)_type = bcc
result = duplicate
finish
link = rtable(link)_link
repeat
result = not duplicate
end ; !of check duplicate
if server map top=0 start ; !initialise
rtable top = 0
server map(dlist map posn)_rtable pointer = 0
finish
end = beg+len-1
pt = beg-1
while pt<end cycle ; !main loop of the routine
get next rname
if error#0 or rname="" then continue
if rtable top=max recipients start
add to report("Too many recipients - message not delivered") if report=yes
return
finish
if type=add viastring start
if length(rname)+length(viastring)<=255 then rname = rname.viastring
finish
serv flag = 0; !extract from station entry
host count = 0; !1 = rightmost hostname in address
entry = 0; !set if dir entry found
option = 0; !type of dir entry
fsys = -1; !fsys of user
managr = ""; !set to userno if dir entry
lcrname = rname; !save a lc copy
{common host deletion possible here}
if monitoring&4#0 then logprint(dt." *".type to s(type)." ".rname)
cycle
server = rightmost host
if server="" start ; !local part reached
serv no = lookup locally; !translate directory entry or check userno
if servno<=0 then exit ; !a bad directory entry!
else ; !non-empty rightmost host
serv no = lookup host(server); !if valid, is it me?
if serv no>0 and station_flags&(this host flag!this auth flag)#0 start
serv flag = station_flags; !remember this for use in 'lookup locally'
continue ; !go lookup next part
finish
finish
if servno>0 start
if station_flags&route flag#0 and type#ignore route start
if statstring(station_route)->s1.("*").s2 start
unless server->str.(".").server then exit
server = s1.server.s2
finish else server = statstring(station_route)
rname = rname."%".server
continue ; !repeat the process
finish ; !not a route, so we are finished
else ; !server not recognised
if host count=1 and type=jnt header start
!not so strict here
if servno=domain literal ref then continue
!discard it, it means us
{ host not known but may mean here! - try the next part on spec }
str = rname.tostring(percent marker).server
!save it
server = rightmost host; !after the one which brought us here
save report = report; report = no
if server="" then flag = lookup locally else flag = lookup host(server)
report = save report
str -> rname.(tostring(percent marker)).server
!put it back
if flag#-1 then continue ; !it worked, so now do it properly
finish
finish
exit
repeat
if monitoring&4#0 then logprint(" -> ".rname." + ".server." (".itos(servno).")".snl)
if servno<0 start ; !invalid host
if length(server)=0 then continue ; !have already reported
length(server) = 100 if length(server)>100
make report(lcrname, "host name not known") if report=yes
continue ; !to next address
finish
unless length(rname)<=127 start
length(rname) = 200 if length(rname)>200
make report(lcrname, "recipient name too long") if report=yes
continue
finish
if servno=domain literal ref start
if length(server)>127 then make report(lcrname, "host name too long") and continue
else
if station_services&mail service offered=0 start
make report(lcrname, "host does not offer a mail service") if report=yes
continue
finish
finish
! chain together rnames for the same server - also chain all dlists to check for loops
posn = none allocated
if server map top=0 start
if option=dlist option then posn = dlist map posn
!chain dlists from 0
else
if option=dlist option then flag = check for duplicate(dlist map posn) else start
flag = not duplicate
if servno#domain literal ref start ; !dont chain these together
for i = 1, 1, server map top cycle
if servno=server map(i)_servno then flag = check for duplicate(i) and exit
repeat
finish
finish
if flag=duplicate then continue ; !omit it
finish
if type=flag bcc then continue ; !dont add to table
rtable top = rtable top+1
rtable(rtable top)_entry = entry
rtable(rtable top)_rname = rname
rtable(rtable top)_managr = managr
rtable(rtable top)_fsys = fsys
if option=bboard option then rtable(rtable top)_type = bboard option else rtable(rtable top)_type = type
if posn=none allocated start ; !first use of this host
if server map top=max server map top start
add to report("Too many hosts addressed - message not delivered") if report=yes
rtable top = max recipients
return
finish
server map top = server map top+1; !get next slot
posn = server map top
server map(posn)_servno = servno
server map(posn)_bcc = 0
if servno=domain literal ref start
server map(posn)_name = server
server map(posn)_short name = ""
server map(posn)_flags = 0
else
server map(posn)_name = statstring(station_name)
server map(posn)_short name <- statstring(station_shortest name)
server map(posn)_flags = station_flags
finish
rtable(rtable top)_link = 0
finish else rtable(rtable top)_link = server map(posn)_rtable pointer
server map(posn)_rtable pointer = rtable top
if option=dlist option start
dentry = locate dlist entry(rname)
if dentry#0 start
process recipients(db_dtab(dentry)_offset+db conad, db_dtab(dentry)_length, type, no report)
finish else printstring("Missing dlist: ".rname.snl)
finish
if type=bcc then server map(posn)_bcc = yes
repeat
end ; !of process recipients
integer fn locate dlist entry(string (255) rname)
integer i
if dbconad=0 or db_n dlists=0 then result = 0
rname = compress(rname)
cycle i = 1, 1, db_n dlists
if rname=db_dtab(i)_dname then result = i
repeat
result = 0
end ; !of locate dlist entry
string fn printable(string (255) s)
string (255) t
integer i
if s="" then result = ""
t = ""
cycle i = 1, 1, length(s)
if 33<=charno(s, i)<=126 then t = t.tostring(charno(s, i))
repeat
result = t
end ; !of printable
routine distribute mail(record (msg descriptor f) name msg, string (6) user, integer sending ident, fsys,
bitcomp, size, integer name flag)
! Gets a descriptor for each local recipient of a message and for each
! remote server, and links the descriptors by message and by recipient.
record (msg descriptor f) name r msg
integer ident, next, bits, fl, m count, file exists, posn
string (127) remote
string (15) short remote
flag = 0; file exists = 0
for posn = 1, 1, server map top cycle
next = server map(posn)_rtable pointer
while next#0 cycle
ident = get next descriptor(fsys)
if ident=0 then flag = no free message descriptors and return
r msg == record(message addr(ident))
r msg = 0
r msg_mess id = msg_mess id
r msg_dt sent = msg_dt sent
r msg_dt received = msg_dt received
r msg_ident = sending ident
if server map(posn)_flags&this host flag#0 start
if file exists=0 start
compose message(sending ident, bitcomp&(~(1<<bcc)), size, flag)
if flag#0 then return
file exists = 1
finish
if rtable(next)_managr="" start ; !not in directory
r msg_rname = ""
r msg_managr <- rtable(next)_rname
else
r msg_rname <- rtable(next)_rname
r msg_managr <- rtable(next)_managr
finish
r msg_server = this short host
r msg_status = received
r msg_r type = rtable(next)_type
fl = dsfi(r msg_managr, rtable(next)_fsys, msg indicator, 0, addr(m count))
if fl=0 then m count = m count+1 and c
fl = dsfi(r msg_managr, rtable(next)_fsys, msg indicator, 1, addr(m count))
if fl#0 start
log print(dt."DSFI43 fails ".derrs(fl).snl)
finish
link recipient(msg, r msg, ident, rtable(next)_entry, rtable(next)_fsys, tell)
log print(dt."Message ".msg_mess id." received for ".r msg_managr." at ".ident to s(ident).snl)
if rtable(next)_type=bboard option then c
detach job for accept(r msg_managr, rtable(next)_fsys, r msg_rname)
else ; !send to remote server
remote = server map(posn)_name
short remote = server map(posn)_short name
if short remote="" then short remote <- remote
r msg_rname <- myname."@".short remote
r msg_managr = myname
r msg_server <- short remote
bits = bitcomp&(~((1-server map(posn)_bcc)<<bcc))
compose remote message(ident, posn, size, bits, flag)
if flag=0 start
dispatch to remote(ident, remote, user, flag)
if flag=0 start
r msg_recip link = msg_recip link
msg_recip link = ident
if file exists=0 start
compose message(sending ident, bits, size, flag)
if flag#0 then return
file exists = 1
finish
finish else delete message(ident, bits)
finish
if flag=0 start
log print(dt."Message ".msg_mess id." spooling to ".short remote." at ".ident to s(ident).snl)
r msg_status = spooling
message count = message count+1
else
log print(dt."Message ".msg_mess id." failure to spool to ".short remote.snl)
flag = create file fails
add to report("Failed to transmit to ".remote)
finish
exit
finish
next = rtable(next)_link
repeat
repeat
end ; !of distribute mail
routine link recipient(record (msg descriptor f) name sent msg, r msg, integer ident, ad entry, fsys, tell)
! Links a received message descriptor to others for the same recipient,
! and to others for the same message.
record (addr entry f) name addr entry
string (63) s, t
integer flag, l, link
s = ""
if ad entry#0 start
addr entry == record(addr file conad+ad entry*ad entry size)
if addr entry_options#sfioption start ; !to an alias
if addr entry_link=0 and addr entry_options=alias option then s = "for ".addr entry_rname else c
tell = no
finish else s = "from ".sent msg_rname
link = addr entry_link
r msg_rname link = link
addr entry_link = ident
else
link = ad file_anon link
r msg_rname link = link
ad file_anon link = ident
s = "from ".sent msg_rname
finish
! %if tell = yes %start
! %while link # 0 %cycle
! msg to == record(message addr(link))
! %if msg to_status = received %start
! %if ad entry # 0 %or msg to_managr = r msg_managr %start
! msg from == record(message addr(msg to_ident))
! %if msg from_rname = sent msg_rname %then tell = no %and %exit
! %finish
! %finish %else %exit
! link = msg to_rname link
! %repeat
! %finish
r msg_recip link = sent msg_recip link
sent msg_recip link = ident
message count = message count+1
if tell=yes and s#"" and r msg_server=this short host start
s = "Message ".s
s = s." ".t while s->s.(" ").t
if ad entry#0 then addr entry_dt last told = secs now
l = length(s)
flag = dmessage(r msg_managr, l, 1, fsys, addr(s)+1)
if 0#flag#process na start
log print(dt."Dmessage ".r msg_managr." fails ".derrs(flag).snl)
finish
finish
end ; !of link recipient
routine unlink msg(record (msg descriptor f) name s msg, integer ident, next recip)
record (msg descriptor f) name next msg
integer name link
link == s msg_recip link
while link#0 cycle
if link=ident then link = next recip and return
next msg == record(message addr(link))
link == next msg_recip link
repeat
log print(dt."Failed to unlink ".ident to s(ident)." from ".s msg_mess id.snl)
end ; !of unlink msg
routine compose message(integer ident, bits, nkb, integer name flag)
! Creates a message file from a series of components.
integer caddr, c, i, pos, next, last
record (fhf) name file header
string (11) filename
filename = ident to s(ident)
create and connect(filename, ident>>24, nkb<<10, zerod!cherish, r!w, caddr)
if caddr=0 then flag = create file fails and return
file header == record(caddr)
cycle last = 1, 1, max components
if bits>>last=0 then exit
repeat
file header_start = 40+last*8
file header_end = file header_start
cycle next = 1, 1, maxcomponents
c = order(next)
if bits>>c&1=1 start
i = file header_end+length(lc comp name(c))+2+msg clen(c)
if i>=file header_size start
i = ((i+epage size-1)&(-epage size))>>10
flag = dchsize(myname, filename, ident>>24, i)
if flag#0 start
printstring("Chsize ".myname.".".filename." fails ".derrs(flag).snl)
flag = ddestroy(myname, filename, "", ident>>24, 0)
printstring(dt."Destroy ".myname.".".filename." flag = ".derrs(flag).snl)
flag = create file fails
return
finish
file header_size = i<<10
finish
pos = file header_end+caddr
string(pos) = lc comp name(c)
i = pos+byteinteger(pos)+1
byteinteger(pos) = nl
move(msg clen(c), msg cbeg(c), i)
file header_cp(c)_beg = i-caddr
file header_cp(c)_len = msg clen(c)
i = i+msg clen(c)
file header_end = i-caddr
finish
repeat
file header_bitcomp = bits
flag = ddisconnect(myname, filename, ident>>24, 0)
if flag#0 start
printstring("Disconnect ".myname.".".filename." fails ".derrs(flag).snl)
flag = create file fails
finish
end ; !of compose message
routine give messages(string (6) user, integer fsys, anon, integer name linkhead, flag)
record (msg descriptor f) name msg
record (msg descriptor f) name s msg
integer name link
record (fhf) name s header
string (31) bcc name
integer sconad, rconad, seg, gap, i, f, nkb
link == linkhead
while link#0 cycle
msg == record(message addr(link))
if msg_status=received and shortform(msg_server)=this short host and (msg_managr=user or anon=no) start
s msg == record(message addr(msg_ident))
seg = 0; gap = 0
flag = dconnect(myname, ident to s(msg_ident), msg_ident>>24, r, 0, seg, gap)
if flag=0 start
sconad = seg<<18
s header == record(sconad)
if msg_rtype=bcc or (s header_bitcomp>>ack to)&1=1 start
fill(max components*8, addr(msg cbeg(1)), 0)
bitcomp = s header_bitcomp
cycle i = max components, -1, 1
if (bitcomp>>i)&1=1 start
msg cbeg(i) = s header_cp(i)_beg+s conad
msg clen(i) = s header_cp(i)_len
finish
repeat
finish
if msg_rtype#bcc start ; !just make a copy
create and connect(ident to s(fsys<<24), fsys, integer(sconad), zerod!tempfi, r!w, rconad)
if rconad>0 start
move(integer(sconad), sconad, rconad)
flag = ddisconnect(myname, ident to s(fsys<<24), fsys, 0)
finish else flag = create file fails
else
if msg_rname#"" then bcc name = msg_rname else bcc name = user."@".this short host
put component(bcc, bcc name)
nkb = ((integer(sconad)+epage size-1)&(-epage size))>>10
compose message(fsys<<24, bitcomp, nkb, flag)
finish
if flag=0 start
if s msg_dt after#0 then i = s msg_dt after else i = s msg_dt sent
cycle i = i, 1, i+9
flag = dtransfer(myname, user, ident to s(fsys<<24), rootfilename.htos(i, 8), fsys, fsys, 1)
if flag#already exists then exit
repeat
if flag=0 then start
message count = message count+1
log print(dt."Message ".s msg_mess id." delivered to ".msg_rname." at ".user.snl)
msg_dt delivered = secs now
msg_status = unused
unlink msg(s msg, link, msg_recip link)
link = msg_rname link
if (s header_bitcomp>>ack to)&1=1 then send acknowledgement(msg)
else
log print(dt."Transfer ".s msg_mess id." to ".user." fails ".derrs(flag).snl)
finish
finish
if flag#0 then f = ddisconnect(myname, ident to s(fsys<<24), fsys, 1)
!+destroy, ignore flag
f = ddisconnect(myname, ident to s(msg_ident), msg_ident>>24, 0)
if s msg_recip link=0 then delete message(msg_ident, f)
else
printstring("!!Connect ".msg_mess id." fails ".derrs(flag).snl)
msg_status = unused
unlink msg(s msg, link, msg_recip link)
link = msg_rname link
finish
else
if anon=no start
printstring(dt."Bad link for ".user." in MAILLIST fsys ".itos(fsys).snl)
return
finish else link == msg_rname link
finish
if flag#0 then return
repeat
end ; !of give messages
integer fn get next descriptor(integer fsys)
! Gets the next free message descriptor from the MAILLIST file.
! Free pointer cycles round file looking hopefully for the oldest
! free descriptors so as not to over write recently used ones to
! preserve a history of what has gone on.
record (fhf) name file header
integer ms
record (msg descriptor f) array name messages
record (msg descriptor f) array format msg af(1:max messages)
if f systems(fsys)#0 start ; !check that a mail file is there
file header == record(f systems(fsys))
messages == array(f systems(fsys)+message entry size, msg af)
ms = file header_free hole; !find next free hole
until ms=file header_free hole cycle
!stop when we come round again
if messages(ms)_status=unused start
!is descriptor unused
file header_free hole = ms+1
file header_free hole = 1 if file header_free hole>max messages
!wrap round
result = fsys<<24!ms
finish
ms = ms+1
ms = 1 if ms>max messages
repeat
printstring("No free message descriptors fsys ".i to s(fsys).snl)
finish else printstring("Invalid fsys for descriptor = ".i to s(fsys).snl)
result = 0
end ; !of integerfn get next descriptor
string fn short form(string (15) server)
! Temp fn to check the equivalence of host names
integer i
i = lookup host(server)
if i<=0 then result = ""
result = statstring(station_shortest name)
end ; !of short form
string fn ident to s(integer ident)
! Turns a message identifier into a string of fixed format
!
string (2) fsys
string (4) rest
fsys = i to s(ident>>24)
fsys = "0".fsys if length(fsys)=1
rest = i to s(ident&x'FFFFFF')
rest = "0".rest while length(rest)<4
result = fsys.rest
end ; !of stringfn ident to s
integer fn message addr(integer ident)
! Returns the address of the message descriptor "IDENT"
! Returns zero if IDENT is not valid
integer fsys, ms
fsys = ident>>24; ms = ident&x'FFFFFF'
result = 0 unless f systems(fsys)#0 and 1<=ms<=max messages
result = f systems(fsys)+ms*message entry size
end ; !of integerfn message addr
routine return to sender(record (msg descriptor f) name msg, integer name flag, integer ident)
! Returns a message to its originator. The message either failed
! to spool, or no indication was later received from spoolr about
! its progress.
integer seg, gap, s conad, type, i
record (msg descriptor f) name s msg
record (fhf) name s header
string (8) s
report fsys = myfsys
report conad = 0
type = mailer dead letter
s conad = 0
add to report("Message ".msg_mess id)
add to report("failed to transmit to ".msg_server)
s msg == record(message addr(msg_ident))
seg = 0; gap = 0
flag = dconnect(myname, ident to s(msg_ident), msg_ident>>24, r, 0, seg, gap)
if flag=0 start
s conad = seg<<18
s header == record(s conad)
fill(max components*8, addr(msg cbeg(1)), 0)
bitcomp = s header_bitcomp
cycle i = max components, -1, 1
if (bitcomp>>i)&1=1 start
msg cbeg(i) = s header_cp(i)_beg+s conad
msg clen(i) = s header_cp(i)_len
finish
repeat
type = mailer returned msg
finish else printstring("Connect ".ident to s(msg_ident)." fails: ".derrs(flag))
mailer sends message(msg_ident>>24, sconad, -1, type, flag)
delete message(ident, i)
if sconad>0 then i = ddisconnect(myname, ident to s(msg_ident), msg_ident>>24, 0)
if flag=0 then s = "succeeds" else s = "fails"
log print(dt."Returning msg ".msg_mess id." at ".ident to s(msg_ident)." ".s.snl)
end ; !of return to sender
routine delete message(integer ident, integer name flag)
! Routine to delete a message and its descriptor.
record (msg descriptorf) name message
string (11) file
string (8) plus
integer fsys, ma
file = ident to s(ident)
fsys = ident>>24
ma = message addr(ident)
if ma=0 start
printstring("Invalid desc ".file." in delete msg".snl)
return
finish
message == record(ma)
flag = ddestroy(my name, file, "", fsys, 0)
if flag#0 start
if message_status&outbound=0 then printstring("Destroy ".my name.".".file." fails ".derrs(flag).snl)
plus = " (descr)"
finish else plus = " (file)"
log print(dt."Message ".message_mess id." deleted, ident=".ident to s(ident).plus.snl)
message_dt deleted = current dt in secs
message_status = unused
end ; !of routine delete message
string fn statstring(integer ad)
if ad=0 then result = ""
result = string(stat space offset+ad)
end ; !of statstring
integer fn lookup hasht(string (127) name)
record format hname f(integer link, host entry, string (255) name)
record (hname f) name hname entry
integer i, pt, n, h
byte integer array x(0:15)
const byte integer array prime(1:7)= 23, 19, 11, 7, 5, 13, 17
pt = (addr(x(7))>>3)<<3
longinteger(pt) = 0
n = addr(name)
byteinteger(pt+i&7) = byteinteger(pt+i&7)!!byteinteger(n+i) for i = 0, 1, length(name)
h = length(name)*29
h = h+prime(i)*byteinteger(pt+i) for i = 1, 1, 7
h = h&hash length
if pointers_hasht(h)#-1 start
hname entry == record(config conad+pointers_hasht(h))
cycle
if name=hname entry_name start ; !found it
station == record(station offset+hname entry_host entry*statio n entry size)
stat space offset = addr(station_string space(0))
!for use in 'statstring'
result = hname entry_host entry
finish
exit if hname entry_link=-1
hname entry == record(config conad+hname entry_link)
repeat
finish
result = 0
end ; !of lookup hasht
integer fn lookup host(string (127) name)
! Determines if a host name is valid - may be a domain literal, or found in the network config file
integer res
string (127) s1, s2
if (length(name)>2 and charno(name, 1)='[') or name->s1.("FTP").s2 then result = 0
!domain literal
name = toupper(printable(name))
res = lookup hasht(name)
if res#0 then result = res
unless name->(this ukac).s1 start
res = lookup hasht(this ukac.name); !prefix uk.ac
if res#0 then result = res
if name->name.(".").s1 start
res = lookup hasht(name); !for arpa.anything etc
if res#0 and station_flags&route flag#0 then result = res
finish
finish
result = -1
end ; !of lookup host
integer fn lookup name(string (255) rname)
! Searches the name table for a given rname and returns
! the entry no of the corresponding addr table entry.
integer lower, upper, entry
string (255) sur
sur = compress(rname)
unless 0<length(sur)<32 and 'A'<=charno(sur, 1)<='Z' then result = not found
lower = startchar(charno(sur, 1))
upper = startchar(charno(sur, 1)+1)
if lower<upper start
cycle
entry = (lower+upper)>>1
if n table(entry)_rname=sur then ->give result
if n table(entry)_rname<sur start
if entry=lower then exit
lower = entry
else
if entry=upper then exit
upper = entry
finish
repeat
finish
if name file_extrastart<=name file_extraend start
cycle entry = name file_extrastart, 1, name file_extraend
if n table(entry)_rname=sur then ->give result
repeat
finish
result = not found
give result:
if n table(entry)_soundex=0 then discarded entry = entry and result = not found
result = entry
end ; !of lookup name
string fn compress(string (255) s)
! Translates a string to uppercase alphanumeric characters.
const byte integer array tab(0:255)= c
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,48,49,50,51,52,53,54,55,56,57,0,0,
0,0,0,0,
0,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,
86,87,88,89,90,0,0,0,0,0,
0,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,
86,87,88,89,90,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
integer dr0, dr1, accdr0, accdr1, i, j
string (255) t
if length(s)=0 then result = ""
dr0 = x'58000000'!length(s)
dr1 = addr(s)+1
accdr0 = x'18000100'
accdr1 = addr(tab(0))
*ld_dr0
*lsd_accdr0
*ttr_ l = dr
i = addr(s)
j = addr(t)+1
cycle i = i+1, 1, i+byteinteger(i)
if byteinteger(i)#0 then byteinteger(j) = byteinteger(i) and j = j+1
repeat
length(t) = j-addr(t)-1
length(t) = 31 if length(t)>31
result = t
end ; !of compress
string fn to upper(string (255) s)
integer dr0, dr1, accdr0, accdr1
dr0 = x'58000000'!length(s)
dr1 = addr(s)+1
accdr0 = x'18000100'
accdr1 = ad ltou trans
*ld_dr0
*lsd_accdr0
*ttr_ l = dr
result = s
end ; !of to upper
routine append to report(integer conad, len)
integer size, flag, i
if len>16000 start
add to report(snl."The text of your message begins as follows -".snl)
len = 16000
for i = conad+len-1, -1, conad+15000 cycle
if byteinteger(i)=nl then len = i-conad+1 and exit
repeat
finish else add to report(snl."The text of your message follows -".snl)
if byteinteger(conad)#nl then add to report("")
size = (report file header_end+len+epage size)&(~epage size)
if size>report file header_size start
flag = dchsize(myname, "REPORTFILE", report fsys, size>>10)
if flag#0 start
printstring("Dchsize reportfile fails: ".derrs(flag).snl)
len = report file header_size-report file header_end
finish else report file header_size = size
finish
move(len, conad, report conad+report file header_end)
report file header_end = report file header_end+len
end ; !of append to report
routine add to report(string (255) s)
! Creates a report file and adds text to it.
integer flag, size
if report conad=0 start
create and connect("REPORTFILE", report fsys, epage size, zerod!tempfi, r!w, report conad)
if report conad=0 then report conad = -1 else start
report file header == record(report conad)
report file header_type = ss char type
finish
finish
if report conad<0 then return
size = (report file header_end+length(s)+1+epage size)&(-epage size)
if size>report file header_size start
flag = dchsize(myname, "REPORTFILE", report fsys, size>>10)
if flag#0 start
log print(dt."Chsize reportfile fails ".derrs(flag).snl)
string(report conad+report file header_size-11) = "** FULL **"
report full = 1
report file header_end = report file header_size-1
return
finish
report file header_size = size
finish
string(report conad+report file header_end) = s
byteinteger(report conad+report file header_end) = nl
report file header_end = report file header_end+length(s)+1
end ; !of add to report
routine return report(string (6) user, string (11) report file, integer fsys, integer name flag)
! Transfers a report file to a user
integer i
flag = ddisconnect(myname, "REPORTFILE", fsys, 0)
if flag#0 start
printstring("Disconnect ".myname.".REPORTFILE fails ".derrs(flag).snl)
flag = cannot return report file
return
finish
flag = dtransfer(myname, user, "REPORTFILE", reportfile, fsys, fsys, 1)
if flag=0 then return
printstring("Transfer REPORTFILE to ".user." fails ".derrs(flag).snl)
i = ddestroy(myname, "REPORTFILE", "", fsys, 0)
flag = cannot return report file
end ; !of return report
routine send acknowledgement(record (msg descriptor f) name r msg)
! On acceptance of a message, sends an acknowledgement to the sender
string (63) s
integer flag, save
save = message count
report conad = 0
add to report("Message ".r msg_mess id)
if r msg_rname="" then s = r msg_managr."@".this host else s = r msg_rname." @ ".this institution
add to report("accepted by ".s." at ".time." on ".date.snl)
mailer sends message(r msg_ident>>24, 0, 0, mailer ack, flag)
if flag=0 then s = "succeeds" else s = "fails"
log print(dt."Sending acknowledgement to ".r msg_mess id." ".s.snl)
report conad = 0
message count = save
end ; !of send acknowledgement
routine compose remote message(integer ident, posn, nkb, bits, integer name flag)
! Packages up a message for transmission to a remote mail server.
integer i, c, dispose, caddr, link, mode, low server, high server
record (fhf) name file header
string (255) s
string (6) filename
routine put(integer len, beg, string (255) extra)
integer i, flag
i = file header_end+len+length(extra)
if i>file header_size start
i = ((i+epage size-1)&(-epage size))>>10
flag = dchsize(myname, filename, ident>>24, i)
if flag#0 start
printstring("Dchsize ".myname." fails ".derrs(flag).snl)
dispose = yes
file header_end = file header_start
return
finish
file header_size = i<<10
finish
if len>0 start
move(len, beg, caddr+file header_end)
file header_end = file header_end+len
finish
if extra#"" start
move(length(extra), addr(extra)+1, caddr+file header_end)
file header_end = file header_end+length(extra)
finish
end ; !of put
dispose = no; !dont destroy
if posn=-1 start ; != 'after' delivery
low server = 1; high server = server map top
mode = cherish
else
low server = posn; high server = posn
mode = tempfi
finish
filename = ident to s(ident)
create and connect(filename, ident>>24, nkb<<10, zerod!mode, r!w, caddr)
if caddr=0 then flag = create file fails and return
file header == record(caddr)
s = ""
cycle i = low server, 1, high server
link = server map(i)_rtable pointer
while link#0 cycle ; !build jnt mail header
if s#"" then put(0, 0, ",".snl)
if rtable(link)_managr="" then s = rtable(link)_rname."@".server map(i)_name else start
if server map(i)_flags&update flag=0 then s = rtable(link)_managr."@".server map(i)_name else c
s = rtable(link)_rname."@".this institution
finish
log print(dt."JNT header = ".s.snl) if monitoring&2>0
put(0, 0, s)
link = rtable(link)_link
repeat
repeat
put(0, 0, snl.snl)
cycle i = 1, 1, max components
c = order(i)
if bits>>c&1=1 start
put(length(lc comp name(c)), addr(lc comp name(c))+1, "")
if byteinteger(msg cbeg(c)+msg clen(c)-1)#nl then s = snl else s = ""
put(msg clen(c), msg cbeg(c), s)
finish
repeat
flag = ddisconnect(myname, filename, ident>>24, dispose)
if flag#0 start
printstring("Ddisconnect ".myname." .".filename." fails".derrs(flag).snl)
flag = create file fails
finish
if dispose=yes then flag = create file fails
end ; !of compose remote message
routine dispatch to remote(integer ident, string (127) remote, string (6) user, integer name flag)
! Submits a message to SPOOLR for transmission to a remote server.
integer index
string (11) srce
record format document descriptorf(string (7) header, byte integer state, string (6) user,
string (15) dest, integer date and time received, date and time started, date and time output,
date and time deleted, start after date and time, priority, data start, data length, time, output limit,
half integer mode of access, byte integer priority requested, forms, mode, copies, order, rerun,
decks, drives, fails, outdev, srce, output, delivery, name, byte integer array vol label(1:8),
byte integer external user, external password, external name, ftp alias, storage codename, device type,
device qualifier, data type, text storage, sp1, sp2, sp3, sp4, sp5, sp6, sp7, byte integer dap blocks,
try emas to emas, ftp retry level, byte integer string ptr, string (147) string space)
record (document descriptorf) document
routine to doc string(record (document descriptor f) name document, byte integer name field,
string name value)
field = 0 and return if value=""
field = x'FF' and return if document_string ptr+length(value)>147
field = document_string ptr
string(addr(document_string space)+document_string ptr-1) = value
document_string ptr = document_string ptr+length(value)+1
end
index = top spoolr reply
until index=top spoolr reply cycle
if spool reply index(index)=0 start
srce = ident to s(ident)
document = 0
document_string ptr = 1
document_dest = "FTP"
document_priority = 3; !STD just now
to docstring(document, document_ftp alias, remote)
document_mode of access = x'0001'
to docstring(document, document_name, srce)
to docstring(document, document_srce, srce)
document_header = "BINDOC:"
document_user = user
flag = dexecmess("FTRANS", index<<8!spoolr reply, 264, addr(document))
log print(dt."Dexecmess ".myname.".".ident to s(ident)." to ".remote." flag = ".derrs(flag).snl)
if flag=0 then spool reply index(index) = ident and top spoolr reply = (index+1)&max reply index
return
finish
index = (index+1)&max reply index
repeat
printstring("No replies from FTRANS - Mailer closed".snl)
mailer state = closed
flag = create file fails
end ; !of dispatch to remote
routine link after(record (msg descriptor f) name msg, integer ident)
! Inserts a message descriptor into a linked list of 'after'
! messages in chronological order.
integer name link
record (msg descriptor f) name l msg
link == after linkhead
msg_ident = 0
while link#0 cycle
l msg == record(message addr(link))
unless l msg_status=waiting then return
if l msg_dt after>msg_dt after then msg_ident = link and exit
link == l msg_ident
repeat
link = ident
message count = message count+1
end ; !of link after
routine place alarm call
! Call the elapsed interval timer for a time-determined delivery message
integer i, secs, j, k
record (msg descriptor f) name msg
record (pe) p
i = message addr(after linkhead)
if i#0 start
msg == record(i)
secs = msg_dt after-current dt in secs
p = 0
if secs<=0 then p_dest = my service number!alarm call else start
p_dest = elapsed int; !get pon in n secs
p_p1 = my service number!alarm call
if secs>x'7FFF' then p_p2 = x'7FFF' else p_p2 = secs
finish
i = dpon2("", p, 0, 6)
finish
k = (charno(date, 7)-'0')*10+charno(date, 8)-'0'
i = get fourth sunday(3, k); !in march
j = get fourth sunday(10, k); !in october
if i<=current dt in secs<j then time zone = "bst" else time zone = "gmt"
end ; !of place alarm call
routine process name command(string (255) s, string (6) user, integer name flag)
! Acts on one of the following user requests:
! ACCREDIT <Rname>,(ALIAS ! DLIST ! BBOARD),,<dept>
! DISCREDIT <Rname>
! INQUIRE <Rname>
integer fsys, i, entry, option
string (255) rname, param1, param2, param3
record (addr entry f) name addr entry
const integer max name commands= 4
switch comm(1:max name commands)
const string (9) array name command(1:max name commands)= c
"ACCREDIT","DISCREDIT","INQUIRE","MAILHERE"
const string (6) array dir options(2:4)= "ALIAS", "DLIST", "BBOARD"
if mailer state=closed then flag = mail service closed and return
fsys = -1
secs now = current dt in secs
flag = dfsys(user, fsys)
report conad = 0
if flag=0 start
if s->s.(" ").rname start
unless rname->rname.(",").param1 then param1 = ""
unless 0<length(rname)<=31 then flag = illegal name and return
unless param1->param1.(",").param2 then param2 = ""
unless param2->param2.(",").param3 then param3 = ""
cycle i = max name commands, -1, 1
if s=name command(i) then ->comm(i)
repeat
finish
flag = invalid command
finish
return
comm(1): !accredit
flag = student user(user)
if flag#0 then return
if length(param3)>31 then flag = bad params and return
option = 0
cycle i = 2, 1, 4
if param1=dir options(i) then option = i and exit
repeat
if option=0 then flag = bad params and return
if option>2 and (dbconad=0 or db_bowner#user) then flag = invalid rname option and return
entry = lookup name(rname)
if entry#0 start
addr entry == record(addr file conad+entry*ad entry size)
if addr entry_managr#user or addr entry_server#this short host then c
flag = rname already accredited and return
addr entry_department = param3
return
finish
if user="MANAGR" start
if param3->param1.("@").param2 start
unless 0<length(param1)<16 and 0<length(param2)<16 then flag = bad params and return
param2 = toupper(param2)
flag = accredit name(rname, "", param2, param1, option, -1, secs now)
return
finish
if length(param3)=6 start
user = toupper(param3)
param3 = ""; fsys = -1
i = dfsys(user, fsys)
if i#0 then flag = user not accredited and return
finish
finish else if kent = yes then start
if user # "BBOARD" then start
flag = bad params
return
finish
finish
flag = accredit name(rname, param3, this short host, user, option, fsys, secs now)
if flag=0 start
entry = lookup name(rname)
if entry#0 then update remote servers("ACCREDIT", entry, entry)
finish
return
comm(2): !discredit
entry = lookup name(rname)
if entry=0 then flag = user not accredited and return
addr entry == record(addr file conad+entry*ad entry size)
if user#"MANAGR" start
if kent = yes then flag = bad params and return
if addr entry_managr#user or addr entry_server#this short host then c
flag = rname belongs to another user and return
if addr entry_link#0 then flag = uncollected mail for rname and return
finish
update remote servers("DISCREDIT", entry, entry)
discredit entry(entry)
return
comm(3): !inquire
flag = lookup name(rname)
return
comm(4): !mailhere
entry = lookup name(rname)
if entry = 0 then flag = user not accredited and return
addr entry == record(addr file conad+entry*ad entry size)
if addr entry_department # "__sysid__".user then start
flag = rname belongs to another user
return
finish
addr entry_server = this short host
addr entry_managr = user
addr entry_timestamp = addr entry_timestamp - 86400
addr entry_department = ""
update remote servers("ACCREDIT",entry,entry)
flag = 0
return
end ; !of process name command
routine discredit entry(integer entry no)
! Removes an entry from the name and address tables
record (addr entry f) name addr entry
addr entry == record(addr file conad+entry no*ad entry size)
log print(dt."Discrediting ".addr entry_rname." <".addr entry_managr."@".addr entry_server."> ". c
addr entry_department.snl)
n table(entry no)_soundex = 0
addr entry = 0
end ; !of discredit entry
integer fn accredit name(string (31) rname, department, string (15) server, managr, integer options, fsys,
secs)
! Adds an entry to the name and address tables.
record (addr entry f) name addr entry
string (31) sur
integer entry no, i
sur = compress(rname)
unless length(sur)>0 and 'A'<=charno(sur, 1)<='Z' then result = illegal name
if server=this short host and length(sur)=6 start
i = -1
i = dfsys(sur, i); !make sure its not anothers usernumber
if i#user not known and sur#managr then result = illegal name
finish
if ad file_entries>=max rnames start
printstring("Addr table full!!".snl)
result = addr table full
finish
discarded entry = 0
entry no = lookup name(sur)
if discarded entry#0 then entry no = discarded entry else entry no = name file_extraend+1
addr entry == record(addr file conad+entry no*ad entry size)
unless 1<=entry no<=max rnames and addr entry_rname="" start
printstring("Addr file corrupt!!".snl)
ad file_entries = max rnames
result = addr table full
finish
addr entry = 0
addr entry_fsys = fsys
addr entry_options = options
addr entry_timestamp = secs
addr entry_managr = managr
addr entry_server = server
addr entry_department = department
addr entry_rname = rname
n table(entry no)_rname = compress(rname)
n table(entry no)_soundex = soundex(rname)
if discarded entry=0 then name file_extraend = entry no and ad file_entries = ad file_entries+1
log print(dt."Accrediting ".rname." <".managr."@".server."> ".department.snl)
result = ok
end ; !of accredit name
routine create and connect(string (11) file, integer fsys, nbytes, createmode, connectmode,
integer name caddr)
integer seg, gap, again, size, f, flag
record (fhf) name file header
string (11) rt
caddr = 0
size = (nbytes+epage size-1)&(-epage size)
cycle again = 2, -1, 1
flag = dcreate(myname, file, fsys, size>>10, createmode)
if flag=0 start
if createmode&cherish#0 then flag = dfstatus(myname, file, fsys, noarch, 0)
seg = 0; gap = 0
flag = dconnect(myname, file, fsys, connectmode, 0, seg, gap)
if flag=0 start
caddr = seg<<18
file header == record(caddr)
file header_end = file header size
file header_start = file header size
file header_size = size
file header_datetime = current dt in secs!x'80000000'
return
finish else rt = "Connect"
exit
finish
rt = "Create"
f = ddestroy(myname, file, "", fsys, 0)
f = ddisconnect(myname, file, fsys, 1); !speculative
repeat
printstring(rt." ".myname.".".file." fails ".derrs(flag).snl)
end ; !of create and connect
routine connect or create(string (6) user, string (11) file, integer fsys, size, flags, integer name caddr)
! Connect or create a file. Setting CADDR with the connect address or
! zero if unsuccesful.
record (fhf) name file header
record (finff) file info
integer flag, seg, gap, nkb
string (31) filename
caddr = 0; !set return connect address to zero initially
nkb = ((size+e page size-1)&(-e page size))>>10
flag = dfinfo(user, file, fsys, addr(file info))
if flag=0 start
if nkb#file info_nkb start
flag = dchsize(user, file, fsys, nkb)
if flag#0 then printstring("Chsize ".user.".".file." fails ".derrs(flag).snl) else c
printstring(user.".".file." SIZE CHANGED ".i to s(nkb-file info_nkb)." KBYTES".snl)
finish
finish
seg = 0; !any segment will do
gap = 0; !any gap will do
unless flag=does not exist then flag = dconnect(user, file, fsys, r!w!shared, 0, seg, gap)
unless flag=ok start ; !successfully connected?
filename = user.".".file
unless flag=does not exist start ; !no? then did it exist
printstring("Connect ".filename." fails ".derrs(flag).snl)
!yes then failure message
flag = ddestroy(user, file, "", fsys, 0)
!try to destroy it
finish else flag = ok
if flag=ok start ; !success or does not exist
flag = dcreate(user, file, fsys, nkb, flags)
!create file
if flag=ok start ; !created ok?
if flags&cherish#0 then flag = dfstatus(user, file, fsys, noarch, 0)
seg = 0; gap = 0
flag = dconnect(user, file, fsys, r!w!shared, 0, seg, gap)
if flag=ok start ; !connected ok?
caddr = seg<<18; !set connect address
file header == record(caddr)
!set up a file headder
file header_end = file header size
file header_start = file header size
file header_size = (size+e page size-1)&(-e page size)
file header_datetime = current dt in secs
finish else printstring("Connect ".filename." fails ".derrs(flag).snl)
finish else printstring("Create ".filename." fails ".derrs(flag).snl)
finish else printstring("Destroy ".filename." fails ".derrs(flag).snl)
finish else caddr = seg<<18; !already existed so return connect address
end ; !of routine connect or create
routine mail queue(record (reqf) name p)
! Processes files held in SPOOLR's mail queue
const integer reqact= x'FFFF003C'; !request a file from spoolr
const integer return act= x'FFFF003D'; ! return a file to spoolr
record (repf) name pp
string (127) ftp source
integer flag, fsys, seg, gap
own integer dispose
switch act(return file ack:file from spoolr)
pp == p
->act(p_dest&x'1F')
act(return file ack):
if pp_flag#0 start
printstring("SPOOL return file fails = ".itos(pp_flag).snl)
return
finish
if dispose=spoolr requeue then dispose = spoolr delete and return
if mailer state=closed then return
p = 0
p_dest = reqact; !now request another file
p_srce = file from spoolr
p_flag = 0; !delay reply till there is a file
p_user = myname
flag = dpon2("SPOOLR", p, 1, 6)
return
act(file from spoolr):
if pp_flag#0 start
printstring("SPOOL request file fails = ".itos(pp_flag).snl)
return
finish
if mailer state=closed then dispose = spoolr requeue else start
fsys = (charno(pp_file, 1)-'0')*10+charno(pp_file, 2)-'0'
seg = 0
gap = 0
dispose = spoolr delete; !delete when returned
flag = dconnect("SPOOLR", pp_file, fsys, r, 0, seg, gap)
if flag=0 start
ftp source <- string(seg<<18+16); !sneaky, spoolr sticks source in file
if ftp source="" then ftp source = pp_ftp source
!for compatibility
process remote file(seg<<18, pp_file, "RELAY", dispose, ftp source)
flag = ddisconnect("SPOOLR", pp_file, fsys, 0)
finish else printstring("Dconnect SPOOLR.".pp_file." fails ".derrs(flag).snl)
finish
if dispose=spoolr requeue then printstring("MAILER requeues SPOOLR.".pp_file.snl)
p_dest = return act
p_srce = return file ack
p_file = pp_file
p_user = myname
p_flag = dispose
p_p6 = 0
flag = dpon2("SPOOLR", p, 1, 6)
end ; !of mail queue
routine process remote file(integer caddr, string name file, string (6) user, integer name dispose,
string (127) ftp source)
! Takes a file from SPOOLR and distributes it to its recipients.
! Also processes a time-determined delivery message whose time has come.
integer flag, top, mend, mbeg, i, j, msg type, nkb, ident, dt sent, fsys, len
string (255) s, msg id, fromname, rname, via string, server
string (31) date time now, managr, srce
record (msg descriptor f) name msg
record (fhf) name file header
const byte integer array preferred sender comp(1:3)= reply to, from, sender
if dispose<0 then srce = myname else srce = "SPOOLR"
log print(dt.srce.".".file." received".snl)
message count = 0
report conad = 0
report fsys = myfsys
bitcomp = 0
msg type = mailer report; !in case of failure
secs now = current dt in secs
date time now = secs to dt(secs now)
fsys = myfsys
! Partition the file into JNT header and message proper
file header == record(caddr)
top = caddr+file header_start
m beg = top; !find start of message within file
m end = caddr+file header_end-1
while m beg<m end cycle
if byteinteger(m beg)#nl then m beg = m beg+1 and continue
mbeg = mbeg+1 until 9#byteinteger(m beg)#' ' or m beg=m end
m beg = m beg+1
if byteinteger(mbeg-1)=nl then exit
repeat
! If file partitioned ok, analyse message components
if top+2<m beg<m end start
staticise message(m beg, m end, remote, i); !get message components
if bitcomp=0 then bitcomp = 1<<body
! Find where message is from and add Via field
srce = ""
if ""#ftp source#"LP" start
if lookup host(ftp source)>0 then ftp source = lcstring(statstring(station_name))
via string = ftp source." ; (to ".this lc host.") ".date time now
put component(via, viastring)
srce = ftp source
finish
! Find who the message is from
cycle j = 1, 1, 3
server map top = 0
i = preferred sender comp(j)
if bitcomp&(1<<i)=0 then continue
process recipients(msg cbeg(i), msg clen(i), ignore route, no report)
if server map top#0 then exit
repeat
if server map top#0 start ; !know who its from
rname = rtable(server map(1)_rtable pointer)_rname
managr = rtable(server map(1)_rtable pointer)_managr
server = server map(1)_short name
if server="" then server = server map(1)_name
server map top = 0; !reset to zero
else
if srce#"" then server = srce else server = "?"
rname = "?"
managr = ""
finish
take component(mess id, msgid)
take component(cdate, s)
dt sent = check and convert dt(s)
unless 0<dt sent<secs now then dt sent = secs now-1
if msg id="" start
if s->msgid.(",").s start ; !remove day from date
finish
if 0<length(s)<200 then msg id = "sent ".s else msg id = "received ".date time now
msg id = "<".msg id." via ".server.">"
put component(mess id, msg id)
finish
take component(from, fromname)
if fromname->fromname.(",").s start
finish
if server=this short host or srce="" then fsys = next fsys
if srce="" and toupper(fromname)="FTPMAN" then srce = "SPOOLR"
unless fromname->fromname.("<").s or length(rname)=1 then fromname = rname
if compress(fromname)="" then fromname = rname
! Analyse recipients (JNT mail header addresses)
i = m beg-top-2
process recipients(top, i, jnt header, report)
if server map top=0 start ; !no recipients
move(31, top, addr(s)+1)
length(s) = 31
s = compress(s)
length(s) = length(myname)
if s=myname start
if (bitcomp&originator comp)=1<<from and (compress(rname)=myname or srce="SPOOLR") start
report conad = 0
flag = msg for mailer(server, msg id)
if flag=0 then return
finish
msg type = mailer dead letter
log print(dt."Srce = ".srce.", server = ".server.snl)
finish
add to report("Message contains no valid recipients - not delivered") if report conad=0
finish
! If there are valid recipients, distribute the message to them
if server map top>0 and rtable top<max recipients start
if bitcomp>>bcc&1=1 start ; !determine the bcc recipients
i = rtable top
process recipients(msg cbeg(bcc), msg clen(bcc), flag bcc, no report)
rtable top = i
finish
ident = get next descriptor(fsys)
if ident#0 start
msg == record(message addr(ident))
msg = 0
msg_rname <- fromname
msg_managr <- managr
msg_server <- server
msg_mess id <- msg id
msg_dt sent = dt sent
msg_dt received = secs now
msg_status = sending
nkb = (m end-m beg+1023)>>10
log print(dt."Remote message ".msg_mess id." from ".srce." received at ".ident to s(ident).snl)
distribute mail(msg, user, ident, fsys, bitcomp, nkb, flag)
if msg_recip link=0 then msg_status = unused
if flag#0 start
printstring("Increase MAXKB or index size for MAILER fsys ".itos(fsys).snl)
dispose = spoolr requeue
return
finish
finish else dispose = spoolr requeue and return
finish
finish else add to report("Invalid msg format") and msg type = mailer dead letter
! Return a report to the sender or deal with a file with the wrong format
if report conad#0 start
log print(dt."Non-delivery report generated".snl)
if msg type=mailer report start
caddr = mbeg; !omit JNT header
len = mend-mbeg+1
finish else len = -1; !use the file header
mailer sends message(fsys, caddr, len, msg type, flag)
finish
end ; !of process remote file
routine mailer sends message(integer fsys, conad, len, type, integer name flag)
! Creates a message from MAILER to a user.
! The message may be an acknowledgement, a non-delivery report, a returned message,
! a dead letter or an FTP failure report
integer i, j, l, ident, final type, rtype
string (31) me
string (255) sub, in reply, dts, s
string (5) account user
record (msg descriptor f) name msg
const integer no mtypes= 5
const string (20) array mtype(1:no mtypes)= c
"Acknowledgement", "Non-delivery report","Returned message",
"Dead letter/report", "Transmission failure"
const byte integer array best sender(1:4)= ack to, sender, from, reply to
routine output(integer from, to)
integer i
cycle i = from, 1, to
printsymbol(byteinteger(i))
repeat
end ; !of output
if len=-1 start ; !get len from the file header
len = integer(conad)-integer(conad+4)
conad = conad+integer(conad+4)
finish
server map top = 0
final type = type
if type#mailer dead letter start ; !if dead, deliver to local postmaster
rtype = 0
if bitcomp&any vias#0 start
viastring = ""
cycle i = via6, -1, via
if (bitcomp>>i)&1=0 then continue
take component(i, dts)
if dts->dts.(";").sub start ; !comment?
finish
dts = printable(dts)
if length(dts)=0 then continue
if dts="TEST" or dts="GUEST" then continue
if length(dts)+length(viastring)>254 then viastring = "" and exit
viastring = viastring."%".dts
repeat
if viastring#"" then rtype = add viastring
log print(dt."Viastring=".viastring.snl) if monitoring&2=2
finish
if type=1 then l = 1 else l = 2; !use ack to?
cycle i = l, 1, 4; !where to send msg?
j = best sender(i)
if rtype#add viastring then rtype = j
if bitcomp&(1<<j)=0 then continue
process recipients(msg cbeg(j), msg clen(j), rtype, no report)
if server map top>0 start
msg cbeg(to) = msg cbeg(j); !note new 'to' field
msg clen(to) = msg clen(j)
if compress(rtable(1)_rname)->s.(myname).dts then server map top = 0
exit
finish
repeat
finish
if server map top=0 start ; !no good originator field
log print(dt."Cannot send ".mtype(type)." to sender".snl)
j = addr(pointers_dead letters)+1
l = length(pointers_dead letters)
process recipients(j, l, 0, no report); !try dead letter box
if server map top>0 then msg cbeg(to) = j and msg clen(to) = l
final type = mailer dead letter
finish
ident = get next descriptor(fsys)
if ident=0 or server map top=0 start
send and define(2, 4, "LPONLY")
selectoutput(2)
printstring(dt."Dumping non-deliverable ".mtype(type).snl)
output(conad, conad+len-1) if conad>0
if report conad>0 start
printstring(snl.dt."Contents of report file:".snl)
output(report conad+integer(report conad+4), report conad+integer(report conad)-1)
flag = ddisconnect(myname, "REPORTFILE", reportfsys, 1)
!+destroy
report conad = 0
finish
selectoutput(0)
send and define(2, 0, "LPONLY"); !stream2, 0=dont redefine
selectoutput(1)
printstring(dt."Non-deliverable ".mtype(type)." sent to LP".snl)
selectoutput(0)
flag = 1
return
finish
secs now = current dt in secs
dts = secs to dt(secs now)
msg == record(message addr(ident))
msg = 0
msg_rname = myname
msg_server = this short host
msg_mess id = "<".dts." ".ident to s(ident)."@".this short host.">"
msg_dt sent = secs now
msg_dt received = secs now
msg_status = sending
me = myname."@".this host
put component(from, me)
put component(c date, dts)
take component(subject, sub)
if length(sub)>200 then length(sub) = 200
if sub="" then sub = mtype(type) else sub = mtype(type)." (".sub.")"
if final type#type then sub = mtype(final type)." - ".sub
put component(subject, sub)
if bitcomp&(1<<mess id)#0 start ; !set 'in reply to'
take component(mess id, in reply)
in reply = "Your message ".in reply
put component(in reply to, in reply)
else
bitcomp = bitcomp&(~(1<<in reply to))
finish
put component(mess id, msg_mess id)
bitcomp = bitcomp!1<<to!1<<body
bitcomp = bitcomp&(1<<from!1<<to!1<<c date!1<<mess id!1<<in reply to!1<<subject!1<<body)
if final type>=mailer report and conad#0 then append to report(conad, len)
msg cbeg(body) = report conad+report file header_start+1
msg clen(body) = report file header_end-report file header_start-1
i = (msg clen(body)+4095)>>10
account user <- compress(mtype(type))
distribute mail(msg, account user, ident, fsys, bitcomp, i, flag)
if msg_recip link=0 then msg_status = 0
i = ddisconnect(myname, "REPORTFILE", report fsys, 1); !+ destroy
report conad = 0
end ; !of mailer sends message
integer fn next fsys
integer fsys
fsys = last fsys
until fsys=last fsys cycle
if pointers_discs(fsys)&3=2 and f systems(fsys)#0 start
last fsys = fsys+1
last fsys = 0 if last fsys>max fsys
result = fsys
finish
fsys = fsys+1
fsys = 0 if fsys>max fsys
repeat
result = myfsys
end ; !of next fsys
routine take component(integer component, string name s)
! Copies a message component to a string skipping leading spaces
integer l, i
if bitcomp&(1<<component)=0 then s = "" and return
i = msg cbeg(component)
l = i+msg clen(component)-1
i = i+1 while i<=l and byteinteger(i)=' '
l = l-i+1
if l>255 then l = 255
move(l, i, addr(s)+1)
length(s) = l
end ; !of take component
routine process oper req(record (cf) name p)
! Processes mainframe OPER commands
record (finff) info
record (msg descriptor f) name msg
record (addr entry f) name addr entry
integer i, oper no, infoad, size, j, del
string (255) param, reply, s1, s2
const integer max commands= 22
switch sw(1:max commands)
const string (8) array command(1:max commands)= c
"MON","CONFIG","STOP","PRINT","CLOSE","OPEN","OPENFSYS","UPDATE",
"DUMP","TEST","CREATE","DISPLAY",
"DELETE","UPDATERS","KICK","SHORTUPD","RETURN","MAILLIST",
"KILLFSYS","MOVEFSYS","TIDYARCH","TAKECONF"
if p_s="" then return
del = no
oper no = p_srce>>8&7; !where message came from
log print(dt."From OPER".itos(oper no)." ".p_s.snl)
p_s = param.reply while p_s->param.(" ").reply
cycle i = max commands, -1, 1
if p_s->s1.(command(i)).param and s1="" then ->sw(i)
repeat
reply = "Invalid command ".p_s." ?"
->error
sw(1): !monitoring on/off
i = stoi(param)
if i>=0 then monitoring = i and return
if "ON"#param#"OFF" then ->bad parameter
if param="ON" then monitoring = yes else monitoring = no
return
sw(2): !config
if param->s1.(".").s2 and length(s1)=6 and 1<=length(s2)<=11 start
i = dsfi(myname, myfsys, get config name, 1, addr(param))
if i#0 then printstring("DSFI set config fails ".derrs(i).snl)
else
if param#"?" then ->bad parameter
i = dsfi(myname, myfsys, get config name, 0, addr(param))
if i=0 then printstring("Config ".param.snl) else printstring("DSFI get config fails ".derrs(i).snl)
finish
return
sw(3): !stop
stop
sw(4): !print
send and define(1, 64, "LP")
return
sw(5): !close
if mailer state=closed then reply = "Already closed" and ->error
mailer state = closed
i = ddisconnect(myname, addrfile, myfsys, 0)
if i#0 then printstring("Disconnect ADDRFILE fails:".derrs(i).snl)
addr file conad = 0
return
sw(7): !open fsys
if mailer state=closed then printstring("Openfsys fails - mailer closed".snl) and return
i = stoi(param)
unless 0<=i<=max fsys then ->bad parameter
if f systems(i)#0 then printstring("Already open fsys ".param.snl) and return
open file system(i)
check descriptors(i)
return
sw(6): !open
if mailer state=open then reply = "Already opened" and ->error
connect tables
if addr file conad>0 start
i = connect config file("")
if i#0 then i = connect config file(confbackup)
if i=0 start
mailer state = open
if name file conad=0 then update tables
finish
if mailer state=open then check descriptors(-1)
finish else printstring("Cannot open".snl)
return
sw(8): !update tables
if mailer state=closed then printstring("Update fails - mailer closed".snl) and return
update tables
if mailer state=closed then return
delete junk(-1)
i = monitoring
monitoring = 8; !log descriptors
check descriptors(-1)
monitoring = i
relink new rnames
if message count#0 then check descriptors(-1)
reset message count
retell recipients
update remote servers("UPDATE", 1, ad file_entries)
update remote servers("UPDATEALL", 1, ad file_entries)
printstring("Update complete".snl)
return
sw(9): !dump
unless param->param.(",").reply.(",").s1 then ->bad parameter
if param->s2.("M").param and s2="" then i = f systems(s to i(param)) else start
i = addr file conad
finish
if i<=0 then ->bad parameter
selectoutput(1)
dump(stoi(reply)+i, stoi(s1), i)
selectoutput(0)
return
sw(10): !test
unless param->s1.(",").s2 then ->bad parameter
cycle i = 1, 1, ad file_entries
addr entry == record(addr file conad+i*ad entry size)
if addr entry_server=s1 then addr entry_server = s2
repeat
printstring("Done".snl)
return
sw(11): !create
infoad = addr(info)
i = dfinfo(myname, addrfile, myfsys, infoad)
if i#does not exist start
if i=0 then printstring("Already exists".snl) else printstring("Dfinfo ADDRFILE fails:".derrs(i).snl)
return
finish
i = dfinfo(myname, addrbackup, myfsys, infoad)
if i#does not exist start
i = newgen or rename(addrbackup, addrfile, addr file conad)
if i=0 then printstring("ADDRFILE recreated from private backup".snl)
return
finish
size = ad entry size*(default max rnames+1)
create and connect(addrfile, myfsys, size, zerod!cherish, r!w!shared, i)
if i=0 then return
ad file == record(i)
ad file_start = ad entry size
ad file_end = size
ad file_size = (size+epage size-1)&(-epage size)
ad file_datetime = current dt in secs!x'80000000'
ad file_version = ad file version no
i = dpermission(myname, "", "", addrfile, myfsys, 1, r)
printstring("ADDRFILE created".snl)
return
sw(13): !delete
del = yes
sw(12): !display
i = s to ident(param)
j = message addr(i)
if j=0 then ->bad parameter
msg == record(j)
printstring("Message ident = ".ident to s(i).snl)
printstring("Rname = ".msg_rname." Managr = ".msg_managr." Server = ".msg_server.snl)
printstring("Mess ID = ".msg_mess id.snl)
if msg_dt sent#0 then printstring("DT sent = ".secs to dt(msg_dt sent).snl)
if msg_dt received#0 then printstring("DT received = ".secs to dt(msg_dt received).snl)
if msg_dt spooled#0 then printstring("DT spooled = ".secs to dt(msg_dt spooled).snl)
if msg_dt after#0 then printstring("DT after = ".secs to dt(msg_dt after).snl)
if msg_dt delivered#0 then printstring("DT delivered = ".secs to dt(msg_dt delivered).snl)
if msg_dt deleted#0 then printstring("DT deleted = ".secs to dt(msg_dt deleted).snl)
printstring("Status = ".itos(msg_status)." Ident = ".ident to s(msg_ident)." Recip link = ".ident to s c
(msg_recip link).snl)
printstring("Rtype = ".itos(msg_rtype)." Rname link = ".ident to s(msg_rname link).snl)
if del=yes then delete message(i, j)
return
sw(14): !update rs
if mailer state=closed then printstring("Update rs fails - mailer closed".snl) and return
update remote servers("UPDATE", 1, ad file_entries)
return
sw(15): !kick mailer stream
p = 0
p_dest = return file ack
mail queue(p)
return
sw(16): !shortupdate
update tables
if mailer state=closed then return
reset message count; !zeroed by update tables
check descriptors(-1)
printstring("Shortupd complete".snl)
return
sw(17): !return old messages
if param#"" start
i = stoi(param)
if i>0 then param = "" and i = i*secs in 24hrs else i = 0
finish else i = default return period
return old messages(param, i)
return
sw(18): !create maillist
i = stoi(param)
unless 0<=i<=max fsys then ->bad parameter
create maillist(i)
return
sw(19): !killfsys
i = stoi(param)
unless 0<=i<=max fsys then ->bad parameter
killfsys(i)
return
sw(20): !movefsys
if param->s1.("TO").s2 start
i = stoi(s1)
j = stoi(s2)
if 0<=i<=max fsys and 0<=j<=max fsys start
movefsys(i, j)
return
finish
finish
->bad parameter
sw(21): !tidyarch
if param="" then i = myfsys else i = stoi(param)
unless 0<=i<=max fsys or i=-1 then ->bad parameter
tidy archive(i)
return
sw(22): !takeconf
i = connect config file(param)
if i#0 then i = connect configfile(myname.".".confbackup)
if i#0 start
mailer state = closed
printstring("Mailer closed!!".tostring(17).snl)
finish else printstring("Done".snl)
return
bad parameter:
reply = "Invalid parameter ".param." ?"
error:
printstring(reply.snl)
end ; !of process oper req
routine deliver after message
! Have received an alarm call - now deliver a time-determined delivery message
record (msg descriptor f) name msg
integer ident, seg, gap, flag, dispose
string (11) file
if after linkhead=0 then return
ident = after linkhead
msg == record(message addr(ident))
if msg_dt after<=current dt in secs start
after linkhead = msg_ident
if msg_status=waiting start
file = ident to s(ident)
seg = 0; gap = 0
flag = dconnect(myname, file, ident>>24, r!w, 0, seg, gap)
if flag=0 start
dispose = -1; !its not really a remote file
process remote file(seg<<18, file, msg_managr, dispose, "")
flag = ddisconnect(myname, file, ident>>24, 0)
if flag#0 start
log print(dt."Ddisconnect ".myname.".".file." fails: ".derrs(flag).snl)
finish
else
log print(dt."Dconnect ".myname.".".file." fails: ".derrs(flag).snl)
finish
delete message(ident, flag) unless dispose=spoolr requeue
finish
finish
place alarm call
end ; !of deliver after message
routine decode spoolr reply(integer reply, flag)
! Interprets SPOOLR's reply to a request to transmit a file to
! a remote server.
integer ident, i
record (msg descriptor f) name msg
if reply=max reply index+1 then return ; !mailer logfile
if 0<=reply<=max reply index start
ident = spool reply index(reply)
i = message addr(ident)
if i#0 start
msg == record(i)
if msg_status=spooling start
if flag=0 start
msg_dt spooled = current dt in secs
msg_status = spooled
else
printstring("Failed to spool ".ident to s(ident)." !!".snl)
!!!!SHOULD TRY AGAIN??
return to sender(msg, flag, ident)
finish
spool reply index(reply) = 0
return
finish
finish
finish else ident = 0
log print(dt."Bad reply from FTRANS - index ".itos(reply).", ident ".ident to s(ident).snl)
end ; !of decode spoolr reply
integer fn msg for mailer(string (15) srce, string name msg id)
! This function handles messages from other mail servers which
! contain amendments to the name/address directory
integer i, entry, pt, fin, its, iopt, records, fn, j
integer res, seg, gap, s conad, ident, flag
string (255) s, rname, dept, managr, t
string (6) file
record (msg descriptor f) name t msg
record (msg descriptor f) name msg
record (fhf) name s header
record (addr entry f) name addr entry
const integer max commands= 4
const string (9) array coms(1:max commands)= c
"ACCREDIT","DISCREDIT","UPDATE", "FTP"
switch c(1:max commands)
integer fn check record(integer from, len)
string (255) ts, opt
if 0<len<255 start
move(len, from, addr(s)+1)
length(s) = len
if s->rname.(",").dept.(",").managr.(",").ts.(",").opt start
if opt->opt.(snl) start
finish
ts = compress(ts)
its = stoi(ts)
iopt = stoi(opt)
if its#not assigned#iopt and length(rname)<=31 and length(dept)<=31 and length(managr)<=15 start
entry = lookup name(rname)
if entry#0 then addr entry == record(addr file conad+entry*ad entry size)
managr = printable(managr)
if its>secs now then its = secs now
result = 0
finish
finish
finish
s = "Invalid ".coms(fn).", record ".itos(records)." in file"
log print(dt.s.snl)
add to report(s)
result = 1
end ; !of check record
integer fn try to accredit
if entry=0 then result = accredit name(rname, dept, srce, managr, iopt, -1, its)
if addr entry_server#srce or addr entry_managr#managr start
!conflict
if addr entry_timestamp<=its start
log print(dt."Rejecting ACCREDIT for ".rname." <".managr."@".srce."> ".dept.snl)
if addr entry_timestamp=its then discredit entry(entry)
!remove both
else
discredit entry(entry); !supplants existing entry
result = accredit name(rname, dept, srce, managr, iopt, -1, its)
finish
else ; !same entry, may be amendments
addr entry_department = dept
addr entry_options = iopt
addr entry_timestamp = its
addr entry_rname = rname
addr entry_link = 0
finish
result = 0
end ; !of try to accredit
if srce#"" start
take component(comments, s)
s = compress(s)
if length(s)+length(msgid)>200 then s = "?"
dept <- dt."Remote msg ".msg id." from ".srce.", ".s." advice".snl
log print(dept)
records = 0
cycle fn = max commands, -1, 1
if s=coms(fn) then ->c(fn)
repeat
s = "bad function name"
finish else s = "no source key"
log print(dt."Invalid msg for MAILER - ".s.snl)
add to report("Fails - ".s)
result = 1
c(1): !accredit
if check record(msg cbeg(body), msg clen(body))#0 then result = 1
i = try to accredit
if i#0 then add to report("Accredit fails - ".err mess(i))
result = i
c(2): !discredit
if check record(msg cbeg(body), msg clen(body))#0 then result = 1
if entry=0 then s = " Rname not accredited" else s = " not Rname owner"
if entry=0 or managr#addr entry_managr or srce#addr entry_server start
log print(dt."Rejecting DISCREDIT ".rname." <".managr."@".srce."> ".s.snl)
add to report("Discredit fails - ".s)
result = 1
finish else discredit entry(entry)
result = 0
c(3): !update
cycle entry = 1, 1, ad file_entries
addr entry == record(addr file conad+entry*ad entry size)
if addr entry_server=srce then addr entry_link = -1
repeat
pt = msg cbeg(body)
fin = pt+msg clen(body)-1
until pt>=fin cycle
j = fin+1
cycle i = pt, 1, fin
if byteinteger(i)=nl then j = i and exit
repeat
if check record(pt, j-pt)#0 then result = 1
pt = j+1
if try to accredit#0 then result = 1
records = records+1
repeat
log print(dt.itos(records)." UPDATE records processed".snl)
cycle entry = 1, 1, ad file_entries
addr entry == record(addr file conad+entry*ad entry size)
if addr entry_server=srce and addr entry_link=-1 then discredit entry(entry)
repeat
result = 0
c(4): !ftp report
take component(references, file); !get msg ident
ident = s to ident(file)
i = message addr(ident)
res = 1
if i#0 start
t msg == record(i)
if t msg_status=spooled or t msg_status=spooling start
take component(keywords, s); !gives result 0 or 1
if s="0" then fn = 0 else fn = 1
s = "Message ".t msg_mess id." FTP ".file." to ".t msg_server
msg == record(message addr(t msg_ident))
if fn=0 then s = s." success" and res = 0 else start
s = s." fails"
seg = 0; gap = 0
flag = dconnect(myname, ident to s(t msg_ident), t msg_ident>>24, r, 0, seg, gap)
if flag=0 start
take component(body, t); !spoolr's report on the failure
sconad = seg<<18
s header == record(s conad)
bitcomp = s header_bitcomp
cycle i = 1, 1, max components
if (bitcomp>>i)&1=1 start
msg cbeg(i) = s header_cp(i)_beg+s conad
msg clen(i) = s header_cp(i)_len
finish
repeat
report conad = 0
add to report("The file transfer of your message to host ".t msg_server)
add to report("was not successful. The transaction is given below -".snl)
add to report(t)
mailer sends message(my fsys, sconad, -1, mailer ftp failure, flag)
if flag=0 then res = 0 else s = s." - report fails"
i = ddisconnect(myname, ident to s(t msg_ident), t msg_ident>>24, 0)
finish else s = s.snl.dt."Connect ".ident to s(t msg_ident)." fails ".derrs(flag)
finish
t msg_status = unused
t msg_dt deleted = current dt in secs
unlink msg(msg, ident, t msg_recip link)
if msg_recip link=0 then delete message(t msg_ident, i)
finish else s = "FTP report - message status wrong for ".file
finish else s = "FTP report - invalid ident = ".file
log print(dt.s.snl)
if res#0 then add to report(s)
result = res
end ; !of msg for mailer
integer fn s to ident(string (255) s)
integer i, j
if length(s)#6 then result = 0
cycle i = 1, 1, 6
unless '0'<=charno(s, i)<='9' then result = 0
repeat
length(s) = 2
i = stoi(s)
length(string(addr(s)+2)) = 4
j = stoi(string(addr(s)+2))
result = i<<24!j
end ; !of s to ident
routine return old messages(string (31) managr, integer return period)
! Searches for old undelivered messages and returns them to sender
integer return date, fsys, msg no, seg, gap, flag, old ident, conad, i
record (msg descriptor f) array name messages
record (msg descriptor f) array format msg af(1:max messages)
record (fhf) name m file
record (msg descriptor f) name r msg
record (msg descriptor f) name old msg
string (10) s
integer name link
return date = current dt in secs
if return date<ad file_datetime then printstring("Invalid DT set".snl) and return
if return period=0 then return date = 0 else return date = return date-return period
cycle fsys = 0, 1, max fsys
if f systems(fsys)#0 start
messages == array(f systems(fsys)+message entry size, msg af)
cycle msg no = 1, 1, max messages
if messages(msg no)_status=sending and (messages(msg no)_dt sent<return date or c
""#managr=messages(msg no)_managr) start
old ident = fsys<<24!msg no
old msg == messages(msg no)
seg = 0; gap = 0
flag = dconnect(myname, ident to s(old ident), fsys, r, 0, seg, gap)
if flag#0 start
printstring("Connect MAILER.".ident to s(old ident)." fails ".derrs(flag).snl)
old msg_status = unused
continue
finish
report conad = 0
add to report("The message listed below was uncollected by the".snl. c
"following recipient(s) and has been deleted:")
link == old msg_recip link
while link#0 cycle
r msg == record(message addr(link))
link == r msg_recip link
if r msg_mess id#old msg_mess id then printstring("Bad link!!".snl) and return
add to report(" ".r msg_rname." <".r msg_managr."@".r msg_server.">")
r msg_status = unused
repeat
conad = seg<<18
m file == record(conad)
bitcomp = m file_bitcomp
i = lookup host(old msg_server)
if (i>0 and station_flags&local host flag#0) or bitcomp&(1<<ack to)#0 start
cycle i = max components, -1, 1
if (bitcomp>>i)&1=1 start
msg cbeg(i) = m file_cp(i)_beg+conad
msg clen(i) = m file_cp(i)_len
finish
repeat
mailer sends message(fsys, conad, -1, mailer returned msg, flag)
if flag=0 then s = "succeeds" else s = "fails"
finish else s = "suppressed"
log print(dt."Returning msg ".old msg_mess id." at ".ident to s(old ident)." to ".old msg_server. c
" ".s.snl)
i = ddisconnect(myname, ident to s(old ident), fsys, 0)
if flag=0 then delete message(old ident, flag)
finish
repeat
finish
repeat
end ; !of return old messages
routine update remote servers(string (15) action, integer loopstart, loopend)
! Generates a file containing a one line entry extracted from
! the address table for each locally accredited R-name and transmits
! it to remote mail servers.
record (fhf) name file header
record (msg descriptor f) name msg
record (addr entry f) name addr entry
integer serv no, entry, ident, nkb, flag, x, update type
string (255) s, s1, s2
string (31) dts
string (47) msg id
if action="UPDATEALL" then update type = update copy flag else update type = update flag
message count = 0
cycle x = 1, 1, pointers_stations
station == record(station offset+x*station entry size)
if station_flags&update type=update type start
report conad = 0
report fsys = myfsys
report full = 0
cycle entry = loopstart, 1, loopend
addr entry == record(addr file conad+entry*ad entry size)
if update type&update copy flag=update copy flag or addr entry_server=this short host start
s = addr entry_rname
s = s.s1 while s->s.(",").s1
s1 = addr entry_department
s1 = s1.s2 while s1->s1.(",").s2
if update type&update copy flag=update copy flag then s2 = addr entry_server else c
s2 = "X".htos(addr entry_timestamp, 8)
s = s.",".s1.",".addr entry_managr.",".s2.",".itos(addr entry_options)
s = s.s1 while s->s.(snl).s1
add to report(s)
finish
repeat
if report conad>0 then add to report("")
if report conad<=0 or report full=1 start
printstring("Create remote server update fails".snl)
return
finish
bitcomp = 1<<body
file header == record(report conad)
msg cbeg(body) = report conad+file header_start+1
msg clen(body) = file header_end-file header_start-1
s = myname."@".this host
put component(from, s)
secs now = current dt in secs
dts = secs to dt(secs now)
put component(c date, dts)
put component(comments, action)
ident = get next descriptor(myfsys)
if ident=0 then return
msgid = "<".dts." ".ident to s(ident)."@".this short host.">"
put component(messid, msgid)
msg == record(message addr(ident))
msg = 0
msg_mess id = msgid
msg_dt sent = secs now
msg_managr = myname
msg_server = this short host
msg_mess id = msg id
server map top = 0
nkb = (msg clen(body)+1124)>>10
cycle serv no = 1, 1, pointers_stations
station == record(station offset+servno*station entry size)
if station_flags&update type=update type start
stat space offset = addr(station_string space(0))
s1 = "mailer@".statstring(station_name)
process recipients(addr(s1)+1, length(s1), to, no report)
finish
repeat
distribute mail(msg, "UPDAT", ident, myfsys, bitcomp, nkb, flag)
if msg_recip link#0 then msg_status = sending
exit
finish
repeat
flag = ddisconnect(myname, "REPORTFILE", myfsys, 1); !+destroy
report conad = 0
end ; !of update remote servers
routine check descriptors(integer fsys spec)
! Searches the MAILLIST file on the specified fsys and checks
! the consistency of all SENDING and RECEIVING descriptors.
integer entry, fsys, msg no, i, flag, ident, send ident, res, log
integer previous after linkhead
string (8) state
string (31) s
record (addr entry f) name addr entry
record (msg descriptor f) array name messages
record (msg descriptor f) array format msg af(1:max messages)
record (msg descriptor f) name sent msg
byte integer array use(1:max messages)
byte integer array visit(1:max messages)
integer fn set(byte integer array name a, integer no)
if a(no)=1 then result = 1
a(no) = 1
result = 0
end ; !of set
if fsys spec=-1 start
cycle entry = 1, 1, ad file_entries
addr entry == record(addr file conad+entry*ad entry size)
if addr entry_rname#"" then addr entry_link = 0
repeat
ad file_anon link = 0
after linkhead = 0
finish
if monitoring&8#0 then log = yes else log = no
log print(dt."Check descriptors".snl)
message count = 0
previous afterlinkhead = after linkhead
cycle fsys = 0, 1, max fsys
if (fsys spec=-1 or fsys spec=fsys) and f systems(fsys)#0 start
messages == array(f systems(fsys)+message entry size, msg af)
fill(max messages, addr(use(1)), 0)
fill(max messages, addr(visit(1)), 0)
cycle msg no = 1, 1, max messages
ident = fsys<<24!msg no
if messages(msg no)_status&sending#0 start
if set(visit, msg no)=0 then messages(msg no)_recip link = 0
else
flag = set(use, msg no); !set use
if waiting#messages(msg no)_status#unused start
send ident = messages(msg no)_ident
i = message addr(send ident)
sent msg == record(i)
cycle res = 1, 1, 10
if i#0 and sent msg_status=sending and messages(msg no)_mess id=sent msg_mess id then c
res = 0 and exit
*lss_(3); *ush_-26
*and_3; *st_flag
printstring("Mailer descr, OCP=".itos(flag).snl)
repeat
if res=0 start
if set(visit, send ident&x'FFFFFF')=0 then sent msg_recip link = 0
flag = set(use, send ident&x'FFFFFF')
!set use
if messages(msg no)_status&(spooling!spooled)#0 start
messages(msg no)_recip link = sent msg_recip link
sent msg_recip link = ident
if messages(msg no)_status=spooled then state = "spooled" else state = "spooling"
else
if shortform(messages(msg no)_server)=this short host then c
entry = lookup name(messages(msg no)_rname) else entry = 0
link recipient(sent msg, messages(msg no), ident, entry, -1, dont tell)
state = "received"
finish
if log=yes start
if messages(msg no)_rname#"" then s = messages(msg no)_rname else c
s = "[".messages(msg no)_managr."]"
log print(dt."ID=".messages(msg no)_mess id.", ".state." for ".s." at ".ident to s c
(ident).snl)
finish
else
printstring("Inconsistent descriptor, ident=".ident to s(ident).", ID=".messages(msg no) c
_mess id.", s ident=X".h to s(send ident, 8).snl)
messages(msg no)_status = unused
finish
else
if messages(msg no)_status=waiting start
link after(messages(msg no), ident)
log print(dt."ID=".messages(msg no)_mess id." from ".messages(msg no)_rname.", waiting ". c
secs to dt(messages(msg no)_dt after).snl) if log=yes
finish
finish
finish
repeat
cycle msg no = 1, 1, max messages
if set(use, msg no)=0 start
printstring("Message ".messages(msg no)_mess id." has zero recipients".snl)
delete message(fsys<<24!msg no, flag)
finish
repeat
finish
repeat
if previous after linkhead#after linkhead then place alarm call
log print(dt.itos(message count)." messages outstanding for Fsys ".itos(fsys spec).snl)
end ; !of check descriptors
routine reset message count
! Resets the DSFI record showing message count for a process
integer array count(1:ad file_entries)
integer i, j, last, flag, c, link
integer u, top user, fsys
const integer max users= 1000
string (6) array user(1:max users)
record (addr entry f) name addr entry
record (addr entry f) name addr entry2
record (msg descriptor f) name msg
log print(dt."Reset message count".snl)
cycle i = 1, 1, ad file_entries
addr entry == record(addr file conad+i*ad entry size)
if addr entry_server=this short host start
c = 0
last = i
link = addr entry_link
while link#0 cycle
c = c+1
msg == record(message addr(link))
link = msg_rname link
repeat
count(i) = c
j = 1
while j<i cycle
addr entry2 == record(addr file conad+j*ad entry size)
if addr entry2_managr=addr entry_managr and addr entry2_server=this short host and c
count(j)>=0 start
count(i) = count(i)+count(j)
count(j) = -1
exit
finish
j = j+1
repeat
finish else count(i) = -1
repeat
cycle i = 1, 1, last
if count(i)>=0 start
addr entry == record(addr file conad+i*ad entry size)
flag = dsfi(addr entry_managr, addr entry_fsys, msg indicator, 1, addr(count(i)))
if flag#0 start
log print(dt."DSFI43 fails for ".addr entry_managr.derrs(flag).snl)
else
! %if count(i) > max outstanding %then detachjob for accept(addr entry_managr, %c
! addr entry_fsys,addr entry_rname)
if count(i)>maxoutstanding start
log print("DETACHING FOR ".addr entry_managr.snl)
finish
finish
finish
repeat
top user = 0
link = ad file_anon link
while link#0 cycle
msg == record(message addr(link))
u = 1
while u<=top user cycle
if user(u)=msg_managr then count(u) = count(u)+1 and exit
u = u+1
repeat
if u>top user start
if u>max users then exit ; !cant handle any more
top user = top user+1
user(top user) = msg_managr; !add to table
count(top user) = 1
finish
link = msg_rname link
repeat
u = 1
while u<=top user cycle
fsys = -1
flag = dfsys(user(u), fsys)
if flag=0 start
flag = dsfi(user(u), fsys, msg indicator, 1, addr(count(u)))
! %if COUNT(U)>MAX OUTSTANDING %then DETACHJOB FOR ACCEPT(USER(U),FSYS,"")
else
log print(dt."Dfsys ".user(u)." fails : ".derrs(flag).snl)
finish
u = u+1
repeat
end ; !of reset message count
routine relink new rnames
! Checks each anon-link message. If any recipients now have a valid
! R-name then amend the message descriptor accordingly
integer link, flag, entry
string (31) sfisurname
record (msg descriptor f) name msg
record (addr entry f) name addr entry
log print(dt."Relink new rnames".snl)
link = ad file_anon link
message count = 0
while link#0 cycle
msg == record(message addr(link))
if msg_status&outbound=0 start
printstring("Bad anonlink for ident ".ident to s(link).snl)
return
finish
if shortform(msg_server)=this short host start
flag = dsfi(msg_managr, -1, getsfisurname, 0, addr(sfisurname))
if flag=0 start
entry = lookup name(sfisurname)
if entry#0 start
addr entry == record(addr file conad+entry*ad entry size)
if msg_managr=addr entry_managr and this short host=addr entry_server start
msg_rname = addr entry_rname
message count = 1
log print(dt."Message ".msg_mess id." recipient ".msg_rname." relinked to ".addr entry_rname. c
snl)
finish
finish
else
log print(dt."DSFI fails for user ".msg_managr.", message ".msg_mess id.derrs(flag).snl)
entry = 0
finish
finish
link = msg_rname link
repeat
end ; !of relink new rnames
routine retell recipients
! Checks if any users with uncollected mail have logged on since
! the last TELL message was issued - if so issue another!
! Also corrects any msg descriptors where the recipient has emigrated
! to another host.
integer fn adjust(integer logon)
integer days
if logon<0 then result = logon&x'7FFFFFFF'
days = kday(logon>>17&x'1F', logon>>22&x'F', (logon>>26)+70)-days70
result = days*secs in 24 hrs+(logon>>12&x'1F')*3600+(logon>>6&x'3F')*60+(logon&x'3F')
end ; !of adjust
integer entry, flag, logon, logon2, l, link, last 24 hours
string (63) s
record (msg descriptor f) name msg, msg2
record (addr entry f) name addr entry
log print(dt."Retell recipients".snl)
message count = 0
secs now = current dt in secs
cycle entry = 1, 1, ad file_entries
addr entry == record(addr file conad+entry*ad entry size)
if addr entry_link#0 start
if addr entry_server=this short host start
flag = dsfi(addr entry_managr, addr entry_fsys, get last logon, 0, addr(logon))
if flag=0 start
logon = adjust(logon)
if addr entry_dt last told<logon<secs now start
message count = message count+1
s = "Outstanding message(s)"
if addr entry_options=alias option then s = s." for ".addr entry_rname
l = length(s)
flag = dmessage(addr entry_managr, l, 1, addr entry_fsys, addr(s)+1)
addr entry_dt last told = secs now
if 0#flag#process na then c
printstring(dt."Dmessage ".addr entry_managr." fails ".derrs(flag).snl) else c
printstring(dt."Retell ".addr entry_managr.snl)
finish
else
log print(dt."DSFI logon fails for ".addr entry_managr." ".derrs(flag).snl)
finish
else ; !recipient has moved
link = addr entry_link
until link=0 cycle
msg == record(message addr(link))
msg_rname = ""; !so its not linked to addr file
log print(dt."Message ".msg_mess id." at ".ident to s(link)." relinked".snl)
link = msg_rname link
repeat
finish
finish
repeat
! Now check messages not linked via ADDR file
last 24 hours = secs now-secs in 24 hrs
s = "Outstanding message"
l = length(s)
link = ad file_anon link
while link#0 cycle
msg == record(message addr(link))
if msg_status#received start
printstring("Bad anon link for ident ".ident to s(link).snl)
return
finish
if msg_dt told=last 24 hours then link = msg_rname link and continue
flag = dsfi(msg_managr, -1, get last logon, 0, addr(logon))
if flag=0 start
logon = adjust(logon)
if last 24 hours<logon<secs now and msg_dt received<logon start
message count = message count+1
flag = dmessage(msg_managr, l, 1, -1, addr(s)+1)
if 0#flag#process na then log print(dt."Dmessage ".msg_managr." fails ".derrs(flag).snl) else c
printstring(dt."Retell ".msg_managr.snl)
finish
msg2 == msg
while msg2_rname link#0 cycle
msg2 == record(message addr(msg2_rname link))
if msg2_managr=msg_managr then msg2_dt told = last 24 hours
repeat
else
log print(dt."DSFI logon fails for ".msg_managr." ".derrs(flag).snl)
finish
link = msg_rname link
repeat
log print(dt."Total retells = ".itos(message count).snl)
end ; !of retell recipients
integer fn soundex(string (31) name)
const string (1) array stable('A':'Z')= c
"", "1", "2", "3", "", "1",
"2", "", "", "2", "2", "4",
"5", "5", "", "1", "2", "6",
"2", "3", "", "1", "", "2",
"", "2"
string (31) work, s
integer ptr, last, this
length(name) = length(name)-1 while c
length(name)>0 and (charno(name, length(name))='.' or charno(name, length(name))=' ')
cycle
if name->s.(".").name then continue
if name->s.(" ").name then continue
exit
repeat
name = compress(name)
if name="" then result = 1
if (name->work.("MAC").name and work="") or (name->work.("MC").name and work="") start
work = "@"
last = '@'
ptr = 1
else
last = charno(name, 1)
work = tostring(last)
ptr = 2
finish
while ptr<=length(name) cycle
this = charno(name, ptr)
if 'A'<=this<='Z' and this#last start
last = this
work = work.stable(this)
finish
ptr = ptr+1
repeat
work <- work."0000"
move(4, addr(work)+1, addr(ptr))
result = ptr
end ; !of soundex
routine detachjob for accept(string (6) user, integer fsys, string (255) rname)
integer caddr, flag, suffix
string (11) jfilename
string (255) s, text
record (pe) p
if db conad=0 or db_jobtext="" start
log print(dt."No jobtext for user ".user." rname ".rname.snl)
else
create and connect("JOBFILE", fsys, 4095, zerod, r!w, caddr)
if caddr#0 start
text = db_jobtext.rname.snl
string(caddr+31) = text
integer(caddr) = integer(caddr)+length(text)
flag = ddisconnect(myname, "JOBFILE", fsys, 0)
suffix = current dt in secs
suffix = suffix-(suffix//100)*100
jfilename = "M#JOB".itos(suffix)
flag = dtransfer(myname, user, "JOBFILE", jfilename, fsys, fsys, 1)
if flag=0 start
s = "DOCUMENT DEST=BATCH,SRCE=".jfilename.",START=32,NAME=MAILJOB,LENGTH=".itos(length(text)). c
",OUT=FILE,OUTNAME=.NULL"
p = 0
string(addr(p_p1)) = "SPOOLR"
flag = dsubmit(p, length(s), addr(s)+1, spool log reply, user)
finish
s = derrs(flag)
finish else s = "create file fails"
log print(dt."Dsubmit/transfer job for ".user.", flag = ".s.snl)
finish
end ; !of detachjob for accept
string fn lcstring(string (255) s)
integer i
for i = addr(s)+1, 1, addr(s)+length(s) cycle
if 'A'<=byteinteger(i)<='Z' then byteinteger(i) = byteinteger(i)+32
repeat
result = s
end ; !of lcstring
routine connect dbfile(integer name flag)
! Connect the distribution list/bulletin board file for use. Also takes a new dbfile in service.
integer seg, gap
if db conad=0 start
seg = 0; gap = 0
flag = dconnect(myname, dbfile, myfsys, r!w!shared, apf, seg, gap)
if flag=0 start
db conad = seg<<18
db == record(db conad)
return
finish
printstring("Connect DBFILE fails: ".derrs(flag).snl)
finish
flag = newgen or rename(newdbfile, dbfile, db conad)
printstring("Take new DBFILE, flag = ".derrs(flag).snl)
if db conad#0 start
db == record(db conad)
flag = dpermission(myname, db_bowner, "", dbfile, myfsys, 2, r!w)
!w access to owner
finish
end ; !of connect dbfile
integer fn connect config file(string (31) filename)
! Connects the network configuration file. Normally shared access to FTRANS.CFILE
! Can take a new file during service.
integer seg, gap, flag, i, conad
string (31) user, file, u, f
record (fhf) name file header
if filename="" start
flag = dsfi(my name, my fsys, 2, 0, addr(filename))
finish else flag = 0
if flag=0 start
if filename->user.(".").file and length(user)=6 and length(file)<=11 start
if config conad#0 start ; !disconnect the current file
if current configfile->u.(".").f start
flag = ddisconnect(u, f, myfsys, 0)
if flag#0 then flag = ddisconnect(u, f, -1, 0)
if flag#0 start
printstring("Ddisconnect ".current configfile." fails: ".derrs(flag).snl)
finish else config conad = 0
finish
finish
seg = 0; gap = 0
flag = dconnect(user, file, myfsys, r!shared, 0, seg, gap)
if flag#0 then flag = dconnect(user, file, -1, r!shared, 0, seg, gap)
if seg#0 start
current configfile = filename; !remember filename
config conad = seg<<18
file header == record(config conad)
pointers == record(config conad+file header_start)
station offset = config conad+pointers_station displ-station e ntry size
hasht == pointers_hasht
this host = ""; this short host = ""
this institution = ""
flag = 1
for i = 1, 1, pointers_stations cycle ; !look for this host & institution
station == record(station offset+i*station entry size)
stat space offset = addr(station_string space(0))
if station_flags&this host flag#0 start
this host = statstring(station_name)
this short host = statstring(station_shortest name)
this lc host = lcstring(this host)
else
if station_flags&this auth flag#0 start
this institution = statstring(station_name)
this lc institution = lcstring(this institution)
finish
finish
if this host#"" and this institution#"" then flag = 0 and exit
repeat
if length(this short host)>15 start
printstring("Shortname for thishost too long!: ".this short host.snl)
flag = 1
finish
if flag=0 start
create and connect("X".confbackup, myfsys, file header_end, zerod!cherish, r!w, conad)
if conad>0 start
move(file header_end, config conad, conad)
i = ddisconnect(myname, "X".confbackup, myfsys, 0)
if i=0 start ; !replace the old backup
i = dnewgen(myname, "X".confbackup, confbackup, myfsys)
if i#0 then i = drename(myname, "X".confbackup, confbackup, myfsys)
if i#0 then printstring("Dnewgen/rename X".confbackup." fails: ".derrs(i).snl)
finish else printstring("Ddisconnect X".confbackup." fails: ".derrs(i).snl)
finish
result = 0
finish
printstring("Invalid config file!!!".snl)
finish else printstring("Dconnect ".filename." fails :".derrs(flag).snl)
finish else printstring("Invalid configfile name: ".filename.snl)
finish else printstring("Config from index fails: ".derrs(flag).snl)
result = 1
end ; !of connect config file
routine update tables
! Checks every entry in the address table to make sure that a user
! has not been discredited or has not set zero permission to MAILER.
! An entry stays if its fsys is currently off-line. Also checks
! whether the SFI surname has changed - adjusts table accordingly.
! Initialises name table, resets count, and adds names to new name table.
! Then checks all users on all file systems and accredits new
! users (except those with perm=zero to MAILER)
! Reports users with conflicting names.
! Finally sorts the name table alphabetically if it has been changed.
! CHANGE??: disc on-line but not in pointers, causes discredit entry
integer i, j, permad, fsys, entry, n, f, flag, size, last, zero
integer char, nf conad, new conad, next slot, new max rnames
integer array a(0:max fsys)
record (addr entry f) name addr entry
record (addr entry f) name addr entry2
record (ad file f) name new ad file
record (perm f) perm
record (usf) array nn(0:511)
string (31) sfisurname
integer fn perm to mailer
integer i, j
i = (perm_bytes-16)//8
j = 0
while j<i cycle
if perm_i prms(j)_user=mailer start
if perm_i prms(j)_uprm=no then result = no
finish
j = j+1
repeat
result = yes
end ; !of perm to mailer
! Create new name table
if ad file_entries+200>max rnames then new max rnames = max rnames+200 else new max rnames = max rnames
if new max rnames>abs max rnames then c
printstring("MAILER - too many names!!".snl) and new max rnames = abs max rnames
after linkhead = 0
if name file conad#0 then name file_datetime = 0; !tells users 'bad medicine'
mailer state = closed
name file conad = 0
flag = ddisconnect(myname, snamefile, myfsys, 0)
if flag#0 then printstring("Disconnect NAMEFILE fails: ".derrs(flag).snl)
size = name file header+new max rnames*name entry size
create and connect("N".snamefile, myfsys, size, zerod!tempfi, r!w, nf conad)
if nf conad=0 start
printstring("MAILER closed".snl)
return
finish
name file == record(nf conad)
n table == array(nf conad+name file header, name table arf)
startchar == name file_startchar
permad = addr(perm)
secs now = current dt in secs
last = 0
! Check existing entries in the address table
cycle entry = max rnames, -1, 1
addr entry == record(addr file conad+entry*ad entry size)
addr entry_link = 0
if addr entry_server=this short host start
again:
flag = dpermission(addr entry_managr, "", "", "", addr entry_fsys, get index list, permad)
if flag#ok start
fsys = -1
i = dfsys(addr entry_managr, fsys)
if i=ok and fsys#addr entry_fsys start ; !found on another fsys
log print(" - moving ".addr entry_rname." to fsys ".itos(fsys).snl)
addr entry_fsys = fsys
->again
finish
if flag=fsys not available start
!users fsys currently off-line
log print(" - ".addr entry_rname." at ".addr entry_managr." off-line".snl)
else
if flag=user not known start
!user discredited
log print(" - removing ".addr entry_rname." at ".addr entry_managr." ".derrs(flag).snl)
addr entry = 0
else ; !some failure in dperm
log print(" - DPERM ".addr entry_rname." at ".addr entry_managr." fails:".derrs(flag).snl)
finish
finish
else ; !got perm
if perm to mailer=no and addr entry_options=sfioption start
log print(" - Removing ".addr entry_rname." at ".addr entry_managr." no permission".snl)
addr entry = 0
else
flag = dsfi(addr entry_managr, addr entry_fsys, get sfi surname, 0, addr(sfisurname))
if flag=0 and sfisurname#addr entry_rname and addr entry_options=sfioption start
log print(" - removing ".addr entry_rname." at ".addr entry_managr." new sname".snl)
addr entry = 0
finish
finish
finish
finish ; !not this server, cant check
if addr entry_rname#"" start
if last=0 then last = entry
else
if last#0 start
addr entry2 == record(addr file conad+last*ad entry size)
addr entry = addr entry2
addr entry2 = 0
last = last-1
finish
finish
repeat
! Next collect names into new name table.
if last>0 start
cycle entry = 1, 1, last
addr entry == record(addr file conad+entry*ad entry size)
n table(entry)_rname = compress(addr entry_rname)
n table(entry)_soundex = entry
repeat
finish
cycle i = '[', -1, 'A'
startchar(i) = 0
repeat
name file_extrastart = 1
name file_extraend = last
ad file_entries = last
! Now check for newly accredited users
get av fsys(f, a)
zero = 0
cycle f = 0, 1, f-1
if pointers_discs(a(f))&2=0 start
printstring("Not updating fsys ".itos(a(f))." - not in config file".snl)
continue
else
log print(dt."Updating fsys ".itos(a(f)).snl)
finish
flag = get usnames2(nn, n, a(f))
if flag=0 start
j = 0
while j<n cycle
flag = dsfi(nn(j)_user, a(f), msg indicator, 1, addr(zero))
if flag#0 start
log print("DSFI43 fails for ".nn(j)_user.derrs(flag).snl)
finish
flag = dsfi(nn(j)_user, a(f), get sfi surname, 0, addr(sfisurname))
if nn(j)_user=mailer or nn(j)_user="SPOOLR" or nn(j)_user="VOLUMS" or nn(j)_user="JOBBER" then c
sfisurname = ""
if flag=0 start
if sfisurname#"" start
entry = lookup name(sfisurname)
if entry=not found start
flag = dpermission(nn(j)_user, "", "", "", a(f), get index list, permad)
if flag=0 start
if perm to mailer=yes start
flag = accredit name(sfisurname, "", this short host, nn(j)_user, sfioption, a(f),
secs now)
if flag#ok start
log print(" - accredit ".nn(j)_user." fails: ".err mess(flag).snl)
finish
else
log print(" - cant accredit ".nn(j)_user." no permission".snl)
finish
finish else printstring("Update - DPERM fails for ".nn(j)_user." ".derrs(flag).snl)
else ; !same user?
addr entry == record(addr file conad+entry*ad entry s ize)
if compress(addr entry_rname)=compress(sfisurname) and nn(j)_user=addr entry_managr and c
addr entry_fsys=a(f) and addr entry_server=this short host start
if addr entry_options=alias option then addr entry_options = sfi option
else
log print(" - cant accredit ".nn(j)_user." sname='".sfisurname."' same as ". c
addr entry_managr."@".addr entry_server.snl)
finish
finish
else
log print(" - cant accredit ".nn(j)_user." - null sname".snl)
finish
finish else printstring("Update - DSFI fails for ".nn(j)_user." ".derrs(flag).snl)
j = j+1
repeat
finish else printstring("Update - GETUS fails, fsys ".itos(a(f))." ".derrs(flag).snl)
repeat
! Now sort the name table.
cycle i = 1, 1, name file_extraend
n table(i)_soundex = i
repeat
table sort(name file_extraend)
! Set pointers (A -> Z+1) to partition the name table alphabetically
i = 1
cycle char = 'A', 1, '['
i = i+1 while i<=name file_extraend and char>charno(n table(i)_rname, 1)
startchar(char) = i
repeat
name file_extrastart = i
name file_datetime = current dt in secs
! Create new addrfile and move sorted entries into it.
! Then newgen both files.
size = ad entry size*(new max rnames+1)
create and connect("N".addrfile, myfsys, size, zerod!tempfi, r!w, new conad)
if new conad#0 start
new ad file == record(new conad)
new ad file_start = ad entry size
new ad file_end = size
new ad file_size = (size+epagesize-1)&(-epagesize)
next slot = newconad+ad entry size
flag = 0
cycle i = 1, 1, ad file_entries
unless 0<n table(i)_soundex<=ad file_entries then flag = 1 and exit
move(ad entry size, addr file conad+n table(i)_soundex*ad entry size, next slot)
sfisurname <- string(next slot)
n table(i)_soundex = soundex(sfisurname)
next slot = next slot+ad entry size
repeat
new ad file_entries = ad file_entries
new ad file_datetime = name file_datetime
finish else flag = 1
if flag=0 then flag = newgen or rename("N".snamefile, snamefile, name file conad)
if flag=0 then flag = newgen or rename("N".addrfile, addrfile, addr file conad)
if flag#0 start
mailer state = closed
printstring("Mailer closed".snl)
return
finish
ad file == record(addr file conad)
name file == record(name file conad)
n table == array(name file conad+name file header, name table arf)
startchar == name file_startchar
connect or create(myname, addrbackup, myfsys, ad file_end, cherish!zerod, new conad)
if new conad>0 start ; !make a backup copy
move(ad file_end, addr file conad, newconad)
flag = ddisconnect(myname, addrbackup, myfsys, 0)
finish
printstring("Tables updated".snl)
log print(dt."R-names accredited = ".itos(name file_extraend).snl)
mailer state = open
end ; !of update tables
integer fn newgen or rename(string (11) newfile, file, integer name conad)
integer seg, gap, flag, f
conad = 0
flag = ddisconnect(myname, newfile, myfsys, 0)
flag = ddisconnect(myname, file, myfsys, 0)
flag = dnewgen(myname, file, newfile, myfsys)
if flag#0 start
flag = drename(myname, newfile, file, myfsys)
if flag#0 start
printstring("Newgen/rename ".file." fails ".derrs(flag).snl)
result = flag
finish
finish
seg = 0; gap = 0
flag = dconnect(myname, file, myfsys, r!w!shared, apf, seg, gap)
if flag#0 then printstring("Connect ".file." fail ".derrs(flag).snl) else conad = seg<<18
f = dfstatus(myname, file, myfsys, setcherish, 0)
f = dfstatus(myname, file, myfsys, noarch, 0)
f = dpermission(myname, "", "", file, myfsys, 1, r)
result = flag
end ; !of newgen or rename
routine table sort(integer n)
integer i, j, ordered, save, an
byte integer array x(1:name entry size)
save = addr(x(1))
an = addr(n table(n))
cycle i = addr(n table(1)), name entry size, an-name entry size
move(name entry size, an, save)
ordered = yes
cycle j = an, -name entry size, i+name entry size
if string(j-name entry size)<string(save) start
move(name entry size, save, j)
move(name entry size, j-name entry size, save)
else
move(name entry size, j-name entry size, j)
ordered = no
finish
repeat
move(name entry size, save, i)
if ordered=yes then exit
repeat
i = i-addr(ntable(1))
i = i//nameentrysize
write(i, 4); newline
end ; !of table sort
routine connect tables
! Connects the ADDR and NAME files.
! If not found on the IPL disc, searches all other file systems
! for them and transfers them across.
integer seg, gap, fsys, flag, infoad, i
record (finff) info
seg = 0; gap = 0
addr file conad = 0
name file conad = 0
flag = dconnect(myname, addrfile, myfsys, r!w!shared, apf, seg, gap)
if seg#0 then addr file conad = seg<<18 else start
printstring("Connect ADDRFILE on IPL disc fails:".derrs(flag).snl)
if flag#does not exist then return
if pointers_discs(myfsys)&1=0 then c
printstring("Addrfile not transferable to non-service disc".snl) and return
infoad = addr(info)
cycle fsys = 0, 1, max fsys
if f systems(fsys)#0 start
flag = dfinfo(myname, addrfile, fsys, infoad)
if flag=0 start
flag = dtransfer(myname, myname, addrfile, addrfile, fsys, myfsys, 1)
if flag=0 start
printstring("ADDRFILE transferred from fsys ".itos(fsys).snl)
seg = 0; gap = 0
flag = dconnect(myname, addrfile, myfsys, r!w!shared, apf, seg, gap)
if flag=0 start
addr file conad = seg<<18
flag = dtransfer(myname, myname, snamefile, snamefile, fsys, myfsys, 1)
if flag=0 then printstring("NAMEFILE transferred from fsys ".itos(fsys).snl)
exit
else
printstring("Connect ADDRFILE fails:".derrs(flag).snl)
return
finish
finish else printstring("Dtransfer ADDRFILE fsys ".itos(fsys)." fails:".derrs(flag).snl)
finish
finish
repeat
finish
if addr file conad=0 then return
ad file == record(addr file conad)
i = (ad file_end//ad entry size)-1
if i>max rnames then max rnames = i
seg = 0; gap = 0
flag = dconnect(myname, snamefile, myfsys, r!w!shared, apf, seg, gap)
if seg#0 start
name file conad = seg<<18
name file == record(name file conad)
if name file_datetime#ad file_datetime start
printstring("Out of date NAMEFILE".snl)
name file_datetime = 0
name file conad = 0
else
n table == array(name file conad+name file header, name table arf)
startchar == name file_startchar
finish
finish else printstring("Connect NAMEFILE fails:".derrs(flag).snl)
end ; !of connect tables
routine delete junk(integer fsys spec)
! Deletes junk mail without notice to user or sender if older that
! "junk return period" (currently 7 days). So far only TRANSFER ok
! messages are junked but this may be extended!!
! In addition, returns SPOOLING and SPOOLED messages to sender
integer fsys, msg no, return date, flag
record (msg descriptor f) array name messages
record (msg descriptor f) array format msg af(1:max messages)
const string (15) junkname= "TRANSFER [ ok ]"
log print(dt."Delete junk, fsys ".itos(fsys spec).snl)
return date = current dt in secs
if return date<ad file_datetime then printstring("Invalid DT set".snl) and return
return date = return date-junk return period
cycle fsys = 0, 1, max fsys
if (fsys spec=-1 or fsys spec=fsys) and f systems(fsys)#0 start
messages == array(f systems(fsys)+message entry size, msg af)
cycle msg no = 1, 1, max messages
if messages(msg no)_dt sent<return date start
if messages(msg no)_status=sending and messages(msg no)_rname=junkname start
delete message(fsys<<24!msg no, flag)
delete message(messages(msg no)_recip link, flag)
finish
if messages(msg no)_status=spooled or messages(msg no)_status=spooling start
log print(dt."Message ".messages(msg no)_mess id." overdue spooling".snl)
return to sender(messages(msg no), flag, fsys<<24!msg no)
finish
finish
repeat
finish
repeat
end ; !of delete junk
routine move fsys(integer from fsys, to fsys)
! Moves message files and message descriptors from one disc to another
integer msg no, old ident, new ident, flag, next old, id
string (6) old file, new file
record (msg descriptor f) array name messages
record (msg descriptor f) array format msg af(1:max messages)
record (msg descriptor f) name new msg
if fsystems(from fsys)=0 or fsystems(to fsys)=0 start
printstring("Fails - fsys off-line!!".snl)
return
finish
messages == array(f systems(from fsys)+message entry size, msg af)
cycle msg no = 1, 1, max messages
old ident = from fsys<<24!msg no
old file = ident to s(old ident)
if sending#messages(msg no)_status#waiting then continue
new ident = get next descriptor(to fsys)
if new ident=0 then return
new file = ident to s(new ident)
new msg == record(message addr(new ident))
flag = dtransfer(myname, myname, old file, new file, from fsys, to fsys, 1)
if flag#0 start
printstring("Transfer ".old file." to ".new file." fails : ".derrs(flag).snl)
return
finish
new msg = messages(msg no); !copy contents
if messages(msg no)_status=sending start
next old = messages(msg no)_recip link&x'FFFFFF'
while next old#0 cycle
if messages(next old)_status=spooled then printstring("Cant move spooled msg ".old file.snl) else c
start
id = get next descriptor(to fsys)
if id=0 then return
new msg == record(message addr(id))
new msg = messages(next old); !copy contents
new msg_ident = new ident
finish
messages(next old)_status = unused
next old = messages(next old)_recip link&x'FFFFFF'
repeat
finish
messages(msg no)_status = unused; !fully moved
messages(msg no)_dt deleted = current dt in secs
log print(dt."Message ".messages(msg no)_mess id." moved from ".old file." to ".new file.snl)
repeat
printstring("Movefsys complete".snl)
end ; !of move fsys
routine tidy archive(integer fsys spec)
! Keeps the archive index under control by deleting old duplicates
record format archf(string (11) name, integer kbytes, string (8) date, string (6) tape,
integer chapter, flags)
const integer max= 1000
record (arch f) array arch(0:max-1)
integer filenum, maxrec, nfiles, fsys, i, j, flag
cycle fsys = 0, 1, maxfsys
if fsys spec=-1 or fsys=fsys spec start
if f systems(fsys)=0 then continue
filenum = 0; maxrec = max
flag = dfilenames(myname, arch, filenum, maxrec, nfiles, fsys, 2)
if flag=0 start
if maxrec>1 start
cycle i = 0, 1, maxrec-2
if arch(i)_name="" then continue
cycle j = i+1, 1, maxrec-1
if arch(i)_name=arch(j)_name start
flag = ddestroy(myname, arch(j)_name, arch(j)_date, fsys, 2)
log print(dt."Destroy BACK ".arch(j)_name." flag =".derrs(flag).snl)
arch(j)_name = ""
finish
repeat
repeat
finish
finish else printstring("Dfilenames fails: ".derrs(flag).snl)
finish
repeat
end ; !of tidy archive
routine killfsys(integer fsys)
! Deletes all messages sent to users on a given fsys and
! removes directory entries for the users.
record (addr entry f) name addr entry
record (msg descriptor f) name msg
record (msg descriptor f) array name messages
record (msg descriptor f) array format msg af(1:max messages)
integer i, link, msg no
if pointers_discs(fsys)&2#0 start
printstring("Killfsys refused - fsys ".itos(fsys)." is".snl."still present in config file".snl)
return
finish
cycle i = 1, 1, ad file_entries
addr entry == record(addr file conad+i*ad entry size)
if addr entry_fsys=fsys and addr entry_server=this short host start
link = addr entry_link
while link>0 cycle
msg == record(message addr(link))
msg_dt deleted = current dt in secs
msg_status = unused
log print(dt."Message ".msg_mess id." for ".addr entry_rname." removed at ".ident to s(link).snl)
link = msg_rname link
repeat
discredit entry(i)
finish
repeat
if fsystems(fsys)#0 start
messages == array(f systems(fsys)+message entry size, msg af)
cycle msg no = 1, 1, max messages
if messages(msg no)_status&sending#0 then delete message(fsys<<24!msg no, i)
repeat
finish else printstring("Fsys ".itos(fsys)." off-line for kill!!".snl)
end ; !of killfsys
routine create maillist(integer fsys)
record (fhf) name file header
integer caddr, file size, flag
string (11) file
string (2) sfsys
sfsys = i to s(fsys)
if f systems(fsys)=0 start ; !check if already open
file = "MAILLIST".sfsys
file size = message entry size*(max messages+1)
connect or create(my name, file, fsys, file size, zerod!cherish, caddr)
!connect or create
f systems(fsys) = caddr; !store connect address
unless caddr=0 start
file header == record(caddr)
if file header_end=file header_start start
!new file?
file header_end = file size
file header_free hole = 1
printstring("NEW MAIL LIST FSYS ".sfsys.snl)
flag = dpermission(myname, "DIRECT", "", "", fsys, 6, r)
printstring("Set index permission for DIRECT fails ".derrs(flag).snl) if flag#0
finish
finish else printstring("No MAIL LIST fsys ".sfsys.snl)
finish else printstring("Already open fsys ".sfsys.snl)
end ; !of routine create maillist
routine open file system(integer fsys)
! MAILER maintains a file index on each file system and this routine
! opens the files on the specified file system for use.
! When a file system is open the connect address of its MAILLIST file is
! placed in the array F SYSTEMS.
integer caddr, flag, seg, gap
string (11) file
string (2) sfsys
sfsys = i to s(fsys)
if f systems(fsys)=0 start ; !check if already open
file = "MAILLIST".sfsys
seg = 0; gap = 0
flag = dconnect(myname, file, fsys, r!w!shared, 0, seg, gap)
caddr = seg<<18
if caddr>0 then f systems(fsys) = caddr else c
printstring("Connect MAILLIST fsys ".sfsys." fails ".derrs(flag).snl)
finish else printstring("Already open fsys ".sfsys.snl)
end ; !of routine open file system
routine close file system(integer fsys)
! Notified by Director that a file system is closing, this
! routine disconnects the MAILLIST files on all closing fsys
! then relinks the message descriptors.
integer f, k, n, flag
string (11) file
integer array a(0:max fsys)
if f systems(fsys)=0 then return ; !already closed
get av fsys(n, a)
n = n-1
cycle f = 0, 1, maxfsys
if f systems(f)=0 then continue
cycle k = 0, 1, n
if a(k)=f then exit
if k=n start ; !not available
file = "MAILLIST".itos(f)
flag = ddisconnect(myname, file, f, 0)
f systems(f) = 0
log print(dt."Ddisconnect ".myname.".".file." flag = ".derrs(flag).snl)
finish
repeat
repeat
if mailer state=open then check descriptors(-1)
end ; !of close file system
routine initialise
! Sets up global variables, tables and lists
! and connects files used by MAILER on the on-line file systems.
integer i, j, k
integer array a(0:max fsys); !used to store fsys nos suplied by director
record (pe) p
com == record(acomf)
date == string(addr(com_date0)+3)
time == string(addr(com_time0)+3)
e page size = com_e page size<<10; !extended page size in bytes
monitoring = 6
max rnames = default max rnames
after linkhead = 0
report fsys = my fsys
last fsys = 0
ad l to u trans = com_trans+512
cycle i = 0, 1, max reply index
spool reply index(i) = 0
repeat
top spoolr reply = 0
cycle i = 0, 1, max fsys
f systems(i) = 0; !mark all files as not connected
repeat
get av fsys(j, a); !get list of available f systems
i = 0
while i<j cycle
open file system(a(i)); !open currently on line file systems
k = change context
i = i+1
repeat
rtable == array(rtable conad, rtable arf)
k = (charno(date, 7)-'0')*10+charno(date, 8)-'0'
i = get fourth sunday(3, k); !in march
j = get fourth sunday(10, k); !in october
if i<=current dt in secs<j then time zone = "bst" else time zone = "gmt"
dbconad = 0
connect dbfile(i)
connect tables
if addr file conad=0 start
mailer state = closed
printstring("MAILER closed".tostring(17).snl)
return
finish
config conad = 0; current configfile = ""
i = connect config file("")
if i#0 then i = connect configfile(myname.".".confbackup)
if i#0 start
mailer state = closed
printstring("Mailer closed!!".tostring(17).snl)
else
mailer state = open
if name file conad=0 then update tables
finish
if mailer state=open start
check descriptors(-1)
p = 0; !kick spoolr for my stream
p_dest = return file ack
mail queue(p)
finish
end ; !of routine initialise
end
end of file