Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue59/Arch/Extended Sample/UnitObjectBase.pas

Pascal/Delphi Source File | 2000-05-29 | 7.9 KB | 259 lines

unit UnitObjectBase;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
  TObjectBase = class;
  TObjectBaseClass = class of TObjectBase;
  TObjectBase = class(TDataModule)
  private
    FReferencingObjectList: TList;
    FKey: integer;
    class function FindReference(anObjectClass: TObjectBaseClass; const aKey: integer): TObjectBase;
    procedure AddReference(aReferencingObject: TComponent);
    constructor PrivateCreate(Owner: TComponent);
    procedure AncestorInitializeObject;
    procedure AbstractFinalizeObject;
  protected

    procedure InitializeObject; virtual;
    procedure FinalizeObject; virtual;

  public

    constructor Create(Owner: TComponent); override;
    destructor Destroy; override;

    // Saving, canceling, and updates pending are concepts that probably
    // only relate to entity objects. However, I'm introducing the methods
    // at the top of the hierarchy for convenience.
    class function AnyUpdatesPending: boolean;
    function UpdatesPending: boolean; virtual;
    procedure Save; virtual;
    procedure Cancel; virtual;
    class procedure SaveAll;

    function Equals(aClass: TObjectBaseClass; aKey: integer): boolean; overload; virtual;
    function Equals(anObject: TObjectBase): boolean; overload; virtual;

    // FetchReference and FreeReference are the only ways to create or
    // destroy TObjectBase objects.
    class function FetchReference(aReferencingObject: TComponent; aKey: integer): TObjectBase;
    procedure FreeReference(aReferencingObject: TComponent);

    property Key: integer read FKey;

    class function NewInteger: integer;

  end;

var
  ObjectBase: TObjectBase;

implementation

{$R *.DFM}

uses UnitFormBase, UnitObjectEntityBase;

var PrivateClassObjectList: TList;

function TObjectBase.Equals(aClass: TObjectBaseClass; aKey: integer): boolean;
begin
  // Return TRUE if the object type and key match.
  Result := (Self <> NIL) and (Self.ClassType = aClass) and (Self.Key = aKey);
end;

function TObjectBase.Equals(anObject: TObjectBase): boolean;
begin
  // Objects are equal if they are both NIL, or if they are both of
  // the same class and have the same key.
  if ( (Self = NIL) and (anObject = NIL) ) then
    Result := TRUE
  else if ( (Self <> NIL) or (anObject <> NIL) ) then
    Result := FALSE
  else
    Result := (Self.ClassType = anObject.ClassType) and (Self.Key = anObject.Key);
end;

procedure TObjectBase.AddReference(aReferencingObject: TComponent);
var i: integer;
begin
  // Increment the reference count for the referencing object. If the
  // referencing object is already on the list then don't add it a
  // second time.
  i := FReferencingObjectList.IndexOf(aReferencingObject);
  if (i = -1) then
    FReferencingObjectList.Add(aReferencingObject);
end;

constructor TObjectBase.Create(Owner: TComponent);
begin
  // Programmers aren't allowed to run this method -- they have to use
  // FetchReference. If this gets run odds are the TDataModule wasn't
  // removed from the auto-create list.
  inherited;
  MessageDlg('TObjectBase.Create is being run. Check that the data module ' + Self.Name + ' is not being auto-created.', mtError, [mbOK], 0);
end;

class function TObjectBase.FetchReference(aReferencingObject: TComponent; aKey: integer): TObjectBase;
begin
  // "Self" refers to the class type in class methods.

  // See if the object already exists.
  Result := FindReference(Self, aKey);

  if (Result = NIL) then begin
    // It doesn't exist...

    // Owner = NIL, because it's up to the referencing objects to free up
    // those references. If Owner were set to Application then upon
    // Applicatoin.Terminate the Application might delete objects before
    // we were done with them.
    Result := Self.PrivateCreate(NIL);
    // Add the new object to the list of existing objects.
    PrivateClassObjectList.Add(Result);
    // Initialize the Key property.
    Result.FKey := aKey;
    Result.AncestorInitializeObject;
    // Add the referencing object to the new object's list of references.
    Result.AddReference(aReferencingObject);
    Result.InitializeObject;
  end
  else begin
    // Add the referencing object to the new object's list of references.
    Result.AddReference(aReferencingObject);
  end; // else begin
