-- Copyright (C) 1981, 1984, 1999 by Xerox Corporation. All rights reserved.
-- MailboxAlloc.mesa, Transport Mechanism Mail Server - Mailbox management --
-- HGM, 16-Dec-84 3:33:26
-- Andrew Birrell September 14, 1982 2:14 pm
-- Randy Gobbel 19-May-81 20:47:16
-- Mark Johnson 19-May-81 13:43:58
-- Hankins 10-Aug-84 16:22:13 Klamath update
DIRECTORY
Ascii USING [CR, TAB],
BitMapDefs USING [Map, FindFree, Clear, Test, Set],
BodyDefs USING [
ItemHeader, ItemLength, maxRNameLength, oldestTime, PackedTime, RName,
RNameSize, Timestamp],
BTreeDefs USING [BTreeHandle, Call, Delete, EnumerateFrom, Insert, Lookup],
EnquiryDefs USING [Handle],
HeapDefs USING [
GetReaderOffset, HeapAbandonWrite, HeapEndRead, HeapEndWrite, HeapReadData,
HeapReadRName, HeapStartRead, HeapStartWrite, HeapWriteData, HeapWriteRName,
ObjectNumber, ReaderHandle, ReadItemHeader, SendObj, SetReaderOffset,
WriterHandle],
Inline USING [COPY],
LogDefs USING [DisplayNumber, ShowLine, ShowNumber, WriteChar, WriteLogEntry, WriteString],
MailboxDefs,
ObjectDirDefs USING [noObject, FreeObject, UseObject],
PolicyDefs USING [ArchiverPause, EndOperation, Wait, WaitOperation],
Process USING [InitializeMonitor],
ProtocolDefs USING [
AppendTimestamp, Handle, Remark, SendItemHeader, SendTimestamp],
ReturnDefs USING [CopyItem],
SLDefs USING [SLHeader, SLWrite],
SpillDefs USING [
AddBody, ArchReader, CopyBody, CopyText, Delete, DeleteEntry, EndWrite,
EndReading, OpenToRead, RecoverBody, ServerCrash, StartWrite, TestDeletion],
String USING [AppendDecimal, AppendString, EquivalentStrings, LowerCase],
Storage USING [Node],
Time USING [Append, Current, Unpack],
VMDefs USING [
Page, ReadPage, UsePage, PageNumber, PageIndex, Release, FileHandle,
MarkStartWait, LookAheadCount];
MailboxAlloc: MONITOR
IMPORTS
BitMapDefs, BodyDefs, BTreeDefs, HeapDefs, Inline, LogDefs, ObjectDirDefs,
PolicyDefs, Process, ProtocolDefs, ReturnDefs, SLDefs, SpillDefs, String,
Storage, Time, VMDefs
EXPORTS EnquiryDefs, MailboxDefs
SHARES MailboxDefs =
BEGIN
Allocate: PROCEDURE [CARDINAL] RETURNS [POINTER] = Storage.Node;
MBXName: TYPE = VMDefs.PageNumber;
MBXHandle: PUBLIC TYPE = POINTER TO MBXData;
-- representation of state of mailbox reading --
MBXData: TYPE = MONITORED RECORD [
lock: MBXName, -- page number for mailbox interlock bit --
latest: MBXName, --address of latest page of mbx--
where: MBXName, --address of this page--
current: CARDINAL, --number of next page to be read--
messages: DESCRIPTOR FOR ARRAY OF HeapDefs.ObjectNumber, --messages in this page--
nextMsg: CARDINAL, -- index into array of messages --
object: HeapDefs.ObjectNumber, -- current element of "messages" --
bodyObj: HeapDefs.ObjectNumber, --"object" without TOC indirection --
archObj: HeapDefs.ObjectNumber, -- current "archived" object --
archCount: CARDINAL, -- count relative to start of archive file --
archFile: SpillDefs.ArchReader,
archOpen: BOOLEAN,
remainder: CARDINAL, -- number of messages left in the mailbox --
next: MBXHandle, -- for free chain of 'MBXData's--
page: VMDefs.Page --current page buffer-- ];
-- header in disk representation of each mailbox page --
MBXHeader: TYPE = RECORD [
chain: MBXName, --previous MBX page of this MBX--
first: VMDefs.PageIndex, --first entry in this page--
free: VMDefs.PageIndex,
number: CARDINAL --page number within this MBX-- ];
MBXEnd: MBXHandle = NIL;
MBXChain: MBXHandle ← MBXEnd;
handle: VMDefs.FileHandle;
lookAhead: VMDefs.LookAheadCount = 0;
pageMap: BitMapDefs.Map;
mailboxes: CARDINAL ← 0;
-- proc var's for MailboxRestart to use:
Arch: TYPE = PROC;
FindIn: TYPE = PROC [who: BodyDefs.RName] RETURNS [TreeRec];
GetBody: TYPE = PROC [given: HeapDefs.ObjectNumber]
RETURNS [body: HeapDefs.ObjectNumber];
ReadP: TYPE = PROC [body: HeapDefs.ObjectNumber]
RETURNS [postmark: BodyDefs.Timestamp];
ChangeIn: TYPE = PROC [
who: BodyDefs.RName, where, lock: MBXName, oldest: BodyDefs.Timestamp];
archiver: Arch ← Archiver;
findInTree: FindIn ← FindInTree;
getBodyObj: GetBody ← GetBodyObj;
readPostmark: ReadP ← ReadPostmark;
changeInTree: ChangeIn ← ChangeInTree;
-- punning for R-Names --
RNameDesc: PROCEDURE [name: BodyDefs.RName]
RETURNS [DESCRIPTOR FOR ARRAY OF WORD] =
BEGIN
index: CARDINAL;
FOR index IN [0..name.length) DO
name[index] ← String.LowerCase[name[index]] ENDLOOP;
IF name.length MOD 2 # 0 THEN name[name.length] ← '@;
RETURN[DESCRIPTOR[@(name.text), (1 + name.length) / 2]]
END;
-- Management of Btree entries --
tree: BTreeDefs.BTreeHandle;
TreeRec: TYPE = RECORD [
SELECT t: * FROM
found => [where, lock: MBXName, oldest: BodyDefs.Timestamp],
empty => [last: BodyDefs.Timestamp],
ENDCASE];
FindInTree: INTERNAL PROCEDURE [who: BodyDefs.RName] RETURNS [TreeRec] =
BEGIN
value: TreeRec;
length: CARDINAL = BTreeDefs.Lookup[
tree, RNameDesc[who], DESCRIPTOR[@value, SIZE[TreeRec]]];
IF length = 177777B THEN -- not in tree --
RETURN[[empty[BodyDefs.oldestTime]]]
ELSE RETURN[value]
END;
ChangeInTree: INTERNAL PROCEDURE [
who: BodyDefs.RName, where, lock: MBXName, oldest: BodyDefs.Timestamp] =
BEGIN
value: TreeRec ← [found[where: where, lock: lock, oldest: oldest]];
BTreeDefs.Insert[tree, RNameDesc[who], DESCRIPTOR[@value, SIZE[TreeRec]]];
END;
EmptyInTree: ENTRY PROCEDURE [who: BodyDefs.RName, last: BodyDefs.Timestamp] =
BEGIN
value: TreeRec ← [empty[last]];
BTreeDefs.Insert[tree, RNameDesc[who], DESCRIPTOR[@value, SIZE[TreeRec]]];
mailboxes ← mailboxes - 1;
END;
PurgeFromTree: ENTRY PROCEDURE [who: BodyDefs.RName] =
BEGIN
value: TreeRec = FindInTree[who];
WITH value SELECT FROM
empty => BTreeDefs.Delete[tree, RNameDesc[who]];
ENDCASE => NULL -- someone else may have reinstated it -- ;
END;
EnumerateTree: ENTRY PROC [work: PROC [BodyDefs.RName, found TreeRec]] =
BEGIN
-- beware: calls "work" with the monitor locked --
Action: INTERNAL BTreeDefs.Call =
BEGIN
value: POINTER TO TreeRec = LOOPHOLE[BASE[v]];
name: BodyDefs.RName = [BodyDefs.maxRNameLength];
more ← TRUE;
dirty ← FALSE; -- results of "Action" --
IF LENGTH[k] = 0 THEN RETURN;
name.length ← 2 * LENGTH[k];
Inline.COPY[from: BASE[k], to: @(name.text), nwords: LENGTH[k]];
IF name.length > 0 AND name[name.length - 1] = '@ THEN
name.length ← name.length - 1 -- undo padding kludge -- ;
WITH res: value SELECT FROM found => work[name, res]; ENDCASE => NULL;
END;
BTreeDefs.EnumerateFrom[tree, DESCRIPTOR[NIL, 0], Action ! UNWIND => NULL];
END;
-- Interlocks on mailboxes --
-- the lock map is used for single writer/multiple reader synchronization
-- Any potential writer tests the lock; readers claim it. Both always
-- have the monitor lock while doing this.
lockMap: BitMapDefs.Map;
conflictMap: BitMapDefs.Map;
MBXFree: CONDITION;
AcquireMBX: INTERNAL PROCEDURE [who: BodyDefs.RName]
RETURNS [found: BOOLEAN, mbx, lock: MBXName] =
BEGIN
DO
value: TreeRec = FindInTree[who];
WITH res: value SELECT FROM
empty => {found ← FALSE; EXIT};
found =>
IF LockedMBX[res.lock] THEN WAIT MBXFree
ELSE
BEGIN
found ← TRUE;
mbx ← res.where;
lock ← res.lock;
BitMapDefs.Set[lockMap, lock];
EXIT
END;
ENDCASE => ERROR;
ENDLOOP;
END;
LockedMBX: INTERNAL PROCEDURE [lock: MBXName] RETURNS [locked: BOOLEAN] =
BEGIN
locked ← BitMapDefs.Test[lockMap, lock];
IF locked THEN BitMapDefs.Set[conflictMap, lock];
END;
FreeMBX: INTERNAL PROCEDURE [lock: MBXName] =
BEGIN
BitMapDefs.Clear[lockMap, lock];
IF BitMapDefs.Test[conflictMap, lock] THEN {
BitMapDefs.Clear[conflictMap, lock]; NoteUnlocked[]};
BROADCAST MBXFree;
END;
unlockedMBX: BOOLEAN ← TRUE;
unlockedMBXCond: CONDITION;
WaitForUnlocked: PUBLIC ENTRY PROC =
BEGIN
UNTIL unlockedMBX DO WAIT unlockedMBXCond ENDLOOP;
unlockedMBX ← FALSE;
END;
NoteUnlocked: INTERNAL PROC = INLINE {
unlockedMBX ← TRUE; NOTIFY unlockedMBXCond};
-- Access to mailboxes --
nextVirginPage: VMDefs.PageNumber; -- size of mailbox file --
WrongNewMBXPage: ERROR = CODE;
mailboxContents: LONG CARDINAL ← 0;
MBXWrite: PUBLIC ENTRY PROCEDURE [
who: BodyDefs.RName, obj: HeapDefs.ObjectNumber, postmark: BodyDefs.Timestamp]
RETURNS [done: BOOLEAN] =
BEGIN
ENABLE UNWIND => NULL;
addPage: BOOLEAN ← FALSE;
page: VMDefs.Page;
header: POINTER TO MBXHeader;
number: CARDINAL; -- number of a new page within this mailbox --
mbx: TreeRec = FindInTree[who: who];
WITH tree: mbx SELECT FROM
empty =>
BEGIN
IF tree.last = postmark THEN {
LogDefs.WriteChar['E];
LogDefs.WriteChar['!];
RETURN[TRUE] --duplicate-- };
number ← 0;
addPage ← TRUE;
-- no interlock to check --
END;
found =>
BEGIN
page ← VMDefs.ReadPage[[handle, tree.where], lookAhead];
header ← LOOPHOLE[page, POINTER] + FIRST[VMDefs.PageIndex];
IF header.first # header.free THEN -- test for duplicate elimination --
BEGIN
x: POINTER TO HeapDefs.ObjectNumber =
LOOPHOLE[page, POINTER] + header.free - SIZE[HeapDefs.ObjectNumber];
IF x↑ = obj THEN
BEGIN
VMDefs.Release[page];
LogDefs.WriteChar['E];
RETURN[TRUE] --duplicate--
END;
END;
IF LockedMBX[tree.lock] THEN BEGIN VMDefs.Release[page]; RETURN[FALSE] END
--ELSE we are protected by our monitor lock -- ;
IF header.free + SIZE[HeapDefs.ObjectNumber] > LAST[VMDefs.PageIndex] THEN
-- will need to expand to another page --
BEGIN
number ← header.number + 1;
VMDefs.Release[page];
addPage ← TRUE;
END;
IF tree.oldest = BodyDefs.oldestTime AND NOT addPage THEN
ChangeInTree[
who: who, where: tree.where, lock: tree.lock, oldest: postmark];
END;
ENDCASE => ERROR;
IF addPage THEN
BEGIN -- create and initialise new page of mailbox --
desc: DESCRIPTOR FOR ARRAY OF WORD = DESCRIPTOR[
who, BodyDefs.RNameSize[who]];
new: MBXName = BitMapDefs.FindFree[pageMap];
IF new >= nextVirginPage THEN
IF new > nextVirginPage THEN ERROR WrongNewMBXPage[]
ELSE nextVirginPage ← nextVirginPage + 1;
BitMapDefs.Set[pageMap, new];
WITH tree: mbx SELECT FROM
empty =>
BEGIN
ChangeInTree[who: who, where: new, lock: new, oldest: postmark];
mailboxes ← mailboxes + 1;
END;
found =>
ChangeInTree[
who: who, where: new, lock: tree.lock,
oldest:
IF tree.oldest = BodyDefs.oldestTime THEN postmark ELSE tree.oldest];
ENDCASE => ERROR;
page ← VMDefs.UsePage[[handle, new]];
header ← LOOPHOLE[page, POINTER] + FIRST[VMDefs.PageIndex];
header.free ← FIRST[VMDefs.PageIndex] + SIZE[MBXHeader];
Inline.COPY[BASE[desc], LENGTH[desc], page + header.free];
header.first ← header.free ← header.free + LENGTH[desc];
header.chain ←
WITH tree: mbx SELECT FROM found => tree.where, ENDCASE => new
-- end-of-chain -- ;
header.number ← number;
END;
BEGIN
x: POINTER TO HeapDefs.ObjectNumber = LOOPHOLE[page, POINTER] + header.free;
x↑ ← obj;
END;
header.free ← header.free + SIZE[HeapDefs.ObjectNumber];
ObjectDirDefs.UseObject[obj];
mailboxContents ← mailboxContents + 1; -- global count --
VMDefs.MarkStartWait[page];
VMDefs.Release[page];
RETURN[TRUE]
END;
FreeMBXPage: ENTRY PROC [page: MBXName] = {BitMapDefs.Clear[pageMap, page]};
Poll: PUBLIC ENTRY PROCEDURE [who: BodyDefs.RName] RETURNS [found: BOOLEAN] =
BEGIN
value: TreeRec = FindInTree[who];
found ← WITH value SELECT FROM found => TRUE, ENDCASE => FALSE;
END;
Open: PUBLIC ENTRY PROCEDURE [who: BodyDefs.RName]
RETURNS [found: BOOLEAN, count: CARDINAL, mbx: MBXHandle] =
BEGIN
IF MBXChain = MBXEnd THEN mbx ← Allocate[SIZE[MBXData]]
ELSE BEGIN mbx ← MBXChain; MBXChain ← MBXChain.next END;
[found, mbx.latest, mbx.lock] ← AcquireMBX[who: who];
IF found THEN
BEGIN
Process.InitializeMonitor[@mbx.LOCK];
SetupMBX[mbx];
count ← mbx.remainder;
END
ELSE
BEGIN
LogAction[who, nothing];
mbx.next ← MBXChain;
MBXChain ← mbx;
count ← 0;
mbx ← NIL;
END;
END;
Destroy: ENTRY PROC [mbx: MBXHandle] =
BEGIN
VMDefs.Release[mbx.page];
FreeMBX[mbx.lock];
mbx.next ← MBXChain;
MBXChain ← mbx;
END;
RestartMBX: PROC [mbx: MBXHandle] =
BEGIN
-- re-positions to start of mailbox without releasing lock --
CloseArch[mbx];
VMDefs.Release[mbx.page];
SetupMBX[mbx];
END;
SetupMBX: PROC [mbx: MBXHandle] =
BEGIN
mbx.current ← 0;
mbx.page ← VMDefs.ReadPage[[handle, mbx.where ← mbx.latest], lookAhead];
mbx.remainder ← GetPage[mbx];
mbx.archObj ← ObjectDirDefs.noObject;
mbx.archOpen ← FALSE;
END;
GetPage: PROCEDURE [mbx: MBXHandle] RETURNS [count: CARDINAL] =
BEGIN
header: POINTER TO MBXHeader;
count ← 0;
IF mbx.where # mbx.latest THEN
BEGIN -- finish with previous page --
VMDefs.Release[mbx.page];
mbx.page ← VMDefs.ReadPage[[handle, mbx.where ← mbx.latest], lookAhead];
END;
DO
BEGIN
header ← LOOPHOLE[mbx.page, POINTER] + FIRST[VMDefs.PageIndex];
count ← count + (header.free - header.first) / SIZE[HeapDefs.ObjectNumber];
IF header.number = mbx.current THEN EXIT;
BEGIN
next: MBXName = header.chain; -- that store is about to go --
VMDefs.Release[mbx.page];
mbx.where ← next;
END;
mbx.page ← VMDefs.ReadPage[[handle, mbx.where], lookAhead];
END;
ENDLOOP;
mbx.messages ← DESCRIPTOR[
mbx.page + header.first,
(header.free - header.first) / SIZE[HeapDefs.ObjectNumber]];
mbx.nextMsg ← 0;
mbx.current ← mbx.current + 1;
END;
NextMessage: PUBLIC PROC [mbx: MBXHandle]
RETURNS [msgExists, archived, deleted: BOOLEAN] = {
[msgExists, archived, deleted] ← RealNextMessage[mbx, yes]};
RealNextMessage: PROC [mbx: MBXHandle, testArchDeletion: {yes, no}]
RETURNS [msgExists, archived, deleted: BOOLEAN] =
BEGIN
IF mbx.remainder = 0 THEN RETURN[FALSE, FALSE, FALSE];
IF mbx.nextMsg = LENGTH[mbx.messages] THEN [] ← GetPage[mbx];
IF LENGTH[mbx.messages] = 0 THEN ERROR;
mbx.nextMsg ← mbx.nextMsg + 1;
mbx.remainder ← mbx.remainder - 1;
mbx.object ← mbx.messages[mbx.nextMsg - 1];
mbx.bodyObj ← GetBodyObj[mbx.object];
archived ← (mbx.bodyObj.type = archived);
IF archived THEN
BEGIN
ENABLE
BEGIN
SpillDefs.ServerCrash => ERROR InaccessibleArchive[];
UNWIND => mbx.archOpen ← FALSE;
END;
IF mbx.bodyObj = mbx.archObj THEN mbx.archCount ← mbx.archCount + 1
ELSE {CloseArch[mbx]; mbx.archObj ← mbx.bodyObj; mbx.archCount ← 0};
IF testArchDeletion = yes THEN
BEGIN
OpenArch[mbx]; -- for deletion test! --
deleted ← SpillDefs.TestDeletion[mbx.archFile, mbx.archCount];
END
ELSE deleted ← FALSE --don't care--
END
ELSE
BEGIN
deleted ← (mbx.bodyObj = ObjectDirDefs.noObject);
IF NOT deleted -- deleted msgs were skipped when archiving --
THEN {CloseArch[mbx]; mbx.archObj ← ObjectDirDefs.noObject};
END;
msgExists ← TRUE;
END;
ReadTOC: PUBLIC PROC [mbx: MBXHandle, text: ProtocolDefs.Remark] =
BEGIN
IF mbx.object.type # TOC THEN text.length ← 0
ELSE
BEGIN
reader: HeapDefs.ReaderHandle = HeapDefs.HeapStartRead[mbx.object];
obj: HeapDefs.ObjectNumber;
[] ← HeapDefs.HeapReadData[reader, [@obj, SIZE[HeapDefs.ObjectNumber]]];
--CHEAT-- [] ← HeapDefs.HeapReadRName[reader, text];
HeapDefs.HeapEndRead[reader];
END;
END;
GetBodyObj: PROC [given: HeapDefs.ObjectNumber]
RETURNS [body: HeapDefs.ObjectNumber] =
BEGIN
IF given.type = TOC THEN
BEGIN
tocReader: HeapDefs.ReaderHandle = HeapDefs.HeapStartRead[given];
[] ← HeapDefs.HeapReadData[tocReader, [@body, SIZE[HeapDefs.ObjectNumber]]];
HeapDefs.HeapEndRead[tocReader];
END
ELSE body ← given;
END;
InaccessibleArchive: PUBLIC ERROR = CODE;
SendBody: PUBLIC PROC [mbx: MBXHandle, str: ProtocolDefs.Handle] =
BEGIN
IF mbx.bodyObj.type = archived THEN
BEGIN
ENABLE
BEGIN
SpillDefs.ServerCrash => ERROR InaccessibleArchive[];
UNWIND => mbx.archOpen ← FALSE;
END;
OpenArch[mbx];
SpillDefs.CopyBody[mbx.archFile, mbx.archCount, str];
CountArchived[];
END
ELSE
BEGIN
reader: HeapDefs.ReaderHandle = HeapDefs.HeapStartRead[mbx.bodyObj];
header: BodyDefs.ItemHeader = HeapDefs.ReadItemHeader[reader];
postmark: BodyDefs.Timestamp;
IF header.type # PostMark THEN ERROR;
[] ← HeapDefs.HeapReadData[reader, [@postmark, SIZE[BodyDefs.Timestamp]]];
ConsiderDelay[postmark];
ProtocolDefs.SendItemHeader[str, header];
ProtocolDefs.SendTimestamp[str, postmark];
HeapDefs.SendObj[reader, str];
END;
END;
SendText: PUBLIC PROC [
mbx: MBXHandle, sendLength: PROC [BodyDefs.ItemLength], str: UNSPECIFIED,
sendBytes: PROC [UNSPECIFIED, POINTER, CARDINAL]] =
BEGIN
IF mbx.bodyObj.type = archived THEN
BEGIN
ENABLE
BEGIN
SpillDefs.ServerCrash => ERROR InaccessibleArchive[];
UNWIND => mbx.archOpen ← FALSE;
END;
OpenArch[mbx];
SpillDefs.CopyText[mbx.archFile, mbx.archCount, sendLength, str, sendBytes];
CountArchived[];
END
ELSE
BEGIN
reader: HeapDefs.ReaderHandle = HeapDefs.HeapStartRead[mbx.bodyObj];
DO
ENABLE UNWIND => HeapDefs.HeapEndRead[reader];
header: BodyDefs.ItemHeader = HeapDefs.ReadItemHeader[reader];
SELECT header.type FROM
PostMark =>
BEGIN
postmark: BodyDefs.Timestamp;
[] ← HeapDefs.HeapReadData[
reader, [@postmark, SIZE[BodyDefs.Timestamp]]];
ConsiderDelay[postmark];
END;
Text =>
BEGIN
sendLength[header.length];
ReturnDefs.CopyItem[reader, header.length, sendBytes, str];
EXIT
END;
LastItem => EXIT --no text-- ;
ENDCASE =>
HeapDefs.SetReaderOffset[
reader, HeapDefs.GetReaderOffset[reader] + (header.length + 1) / 2];
ENDLOOP;
HeapDefs.HeapEndRead[reader];
END;
END;
OpenArch: PROC [mbx: MBXHandle] =
BEGIN
IF NOT mbx.archOpen THEN
BEGIN
mbx.archFile ← SpillDefs.OpenToRead[mbx.archObj];
mbx.archOpen ← TRUE;
END;
END;
CloseArch: PROC [mbx: MBXHandle] =
BEGIN
IF mbx.archOpen THEN
SpillDefs.EndReading[mbx.archFile ! SpillDefs.ServerCrash => CONTINUE];
mbx.archOpen ← FALSE;
END;
WriteTOC: PUBLIC PROC [mbx: MBXHandle, text: ProtocolDefs.Remark] =
BEGIN
Accept: PROC [obj: HeapDefs.ObjectNumber] =
BEGIN
ObjectDirDefs.UseObject[obj];
mbx.messages[mbx.nextMsg - 1] ← obj;
VMDefs.MarkStartWait[mbx.page];
IF mbx.object.type = TOC THEN ObjectDirDefs.FreeObject[mbx.object];
mbx.object ← obj;
END;
body: HeapDefs.ObjectNumber ← mbx.bodyObj;
IF text.length = 0 THEN
BEGIN
-- no TOC required --
IF mbx.object.type = TOC THEN {
Accept[body]; ObjectDirDefs.FreeObject[body]};
END
ELSE
BEGIN
writer: HeapDefs.WriterHandle = HeapDefs.HeapStartWrite[TOC];
HeapDefs.HeapWriteData[writer, [@body, SIZE[HeapDefs.ObjectNumber]]];
--CHEAT-- HeapDefs.HeapWriteRName[writer, text];
HeapDefs.HeapEndWrite[writer, Accept];
END;
END;
DeleteMessage: PUBLIC PROC [mbx: MBXHandle] =
BEGIN
IF mbx.bodyObj.type = archived THEN
BEGIN
ENABLE
BEGIN
SpillDefs.ServerCrash => ERROR InaccessibleArchive[];
UNWIND => mbx.archOpen ← FALSE;
END;
IF mbx.object.type = TOC THEN
BEGIN
mbx.messages[mbx.nextMsg - 1] ← mbx.bodyObj;
VMDefs.MarkStartWait[mbx.page];
END;
OpenArch[mbx];
SpillDefs.DeleteEntry[mbx.archFile, mbx.archCount];
END
ELSE
BEGIN
mbx.messages[mbx.nextMsg - 1] ← ObjectDirDefs.noObject;
VMDefs.MarkStartWait[mbx.page];
ObjectDirDefs.FreeObject[mbx.bodyObj];
mbx.bodyObj ← ObjectDirDefs.noObject;
END;
IF mbx.object.type = TOC THEN
BEGIN ObjectDirDefs.FreeObject[mbx.object]; mbx.object ← mbx.bodyObj; END;
END;
Close: PUBLIC PROCEDURE [mbx: MBXHandle] =
BEGIN
LogAction[
LOOPHOLE[mbx.page, POINTER] + FIRST[VMDefs.PageIndex] + SIZE[MBXHeader],
no];
InnerClose[mbx];
END;
InnerClose: PROC [mbx: MBXHandle] = BEGIN CloseArch[mbx]; Destroy[mbx]; END;
ReadPostmark: PROC [body: HeapDefs.ObjectNumber]
RETURNS [postmark: BodyDefs.Timestamp] =
BEGIN
reader: HeapDefs.ReaderHandle = HeapDefs.HeapStartRead[body];
header: BodyDefs.ItemHeader = HeapDefs.ReadItemHeader[reader];
IF header.type # PostMark THEN ERROR;
[] ← HeapDefs.HeapReadData[reader, [@postmark, SIZE[BodyDefs.Timestamp]]];
HeapDefs.HeapEndRead[reader];
END;
FlushAndClose: PUBLIC PROCEDURE [mbx: MBXHandle] =
BEGIN
-- Beware: this procedure works without the monitor lock, because there
-- may be unbounded delays while we delete archive files. The order of
-- events is quite important! We must also take care that everything
-- will look ok if we crash in the middle of flushing a multi-page
-- mailbox.
buffer: DESCRIPTOR FOR ARRAY OF HeapDefs.ObjectNumber;
base: VMDefs.PageIndex = FIRST[VMDefs.PageIndex];
header: POINTER TO MBXHeader ← LOOPHOLE[mbx.page, POINTER] + base;
msgCount: CARDINAL ← 0;
archiveFailure: BOOLEAN ← FALSE;
lastPost: BodyDefs.Timestamp ← BodyDefs.oldestTime;
-- postmark of latest message --
DeleteArch: PROC = -- delete archive file --
BEGIN
IF mbx.archObj # ObjectDirDefs.noObject THEN
BEGIN
SpillDefs.Delete[
mbx.archObj !
SpillDefs.ServerCrash => {archiveFailure ← TRUE; CONTINUE}];
ObjectDirDefs.FreeObject[mbx.archObj];
mbx.archObj ← ObjectDirDefs.noObject;
END;
END;
IF mbx.where # mbx.latest THEN
BEGIN -- find first page --
VMDefs.Release[mbx.page];
mbx.page ← VMDefs.ReadPage[[handle, mbx.where ← mbx.latest], lookAhead];
END;
CloseArch[mbx];
mbx.archObj ← ObjectDirDefs.noObject;
DO
who: BodyDefs.RName = LOOPHOLE[mbx.page, POINTER] + base + SIZE[MBXHeader];
header ← LOOPHOLE[mbx.page, POINTER] + base;
buffer ← DESCRIPTOR[
mbx.page + header.first,
(header.free - header.first) / SIZE[HeapDefs.ObjectNumber]];
msgCount ← msgCount + LENGTH[buffer];
BEGIN -- write MBX to disk as empty, in case of crash --
header.free ← header.first;
VMDefs.MarkStartWait[mbx.page];
END;
IF mbx.where = mbx.latest THEN
BEGIN
-- this mbx page contains last mbx message --
lastObj: HeapDefs.ObjectNumber = buffer[LENGTH[buffer] - 1];
IF lastObj # ObjectDirDefs.noObject THEN
BEGIN
body: HeapDefs.ObjectNumber = GetBodyObj[lastObj];
IF body.type # archived THEN lastPost ← ReadPostmark[body]
-- ELSE lastPost is irrelevant! -- ;
END;
END;
-- decrement reference counts --
FOR index: CARDINAL DECREASING IN [0..LENGTH[buffer]) DO
obj: HeapDefs.ObjectNumber = buffer[index];
IF obj # ObjectDirDefs.noObject THEN
BEGIN
body: HeapDefs.ObjectNumber = GetBodyObj[obj];
IF obj.type = TOC THEN ObjectDirDefs.FreeObject[obj];
IF body # mbx.archObj THEN
BEGIN
DeleteArch[];
IF body.type = archived -- record for later deletion --
THEN {mbx.archObj ← body; ObjectDirDefs.UseObject[body]};
END;
ObjectDirDefs.FreeObject[body];
END;
mailboxContents ← mailboxContents - 1;
ENDLOOP;
-- Clearing bit in pageMap allows page to be re-used --
IF header.number = 0 -- we're at the end of the earliest page --
THEN
BEGIN
EmptyInTree[who, lastPost];
FreeMBXPage[mbx.where]; -- must not access page after here --
EXIT
END;
BEGIN
next: MBXName = header.chain; --that store is about to go--
FreeMBXPage[mbx.where]; -- must not access page after here --
VMDefs.Release[mbx.page];
mbx.where ← next;
mbx.page ← VMDefs.ReadPage[[handle, mbx.where], lookAhead];
END;
ENDLOOP;
DeleteArch[];
IF archiveFailure THEN
LogDefs.ShowLine["Failed to delete mailbox archive file"L];
LogAction[
LOOPHOLE[mbx.page, POINTER] + base + SIZE[MBXHeader], yes, msgCount];
Destroy[mbx];
END;
AdjustOldest: ENTRY PROC [who: BodyDefs.RName, time: BodyDefs.Timestamp] =
BEGIN
-- alter "oldest" stamp after archiving --
prev: TreeRec = FindInTree[who: who];
WITH tree: prev SELECT FROM
empty => ERROR; -- silly: we have an interlock on it! --
found =>
ChangeInTree[who: who, where: tree.where, lock: tree.lock, oldest: time];
ENDCASE => ERROR;
END;
Archive: PUBLIC PROC [who: BodyDefs.RName, keep: CARDINAL] =
BEGIN
mbx: MBXHandle;
contents: CARDINAL;
found: BOOLEAN;
[found, contents, mbx] ← Open[who];
IF found AND contents > keep THEN
BEGIN
ENABLE UNWIND => Close[mbx];
msgExists, archived, deleted: BOOLEAN;
archStart: CARDINAL ← 0;
WHILE archStart < contents - keep -- skip to non-archived message --
DO
[msgExists, archived, deleted] ← RealNextMessage[mbx, no];
IF NOT msgExists THEN ERROR;
IF NOT archived AND NOT deleted THEN EXIT;
archStart ← archStart + 1;
ENDLOOP;
IF archStart < contents - keep THEN
BEGIN
spillCount: CARDINAL = (contents - keep) - archStart;
archObj: HeapDefs.ObjectNumber;
Backup: PROC =
BEGIN
RestartMBX[mbx];
THROUGH [0..archStart] DO
[msgExists, archived, deleted] ← RealNextMessage[mbx, no]; ENDLOOP;
END;
BEGIN
ENABLE
SpillDefs.ServerCrash => {
ObjectDirDefs.FreeObject[archObj]; Backup[]; RETRY};
archObj ← SpillDefs.StartWrite[
who, spillCount ! SpillDefs.ServerCrash => ERROR InaccessibleArchive[]];
THROUGH [0..spillCount) DO
IF NOT msgExists OR archived THEN ERROR;
IF NOT deleted THEN SpillDefs.AddBody[mbx.bodyObj];
[msgExists, archived, deleted] ← NextMessage[mbx];
ENDLOOP;
SpillDefs.EndWrite[];
END;
Backup[];
THROUGH [0..spillCount) DO
IF NOT deleted THEN
BEGIN
mbx.messages[mbx.nextMsg - 1] ← archObj;
ObjectDirDefs.UseObject[archObj];
VMDefs.MarkStartWait[mbx.page];
IF mbx.object.type = TOC THEN ObjectDirDefs.FreeObject[mbx.object];
ObjectDirDefs.FreeObject[mbx.bodyObj];
END;
[msgExists, archived, deleted] ← NextMessage[mbx];
ENDLOOP;
AdjustOldest[
who,
IF msgExists THEN ReadPostmark[mbx.bodyObj] ELSE BodyDefs.oldestTime];
ObjectDirDefs.FreeObject[archObj];
LogAction[who, arch, spillCount];
END;
END;
IF found THEN InnerClose[mbx];
END;
defaultDays: CARDINAL = 7;
archiveDays: CARDINAL ← defaultDays;
ReadArchiveDays: ENTRY PROC RETURNS [days: CARDINAL] = INLINE {
days ← archiveDays; archiveDays ← defaultDays};
SetArchiveDays: PUBLIC ENTRY PROC [days: CARDINAL] = {archiveDays ← days};
Archiver: PROC =
BEGIN
DO
PolicyDefs.ArchiverPause[];
PolicyDefs.WaitOperation[archiver];
BEGIN
writer: HeapDefs.WriterHandle = HeapDefs.HeapStartWrite[temp];
archivePeriod: CARDINAL ← ReadArchiveDays[];
now: BodyDefs.PackedTime = Time.Current[];
old: BodyDefs.PackedTime = now - LONG[archivePeriod] * 24 * 60 * 60;
count: CARDINAL ← 0;
Work: PROC [who: BodyDefs.RName, tree: found TreeRec] =
BEGIN
IF tree.oldest # BodyDefs.oldestTime AND tree.oldest.time < old THEN {
HeapDefs.HeapWriteRName[writer, who]; count ← count + 1};
END;
EnumerateTree[Work];
IF count = 0 THEN HeapDefs.HeapAbandonWrite[writer]
ELSE
BEGIN
reader: HeapDefs.ReaderHandle;
GetReader: PROC [obj: HeapDefs.ObjectNumber] = {
reader ← HeapDefs.HeapStartRead[obj]};
LogDefs.ShowNumber["Starting mailbox archiving. ("L, archivePeriod, " day cutoff)."L];
HeapDefs.HeapEndWrite[writer, GetReader];
THROUGH [0..count) DO
once: BOOLEAN ← FALSE;
who: BodyDefs.RName = [BodyDefs.maxRNameLength];
[] ← HeapDefs.HeapReadRName[reader, who];
BEGIN ENABLE InaccessibleArchive => {
LogAction[who, archFail];
RETRY; };
IF once THEN {
PolicyDefs.EndOperation[archiver];
PolicyDefs.Wait[mins: 15];
PolicyDefs.WaitOperation[archiver]; };
once ← TRUE;
Archive[who, 0];
END;
ENDLOOP;
HeapDefs.HeapEndRead[reader];
LogDefs.ShowLine["Finished archiving mailboxes."L];
END;
END;
PolicyDefs.EndOperation[archiver];
ENDLOOP;
END;
Remail: PUBLIC PROC [who: BodyDefs.RName, valid: BOOLEAN] =
BEGIN
RemailMessage: PROC [body: HeapDefs.ObjectNumber] =
BEGIN
log: STRING = [64];
slHeader: SLDefs.SLHeader;
slHeader.created ← ReadPostmark[body];
slHeader.received ← [0, 0, Time.Current[]];
String.AppendString[log, "Remailing "L];
ProtocolDefs.AppendTimestamp[log, slHeader.created];
String.AppendString[log, " as "L];
slHeader.created.time ← slHeader.received.time;
ProtocolDefs.AppendTimestamp[log, slHeader.created];
LogDefs.WriteLogEntry[log];
slHeader.server ← NIL;
BEGIN -- write steering list --
sl: HeapDefs.WriterHandle = HeapDefs.HeapStartWrite[SLinput];
HeapDefs.HeapWriteData[sl, [@slHeader, SIZE[SLDefs.SLHeader]]];
HeapDefs.HeapWriteRName[sl, who];
SLDefs.SLWrite[body: body, SL: sl, queue: input];
END;
END;
found: BOOLEAN;
count: CARDINAL;
mbx: MBXHandle;
[found, count, mbx] ← Open[who];
IF found THEN
BEGIN
IF valid THEN
BEGIN
ENABLE UNWIND => Close[mbx];
LogAction[who, remail];
THROUGH [1..count] DO
msgExists, archived, deleted: BOOLEAN;
[msgExists, archived, deleted] ← NextMessage[mbx];
IF NOT msgExists THEN ERROR;
IF deleted THEN LOOP;
BEGIN
ENABLE UNWIND => PolicyDefs.EndOperation[remailing];
PolicyDefs.WaitOperation[remailing];
IF mbx.bodyObj.type = archived THEN
BEGIN
ENABLE
SpillDefs.ServerCrash => {mbx.archOpen ← FALSE; GOTO inaccessible};
OpenArch[mbx];
HeapDefs.HeapEndWrite[
SpillDefs.RecoverBody[mbx.archFile, mbx.archCount], RemailMessage];
EXITS inaccessible => {ERROR InaccessibleArchive[]};
END
ELSE RemailMessage[mbx.bodyObj];
DeleteMessage[mbx];
PolicyDefs.EndOperation[remailing];
END;
ENDLOOP;
END
ELSE LogAction[who, dead];
FlushAndClose[mbx];
END;
PurgeFromTree[who];
END;
s: STRING = "Birrell.pa"; --for use from the debugger--
LogAction: PROCEDURE [
who: BodyDefs.RName, action: {yes, no, nothing, arch, archFail, remail, dead},
data: CARDINAL ← 0] =
BEGIN
log: STRING = [128];
String.AppendString[log, "Mailbox "L];
String.AppendString[log, who];
String.AppendString[
log,
SELECT action FROM
nothing => ": already empty"L,
no => ": abandoned reading"L,
yes => ": emptied, "L,
arch => ": archived "L,
archFail => ": archive failed"L,
remail => ": remailing"L,
dead => ": dead"L,
ENDCASE => ERROR];
SELECT action FROM
yes, arch =>
BEGIN
String.AppendDecimal[log, data];
String.AppendString[log, " messages"L];
END;
ENDCASE => NULL;
LogDefs.WriteLogEntry[log];
IF action = remail THEN {
LogDefs.WriteString[" Remail "L]; LogDefs.WriteString[who]};
END;
MailboxCount: PUBLIC PROC [
str: EnquiryDefs.Handle, nameSought: BodyDefs.RName] =
BEGIN OPEN str;
allNames: BOOLEAN ← String.EquivalentStrings[nameSought, "*"L];
encountered: LONG CARDINAL ← 0; -- should be equivalent to mailboxContents
freePageCount: CARDINAL ← 0;
WriteChar[Ascii.CR];
FOR pageNumber: CARDINAL IN [0..nextVirginPage) DO
page: VMDefs.Page = VMDefs.ReadPage[[handle, pageNumber], 0];
BEGIN
ENABLE UNWIND => VMDefs.Release[page];
header: POINTER TO MBXHeader = LOOPHOLE[page];
IF header.first = header.free THEN freePageCount ← freePageCount + 1
ELSE
BEGIN
name: BodyDefs.RName = LOOPHOLE[page, POINTER] + SIZE[MBXHeader];
count: CARDINAL =
(header.free - header.first) / SIZE[HeapDefs.ObjectNumber];
objects: DESCRIPTOR FOR ARRAY OF HeapDefs.ObjectNumber = DESCRIPTOR[
LOOPHOLE[page, POINTER] + header.first, count];
tocCount: CARDINAL ← 0;
delCount: CARDINAL ← 0;
archCount: CARDINAL ← 0;
IF ~allNames AND ~String.EquivalentStrings[nameSought, name] THEN
GOTO tryNextName;
WriteString[name];
WriteChar['(];
WriteDecimal[header.number];
WriteChar[')];
WriteString[": "L];
WriteDecimal[count];
encountered ← encountered + count;
WriteString[" messages"L];
FOR this: CARDINAL IN [0..count) DO
SELECT objects[this].type FROM
TOC => tocCount ← tocCount + 1;
archived => archCount ← archCount + 1;
gap => delCount ← delCount + 1;
ENDCASE => NULL;
ENDLOOP;
IF tocCount # 0 THEN {
WriteString["; "L]; WriteDecimal[tocCount]; WriteString[" TOC's"L]};
IF delCount # 0 THEN {
WriteString["; "L]; WriteDecimal[delCount]; WriteString[" deleted"L]};
IF archCount # 0 THEN {
WriteString["; "L]; WriteDecimal[archCount]; WriteString[" archived"L]};
IF header.number = 0 THEN
BEGIN
LookInTree: ENTRY PROC RETURNS [TreeRec] = INLINE {
RETURN[FindInTree[name]]};
mbx: TreeRec = LookInTree[];
WriteString["; "L];
WITH tree: mbx SELECT FROM
empty => WriteString[" *** not in tree!"L];
found =>
IF tree.oldest = BodyDefs.oldestTime THEN WriteString["no date"L]
ELSE
BEGIN
t: STRING = [18]; -- 29-Feb-99 24:23:22 --
Time.Append[t, Time.Unpack[LOOPHOLE[tree.oldest.time]]];
WriteString[t];
END;
ENDCASE => WriteString[" *** illegal tree entry"L];
END;
WriteChar[Ascii.CR];
END;
EXITS tryNextName => NULL;
END;
VMDefs.Release[page];
IF DelTyped[] THEN GOTO del;
ENDLOOP;
IF allNames THEN
BEGIN
WriteDecimal[freePageCount];
WriteString[" empty pages"L];
WriteChar[Ascii.CR];
WriteString["Number of mailboxes with content = "L];
WriteLongDecimal[mailboxes];
WriteChar[Ascii.CR];
WriteString["Total of messages in mailboxes (some are duplicates) = "L];
WriteLongDecimal[encountered];
WriteChar[Ascii.CR];
END;
EXITS del => {str.Flush[]; str.WriteString[" XXX"L]};
END;
HistBox: TYPE = {min17, min53, min160, hr8, day1, day3, day9, longer, archived};
histInterval: ARRAY HistBox OF CARDINAL = [
(8 * 60) / 27, (8 * 60) / 9, (8 * 60) / 3, 8 * 60, 3 * 8 * 60, 9 * 8 * 60,
27 * 8 * 60, LAST[CARDINAL], LAST[CARDINAL]];
histCount: ARRAY HistBox OF CARDINAL ← ALL[0];
histTotal: LONG CARDINAL ← 0;
ConsiderDelay: ENTRY PROC [postmark: BodyDefs.Timestamp] =
BEGIN
now: LONG CARDINAL = Time.Current[];
FOR box: HistBox IN [FIRST[HistBox]..longer) DO
limit: LONG CARDINAL = now - LONG[60] * histInterval[box];
IF postmark.time > limit THEN {histCount[box] ← histCount[box] + 1; EXIT};
REPEAT FINISHED => histCount[longer] ← histCount[longer] + 1
ENDLOOP;
histTotal ← histTotal + 1;
END;
CountArchived: ENTRY PROC = INLINE {
histCount[archived] ← histCount[archived] + 1; histTotal ← histTotal + 1};
Histograms: PUBLIC PROC [str: EnquiryDefs.Handle] =
BEGIN OPEN str;
histCaption: ARRAY HistBox OF STRING = [
"17 min: "L, "53 min: "L, "2.7 hr: "L, "8 hrs: "L, "24 hrs: "L,
"3 days: "L, "9 days: "L, "longer: "L, "archiv: "L];
WriteChar[Ascii.CR];
WriteString["Mail retrieval delays"L];
WriteChar[Ascii.CR];
FOR box: HistBox IN HistBox DO
WriteString[histCaption[box]];
WriteDecimal[histCount[box]];
WriteChar[Ascii.TAB];
IF histTotal = 0 THEN WriteChar['?]
ELSE WriteLongDecimal[(histCount[box] * LONG[100]) / histTotal];
WriteChar['%];
WriteChar[Ascii.CR];
ENDLOOP;
WriteString["total: "L];
WriteLongDecimal[histTotal];
END;
LogDefs.DisplayNumber["Mailboxes"L, [short[@mailboxes]]];
END.
beginnin of Aug: can't let MailboxRestart import it's proc's so make proc. vars
10-Aug-84 16:23:04: also change MailboxCount so does indiv. mailbox