-- Copyright (C) 1981, 1983, 1984  by Xerox Corporation. All rights reserved. 
-- RegBTree.mesa, Transport Mechanism Registration Server - Operations on the B-Tree --

-- HGM,	18-Nov-84  0:25:30 
-- Randy Gobbel,	19-May-81 12:12:10 
-- Andrew Birrell,	 4-Nov-81 16:19:48
-- Mike Schroeder	25-Jan-83 15:33:27 

DIRECTORY
  BodyDefs USING [maxRNameLength, oldestTime, RName, Timestamp],
  BTreeDefs,
  EnquiryDefs USING [],
  HeapDefs USING [
    GetReaderObject, HeapAbandonWrite, HeapEndWrite, HeapEndRead, HeapReadRName,
    HeapStartRead, HeapStartWrite, HeapWriteRName, ObjectNumber, ReaderHandle,
    WriterHandle],
  Inline USING [COPY],
  LogDefs USING [ShowLine],
  ObjectDirDefs USING [FreeObject, RestartObject, UseObject],
  PolicyDefs USING [EndOperation, RegPurgerPause, WaitOperation],
  Process USING [Pause],
  ProtocolDefs USING [RNameType],
  RegBTreeDefs USING [LookupReason, RegistryObject, RegState],
  RegCacheDefs USING [AddName, FlushName, ReadName, TestKnownReg],
  RegistryDefs USING [MakeTimestamp],
  RegServerDefs USING [ConsiderPurging, ReallyPurge],
  String USING [AppendString],
  VMDefs USING [OpenFile];

