CD Shareware Magazine 1996 December/CD_shareware_12-96.iso/WIN/Programa/OORDB.ZIP/OORDB.EXE/MAPPING.PAS

Pascal/Delphi Source File | 1996-08-12 | 19.2 KB | 795 lines

unit Mapping;

interface
uses
  SysUtils,
  Assert_,
  TypInfo,
  Classes,
  DB,
  DBTables;


type
  TORMapping  = class;
  TORList     = class;
  TORFile     = class;
  TORObject   = class;

  TORObjClass   = class of TORObject;
  TProcessProp  = procedure (O :TORObject; PropInfo :PPropInfo) of object;

  TORMapping = class
  private
    FDatabase :TDatabase;
    FFiles    :TStringList;

    procedure AddFile(AFile :TORFile);          virtual;
  protected
    function  GetFile(C :TORObjClass) :TORFile; virtual;

  public
    constructor Create(db :TDatabase);
    destructor  Destroy; override;
    procedure   ApplyUpdates;                   virtual;

    property  Database :TDatabase read FDatabase write FDatabase;
    property  Files[C :TORObjClass] :TORFile read GetFile; default;
  end;

  TORList    = class
  protected
    FMapping  :TORMapping;
    FClass    :TORObjClass;
    FDataSet  :TDataSet;

    function  Load(const Key :Variant):TORObject;         virtual; abstract;
    function  LoadCurrent(const Key :Variant):TORObject;  virtual; abstract;

    procedure OpenStorage;                      virtual;
    function  GetObject(i :Integer):TORObject;  virtual;
    procedure Update;                           virtual;

    property  DataSet     :TDataSet    read FDataSet;
    property  MappedClass :TORObjClass read FClass;
  public
    constructor Create(AMapping :TORMapping; AClass :TORObjClass; ADataSet :TDataSet);
    destructor  Destroy;                       override;
    function    Count :Integer;                virtual;

    property    Mapping     :TORMapping  read FMapping;
    property    Objects[i :Integer]:TORObject read GetObject;
  end;

  TORFile    = class(TORList)
  protected
    FCache      :TStringList;
    FDependants :TList;

    constructor Create(AMapping :TORMapping; AClass :TORObjClass; ADataSet :TDataSet);
    destructor  Destroy;        override;

    function  Load(  const Key :Variant):TORObject;       override;
    function  LoadCurrent(const Key :Variant):TORObject;  override;

    procedure Delete(const Key :Variant);            virtual;
    procedure Release(O:TORObject);                  virtual;
    procedure Store(O:TORObject);                    virtual;
    procedure New(O:TORObject);                      virtual;

    procedure AddDependant(Dep :TORList);            virtual;
    procedure RemoveDependant(Dep :TORList);         virtual;
    procedure UpdateDependants;                      virtual;

    procedure ApplyUpdates;   virtual;
    procedure Clear;          virtual;
  public
    function  FindInCached(const Key :Variant) :TORObject;
  end;

  TORQuery = class(TORList)
  private
    FBaseFile :TORFile;

  protected
    function  Load(  const Key :Variant):TORObject;       override;
    function  LoadCurrent(const Key :Variant):TORObject;  override;

    property  BaseFile :TORFile read FBaseFile;
  public
    constructor Create(AMapping :TORMapping; AClass :TORObjClass; ADataSet :TDataSet; ABaseFile :TORFile);
    destructor  Destroy; override;
  end;

  TORCachedQuery = class(TORQuery)
  protected
    FList :TList;
    destructor  Destroy;        override;

    procedure OpenStorage;                      override;
    function  Count :Integer;                   override;
    function  GetObject(i :Integer):TORObject;  override;
    procedure Update;                           override;
  end;

  TORreader = class
  private
    FFile :TORFile;
  protected

    function  GetValue(const Name :string):Variant;            virtual;
    procedure ReadPropInfo(O :TORObject; PropInfo :PPropInfo); virtual;
    procedure ReadObjInfo (O :TORObject; PropInfo :PPropInfo); virtual;
    function  ReadProperty(const ProName :string) : Variant;   virtual;
  public
    constructor Create(AFile :TORFile);
    property FieldValues[const Name :string] :Variant read GetValue; default;
  end;

  TORWriter = class(TORReader)
    procedure SetValue(const Name :string; const Value :Variant);         virtual;
    procedure WritePropInfo(O :TORObject; PropInfo :PPropInfo);           virtual;
    procedure WriteObjInfo (O :TORObject; PropInfo :PPropInfo);           virtual;
    procedure WriteProperty(const ProName :string; const Value :Variant); virtual;
  public
    property FieldValues[const Name :string] :Variant
    read  GetValue
    write SetValue;
  end;

  TORObject = class(TPersistent)
  private
    FFile :TORFile;
  protected

    class function DefaultTableName :string;  virtual;
    class function KeyName   :string;         virtual; abstract;
    function  GetKey :Variant;                virtual; abstract;
    procedure SetKey (Value :Variant);        virtual; abstract;

    procedure ReadData( Reader :TORReader);   virtual;
    procedure WriteData(Writer :TORWriter);   virtual;

    procedure ForEachProperty(ProcessProp :TProcessProp);  virtual;
    property  Key :Variant read GetKey write SetKey;

    property  ORFile :TORFile read FFile;

  public
    constructor Create(AMapping :TORMapping); virtual;
    destructor  Destroy; override;

    procedure  Store;
    procedure  Release;
  end;

  EDBFailed = class(EFailed);
  EDBObjectNotFound       = class(EDBFailed);
  EDBObjectNotInDatabase  = class(EDBFailed);
  EDBCommitFailed         = class(EDBFailed);
  EDBCannotOpenStorage    = class(EDBFailed);
  EDBNoDatabase           = class(EDBFailed);
  EDBClassNotSpecified    = class(EDBFailed);
  EDBNoDataset            = class(EDBFailed);
  EDBNoBaseFile           = class(EDBFailed);
  EDBNewFailed            = class(EDBFailed);
  EDBLoadFailed           = class(EDBFailed);

