(* Ulm's Oberon Library
   Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
   ----------------------------------------------------------------------------
   Ulm's Oberon Library is free software; you can redistribute it
   and/or modify it under the terms of the GNU Library General Public
   License as published by the Free Software Foundation; either version
   2 of the License, or (at your option) any later version.

   Ulm's Oberon Library is distributed in the hope that it will be
   useful, but WITHOUT ANY WARRANTY; without even the implied warranty
   of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
   Library General Public License for more details.

   You should have received a copy of the GNU Library General Public
   License along with this library; if not, write to the Free Software
   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   ----------------------------------------------------------------------------
   E-mail contact: oberon@mathematik.uni-ulm.de
   ----------------------------------------------------------------------------
   $Id: PersistentD.om,v 1.4 1998/02/22 10:25:22 borchert Exp $
   ----------------------------------------------------------------------------
   $Log: PersistentD.om,v $
   Revision 1.4  1998/02/22  10:25:22  borchert
   bug fix in GetObject: Disciplines.Add was missing if the main object
   is just an extension of Disciplines.Object and not of
   PersistentDisciplines.Object

   Revision 1.3  1996/07/24  07:41:28  borchert
   bug fix: count component was not initialized (with the
            exception of CreateObject) -- detected by Martin Hasch

   Revision 1.2  1995/03/17  16:13:33  borchert
   - persistent disciplines may now be attached to non-persistent objects
   - some fixes due to changes of PersistentObjects

   Revision 1.1  1994/02/22  20:09:12  borchert
   Initial revision

   ----------------------------------------------------------------------------
*)

