const string (11) configoutfile="DBOUT"
external routine make db file(string (255) file)
!Reads a text file containing bulletin board and distribution list details
!for MAILER. If no errors are found, creates file DBOUT which can be given
!to MAILER using the command GIVEDBFILE. Both programs can only be run in the
!BBOARD process which requires ACR=10 and privileges 8, 18, 25
const integer max servers= 255
const integer max messages= 2000; !IN ANY ONE FOLDER
const integer yes=1, no=0
const integer ad entry size= 128
const integer btable entry size=108
const integer dlist type=3
const integer bboard type=4
const integer max bboards=255
const integer max dlists=255
const integer dlist entry size=40
const integer folder marker=x'82828282'
const integer default max msgs=128
const integer default fsize=4096
const integer max mailer flags= 530
const string (18) serv file= "MAILER.MAILSERVERS"
const string (6) bboard process="BBOARD"
const string (81) jobtext= c
".whenever anyfail .then .continue
run(bboard.db_useraccy)
run bboard.db_useraccy
"
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 comf(integer ocp type, ipldev, sblks, sepgs, ndiscs, ddtaddr, gpctabsize, gpca, sfctabsize,
sfca, sfck, dirsite, dcodeda, suplvn)
record format btablef(string (31) bname, title, string (18) folder, byte integer sp0, half integer maxmsgs,
maxdays, n msgs, sp1, integer dt last addition, sp2, sp3, sp4)
record format dtablef(string (31) dname, integer offset, length)
record (dtablef) array format dtable arf(1:max dlists)
record format ff(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))
record format paf(integer dest, srce, flag, message count, secs, ident, bad bitcomp, p6)
record format rf(integer conad, filetype, datastart, dataend)
record format serv f(string (15) name, integer sp0, sp1, sp2)
record format serv ff(integer mark, servers, string (15) authority, string (31) dead letters,
record (serv f) array serv(1:max servers))
record format f index f(integer dt, (integer offset or byte integer status, x1, x2, x3))
record format folder f(integer end, start, size, filetype, checksum, datetime, format, spare, marker,
max msgs, n msgs, sp0, record (f index f) array msg no(1:max messages))
record (btablef) array btab(1:max bboards)
record (dtablef) array name dtab
system routine spec changefilesize(string (31) file, integer newsize, integer name flag)
external routine spec cherish(string (255) s)
system routine spec connect(string (31) file, integer mode, hole, prot, record (rf) name r,
integer name flag)
external routine spec define(string (255) s)
external string fn spec derrs(integer flag)
external integer fn spec dfstatus(string (6) user, string (11) file, c
integer fsys, act, value)
external routine spec disconnect(string (255) s)
external integer fn spec dmail(record (paf) name p, integer len, adr)
external integer fn spec exist(string (31) s)
system string fn spec failure message(integer i)
system string fn spec itos(integer n)
system routine spec move(integer len, from, to)
system routine spec outfile(string (31) file, integer size, hole, prot, integer name conad, flag)
external routine spec permit(string (255) s)
system integer fn spec pstoi(string name s)
external string fn spec ucstring(string (255) s)
external string fn spec uinfs(integer i)
routine spec fail(string (255) reason)
integer i, b, lineno, flag, addr file conad, dlists, pt, boards
integer conad, d
string (255) rest, line, s, matchstring, rname
string (31) this host
record (paf) pa
record (addr entry f) name addr entry
record (comf) name com
record (serv ff) name server
record (ff) name f
record (rf) r
const string (1) snl="
"
const string (28) array mailer flags(501:max mailer flags)= c
"Invalid parameters",
"Duplicate component:",
"Unknown component",
"Invalid command",
"No valid recipients",
"Too many recipients",
"Addr table full",
"Name table full",
"Illegal name",
"Mail service closed",
"Recipient offline",
"Message too long",
"",
"Missing component:",
"No free message descriptors",
"Invalid component:",
"Total message kb exceeded",
"Cannot return report file",
"Message stored",
"Forbidden component",
"Create file fails",
"User not accredited",
"Invalid password",
"Name not accredited",
"Name already accredited",
"Name belongs to another user",
"Uncollected mail for R-name",
"Invalid date/time after",
"Not allowed in student procs",
"Invalid Rname option"
on event 9 start
fail("input ended")
finish
routine leadtrail(string name s)
length(s) = length(s)-1 while length(s)>0 and charno(s, length(s))=' '
s = substring(s, 2, length(s)) while length(s)>1 and charno(s, 1)=' '
end ; !of leadtrail
routine readline
integer i
lineno = lineno+1
skipsymbol while next symbol=' '
line = ""
cycle
readsymbol(i)
if i=nl then exit
line = line.tostring(i)
repeat
if line->line.("!") start ; finish
leadtrail(line)
if line="" then readline
end ; !of readline
string fn compress(string (255) s)
integer i
string (255) t
if s="" then result = ""
for i = 1, 1, length(s) cycle
if 'A'<=charno(s, i)<='Z' then charno(s, i) = charno(s, i)+32
repeat
s = s.t while s->s.(" ").t
result = s
end ; !of compress
string fn uccompress(string (255) s)
string (255) t
s = s.t while s->s.(" ").t
result = ucstring(s)
end ; !of uccompress
routine check rname(string (31) rname, integer type, string (31) dept, integer level)
string (255) s, stype
integer flag
s = "NAMESERVER INQUIRE ".rname
pa = 0
flag = dmail(pa, length(s), addr(s)+1)
if flag>0 start ; !name found
if level=1 then return ; !no check on ownership
addr entry == record(addr file conad+flag*ad entry size)
if uccompress(rname)#uccompress(addr entry_rname) then fail("whoops!")
if addr entry_managr#bboard process then c
fail(rname." belong to ".addr entry_managr." instead of ".bboard process)
if level=3 and addr entry_server#this host then fail(rname." belong to another host, ".addr entry_server)
if addr entry_options#type then fail(rname." has wrong type in dir entry, ".itos(addr entry_options))
return ; !all checking done
finish ; !name not found
if level=1 then printstring("Warning - ".rname." not accredited".snl) and return
if type=bboard type then stype = "BBOARD" else stype = "DLIST"
s = "NAMESERVER ACCREDIT ".rname.",".stype.",,".dept
pa = 0
flag = dmail(pa, length(s), addr(s)+1)
printstring("Accredit ".stype." ".rname." ")
if pa_flag#0 start
if pa_flag>500 then printstring(mailer flags(pa_flag)) else printstring(derrs(pa_flag))
finish else printstring("successful")
newline
end ; !of check rname
routine fail(string (255) reason)
printstring("Fails on : ".matchstring." (line ".itos(lineno).")".snl." - ".reason.snl)
stop
end ; !of fail
string fn next
string (255) res
if line="" then fail("should be 'name='")
cycle
if line->res.(",").line start
leadtrail(line)
if line="" then readline
finish else res = line and line = ""
leadtrail(res)
matchstring = res
result = res
repeat
end ; !of next
routine match(string (31) item)
string (255) param
readline
matchstring = line; !in case of errors
unless matchstring->param.("=").line and compress(param)=item then fail("should be '".item."='")
leadtrail(line)
end ; !of match
integer fn check item(string (31) item, integer size)
integer i
match(item)
if size>0 start
if length(line)>size then fail("too long") else result = 1
finish
i = pstoi(line)
unless 0<=i<=(-size) then fail("bad numeric value")
result = i
end ; !of check item
routine noarchive(string (255) file)
integer flag
string (255) s
if file -> s.(".").file start ; finish
flag=dfstatus(uinfs(1),uccompress(file),-1,17,0)
end ;!of noarchive
routine check or create folder(string (255) file)
record (folder f) name cf
integer flag, conad
connect(file, 0, 0, 0, r, flag)
if flag=0 start
if integer(r_conad+32)#folder marker then fail(file." is not a folder")
noarchive(file)
finish else start
if exist(file)#0 then fail(failure message(flag))
outfile(file, default fsize, 0, 0, conad, flag)
if flag=0 start
cf == record(conad)
cf_end = addr(cf_msg no(default max msgs))-conad+8
cf_start = cf_end
cf_size = default fsize
cf_filetype = 4
cf_format = 3; !UNSTRUCTURED
cf_marker = folder marker
cf_max msgs = default max msgs
cf_n msgs = 0
printstring("Folder ".file." created".snl)
cherish(file)
noarchive(file)
finish else start
fail("Create folder ".file." fails ".failure message(flag).snl)
finish
finish
end ; !of check folder
routine last message details(string (31) file, integer bno)
record (folder f) name cf
integer flag, conad, dt
connect(file, 1, 0, 0, r, flag)
if flag=0 start
cf == record(r_conad)
if cf_n msgs>0 then dt = cf_msg no(cf_n msgs)_dt else dt=0
btab(bno)_dt last addition = dt
btab(bno)_n msgs = cf_n msgs
disconnect(file)
finish else fail(failure message(flag))
end
routine check size(integer newsize)
integer flag
newsize = (newsize+4095)//4096
if newsize<=f_size then return
changefilesize(configoutfile, newsize, flag)
if flag#0 then fail(failure message(flag))
f_size = newsize
end ; !of check size
string fn reduce rname(string (255) rname)
integer i
string (255) s
rname = uccompress(rname)
s = ""
if length(rname)>0 start
for i = 1, 1, length(rname) cycle
if 'A'<=charno(rname, i)<='Z' or '0'<=charno(rname, i)<='9' then s = s.tostring(charno(rname, i))
repeat
finish
result = s
end ; !of reduce rname
routine set permission(string (255) s)
integer i
string (31) mode
unless s->s.("/").mode then mode = ""
unless length(s)=6 then fail("invalid username")
for i = 1, 1, 6 cycle
unless 'A'<=charno(s, i)<='Z' or charno(s, i)='?' then fail("invalid username")
repeat
permit(btab(b)_folder.",".s.",".mode)
end ; !of set permission
if uinfs(1)#"BBOARD" then printstring("Warning - not in BBOARD process".snl)
lineno = 0
matchstring = "initialisation"
define("1,".file)
selectinput(1); !make sure input file is there
com == record(x'80000000'+48<<18); !for finding ipl fsys
connect("MAILER.ADDRFILE", 9, 0, (com_suplvn<<8)!x'80', r, flag)
if flag#0 then fail("cant connect addrfile: ".failure message(flag))
addr file conad = r_conad; !required for looking up rnames
connect(servfile, 9, 0, 0, r, flag)
if flag#0 then fail("cant connect servfile: ".failure message(flag))
server == record(r_conad+r_datastart)
this host = server_serv(1)_name
noarchive("ERRORF")
noarchive("DB")
noarchive("USERACC")
outfile(configoutfile, 4096*2, 0, 0, conad, flag)
if flag#0 then fail(failure message(flag))
f == record(conad)
f_jobtext = jobtext
f_bowner = bboard process
boards = check item("bboards", -max bboards); !read bboard details
f_n boards = boards
if boards>0 start
for b = 1, 1, boards cycle
i = check item("title", 31)
btab(b)_title = line
i = check item("name", 255)
unless line->rname.("@").rest then fail("missing '@'")
unless uccompress(rest)=server_authority then fail("cant accredit 'bboard@elsewhere'!")
if rname->rname.("*").s start
s = this host
btab(b)_dt last addition = 1
finish else start
s = ""
btab(b)_dt last addition = 0
finish
leadtrail(rname)
btab(b)_bname = rname
rname = rname.s
check rname(rname, bboard type, btab(b)_title, 3)
btab(b)_maxmsgs = check item("maxmsgs", -2000)
btab(b)_maxdays = check item("maxdays", -365)
i = check item("folder", 18)
btab(b)_folder = bboard process.".".uccompress(line)
check or create folder(btab(b)_folder)
i = check item("permit", 255)
until line="" cycle
s = next
if s="" then continue
set permission(uccompress(s))
repeat
repeat
finish
dtab == array(addr(f_dtab(1)), dtable arf); !read dtab details
dlists = check item("dlists", -max dlists)
f_n dlists = dlists
pt = addr(f_dtab(1))+dlists*dlist entry size
if dlists>0 start
for d = 1, 1, dlists cycle
checksize(pt+4096); !make sure we have room for list
i = check item("title", 31)
s = line; !save it for now
i = check item("name", 31)
unless line->rname.("@").rest then fail("missing '@'")
unless uccompress(rest)=server_authority then fail("cant accredit 'dlist@elsewhere'!")
leadtrail(rname)
check rname(rname, dlist type, s, 2)
dtab(d)_dname = reduce rname(rname)
i = check item("list", 255)
dtab(d)_offset = pt+1-conad
until line="" cycle ; !take each name in turn
rname = next
if rname="" then continue
unless rname->s.("@").rest then fail("missing '@'")
leadtrail(s); leadtrail(rest)
rest = uccompress(rest)
if rest=server_authority then check rname(s, 0, "", 1) else start
for i = 1, 1, server_servers cycle
if server_serv(i)_name=rest then exit
if i=server_servers then fail("host ".rest." not known")
repeat
finish
string(pt) = rname
i = pt
pt = pt+byteinteger(pt)+1
byteinteger(i) = ','
repeat
dtab(d)_length = pt-dtab(d)_offset-conad
if dtab(d)_length=0 then fail("empty list")
repeat
finish else pt = addr(dtab(1))
if boards>0 start ; !check consistency
matchstring = "end"; !in case of error
for b = 1, 1, boards cycle
if btab(b)_dt last addition=1 start
btab(b)_dt last addition = 0
d = dlists
s = reduce rname(btab(b)_bname)
while d#0 cycle
if s=dtab(d)_dname then exit
d = d-1
repeat
if d=0 then fail("missing dlist for bboard ".btab(b)_bname)
finish
last message details(btab(b)_folder, b)
repeat
finish
f_board offset = (pt-conad+3)&x'fffffffc'; !round up to word
i = f_n boards*btable entry size
f_end = f_board offset+i
checksize(f_end)
if f_n boards>0 then move(i, addr(btab(1)), f_board offset+conad)
disconnect(".ALL")
end ; !of make db file
external routine give dbfile(string (255) null)
!Gives a new distribution list/bulletin board file to MAILER and tells it
!to start using it.
const integer take dbfile=28; !mailer service
const integer pon and suspend=7
const integer sync1 type=1
integer flag
const string (6) mailer="MAILER"
const string (1) snl="
"
record format comf(integer ocp type, ipldev, sblks, sepgs, ndiscs, ddtaddr, gpctabsize, gpca, sfctabsize,
sfca, sfck, dirsite, dcodeda, suplvn)
record format pe(integer dest, srce, p1, p2, p3, p4, p5, p6)
record (pe) p
external string fn spec derrs(integer flag)
external integer fn spec dpon2(string (6) user, record (pe) name p, integer msgtype, outno)
external integer fn spec dtransfer(string (6) user1, user2, string (11) file, newname, integer fsys1,
fsys2, type)
external integer fn spec ddestroy(string (6) user, string (11) file, string (8) date, integer fsys, type)
system routine spec disconnect(string (255) s, integer name flag)
external integer fn spec uinfi(integer i)
external string fn spec uinfs(integer i)
record (comf) name com
disconnect(configoutfile, flag); !ignore flag
com == record(x'80000000'+48<<18)
flag = ddestroy(mailer, configoutfile, "", com_suplvn, 0); !ignore flag
flag = dtransfer(uinfs(1), mailer, configoutfile, configoutfile, uinfi(1), com_suplvn, 1)
if flag#0 then printstring("Transfer fails : ".derrs(flag).snl) and return
p = 0
p_dest = take dbfile!x'ffff0000'
flag = dpon2(mailer, p, sync1 type, pon and suspend)
if flag#0 then printstring("DPON fails : ".derrs(flag).snl) and return
printstring("Flag = ".derrs(p_p1).snl)
end ; !of give dbfile
end of file