implementation


{ TORMapping }

constructor TORMapping.Create(db :TDatabase);
begin
   inherited Create;
   FDatabase := db;
   FFiles := TStringList.Create;
   FFiles.Sorted     := True;
   FFiles.Duplicates := dupError;
end;

destructor  TORMapping.Destroy;
var
  i :Integer;
begin
  for i := 0 to FFiles.Count-1 do
    TORFile(FFiles.Objects[i]).Free;
  FFiles.Free;
  inherited Destroy;
end;

procedure TORMapping.ApplyUpdates;
var
   i :Integer;
begin
   if FDatabase = nil then
     raise EDBNoDatabase.Create;
   try
      FDatabase.Connected := True;

      if FFiles.Count > 0 then begin
         FDatabase.StartTransaction;
         try
            for i := 0 to FFiles.Count-1 do
              TORFile(FFiles.Objects[i]).ApplyUpdates;
            FDatabase.Commit
         except
            FDatabase.Rollback;
            raise;
         end;
            for i := 0 to FFiles.Count-1 do
              TORFile(FFiles.Objects[i]).Clear;
      end
   except
     raise EDBCommitFailed.Create;
   end
end;

procedure TORMapping.AddFile(AFile :TORFile);
begin
  FFiles.AddObject(AFile.MappedClass.ClassName, AFile)
end;

function TORMapping.GetFile(C :TORObjClass) :TORFile;
var
  i :Integer;
begin
   i := FFiles.IndexOf(C.ClassName);
   if i < 0 then
     Result := nil
   else
     Result := TORFile(FFiles.Objects[i])
end;

{ TORList }

constructor TORList.Create(AMapping :TORMapping; AClass :TORObjClass; ADataSet :TDataSet);
begin
   Require(AMapping <> nil, nil);
   Require(AClass <> nil, nil);
   Require(ADataSet <> nil, nil);

   inherited Create;
   FMapping := AMapping;
   FClass   := AClass;
   FDataset := ADataset;
end;

destructor  TORList.Destroy;
begin
  FDataSet := nil;
  inherited Destroy;
end;

function TORList.Count :Integer;
begin
  OpenStorage;
  Result := FDataSet.RecordCount
end;

function  TORList.GetObject(i :Integer) :TORObject;
begin
  OpenStorage;
  try
     if FDataSet.RecNo >= 0 then
        FDataSet.MoveBy((i+1) - FDataSet.RecNo)
     else begin
        FDataSet.First;
        FDataSet.MoveBy(i)
     end
  except
    raise EDBFailed.Create
  end;
  Result := LoadCurrent(FDataSet[MappedClass.KeyName])
