// IfsMailSort.bcpl -- Sorts newly arrived mail
// Copyright Xerox Corporation 1979, 1980, 1981
// Last modified November 18, 1981 9:31 AM by Taft
get "Ifs.decl"
get "IfsDirs.decl"
get "IfsMail.decl"
get "IfsFiles.decl"
external
[
// outgoing procedure
SortNewMail
// incoming procedures from IFS Dirs
DestroyFD; IFSOpenFile; OpenIFSStream
GetBufferForFD; LockTransferLeaderPage
// incoming procedures from disk streams
WriteBlock; Closes; Puts
FilePos; SetFilePos; FileLength
// incoming procedures from other mail modules
EnumerateMailFile; EnumerateMB; ReadMB; WriteMNB
CheckName; MailStatDelay; DiskToDisk
// incoming procedures -- miscellaneous
SysAllocateZero; SysFree; Zero; MoveBlock; Usc
DoubleSubtract; DoubleIncrement; MultEq
IFSError; Dequeue; ReadCalendar
ConcatenateStrings; StringCompare; ExtractSubstring
SetTimer; TimerHasExpired; Dismiss
LockCell; UnlockCell; VFileReadPage
// incoming statics
mail
]
//----------------------------------------------------------------------------
let SortNewMail(stream) = EnumerateMailFile(stream, Sort)
//----------------------------------------------------------------------------
//----------------------------------------------------------------------------
and Sort(msg) be
//----------------------------------------------------------------------------
[
DoubleIncrement(lv mail>>Mail.msgID) //for duplicate suppression
// Deliver copies to local mailboxes, and build a list of remote servers
EnumerateMB(msg, DeliverLocal)
// Queue copies for forwarding to remote mailboxes
[
let hqi = Dequeue(lv msg>>Msg.hostQ); if hqi eq 0 break
if hqi>>HQI.used then DeliverRemote(msg, hqi)
SysFree(hqi)
] repeat
]
//----------------------------------------------------------------------------
and DeliverLocal(mb, msg) = valof
//----------------------------------------------------------------------------
// Called from EnumerateMB in Sort.
// If mb describes a local mailbox, then append a copy of msg to it.
// If mb describes a remote mailbox, skip it.
// If mb's syntax is bad or it references a nonexistant local mailbox,
// then change mb into an exception block.
[
if mb>>MB.type ne mbTypeMlbx resultis false
let fd = CheckName(lv mb>>MNB.name, msg, lv mb>>MNB.ec, true)
if fd eq 0 then [ mb>>MNB.type = mbTypeExcp; resultis true ] //bad syntax
if fd eq -1 then
[ // Non-local and can forward.
// Reset MNB.ec in case local mailbox just became non-local.
if mb>>MNB.ec ne 0 then [ mb>>MNB.ec = 0; resultis true ]
resultis false
]
// Mailbox is local, check for duplicates
let ild = GetBufferForFD(fd)
if LockTransferLeaderPage(fd, ild) eq 0 then // read
[
let fProp = ild + ild>>LD.propertyBegin
until fProp>>FPROP.type eq 0 % fProp>>FPROP.type eq fPropTypeMsgID do
fProp = fProp + fProp>>FPROP.length
if ild+ild>>LD.propertyBegin+ild>>LD.propertyLength uls
fProp+lenFPropMsgID then IFSError(ecLeaderProps, ild)
if fProp>>FPROP.type eq 0 then
[
fProp>>FPROP.type = fPropTypeMsgID
fProp>>FPROP.length = lenFPropMsgID
Zero(lv fProp>>FPropMsgID.msgID, 2)
fProp!lenFPropMsgID = 0
]
if MultEq(lv fProp>>FPropMsgID.msgID, lv mail>>Mail.msgID) then
[ // duplicate
SysFree(ild)
DestroyFD(fd)
mb>>MNB.type = mbTypeFree
resultis true
]
MoveBlock(lv fProp>>FPropMsgID.msgID, lv mail>>Mail.msgID, 2)
LockTransferLeaderPage(fd, ild, true) // write
]
SysFree(ild)
// try to open a stream on it
let stream, ec = nil, nil
let timer = nil; SetTimer(lv timer, openTimeout*100)
[
stream = OpenIFSStream(fd, lv ec, modeAppend)
if stream ne 0 % ec ne ecFileBusy % TimerHasExpired(lv timer) break
Dismiss(100)
] repeat
if stream eq 0 then
[ // Busy, try again later
DestroyFD(fd)
mb>>MNB.ec = ecFileBusy // so RemoteRecipients will skip over it
resultis true
]
// append a copy of the message to it
FinishAppendingMsg(StartAppendingMsg(stream), msg)
mb>>MNB.type = mbTypeFree
resultis true
]
//----------------------------------------------------------------------------
and DeliverRemote(inMsg, hqi, outMsg) be
//----------------------------------------------------------------------------
// Generates a message for forwarding to host. Specifically, it:
// copies the sender from inMsg;
// copies recipients whose registry matches hqi;
// copies the text of inMsg.
// Caller is responsible for ensuring that there is at least one recipient
// for the specified host.
// Note: if hqi is the HQI corresponding to gvName, ALL remote recipients
// are forwarded to this host. In this case, all the other HQIs will
// not have had their HQI.used bits set, so the HQI for gvName is the
// only one on which DeliverRemote will be called.
// outMsg isn't really an argument, just a local. Its up there so
// the compiler will allocate it after 'hqi', which is convenient
// when calling RemoteRecipients via EnumerateMB, below.
[
// try to open a forwarding file
let fileName = ConcatenateStrings("<Mail>Fwd>", lv hqi>>HQI.name)
let outStream = IFSOpenFile(fileName, 0, modeAppend)
SysFree(fileName)
if outStream eq 0 return
// append to forwarding file
outMsg = StartAppendingMsg(outStream)
// generate the sender
SetFilePos(inMsg>>Msg.stream, lv inMsg>>Msg.posSndr)
let mb = ReadMB(inMsg)
WriteMNB(outMsg, mbTypeSndr, lv mb>>MNB.name)
SysFree(mb)
// generate the list of recipients
EnumerateMB(inMsg, RemoteRecipients, lv hqi)
// Copy message text, close outMsg.
FinishAppendingMsg(outMsg, inMsg)
// don't set Mail.workToDo since the forwarder will run next anyway
]
//----------------------------------------------------------------------------
and RemoteRecipients(mb, inMsg, args) = valof
//----------------------------------------------------------------------------
// Called from EnumerateMB in DeliverRemote.
// Copies mailbox blocks from inMsg to outMsg.
// Marks the mailbox blocks in inMsg free.
// args!0 -> hqi, args!1 -> outMsg
[
let hqi, outMsg = args!0, args!1
if mb>>MNB.type ne mbTypeMlbx % mb>>MNB.ec ne 0 resultis false
// Append entry if hqi corresponds to gvName or registry matches hqi.name.
if hqi ne inMsg>>Msg.gvHQI then
[
let name, dot = lv mb>>MNB.name, 0
for i = name>>String.length to 1 by -1 do
if name>>String.char↑i eq $. then [ dot = i; break ]
if StringCompare(name, lv hqi>>HQI.name, dot+1) ne 0 resultis false
]
WriteMNB(outMsg, mbTypeMlbx, lv mb>>MNB.name)
mb>>MNB.type = mbTypeFree
resultis true
]
// These two procedures perform the mechanical aspects of appending
// new messages to message files. They are used by:
// DeliverLocal on local mail boxes, and by
// DeliverRemote on forward files for remote mail systems.
//----------------------------------------------------------------------------
and StartAppendingMsg(outStream) = valof
//----------------------------------------------------------------------------
// Creates and returns an Msg for appending to outStream.
[
let outMsg = SysAllocateZero(lenMsg)
outMsg>>Msg.stream = outStream
FilePos(outStream, lv outMsg>>Msg.posBegin)
WriteBlock(outStream, lv outMsg>>Msg.mh, lenMH)
FilePos(outStream, lv outMsg>>Msg.posBlk)
FilePos(outStream, lv outMsg>>Msg.posTxt)
resultis outMsg
]
//----------------------------------------------------------------------------
and FinishAppendingMsg(outMsg, inMsg) = valof
//----------------------------------------------------------------------------
// Finishes appending inMsg to outMsg -- copies the text, finishes the
// header, closes the stream, and destroys outMsg.
[
let outStream = outMsg>>Msg.stream
let inStream = inMsg>>Msg.stream
SetFilePos(inStream, lv inMsg>>Msg.posTxt)
MoveBlock(lv outMsg>>Msg.lenTxt, lv inMsg>>Msg.lenTxt, 2)
DiskToDisk(outStream, inStream, lv outMsg>>Msg.lenTxt)
MoveBlock(lv outMsg>>Msg.lenTxt, lv inMsg>>Msg.lenTxt, 2)
if (FilePos(outStream, lv outMsg>>Msg.posEnd) & 1) eq 1 then
[
Puts(outStream, 0) //pad to word boundary
DoubleIncrement(lv outMsg>>Msg.posEnd)
]
ReadCalendar(lv outMsg>>Msg.date)
SetFilePos(outStream, lv outMsg>>Msg.posBegin)
outMsg>>Msg.version = mhVersion
outMsg>>Msg.seal = mhSeal
WriteBlock(outStream, lv outMsg>>Msg.mh, lenMH)
FileLength(outStream) //so Closes doesn't truncate
Closes(outStream)
// time in seconds msg waited in <Mail>New>Mail
MailStatDelay(msTypeSort, lv inMsg>>Msg.date)
SysFree(outMsg)
resultis 0
]