!! Mail Interface !! Version 2h 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 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 atrans= x'80C0008F'; !ADDRESS OF TRANSLATE TABS const integer yes= 1 const integer no= 0 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 const string (9) profile file= "M#PROFILE" const string (31) helpfile= "SUBSYS.MAILHELP" 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="FTRANS.CFILE" 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" finish else start 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 finish else start 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 finish else start 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 limit amount listed= ~(1<<messid!1<<inreplyto!any vias) 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 comf(integer ocp type, ipldev, sblks, sepgs, ndiscs, ddtaddr, gpctabsize, gpca, sfctabsize, sfca, sfck, dirsite, dcodeda, suplvn) record format dtablef(string (31) dname, integer offset, length) record format btablef(string (31) bname, title, string (18) folder, byte integer sp0, half integer maxmsgs, maxdays, n msgs, sp1, integer dt last addition, sp2, sp3, sp4) record format 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) external routine spec cherish(string (255) s) system integer map spec comreg(integer i) external routine spec clear(string (255) s) system routine spec connect(string (31) file, integer mode, hole, prot, record (rf) name r, integer name flag) external integer fn spec dfilenames(string (6) user, record (frecf) array name inf, integer name filenum, maxrec, nfiles, integer fsys, type) external routine spec define(string (255) s) external string fn spec derrs(integer flag) system routine spec destroy(string (31) file, integer name flag) system integer fn spec devcode(string (16) s) external integer fn spec dfstatus(string (6) user, string (11) file, integer fsys, act, value) system routine spec disconnect(string (31) file, integer name flag) 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) dynamic routine spec ecce(string (255) s) dynamic routine spec edit(string (255) s) system string fn spec failure message(integer i) external integer fn spec instream system integer fn spec iocp(integer ep, param) system string fn spec itos(integer n) system routine spec outfile(string (31) file, integer size, hole, prot, integer name conad, flag) system routine spec move(integer len, from, to) system routine spec newgen(string (31) file, newfile, integer name flag) external integer fn spec outpos external integer fn spec outstream external string fn spec ucstring(string (255) s) system routine spec uctranslate(integer addr, length) external integer fn spec exist(string (31) file) system integer fn spec pstoi(string name s) system routine spec psysmes(integer root, flag) external routine spec read profile(string (11) key, name info, integer name version, flag) external integer fn spec returncode system routine spec sdisconnect(string (31) file, integer fsys, integer name flag) system routine spec setfname(string (40) name) external routine spec setreturncode(integer i) external routine spec terminate external string fn spec uinfs(integer entry) external integer fn spec uinfi(integer entry) dynamic routine spec zview alias "S#ZVIEW"(string (255) s) external routine spec prompt(string (15) s) external routine spec write profile(string (11) key, name info, integer name version, flag) 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 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 (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 (comf) name com 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) finish else start 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) half integer array format msg list f(1:2000) half integer array name msg list half integer array name my msg list 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 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) 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, integer name flag) 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 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) this host = uinfs(15).".".line unless line->line.(".").this short host then this short host = line lctranslate(addr(this host)+1, length(this host)) this host = uinfs(10); !temp temp temp temp temp temp temp if this host="2976" then this host = "2972"; !temp frig 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 = dsfi(myprocess, myfsys, msg indicator, 0, addr(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(integer(atrans)+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 = 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 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 = dsfi(myprocess, myfsys, msg indicator, 0, addr(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 cycle 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 finish else start 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" finish else start 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 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) finish else start 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 flag = preserve draft(-1) if ssmp possible=yes and ssmp on=yes then selectinput(workframe) mycall(op, lc line, flag) if ssmp possible=yes and ssmp on=yes start selectinput(comframe) selectoutput(workframe) finish else start selectinput(saveinstream) selectoutput(saveoutstream) finish j = verify conad(workfile, dconad) if i#0 start for i = 1, 1, i cycle if flag=0 and 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 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 finish else start 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) finish else start 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) finish else start ; !board specified line = compress(line) flag = open bboard(line, 0) if flag=0 start if myprocess=db_bowner and line->("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) finish else start 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)) finish else start 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") finish else start 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 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 finish else start ; !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) finish else start 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 ->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, flag) if flag#0 then continue after edit: if returncode=0 then file to component(i, no, op) destroy(op, flag) check workfile(epage size, flag) 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 finish else start 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(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) 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(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(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 finish else start 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 open folder(lc line, dest f) if 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 finish else start 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 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 finish else start 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 sdisconnect("MAILER.".snamefile, com_suplvn, flag) sdisconnect("MAILER.".addrfile, com_suplvn, flag) finish if config conad#0 then sdisconnect(configfile, com_suplvn, flag) if dbconad#0 then sdisconnect("MAILER".dbfile, com_suplvn, 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) finish else start 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(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(saveoutstream) else selectoutput(saveoutstream) closestream(j) clear(itos(j)) finish continue prompt for send: 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 finish else start 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) 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) finish else start 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<<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 = ucstring(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 finish else start ; !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 routine get from tt(integer comp) integer pos, i, term, startpos, esc, j, endpos, flag string (63) s on event 9 start i = iocp(12, 0); !clear input ended if esc=1 and dbitcomp>>comp&1#1 then ->file input return finish if ssmp possible=yes and ssmp on=yes then selectinput(workframe) esc = 0 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 prompt(":") else prompt(" : ") term = ':' finish else start prompt(lc comp name(comp)) term = nl finish startpos = dconad+d_end pos = startpos endpos = dconad+d_size-512 file input: while next ch='@' cycle s = "" esc = 1 cycle readch(i) i = nextch if i=nl or i=em then exit if i>' ' and length(s)#63 then s = s.tostring(i) repeat readch(i) uctranslate(addr(s)+1, length(s)) locate component(comp, s) if dbitcomp>>comp&1=1 then ->check em if i=em then j = iocp(12, 0) repeat cycle readch(i) if (i='*' or i=':') and nextch=nl then skipsymbol and exit 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 else dbitcomp = dbitcomp&(~(1<<comp)) 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) finish else start 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 finish else start 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 finish else start 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 finish else start 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) flag = dpermission(myprocess, "MAILER", "", "M#MSG", myfsys, 2, 3) pa = 0 flag = dmail(pa, length(s), addr(s)+1) if 0<flag<501 then printstring("Director DMAIL error ".derrs(flag).snl) 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 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) finish else start 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:") i = nextch; !force out prompt) finish end ; !of do scan routine message list(string (255) msgline, integer name count, string name s) system routine spec fill(integer len, from, filler) 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 finish else start { 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 k = 32<<8!charno(s2, 1) !CASE MASK FIRST CHAR 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 finish else start if mm_bitcomp>>c&1=0 then continue fp = mm_c(c)_beg+adr 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 finish if fp<=range start if type=3 then add(m); !EQUALS finish else start if type=4 then add(m); !NOT EQUALS finish repeat end ; ! OF DECODE byte 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) { %cycle i = 0,1,N bytes-1} { %if op = Or %then %c } { byte integer(list1+i) = byte integer(list1+i) ! byte integer(list2+i) %c } { %else %c} { byte integer(list1+i) = byte integer(list1+i) & byte integer(list2+i)} 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 finish else start *ldtb_16_18000000 *ldb_n bytes *lda_list2 *cyd_0 *lda_list1 *ors_ l = dr ; !OR STRINGS finish end routine negate(integer list) { %cycle i = 0,1,N bytes-1} { byte integer(list addr+i) = ~byte integer(list addr+i)} { %repeat} *ldtb_16_18000000 *ldb_n bytes *lda_list *neqs_ l = dr , 0, 255; !NEGATE EACH BYTE 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 finish else start { 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 finish else start { 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 finish else start { 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 finish else start { 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 com == record(x'80000000'+48<<18) connect("MAILER.".snamefile, read shared, 0, (com_suplvn<<8)!x'80', 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) sdisconnect("MAILER.".snamefile, com_suplvn, flag) sdisconnect("MAILER.".addrfile, com_suplvn, 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 flag = dfilenames(myprocess, pf, filenum, maxrec, nfiles, myfsys, 0) 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 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 finish else start 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 finish else start 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 printstring("Folder ".file." created".snl) if file#"T#MAIL" cherish(file) finish else start printstring("Create folder ".file." fails ".failure message(flag).snl) finish result = flag end ; !OF CREATE FOLDER integer fn free stream external routine spec definfo(integer chan, string name file, integer name stat) 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.(".").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.(".").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 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 finish else start ; !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 count) integer i, j, k, or, adr, offset 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 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 and or#body start for k = 1, 1, 10 cycle if i+k>=j or byteinteger(i+k)#' ' then exit repeat spaces(11-k) finish repeat end ; !OF OUT for i = 1, 1, count cycle 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) finish else start 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 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: ") finish else start 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 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 finish else start 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: ") finish else start 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 finish else start 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 finish else start 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 *lss_k; *iad_693902 *imy_4; *isb_1; *imdv_146097 *lss_ tos ; *idv_4; *imy_4; *iad_3 *imdv_1461; *st_(y) *lss_ tos ; *iad_4; *idv_4 *imy_5; *isb_3; *imdv_153 *st_(m); *lss_ tos *iad_5; *idv_5; *st_(d) if m<10 then m = m+3 else m = m-9 and y = y+1 end ; ! OF KDATE integer fn current secs !! GIVES CURRENT DT IN NEW PACKED FORM const long integer mill= 1000000 *rrtc_0; *ush_-1 *shs_1; *ush_1 *imdv_mill *isb_secs70; *stuh_ b !*OR_X'80000000' *exit_-64 end routine decwrite2(integer value, ad) !! WRITES VALUE AS TWO DECIMAL ISO DIGITS INTO AD AND AD+1 *lss_value; *imdv_10 *ush_8; *iad_ tos ; *iad_x'3030' *lda_ad; *ldtb_x'58000002' *st_(dr ) end ; ! OF DECWRITE2 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" *lss_p; *ush_1; *ush_-1 *imdv_60; *imdv_60; *imdv_24 *lss_ tos ; *st_h *lss_ tos ; *st_m *lss_ tos ; *st_secs decwrite2(h, at+1) decwrite2(m, at+4) decwrite2(secs, at+7) ad = addr(dat) dat = "00 XXX 00" p = (p&x'7FFFFFFF')//secs in 24 hrs kdate(d, mo, y, p+days70) string(ad+2) = " ".month(mo) decwrite2(d, ad+1) decwrite2(y, ad+8) result = dat." ".tim 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 finish else start 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 finish else start 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, integer name flag) system routine spec enter(integer mode, dr0, dr1, string (255) param) system routine spec findentry(string (31) entry, integer type, dad, string name file, integer name dr0, dr1, flag) system routine spec load(string (31) name, integer type, integer name flag) system routine spec unload(integer curgla) external routine spec call(string (31) entry, string (255) param) integer savecomreg44, dr0, dr1 string (1) dummys if uinfi(26)=0 start savecomreg44 = comreg(44) load(command, 0, flag) ->err if flag#0 findentry(command, 0, 0, dummys, dr0, dr1, flag) ->err if flag#0 enter(2, dr0, dr1, param) unload(savecomreg44) err: if flag#0 then psysmes(86, flag) finish else 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 dr0, dr1, accdr0, accdr1, i, j string (255) t if length(s)=0 then result = "" dr0 = x'58000000'!length(s) dr1 = addr(s)+1 accdr0 = x'18000100' accdr1 = addr(tab(0)) *ld_dr0 *lsd_accdr0 *ttr_ l = dr i = addr(s) j = addr(t)+1 for i = i+1, 1, i+byteinteger(i) cycle if byteinteger(i)#0 then byteinteger(j) = byteinteger(i) and j = j+1 repeat length(t) = j-addr(t)-1 length(t) = 31 if length(t)>31 result = t end ; !OF COMPRESS routine connect dbfile record (rf) rr integer flag, i, version com == record(x'80000000'+48<<18) connect("MAILER.".dbfile, read shared, 0, (com_suplvn<<8)!x'80', rr, flag) if flag=0 start db == record(rr_conad) if db_bowner=myprocess start sdisconnect("MAILER.".dbfile, com_suplvn, flag) connect("MAILER.".dbfile, read write!read shared, 0, (com_suplvn<<8)!x'80', rr, flag) if flag=0 then db == record(rr_conad) else set return code(flag) and stop 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 finish else start 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.(".").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 half integer array mylist(1:10) 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 btab(b)_n msgs = n if dt=0 then btab(b)_dt last addition = dt 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 c byte integer max ftp lines), byte integer status, (byte integer service or c byte integer ftp service), byte integer connect retry ptr, fep, address type, accounting, (byte integer q lines or byte integer ftp q lines), (integer limit or c integer ftp limit), integer last call, last response, system loaded, connect attempts, connect retry time, integer array ispare(0:4), integer seconds, bytes, integer last q response by us, p transfers, q transfers, p kb, q kb, p mail, q mail, integer name, shortest name, integer array address(1:4), integer pss entry, integer mail, integer ftp, integer description, (integer queue or 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(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 = ucstring(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)." ") 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 finish else start 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 com == record(x'80000000'+48<<18) connect("MAILER.".snamefile, read shared, 0, (com_suplvn<<8)!x'80', rr, flag) if flag#0 then ->discon name file conad = rr_conad connect("MAILER.".addrfile, read shared, 0, (com_suplvn<<8)!x'80', 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) sdisconnect("MAILER.".snamefile, com_suplvn, flag) sdisconnect("MAILER.".addrfile, com_suplvn, 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 finish else start 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 finish else start ; !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) finish else start 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 = ucstring(m) link == vlist(pt)_link while link#0 cycle if ucm=ucstring(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 = ucstring(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 finish else start 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) 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 finish else start 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 finish else start ; !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 finish else start 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