end;

procedure TORList.OpenStorage;
begin
  if FDataset = nil then
    raise EDBNoDataset.Create
  else
    try
       FDataset.Active := True
    except
       raise EDBCannotOpenStorage.Create
    end
end;

procedure TORList.Update;
begin
  Dataset.Close
end;

{ TORFile }

constructor TORFile.Create(AMapping :TORMapping; AClass :TORObjClass; ADataSet :TDataSet);
begin
  inherited Create(AMapping, AClass, ADataSet);
  FCache            := TStringList.Create;
  FDependants       := TList.Create;
  FCache.Sorted     := True;
  FCache.Duplicates := dupError;
  AMapping.AddFile(Self);
end;

destructor  TORFile.Destroy;
begin
   Clear;
   FCache.Free;
   FDependants.Free;
   inherited Destroy;
end;

function TORFile.LoadCurrent(const Key :Variant):TORObject;
var
  Reader :TORReader;
begin
  OpenStorage;
  Result := FindInCached(Key);
  if Result = nil then begin
    Result := MappedClass.Create(nil);
    try
       Result.FFile := Self;
       Result.Key   := Key;
       Reader := TORReader.Create(Self);
       try
          Result.ReadData(Reader)
       finally
          Reader.Free
       end;
       FCache.AddObject(Key, Result)
    except
       Result.FFile := nil;
       Result.Free;
       raise EDBLoadFailed.Create
    end
  end;
end;

function TORFile.Load(const Key :Variant):TORObject;
var
  Reader :TORReader;
begin
  OpenStorage;
  Result := FindInCached(Key);
  if Result = nil then begin
    Result := MappedClass.Create(nil);
    try
       Result.FFile := Self;
       Result.Key   := Key;

       if not FDataSet.Locate(MappedClass.KeyName, Key, []) then
          raise EDBObjectNotFound.Create
       else begin
          Reader := TORReader.Create(Self);
          try
             Result.ReadData(Reader)
          finally
             Reader.Free
          end
       end;
       FCache.AddObject(Key, Result)
    except
       Result.FFile := nil;
       Result.Free;
       raise EDBLoadFailed.Create
    end
  end;
end;

procedure TORFile.Store(O:TORObject);
var
  Writer :TORWriter;
begin
  UpdateDependants;
  OpenStorage;
  Writer := TORWriter.Create(Self);
  if FDataSet.Locate(O.KeyName, O.Key, []) then
     FDataSet.Edit
  else
     raise EDBObjectNotFound.Create;
  try
     try
        O.WriteData(Writer);
        FDataSet.Post
     finally
        Writer.Free
     end
  except
    FDataSet.Cancel
  end
end;

procedure TORFile.New(O:TORObject);
var
  Writer :TORWriter;
begin
  UpdateDependants;
  OpenStorage;
  FDataSet.Append;
  try
    FDataset.Post;
    O.Key := FDataset[MappedClass.KeyName];
    FCache.AddObject(O.Key, O);
  except
    FDataset.Cancel;
    raise EDBNewFailed.Create;
  end
end;

procedure TORFile.Delete(const Key :Variant);
var
  O :TORObject;
  i :Integer;
begin
  UpdateDependants;
  OpenStorage;
  if not FDataSet.Locate(MappedClass.KeyName, Key, []) then
     raise EDBObjectNotFound.Create
  else begin
    FDataSet.Delete;
    if FCache.Find(Key, i) then begin
      O := TORObject(FCache.Objects[i]);
      FCache.Delete(i);
      O.FFile := nil;
      O.Free;
    end
  end;
end;


procedure TORFile.Release(O :TORObject);
var
  i :Integer;
begin
   UpdateDependants;
   if not FCache.Find(O.Key, i) then
     raise EDBObjectNotFound.Create;
   FCache.Delete(i);
   O.FFile := nil;
   Assert(not FCache.Find(O.Key, i), nil)
end;

function TORFile.FindInCached(const Key :Variant) :TORObject;
var
   i :Integer;
begin
   if FCache.Find(Key, i) then
     Result := TORObject(FCache.Objects[i])
   else
     Result := nil;
   Assert((Result = nil) or (Result.FFile <> nil), nil)
end;

procedure TORFile.ApplyUpdates;
var
   i :Integer;
