// IfsMailJob.bcpl -- sorts and forwards mail
// Copyright Xerox Corporation 1979, 1980, 1981, 1982
// Last modified April 9, 1982 12:33 PM by Taft
get "Ifs.decl"
get "IfsMail.decl"
get "IfsDirs.decl"
get "IfsFtpProt.decl"
get "AltoFileSys.d"
external
[
// outgoing procedures
MailJob; EnumerateMailFile; EnumerateMB; ReadMB
// incoming procedures from other mail modules
SortNewMail; ForwardMail; StartUndelivMsg; FinishUndelivMsg
// incoming procedures from IFS dirs
LookupIFSFile; NextFD; DestroyFD; DeleteFileFromFD; GetBufferForFD
LockTransferLeaderPage; OpenIFSStream; CloseIFSStream; CloseIFSFile
// incoming procedures - misc
DestroyJob; JobOK; IFSError; IFSPrintError
ReadBlock; WriteBlock; Closes; Endofs; FilePos; SetFilePos
DoubleIncrement; DoubleUsc; DoubleAdd; Mul
SysAllocate; SysFree; ReadCalendar; Zero; PutTemplate
// incoming statics
mail; debugFlag
]
//---------------------------------------------------------------------------
let MailJob(ctx) be // a context
//---------------------------------------------------------------------------
[
ctx>>RSCtx.userInfo = mail>>Mail.ui
[ // repeat
mail>>Mail.workToDo = false
EnumerateMailDir("<Mail>New>Mail!**", SortNewMail, minSortInterval)
EnumerateMailDir("<Mail>Fwd>**!1", ForwardMail, minForwardInterval)
] repeatwhile mail>>Mail.enabled ne 0 & mail>>Mail.workToDo ne 0 &
JobOK(jobTypeMail)
mail>>Mail.wake = jobInterval/eventInterval
mail>>Mail.ctx = 0
DestroyJob()
]
//----------------------------------------------------------------------------
and EnumerateMailDir(dirName, Proc, minInterval) be
//----------------------------------------------------------------------------
// Enumerates all files matching dirName, opens a stream and calls Proc.
// Skips over a file if it was last checked less than minInterval seconds ago,
// unless it has been written more recently than that.
// If Proc returns true, the file is then deleted.
[
let fd = LookupIFSFile(dirName, lcMultiple)
if fd eq 0 return
[ // repeat
// Continue or stop?
if mail>>Mail.enabled eq 0 break
unless JobOK(jobTypeMail) do [ mail>>Mail.workToDo = true; break ]
// We should look closely at this file if it has been written since
// last read or if it hasn't been read for at least minInterval.
let time = vec 1; ReadCalendar(time)
DoubleIncrement(time, -minInterval)
let ld = GetBufferForFD(fd)
let ok = LockTransferLeaderPage(fd, ld) eq 0 &
(DoubleUsc(lv ld>>LD.written, lv ld>>LD.read) gr 0 %
DoubleUsc(time, lv ld>>LD.read) ge 0)
SysFree(ld)
unless ok loop
// Open the file and see what's inside.
let stream = OpenIFSStream(fd, 0, modeReadWrite)
if stream ne 0 then
[
let delete = Proc(stream)
// Do not unlock file if we're going to delete it.
CloseIFSStream(stream, delete)
if delete then
if DeleteFileFromFD(fd, false, true) ne 0 then CloseIFSFile(fd)
]
] repeatwhile NextFD(fd)
// Done enumeration -- cleanup and go away
DestroyFD(fd)
]
//----------------------------------------------------------------------------
and EnumerateMailFile(stream, Proc) = valof
//----------------------------------------------------------------------------
// Enumerates all msgs in the stream, calling Proc for each one.
// Returns true if the file behind stream can be deleted.
[
let delete = true
let msg = vec lenMsg; Zero(msg, lenMsg)
msg>>Msg.stream = stream
[ // read next message in file
SetFilePos(stream, lv msg>>Msg.posEnd)
if Endofs(stream) break
// if the message is damaged, skip it.
if ReadBlock(stream, lv msg>>Msg.mh, lenMH) ne lenMH then
[ if debugFlag then IFSError(ecEofInHdr, msg); break ]
if msg>>Msg.seal ne mhSeal then
[ if debugFlag then IFSError(ecBadMsgSeal, msg); break ]
if msg>>Msg.numActive eq 0 loop
Proc(msg)
// Check long-term timeout and handle any Exception blocks.
let timeout = vec 1; Mul(0, 3600, deliveryTimeout, timeout)
DoubleAdd(timeout, lv msg>>Msg.date)
let now = vec 1; ReadCalendar(now)
EnumerateMB(msg, Undeliv, DoubleUsc(now, timeout) ge 0)
// if there is one, finish off the undeliverable msg msg
if msg>>Msg.uMsg then FinishUndelivMsg(msg)
// rewrite message header
if msg>>Msg.numActive ne 0 then delete = false
SetFilePos(stream, lv msg>>Msg.posBegin)
WriteBlock(stream, lv msg>>Msg.mh, lenMH)
] repeat
resultis delete
]
//----------------------------------------------------------------------------
and Undeliv(mb, msg, timeout) = valof
//----------------------------------------------------------------------------
// Called from EnumeratMB in EnumerateMailFile.
// If 'timeout' then converts all active blocks into exception blocks.
// Generates an undeliverable message message for all exception blocks.
[
let rewrite, type = false, mb>>MB.type
if timeout & type ne mbTypeFree & type ne mbTypeSndr & type ne mbTypeExcp then
[
mb>>MB.type = mbTypeExcp
mb>>MNB.ec = ecDeliveryTimeout
rewrite = true
]
if mb>>MB.type ne mbTypeExcp resultis false
if msg>>Msg.uMsg eq 0 then StartUndelivMsg(msg)
if msg>>Msg.uMsg ne 0 then
[
let uStream = msg>>Msg.uMsg>>Msg.stream
PutTemplate(uStream, "*N$S - ", lv mb>>MNB.name)
IFSPrintError(uStream, mb>>MNB.ec)
mb>>MB.type = mbTypeFree
rewrite = true
]
resultis rewrite
]
//----------------------------------------------------------------------------
and EnumerateMB(msg, Proc, arg) be
//----------------------------------------------------------------------------
// Enumerates the Blocks in msg calling Proc for each one.
// If Proc returns true, the block is rewritten.
// Changing the length of the block is forbidden.
[
let stream = msg>>Msg.stream
SetFilePos(stream, lv msg>>Msg.posBlk)
msg>>Msg.numActive = 0
let mb = SysAllocate(maxLenMB)
[
let thisPos = vec 1; FilePos(stream, thisPos)
if DoubleUsc(thisPos, lv msg>>Msg.posTxt) ge 0 break
ReadMB(msg, mb)
let nextPos = vec 1; FilePos(stream, nextPos)
test Proc(mb, msg, arg) //rewrite block?
ifnot SetFilePos(stream, nextPos) //Proc may have changed stream pos.
ifso //back up and rewrite the block
[
SetFilePos(stream, thisPos)
WriteBlock(stream, mb, mb>>MB.length)
]
unless mb>>MB.type eq mbTypeFree % mb>>MB.type eq mbTypeSndr do
msg>>Msg.numActive = msg>>Msg.numActive +1
] repeat
SysFree(mb)
]
//----------------------------------------------------------------------------
and ReadMB(msg, mb; numargs na) = valof
//----------------------------------------------------------------------------
[
let temp = nil
ReadBlock(msg>>Msg.stream, lv temp, 1)
if na ls 2 % mb eq 0 then mb = SysAllocate(temp<<MB.length)
mb!0 = temp
if ReadBlock(msg>>Msg.stream, mb+1, mb>>MB.length-1) ne mb>>MB.length-1 then
IFSError(ecEofInBlk, msg)
resultis mb
]