!! Mail Interface
!! Version 4c
const integer yes= 1
const integer no= 0
const integer xa=1, non xa=2 {2900=2900}
const integer target=2900
const integer ssmp possible=0
const integer kent= 1
const integer max components= 30
const integer distinct components= 18
const integer max folders= 16; !OPEN AT ONE TIME
const integer max messages= 2000; !IN ANY ONE FOLDER
const integer max msg size= 256<<10; ! 256K
const integer max mailer flags= 530
const integer pf max= 201; !FOR DFILENAMES
const integer default messages= 128; !WHEN A FOLDER IS CREATED
const integer max fsys=99; !for 'pointers' record
const integer max hash length= 16384; !for 'pointers' record
const integer name entry size= 36
const integer ad entry size= 128
const integer max rnames= 10000
const integer max bboards=255
const integer max bb entries=50
const integer max dlists=255
const integer max addrfile options=4
const integer not bboard type=-1
const integer name file header= 160
const integer epage size= 4096
const integer default folder size= epage size
const string (7) default folder= "M#INBOX"
const integer offset mask= X'FFFFFF'
const integer marker= x'82828282'; !VERIFIES FILE IS A FOLDER
const integer p marker= x'84848484'; !VERIFIES FILE IS A PROFILE FILE
const integer read write= 3; !CONNECT MODE
const integer read shared= b'1001'; !CONNECT MODE
const integer sfioption= b'00000001'; !SET IF ADDR TABLE ENTRY = SFI SURNAME
const integer tempfile= x'40000000'; !CREATE MODE
const integer char filetype= 3
const integer data filetype= 4
const integer em= 25
const integer msg indicator= 43; !DSFI ENTRY
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
if target=2900 start
const string (1) usep="."
else
const string (1) usep=":"
finish
const string (9) profile file= "M#PROFILE"
const string (31) helpfile= "MAILHELP"
const string (6) hfileowner="SUBSYS"
const string (7) workfile= "M#WORK"
const string (8) addrfile= "ADDRFILE"
const string (8) snamefile= "NAMEFIL"
const string (6) dbfile="DBFILE"
const string (12) configfile="CFILE"
const string (6) confileowner="FTRANS"
const string (5) op prompt= "Mail:"
if kent=0 start
const integer max ops= 35
const string (9) array op names(1:max ops)= c
"ACCEPT","ACCREDIT","ALIAS","BBOARD","BBCANCEL","COMPOSE","COPY","DIRECTORY",
"DISCARD","DISCREDIT","DN","ECCE","EDIT","FILE",
"FORWARD","GOTO","HELP"," INQUIRE","LIST","NEXT","OPEN","OUTPUT","POST",
"PREVIOUS","PROFILE","QUIT",
"REPLY","RETRIEVE"," REVOKE","SCAN","SEND","STOP"," SYNTAX","TIDY","VEDIT"
else
const integer max ops= 37
const string (9) array op names(1:max ops)= c
"ACCEPT","ACCREDIT","ALIAS","BBOARD","BBCANCEL","CHEF","COMPOSE","COPY",
"DIRECTORY","DISCARD","DISCREDIT","DN",
"ECCE","EDIT","EM","FILE","FORWARD","GOTO","HELP"," INQUIRE","LIST","NEXT",
"OPEN","OUTPUT","POST",
"PREVIOUS","PROFILE","QUIT","REPLY","RETRIEVE"," REVOKE","SCAN","SEND",
"STOP"," SYNTAX","TIDY","VEDIT"
finish
const integer accept= 1,accredit = accept+1,alias = accredit+1,
bboard=alias+1, bbcancel = bboard+1
if kent=0 start
const integer compose= bbcancel+1
else
const integer zchef= bbcancel+1,compose = zchef+1
finish
const integer zcopy= compose+1
const integer directory= zcopy+1,discard = directory+1
const integer discredit= discard+1,dn = discredit+1
const integer zecce= dn+1,zedit = zecce+1
if kent=0 start
const integer file= zedit+1
else
const integer zem= zedit+1,file = zem+1
finish
const integer forward= file+1,goto = forward+1
const integer help= goto+1,inquire = help+1
const integer zlist= inquire+1,next = zlist+1
const integer open= next+1,zoutput = open+1,post = zoutput+1
const integer previous= post+1,profile = previous+1,quit = profile+1,
reply = quit+1
const integer retrieve= reply+1,revoke = retrieve+1
const integer scan= revoke+1,send = scan+1
const integer stop= send+1,syntax = stop+1,tidy = syntax+1
const integer v editor= tidy+1
const integer emas call= -1
const integer unknown command= 0
const integer other editor= file
!! MESSAGE COMPONENTS
const string (16) array component name(1:max components)= "
"{snl}, "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", "",
"", "", "", "", ""
!! For display to user
const string (13) array lc comp name(1:max components)= c
"Text: ","Subject: ","From: ","Date: ","Msg ID: ","To: ","cc: ","bcc: ",
"Sender: ","After: ",
"In reply to: ","Reply to: ","Keywords: ","Folder: ",
"References: ","Comments: ","Ack to: ","Via: ","Via: ","Via: ","Via: ",
"Via: ","Via: ",
"","","","","","",""
!! 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,reply to = 12,keywords = 13,folder = 14
const integer references= 15,comments = 16,ackto = 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
!! For checking user input
const string (11) array uc comp name(1:distinct components)= c
"TEXT","SUBJECT","FROM","DATE","MSGID","TO","CC","BCC","SENDER","AFTER",
"INREPLYTO","REPLYTO","KEYWORDS","FOLDER",
"REFERENCES","COMMENTS","ACKTO","VIA"
!! Order of components within a message
const integer array order(2:max components)= c
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 array prompt order(1:distinct components)= c
cdate, from, sender, to, cc,
bcc,reply to,subject,comments, mess id, in reply to, references, keywords,
folder,
ack to,via, after, body
const long integer recip comps= 1<<to!1<<cc!1<<bcc
const long integer text comps= 1<<body!1<<comments
const long integer any vias= 1<<via!1<<via2!1<<via3!1<<via4!1<<via5!1<<via6
const long integer any user= 1<<user1!1<<user2!1<<user3!1<<user4!1<<user5!1<<user6
const long integer limit amount listed= ~(1<<messid!1<<inreplyto!any vias!any user)
const long integer valid local comp=~(1<<c date!1<<source key!1<<mess id!1<<se c
nder!any vias)
const long integer one=1
const string (5) drstring= "DRAFT"
const string (3) yes string= "YES"
const string (2) no string= "NO"
const string (3) all string= "ALL"
const string (5) nullstring= ".NULL"
const string (7) fold string= ".FOLDER"
const string (1) snl= "
"
const integer bad access= 303; !SS FLAG
const integer invalid filetype= 267; !SS FLAG
const integer too many files= 309; !SS FLAG
!! MAILER FLAGS
const integer error report= 513
const integer no to students= 529
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"
record format c tab f(integer beg, len)
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, accpend, marker, max msgs,
n msgs, sp0, record (f index f) array msg no(1:max messages))
record format frecf(string (11) name, integer sp12, kbytes, byte integer arch, codes, cct, ownp, eep, codes2,
ssbyte, flags, sp29, sp30, sp31)
record format mail file f(integer end, start, size, type, free hole, datetime, sp0, version,
long integer bitcomp, record (c tab f) array cp(1:max components))
record format m structure f(integer marker, length, dt, sp0, long integer bitcomp,
record (ctabf) array c(1:max components))
record format paf(integer dest, srce, flag, message count, secs, ident, bad bitcomp, p6)
record format rf(integer conad, filetype, datastart, dataend)
record format pf(integer end, start, size, filetype, checksum, datetime, format, spare, marker, version,
list size, alias head, free list, string (15) v editor, string (79) accept, byte integer l list console,
l list file, autofile, autoaccept, overwrite, return new, b1, b2)
record format af(integer link, alink, string (23) name)
record format vf(integer link, string (27) name)
record format ad file f(integer end, start, size, type, free hole, datetime, entries, version, anon 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 dtablef(string (31) dname, integer offset, length)
record format db f(integer end, start, size, filetype, sp0, dt, format, sp1, string (6) bowner,
integer n boards, n dlists, bboard offset, sp2, string (255) jobtext,
record (dtablef) array dtab(1:max dlists))
record format prb f(string (31) bname, integer dt last)
record format pr bb f(integer no, record (prb f) array entry(1:max bb entries))
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, station, 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:max hash length)} integer hash start)
if target=2900 start
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)
else
record format btablef(string (31) bname, title, string (18) folder, byte integer sp0,
short integer maxmsgs, maxdays, n msgs, sp1, integer dt last addition, sp2, sp3, sp4)
finish
if target=2900 start
external routine spec call(string (31) entry, string (255) param)
external routine spec cherish(string (255) s)
external routine spec clear(string (255) s)
external routine spec connect alias "S#CONNECT"(string (31) file, integer mode, hole, prot,
record (rf) name r, integer name flag)
external routine spec define(string (255) s)
external routine spec definfo(integer chan, string name file, integer name stat)
external routine spec destroy alias "S#DESTROY"(string (31) file, integer name flag)
external integer fn spec devcode alias "S#DEVCODE"(string (16) s)
external routine spec disconnect alias "S#DISCONNECT"(string (31) file, integer name flag)
dynamic routine spec ecce(string (255) s)
dynamic routine spec edit(string (255) s)
external routine spec fill alias "S#FILL"(integer len, from, filler)
external integer fn spec exist(string (31) file)
external string fn spec failure message alias "S#FAILUREMESSAGE"(integer i)
external integer fn spec instream
external integer fn spec iocp alias "S#IOCP"(integer ep, param)
external string fn spec itos alias "S#ITOS"(integer n)
external routine spec move alias "S#MOVE"(integer len, from, to)
external routine spec newgen alias "S#NEWGEN"(string (31) file, newfile, integer name flag)
external routine spec outfile alias "S#OUTFILE"(string (31) file, integer size, hole, prot,
integer name conad, flag)
external integer fn spec outpos
external integer fn spec outstream
external routine spec prompt(string (15) s)
external integer fn spec pstoi alias "S#PSTOI"(string name s)
external routine spec psysmes alias "S#PSYSMES"(integer root, flag)
external routine spec read profile(string (11) key, name info, integer name version, flag)
external integer fn spec returncode
external routine spec setfname alias "S#SETFNAME"(string (40) name)
external routine spec setreturncode(integer i)
external routine spec terminate
external string fn spec ucstring(string (255) s)
external routine spec uctranslate alias "S#UCTRANSLATE"(integer addr, length)
external string fn spec uinfs(integer entry)
external integer fn spec uinfi(integer entry)
external routine spec write profile(string (11) key, name info, integer name version, flag)
dynamic routine spec zview alias "S#ZVIEW"(string (255) s)
else
external routine spec call(string name command, param)
external routine spec cherish(string (255) name)
external routine spec clear(string (255) s)
record format chdrform(integer conad, filetype, datastart, dataend)
routine connect(string (31) s, integer a, m, p, record (chdrform) name r, integer name f)
external routine spec proc alias "S#CONNECT"(string name s, integer name a, m, p, r1, r2, r3, r4, flag)
proc(s, a, m, p, r_conad, r_filetype, r_datastart, r_dataend, f)
end ; ! Of %routine connect.
external routine spec define(string (255) s)
external routine spec definfo(integer chan, string name file, integer name status)
external routine spec destroy alias "S#DESTROY"(string name nfile, integer name flag)
external integer function spec devcode alias "S#DEVCODE"(string (16) device)
external routine spec disconnect alias "S#DISCONNECT"(string name nfile, integer name flag)
dynamic routine spec ecce(string (255) s)
dynamic routine spec edit(string (255) s)
external routine spec fill alias "S#FILL"(integer name nlength, nfrom, nfiller)
external integer function spec exist(string name nfile)
string function failuremessage(integer type)
external routine spec proc alias "S#FAILUREMESSAGE"(integer name nmess, string name fmst)
string (255) fmst
proc(type, fmst)
result = fmst
end ; ! Of %string %function failure message.
external integer fn spec instream
external integer fn spec iocp alias "S#IOCP"(integer ep, param)
string function itos(integer n)
external routine spec proc alias "S#ITOS"(integer name nn, string name nst)
string (20) nst
proc(n, nst)
result = nst
end ; ! Of %string %function itos.
external routine spec move alias "S#MOVE"(integer name nlength, nfrom, nto)
external routine spec newgen alias "S#NEWGEN"(string name nfile, nnewfile, integer name flag)
external routine spec outfile alias "S#OUTFILE"(string name nfile, integer name nfilesize, nhole, nprot,
conad, flag)
external integer function spec outpos
external integer fn spec outstream
external routine spec prompt(string (255) s)
external integer function spec pstoi alias "S#PSTOI"(string name s)
external routine spec psysmes alias "S#PSYSMES"(integer root, flag)
external routine spec read profile(string name key, name info, integer name version, flag)
external integer fn spec returncode
external routine spec setfname alias "S#SETFNAME"(string name name)
external routine spec set return code(integer name n)
external routine spec terminate
external string fn spec ucstring(string name s)
external routine spec uctranslate alias "S#UCTRANSLATE"(integer name naddr, nl)
string function uinfs(integer entry)
external routine spec proc alias "UINFS"(integer name entry, string name nv)
string (255) temp
proc(entry, temp)
result = temp
end ; ! Of %string %function uinfs.
external integer function spec uinfi(integer name entry)
external routine spec write profile(string name key, name info, integer name version, flag)
dynamic routine spec zview alias "S#ZVIEW"(string (255) s)
finish
string fn myucstring(string (255) s); !!!temp routine till bug is fixed
result = ucstring(s)
end
if target=2900 start
external integer fn spec dfilenames(string (6) user, record (frecf) array name inf,
integer name filenum, maxrec, nfiles, integer fsys, type)
external string fn spec derrs(integer flag)
external integer fn spec dfstatus(string (6) user, string (11) file, integer fsys, act, value)
external integer fn spec dmail(record (paf) name p, integer len, adr)
external integer fn spec dchsize(string (6) user, string (11) file, integer fsys, newsize)
external integer fn spec dpermission(string (6) owner, user, string (8) date, string (11) file,
integer fsys, type, adrprm)
external integer fn spec dsfi(string (6) user, integer fsys, type, set, address)
else
external integer fn spec dchsize(string name file index, file, integer name fsys, nkb)
external integer fn spec dfilenames(string name group, integer name fileno, maxrec, nfiles, fsys, type,
record (frecf) array name inf)
external integer fn spec dflag(integer name flag, string name txt)
external integer fn spec dfstatus(string name file index, file, integer name fsys, act, value)
external integer fn spec dmail(record (paf) name p, integer name len, adr)
external integer fn spec dmove to file(integer name len, from, to)
external integer fn spec dpermission(string name file index, user, date, file, integer name fsys, type,
adr)
external integer fn spec dsfi(string name file index, integer name fsys, type, set, string name s,
integer array name i)
external string fn derrs(integer flag)
string (255) text
integer f
f = dflag(flag, text)
result = text
end ; !of derrs
finish
if target=2900 start
record format comf(integer ocptype, 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, resv2, 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)
const record (comf) name com= x'80000000'+48<<18
else
record format comf(integer ocptype, slipl, tops, sepgs, ndiscs, nsldevs, dlvnaddr, ditaddr, sldevtabad,
steer int, dirsite, dcodeda, suplvn, tojday, date0, date1, date2, time0, time1, time2, pagesize, users,
cattad, servaad, nocps, itint, ration, trans, long integer kmon, integer supvsn, secsfrmn, secstocd,
sync1dest, sync2dest, asyncdest, maxprocs, inspersec, elaphead, commsreca, storeaad, procaad, tslice, feps,
maxcbt, performad, curproc, inptr, outptr, parm asla, kernelqa, runq1a, runq2a, channelq, end)
if target=xa start
const integer seg shift=20; !31 bit addressing, 1024k segment
else
const integer seg shift=16; !24 bit addressing, 64k segment
finish
const record (comf) name com=31<<seg shift
finish
if kent#0 start
dynamic routine spec chef(string (255) s)
dynamic routine spec zm alias "EM"(string (255) s)
finish
if ssmp possible=yes start
const integer noscroll= 1<<26
const integer freeze= 1<<27
const integer breaktext=1<<28
const integer unset=1<<31; !to remove a mode setting
record format frameinfo(byte integer top, rows, left, cols, row, col, integer mode)
external routine spec sp show frame(integer chan, record (frameinfo) name f)
external routine spec sp setmode(integer mode)
external routine spec startssmp(string (255) s)
external integer fn spec sp new frame(integer top, rows, left, cols)
external routine spec sp set cursor(integer row, col)
external routine spec sp clear frame
external routine spec sp clear line
external routine spec sp scroll(integer first, last, n)
external routine spec sp set tabs(integer array name tabs)
external routine spec sp set shade(integer s)
external routine spec sp lineedit(string (255) s)
finish
external routine mail(string (255) s)
integer current msg, current folder, fconad, i, folders open, dconad
integer flag, t conad, myfsys, dest f, temp mno
integer fn, j, count, this f, sec f, offset, plus dashes, save outstream, secs now
integer pconad, llist console, llist file, list limit
integer addr file conad, name file conad, save instream, db conad
integer return new, bb access, bbpointer, ftype, xreturn code, k, save dbitcomp
integer config conad, started, to terminal, termtype
long integer dbitcomp
string (6) myprocess
string (31) mysurname
string (31) this host, this short host
string (255) op, line, err, lc line, output
string (31) m editor
string (2) crlf
string (3) zone
record (paf) pa
record (rf) r
record (folder f) name f
record (folder f) name ff
record (folder f) name f2
record (folder f) name d
record (m structure f) name moved m
record (m structure f) name m
record (m structure f) name mm
record (mail file f) name mail file
record (pf) name p
record (db f) name db
record (af) array format alist arf(1:2000)
record (vf) array format vlist arf(1:2000)
record (af) array name alist
record (vf) array name vlist
record (btablef) array format btable arf(1:max bboards)
record (btablef) array name btab
record (pr bb f) pr bb
record (pointers f) name pointers
switch sw(-1:max ops)
if kent=0 start
switch ed(zecce:other editor)
else
switch ed(zchef:other editor)
finish
integer array cbeg(1:max components)
integer array clen(1:max components)
integer array fconads(1:max folders)
string (31) array fnames(1:max folders)
byte integer array conmode(1:max folders)
byte integer array esc comp(0:7)
string (15) array esc file(0:7)
if target=2900 start
half integer array format msg list f(1:2000)
half integer array name msg list
half integer array name my msg list
else
short integer array format msg list f(1:2000)
short integer array name msg list
short integer array name my msg list
finish
byte integer array format ltou f(0:255)
byte integer array name ltou
record (ad file f) name ad file
record (name entry f) array format name table arf(1:max rnames)
record (name entry f) array name n table
record (name file f) name name file
integer array format hasht af(0:max hash length)
integer array name hash t
if ssmp possible=yes start
integer lastscan, workframe, scanframe, comframe, tempframe, lastrow, ssmp on
record (frameinfo) frame
finish
integer fn spec accommodate message(integer size, dt, type, folder no, string (11) file)
integer fn spec analyse dt after(string (255) datestring)
string fn spec any bboard msgs(integer others)
integer fn spec bb match(string (31) bname)
integer fn spec bb manage(string (31) bname)
integer fn spec bb permitted(string (31) file)
routine spec bb swop(integer one, two)
routine spec bb scan(integer bb no, dt)
integer fn spec check operation(string (255) op)
integer fn spec check overwrite(string (255) s)
routine spec check workfile(integer size, integer name flag)
integer fn spec check write access(integer folder no)
routine spec compose message(integer name flag)
string fn spec compress(string (255) s)
routine spec connect dbfile
integer fn spec current secs
routine spec dispatch message
routine spec do scan(string (255) msgs)
integer fn spec draft overwritable
routine spec draft to msg(integer folder no, secs, type, integer name flag)
routine spec fail(string (255) mess)
routine spec file to component(integer comp, retain, string (31) file)
integer fn spec find alias(string (255) s)
routine spec f list(integer first, count)
routine spec f scan(integer count)
integer fn spec free stream
integer fn spec generate postal output(integer name recips, folder no)
routine spec get from tt(integer comp)
string fn spec get postal addresses(integer name beg, recips, integer end)
integer fn spec get message count(integer name count)
routine spec get profile(integer name flag)
routine spec get string(integer comp, string name s)
string fn spec get zone
integer fn spec h to i(string (8) num)
string fn spec ident to s(integer ident)
routine spec incorporate messages
routine spec lctranslate(integer addr, len)
routine spec lookup directory(integer chan)
routine spec locate component(integer copy, string (255) s)
routine spec locate message(string (63) t, integer name fno, mno, offset)
integer fn spec lookup component(string (255) s)
integer fn spec mailer awake
routine spec message list(string (255) msgline, integer name count, string name s)
routine spec mod alias list(string (255) alias, members, integer type)
integer fn spec msg to draft(string (63) line)
routine spec mycall(string (31) command, string (255) param)
routine spec nameserver request(string (255) s, integer name flag)
integer fn spec open bboard(string (31) bname, integer dt)
routine spec open folder(string (255) file, integer name folder no)
routine spec output component(string (255) comp, outdev, integer name flag)
integer fn spec preserve draft(integer folder no)
routine spec put string(integer comp, string name s)
integer fn spec create folder(string (255) file, integer size, max msgs)
routine spec note current folder(integer folder no)
routine spec readnext(string name line)
routine spec replace aliases(integer name st, len)
routine spec set profile
routine spec scan input
integer fn spec start of(string (255) whole string, first part, string (*) name rest)
integer fn spec user reply(string name s)
integer fn spec verify conad(string (31) file, integer conad)
string (19) fn spec secs to dt(integer p)
on event 9 start
->sw(stop)
finish
myprocess = uinfs(1)
mysurname = uinfs(7)
myfsys = uinfi(1)
line = uinfs(16)
if target#2900 start
if line="EDINBURGH.EMAS3" then line = "EDINBURGH.EMAS-A"
finish
this host = uinfs(15).".".line
unless line->line.(".").this short host then this short host = line
lctranslate(addr(this host)+1, length(this host))
name file conad = 0
db conad = 0
config conad = 0
saveinstream = instream
saveoutstream = outstream
current folder = 0
current msg = 0
fconad = 0
folders open = 0
dconad = 0
dbitcomp = 0
pconad = 0
fn = 0
bbaccess = 0
bbpointer = 0
f type = not bboard type
xreturn code = 0
zone = ""
crlf = tostring(13).tostring(10)
if s="?" start
flag = get message count(i)
if flag=0 start
if i=0 then s = "No" else s = itos(i)
if i=1 then op = "" else op = "s"
printstring(s." new message".op.any bboard msgs(i).snl)
finish
return
finish
ltou == array(com_trans+512, ltou f)
get profile(flag)
if flag#0 then return
open folder(default folder, i)
if i=0 then return
note current folder(i)
check workfile(epage size, flag)
if flag#0 then return
i = uinfi(2); !fore=1, back=2, obey=3
definfo(saveoutstream, line, j)
if i=1 and (line="" or line=".OUT") then to terminal = yes else to terminal = no
termtype = uinfi(23)
m editor = ""
i = f_n msgs; !RESTORE THE DRAFT
if i>0 and f_msg no(i)_status='*' start
flag = msg to draft(itos(i))
flag = preserve draft(1)
offset = f_msg no(i)_offset&offset mask
mm == record(fconad+offset)
if integer(fconad)=offset+mm_length start
integer(fconad) = offset; !REMOVE FROM FOLDER
f_n msgs = i-1; !DECREMENT NO OF MSGS
note current folder(1)
finish
finish
if ssmp possible=yes start
ssmp on = no
sp show frame(0, frame)
if frame_rows=0 start
startssmp("")
sp show frame(0, frame)
if frame_rows#0 then ssmp on = yes
finish else ssmp on = yes
if ssmp on=yes start
lastrow = frame_rows
workframe = sp newframe(1, lastrow-5, 1, frame_cols)
scanframe = sp newframe(lastrow-3, 3, 1, frame_cols)
comframe = sp newframe(lastrow-1, 2, 1, frame_cols)
for i = lastrow-4, 2, lastrow-2 cycle
tempframe = sp newframe(i, 1, 1, frame_cols)
selectoutput(tempframe)
printch('-') for j = 1, 1, frame_cols
closestream(tempframe)
repeat
selectoutput(workframe)
sp clear frame
sp setmode(freeze!breaktext)
lastscan = 0
selectinput(comframe)
finish
finish
started = no
cycle ; !main loop
if started=no start ; !first time round only
started = yes
if s#"" start
if s->op.(",").lc line then lc line = op." ".lc line else start
if s->op.("/").lc line then lc line = op." /".lc line else lc line = s
finish
->quickstart
finish
if p_autoaccept=yes start
flag = get message count(i)
if flag=0 and i>0 then lc line = "ACCEPT ".p_accept and ->quickstart
finish
lc line = ""
if f_acc pend=yes then ->incorp; !may be msg files lying around
finish
if ssmp possible=yes and ssmp on=yes start
if currentmsg#lastscan start
selectoutput(scanframe)
sp set cursor(1, 1)
sp clear line
messagelist("CURRENT", count, s)
f scan(1)
selectoutput(workframe)
lastscan = current msg
finish
finish
prompt(op prompt)
if nextch=nl start
readch(i)
if return new=yes start
if f_n msgs=0 then continue
cycle i = 1, 1, f_n msgs
if f_msg no(i)_status='n' then lc line = itos(i) and ->quickstart
repeat
else
lc line = "NEXT"; !the command usually called
if current msg#0 start
if f type>0 start ; !in a bboard
if pr bb_entry(f type)_dt last<f_msg no(current msg)_dt then lc line = "LIST"
else
unless 'u'#f_msg no(current msg)_status#'n' then lc line = "LIST"
finish
finish
->quickstart
finish
finish
readnext(lc line)
quickstart:
scan input
if fn=-2 then continue ; !null input
->sw(fn)
sw(unknown command):
if start of(op, "-", op)=1 then i = -1 else start
if start of(op, "+", op)=1 then i = 1 else i = 0
finish
if op="" and i#0 then j = 1 else start
if length(op)>9 then j = -1 else j = pstoi(op)
finish
unless j<0 start
if j=0 then line = "DRAFT" else start
if i#0 then j = current msg+(i*j)
if j<=0 then j = 1 else start
if j>f_n msgs then j = f_n msgs
finish
line = itos(j)
finish
->sw(zlist)
finish
printstring(" - unknown command".s.snl)
continue
sw(emas call):
!CALL A ROUTINE SPECIFIED BY THE USER
if kent=no start
if charno(myprocess, 4)='U' then printstring(mailer flags(no to students).snl) and continue
finish
unless op#"" and 'A'<=charno(op, 1)<='Z' then fail("'".op."' is an invalid entry name")
i = 0
lc line = ""
if output#"" then line = line."/".output
if target=2900 start
until line="" cycle
unless line->s.(",").line then s = line and line = ""
if s->err.(":") start
j = lookup component(err)
if j<=0 then printstring(err) and ->mainloop
i = i+1
if i>7 then fail("too many parameters") and ->mainloop
esc comp(i) = j
esc file(i) <- "T#".itos(i).uc comp name(j)
if s->err.(":").s and (s="" or start of(s, drstring, err)=1) start
if dbitcomp>>j&1=0 start ; !COMPONENT EMPTY
outfile(esc file(i), 4096, 0, 0, j, flag)
if flag#0 then fail(failure message(flag)) and ->mainloop
finish else output component(uc comp name(j).":DRAFT", esc file(i), flag)
else
esc comp(i) = 255
output component(uc comp name(j).":".s, esc file(i), flag)
finish
if flag#0 then ->mainloop
s = esc file(i)
finish
if line="" then lc line = lc line.s else lc line = lc line.s.","
repeat
finish else lc line = line
flag = preserve draft(-1)
if ssmp possible=yes and ssmp on=yes then selectinput(workframe)
mycall(op, lc line)
if ssmp possible=yes and ssmp on=yes start
selectinput(comframe)
selectoutput(workframe)
else
selectinput(saveinstream)
selectoutput(saveoutstream)
finish
j = verify conad(workfile, dconad)
if target=2900 start
if i#0 start
for i = 1, 1, i cycle
if esc comp(i)#255 and j=0 then file to component(esc comp(i), yes, esc file(i))
destroy(esc file(i), j)
repeat
finish
finish
flag = j
for j = 1, 1, folders open cycle
if flag#0 then exit
flag = verify conad(fnames(j), fconads(j))
repeat
if flag#0 then printstring("Files disconnected - QUIT called".snl) and dbitcomp = 0 and ->sw(stop)
newline
continue
sw(accept):
!
if mailer awake=no then continue
if line="" then line = p_accept
if output#"" start
open folder(output, i)
if i#0 then note current folder(i) else continue
else
if ftype#not bboard type then printstring(" - reopening ".default folder.snl) and note current folder(1)
finish
if check write access(current folder)#0 then continue
pa = 0
line = line."+".s while line->line.(",").s
if line="" then line = mysurname
line = "MAILSERVER ACCEPT M#,".line
count = 0
for i = 1, 1, 6 cycle
f_acc pend = yes; !in case we dont complete it
flag = dmail(pa, length(line), addr(line)+1)
count = count+pa_message count
if pa_flag#0 start
if pa_flag=15 and pa_message count>0 then incorporate messages and continue ; !no file descriptors
if pa_flag<500 then fail(derrs(pa_flag)) else fail(mailer flags(flag))
finish
exit
repeat
if count=0 then f_acc pend = 0 and continue
message list("UNSEEN", i, s)
if i=0 then s = "" else start
s = ", ".itos(i)." unseen message"
if i#1 then s = s."s"
finish
s = s.any bboard msgs(count+i)
if count=0 then printstring("No new messages".s.snl) and continue
printstring(itos(count)." new message")
if count#1 then printsymbol('s')
printstring(s.snl)
incorp:
incorporate messages
i = 1; !MAKE FIRST NEW MESSAGE CURRENT
while i<=f_n msgs cycle
if f_msg no(i)_status='n' then current msg = i and exit
i = i+1
repeat
do scan("NEW")
continue
sw(accredit):
unless line->op.(",").line then op = line and line = ""
if compress(op)="" start
prompt("Rname:")
read next(op)
finish
s <- "NAMESERVER ACCREDIT ".op.",ALIAS,"
if compress(line)="" start
prompt("Department:")
if nextsymbol=nl then skip symbol and line = "" else readnext(line)
finish
s <- s.",".line
nameserver request(s, flag)
if flag=0 then printstring("Accredited successfully".snl)
if compress(op)=compress(mysurname) then flag = dpermission(myprocess, "MAILER", "", "", myfsys, 7, 0)
continue
sw(alias):
if line="" then i = 1 else start
if line->line.("=").s then i = 3 else start
if line->line.("#").s start
if s="" then i = 5 else i = 4
finish else i = 2
finish
finish
mod alias list(line, s, i)
continue
sw(bboard):
if dbconad=0 then connect dbfile
if dbconad=0 then continue
if line="?" or (line="" and pr bb_no=0) start
flag = 0
for i = 1, 1, pr bb_no cycle
j = bb match(pr bb_entry(i)_bname)
if j>0 start
if flag=0 then flag = 1 and newline
bb scan(j, pr bb_entry(i)_dt last)
else
pr bb_entry(i)_bname = ""
bbaccess = 1; !write back later
finish
repeat
flag = 0; !for printing heading
for i = 1, 1, db_n boards cycle
s = compress(btab(i)_bname)
for j = 1, 1, pr bb_no cycle ; !already scanned?
if s=pr bb_entry(j)_bname then s = "" and exit
repeat
if s#"" and 0=bb permitted(btab(i)_folder) start
if flag=0 then flag = 1 and c
printstring(snl."Type 'bb <name>' to subscribe to any of these <named> bboards:".snl.snl)
bb scan(i, x'7fffffff')
finish
repeat
newline
continue
finish
if line="" start
while bbpointer<pr bb_no cycle
bbpointer = bbpointer+1
if pr bb_entry(bbpointer)_bname#"" start
i = pr bb_entry(bbpointer)_dt last
if i=0 then i = 1; !in case folder is empty
flag = open bboard(pr bb_entry(bbpointer)_bname, i)
if flag>0 then ->mainloop; !found new messages
finish
repeat
bbpointer = 0
if f type=not bboard type then s = "" else s = ", reopening ".default folder and note current folder(1)
printstring(" - all bboards checked".s.snl)
else ; !board specified
line = compress(line)
flag = open bboard(line, 0)
if flag=0 start
if myprocess=db_bowner and line->lcline.("HELLO").line start
i = bb manage(line)
if i=yes then line = "" and ->sw(tidy)
finish else printstring(" - bboard not found".snl)
continue
finish
if ftype=0 start ; !add to profile
for i = 1, 1, max bb entries cycle
if pr bb_entry(i)_bname="" start
pr bb_entry(i)_bname = line
pr bb_entry(i)_dt last = 0
f type = i; !to record LIST
if i>pr bb_no then pr bb_no = i
bbaccess = 1; !write back later
if f type>bbpointer start
bbpointer = bbpointer+1
bb swop(ftype, bbpointer)
f type = bbpointer
finish
exit
finish
repeat
finish
finish
continue
sw(bbcancel):
if dbconad=0 then connect dbfile
if dbconad=0 then continue
if line="" start
if f type=not bboard type then printstring(" - bboard parameter??".snl) and continue
if f type=0 then continue
line = pr bb_entry(f type)_bname
finish
line = compress(line)
for i = 1, 1, pr bb_no cycle
if pr bb_entry(i)_bname=line start
pr bb_entry(i)_bname = ""
if i=pr bb_no start
for j = pr bb_no, -1, 1 cycle
if pr bb_entry(j)_bname="" then pr bb_no = j-1
repeat
finish
bb access = 1; !write back later
if f type>0 then f type = 0
printstring("Bboard ".line." removed".snl)
->mainloop
finish
repeat
i = bb match(line)
if i=0 then printstring(" - not a known bboard name".snl) else c
printstring(" - this bboard is not subscribed to".snl)
continue
sw(compose):
check workfile(epagesize, flag)
if flag#0 then continue
if draft overwritable=no then continue
dbitcomp = 0
j = 1<<subject!1<<to!1<<body
while line#"" cycle
unless line->s.(",").line then s = line and line = ""
i = lookup component(s)
if i<=0 then printstring(err) and ->mainloop
j = j!1<<i
repeat
if j>>from&1=1 then j = j!(1<<reply to)
d_start = d_end
for i = 1, 1, distinct components cycle
if j>>prompt order(i)&1=1 then get from tt(prompt order(i))
repeat
->prompt for send
sw(zcopy):
if output="" then output = "TEXT"
if start of(drstring, output, op)=1 start
if line="" then line = "CURRENT"
flag = msg to draft(line)
else
i = lookup component(output)
if i<=0 then printstring(err) and continue
if line="" then get from tt(i) else locate component(i, line)
finish
continue
sw(directory):
if output#"" and check overwrite(output)#0 then continue
if length(line)=0 then printstring(" - rname parameter?".snl) and continue
if output#"" start
unless 'A'<=charno(output, 1)<='Z' or charno(output, 1)='.' then c
printstring(" ".output." - invalid filename ".snl) and continue
i = free stream
define(itos(i).",".output)
if returncode#0 then continue
finish else i = 0
lookup directory(i)
if i#0 then clear(itos(i))
continue
sw(discard):
if line="" then line = "CURRENT"
op = ""
until line="" cycle
unless line->s.(",").line then s = line and line = ""
if s->s.(":") start ; !COMPONENT OF THE DRAFT
i = lookup component(compress(s))
if i<=0 then printstring(err) else dbitcomp = dbitcomp&(~(1<<i))
else
if op="" then op = s else op = op.",".s
finish
repeat
if op="" then continue
if conmode(current folder)=0 start
if ftype#not bboard type start ; !discard bboard msg??
message list(op, count, s)
if s#"" then printstring(s) and continue
if count=0 then continue
check workfile(epagesize, flag)
i = addr(msg list(1))
my msg list == array(i, msglist f)
d_end = i+count*2-dconad
save dbitcomp = dbitcomp
for k = 1, 1, db_n boards cycle
if btab(k)_folder=fnames(current folder) start
dbitcomp = 0
putstring(to, btab(k)_bname)
s = "discard"
putstring(comments, s)
dest f = 0; j = 0
for i = 1, 1, count cycle
if my msg list(i)=0 then continue
locate component(references, "MSG:".itos(my msg list(i)))
locate component(from, "FROM:".itos(my msg list(i)))
getstring(from, op)
if myprocess#"MANAGR" start
unless compress(op)->(compress(mysurname)).line then c
printstring(" - message ".itos(my msg list(i))." in '".btab(k)_bname. c
"' was not sent by you".snl) and continue
dbitcomp = dbitcomp&(~(1<<from))
finish
compose message(flag)
if flag#0 then continue
dispatch message
if pa_message count>0 then j = j+1
repeat
if j=1 then s = "" else s = "s"
if j=0 then line = "no" else line = itos(j)
printstring(" - ".line." discard request".s." queued".snl)
exit
finish
repeat
dbitcomp = save dbitcomp
continue
finish
fail("cannot write to current folder")
continue
finish
message list(op, i, s)
if s#"" then printstring(s) and s = ""
count = 0
for i = 1, 1, i cycle
if msg list(i)=0 then dbitcomp = 0 else start
if f_msg no(msg list(i))_status='x' then continue
!already discarded
f_msg no(msg list(i))_status = 'x'
current msg = msg list(i)
finish
count = count+1
repeat
if count=1 then s = "" else s = "s"
printstring(itos(count)." message".s." discarded".snl)
continue
sw(discredit):
if compress(line)="" start
prompt("Rname:")
readnext(line)
finish
s <- "NAMESERVER DISCREDIT ".line
nameserver request(s, flag)
if flag=0 start
printstring("Discredited successfully".snl)
if compress(line)=compress(mysurname) then flag = dpermission(myprocess, "MAILER", "", "", myfsys, 6, 0)
finish
continue
sw(dn):
if conmode(current folder)=0 start
fail("cannot write to current folder")
else
if current msg#0 then f_msg no(current msg)_status = 'x'
finish
->sw(next)
sw(v editor):
if kent=no start
s = substring(myprocess, 1, 4)
if charno(myprocess, 4)='U' and "ECUU"#s#"ECVU" then c
printstring(" - ".mailer flags(no to students).snl) and continue
finish
fn = other editor
if kent#0 start
sw(zchef):
sw(zem):
finish
sw(zecce):
sw(zedit):
!%if output#"" %then fail("no output parameter allowed") %and %continue
!%if line="" %then line="TEXT"
!i=lookup component(line)
!%if i<=0 %then printstring(err) %andcontinue
!%if charno(line,length(line))=':' %then length(line)=length(line)-1
!%if dbitcomp>>i&1=1 %start
!op="M#MSG"
!output component(line.":DRAFT",op,flag)
!%if flag#0 %then %continue
!%else
!op="M#".line
!outfile(op,-4096,0,0,j,flag)
!%if flag#0 %then fail(failure message(flag)) %andcontinue
!integer(j+12)=char filetype
!%finish
!->ed(fn)
if line=""=output then line = "TEXT:"
if output="" start
if line->op.(":").output start
if output#"" then printstring(" - output to which component of the draft?".snl) and continue
finish else line = line.":"
output = line
finish
i = lookup component(output)
if i<=0 then printstring(err) and continue
if line=output and dbitcomp>>i&1=0 then line = ""
if line->line.(":").op start ; !COMPONENT NAME INPUT
if op="" then line = line.":DRAFT" else line = line.":".op
op = "M#MSG"
output component(line, op, flag)
if flag#0 then continue
else ; !FILENAME OR NULL INPUT
if output->output.(":") start
finish
op = "M#".output
if length(op)>11 then length(op) = 11
if line#"" start
connect(line, 0, 0, 0, r, flag)
if flag#0 then fail(failure message(flag)) and continue
outfile(op, r_dataend, 0, 0, j, flag)
if flag=0 then move(r_dataend, r_conad, j)
else
outfile(op, 4096, 0, 0, j, flag)
if flag=0 then integer(j+12) = char filetype
finish
if flag#0 then fail(failure message(flag)) and continue
finish
if target#2900 then disconnect(op, flag)
->ed(fn)
if kent#0 start
ed(zchef):
chef(op.",@+R/.*/Chef - type Q to quit/;@+;@+R/.*/p/")
->after edit
ed(zem):
zm(op)
->after edit
finish
ed(zecce):
ecce(op)
->after edit
ed(zedit):
edit(op)
->after edit
ed(other editor):
mycall(p_v editor, op)
after edit:
if returncode=0 then file to component(i, no, op)
if target#2900 then disconnect(op, flag)
destroy(op, flag)
check workfile(epage size, flag)
continue
!sw(extract):
!%if line="" %then line="CURRENT"
!flag=msg to draft(line)
!%continue
sw(file):
if line="" then line = "CURRENT"
if output="" or output=fnames(current folder) then this f = current folder else start
open folder(output, this f)
if this f=0 then continue
finish
flag = preserve draft(this f)
if flag#0 then continue
message list(line, count, s)
if s#"" then printstring(s)
if count>0 and this f=current folder then start
unless count=1 and msg list(1)=0 then c
printstring(" ".line." - cannot file messages to their own folder".snl) and continue
finish
j = 0; s = ""
for i = 1, 1, count cycle
if msg list(i)=0 start ; !FILE THE DRAFT
if dbitcomp=0 then printstring(" DRAFT - message empty".snl) and continue
draft to msg(this f, current secs, 's', flag)
if flag#0 then exit
dbitcomp = 0
d_end = d_start
if current folder=this f then current msg = f_n msgs
else
current msg = msg list(i)
offset = f_msg no(current msg)_offset
if offset>>24='x' start
if length(s)<200 then s = s.itos(current msg).", "
continue
finish
mm == record(fconad+offset&offset mask)
flag = accommodate message(mm_length, f_msg no(current msg)_dt, offset>>24, this f, "")
if flag#0 then exit
move(mm_length, addr(mm_marker), addr(moved m_marker))
if conmode(current folder)=read write then f_msg no(current msg)_status = 'x'
finish
j = j+1; !keep a count
repeat
if s#"" then length(s) = length(s)-2 and printstring(" ".s." - cant file discarded messages".snl)
if j=1 then s = "" else s = "s"
printstring(itos(j)." message".s." filed and discarded".snl)
continue
sw(forward):
check workfile(epage size, flag)
if flag#0 then continue
if line="" then line = "CURRENT"
message list(line, count, op)
if op#"" then printstring(op)
if count=0 then continue
if draft overwritable=no then continue
if count=1 start
plus dashes = 0; op = ""
temp mno = msg list(1)
finish else plus dashes = 1 and op = "s"
list limit = -1; !ALWAYS INCLUDE ALL COMPONENTS
i = free stream
define(itos(i).",M#MSG")
selectoutput(i)
printstring("--- Forwarded message".op.":".snl)
f list(1, count)
printstring(snl."--- End of forwarded message".op.snl)
if ssmp possible=yes and ssmp on=yes then selectoutput(workframe) else selectoutput(saveoutstream)
closestream(i)
clear(itos(i))
connect("M#MSG", 0, 0, 0, r, flag)
if flag#0 then fail(failure message(flag)) and continue
i = r_dataend-r_datastart
check workfile(i, flag)
if flag#0 then continue
move(i, r_conad+r_datastart, dconad+d_end)
if target#2900 then disconnect("M#MSG", flag)
dbitcomp = 1<<body
cbeg(body) = dconad+d_end
clen(body) = i
d_end = d_end+i
if count=1 start
if temp mno=0 then count = 0 else start
mm == record(fconads(current folder)+(f_msg no(temp mno)_offset&offset mask))
for i = reply to, (from-reply to), from cycle
if mm_bitcomp&(1<<i)#0 start
locate component(reply to, uc comp name(i).":".itos(temp mno))
getstring(reply to, s)
unless s->("MAILER@").s then exit
dbitcomp = dbitcomp&(~(1<<reply to))
finish
repeat
finish
finish
check workfile(epagesize, flag)
if flag#0 then continue
if count=1 and mm_bitcomp&(1<<subject)#0 then locate component(subject, "SUBJECT:".itos(temp mno)) else c
start
op = "Forwarded message".op
putstring(subject, op)
finish
get from tt(to)
get from tt(comments)
->prompt for send
sw(goto):
if line="" then printstring(" parameter?".snl) and continue
message list(line, i, s)
if s#"" then printstring(s)
if i>0 start
if msg list(1)=0 then printstring(" DRAFT - may not be current message".snl) else start
current msg = msg list(1)
if f type>0 start
if pr bb_entry(f type)_dt last<f_msg no(current msg)_dt then c
pr bb_entry(f type)_dt last = f_msg no(current msg)_dt and bb access = 1
finish
finish
finish
continue
sw(help):
if line#"" start
fn = check operation(line)
if fn>0 then line = op names(fn)
line = ",".line
finish
zview(hfileowner.usep.helpfile.line)
continue
sw(inquire):
printstring("Not available".snl)
continue
sw(zlist):
if output#"" and check overwrite(output)#0 then continue
if line="" then line = "CURRENT"; !DEFAULT
message list(line, i, op)
if op#"" then printstring(op)
if i>0 start
if output#"" start
if check overwrite(output)#0 then continue
if i>250 then op = ",".itos(uinfi(6)-1) else op = ""
!max filesize
j = free stream
define(itos(j).",".output.op)
if returncode#0 then continue
selectoutput(j)
list limit = llist file
finish else list limit = llist console
if i>1 and output#"" start
printstring(snl."Folder ".fnames(current folder).", messages '".line."'".snl)
f scan(i)
plus dashes = 1; !INSERT LINE OF '_' BETWEEN MSGS
finish else plus dashes = 0
f list(1, i)
if output="" then continue
if ssmp possible=yes and ssmp on=yes then selectoutput(workframe) else selectoutput(saveoutstream)
closestream(j)
clear(itos(j))
finish
continue
sw(next):
j = current msg
if j=f_n msgs then printstring(" ** end of folder **".snl) and continue
if line#"" start
check workfile(epagesize, flag)
if flag#0 then continue
message list(line, count, op)
if op#"" then printstring(op)
for i = 1, 1, count cycle
if msg list(i)>current msg start
current msg = msg list(i)
if f_msg no(current msg)_status='x' then c
printstring(" ".itos(current msg)." - discarded message (now current)".snl) and exit
line = ""
->sw(zlist)
finish
repeat
else
while j<f_n msgs cycle
if f_msg no(j+1)_status#'x' start
current msg = j+1
line = ""
->sw(zlist)
finish
j = j+1
repeat
printstring(" ".itos(current msg)." - all following messages are discarded".snl)
finish
continue
sw(open):
if line="?" start
if f_n msgs=1 then s = "" else s = "s"
if f type#not bboard type start
for i = 1, 1, db_n boards cycle
if btab(i)_folder=fnames(current folder) then line = "Bboard '".btab(i)_bname."'" and exit
repeat
finish
if line="?" then line = "Folder ".fnames(current folder)
printstring(line." contains ".itos(f_n msgs)." message".s.", current message = ".itos(current msg).snl)
continue
finish
if line="" then line = default folder
j = 0
j = exist(line)
open folder(line, i)
if i#0 start
note current folder(i)
if f_n msgs=1 then s = "" else s = "s"
if j#0 then printstring("Folder ".line." contains ".itos(f_n msgs)." message".s.snl)
finish
continue
sw(zoutput):
if output="" then output = ".OUT" else start
if check overwrite(output)#0 then continue
finish
if line="" then line = "TEXT:"
unless line->line.(":").op then op = ""
if op="" then line = line.":CURRENT" else line = line.":".op
output component(line, output, flag)
continue
sw(post):
dest f = 0
if output#"" start
if output->output.(",").lc line start
if start of(nullstring, lc line, s)=1 then dest f = 0 else start
open folder(lc line, dest f)
if dest f=0 then continue
finish
else
if p_autofile=0 then dest f = 0 else dest f = current folder
finish
if dest f#0 start
if f type#not bboard type and dest f=current folder then dest f = 1
if check write access(dest f)#0 then continue
finish
if checkoverwrite(output)#0 then continue
unless 'A'<=charno(output, 1)<='Z' or charno(output, 1)='.' then c
printstring(" ".output." - invalid filename".snl) and continue
else
printstring(" - no output device or file specified".snl)
continue
finish
check workfile(1024, flag)
if flag#0 then continue
if line="" then flag = 0 else flag = msg to draft(line)
if flag#0 then continue
if dbitcomp&recip comps=0 or dbitcomp&text comps=0 start
if dbitcomp&recip comps=0 then s = "To:" else s = "Text:"
printstring(" ".s." component missing".snl)
continue
finish
if p_alias head#0 start
for i = to, 1, bcc cycle ; !to, cc, bcc
if dbitcomp>>i&1=1 start
check workfile(clen(i)+1024, flag)
if flag#0 then ->mainloop
replace aliases(cbeg(i), clen(i))
finish
repeat
finish
i = uinfi(6)-1; !maxfile in Kb
if 511<i then i = 511
j = free stream
define(itos(j).",".output.",".itos(i))
if returncode#0 then continue
selectoutput(j)
plus dashes = 0
count = generate postal output(i, dest f)
closestream(j)
clear(itos(j))
if count>0 start
printstring("Post printed")
if dest f#0 then printstring(" and filed")
if i>count then printstring(", also send to MAIL users?".snl) and ->prompt for send else newline
finish else printstring("No postal addresses in message".snl)
continue
sw(previous):
j = current msg
if j=1 then printstring(" ** top of folder **".snl) and continue
if line#"" start
check workfile(epagesize, flag)
if flag#0 then continue
message list(line, count, op)
if op#"" then printstring(op)
for i = count, -1, 1 cycle
if 0<msg list(i)<current msg start
current msg = msg list(i)
if f_msg no(current msg)_status='x' then c
printstring(" ".itos(current msg)." - discarded message (now current)".snl) and exit
line = ""
->sw(zlist)
finish
repeat
else
while 1<j cycle
if f_msg no(j-1)_status#'x' start
current msg = j-1
line = ""
->sw(zlist)
finish
j = j-1
repeat
printstring(" ".itos(current msg)." - all previous messages are discarded".snl)
finish
continue
sw(profile):
set profile
continue
sw(quit):
sw(stop):
if dbitcomp#0 then draft to msg(1, 0, '*', flag)
while folders open>0 cycle
disconnect(fnames(folders open), flag)
folders open = folders open-1
repeat
if name file conad#0 start
disconnect("MAILER".usep.snamefile, flag)
disconnect("MAILER".usep.addrfile, flag)
finish
if config conad#0 then disconnect(confileowner.usep.configfile, flag)
if dbconad#0 then disconnect("MAILER".usep.dbfile, flag)
if bb access=1 start
if pr bb_no=0 then i = -1 else i = 1
write profile(dbfile, pr bb, i, flag); !ignore flag
finish
destroy(workfile, flag)
destroy("M#MSG", flag)
destroy("M#DREPORT", flag)
set return code(xreturn code)
if ssmp possible=yes and ssmp on=yes start
selectoutput(0)
sp set cursor(last row, 1)
selectinput(saveinstream)
selectoutput(saveoutstream)
finish
return
sw(reply):
check workfile(epagesize, flag)
if flag#0 then continue
if line="" then line = "CURRENT"
flag = msg to draft(line)
if flag#0 then continue
if dbitcomp>>reply to&1=1 start
cbeg(to) = cbeg(reply to)
clen(to) = clen(reply to)
else
if dbitcomp>>from&1=0 then printstring(" From: - component missing".snl) and continue
cbeg(to) = cbeg(from)
clen(to) = clen(from)
finish
dbitcomp = dbitcomp!(1<<to)
if dbitcomp>>subject&1=1 start
getstring(subject, s)
s = substring(s, 2, length(s)) while length(s)>1 and charno(s, 1)<=' '
unless start of(s, "Re:", op)=1 or start of(s, "RE:", op)=1 then s = "Re: ".s and putstring(subject, s)
i = 1<<to!1<<subject
finish else i = 1<<to
getstring(to, s)
if s->s.(",").op then line = " etc" else line = ""
if s->s.("<").op start
finish
if s->s.(" at ").op then start
finish
if length(s)>60 then length(s) = 60
printstring("Replying to ".s.line.snl) unless s=""
getstring(messid, op)
if op#"" then s = "Your message ".op else start
if dbitcomp&1<<cdate=0 then s = "" else getstring(cdate, line) and s = "Your message of ".line
finish
dbitcomp = i
if s#"" then putstring(in reply to, s)
get from tt(body)
->prompt for send
!sw(replace):
!%if line="" %then line="TEXT"
!%until line="" %cycle
!unless line->s.(",").line %then s=line %and line=""
!i=lookup component(s)
!%if i<=0 %then printstring(err) %andcontinue
!get from tt(i)
!%repeat
!%continue
sw(retrieve):
if line="" then line = "CURRENT"
message list(line, i, s)
if s#"" then printstring(s)
if i>0 and conmode(current folder)=0 start
fail("cannot write to current folder")
continue
finish
j = 0
count = 0
for i = 1, 1, i cycle
if msg list(i)=0 then printstring(" DRAFT - cannot retrieve draft message".snl) else start
if j=0 then j = 1 and current msg = msg list(i)
if f_msg no(msg list(i))_status='x' then f_msg no(msg list(i))_status = ' ' and count = count+1
finish
repeat
if count=1 then s = "" else s = "s"
printstring(itos(count)." message".s." retrieved".snl)
continue
sw(revoke):
printstring("Not available".snl)
continue
sw(scan):
if output#"" and check overwrite(output)#0 then continue
if ssmp possible=yes and ssmp on=yes and output="" then sp clear frame
if line="" then line = "CURRENT" else start
if start of(allstring, line, op)=1 and dbitcomp#0 and current folder=1 start
if f_n msgs>0 then line = line.",DRAFT" else line = "DRAFT"
finish
finish
message list(line, i, op)
if op#"" then printstring(op)
if i>0 start
if output#"" start
unless 'A'<=charno(output, 1)<='Z' or charno(output, 1)='.' then c
printstring(" ".output." - invalid filename ".snl) and continue
j = free stream
define(itos(j).",".output)
if returncode#0 then continue
selectoutput(j)
finish
f scan(i)
if output="" then continue
if ssmp possible=yes and ssmp on=yes then selectoutput(workframe) else selectoutput(saveoutstream)
closestream(j)
clear(itos(j))
finish
continue
prompt for send:
if dbitcomp&recip comps=0 or dbitcomp&text comps=0 then continue
prompt("Send now? : ")
j = user reply(s)
if j=no start
if s="" or start of(nullstring, s, op)=1 then continue
if start of(fold string, s, op)=1 then s = "" else s = "/".s
lc line = "FILE DRAFT".s
->quickstart
finish
if j=yes then lc line = "SEND DRAFT".s else lc line = "SEND DRAFT,".s
->quickstart
sw(send):
if output#"" start
if start of(nullstring, output, lc line)=1 then dest f = 0 else start
open folder(output, dest f)
if dest f=0 then continue
finish
else
if p_autofile=0 then dest f = 0 else dest f = current folder
finish
if dest f#0 start
if f type#not bboard type and dest f=current folder then dest f = 1
if check write access(dest f)#0 then continue
finish
s = "" unless line->line.(",").s
unless line="" then flag = msg to draft(line) else flag = 0
if flag#0 then continue
if dbitcomp&recip comps=0 or dbitcomp&text comps=0 start
if dbitcomp&recip comps=0 then s = "To:" else s = "Text:"
printstring(" ".s." - component missing".snl)
continue
finish
check workfile(1024, flag)
if flag#0 then continue
if compress(s)#"" start
secs now = current secs
j = analyse dt after(s)
if j<0 then continue
if j<=secs now then printstring("Date/time less than present date/time".snl) and ->prompt for send
s = secs to dt(j)
putstring(after, s)
finish else j = 0
if j=0 then dbitcomp = dbitcomp&(~(1<<after))
compose message(flag)
if flag#0 then continue
dispatch message
if dest f#0 and pa_message count>0 start
if zone="" then zone = get zone
op = "<".secs to dt(pa_secs)." ".zone." ".ident to s(pa_ident)."@".this short host.">"
putstring(messid, op)
draft to msg(dest f, pa_secs, ' ', flag)
if flag#0 then continue
dbitcomp = 0
d_end = d_start
if current msg=0 and dest f=current folder then current msg = 1
finish
continue
sw(syntax):
printstring("Not available".snl)
continue
sw(tidy):
if line#"" start
open folder(line, this f)
if this f=0 then continue
finish else this f = current folder
if check write access(this f)#0 then continue
ff == record(fconads(this f))
if ff_n msgs=0 then continue
flag = create folder("T#MAIL", ff_size, ff_max msgs)
if flag#0 then continue
open folder("T#MAIL", sec f)
if sec f=0 then continue
f2 == record(fconads(sec f))
flag = preserve draft(this f)
if flag#0 then continue
j = fconads(this f)
for i = 1, 1, ff_n msgs cycle
offset = ff_msg no(i)_offset
if offset>>24#'x' start
mm == record(j+offset&offset mask)
flag = accommodate message(mm_length, ff_msg no(i)_dt, offset>>24, sec f, "")
if flag#0 then exit
move(mm_length, addr(mm_marker), addr(moved m_marker))
finish
repeat
if flag#0 then continue
if f2_n msgs=1 then s = "" else s = "s"
printstring("Folder ".fnames(this f)." contains ".itos(f2_n msgs)." message".s.snl)
disconnect(fnames(this f), flag)
if target#2900 start
disconnect("T#MAIL", flag)
disconnect("T#MAIL", flag)
finish
newgen("T#MAIL", fnames(this f), flag)
if flag#0 then printstring(failure message(flag).snl)
fnames(sec f) = ""
connect(fnames(this f), read write, 0, 0, r, flag)
if flag#0 then fail(failure message(flag)) and return
fconads(this f) = r_conad
if this f=current folder then note current folder(this f)
ff == record(r_conad)
i = (ff_end+epage size-1)&(-epage size)
ff_size = i
flag = dchsize(myprocess, fnames(this f), myfsys, i>>10)
if flag#0 then printstring("Fault - ".derrs(flag).snl)
continue
mainloop:
repeat
!! Routines
integer fn start of(string (255) whole string, first part, string (*) name rest)
result = 0 unless 0<length(first part)<=length(whole string) and c
first part=substring(whole string, 1, length(first part))
whole string -> (first part).rest
result = 1
end ; !OF START OF
routine check workfile(integer size, integer name flag)
if dconad=0 start
outfile(workfile, epagesize*2, 0, tempfile, dconad, flag)
if flag#0 then fail(failure message(flag)) and return
d == record(dconad)
else
if d_end+size>d_size start
size = (size+d_end+epage size-1)&(-epage size)
flag = dchsize(myprocess, workfile, myfsys, size>>10)
if flag#0 then printstring("Extend workfile fails - ".derrs(flag).snl) and return
d_size = size
finish else flag = 0
finish
end ; !OF CHECK WORKFILE
integer fn check operation(string (255) op)
integer fn
for fn = 1, 1, max ops cycle
if start of(op names(fn), op, s)=1 then result = fn
repeat
s = ""
while length(op)>1 cycle
length(op) = length(op)-1
for fn = 1, 1, max ops cycle
if start of(opnames(fn), op, err)=1 start
if s#"" then s = s.", "
s = s.opnames(fn)
finish
repeat
if s#"" then s = ": ".s." intended??" and result = unknown command
repeat
result = unknown command
end ; !OF CHECK OPERATION
routine lctranslate(integer addr, len)
integer i
for i = addr, 1, addr+len-1 cycle
if 'A'<=byteinteger(i)<='Z' then byteinteger(i) = byteinteger(i)+32
repeat
end ; !of lctranslate
routine scan input
const byte integer array class(' ':'~')= 0, 1, 3, 4(8),6,4,6,4, 2,
6(10),4(7), 5(26), 4(6), 5(26), 4(4)
const byte integer array table(0:6, 0:7)= c
16_00, 16_01, 16_12, 16_12, 16_12, 16_12, 16_17, {0 = starting} c
16_73, 16_73, 16_73, 16_73, 16_73, 16_12, 16_73, {1 = reading op} c
16_24, 16_24, 16_60, 16_44, 16_24, 16_24, 16_24, {2 = reading line + spaces,/} c
16_30, 16_34, 16_60, 16_54, 16_34, 16_34, 16_34, {3 = reading line, no sp,/} c
16_44, 16_44, 16_44, 16_24, 16_44, 16_44, 16_44, {4 = reading line + spaces,"} c
16_50, 16_54, 16_54, 16_34, 16_54, 16_54, 16_54, {5 = reading line, no sp,"} c
16_60, 16_65, 16_65, 16_65, 16_65, 16_65, 16_65, {6 = reading output} c
16_70, 16_36, 16_60, 16_36, 16_36, 16_36, 16_36 {7 = scanning for line}
{ space ! / " rest alpha +-digit }
! Left quartet = next state, right quartet = action
const integer lc fns= 1<<accredit!1<<alias
const long integer spaces fns= one<<accredit!one<<alias!one<<discard!one<<file c
!one<<forward!one<<goto!one<<zlist!one<<next!one<<previous!one<<reply %c
!one<<retrieve!one<<scan!one<<send!one<<directory
integer cl, char, i, state, act
string (255) ucline
switch sw(-1:7)
op = ""; line = ""
output = ""
ucline = myucstring(lc line)
state = 0
fn = -2
for i = 1, 1, length(ucline) cycle
char = charno(ucline, i)
if ' '<=char<='~' then cl = class(char) else exit
sw(-1):
act = table(cl, state)&7
state = table(cl, state)>>4
->sw(act)
sw(0):
!do nothing
continue
sw(1):
!note emas call
fn = emas call
continue
sw(2):
!add to op
op = op.tostring(char)
continue
sw(3):
!evaluate op
if fn#-2 start
if cl=6 then state = 1 and ->sw(2)
continue
finish
fn = check operation(op)
if fn>0 and (1<<fn)&lc fns#0 then ucline = lc line
!preserve lower case
->sw(-1); !rescan char
sw(4):
!add to line
line = line.tostring(char)
continue
sw(5):
!add to output
output = output.tostring(char)
continue
sw(6):
!check for spaces
if fn>0 and (one<<fn)&spaces fns#0 then state = 2
->sw(4)
sw(7):
!pseudo LIST
fn = unknown command
->sw(2); !add to op
repeat
if fn=-2 and op#"" then fn = check operation(op)
end ; !of scan input
integer fn user reply(string name s)
string (255) t, u, v
cycle
readnext(s)
uctranslate(addr(s)+1, length(s))
if s->t.("/").u start
t = compress(t)
u -> (" ").u while u#"" and charno(u, 1)=' '
if t="" or start of(yes string, t, v)=1 then s = "/".u and result = yes
if start of(no string, t, v)=1 then s = u and result = no
result = -1
else ; !NO OUTPUT GIVEN
t = compress(s)
if t="" then continue
if start of(yesstring, t, v)=1 then s = "" and result = yes
if start of(no string, t, v)=1 then s = "" and result = no
result = -1
finish
repeat
end ; !OF USER REPLY
integer fn get message count(integer name count)
if target=2900 start
result = dsfi(myprocess, myfsys, msg indicator, 0, addr(count))
else
integer flag
integer array i(0:0)
flag = dsfi(myprocess, myfsys, msg indicator, 0, "", i)
if flag=0 then count = i(0)
result = flag
finish
end ; !of get message count
routine get from tt(integer comp)
integer pos, i, term, startpos, tcom, j, endpos, flag, conad, one, k
string (63) s, t
string (31) curr prompt
switch tilde, special(0:127)
if kent=0 start
const string (4) default editor="EDIT"
finish else start
const string (2) default editor="EM"
finish
on event 9 start
i = 25
->out
finish
routine appendfile(string (63) file)
integer flag, len
record (rf) r
length(file) = length(file)&31
connect(file, 0, 0, 0, r, flag)
if flag=0 start
len = r_dataend-r_datastart
if len>0 start
if r_filetype#3 then printstring(" warning - ".file." is not a character file".snl)
check workfile(pos-startpos+len+512, flag)
if flag=0 start
move(len, r_conad+r_datastart, pos)
pos = pos+len
finish
finish else printstring(" ".file." is an empty file".snl)
if target#2900 then disconnect(file, flag)
finish else fail(failure message(flag))
end ; !of appendfile
if ssmp possible=yes and ssmp on=yes then selectinput(workframe)
if (1<<comp)&text comps#0 start
if comp=body then s = tostring(13).tostring(10).":" else s = ""
prompt(lc comp name(comp).s)
i = next ch
if comp=body then curr prompt = ":" else curr prompt = " : "
term = ':'
else
curr prompt = lc comp name(comp)
term = nl
finish
prompt(curr prompt)
dbitcomp = dbitcomp&(~(1<<comp))
startpos = dconad+d_end
pos = startpos
endpos = dconad+d_size-512
cycle
readch(i); !first char on a line
->special(i&127)
special('~'): !tilde escape
if nextch='~' then skip symbol and ->special(0); !double=ignore
readch(tcom)
s = ""
cycle
readch(i)
if i=nl or i=em then exit
if i=' ' and s="" then continue
s <- s.tostring(i); !parameter
repeat
length(s) = length(s)-1 while length(s)>1 and charno(s, length(s))=' '
s = myucstring(s)
tcom = tcom+32 if 'A'<=tcom<='Z'
->tilde(tcom&127)
tilde('f'): !~f = insert file
append file(s)
continue
tilde('l'): !~l = list input
printsymbol(byteinteger(j)) for j = startpos, 1, pos-1
continue
tilde('c'): !~c = insert message component
if s="" then s = "TEXT"
unless s->s.(":").t then t = ""
s = s.":".t
d_end = pos-dconad+1
locate component(comp, s)
d_end = startpos-dconad
if dbitcomp>>comp&1=1 start
dbitcomp = dbitcomp&(~(1<<comp))
check workfile(pos-startpos+clen(comp)+512, flag)
if flag=0 start
move(clen(comp), cbeg(comp), pos)
pos = pos+clen(comp)
if byteinteger(pos-1)#nl then byteinteger(pos) = nl and pos = pos+1
finish
finish
continue
tilde('m'): !~m = insert message
d_end = pos-dconad+1
if s="" then s = "CURRENT"
message list(s, j, op)
if op#"" then printstring(op)
if j=0 then d_end = startpos-dconad and continue
list limit = llist file
if j>1 then plus dashes = 1 else plus dashes = 0
fn = forward; !to suppress "(Message 43)" line
k = free stream
define(itos(k).",M#MSG")
select output(k)
f list(1, j)
if ssmp possible=yes and ssmp on=yes then selectoutput(workframe) else selectoutput(saveoutstream)
closestream(k)
clear(itos(k))
d_end = startpos-dconad
if j>0 then appendfile("M#MSG")
continue
tilde('e'): !~e = edit input
j = pos-startpos
outfile("M#EDIT", j+1, 0, 0, conad, flag)
if flag#0 then fail(failure message(flag)) and continue
move(j, startpos, conad+integer(conad+4))
integer(conad) = integer(conad)+j
integer(conad+12) = 3; ! character file
if m editor="" start
one = 1
if kent = 0 start
read profile("MEDIT", m editor, one, flag)
else
read profile("EDITOR", m editor, one, flag)
finish
if flag>1 then m editor = default editor
finish
mycall(m editor, "M#EDIT")
k = pos
pos = startpos
appendfile("M#EDIT")
if target#2900 then disconnect("M#EDIT", flag)
destroy("M#EDIT", flag)
if k<pos and byteinteger(pos-1)#nl then byteinteger(pos-1) = nl and pos = pos+1
prompt(curr prompt)
continue
tilde('!'): !~! = call command
unless s->s.(" ").t then t = ""
mycall(s, t)
prompt(curr prompt)
continue
tilde('s'): !~s = select editor
if s#"" start
one = 1
if kent = 0 start
write profile("MEDIT", s, one, flag)
else
write profile("EDITOR", s, one, flag)
finish
if flag>1 then printstring(" failed to store ".s." as editor".snl) else m editor = s
finish
continue
tilde('a'): !~a = abandon input
pos = startpos
exit
tilde(*): !~anything else
printstring("The following tilde escapes are provided:
~f filename - include the file indicated
~e - edit the text collected so far (by default, uses '".default editor."')
~l - list the text collected so far")
printstring("
~m message - include the messages indicated (e.g. last3)
~c component - include message component (e.g. cc:last)
~a - abandon input")
printstring("
~! command - call an EMAS command
~s editor - select the editor invoked by '~E'")
printstring("
~~ - single '~' character
~? - list this help message
")
if kent=0 start
printstring("Terminate input with control+Y".snl)
else
printstring("Terminate input with control+D or control+Y".snl)
finish
continue
special('@'): !old style @filename
if pos#startpos then ->special(0); !must be first char
s = ""
cycle
readch(i)
if i=nl or i=em then exit
s <- s.tostring(i)
repeat
uctranslate(addr(s)+1, length(s))
locate component(comp, s)
if i#em and dbitcomp>>comp&1=0 then continue
->check em
special('*'): !old style endoftext
special(':'): !old style endoftext
if nextch=nl then skipsymbol and exit
special(*): !all the rest
if pos>endpos start
check workfile(pos-startpos+epagesize, flag)
if flag#0 then exit
endpos = dconad+d_size-512
finish
cycle
byteinteger(pos) = i
pos = pos+1
if i=nl then exit
if i=em then ->out
readch(i)
repeat
if term=nl start
if pos>startpos+1 start
if byteinteger(pos-2)=',' then continue
if byteinteger(pos-2)='¬' start
pos = pos-1
byteinteger(pos-1) = nl
continue
finish
finish
exit
finish
repeat
out:
if pos>startpos+1 start
cbeg(comp) = startpos
clen(comp) = pos-cbeg(comp)-1
dbitcomp = dbitcomp!1<<comp
d_end = d_end+clen(comp)
finish
check em:
!IN CASE EM LEFT
if i=em then j = iocp(12, 0)
if ssmp possible=yes and ssmp on=yes then select input(comframe)
end ; !OF GET FROM TT
routine locate component(integer comp, string (255) s)
string (63) t, t1
integer fno, mno, offset, c
record (rf) r
if start of(s, "@", s)=1 start
finish
if s->s.(":").t start
c = lookup component(s)
if c<=0 then printstring(err) and return
if t#"" and start of(drstring, t, t1)=1 start
if dbitcomp>>c&1=0 or clen(c)=0 then printstring(" ".s.":".t." - component empty".snl) and ->fails
cbeg(comp) = cbeg(c)
clen(comp) = clen(c)
else
locate message(t, fno, mno, offset)
if offset=0 then ->fails
if mm_bitcomp>>c&1=0 or mm_c(c)_len=0 then c
printstring(" ".s.":".t." - component empty".snl) and ->fails
cbeg(comp) = mm_c(c)_beg+offset
clen(comp) = mm_c(c)_len
finish
dbitcomp = dbitcomp!1<<comp
return
finish
connect(s, 0, 0, 0, r, flag)
if flag#0 then fail(failure message(flag)) and return
if r_dataend<=r_datastart then printstring(" ".s." is an empty file".snl) and return
if r_filetype#3 then printstring(" warning - ".s." is not a character file".snl)
cbeg(comp) = r_conad+r_datastart
clen(comp) = r_dataend-r_datastart
dbitcomp = dbitcomp!1<<comp
return
fails:
dbitcomp = dbitcomp&(~(1<<comp))
end ; !OF LOCATE COMPONENT
routine locate message(string (63) t, integer name fno, mno, offset)
string (255) s
string (63) u
integer count, save f, save m
offset = 0
if t->s.("(").u.(")") start
t = s
open folder(u, fno)
if fno=0 then return
if t="" then t = "CURRENT"
save f = current folder; save m = current msg
note current folder(fno)
message list(t, count, s)
note current folder(save f)
current msg = save m
else
fno = current folder
if t="" then t = "CURRENT"
message list(t, count, s)
finish
mno = msg list(1)
if s#"" then printstring(s) and return
if count=0 or mno=0 then fail("message? ".t) and return
ff == record(fconads(fno))
offset = fconads(fno)+ff_msg no(mno)_offset&offset mask
mm == record(offset)
end ; !OF LOCATE MESSAGE
integer fn lookup component(string (255) s)
string (255) t
integer i
if s->s.(":") then start
finish
for i = 1, 1, distinct components cycle
if start of(uc comp name(i), s, t)=1 then result = i
repeat
err = " ".s." - invalid component name"
while length(s)>1 cycle
length(s) = length(s)-1
for i = 1, 1, distinct components-1 cycle
if start of(uc comp name(i), s, t)=1 then c
err = err.", '".lc comp name(i)."' intended??".snl and result = -1
repeat
repeat
err = err.snl
result = 0
end ; !OF LOOKUP COMPONENT
integer fn find alias(string (255) s)
integer link
if length(s)>23 then result = 0
link = p_alias head
while link#0 cycle
if alist(link)_name=s then result = link
link = alist(link)_alink
repeat
result = 0
end ; !OF FIND ALIAS
routine replace aliases(integer name st, len)
integer first, last, changed, i, l, pos, brackets, outstart, link
string (255) str
integer fn room
integer i, j
i = outstart-1
j = dconad+d_end
while i>=j cycle
if byteinteger(i)=nl then exit
i = i-1
repeat
result = outstart-i-1
end ; !OF ROOM
first = st
last = st+len-1
outstart = dconad+d_end
pos = first
changed = 0
brackets = 0
while pos<=last cycle
for pos = pos, 1, last cycle
if byteinteger(pos)='(' then brackets = brackets+1 and continue
if byteinteger(pos)=')' and brackets>0 then brackets = brackets-1 and continue
if brackets=0 and byteinteger(pos)=',' then exit
repeat
if pos=last then pos = last+1
l = pos-first
if l>255 then i = 255 else i = l
move(i, first, addr(str)+1)
length(str) = i
str = compress(str)
link = find alias(str)
if link=0 start
if changed#0 and room+l>60 then byteinteger(outstart) = nl and outstart = outstart+1
move(l, first, outstart)
outstart = outstart+l
else
changed = 1
while vlist(link)_link#0 cycle
link = vlist(link)_link
str = vlist(link)_name.","
i = room
if i+length(str)>60 then str = snl.str else start
if i#0 then str = " ".str
finish
move(length(str), addr(str)+1, outstart)
outstart = outstart+length(str)
repeat
outstart = outstart-1
finish
while pos<last and (byteinteger(pos)=',' or byteinteger(pos)<=' ') cycle
byteinteger(outstart) = byteinteger(pos)
outstart = outstart+1
pos = pos+1
repeat
first = pos
repeat
if changed#0 start
st = dconad+d_end
len = outstart-st
d_end = d_end+len
finish
end ; !OF REPLACE ALIASES
routine compose message(integer name flag)
integer len, i, conad, pos, j, c, k, fin
const byte integer array ad field(1:5)= to, cc, bcc, reply to, ack to
if p_alias head#0 start
for j = 1, 1, 5 cycle
i = ad field(j)
if dbitcomp>>i&1=1 start
check workfile(clen(i)+1024, flag)
if flag#0 then return
replace aliases(cbeg(i), clen(i))
finish
repeat
finish
len = 40
dbitcomp = dbitcomp&valid local comp
for i = max components, -1, 1 cycle
if dbitcomp>>i&1=1 then len = len+clen(i)+length(component name(i))+1
repeat
if len>max msg size then fail("message file too big") and flag = 1 and return
outfile("M#MSG", len, 0, tempfile, conad, flag)
if flag#0 then fail(failure message(flag)) and return
ff == record(conad)
pos = ff_start+conad
for i = 2, 1, max components cycle
c = order(i)
if dbitcomp>>c&1=1 start
for j = cbeg(c)+clen(c)-1, -1, cbeg(c) cycle
if byteinteger(j)=nl then clen(c) = clen(c)-1 else exit
repeat
if clen(c)<=0 then dbitcomp = dbitcomp&(~(1<<c)) and continue
string(pos) = component name(c)
j = pos+byteinteger(pos)+1
byteinteger(pos) = nl
if c#body start
fin = cbeg(c)+clen(c)-1
for k = cbeg(c), 1, fin cycle
byteinteger(j) = byteinteger(k)
j = j+1
if byteinteger(k)=nl and k#fin and byteinteger(k+1)#' ' then byteinteger(j) = ' ' and j = j+1
repeat
if byteinteger(j-1)=',' then pos = j-1 else pos = j
else
move(clen(c), cbeg(c), j)
pos = j+clen(c)
finish
finish
repeat
ff_end = pos-conad
end ; !OF COMPOSE MESSAGE
routine dispatch message
string (63) s
record (rf) r
integer flag, i, j
if mailer awake=yes start
s = "MAILSERVER POST M#MSG,32,".itos(ff_end-32).",M#REPORT"
disconnect("M#MSG", flag)
pa = 0
pa_flag = dpermission(myprocess, "MAILER", "", "M#MSG", myfsys, 2, 3)
if pa_flag#0 start
fail(derrs(pa_flag))
else
flag = dmail(pa, length(s), addr(s)+1)
if 0<flag<501 then printstring("Director DMAIL error ".derrs(flag).snl)
finish
if pa_flag#0 start
printstring("Fault - ")
if 500<=pa_flag<=max mailer flags then printstring(mailer flags(pa_flag)." ") else c
printstring(derrs(flag))
if pa_bad bitcomp#0 start
j = outpos
for i = max components, -1, 1 cycle
if pa_bad bitcomp>>i&1=1 start
if j#outpos then printstring(", ")
if outpos+length(lc comp name(i))>72 then newline
printstring(lc comp name(i))
finish
repeat
finish
newline
if pa_flag=error report start
connect("M#REPORT", 0, 0, 0, r, flag)
if flag=0 start
for i = r_conad+r_datastart+1, 1, r_conad+r_dataend-1 cycle
printsymbol(byteinteger(i))
repeat
newline
finish
if target#2900 then disconnect("M#REPORT", flag)
finish
destroy("M#REPORT", flag)
finish
finish else pa_message count = 0
if fn=discard then return
if pa_message count=0 start
if dest f=0 then s = "" else s = " or filed"
printstring("Not sent".s.snl)
else
if dest f=0 then s = "" else start
s = " and filed"
if f type#not bboard type and dest f=1 then s = s." (in ".default folder.")"
finish
printstring("Message sent".s.snl)
finish
end ; !OF DISPATCH MESSAGE
routine do scan(string (255) msgs)
string (255) s
integer i
message list(msgs, i, s)
if i#0 start
fscan(i)
if i>1 then s = "each " else s = ""
prompt("<return> to list ".s."message".crlf.crlf."Mail:"); !temp temp temp
i = nextch; !force out prompt)
finish
end ; !of do scan
routine message list(string (255) msgline, integer name count, string name s)
const byte integer non terminal= 0,stack end = 1,or = 2
const byte integer and= 3,not = 4,open bracket = 5
const byte integer close bracket= 6,identifier = 7
byte integer direction, draft wanted
integer i, j, k, p count, table base, sp, mark, n bytes, list, tlist
integer toplist, worktop, sign, mult
const integer n mess= 10
string (71) array e(1:n mess)
string (120) s1, s2, err string
const string (12) syntax f msg= " - syntax ??"
const string (34) array emess(1:n mess)=
"No messages in folder",
"invalid message keyword",
"message ¬ is last in folder",
"invalid message range",
"no ¬ messages in folder",
"message 1 is first in folder",
"current message is first in folder",
"current message is last in folder",
"invalid message component",
"no text specified"
record format stack f(byte token, integer list)
record (stack f) array stack(1:20)
byte integer array msg toks, polish toks(1:120)
byte integer array table(identifier:127)
routine tokenise; ! Put tokens from 'msgline' into 'msgtoks'
integer ptr, pos, tp
byte state, op
string (120) tok, cont
integer fn install(string (120) what)
byte integer result
result = pos
string(table base+pos) = what
pos = pos+table(pos)+1
result = result
end
string fn next token
const byte blank= 7,lett dig = 8,quote = 9,special = 10,rest = 11
const byte array class(' ':'~')= c
blank,rest,quote,rest(3),and,rest,open bracket,close bracket,
rest(2),or,rest(3),lett dig(10),rest(7),lett dig(26),
rest(6), lett dig(26),rest(3),not
const byte array fsm(blank:rest, 0:2)= { Finite State Machine tables} c
16_00, 16_11, 16_20, 16_02, 16_11,{| startup} c
16_04, 16_11, 16_03, 16_03, 16_11,{| build atom} c
16_21, 16_21, 16_04, 16_21, 16_21 {| build quoted string}
{ ----------------------------------------+-------------------}
{ blank lettdig quote special rest |}
byte act, char, cl
string (120) str
switch sw(0:4)
str = ""
cycle
ptr = ptr+1
if ptr>length(msgline) then ->sw(4)
char = charno(msgline, ptr)
unless ' '<=char<='~' then ->sw(4)
cl = class(char)
if cl<blank then op = cl and cl = special
act = fsm(cl, state)&16_F { First nybble = act}
state = fsm(cl, state)>>4 { 2nd " = state}
->sw(act)
sw(0):
! do nothing
continue
sw(1):
! concat chars
str = str.tostring(char)
continue
sw(2):
! return special
result = tostring(char)
sw(3):
! rescan and return
ptr = ptr-1
sw(4):
! return
if str="AND" then op = and and str = "&" else if str="OR" then op = or and str = "," else if c
str="NOT" then op = not and str = "~" else op = identifier
result = str
repeat
end ; ! Of next token
{ tokenise begins }
length(msgline) = length(msgline)-1 while charno(msgline, length(msgline))=',' and length(msgline)>1
return if msgline=","
msgline = substring(msgline, 2, length(msgline)) while charno(msgline, 1)=','
state = 0; pos = identifier; tp = 0
ptr = 0; cont = ""; err string = ""
cycle
tok = nexttoken; err string = err string.tok
if op=identifier then cont = cont.tok and continue { Normal string }
if cont#"" start { we have an operator here }
tp = tp+1 { first install any string in cont }
msgtoks(tp) = install(cont)
cont = ""
finish
tp = tp+1 and msgtoks(tp) = op
repeat until ptr>=length(msgline)
tp = tp+1 and msgtoks(tp) = install(cont) unless cont=""
msgtoks(tp+1) = stack end
end ; ! OF TOKENISE
{ Take infix expression from 'msgtoks' & output polish expression in 'polishtoks'}
integer function to polish
integer i, j, k
byte integer r, q, flag
byte integer array s(1:120)
integer fn prec(byte integer i, j)
const byte integer array precs(stack end:identifier, stack end:identifier)= c
{ # |} '=' , '>' , '>' , '>' , '>' , '>' , '>',
{ , |} '<' , '>' , '>' , '>' , '<' , '>' , '>',
{ & |} '<' , '<' , '>' , '>' , '<' , '>' , '>',
{ ~ |} '<' , '<' , '<' , '<' , '<' , 'x' , 'x',
{ ( |} '<' , '<' , '<' , '<' , '<' , 'x' , 'x',
{ ) |} '<' , '>' , '>' , '>' , '=' , '>' , '>',
{ id|} '<' , '<' , '<' , '<' , '<' , 'x' , 'x'
{ | # , & ~ ( ) id }
if i>identifier then i = identifier
if j>identifier then j = identifier
result = precs(i, j)
end
s(1) = stack end
i = 1
k = 0
flag = 0
cycle
cycle { Looking for tail }
if flag=0 start
k = k+1
r = msgtoks(k)
if s(i)=non terminal then j = i-1 else j = i
finish ; flag = 0
result = k if prec(s(j), r)='x'
if prec(s(j), r)='>' then exit
i = i+1
s(i) = r
repeat
cycle { Looking for head }
q = s(j)
j = j-1
if s(j)=non terminal then j = j-1
if prec(s(j), q)='<' then exit
repeat
{ S(j+1)...S(i) is prime phrase }
if s(j+1)>=identifier start { Reduce to Non Terminal }
result = k if i#j+1
p count = p count+1
polishtoks(p count) = s(j+1)
finish else if s(j+1)=open bracket start { (N) -> N }
result = k if s(j+2)#non terminal or s(j+3)#close bracket or i#j+3
finish else if s(j+1)=not start { ~N }
result = k if s(j+2)#non terminal or i#j+2
p count = p count+1
polishtoks(p count) = not
else { N ! N / N & N }
result = k if s(j+1)#non terminal or or#s(j+2)#and or s(j+3)#non terminal or i#j+3
p count = p count+1
polishtoks(p count) = s(j+2) { operator }
finish
i = j+1
s(i) = non terminal
exit if i=2 and r=stack end
flag = 1
repeat
result = 0 { Normal success }
end ; ! OF TO POLISH
routine decode(integer list, string (100) line)
integer type, i, j, k, m, adr, c, fp, range, stype, dr0, dr1
record (m structure f) name mm
const string (1) array symb(1:4)= "-",">","=","#"
const integer n relkeys= 4
const string (8) array relkey(1:n relkeys)= "NEXT","LAST",
"PREVIOUS","FIRST"
const integer n keys= 11
const string (9) array key(0:n keys)=
"DRAFT","NEW","CURRENT","NEXT","LAST","PREVIOUS","ALL",
"OLD","SAVED","DISCARDED","UNSEEN","FIRST"
const byte integer array value(0:n keys)= c
0,'n',0,0,0,0,0,' ','s','x','u',0
switch swtype(0:4)
switch relsw(1:5)
routine err(string (120) s, integer type)
if e(type)="" then e(type) <- s else e(type) <- e(type).", ".s
end ; !OF ERR
routine add(integer no) { adds individual elements to bitmap }
integer i
i = list+no>>3 { i= address of byte }
byte integer(i) = byte integer(i)!1<<(no&2_111)
end ; !OF ADD
integer fn keyword code(string (120) kword)
integer i
cycle i = 0, 1, nkeys
if start of(key(i), kword, s1)=1 then result = i
repeat
err(kword, 2)
result = -1
end
integer fn no or keyword(string (120) s)
integer i
switch ksw(-1:nkeys)
i = pstoi(s)
unless i<0 start
if i>f_n msgs then err(s, 3) and result = f_n msgs
result = i
finish
i = keyword code(s)
->ksw(i)
ksw(2):
! current
result = current msg
ksw(3):
! next
if current msg=f_n msgs then err(key(i), 8) and result = -1
result = current msg+1
ksw(4):
! last
result = f_n msgs
ksw(5):
! previous
if current msg=1 then err(key(i), 7) and result = -1
result = current msg-1
ksw(11):
! first
result = 1
ksw(*):
! all others
err(line, 4)
ksw(-1):
! fault
result = -1
end ; !OF NO OR KEYWORD
routine interpret keyword(string (255) kword)
integer kw, i
byte flag
switch sw(-1:nkeys)
kw = keyword code(kword)
->sw(kw)
sw(0):
! draft
add(0)
draft wanted = yes
return
sw(2):
! current
add(current msg)
return
sw(3):
! next
if current msg=f_n msgs then err(key(kw), 8) else add(current msg+1)
return
sw(4):
! last
add(f_n msgs)
return
sw(5):
! previous
if current msg=1 then err(key(kw), 7) else add(current msg-1)
return
sw(6):
! all
fill(n bytes, list, 16_FF)
return
sw(11):
! first
add(1)
return
sw(1):
! new
sw(7):
! old
sw(8):
! saved
sw(9):
! discarded
sw(10):
! unseen
flag = 0
cycle i = 1, 1, f_n msgs
if value(kw)=f_msg no(i)_status then add(i) and flag = 1
!ONE SUCCESS
repeat
if flag=0 then err(key(kw), 5)
sw(-1):
! fault
end ; !OF INTERPRET KEYWORD
{ decode begins}
i = pstoi(line)
if i>0 start
if i>f_n msgs then err(line, 3) else add(i)
return
finish
for type = 4, -1, 1 cycle
if line->s1.(symb(type)).s2 then ->swtype(type)
repeat
s1 = line; !TRY FOR KEYWORD(+n)
for i = 1, 1, length(line) cycle
if '0'<=charno(line, i)<='9' start
s2 = substring(line, i, length(line))
k = pstoi(s2)
if k>0 then length(s1) = i-1 and ->swtype(0)
exit
finish
repeat
interpret keyword(line); !KEYWORD ALONE
return
swtype(0):
!KEYWORD+NUMBER
for i = 1, 1, n relkeys cycle
if start of(relkey(i), s1, s2)=1 then ->relsw(i)
repeat
err(line, 2)
return
relsw(1):
!NEXT nn
if current msg=f_n msgs then err(line, 8) and return
i = current msg+1
j = current msg+k
->relsw(5)
relsw(2):
!LAST nn
j = f_n msgs
i = j-k+1
->relsw(5)
relsw(3):
!PREVIOUS nn
if current msg=1 then err(line, 7) and return
i = current msg-k
j = current msg-1
->relsw(5)
relsw(4):
!FIRST nn
i = 1
j = k
relsw(5):
!NOTE MSGS
if i<1 then i = 1
if j>f_n msgs then j = f_n msgs
add(k) for k = i, 1, j
return
swtype(2):
!RANGE N>M
direction = 1 { ascending order }
swtype(1):
!RANGE N-M
if s1="" or s2="" then err(line, 4) and return
i = no or keyword(s1)
j = no or keyword(s2)
if i<0 or j<0 then return
if type#1 then type = -1
if (i-j)*type>0 then err(line, 4) and return
add(k) for k = i, type, j
return
swtype(3):
!MATCH C=STRING
swtype(4):
!MATCH C#STRING
c = lookup component(s1)
s1 = " " if s1=""
if c<=0 then err(s1, 9) and return
if length(s2)=0 then fp = 1 else start
if target=2900 then k = 32<<8!charno(s2, 1) {+case mask} else k = charno(s2, 1)
finish
stype = x'58000000'; !STRING DESCRIPTOR
for m = 1, 1, f_n msgs cycle
adr = fconads(current folder)+f_msg no(m)_offset&offset mask
mm == record(adr)
if length(s2)=0 start
if mm_bitcomp>>c&1=0 then range = 1 else range = 0
else
if mm_bitcomp>>c&1=0 then continue
fp = mm_c(c)_beg+adr
if target=2900 start
range = fp+mm_c(c)_len-1
until fp>range cycle
i = range-fp-length(s2)+2
if i>0 then start
*ldtb_stype
*ldb_i; !LENGTH
*lda_fp; !START
*lb_k; !REQUIRED CHAR
*swne_ l = dr
*jcc_4, <f83>; !FOUND ->
finish
fp = range+1; !SET TO BOTTOM
exit ; !NOT FOUND
f83:
!NOW COMPARE WITH TEXT
*std_dr0; !STORE DESC
fp = dr1
for i = 1, 1, length(s2) cycle
if charno(s2, i)#ltou(byteinteger(fp+i-1)) then ->f85
repeat
exit
f85:
!MATCH FAILS
fp = fp+1
repeat
else
range = fp+mm_c(c)_len-1-length(s2)+1
until fp>range cycle
if k=ltou(byteinteger(fp)) start
for j = 2, 1, length(s2) cycle
if charno(s2, j)#ltou(byteinteger(fp+j-1)) then ->f85
repeat
exit ; !successful
finish
f85:
fp = fp+1
repeat
finish
finish
if fp<=range start
if type=3 then add(m); !EQUALS
else
if type=4 then add(m); !NOT EQUALS
finish
repeat
end ; ! OF DECODE
integer function next free list
integer i
toplist = toplist+1
i = worktop+toplist*n bytes
fill(n bytes, i, 0) { zero array }
result = i
end
routine operate on lists(byte op, integer list1, list2)
if target=2900 start
if op=and start
*ldtb_16_18000000; !DESCRIPTOR AND...
*ldb_n bytes; !...BOUND
*lda_list2; !START OF SECOND 'STRING'
*cyd_0; !PUT IN ACC
*lda_list1; !START OF FIRST 'STRING'
*ands_ l = dr ; !AND STRINGS
else
*ldtb_16_18000000
*ldb_n bytes
*lda_list2
*cyd_0
*lda_list1
*ors_ l = dr ; !OR STRINGS
finish
else
integer i
cycle i = 0, 1, n bytes-1
if op=or then byte integer(list1+i) = byte integer(list1+i)!byte integer(list2+i) else c
byte integer(list1+i) = byte integer(list1+i)&byte integer(list2+i)
repeat
finish
end
routine negate(integer list)
if target#2900 start
integer i
cycle i = 0, 1, n bytes-1
byte integer(list+i) = ~byte integer(list+i)
repeat
else
*ldtb_16_18000000
*ldb_n bytes
*lda_list
*neqs_ l = dr , 0, 255; !NEGATE EACH BYTE
finish
end
{ message list begins}
s = ""; count = 0
return if msgline=""
fail("folder?") and return if current folder=0
check workfile(epagesize, i)
if i#0 then return
n bytes = f_n msgs//8+1
worktop = dconad+d_end
msg list == array(worktop+(n bytes+1)&x'fffffffe', msglist f) { word aligned }
if f_n msgs=0 start { only draft allowed }
if startof("DRAFT", msgline, s1)=0 then s = emess(1).snl and return
count = 1; msglist(1) = 0
return
finish
sp = 0; direction = 0 { ascending order }
p count = 0; draft wanted = no; toplist = -1
e(i) = "" for i = n mess, -1, 1
list = next free list
table base = addr(table(identifier))-identifier
tokenise
return if msgline=","
mark = to polish
if mark#0 then ->syntax fault
if pcount=1 then decode(list, string(table base+polish toks(1))) else start
cycle i = 1, 1, p count
if polish toks(i)>=identifier start
sp = sp+1
stack(sp)_token = polish toks(i)
stack(sp)_list = 0
else { Operator found }
if stack(sp)_list#0 start { Top stack is a listno }
if polish toks(i)=not then negate(stack(sp)_list) else if c
stack(sp-1)_list#0 start { Top 2 are lists }
operate on lists(polishtoks(i), stack(sp-1)_list, stack(sp)_list)
toplist = toplist-1; sp = sp-1
else { 1 list 1 string }
if polish toks(i)=and start
tlist = next free list
decode(tlist, string(table base+stack(sp-1)_token))
operate on lists(and, stack(sp)_list, tlist)
toplist = toplist-1 { recover space from tlist }
finish else decode(stack(sp)_list, string(table base+stack(sp-1)_token))
stack(sp-1)_list = stack(sp)_list
sp = sp-1
finish
else { stack top is not a list number }
if polish toks(i)=not start
decode(list, string(table base+stack(sp)_token))
negate(list)
stack(sp)_list = list
list = next free list
finish else if stack(sp-1)_list#0 start { 2nd is}
if polish toks(i)=and start
tlist = next free list
decode(tlist, string(table base+stack(sp)_token))
operate on lists(and, stack(sp-1)_list, tlist)
toplist = toplist-1
finish else decode(stack(sp-1)_list, string(table base+stack(sp)_token))
sp = sp-1
else { 2 'normal' token strings }
decode(list, string(table base+stack(sp-1)_token))
if polish toks(i)=and start
tlist = next free list
decode(tlist, string(table base+stack(sp)_token))
operate on lists(and, list, tlist)
toplist = toplist-1
finish else decode(list, string(table base+stack(sp)_token))
sp = sp-1
stack(sp)_list = list
list = next free list
finish
finish { Stack top not list }
finish { operator found }
repeat
finish
{ Translate from bit list to msg list }
if e(2)=""=e(9) and e(4)="" start
{ Dont output anything if there was an invalid keyword/component/ range}
byte integer(worktop) = byte integer(worktop)&16_FE!draft wanted
byte integer(worktop+f_n msgs>>3) = byte integer(worktop+f_n msgs>>3)&((2¬¬(f_n msgs&7+1))-1)
if direction=0 then { ascending } sign = 1 and mult = 0 else sign = -1 and mult = 1
cycle i = (n bytes-1)*mult, sign, (n bytes-1)*(1-mult)
continue if byte integer(worktop+i)=0
cycle j = 7*mult, sign, 7*(1-mult)
continue if byte integer(worktop+i)&(1<<j)=0
count = count+1
msg list(count) = j+i*8
repeat {j}
repeat {i}
finish
msgline = e(5)
msgline <- s1." or".s2 while msgline->s1.(",").s2
for i = 1, 1, n mess cycle
if e(i)#"" start
if 3#i#5 then s1 = emess(i) else start
emess(i) -> s1.("¬").s2
if i=3 then s1 <- s1.itos(f_n msgs).s2 else s1 <- s1.msgline.s2
finish
s <- s." ".e(i)." - ".s1.snl
finish
repeat
return
syntax fault:
k = 0
cycle i = 1, 1, mark
if msgtoks(i)<identifier then k = k+1 else k = k+byte integer(table base+msgtoks(i))
repeat
s = err string.syntax f msg.snl
s = s." " for i = 1, 1, k-1
s = s."!".snl
count = 0 { zero count }
end ; !OF MESSAGE LIST
integer fn mailer awake
integer secs, flag
record (rf) rr
const integer safe from=6*60*60; !6 am
const integer safe to=(23*60+59)*60
secs = current secs
secs = secs-(secs//secs in 24 hrs)*secs in 24 hrs
unless safe from<=secs<=safe to start
if name file conad=0 start
connect("MAILER".usep.snamefile, read shared, 0, 0, rr, flag)
name file == record(rr_conad)
finish else flag = 0
if flag=0 and name file_datetime#0 then result = yes
finish else result = yes; !safe period
printstring(" - mailer housekeeping, try later".snl)
disconnect("MAILER".usep.snamefile, flag)
disconnect("MAILER".usep.addrfile, flag)
name file conad = 0
result = no
end ; !of mailer awake
integer fn preserve draft(integer folder no)
integer i, fin, st
if dbitcomp=0 then result = 0
if folder no>0 start
st = fconads(folder no)
fin = st+integer(st)
finish else fin = dconad+256<<10
for i = max components, -1, 1 cycle
if dbitcomp>>i&1=1 start
if (folder no>0 and st<cbeg(i)<=fin) or (folder no<0 and (cbeg(i)<dconad or cbeg(i)>fin)) start
check workfile(clen(i), flag)
if flag#0 then result = flag
move(clen(i), cbeg(i), d_end+dconad)
cbeg(i) = d_end+dconad
d_end = d_end+clen(i)
finish
finish
repeat
result = 0
end ; !OF PRRESERVE DRAFT
routine draft to msg(integer folder no, secs, type, integer name flag)
string (63) current dt
integer len, nc, i, ad, c, j, st
if secs=0 then secs = current secs else start
current dt = secs to dt(secs)
cbeg(cdate) = addr(current dt)+1
clen(cdate) = length(current dt)
dbitcomp = dbitcomp!(1<<cdate)
finish
len = 1
nc = 0
for i = max components, -1, 1 cycle
if dbitcomp>>i&1=0 then continue
len = len+clen(i)+length(component name(i))+1
if nc=0 then nc = i
repeat
len = 24+nc*8+len
flag = accommodate message(len, secs, type, folder no, "")
if flag#0 then return
ad = addr(moved m_c(nc))+8
st = addr(moved m_marker)
for i = 2, 1, max components cycle
c = order(i)
if dbitcomp>>c&1=1 start
string(ad) = component name(c)
j = ad+byteinteger(ad)+1
byteinteger(ad) = nl
move(clen(c), cbeg(c), j)
moved m_c(c)_beg = j-st
moved m_c(c)_len = clen(c)
ad = j+clen(c)
finish
repeat
moved m_bitcomp = dbitcomp
end ; !OF DRAFT TO MSG
integer fn msg to draft(string (63) line)
integer fno, mno, offset, i
string (63) rest
if start of(drstring, line, rest)=1 then result = 0
if draft overwritable=no then result = 1
locate message(line, fno, mno, offset)
if offset=0 then result = 1
d_end = d_start
dbitcomp = mm_bitcomp
for i = max components, -1, 1 cycle
if dbitcomp>>i&1=1 start
cbeg(i) = mm_c(i)_beg+offset
clen(i) = mm_c(i)_len
finish
repeat
if fno=current folder then current msg = mno
result = 0
end ; !OF MSG TO DRAFT
integer fn draft overwritable
integer i
string (255) line, rest
if dbitcomp=0 or p_overwrite=0 then result = yes
printstring("OK to overwrite draft? ")
terminate
prompt(":")
i = nextch; !force out prompt
prompt("Please reply Y or N :")
cycle
readnext(line)
line = compress(line)
if startof(yesstring, line, rest)=yes then result = yes
if startof(nostring, line, rest)=yes then result = no
repeat
end ; !OF DRAFT OVERWRITABLE
routine incorporate messages
record (rf) r
record (frecf) array pf(0:pfmax-1)
integer filenum, maxrec, nfiles, flag, i, m size, dt, j
string (8) num
filenum = 0
maxrec = pfmax
if target=2900 start
flag = dfilenames(myprocess, pf, filenum, maxrec, nfiles, myfsys, 0)
else
flag = dfilenames(myprocess, filenum, maxrec, nfiles, myfsys, 0, pf)
finish
if flag#0 then fail(derrs(flag)) and return
for i = 0, 1, (maxrec-1) cycle
if length(pf(i)_name)=10 and start of(pf(i)_name, "M#", num)=1 start
dt = h to i(num)
if dt#0 start
connect(pf(i)_name, 0, 0, 0, r, flag)
if flag#0 then fail(failure message(flag)) and return
mail file == record(r_conad)
m size = mail file_end-16
flag = accommodate message(msize, dt, 'n', current folder, pf(i)_name)
if flag#0 then return
move(m size-16, r_conad+32, addr(moved m_bitcomp))
for j = max components, -1, 1 cycle
if moved m_bitcomp>>j&1=1 then moved m_c(j)_beg = moved m_c(j)_beg-16
repeat
if target#2900 then disconnect(pf(i)_name, flag)
destroy(pf(i)_name, flag)
finish
finish
repeat
f_acc pend = no; !'accept' was fully processed
end ; !OF INCORPORATE MESSAGES
integer fn accommodate message(integer size, dt, type, folder no, string (11) file)
record (rf) r
record (folder f) name ff
record (folder f) name temp f
integer flag, n mess, newsize, i, j
if check write access(folder no)#0 then result = bad access
size = ((size+7)>>3)<<3
ff == record(fconads(folder no))
if ff_max msgs=ff_n msgs start
n mess = ff_n msgs+ff_n msgs>>2; !INCREASE BY 25%
if n mess>max messages start
if ff_max msgs=max messages then fail("Folder full") and result = 1
n mess = max messages
finish
flag = preserve draft(folder no)
if flag#0 then result = flag
newsize = ff_end+(n mess-ff_max msgs)*8+size
newsize = (newsize+epage size-1)&(-epage size)
flag = create folder("T#MAIL", newsize, n mess)
if flag#0 then result = 1
temp f == record(t conad)
move(ff_n msgs*8, addr(ff_msg no(1)), addr(temp f_msg no(1)))
temp f_n msgs = ff_n msgs
j = (n mess-ff_n msgs)*8
for i = temp f_n msgs, -1, 1 cycle
temp f_msg no(i)_offset = temp f_msg no(i)_offset+j
repeat
i = ff_end-ff_start
move(i, fconads(folder no)+ff_start, t conad+temp f_start)
temp f_end = temp f_start+i
newgen("T#MAIL", fnames(folder no), flag)
if flag=0 then connect(fnames(folder no), read write, 0, 0, r, flag)
if flag#0 start
fail(failure message(flag))
if folder no=current folder then stop
fconads(folder no) = 0
fnames(folder no) = ""
result = flag
finish
fconads(folder no) = r_conad
ff == record(r_conad)
if folder no=current folder then f == ff
else
if ff_end+size>ff_size start
newsize = (ff_end+size+epagesize-1)&(-epage size)
flag = dchsize(myprocess, fnames(folder no), myfsys, newsize>>10)
if flag#0 start
flag = preserve draft(folder no)
if flag#0 then result = flag
disconnect(fnames(folder no), flag)
flag = dchsize(myprocess, fnames(folder no), myfsys, newsize>>10)
if flag#0 and file#"" start
flag = dfstatus(myprocess, file, myfsys, 5, 0); !make temp
flag = dchsize(myprocess, fnames(folder no), myfsys, newsize>>10)
if flag#0 then i = dfstatus(myprocess, file, myfsys, 4, 0); !remove temp status
finish
if flag#0 then fail(derrs(flag))
connect(fnames(folder no), read write, 0, 0, r, i)
if i#0 start
fail(failure message(i))
if folder no=current folder then stop
fconads(folder no) = 0
fconads(folder no) = r_conad
result = flag
else
fconads(folder no) = r_conad
ff == record(fconads(folder no))
if folder no=current folder then f == ff
if flag#0 then result = flag
finish
finish
ff_size = newsize
finish
finish
i = ff_n msgs
ff_n msgs = ff_n msgs+1
while i>0 cycle
if ff_msg no(i)_dt<=dt then exit
ff_msg no(i+1) = ff_msg no(i)
i = i-1
repeat
moved m == record(fconads(folder no)+ff_end)
moved m_marker = marker
moved m_length = size
moved m_dt = dt
moved m_bitcomp = 0
ff_msg no(i+1)_dt = dt
ff_msg no(i+1)_offset = type<<24!ff_end
ff_end = ff_end+size
result = 0
end ; !OF ACCOMMODATE MESSAGE
routine read next(string name line)
integer i, j
skip symbol while next symbol=nl
line = ""
for i = 255, -1, 1 cycle
read symbol(j)
if j=nl then return
line = line.tostring(j)
repeat
end ; !OF READ NEXT
integer fn verify conad(string (31) file, integer conad)
integer flag
record (rf) r
if file="" then result = 0
connect(file, 0, 0, 0, r, flag)
if flag=0 and r_conad=conad then result = 0
result = 1
end ; !OF VERIFY CONAD
integer fn create folder(string (255) file, integer size, max msgs)
record (folder f) name cf
integer flag
outfile(file, size, 0, 0, t conad, flag)
if flag=0 start
cf == record(t conad)
cf_end = addr(cf_msg no(max msgs))-t conad+8
cf_start = cf_end
cf_size = size
cf_filetype = data filetype
cf_format = 3; !UNSTRUCTURED
cf_marker = marker
cf_max msgs = max msgs
cf_n msgs = 0
if file#"T#MAIL" start
printstring("Folder ".file." created".snl)
cherish(file)
finish
else
printstring("Create folder ".file." fails ".failure message(flag).snl)
finish
result = flag
end ; !OF CREATE FOLDER
integer fn free stream
integer i, stat
string (31) file
for i = 1, 1, 80 cycle
definfo(i, file, stat)
if stat=0 then result = i
repeat
result = 0
end
routine note current folder(integer folder no)
if f type#not bboard type and folder no#current folder start
!type of last current f
flag = preserve draft(current folder)
disconnect(fnames(current folder), flag)
fnames(current folder) = ""
finish
f type = not bboard type
return new = p_return new
current folder = folder no
fconad = fconads(current folder)
f == record(fconad)
current msg = f_n msgs
if current msg>0 then m == record(fconad+(f_msg no(current msg)_offset&offset mask))
end ; !OF NOTE CURRENT FOLDER
routine open folder(string (255) file, integer name folder no)
integer i, flag, empty, cmode
string (255) user, f
record (rf) r
record (folder f) name fo
if start of(fold string, file, f)=1 then folder no = current folder and return
i = 1
flag = 0
cmode = read write
folder no = 0
empty = 0
if file->user.(usep).f start
if user=myprocess then file = f else cmode = 0
finish
while i<=folders open cycle
if file=f names(i) then folder no = i and return
if empty=0 and fnames(i)="" then empty = i
i = i+1
repeat
if exist(file)=0 and cmode=read write start
flag = create folder(file, default folder size, default messages)
if flag#0 then return
finish
if folders open=max folders and empty=0 then flag = too many files else start
connect(file, cmode, 0, 0, r, flag)
if flag=bad access then cmode = 0 and connect(file, cmode, 0, 0, r, flag)
if flag=0 start
if r_filetype=data filetype and integer(r_conad+32)=marker start
if empty#0 then folder no = empty else folders open = folders open+1 and folder no = folders open
fconads(folder no) = r_conad
f names(folder no) = file
conmode(folder no) = cmode
if cmode=read write start
fo == record(r_conad)
for i = 1, 1, fo_n msgs cycle ; !TURN NEW INTO UNSEEN
if fo_msg no(i)_status='n' then fo_msg no(i)_status = 'u'
repeat
finish
return
finish else flag = invalid filetype and setfname(file)
finish
finish
printstring("Open ".file." fails - ".failure message(flag).snl)
end ; !OF OPEN FOLDER
integer fn check write access(integer folder no)
string (31) s1, s2
if conmode(folder no)#read write or fnames(folder no)->s1.("_").s2 start
fail("cannot write to folder ".fnames(folder no))
result = bad access
finish
result = 0
end ; !OF CHECK WRITE ACCESS
integer fn check overwrite(string (255) file)
record (rf) r
integer i
string (255) a, b
if file="" then result = 0
if charno(file, 1)='.' start
if devcode(file)<=0 and file#".OUT" then fail("invalid device name ".file) and result = 1
result = 0
finish
if file->a.(usep).b start
if length(a)#6 then fail("invalid username ".a) and result = 1
if a#myprocess then fail("cannot overwrite ".file) and result = 1
finish
if file->a.("_").b then fail("cannot write to pdmember") and result = 1
if exist(file)=0 then result = 0
connect(file, 3, 0, 0, r, i); !write mode
if i#0 then fail(failuremessage(i)) and result = 1
if integer(r_conad+32)=marker then fail("cannot overwrite folder ".file) and result = 1
if integer(r_conad+12)=6 then fail("cannot overwrite pdfile ".file) and result = 1
if target#2900 then disconnect(file, i); !for use counts
result = 0
end ; !OF CHECK OVERWRITE
routine fail(string (255) mess)
printstring("Fails - ".mess.snl)
end ; !OF FAIL
integer fn h to i(string (8) num)
integer res, i
res = 0
for i = addr(num)+1, 1, addr(num)+8 cycle
if '0'<=byteinteger(i)<='9' then res = res<<4!(byteinteger(i)-'0') else start
if 'A'<=byteinteger(i)<='F' then res = res<<4!(byteinteger(i)+10-'A') else result = 0
finish
repeat
result = res
end ; !OF H TO I
routine f scan(integer count)
integer i, j, adr, field, c, l
string (255) s, rest
routine out(integer from, len, max)
integer i, till, maxtill
till = from+len-1
from = from+1 while from<till and byteinteger(from)=' '
maxtill = from+max-1
if till>maxtill then till = maxtill
for i = from, 1, till cycle
printsymbol(byteinteger(i)) unless byteinteger(i)<31
repeat
end ; !OF OUT
unless ssmp possible=yes and ssmp on=yes then newline
for i = 1, 1, count cycle
if msg list(i)>0 start
adr = fconads(current folder)+f_msg no(msg list(i))_offset&offset mask
mm == record(adr)
printsymbol(f_msg no(msg list(i))_status); !STATUS
write(msg list(i), 3)
if msg list(i)=current msg then printstring("<=") else spaces(2)
if mm_bitcomp>>body&1=1 then j = mm_c(body)_len else j = 0
s = "(".itos(j).")"
spaces(7-length(s))
printstring(s." ")
if mm_bitcomp>>cdate&1=1 start
j = mm_c(cdate)_len
j = 255 if j>255
move(j, mm_c(cdate)_beg+adr, addr(s)+1)
length(s) = j
if s->rest.(",").s start ; finish
out(addr(s)+1, length(s), 6)
finish
spaces(26-outpos)
for c = from, 3, to cycle
if mm_bitcomp>>c&1=1 start
j = mm_c(c)_len
if j>255 then j = 255
move(j, mm_c(c)_beg+adr, addr(s)+1)
length(s) = j
if c=to then printstring("To: ") and field = 12 else field = 16
l = mm_c(c)_len
if s->s.("<").rest or s->s.(" at ").rest start
rest = compress(s)
if length(rest)>0 then l = length(s)
finish
out(mm_c(c)_beg+adr, l, field)
exit
finish
repeat
spaces(45-outpos)
if mm_bitcomp>>subject&1=1 then out(mm_c(subject)_beg+adr, mm_c(subject)_len, 72-outpos) else start
if mm_bitcomp>>body&1=1 start
printstring("(""")
out(mm_c(body)_beg+adr, mm_c(body)_len, 67-outpos)
printstring("..."")")
finish
finish
else ; !DRAFT
printstring("draft ")
if dbitcomp>>body&1=1 then j = clen(body) else j = 0
s = "(".itos(j).")"
spaces(7-length(s))
printstring(s." ")
if dbitcomp>>cdate&1=1 then out(cbeg(cdate), clen(cdate), 6)
spaces(26-outpos)
if dbitcomp>>to&1=1 start
printstring("To: ")
out(cbeg(to), clen(to), 12)
finish
spaces(45-outpos)
if dbitcomp>>subject&1=1 then out(cbeg(subject), clen(subject), 72-outpos) else start
if dbitcomp>>body&1=1 start
printstring("(""")
out(cbeg(body), clen(body), 67-outpos)
printstring("..."")")
finish
finish
finish
newline
repeat
newline
end ; !OF FSCAN
routine f list(integer first, count)
integer i, j, k, or, adr, offset, line count, counting, pagesize, char
long integer l bitcomp
record (m structure f) name mm
string (12) dis
string (63) s
const integer list size= 28
const byte integer array l order(1:list size)= c
subject,from,sender,reply to,to,cc,bcc,comments,in reply to,
keywords,folder,references,ack to,via,via2,via3,via4,via5,via6,
after,messid,user1,user2,user3,user4,user5,user6,body
routine spec reset status
on event 9 start
k = iocp(12, 0)
if msg list(i)#0 and uinfs(4)="more..." then reset status
if i=count or uinfs(4)="next..." or char#25 then newline and return ; !last msg or between msgs
f list(i+1, count)
return
finish
routine reset status
if offset>>24='n' or offset>>24='u' start
if conmode(current folder)=read write then f_msg no(current msg)_status = ' '
finish
if f type>0 start
if pr bb_entry(f type)_dt last<f_msg no(current msg)_dt then c
pr bb_entry(f type)_dt last = f_msg no(current msg)_dt and bb access = 1
finish
end
routine out(integer st, len)
integer i, j, k
j = st+len-1
if or#body start
for i = st, 1, j cycle
if byteinteger(i)>' ' then st = i and exit
repeat
finish
for i = st, 1, j cycle
printch(byteinteger(i))
if byteinteger(i)=nl start
if counting=yes start
if line count=pagesize start
line count = 2
prompt("more...")
char = next symbol
if char#nl then signal event 9, 0
char = 25; skip symbol
finish else line count = line count+1
finish
if or#body start
for k = 1, 1, 10 cycle
if i+k>=j or byteinteger(i+k)#' ' then exit
repeat
spaces(11-k)
finish
finish
repeat
end ; !OF OUT
pagesize = 24; !temp tempp
char = 25
if kent=0 and termtype>3 and fn#forward and (output="" or output=".OUT") and to terminal=yes then c
counting = yes else counting = no
for i = first, 1, count cycle
line count = 9
unless ssmp possible=yes and ssmp on=yes then newline
if plus dashes=1 start
for j = 72, -1, 1 cycle
printsymbol('_')
repeat
newlines(2)
else
if ssmp possible=yes and ssmp on=yes and i>1 start
sp set cursor(lastrow-5, 1)
newline
sp clear frame
finish
finish
if i>first and counting=yes start
prompt("next...")
char = next symbol
if char#nl then signal event 9, 0
char = 25; skip symbol
newline
finish
if msg list(i)#0 start
current msg = msg list(i)
offset = f_msg no(current msg)_offset
adr = fconads(current folder)+offset&offset mask
mm == record(adr)
l bitcomp = mm_bitcomp&list limit
if offset>>24='x' then dis = " - discarded" else dis = ""
if fn#forward then printstring("(Message ".itos(current msg).dis.")".snl)
for j = 1, 1, list size cycle
or = l order(j)
if or=from and l bitcomp>>from&1=0 start
if fn=forward start
s = mysurname." <".myprocess."@".this host.">"
printstring("From: ")
out(addr(s)+1, length(s))
newline
finish
or = cdate
finish
if l bitcomp>>or&1=1 start
if or=body then newline else start
printstring(lc comp name(or))
spaces(10-outpos) if outpos#0
finish
out(mm_c(or)_beg+adr, mm_c(or)_len)
if or=from and l bitcomp>>cdate&1=1 start
if outpos>32 start
newline
printstring("Date: ")
else
spaces(2)
spaces(32-outpos)
finish
k = mm_c(cdate)_len
if k=19 then k = 16
out(mm_c(cdate)_beg+adr, k)
finish
newline
finish
repeat
reset status
else
l bitcomp = dbitcomp&list limit
if post#fn#forward start
if l bitcomp#0 then printstring("(Draft message)".snl) else printstring("Draft message empty".snl)
finish
for j = 1, 1, list size cycle
or = l order(j)
if or=from and l bitcomp>>from&1=0 then or = cdate
if l bitcomp>>or&1=1 start
if or=body then newline else start
printstring(lc comp name(or))
spaces(10-outpos) if outpos#0
finish
out(cbeg(or), clen(or))
if or=from and l bitcomp>>cdate&1=1 start
if outpos>32 start
newline
printstring("Date: ")
else
spaces(2)
spaces(32-outpos)
finish
k = clen(cdate)
if k=19 then k = 16
out(cbeg(cdate), k)
finish
newline
finish
repeat
finish
repeat
end ; !OF F LIST
routine file to component(integer comp, retain, string (31) file)
integer flag, j
connect(file, 0, 0, 0, r, flag)
if flag=0 start
if byteinteger(r_conad+r_dataend-1)=nl then r_dataend = r_dataend-1
j = r_dataend-r_datastart
check workfile(j, flag)
if flag=0 start
if j>0 start
cbeg(comp) = dconad+d_end
clen(comp) = j
move(j, r_conad+r_datastart, cbeg(comp))
d_end = d_end+j
dbitcomp = dbitcomp!1<<comp
else
if retain=no then dbitcomp = dbitcomp&(~(1<<comp))
finish
finish
finish
end ; !OF FILE TO COMPONENT
routine get string(integer comp, string name s)
integer l, i
if dbitcomp>>comp&1=0 then s = "" and return
i = cbeg(comp)
l = i+clen(comp)-1
i = i+1 while i<=l and byteinteger(i)=' '
l = l-i+1
l = 255 if l>255
move(l, i, addr(s)+1)
length(s) = l
end ; !OF GET STRING
routine put string(integer comp, string name s)
if s="" then return
cbeg(comp) = dconad+d_end
clen(comp) = length(s)
move(clen(comp), addr(s)+1, cbeg(comp))
d_end = d_end+clen(comp)
dbitcomp = dbitcomp!1<<comp
end ; !OF PUT STRING
routine output component(string (255) comp, outdev, integer name flag)
integer c, from, len, i, j
string (255) msg, rest
const string (5) drstring= "DRAFT"
len = 0
flag = 1
comp -> comp.(":").msg
c = lookup component(comp)
if c<=0 then printstring(err) and return
if msg#"" and start of(drstring, msg, rest)=1 start ; !COMPONENT OF THE DRAFT
if dbitcomp>>c&1=1 start
from = cbeg(c)
len = clen(c)
finish
else
locate message(msg, i, j, offset)
if offset=0 then return
if mm_bitcomp>>c&1=1 start
from = mm_c(c)_beg+offset
len = mm_c(c)_len
finish
finish
if len=0 then printstring(" ".comp.":".msg." - component empty".snl) and return
unless charno(outdev, 1)='.' or 'A'<=charno(outdev, 1)<='Z' then c
printstring(" ".outdev." - invalid filename".snl) and return
j = free stream
define(itos(j).",".outdev)
if returncode#0 then return
selectoutput(j)
for i = from, 1, from+len-1 cycle
printsymbol(byteinteger(i))
repeat
newline
if ssmp possible=yes and ssmp on=yes then selectoutput(workframe) else selectoutput(saveoutstream)
closestream(j)
clear(itos(j))
flag = 0
end ; !OF OUTPUT COMPONENT
routine nameserver request(string (255) s, integer name flag)
destroy("M#DREPORT", flag)
pa = 0
flag = dmail(pa, length(s), addr(s)+1)
if error report#pa_flag#0 start
printstring("Fault - ")
if 500<=pa_flag<=max mailer flags then printstring(mailer flags(pa_flag)) else printstring(derrs(flag))
newline
finish
flag = pa_flag
end ; !OF NAMESERVER REQUEST
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
if m<10 then m = m+3 else m = m-9 and y = y+1
end ; ! of kdate
integer fn current secs
! gives current dt in new packed form
if target=2900 start
const long integer mill=1000000
*rrtc_0; *ush_-1
*shs_1; *ush_1
*imdv_mill
*isb_secs70; *stuh_ b
!*OR_X'80000000'
*exit_-64
else
result = (com_tojday-days70)*secsin24hrs+com_secsfrmn
finish
end
routine decwrite2(integer value, ad)
! writes value as two decimal iso digits into ad and ad+1
byte integer t, u
value = 99 if value>99
t = value//10
u = value-t*10+'0'
byteinteger(ad) = t+'0'
byteinteger(ad+1) = u
end ; ! of decwrite2
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
const string (3) array month(1:12)= c
"Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec"
at = addr(tim)
tim = "00:00:00"
m = p//60
h = m//60
secs = p-m*60
m = m-h*60
h = h-(h//24)*24
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
end ; !of secs to dt
string fn get zone
integer i, j, k, c secs
string (19) s
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
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
c secs = current secs
s = secs to dt(c secs)
k = (charno(s, 8)-'0')*10+charno(s, 9)-'0'
i = get fourth sunday(3, k); !in march
j = get fourth sunday(10, k); !in october
if i<=c secs<j then result = "bst" else result = "gmt"
end ; !of get zone
integer fn analyse dt after(string (255) datestring)
!! Analyses a string specifying when a message is to be delivered.
!! This routine based on DEC-10 code
integer msg day, msg month, msg year, msg minutes
!RESULTS OF ANALYSIS
integer pt, value, state, datestate, token, dateerror
integer secs now, days now, d, m, y, i
integer todays weekday, days from now
switch action(0:5)
switch subact(0:4)
const integer array mnemonic time value(0:5)= c
8*60,12*60,12*60,16*60,20*60,23*60+59
!! Breakfast, lunch, noon, tea, dinner, midnight
const byte integer array monthlength(1:12)= c
31,28,31,30,31,30,31,31,30,31,30,31
routine dateparse
!! Takes tokens from "datetoken" and tries to make sense of them
!! Transition table for parsing numeric/mnemonic months
!! States are across the top, syntactic classes are vertical
!! Class: 0 = number, 1 = time(number), 2 = month
const byte integer array datetab(0:5, 0:2)= c
1, 2, 2, 2, 0, 5,
4, 4, 4, 4, 5, 5,
3, 2, 5, 5, 3, 5
! 0 1 2 3 4 5
!! Action table for number/mnemonic date
const byte integer array dateact(0:5, 0:2)= c
1, 2, 3, 1, 5, 8,
4, 4, 4, 4, 8, 8,
6, 7, 8, 8, 7, 8
! 0 1 2 3 4 5
switch sw(0:8)
->sw(dateact(state, token))
sw(1):
!A PLAIN NUMBER IS A DATE
msg day = value
->sw(0)
sw(2):
!SECOND NUMBER IS A MONTH
msg month = value
->sw(0)
sw(3):
!YEAR
if value>99 then msg year = value else msg year = value+1900
->sw(0)
sw(4):
!HOURS
msg minutes = value*60
->sw(0)
sw(5):
!MINUTES
msg minutes = msg minutes+value
->sw(0)
sw(6):
!MONTH ALONE SETS DAY TO 1
msg day = 1
sw(7):
!MONTH AFTER DAY JUSTS SETS MONTH
msg month = value
->sw(0)
sw(8):
!ERROR
dateerror = 1
sw(0):
!DO NOTHING
state = datetab(state, token)
end ; !OF DATE PARSE
integer fn date token
!! This routine returns the next token from the input string.
!! Character classes:
!! 0 = space
!! 1 = A-Z
!! 2 = 0-9
!! 3 = (
!! 4 = )
!! 5 = : .
!! 6 = rest
!! 7 = end of string
const byte integer array class(' ':'Z')= c
0,6(7),3,4,6(4),5,6,2(10),5,6(6),1(26)
!! In the state transition table, these character classes are across the
!! top, the following states are vertical:
!! 0 = startup
!! 1 = scan till ")" or end
!! 2 = build keyword
!! 3 = build number
!! 4 = delete blanks
const byte integer array dateparsenext(0:7, 0:4)= c
0, 62, 62, 1, 63, 63, 63, 63,
1, 2, 3, 1, 4, 1, 1, 63,
1, 2, 1, 1, 1, 1, 1, 1,
1, 1, 3, 1, 1, 1, 1, 1,
4, 63, 63, 63, 63, 63, 63, 63
! sp A-Z 0-9 ( ) : rest end
!! Action table
const byte integer array dateparseact(0:7, 0:4)= c
0, 5, 5, 0, 5, 5, 5, 5,
0, 1, 2, 0, 0, 0, 0, 5,
6, 1, 6, 6, 6, 6, 6, 6,
3, 3, 2, 3, 3, 4, 3, 3,
0, 5, 5, 5, 5, 5, 5, 5
const string (9) array datekeyword(1:34)= c
"JANUARY","FEBRUARY","MARCH","APRIL","MAY","JUNE","JULY",
"AUGUST","SEPTEMBER","OCTOBER","NOVEMBER","DECEMBER",
"SUNDAY","MONDAY","TUESDAY","WEDNESDAY","THURSDAY","FRIDAY","SATURDAY",
"TODAY","TOMORROW","WEEK","MONTH","YEAR",
"BREAKFAST","LUNCH","NOON","TEA","DINNER","MIDNIGHT",
"AFTER","SINCE","AT","NEXT"
integer cl, char, act, i
string (255) str, rest
switch sw(0:6)
str = ""
value = 0
cycle
pt = pt+1
if pt>length(datestring) then cl = 7 else start
char = charno(datestring, pt)
if ' '<=char<='Z' then cl = class(char) else cl = 7
finish
act = dateparseact(cl, datestate)
datestate = dateparsenext(cl, datestate)
->sw(act)
sw(0):
!DO NOTHING
continue
sw(1):
!CONCATENATE CHAR
str = str.tostring(char)
continue
sw(2):
!BUILD DECIMAL NUMBER
value = value*10+char-'0'
continue
sw(3):
!RETURN NUMBER
pt = pt-1; !RESCAN CHAR
result = 0; !TOKEN = 0
sw(4):
!RETURN TIME SPEC
result = 1
sw(5):
!RETURN END OF DATE
pt = pt-1; !RESCAN CHAR
result = -1
sw(6):
!STRING - DECODE IT
pt = pt-1; !RESCAN CHAR
value = -1
for i = 34, -1, 1 cycle
if start of(datekeyword(i), str, rest)=1 start
if value#-1 then value = -2 and exit
value = i
finish
repeat
if value<0 start
if value=-1 then printstring("Unknown") else printstring("Ambiguous")
printstring(" date/time keyword: ".str.snl)
dateerror = -1
else
if value<13 then result = 2; !MONTH NAME
if value<20 then value = value-13 and result = 3
!TODAYS WEEKDAY
if value<25 then value = value-20 and result = 4
!MNEMONICDATE
if value<31 then value = value-25 and result = 5
!MNEMONIC TIME
finish ; !OTHERWISE NOISE
value = 0
str = ""
repeat
end ; !OF DATETOKEN
secs now = current secs
days now = secs now//secs in 24 hrs
kdate(d, m, y, days now+days70)
y = y+1900
msg day = d
msg year = y
msg month = m
msg minutes = 0
state = 0
datestate = 0
dateerror = 0
pt = 0
todays weekday = (days now-3)-((days now-3)//7)*7
days from now = 0
datestring <- "(".datestring.")"
cycle
token = datetoken
if token=-1 then exit
->action(token)
action(0):
!NUMBER
action(1):
!TIME
action(2):
!MONTH
dateparse
continue
action(3):
!TODAYS WEEKDAY
days from now = value-todays weekday
if days from now<=0 then days from now = days from now+7
continue
action(4):
!MNEMONIC DATES
->subact(value)
subact(0):
!TODAY
continue
subact(1):
!TOMORROW
days from now = 1
continue
subact(2):
!NEXT WEEK
days from now = 7-todays weekday
continue
subact(3):
!NEXT MONTH
msg month = msg month+1
msg day = 1
if msg month>12 then msg month = 1 and msg year = msg year+1
continue
subact(4):
!NEXT YEAR
msg year = msg year+1
msg day = 1
msg month = 1
continue
action(5):
!MNEMONIC TIMES
msg minutes = mnemonic time value(value)
repeat
if dateerror=0 and pt#length(datestring) then dateerror = 1
if dateerror#0 start
if dateerror#-1 then printstring("Faulty date/time specification".snl)
result = -1
finish
if msg minutes>=24*60 start
printstring("Invalid time in date/time specification".snl)
result = -1
finish
if days from now=0 start
unless 0<msg month<=12 start
printstring("Invalid month in date specification".snl)
result = -1
finish
i = monthlength(msg month)
if msg month=2 and msg year=(msg year>>2)<<2 then i = i+1
unless 0<msg day<=i start
printstring("Month has only ".itos(i)." days".snl)
result = -1
finish
if msg month>2 then msg month = msg month-3 else msg month = msg month+9 and msg year = msg year-1
i = 1461*(msg year-1900)//4+(153*msg month+2)//5+msg day+58-days70
result = i*secs in 24 hrs+msg minutes*60
else
if msg day#d or msg month#m or msg year#y start
printstring("Inconsistent date/time specification".snl)
result = -1
finish
result = (days now+days from now)*secs in 24 hrs+msg minutes*60
finish
end ; !OF ANALYSE DT AFTER
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
routine mycall(string (31) command, string (255) param)
call(command, param)
end ; !OF CALL
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 i, j
string (255) t
if length(s)=0 then result = ""
i = addr(s)
j = addr(t)+1
cycle i = i+1, 1, i+byteinteger(i)
byteinteger(j) = tab(byteinteger(i))
if byteinteger(j)#0 then j = j+1
repeat
length(t) = j-addr(t)-1
length(t) = 31 if length(t)>31
result = t
end ; !of compress
routine connect dbfile
record (rf) rr
integer flag, i, version
connect("MAILER".usep.dbfile, read shared, 0, 0, rr, flag)
if flag=0 start
db == record(rr_conad)
if target=2900 start
if db_bowner=myprocess start
disconnect("MAILER".usep.dbfile, flag)
connect("MAILER".usep.dbfile, read write!read shared, 0, 0, rr, flag)
if flag=0 then db == record(rr_conad) else set return code(flag) and stop
finish
finish
finish else printstring(" - bboards not currently available".snl)
if flag=0 start
db conad = rr_conad
btab == array(db conad+db_bboard offset, btable arf)
read profile(dbfile, pr bb, version, flag)
if flag#0 start
pr bb_no = 0
for i = 1, 1, max bb entries cycle
pr bb_entry(i)_bname = ""
repeat
finish
finish
end ; !of connect dbfile
routine bb scan(integer bb no, dt)
string (255) s
if dt<btab(bb no)_dt last addition then printstring("n ") else spaces(3)
printstring(btab(bb no)_bname)
spaces(20-outpos)
if btab(bb no)_folder=fnames(current folder) then s = "<= " else s = " "
s = s."(".itos(btab(bb no)_n msgs)." item"
if btab(bb no)_n msgs=1 then s = s.") " else s = s."s)"
s = " ".s while length(s)<14
printstring(s); spaces(4)
printstring(btab(bb no)_title)
newline
end ; !of bb scan
integer fn open bboard(string (31) bname, integer dt)
integer b, fno, i, n new
string (7) s1
string (1) s2
b = bb match(bname)
if b#0 start
if 0#dt>=btab(b)_dt last addition then result = 0
open folder(btab(b)_folder, fno)
if fno>0 start
note current folder(fno)
f type = 0; !unprofiled bboard
for i = 1, 1, pr bb_no cycle
if pr bb_entry(i)_bname=bname start
f type = i
if current msg#0 then dt = pr bb_entry(i)_dt last
exit
finish
repeat
return new = no
n new = 0
if f_n msgs>0 start
for i = 1, 1, f_n msgs cycle
if f_msg no(i)_dt>dt then current msg = i and n new = f_n msgs-i+1 and exit
repeat
else
if dt#0 then result = 0
finish
if n new=0 then s1 = "no" else s1 = itos(n new)
if n new=1 then s2 = "" else s2 = "s"
printstring(" - opening bboard '".btab(b)_bname."' (".s1." new message".s2.")".snl)
if n new>0 then do scan("CURRENT-LAST")
finish
result = fno
finish
result = 0
end ; !of open bboards
integer fn bb match(string (31) bname)
integer b
for b = 1, 1, db_n boards cycle
if bname=compress(btab(b)_bname) start
if 0#bb permitted(btab(b)_folder) then result = 0
result = b
finish
repeat
result = 0
end ; !of bb match
integer fn bb permitted(string (31) file)
integer prm, flag
string (31) owner
file -> owner.(usep).file
flag = dpermission(owner, myprocess, "", file, -1, 10, addr(prm))
if flag#0 or prm=0 then result = 32 else result = 0
end ; !of bb permitted
routine bb swop(integer one, two)
record (prb f) prb
prb = pr bb_entry(one)
pr bb_entry(one) = pr bb_entry(two)
pr bb_entry(two) = prb
end ; !of bb swop
string fn any bboard msgs(integer others)
integer i, j
if dbconad=0 then connect dbfile
if dbconad#0 start
for i = 1, 1, pr bb_no cycle
j = bb match(pr bb_entry(i)_bname)
if j>0 and pr bb_entry(i)_dt last<btab(j)_dt last addition start
if others=0 then result = " (except bboard messages)" else result = " (plus bboard messages)"
finish
repeat
finish
result = ""
end ; !of any bboard msgs
integer fn bb manage(string (31) bname)
! Apply limits on bboard 'bname' to the current folder.
! Here we write to the public record DB.
! This routine is executed only in BBOARD process
integer b, i, tidy, secs, n, dt, count, c
string (255) s1, s2
if target=2900 start
half integer array mylist(1:10)
else
short integer array mylist(1:10)
finish
b = bb match(bname)
if b=0 start
set return code(99)
stop
finish
! Now check if a 'discard' message has been received
message list("NEW&COM=DISCARD&(SE="""",SE=MANAGR@)", count, s)
if count>0 start ; !one or more found
count = 10 if count>10
mylist(i) = msg list(i) for i = 1, 1, count
for i = 1, 1, count cycle
dbitcomp = 0
f_msg no(mylist(i))_status = 'x'
for c = from, 12, references cycle
locate component(c, uc comp name(c).":".itos(mylist(i)))
getstring(c, s1)
if s1="" then exit
if length(s1)>253 then length(s1) = 253
s1 = """".s1.""""
uctranslate(addr(s1)+1, length(s1))
if c=from then s2 = s1
repeat
if s1="" then continue
message list("FROM=".s2."&MSG=".s1, c, s)
f_msg no(msglist(c))_status = 'x' for c = 1, 1, c
repeat
finish
!
secs = current secs-btab(b)_maxdays*secsin24hrs
for i = 1, 1, f_n msgs cycle
if f_msg no(i)_dt>=secs then exit
f_msg no(i)_status = 'x'; !discard it
repeat
i = f_n msgs-btab(b)_max msgs
for i = 1, 1, i cycle
f_msg no(i)_status = 'x'
repeat
n = f_n msgs
dt = 0
for i = 1, 1, f_n msgs cycle
if f_msg no(i)_status='x' then n = n-1 else dt = f_msg no(i)_dt
if 'u'#f_msg no(i)_status#'n' then continue
f_msg no(i)_status = ' '
repeat
if target=2900 start
btab(b)_n msgs = n
if dt=0 then btab(b)_dt last addition = dt
else
flag = dmove to file(2, addr(n)+2, addr(btab(b)_n msgs))
if dt=0=flag then flag = dmove to file(4, addr(dt), addr(btab(b)_dt last addition))
if flag#0 then monitor
finish
xreturn code = dt
if n<f_n msgs then tidy = yes else tidy = no
result = tidy
end ; !of bb manage
routine lookup directory(integer chan)
record (rf) rr
integer flag, type, output started, check server, i, j, k, offset, serv flag
string (255) pats, patt, name, server
string (3) qm
const integer station entry size= 512
const integer this auth flag= 8
record format station f((byte integer max lines or byte integer max ftp lines), byte integer status,
(byte integer service or byte integer ftp service), byte integer connect retry ptr, fep,
address type, accounting, (byte integer q lines or byte integer ftp q lines),
(integer limit or 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 integer route), integer flags,
byte integer array string space(0:375) {decrement this if more fields added, keep to 512 total})
record (station f) name station
integer fn connect configfile
record (rf) rr
integer flag
connect(confileowner.usep.config file, 1!8 {read shared}, 0, 0, rr, flag)
if flag#0 then printstring(" - configuration file not currently available".snl) and result = -2
config conad = rr_conad
pointers == record(config conad+rr_datastart)
hash t == array(addr(pointers_hash start), hash t af)
result = 0
end ; !of connect config
integer fn lookup hasht(string (127) name)
const integer station entry size= 512
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&1023 {pointers_hash len once its fixed!!}
if hash t(h)#-1 start
hname entry == record(config conad+hash t(h))
cycle
if name=hname entry_name start ; !found it
station == record(config conad+pointers_station displ+(hname entry_host entry-1)*station entry size)
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)
integer res
string (31) this ukac
string (127) s1, s2
if config conad=0 and connect configfile#0 then result = -1
name = s1.s2 while name->s1.(" ").s2
name = myucstring(name)
res = lookup hasht(name)
if res#0 then result = res
this ukac = uinfs(15)
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 then result = lookup hasht(name); !for arpa.
finish
result = -1
end ; !of lookup host
string fn squeeze(string (255) s)
string (255) t
integer i
if s="" then result = ""
t = ""
for i = 1, 1, length(s) cycle
if 'A'<=charno(s, i)<='Z' or '0'<=charno(s, i)<='9' or charno(s, i)='*' then t = t.substring(s, i, i)
repeat
result = t
end ; !OF SQUEEZE
integer fn analyse(string (255) name)
!! Types defined:
!! 0 = *
!! 1 = *A*
!! 2 = *A
!! 3 = A*B
!! 4 = A
if name="*" then result = 0; !WANTS THE LOT
if start of(name, "*", pats)=1 start
if pats->patt.("*") then result = 1 else patt = pats and result = 2
finish
if name->pats.("*").patt then result = 3 else result = 4
end ; !OF ANALYSE
routine out(integer pos)
record (addr entry f) name addr entry
const string (6) array options(1:4)= "S'name","Alias ","Dlist ", "Bboard"
addr entry == record(addr file conad+pos*ad entry size)
if addr entry_rname="" then return
if output started=0 start
if chan#0 then selectoutput(chan)
printstring(snl."Rname".qm." User Host Type Dept".snl.snl)
output started = 1
finish
printstring(addr entry_rname." ")
spaces(18-outpos)
printstring(addr entry_managr." ")
spaces(26-outpos)
printstring(addr entry_server." ")
spaces(34-outpos)
printstring(options(addr entry_options)." ") if 1<=addr entry_options<=max addrfile options
spaces(43-outpos)
printstring(addr entry_department.snl)
end ; !OF OUT
routine match(integer from, to, base, entry size)
integer i
string (255) s, patv, patu
if from>to then return
base = base+from*entry size
if type=4 start
for i = from, 1, to cycle
if string(base)=name and (check server<=0 or string(base-16)=server) start
out(i)
if check server=0 and output started=1 then return
finish
base = base+entry size
repeat
return
finish
for i = from, 1, to cycle
s = string(base)
base = base+entry size
if type=3 start
unless start of(s, pats, s)=1 then continue
if patt="" then ->output
finish
while s->patv.(patt).patu cycle
if type=1 or patu="" then ->output
s = substring(s, length(patv)+2, length(s))
repeat
continue
output:
if check server<=0 or string(base-16-entry size)=server then out(i)
repeat
end ; !OF MATCH
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))=' ')
result = 1 if name=""
cycle
if name->s.(".").name then continue
if name->s.(" ").name then continue
exit
repeat
if start of(name, "MAC", name)=1 or start of(name, "MC", name)=1 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
if name file conad=0 start
connect("MAILER".usep.snamefile, read shared, 0, 0, rr, flag)
if flag#0 then ->discon
name file conad = rr_conad
connect("MAILER".usep.addrfile, read shared, 0, 0, rr, flag)
if flag#0 then ->discon
addr file conad = rr_conad
name file == record(name file conad)
ad file == record(addr file conad)
ntable == array(name file conad+name file header, name table arf)
finish
if name file_datetime=0 start
discon:
printstring(" - directory not currently available".snl)
disconnect("MAILER".usep.snamefile, flag)
disconnect("MAILER".usep.addrfile, flag)
name file conad = 0
return
finish
qm = " "
line = pats."*".patt while line->pats.("**").patt
if line->line.("@").server start
server = pats.patt while server->pats.(" ").patt
if server="" then server = "*"
finish else server = ""
name = squeeze(line)
output started = 0
check server = 0
if name="" and server="" then printstring(" - rname parameter?".snl) and return
if name="" or name="*" then type = 0 else type = analyse(name)
if type=0 and server="*" then server = ""
if "*"#server#"" start
i = lookup host(server)
if i<=0 then printstring(" - invalid host".snl) and return
i = addr(station_string space(0))
if station_shortest name=0 then server = string(i+station_name) else c
server = string(i+station_shortestname)
serv flag = station_flags
finish else serv flag = 0
if server="" or serv flag&this auth flag#0 start
if type=0 start
for i = 1, 1, ad file_entries cycle
out(i)
repeat
else
if type>=3 start
unless 'A'<=charno(name, 1)<='Z' then printstring(" - illegal rname".snl) and return
i = charno(name, 1)
j = i
finish else i = 'A' and j = 'Z'
k = addr(ntable(1))-name entry size
match(name file_startchar(i), name file_startchar(j+1)-1, k, name entry size)
match(name file_extrastart, name file_extraend, k, name entry size)
if output started=0 start
name = line
if name->name.("@").pats or name->name.("/").pats start
finish
if name->pats.("*").patt then name = pats." ".patt
length(name) = 31 if length(name)>31
k = soundex(name)
qm = "(?)"
for i = 1, 1, name file_extraend cycle
if ntable(i)_soundex=k then out(i)
repeat
finish
finish
else ; !USER@HOST
check server = -1
offset = 88
if server#"" and server#"*" start
if server->pats.("*").patt then printstring(" - invalid host".snl) and return
if type=0 start
type = 4
name = server
offset = 72
finish else check server = 1
finish
match(1, ad file_entries, addr file conad+offset, ad entry size)
finish
if output started=0 start
printstring("Not found".snl)
else
newline
if chan#saveoutstream start
if ssmp possible=yes and ssmp on=yes then selectoutput(workframe) else selectoutput(saveoutstream)
closestream(chan)
finish
finish
end ; !OF LOOKUP DIRECTORY
routine mod alias list(string (255) alias, members, integer type)
switch act(1:5)
integer pt, l
integer name link
string (255) m, ucm
routine spec printlist(integer pt)
if p_alias head=0 and type#3 then printstring(" - alias list empty".snl) and return
if type=1 then ->act(1)
alias = compress(alias)
pt = find alias(alias)
if pt=0 and type#3 then printstring(" - ".alias." not found in alias list".snl) and return
->act(type)
act(1):
!LIST ALL ALIASES
l = p_alias head
while l#0 cycle
printlist(l)
l = alist(l)_alink
repeat
return
act(2):
!LIST MEMBERS OF GIVEN ALIAS
printlist(pt)
return
act(3):
!ADD MEMBER(S) TO LIST
if pt=0 start ; !NEW ALIAS
unless 0<length(alias)<=23 then printstring(" - ".alias." has invalid length".snl) and return
if p_free list=0 start ; !NO ROOM
get profile(flag); !EXTEND FILE
if flag#0 then return
finish
pt = p_free list
p_free list = alist(pt)_link
alist(pt)_link = 0
alist(pt)_alink = p_alias head
alist(pt)_name = alias
p_alias head = pt
finish
act(4):
!REMOVE MEMBER(S) FROM LIST
while members#"" cycle
unless members->m.(",").members then m = members and members = ""
if length(m)>27 then printstring(" - ".m." has invalid length".snl) and continue
ucm = myucstring(m)
link == vlist(pt)_link
while link#0 cycle
if ucm=myucstring(vlist(link)_name) start
if type=3 then ->next; !ALREADY ADDED
i = link
link = vlist(i)_link
vlist(i)_link = p_free list
p_free list = i
->next
finish
link == vlist(link)_link
repeat
if type=3 start
if p_free list=0 start
get profile(flag); !EXTEND FILE
if flag#0 then return
finish
i = p_free list
p_free list = vlist(i)_link
vlist(i)_link = 0
vlist(i)_name = m
link = i
finish else printstring(" - ".m." is not in list".snl)
next:
repeat
if type=3 or alist(pt)_link#0 then return
act(5):
!REMOVE ALL MEMBERS FROM A LIST
link == p_alias head
while link#0 cycle
if alist(link)_name=alias then exit
link == alist(link)_alink
repeat
link = alist(link)_alink; !REMOVE FROM ALIST
link == alist(pt)_link
link == alist(link)_link while link#0; !Last member.
link = p_free list
p_free list = pt
routine printlist(integer pt)
printstring(alist(pt)_name.": ")
while vlist(pt)_link#0 cycle
spaces(((outpos+15)//15)*15-outpos)
pt = vlist(pt)_link
if outpos+length(vlist(pt)_name)>72 then newline and spaces(15)
printstring(vlist(pt)_name)
repeat
newline
end ; !OF PRINTLIST
end ; !OF MOD ALIAS LIST
string fn get postal addresses(integer name beg, recips, integer end)
integer brackets, i
string (255) postaddr, s, rest
postaddr = ""
brackets = 0
for i = beg, 1, end cycle
if brackets=1 start
if byteinteger(i)=')' start
brackets = 0
if postaddr->s.(":").postaddr start
s = myucstring(postaddr)
if start of(s, "POSTAL:", rest)=1 start
rest = compress(rest)
if length(rest)>0 start
beg = i+1
result = substring(postaddr, 8, length(postaddr))
finish
finish
finish
postaddr = ""
continue
finish
postaddr = postaddr.tostring(byteinteger(i)) if length(postaddr)<255
else
if byteinteger(i)='(' then brackets = 1 else start
if byteinteger(i)=',' then recips = recips+1
finish
finish
repeat
beg = i+1
result = ""
end ; !OF GET POSTAL ADDRESSES
integer fn generate postal output(integer name recips, folder no)
string (63) current dt
string (255) s, t, u, v
long integer save dbitcomp
integer count, i, st, fin, comp, stbcc, lenbcc, secs
string (20) first
first = " First fold "
const string (83) second= c
" Second fold |"
const string (83) third= c
" Third fold |"
const string (83) bar= c
"----------------------------------------------------------------------------------|"
const string (83) internal= c
" Internal |"
const string (83) mail= c
" Mail |"
routine side(integer lines)
integer i
for i = 1, 1, lines cycle
spaces(82)
printsymbol('|')
printsymbol(charno(first, i))
newline
repeat
end
recips = 0
count = 0
list limit = llist file
savedbitcomp = dbitcomp
check workfile(2048, i)
if i#0 then result = 0
secs = current secs
if dbitcomp&(1<<cdate)=0 start ; !ADD DATE
current dt = secs to dt(secs)
putstring(cdate, current dt)
finish
if dbitcomp&(1<<from)=0 then putstring(from, mysurname)
message list("DRAFT", i, s)
for comp = bcc, -1, to cycle
if (dbitcomp>>comp)&1=0 then continue
st = cbeg(comp)
fin = st+clen(comp)-1
if comp=bcc start
stbcc = cbeg(bcc)
lenbcc = clen(bcc)
cbeg(bcc) = addr(v)+1
finish
recips = recips+1
while st<=fin cycle
s = get postal addresses(st, recips, fin)
if s#"" start
newpage
count = count+1
if comp=bcc start
v = "(:Postal:".s.")"
clen(bcc) = length(v)
finish
s = t." ".u while s->t.(snl).u
side(20)
printstring(second.snl.bar.snl)
side(2)
printstring(internal.snl.mail.snl)
for i = 1, 1, 18 cycle
if i<=8 or s="" then spaces(82) else start
if s->t.(",").s then t = t."," else t = s and s = ""
while start of(t, " ", t)=1 cycle
repeat
spaces(10)
printstring(t)
spaces(82-outpos)
finish
printsymbol('|')
newline
repeat
printstring(bar.snl.third.snl)
side(18)
newpage; newlines(4)
f list(1, 1)
finish
repeat
if comp=bcc start
cbeg(bcc) = stbcc
clen(bcc) = lenbcc
dbitcomp = dbitcomp&(~(1<<bcc))
finish
repeat
newpage if count>0
if ssmp possible=yes and ssmp on=yes then selectoutput(workframe) else selectoutput(saveoutstream)
if folder no>0 and count>0 start
draft to msg(folder no, secs, ' ', i)
if i#0 then folder no = 0
finish
dbitcomp = save dbitcomp
result = count
end ; !OF GENERATE POSTAL OUTPUT
routine get profile(integer name flag)
const integer pversion= 4
const integer alist offset= 1024
switch psw(0:pversion)
routine spec add entries(integer st, fin)
record (rf) r
integer newsize
if pconad=0 start ; !CONNECT IT
connect(profile file, read write, 0, 0, r, flag)
if flag=0 start
pconad = r_conad
p == record(pconad)
if p_marker#p marker start
printstring("Corrupt PROFILE".snl)
destroy(profilefile, flag)
pconad = 0
get profile(flag)
return
finish
else
outfile(profile file, epagesize, 0, 0, pconad, flag)
if flag#0 then printstring("Create PROFILE fails: ".failure message(flag).snl) and return
p == record(pconad)
p_end = epagesize
p_filetype = data filetype
p_format = 3
p_marker = p marker
cherish(profile file)
printstring("Profile file created".snl)
finish
alist == array(pconad+alist offset, alist arf)
vlist == array(pconad+alist offset, vlist arf)
if p_version>pversion then ->psw(pversion)
->psw(p_version); !BRING IT UP TO DATE
psw(0):
!INITIAL SETUP
add entries(1, (epagesize-alist offset)//32)
if kent=0 then p_v editor = "SCREED" else p_v editor = "CHEF"
p_accept = ""; !EQUALS MYSURNAME
p_llist console = yes
p_llist file = no
psw(1):
!VERSION 1
p_autofile = yes
psw(2):
!version 2
p_autoaccept = yes
psw(3):
!
p_overwrite = no
p_return new = yes
printstring("See Mail:HELP ALERT for recent changes".snl)
p_version = pversion
psw(pversion):
!LATEST VERSION
if p_llist console=no then llist console = -1 else llist console = limit amount listed
if p_llist file=no then llist file = -1 else llist file = limit amount listed
if kent=no and charno(myprocess, 4)='U' then p_accept = ""; !they get it wrong
else ; !EXTEND FILE
newsize = p_size+epagesize
flag = dchsize(myprocess, profile file, myfsys, newsize>>10)
if flag=0 start
add entries(p_list size+1, p_list size+epagesize//32)
p_size = newsize
p_end = newsize
finish else printstring("Extend PROFILE fails: ".derrs(flag).snl)
finish
routine add entries(integer st, fin)
integer i
for i = st, 1, (fin-1) cycle
vlist(i)_link = i+1
repeat
vlist(fin)_link = 0
p_free list = st
p_list size = fin
end ; !OF ADD ENTRIES
end ; !OF GET PROFILE
routine set profile
string (255) sval
byte integer b
routine profile item(string (31) subject, string name value, byte integer name bvalue, integer check)
string (255) s, t
integer i
integer fn yesno
if start of(yesstring, s, t)=1 then result = 1
if start of(nostring, s, t)=1 then result = 0
result = -1
end ; !OF YESNO
if check=0 start
if bvalue=no then value = "NO" else value = "YES"
finish
cycle
printstring(snl.subject." (".value.")")
if length(subject)+length(value)>50 then newline
prompt(" : ")
terminate
if nextsymbol=nl then skipsymbol and return
readnext(s)
s = s.t while s->s.(" ").t
uctranslate(addr(s)+1, length(s))
if check=0 start
i = yesno
if i<0 then printstring("Response should be YES or NO or <return>".snl) and continue
bvalue = i
else
if length(s)>check then printstring("String too long".snl) and continue
value = s
finish
exit
repeat
end ; !OF PROFILE ITEM
printstring("Press <return> to retain (current) values".snl)
profile item("'V' editor", p_v editor, b, 15)
if p_accept="" then p_accept = mysurname
profile item("ACCEPT rnames", p_accept, b, 79)
if compress(p_accept)=compress(mysurname) then p_accept = ""
profile item("Abbrev LIST-to-console", sval, p_llist console, 0)
if p_llist console=no then llist console = -1 else llist console = limit amount listed
profile item("Abbrev LIST-to-file", sval, p_llist file, 0)
if p_llist file=no then llist file = -1 else llist file = limit amount listed
profile item("Default file-a-copy", sval, p_autofile, 0)
profile item("Auto-ACCEPT on entry", sval, p_autoaccept, 0)
profile item("Overwriting draft warning", sval, p_overwrite, 0)
profile item("<return> only lists NEW", sval, p_return new, 0)
return new = p_return new
end ; !OF SET PROFILE
end ; !OF MAIL
end of file