begin
   OpenStorage;
   for i := 0 to FCache.Count-1 do
      Store(TORObject(FCache.Objects[i]));
   with DataSet do
     if CachedUpdates and UpdatesPending then
        ApplyUpdates;
end;

procedure TORFile.Clear;
var
   i :Integer;
begin
    if (FDataSet <> nil) and FDataSet.CachedUpdates then
       FDataSet.CancelUpdates;
    for i := 0 to FCache.Count-1 do
       with TORObject(FCache.Objects[i])do begin
          FFile := nil;
          Free
       end
end;

procedure TORFile.AddDependant(Dep :TORList);
begin
  Require(Dep <> nil, nil);
  FDependants.Add(Dep);
end;

procedure TORFile.RemoveDependant(Dep :TORList);
begin
  Require(Dep <> nil, nil);
  FDependants.Remove(Dep);
end;


procedure TORFile.UpdateDependants;
var
  i :Integer;
begin
  for i := 0 to FDependants.Count-1 do
    TORList(FDependants[i]).Update;
end;

{ TORQuery }

constructor TORQuery.Create(AMapping :TORMapping; AClass :TORObjClass; ADataSet :TDataSet; ABaseFile :TORFile);
begin
  Require(ABaseFile <> nil, nil);
  inherited Create(AMapping, AClass, ADataSet);
  FBaseFile := ABaseFile;
  FBaseFile.AddDependant(Self);
end;

destructor TORQuery.Destroy;
begin
  FBaseFile.RemoveDependant(Self);
  inherited Destroy;
end;

function  TORQuery.Load(  const Key :Variant):TORObject;
begin
   Require(FBaseFile <> nil, EDBNoBaseFile);
   Result := FBaseFile.Load(Key)
end;

function  TORQuery.LoadCurrent(  const Key :Variant):TORObject;
begin
   Require(FBaseFile <> nil, EDBNoBaseFile);
   Result := FBaseFile.Load(Key)
end;

{ TORCachedQuery }

destructor  TORCachedQuery.Destroy;
begin
  FList.Free;
  inherited Destroy;
end;

procedure TORCachedQuery.OpenStorage;
var
  i :Integer;
begin
  if FList = nil then begin
    FList := TList.Create;
    inherited OpenStorage;
    { cache the objects }
    for i := 0 to inherited Count-1 do
      FList.Add(inherited GetObject(i));
    FDataSet.Close
  end
end;

function  TORCachedQuery.GetObject(i :Integer):TORObject;
begin
  if FList = nil then
    OpenStorage;
  Assert(FList <> nil, nil);
  FDataset.Close; { not needed for now }
  Result := FList[i];
end;

procedure TORCachedQuery.Update;
begin
  inherited Update;
  FList.Free;
  FList := nil
end;

function TORCachedQuery.Count :Integer;
begin
  OpenStorage;
  Result := FList.Count
end;

{ TORReader }

constructor TORReader.Create(AFile :TORFile);
begin
   inherited Create;
   FFile := AFile;
end;

function TORReader.GetValue(const Name :string):Variant;
begin
  Result := FFile.FDataSet[Name]
end;

function TORReader.ReadProperty(const ProName :string): Variant;
begin
     Result := FFile.FDataset[ProName]
end;


procedure TORReader.ReadPropInfo(O :TORObject; PropInfo :PPropInfo);
var
  Value :Variant;
begin
    with PropInfo^, PropType^ do
      if PropInfo^.SetProc <> nil then begin
         Value := ReadProperty(PropInfo^.Name);
         case Kind of
            tkInteger,
            tkChar,
            tkEnumeration,
            tkSet:
              if VarIsNull(Value) then
                 SetOrdProp(O, PropInfo, 0)
              else
                 SetOrdProp(O, PropInfo, Value);
            tkString,
            tkLString,
            tkLWString:
              if VarIsNull(Value) then
                 SetStrProp(O, PropInfo, '')
              else
                 SetStrProp(O, PropInfo, Value);
            tkFloat:
              if VarIsNull(Value) then
                 SetFloatProp(O, PropInfo, 0.0)
              else
                 SetFloatProp(O, PropInfo, Value);
            tkVariant:
              SetVariantProp(O, PropInfo, Value);
         end
      end
end;