end;

class function TObjectBase.FindReference(anObjectClass: TObjectBaseClass; const aKey: integer): TObjectBase;
var i: integer;
var anObject: TObjectBase;
begin
  // Return the object using class type and key. If it doesn't exist
  // return NIL.
  Result := NIL;
  for i := 0 to PrivateClassObjectList.Count - 1 do begin
    anObject := TObjectBase(PrivateClassObjectList.Items[i]);
    if (anObject.Equals(anObjectClass, aKey)) then begin
      Result := anObject;
      break;
    end; // then begin
  end; // do begin
end;

procedure TObjectBase.FreeReference(aReferencingObject: TComponent);
var i: integer;
begin
  // Exit if the the programmer runs the routine after the reference has
  // already been cleared.
  if (Self = NIL) then exit;

  // Remove the referencing object from the list of referencing objects.
  // If the reference count goes to zero then destroy the object.
  i := FReferencingObjectList.IndexOf(aReferencingObject);
  if (i = -1) then begin
    // If the referencing object isn't found at all then something is  wrong.
    // It's probably most appropriate to raise an excaption here, but for
    // debugging purposes it may be best to just display an error message.
    MessageDlg('TObjectBase.FreeReference being run by a referencing object not found on the reference list', mtError, [mbOK], 0);
    exit;
  end; // then begin
  FReferencingObjectList.Delete(i);
  if (FReferencingObjectList.Count = 0) then begin
    // There are no references to this object. Free it up.
    FinalizeObject;
    PrivateClassObjectList.Remove(Self);
    AbstractFinalizeObject;
    // Run Destroy in the ancestor because we aren't allowing the programmer
    // to run TObjectBase.Destroy
    inherited Destroy;
  end; // then begin
end;

destructor TObjectBase.Destroy;
begin
  // This should never be run. Raise an exception so the tester knows what's
  // going on.
  MessageDlg('Error: TObjectBase.Destroy being run. Use FreeReference instead', mtWarning, [mbOK], 0);
  inherited;
end;

procedure TObjectBase.AbstractFinalizeObject;
begin
  FReferencingObjectList.Free;
end;

procedure TObjectBase.AncestorInitializeObject;
begin
    FReferencingObjectList := TList.Create;
end;

constructor TObjectBase.PrivateCreate(Owner: TComponent);
begin
  inherited Create(Owner);
end;

procedure TObjectBase.FinalizeObject;
begin
  //
end;

procedure TObjectBase.InitializeObject;
begin
  //
end;

function TObjectBase.UpdatesPending: boolean;
begin
  Result := FALSE;
end;

class procedure TObjectBase.SaveAll;
var i: integer;
var anObject: TObjectBase;
begin
  // Run Save on each entity object
    for i := 0 to (PrivateClassObjectList.Count - 1) do begin
    anObject := (TObjectBase(PrivateClassObjectList.Items[i]));
    if (anObject is TObjectEntityBase) then
      TObjectEntityBase(anObject).Save;
  end; // do begin
end;

class function TObjectBase.AnyUpdatesPending: boolean;
var i: integer;
begin
  Result := FALSE;
    for i := 0 to (PrivateClassObjectList.Count - 1) do
      Result := Result or TObjectBase(PrivateClassObjectList.Items[i]).UpdatesPending;
end;

class function TObjectBase.NewInteger: integer;
begin
  Result := TFormBase.NewInteger;
end;

procedure TObjectBase.Cancel;
begin
  //
end;

procedure TObjectBase.Save;
begin
  //
end;

initialization
  PrivateClassObjectList := TList.Create;

finalization
  if (PrivateClassObjectList.Count <> 0) then
    MessageDlg('Appliation terminating with objects remaining in memory.', mtWarning, [mbOK], 0);
  PrivateClassObjectList.Free;

end.