RegBTree: MONITOR
  IMPORTS
    BTreeDefs, HeapDefs, Inline, LogDefs, ObjectDirDefs, PolicyDefs, Process,
    RegCacheDefs, RegistryDefs, RegServerDefs, String, VMDefs
  EXPORTS EnquiryDefs, RegBTreeDefs =

  BEGIN OPEN RegBTreeDefs;

  -- the b-tree is the only part of the data structures that needs to be
  -- protected by the monitor.  The requirement is that at the end of an
  -- update to the database, the result must be accepted only if the entry
  -- in the b-tree is still the same as it was when the update commenced.
  -- If the entry has changed, a signal is raised and the update is re-
  -- calculated.
  -- B-Tree lookups must also be protected, since during b-tree entry
  -- replacement the item is temporarily deleted from the b-tree.  Note that
  -- the result of a b-tree lookup must have incremented the reference count
  -- on the object, in case someone else deletes the entry.
  -- The lookups are protected by a single-writer, multiple-reader interlock.


  LowerCase: PROCEDURE [c: CHARACTER] RETURNS [CHARACTER] = INLINE {
    RETURN[IF c IN ['A..'Z] THEN c - 'A + 'a ELSE c]};

  IsFirstGE: BTreeDefs.TestKeys =
    BEGIN
    -- parameters a,b: DESC FOR ARRAY OF WORD returns[ BOOLEAN]--
    aC: POINTER TO PACKED ARRAY OF CHARACTER = LOOPHOLE[BASE[a]];
    bC: POINTER TO PACKED ARRAY OF CHARACTER = LOOPHOLE[BASE[b]];
    FOR i: CARDINAL IN [0..2 * MIN[LENGTH[a], LENGTH[b]]) DO
      IF LowerCase[aC[i]] < LowerCase[bC[i]] THEN RETURN[FALSE];
      IF LowerCase[aC[i]] > LowerCase[bC[i]] THEN RETURN[TRUE];
      ENDLOOP;
    RETURN[LENGTH[a] >= LENGTH[b]];
    END;

  AreTheyEq: BTreeDefs.TestKeys =
    BEGIN
    aC: POINTER TO PACKED ARRAY OF CHARACTER = LOOPHOLE[BASE[a]];
    bC: POINTER TO PACKED ARRAY OF CHARACTER = LOOPHOLE[BASE[b]];
    IF LENGTH[a] = LENGTH[b] THEN
      FOR i: CARDINAL IN [0..2 * LENGTH[a]) DO
        IF LowerCase[aC[i]] # LowerCase[bC[i]] THEN EXIT;
        REPEAT FINISHED => RETURN[TRUE];
        ENDLOOP;
    RETURN[FALSE];
    END;

  RNameDesc: PROCEDURE [name: BodyDefs.RName]
    RETURNS [DESCRIPTOR FOR ARRAY OF WORD] =
    BEGIN
    IF name.length MOD 2 # 0 THEN name[name.length] ← '@;
    RETURN[DESCRIPTOR[@(name.text), (1 + name.length) / 2]]
    END;

  tree: BTreeDefs.BTreeHandle;

  Init: ENTRY PROC =
    BEGIN
    tree ← BTreeDefs.CreateAndInitializeBTree[
      fileH: LOOPHOLE[VMDefs.OpenFile[
      name: "Registration.BTree"L, options: oldOrNew, cacheFraction: 10]],
      initializeFile: TRUE, useDefaultOrderingRoutines: FALSE,
      isFirstGreaterOrEqual: IsFirstGE, areTheyEqual: AreTheyEq];
    END;

  -- BTree interlock:
  -- presence of readers is indicated by readerCount --
  -- Writers operate with the monitor locked --

  readerCount: CARDINAL ← 0;
  noReaders: CONDITION;

  StartReader: ENTRY PROC = INLINE {readerCount ← readerCount + 1};

  EndReader: ENTRY PROC = INLINE {
    readerCount ← readerCount - 1; IF readerCount = 0 THEN BROADCAST noReaders};

  StartWriter: INTERNAL PROC = INLINE {
    UNTIL readerCount = 0 DO WAIT noReaders ENDLOOP};


  -- representation of an entry within the b-tree --
  TreeData: TYPE = RECORD [
    knownReg: BOOLEAN,
    type: ProtocolDefs.RNameType,
    stamp: BodyDefs.Timestamp,
    object: HeapDefs.ObjectNumber];


  Lookup: PUBLIC PROCEDURE [
    name: BodyDefs.RName, reason: RegBTreeDefs.LookupReason]
    RETURNS [info: RegistryObject] =
    BEGIN
    -- returns a reader to ensure the object doesn't go away --
    -- if you're doing an update, the reader will be closed by Insert --
    objsize: CARDINAL = SIZE[TreeData];
    treeInfo: TreeData;
    StartReader[];
    -- try cache first --
    [treeInfo.type, treeInfo.stamp, treeInfo.object] ← RegCacheDefs.ReadName[
      name];
    IF treeInfo.type = notFound THEN
      BEGIN
      length: CARDINAL;
      length ← BTreeDefs.Lookup[
        tree, RNameDesc[name], DESCRIPTOR[@treeInfo, objsize]];
      IF length # objsize THEN treeInfo.type ← notFound
      ELSE
        RegCacheDefs.AddName[
          name, treeInfo.knownReg, treeInfo.type, treeInfo.stamp,
          treeInfo.object];
      END;
    info ←
      IF treeInfo.type # notFound THEN [
      type: treeInfo.type, stamp: treeInfo.stamp,
      reader:
      IF
      (SELECT reason FROM
         readNone => FALSE,
         readIndividual => treeInfo.type = individual,
         readGroup => treeInfo.type = group,
         readEither => treeInfo.type # dead,
         readAny => TRUE,
         ENDCASE => ERROR) THEN HeapDefs.HeapStartRead[treeInfo.object] ELSE NIL]
      ELSE [type: notFound, stamp: BodyDefs.oldestTime, reader: NIL];
    EndReader[];
    END;


  OldReaderNeeded: ERROR = CODE;
  UpdateFailed: PUBLIC ERROR [info: RegistryObject] = CODE;

  Insert: PUBLIC ENTRY PROCEDURE [
    name: BodyDefs.RName, type: ProtocolDefs.RNameType,
    stamp: POINTER TO BodyDefs.Timestamp, writer: HeapDefs.WriterHandle,
    info: POINTER TO RegistryObject] =
    BEGIN
    InsertinBTree: INTERNAL PROCEDURE [number: HeapDefs.ObjectNumber] =
      BEGIN
      value ← [knownReg: FALSE, type: type, stamp: stamp↑, object: number];
      ObjectDirDefs.UseObject[number];
      WriteToTreeAndCache[name, @value];
      END;
    value: TreeData;
    valuesize: CARDINAL = SIZE[TreeData];
    valuedesc: DESCRIPTOR FOR ARRAY OF WORD = DESCRIPTOR[@value, valuesize];
    namedesc: DESCRIPTOR FOR ARRAY OF WORD = RNameDesc[name];
    StartWriter[];
    IF info # NIL AND info.type # notFound AND info.reader = NIL THEN
      ERROR OldReaderNeeded[];
    -- here, b-tree contains either the old entry or a new one with different
    -- object number, so we can end the reader on the old object --
    BEGIN
    ENABLE UNWIND => IF writer # NIL THEN HeapDefs.HeapAbandonWrite[writer];
    oldObj: HeapDefs.ObjectNumber;
    IF info # NIL AND info.reader # NIL THEN {
      oldObj ← HeapDefs.GetReaderObject[info.reader];
      HeapDefs.HeapEndRead[info.reader]};
    IF BTreeDefs.Lookup[tree, namedesc, valuedesc] = valuesize THEN
      IF info # NIL AND (info.type = notFound OR oldObj # value.object) THEN
        ERROR UpdateFailed[
          [
          type: value.type, stamp: value.stamp,
          reader: HeapDefs.HeapStartRead[value.object]]]
      ELSE
        BEGIN
        BTreeDefs.Delete[tree, namedesc];
        RegCacheDefs.FlushName[name];
        ObjectDirDefs.FreeObject[value.object];
        END
    ELSE
      IF info # NIL AND info.type # notFound THEN
        ERROR UpdateFailed[
          [type: notFound, stamp: BodyDefs.oldestTime, reader: NIL]]
      ELSE NULL;
    END --ENABLE-- ;
    IF type # notFound THEN
      BEGIN
      IF writer = NIL THEN ERROR;
      HeapDefs.HeapEndWrite[writer, InsertinBTree];
      END;
    END;

  BadKnownRegCall: ERROR = CODE;

  KnownRegistry: PUBLIC ENTRY PROC [name: BodyDefs.RName, yes: BOOLEAN] =
    BEGIN
    value: TreeData;
    valuesize: CARDINAL = SIZE[TreeData];
    valuedesc: DESCRIPTOR FOR ARRAY OF WORD = DESCRIPTOR[@value, valuesize];
    namedesc: DESCRIPTOR FOR ARRAY OF WORD = RNameDesc[name];
    StartWriter[];
    IF BTreeDefs.Lookup[tree, namedesc, valuedesc] = valuesize THEN
      BEGIN
      IF value.type # group THEN ERROR BadKnownRegCall[];
      value.knownReg ← yes;
      WriteToTreeAndCache[name, @value];
      END
    ELSE IF yes THEN ERROR BadKnownRegCall[];
    END;

  TestKnownReg: PUBLIC PROC [name: BodyDefs.RName]
    RETURNS [state: RegBTreeDefs.RegState] =
    BEGIN
    regName: BodyDefs.RName = [BodyDefs.maxRNameLength];
    gv: STRING = ".gv"L;
    value: TreeData;
    valuesize: CARDINAL = SIZE[TreeData];
    valuedesc: DESCRIPTOR FOR ARRAY OF WORD = DESCRIPTOR[@value, valuesize];
    IF name.length > regName.maxlength THEN RETURN[bad];
    FOR i: CARDINAL DECREASING IN [0..name.length) DO
      IF name[i] = '. THEN
        BEGIN
        FOR j: CARDINAL IN [i + 1..name.length) DO
          regName[regName.length] ← name[j];
          regName.length ← regName.length + 1;
          ENDLOOP;
        EXIT
        END;
      REPEAT FINISHED => RETURN[bad]
      ENDLOOP;
    IF regName.length + gv.length > regName.maxlength THEN RETURN[bad];
    String.AppendString[regName, gv];
    StartReader[];
    state ← RegCacheDefs.TestKnownReg[regName];
    IF state = bad THEN
      BEGIN
      IF BTreeDefs.Lookup[tree, RNameDesc[regName], valuedesc] = valuesize THEN
        state ← IF value.knownReg THEN yes ELSE no
      ELSE state ← bad;
      END;
    EndReader[];
    END;


  MarkKnown: PUBLIC SIGNAL = CODE;

  EnumerateTree: PUBLIC PROCEDURE [
    type: ProtocolDefs.RNameType, action: PROCEDURE [BodyDefs.RName]] =
    BEGIN
    InnerAction: PROCEDURE [name: BodyDefs.RName, value: POINTER TO TreeData]
      RETURNS [dirty: BOOLEAN] =
      BEGIN
      dirty ← FALSE;
      IF value.type = type OR type = notFound  -- ! --
        THEN
        action[
          name !
          MarkKnown => {
            value.knownReg ← TRUE;
            dirty ← TRUE;
            RegCacheDefs.AddName[
              name, value.knownReg, value.type, value.stamp, value.object];
            RESUME
            }];
      END;
    EnumerateAllTree[InnerAction];
    END;

  EnumerateAllTree: PROC [
    action: PROCEDURE [BodyDefs.RName, POINTER TO TreeData]
      RETURNS [dirty: BOOLEAN]] =
    BEGIN
    TreeAction: BTreeDefs.Call =
      BEGIN
      rName: BodyDefs.RName = [BodyDefs.maxRNameLength];
      value: POINTER TO TreeData = LOOPHOLE[BASE[v]];
      IF LENGTH[k] = 0 THEN {dirty ← FALSE; more ← TRUE; RETURN};
      rName.length ← 2 * LENGTH[k];
      Inline.COPY[from: BASE[k], to: @(rName.text), nwords: LENGTH[k]];
      IF rName.length > 0 AND rName[rName.length - 1] = '@ THEN
        rName.length ← rName.length - 1 -- undo padding kludge -- ;
      dirty ← action[rName, value];
      more ← TRUE;
      END;
    StartReader[];
    BTreeDefs.EnumerateFrom[
      tree, DESCRIPTOR[NIL, 0], TreeAction ! UNWIND => EndReader[]];
    EndReader[];
    END;


  KeepObject: PUBLIC ENTRY PROCEDURE [
    name: BodyDefs.RName, type: ProtocolDefs.RNameType,
    stamp: POINTER TO BodyDefs.Timestamp, number: HeapDefs.ObjectNumber] =
    -- This is called only during the restart sequence --
    BEGIN
    value: TreeData;
    valuesize: CARDINAL = SIZE[TreeData];
    valuedesc: DESCRIPTOR FOR ARRAY OF WORD = DESCRIPTOR[
      LOOPHOLE[@value, POINTER], valuesize];
    namedesc: DESCRIPTOR FOR ARRAY OF WORD = RNameDesc[name];
    StartWriter[];
    IF BTreeDefs.Lookup[tree, namedesc, valuedesc] = valuesize THEN
      BEGIN
      BTreeDefs.Delete[tree, namedesc];
      ObjectDirDefs.FreeObject[value.object];
      END;
    value ← [knownReg: FALSE, type: type, stamp: stamp↑, object: number];
    ObjectDirDefs.RestartObject[number];
    WriteToTreeAndCache[name, @value];
    END;

  WriteToTreeAndCache: INTERNAL PROC [
    name: BodyDefs.RName, value: POINTER TO TreeData] =
    BEGIN
    BTreeDefs.Insert[tree, RNameDesc[name], DESCRIPTOR[value, SIZE[TreeData]]];
    RegCacheDefs.AddName[
      name, value.knownReg, value.type, value.stamp, value.object];
    END;



  -- BTree purger process --

  RegPurger: PUBLIC PROC = {RegPurgerProcess ← FORK RegPurgerMain[]};

  RegPurgerProcess: PROCESS;

  ageLimit: CARDINAL ← 14 -- days -- ;

  RegPurgerMain: PROC =
    BEGIN
    DO
      limit: BodyDefs.Timestamp;
      writer: HeapDefs.WriterHandle ← NIL;
      RegPurgerAction: PROC [name: BodyDefs.RName, value: POINTER TO TreeData]
        RETURNS [BOOLEAN] =
        BEGIN
        reader: HeapDefs.ReaderHandle = HeapDefs.HeapStartRead[value.object];
        IF RegServerDefs.ConsiderPurging[[value.type, value.stamp, reader], limit]
          THEN
          BEGIN
          IF writer = NIL THEN writer ← HeapDefs.HeapStartWrite[temp];
          HeapDefs.HeapWriteRName[writer, name];
          END;
        HeapDefs.HeapEndRead[reader];
        RETURN[FALSE]
        END;
      RegPurgerCleanup: PROC [obj: HeapDefs.ObjectNumber] =
        BEGIN
        reader: HeapDefs.ReaderHandle = HeapDefs.HeapStartRead[obj];
        DO
          name: STRING = [BodyDefs.maxRNameLength + 21];
          ended: BOOLEAN = HeapDefs.HeapReadRName[reader, name];
          [] ← PossiblyPurge[name, limit];
          Process.Pause[1];  --please can I have a process scheduler --
          IF ended THEN EXIT;
          ENDLOOP;
        HeapDefs.HeapEndRead[reader];
        END;
      PolicyDefs.RegPurgerPause[];
      PolicyDefs.WaitOperation[regPurger];
      limit ← RegistryDefs.MakeTimestamp[];
      limit.time ← limit.time - ageLimit * 24 * LONG[60 * 60];
      LogDefs.ShowLine["RegPurger running"L];
      EnumerateAllTree[RegPurgerAction];
      IF writer # NIL THEN HeapDefs.HeapEndWrite[writer, RegPurgerCleanup];
      PolicyDefs.EndOperation[regPurger];
      ENDLOOP;
    END;

  ImmediatePurge: PUBLIC PROC [name: BodyDefs.RName] RETURNS [done: BOOLEAN] =
    -- Provided for the viticulturists' entrance --
    {RETURN[PossiblyPurge[name, RegistryDefs.MakeTimestamp[]]]};

  PossiblyPurge: ENTRY PROC [name: BodyDefs.RName, limit: BodyDefs.Timestamp]
    RETURNS [done: BOOLEAN] =
    BEGIN
    InsertInBTree: INTERNAL PROCEDURE [number: HeapDefs.ObjectNumber] =
      BEGIN
      value.object ← number;
      ObjectDirDefs.UseObject[number];
      WriteToTreeAndCache[name, @value];
      END;
    value: TreeData;
    valuesize: CARDINAL = SIZE[TreeData];
    valuedesc: DESCRIPTOR FOR ARRAY OF WORD = DESCRIPTOR[
      LOOPHOLE[@value, POINTER], valuesize];
    namedesc: DESCRIPTOR FOR ARRAY OF WORD = RNameDesc[name];
    StartWriter[];
    IF BTreeDefs.Lookup[tree, namedesc, valuedesc] = valuesize THEN
      BEGIN
      writer: HeapDefs.WriterHandle;
      [done, writer] ← RegServerDefs.ReallyPurge[
        name, [value.type, value.stamp, HeapDefs.HeapStartRead[value.object]],
        limit];
      IF done THEN
        BEGIN
        RegCacheDefs.FlushName[name];
        IF writer = NIL THEN  --purged dead entry--
          BEGIN
          BTreeDefs.Delete[tree, namedesc];
          ObjectDirDefs.FreeObject[value.object];
          LogPurgeResult["Purged entry: "L, name];
          END
        ELSE  -- object revised by removing deleted data --
          BEGIN
          ObjectDirDefs.FreeObject[value.object];
          HeapDefs.HeapEndWrite[writer, InsertInBTree];
          LogPurgeResult["Purged data: "L, name];
          END;
        END
      ELSE LogPurgeResult["Purge abandoned: "L, name];
      END;
    END;

  LogPurgeResult: PROC [result, name: STRING] =
    BEGIN
    log: STRING = [96];
    String.AppendString[log, result];
    String.AppendString[log, name];
    LogDefs.ShowLine[log];
    END;


  Init[];

  END.