procedure TORReader.ReadObjInfo(O :TORObject; PropInfo :PPropInfo);
var
  Key   :Variant;
  C     :TClass;
  obj   :TORObject;
begin
    with PropInfo^, PropType^ do
      if (PropInfo^.SetProc <> nil) and (Kind = tkClass) then begin
         C   := GetTypeData(PropType)^.ClassType;
         if C.InheritsFrom(TORObject) then begin
            Key := ReadProperty(PropInfo^.Name);
            if VarIsNull(Key) or VarIsEmpty(Key) then
              SetOrdProp(O, PropInfo, 0)
            else begin
              obj := FFile.Mapping[TORObjClass(C)].Load(Key);
              SetOrdProp(O, PropInfo, Longint(obj))
            end
         end
      end
end;

{ TOBReader }

procedure TORWriter.SetValue(const Name :string; const Value :Variant);
begin
   FFile.FDataSet[Name] := Value
end;

procedure TORWriter.WriteProperty(const ProName :string; const Value :Variant);
begin
     FFile.FDataset[ProName] := Value
end;

procedure TORWriter.WritePropInfo(O :TORObject; PropInfo :PPropInfo);
var
   Value   :Variant;
begin
    with PropInfo^, PropType^ do begin
        if GetProc <> nil then begin
          case Kind of
             tkInteger,
             tkChar,
             tkEnumeration,
             tkSet:
               Value := GetOrdProp(O, PropInfo);
             tkString,
             tkLString,
             tkLWString:
               Value := GetStrProp(O, PropInfo);
             tkFloat:
               Value := GetFloatProp(O, PropInfo);
             tkVariant:
               Value := GetVariantProp(O, PropInfo)
             else
               { do nothing } Exit;
          end;
          WriteProperty(PropInfo^.Name, Value)
        end
    end
end;

procedure TORWriter.WriteObjInfo(O :TORObject; PropInfo :PPropInfo);
var
   Value   :Variant;
   C       :TClass;
   obj     :TORObject;
begin
    with PropInfo^, PropType^ do begin
        if (GetProc <> nil) and (Kind = tkClass) then begin
            C := GetTypeData(PropType)^.ClassType;
            if C.InheritsFrom(TORObject) then begin
                obj := Pointer(GetOrdProp(O, PropInfo));
                if obj = nil then
                    WriteProperty(PropInfo^.Name, Null)
                else
                    WriteProperty(PropInfo^.Name, obj.Key)
            end
        end
    end
end;



{ TORObject }

constructor TORObject.Create(AMapping :TORMapping);
begin
  inherited Create;
  if AMapping <> nil then begin
     FFile := AMapping[TORObjClass(Self.ClassType)];
     Assert(FFile <> nil, nil);
     FFile.New(Self)
  end
end;

destructor TORObject.Destroy;
var
  F :TORFile;
begin
  if  FFile <> nil then begin
    F := FFile;      {!!!}{Deletions are not being cached !}
    FFile := nil;
    F.Delete(Key);
  end;
  inherited Destroy;
end;

procedure  TORObject.Release;
begin
  FFile.Release(Self)
end;

class function TORObject.DefaultTableName :string;
begin
   if ClassName[1] = 'T' then
      Result := Copy(ClassName, 2, Length(ClassName))
   else
      Result := ClassName
end;

procedure TORObject.Store;
begin
  if FFile = nil then
     raise EDBObjectNotInDatabase.Create
  else
     FFile.Store(Self)
end;

procedure TORObject.ReadData( Reader :TORReader);
begin
   ForEachProperty(Reader.ReadPropInfo);
   ForEachProperty(Reader.ReadObjInfo);
end;

procedure TORObject.WriteData(Writer :TORWriter);
begin
   ForEachProperty(Writer.WritePropInfo);
   ForEachProperty(Writer.WriteObjInfo);
end;

procedure TORObject.ForEachProperty(ProcessProp :TProcessProp);
var
  i        :Integer;
  Count    :Integer;
  Info     :PPropInfo;
  PropList :array[0..255] of PPropInfo;
begin
   Count := GetTypeData(ClassInfo)^.PropCount;
   Assert((Count < 256), nil);

   GetPropInfos(ClassInfo, PPropList(@PropList));

   for i := 0 to Count-1 do begin
     if IsStoredProp(Self, PropList[i]) then
        ProcessProp(Self, PropList[i])
   end
end;

end.