MODULE ulmPersistentDisciplines;

   IMPORT Disciplines := ulmDisciplines, Forwarders := ulmForwarders, NetIO := ulmNetIO, Objects := ulmObjects, PersistentObjects := ulmPersistentObjects,
      Services := ulmServices, Streams := ulmStreams, SYS := SYSTEM;

   CONST
      objectName = "PersistentDisciplines.Object";
      disciplineName = "PersistentDisciplines.Discipline";

   TYPE
      Identifier* = LONGINT;

      Discipline* = POINTER TO DisciplineRec;
      DisciplineRec* =
	 RECORD
	    (PersistentObjects.ObjectRec)
	    id*: Identifier; (* should be unique for all types of disciplines *)
	 END;

      DisciplineList = POINTER TO DisciplineListRec;
      DisciplineListRec =
	 RECORD
	    discipline: Discipline;
	    id: Identifier; (* copied from discipline.id *)
	    next: DisciplineList;
	 END;

      Interface = POINTER TO InterfaceRec;
      Object = POINTER TO ObjectRec;
      ObjectRec* =
	 RECORD
	    (PersistentObjects.ObjectRec)
	    (* private part *)
	    count: LONGINT; (* number of attached disciplines *)
	    list: DisciplineList; (* set of disciplines *)
	    if: Interface; (* overrides builtins if # NIL *)
	    forwardTo: Object;
	    usedBy: Object; (* used as target of UseInterfaceOf *)
	       (* very restrictive way of avoiding reference cycles:
		  forwardTo references must be built from inner to
		  outer objects and not vice versa
	       *)
	 END;

   TYPE
      VolatileDiscipline = POINTER TO VolatileDisciplineRec;
      VolatileDisciplineRec =
	 RECORD
	    (Disciplines.DisciplineRec)
	    object: Object;
	 END;
   VAR
      volDiscID: Disciplines.Identifier;

   TYPE
      AddProc* = PROCEDURE (object: Disciplines.Object; discipline: Discipline);
      RemoveProc* = PROCEDURE (object: Disciplines.Object; id: Identifier);
      SeekProc* = PROCEDURE (object: Disciplines.Object; id: Identifier;
			    VAR discipline: Discipline) : BOOLEAN;
      InterfaceRec* =
	 RECORD
	    (Objects.ObjectRec)
	    add*: AddProc;
	    remove*: RemoveProc;
	    seek*: SeekProc;
	 END;

   VAR
      unique: Identifier;
      objIf: PersistentObjects.Interface;
      objDatatype, discDatatype: Services.Type;

   CONST
      hashtabsize = 32;
   TYPE
      Sample = POINTER TO SampleRec;
      SampleRec =
	 RECORD
	    id: Identifier;
	    sample: Discipline;
	    next: Sample;
	 END;
      BucketTable = ARRAY hashtabsize OF Sample;
   VAR
      samples: BucketTable;

   PROCEDURE CreateObject*(VAR object: Object);
      (* creates a new object; this procedures should be called instead of
	 NEW for objects of type `Object'
      *)
   BEGIN
      NEW(object);
      object.count := 0; (* up to now, there are no attached disciplines *)
      object.list := NIL;
      object.if := NIL;
      PersistentObjects.Init(object, objDatatype);
   END CreateObject;

   PROCEDURE GetObject(obj: Disciplines.Object; VAR object: Object);
      VAR
	 disc: VolatileDiscipline;
   BEGIN
      IF obj IS Object THEN
	 object := obj(Object);
	 (* initialize private components now if not done already;
	    we assume here that pointers which have not been
	    initialized yet are defined to be NIL
	    (because of the garbage collection);
	    a similar assumption does not necessarily hold for
	    other types (e.g. integers)
	 *)
	 IF object.list = NIL THEN
	    object.count := 0;
	 END;
      ELSIF Disciplines.Seek(obj, volDiscID, SYS.VAL(Disciplines.Discipline, disc)) THEN
	 object := disc.object;
      ELSE
	 CreateObject(object);
	 NEW(disc); disc.id := volDiscID; disc.object := object;
	 Disciplines.Add(obj, disc);
      END;
   END GetObject;

   (* === normal stuff for disciplines ===================================== *)

   PROCEDURE Unique*(sample: Discipline) : Identifier;
      (* returns a unique identifier;
         this procedure should be called during initialization by
         all modules defining a discipline type;
	 a sample of the associated discipline has to be provided
      *)
      VAR
	 hashval: Identifier;
	 entry: Sample;
   BEGIN
      INC(unique);
      NEW(entry); entry.id := unique; entry.sample := sample;
      hashval := unique MOD hashtabsize;
      entry.next := samples[hashval]; samples[hashval] := entry;
      RETURN unique
   END Unique;

   PROCEDURE GetSample*(id: Identifier) : Discipline;
      (* return sample for the given identifier;
	 NIL will be returned if id has not yet been returned by Unique
      *)
      VAR
	 hashval: Identifier;
	 ptr: Sample;
   BEGIN
      hashval := id MOD hashtabsize;
      ptr := samples[hashval];
      WHILE (ptr # NIL) & (ptr.id # id) DO
	 ptr := ptr.next;
      END;
      IF ptr # NIL THEN
	 RETURN ptr.sample
      ELSE
	 RETURN NIL
      END;
   END GetSample;

   PROCEDURE AttachInterface*(object: Disciplines.Object; if: Interface);
      (* override the builtin implementations of Add, Remove and
	 Seek for `object' with the implementations given by `if'
      *)
      VAR
	 po: Object;
   BEGIN
      GetObject(object, po);
      IF (po.list = NIL) & (po.forwardTo = NIL) THEN
	 po.if := if;
      END;
   END AttachInterface;

   PROCEDURE UseInterfaceOf*(object, host: Disciplines.Object);
      (* forward Add, Remove and Seek operations from object to host *)
      VAR
	 po, phost: Object;
   BEGIN
      GetObject(object, po); GetObject(host, phost);
      IF (po.list = NIL) & (po.forwardTo = NIL) &
	    (po.usedBy = NIL) THEN
	 po.forwardTo := phost;
	 phost.usedBy := po; (* avoid reference cycles *)
      END;
   END UseInterfaceOf;

   PROCEDURE Forward(from, to: Forwarders.Object);
   BEGIN
      UseInterfaceOf(from, to);
   END Forward;

   PROCEDURE Remove*(object: Disciplines.Object; id: Identifier);
      (* remove the discipline with the given id from object, if it exists *)
      VAR
	 po: Object;
	 prev, dl: DisciplineList;
   BEGIN
      GetObject(object, po);
      WHILE po.forwardTo # NIL DO
	 po := po.forwardTo;
      END;
      IF po.if = NIL THEN
	 prev := NIL;
	 dl := po.list;
	 WHILE (dl # NIL) & (dl.id # id) DO
	    prev := dl; dl := dl.next;
	 END;
	 IF dl # NIL THEN
	    IF prev = NIL THEN
	       po.list := dl.next;
	    ELSE
	       prev.next := dl.next;
	    END;
	    DEC(po.count); (* discipline removed *)
	 END;
      ELSE
	 po.if.remove(po, id);
      END;
   END Remove;

   PROCEDURE Add*(object: Disciplines.Object; discipline: Discipline);
      (* adds a new discipline to the given object;
	 if already a discipline with the same identifier exist
	 it is deleted first
      *)
      VAR
	 po: Object;
	 dl: DisciplineList;
   BEGIN
      GetObject(object, po);
      WHILE po.forwardTo # NIL DO
	 po := po.forwardTo;
      END;
      IF po.if = NIL THEN
	 dl := po.list;
	 WHILE (dl # NIL) & (dl.id # discipline.id) DO
	    dl := dl.next;
	 END;
	 IF dl = NIL THEN
	    NEW(dl);
	    dl.id := discipline.id;
	    dl.next := po.list;
	    po.list := dl;
	    INC(po.count); (* discipline added *)
	 END;
	 dl.discipline := discipline;
      ELSE
	 po.if.add(po, discipline);
      END;
   END Add;

   PROCEDURE Seek*(object: Disciplines.Object; id: Identifier;
		  VAR discipline: Discipline) : BOOLEAN;
      (* returns TRUE if a discipline with the given id is found *)
      VAR
	 po: Object;
	 dl: DisciplineList;
   BEGIN
      GetObject(object, po);
      WHILE po.forwardTo # NIL DO
	 po := po.forwardTo;
      END;
      IF po.if = NIL THEN
	 dl := po.list;
	 WHILE (dl # NIL) & (dl.id # id) DO
	    dl := dl.next;
	 END;
	 IF dl # NIL THEN
	    discipline := dl.discipline;
	 ELSE
	    discipline := NIL;
	 END;
	 RETURN discipline # NIL
      ELSE
	 RETURN po.if.seek(po, id, discipline)
      END;
   END Seek;

   (* === interface procedures for PersistentObjects for Object === *)

   PROCEDURE ReadObjectData(stream: Streams.Stream;
                            object: PersistentObjects.Object) : BOOLEAN;
      (* read data and attached disciplines of given object from stream *)
      VAR
	 discipline: Discipline;
	 count: LONGINT;
   BEGIN
      (* get number of attached disciplines *)
      IF ~NetIO.ReadLongInt(stream, count) THEN
         RETURN FALSE;
      END;
      (* read all disciplines from `stream' and attach them to `object' *)
      WHILE count > 0 DO
	 IF ~PersistentObjects.Read(stream, SYS.VAL(PersistentObjects.Object, discipline)) THEN
	    RETURN FALSE;
	 END;
	 Add(object(Object), discipline);
	 DEC(count);
      END;
      RETURN TRUE;
   END ReadObjectData;

   PROCEDURE WriteObjectData(stream: Streams.Stream;
                             object: PersistentObjects.Object) : BOOLEAN;
      (* write data and attached disciplines of given object to stream *)
      VAR
	 dl: DisciplineList;
   BEGIN
      WITH object: Object DO
	 (* write number of attached disciplines to `stream' *)
	 IF ~NetIO.WriteLongInt(stream, object.count) THEN
	    RETURN FALSE;
	 END;
	 (* write all attached disciplines to the stream *)
	 dl := object.list;
	 WHILE dl # NIL DO
	    IF ~PersistentObjects.Write(stream, dl.discipline) THEN
	       RETURN FALSE;
	    END;
	    dl := dl.next;
	 END;
      END;
      RETURN TRUE;
   END WriteObjectData;

   PROCEDURE InternalCreate(VAR obj: PersistentObjects.Object);
      VAR
	 myObject: Object;
   BEGIN
      CreateObject(myObject);
      obj := myObject;
   END InternalCreate;

BEGIN
   unique := 0;

   NEW(objIf);
   objIf.read := ReadObjectData;
   objIf.write := WriteObjectData;
   objIf.create := InternalCreate;
   objIf.createAndRead := NIL;
   PersistentObjects.RegisterType(objDatatype, objectName, "", objIf);
   PersistentObjects.RegisterType(discDatatype, disciplineName, "", NIL);

   volDiscID := Disciplines.Unique();

   Forwarders.Register("", Forward);
END ulmPersistentDisciplines.