-- Transport Mechanism Mail Server - Mailbox management --

-- [Indigo]<Grapevine>MS>MailboxAlloc.mesa

-- Andrew Birrell	September 14, 1982 2:14 pm
-- Randy Gobbel		19-May-81 20:47:16
-- Mark Johnson		19-May-81 13:43:58

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, WriteChar, WriteLogEntry,
		       WriteString ],
MailboxDefs,
ObjectDirDefs	USING[ noObject, FreeObject, UseObject ],
PolicyDefs	USING[ ArchiverPause, EndOperation, 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, 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;


-- 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.WriteLogEntry["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];
      now: BodyDefs.PackedTime = Time.Current[];
      old: BodyDefs.PackedTime = now - 
                                LONG[ReadArchiveDays[]] * 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] };
           HeapDefs.HeapEndWrite[writer, GetReader];
           THROUGH [ 1..count ]
           DO who: BodyDefs.RName = [BodyDefs.maxRNameLength];
              BEGIN
                 [] _ HeapDefs.HeapReadRName[reader, who];
                 Archive[who, 0 ! InaccessibleArchive => GOTO failed];
              EXITS
                 failed => { LogAction[who, archFail]; EXIT };
              END;
           ENDLOOP;
           HeapDefs.HeapEndRead[reader];
           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] =
   BEGIN
   OPEN str;
   encountered: LONG CARDINAL _ 0;
   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;
           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;
      END;
      VMDefs.Release[page];
      IF DelTyped[] THEN GOTO del;
   ENDLOOP;
   WriteDecimal[freePageCount]; WriteString[" empty pages"L];
   WriteChar[Ascii.CR];
   WriteString["mailboxContents = "L];
   WriteLongDecimal[mailboxContents]; WriteChar[Ascii.CR];
--   WriteString["encountered = "L];
--   WriteLongDecimal[encountered]; WriteChar[Ascii.CR];
   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.