source: branches/web/Common/UDatabase.pas

unit UDatabase;

{$mode delphi}{$H+}

interface

uses
  SysUtils, Variants, Classes, TypInfo, USqlDatabase, RTLConsts, Contnrs, Dialogs;

type
  TDatabase = class;
  TDbList = class;
  TDbListClass = class of TDbList;
  TDbObject = class;
  TDbObjectClass = class of TDbObject;

  {$M+}
  TDbObject = class
  private
    FDatabase: TDatabase;
    FId: Integer;
    FRow: TAssociativeArray;
    procedure WriteProperty(Instance: TDbObject; PropInfo: PPropInfo; Data: TAssociativeArray; Depth: Integer);
    procedure DeleteProperty(Instance: TDbObject; PropInfo: PPropInfo);
    procedure DestroyProperty(Instance: TDbObject; PropInfo: PPropInfo; Depth: Integer);
    procedure ReadProperty(Instance: TObject; PropInfo: PPropInfo; Data: TAssociativeArray; Depth: Integer);
    function SearchPropertyByPointer(P: Pointer): string;
  public
    constructor Create(ADatabase: TDatabase); virtual;
    procedure Init;
    procedure Store(Depth: Integer = 1); virtual;
    procedure Delete;
    procedure LoadById(Id: Integer; Depth: Integer = 1);
    procedure Load(Depth: Integer = 1);
    procedure LoadFromRow(Row: TAssociativeArray; Depth: Integer = 1);
    destructor Destroy(Depth: Integer = 100); virtual;
    property Database: TDatabase read FDatabase write FDatabase;
  published
    property Id: Integer read FId write Fid;
  end;

  // TList with RTTI information
  TPersistentList = class
  private
    FList: PPointerList;
    FCount: Integer;
    FCapacity: Integer;
  protected
    function Get(Index: Integer): Pointer;
    procedure Grow; virtual;
    procedure Put(Index: Integer; Item: Pointer);
    procedure Notify(Ptr: Pointer; Action: TListNotification); virtual;
    procedure SetCapacity(NewCapacity: Integer);
    procedure SetCount(NewCount: Integer);
  public
    destructor Destroy; override;
    function Add(Item: Pointer): Integer;
    procedure Clear; virtual;
    procedure Delete(Index: Integer);
    class procedure Error(const Msg: string; Data: Integer); overload; virtual;
    class procedure Error(Msg: PResStringRec; Data: Integer); overload;
    procedure Exchange(Index1, Index2: Integer);
    function Expand: TPersistentList;
    function Extract(Item: Pointer): Pointer;
    function First: Pointer;
    function IndexOf(Item: Pointer): Integer;
    procedure Insert(Index: Integer; Item: Pointer);
    function Last: Pointer;
    procedure Move(CurIndex, NewIndex: Integer);
    function Remove(Item: Pointer): Integer;
    procedure Pack;
    procedure Sort(Compare: TListSortCompare);
    procedure Assign(ListA: TPersistentList; AOperator: TListAssignOp = laCopy; ListB: TPersistentList = nil);
    property Capacity: Integer read FCapacity write SetCapacity;
    property Count: Integer read FCount write SetCount;
    property Items[Index: Integer]: Pointer read Get write Put; default;
    property List: PPointerList read FList;
  end;

  TDbList = class(TObjectList)
  private
    FId: Integer;
    FItemId: Integer;
    FDatabase: TDatabase;
    FItemsClass: TDbObjectClass;
    procedure Put(Index: Integer; const Value: TDbObject); virtual;
    function Get(Index: Integer): TDbObject; virtual;
    procedure CheckId;
  public
    procedure Store(Depth: Integer = 1);
    procedure Load(Depth: Integer = 1);
    procedure Delete;
    constructor Create(ADatabase: TDatabase; Id: Integer); virtual;
    destructor Destroy(Depth: Integer = 100);
//    property Id: Integer read FId write Fid;
    property Items[Index: Integer]: TDbObject read Get write Put; default;
    property ItemsClass: TDbObjectClass read FItemsClass write FItemsClass;
  published
    property ListId: Integer read FId write Fid;
    property ItemId: Integer read FItemId write FItemId;
  end;
  {$M-}

  TDatabase = class(TSqlDatabase)
  private
    FOnError: TNotifyEvent;
    procedure HandleError(Sender: TObject);
  public
    ProcessedClass: TObject;
    DbObject: TDbObject;
    constructor Create;
    property OnError: TNotifyEvent read FOnError write FOnError;
    procedure CheckTable;
    destructor Destroy; override;
  end;

  procedure LogMessage(Text: string);

implementation

procedure LogMessage(Text: string);
begin

end;

{ TDbObject }

procedure TDbObject.WriteProperty(Instance: TDbObject; PropInfo: PPropInfo; Data: TAssociativeArray; Depth: Integer);
var
  PropType: PTypeInfo;
//  AncestorValid: Boolean;

  procedure WriteSet(Value: Longint);
//  var
//    I: Integer;
//    BaseType: PTypeInfo;
  begin
(*
    BaseType := GetTypeData(PropType)^.CompType^;
    WriteValue(vaSet);
    for I := 0 to SizeOf(TIntegerSet) * 8 - 1 do
      if I in TIntegerSet(Value) then WriteStr(GetEnumName(BaseType, I));
    WriteStr('');
*)
  end;

  procedure WriteIntProp(IntType: PTypeInfo; Value: Longint);
  var
    Ident: string;
    IntToIdent: TIntToIdent;
  begin
    IntToIdent := FindIntToIdent(IntType);
    if Assigned(IntToIdent) and IntToIdent(Value, Ident) then
      //WriteIdent(Ident)
    else
      Data.AddKeyValue(PropInfo.Name, IntToStr(Value));
  end;

  procedure WriteOrdProp;
  var
    Value: Longint;
  begin
    Value := GetOrdProp(Instance, PropInfo);
    case PropType^.Kind of
      tkInteger:
        WriteIntProp(PPropInfo(PropInfo)^.PropType, Value);
      tkChar:
        Data.AddKeyValue(PropInfo.Name, Chr(Value));
      tkSet:
        LogMessage('Unsupported writer persistent type: Set');
      //  WriteSet(Value);
      tkEnumeration:
        Data.AddKeyValue(PropInfo.Name, IntToStr(Value));
    end;
  end;

  procedure WriteFloatProp;
  var
    Value: Extended;
  begin
    Value := GetFloatProp(Instance, PropInfo);
    Data.AddKeyValue(PropInfo.Name, MysqlFloatToStr(Value));
  end;

  procedure WriteInt64Prop;
//  var
//    Value: Int64;
  begin
(*
    Value := GetInt64Prop(Instance, PropInfo);
    WritePropPath;
    WriteInteger(Value);
*)
  end;

  procedure WriteStrProp;
  begin
    Data.AddKeyValue(PropInfo.Name, GetWideStrProp(Instance, PropInfo));
  end;

  procedure WriteObjectProp;
  var
    Value: TObject;
//    OldAncestor: TPersistent;
//    SavePropPath, ComponentValue: string;
  begin
    Value := TObject(GetOrdProp(Instance, PropInfo));
    if Value = nil then begin
      Data.AddKeyValue(PropInfo.Name, IntToStr(0));
    end else if Value is TDbObject then begin
      TDbObject(Value).Store(Depth-1);
      Data.AddKeyValue(PropInfo.Name, IntToStr(TDbObject(Value).Id));
    end else if Value is TDbList then begin
      if Value = nil then raise Exception.Create('WriteObjectProp: Unbelievable! Value is nil!');
      TDbList(Value).Store(Depth-1);
      Data.AddKeyValue(PropInfo.Name, IntToStr(TDbList(Value).FId));
    end;
  end;


begin
  // Using IsDefaultPropertyValue will tell us if we should write out
  // a given property because it was different from the default or
  // different from the Ancestor (if applicable).
  if (PropInfo^.GetProc <> nil) and
     ((PropInfo^.SetProc <> nil) or
     ((PropInfo^.PropType^.Kind = tkClass) and
      (TObject(GetOrdProp(Instance, PropInfo)) is TComponent) and
      (csSubComponent in TComponent(GetOrdProp(Instance, PropInfo)).ComponentStyle))) then
  begin
    LogMessage('Write property: '+Instance.ClassName+'.'+PropInfo.Name);
    //if not IsDefaultPropertyValue(Instance, PropInfo, GetLookupInfo) then
    begin
      //AncestorValid := AncestorIsValid(Ancestor, Root, RootAncestor);
      PropType := PropInfo^.PropType;
      case PropType^.Kind of
        tkInteger, tkChar, tkEnumeration, tkSet:
          WriteOrdProp;
        tkFloat:
          WriteFloatProp;
        tkString, tkLString, tkWString:
          WriteStrProp;
        tkClass:
          WriteObjectProp;
        //tkMethod:
        //  WriteMethodProp;
        //tkVariant:
        //  WriteVariantProp;
        tkInt64:
          WriteInt64Prop;
        //tkInterface:
        //  WriteInterfaceProp;
      else
        raise Exception.Create('Not supported class property '+GetEnumName(PropType, Integer(PropType^.Kind)));
      end;
    end;
  end;
end;


procedure TDbObject.ReadProperty(Instance: TObject; PropInfo: PPropInfo; Data: TAssociativeArray; Depth: Integer);
const
  NilMethod: TMethod = (Code: nil; Data: nil);
var
  PropType: PTypeInfo;
//  Method: TMethod;

  procedure SetIntIdent(Instance: TPersistent; PropInfo: Pointer;
    const Ident: string);
  var
    V: Longint;
    IdentToInt: TIdentToInt;
  begin
    IdentToInt := FindIdentToInt(PPropInfo(PropInfo)^.PropType);
    if Assigned(IdentToInt) and IdentToInt(Ident, V) then
      SetOrdProp(Instance, PropInfo, V)
    else
      //PropValueError;
  end;

  procedure ProcessObjectProp;
  var
    Setter: Longint;
    Value: TObject;
    TypeData: PTypeData;
    TargetObject: ^TObject;
    TargetClass: TClass;
    DbListClass: TDbListClass;
    DbObjectClass: TDbObjectClass;
  begin
    if Depth > 0 then begin
  //  List := TDbList.Create(AClass, FDatabase, FId);
    Value := TObject(GetOrdProp(Instance, PropInfo));
    TypeData := GetTypeData(PropInfo.PropType);
//    ShowMessage(PropInfo.Name+' '+TypeData.ClassType.ClassName);
    if Value = nil then begin
      Setter := Longint(PropInfo^.SetProc);
      if (Setter and $FF000000) = $FF000000 then
      begin  // field - Setter is the field's offset in the instance data
        TargetObject := Pointer(Integer(Instance) + (Setter and $00FFFFFF));
        TargetClass := TypeData.ClassType;
//        TargetClass := TargetClass.ClassParent;
//        ShowMessage(TargetClass.ClassName);
        if TargetClass.ClassParent = TDbObject then begin
          DbObjectClass := TDbObjectClass(TargetClass);
          TargetObject^ :=  DbObjectClass.Create(FDatabase);   // auto ref count
        end else
        if TargetClass.ClassParent = TDbList then begin
          DbListClass := TDbListClass(TargetClass);
        //ShowMessage(DbListClass.ClassName);

          TargetObject^ :=  DbListClass.Create(FDatabase, StrToInt(FRow.Values[PropInfo.Name]));   // auto ref count
        end else TargetObject^ :=  TargetClass.Create;   // auto ref count
        Value := TObject(GetOrdProp(Instance, PropInfo));
      end else raise Exception.Create('Object property '+PropInfo.Name+' in object '+Instance.ClassName+' is not mapped directly to variable!');
    end;
    //ShowMessage(IntToStr(Integer(Value.ClassInfo)));
    if Value is TDbObject then begin
      (Value as TDbObject).LoadById(StrToInt(FRow.Values[PropInfo.Name]), Depth-1);
      //ShowMessage(Value.ClassName);
    end else if Value is TDbList then begin
      (Value as TDbList).Load(Depth);
      //ShowMessage(Value.ClassName);
    end;
    end;
  end;

begin
  LogMessage('Read property: ' + Instance.ClassName + '.' + PropInfo.Name);
//  if PPropInfo(PropInfo)^.SetProc = nil then
//    if not ((PPropInfo(PropInfo)^.PropType^.Kind = tkClass) and
//       (TObject(GetOrdProp(Instance, PropInfo)) is TComponent) and
//       (csSubComponent in TComponent(GetOrdProp(Instance, PropInfo)).ComponentStyle)) then
//      ReadError(@SReadOnlyProperty);
  PropType := PPropInfo(PropInfo)^.PropType;
  try
  case PropType^.Kind of
    tkInteger:
//      if NextValue = vaIdent then
//        SetIntIdent(Instance, PropInfo, Data)
//      else
        SetOrdProp(Instance, PropInfo, StrToInt(Data.Values[PropInfo.Name]));
    tkChar:
      SetOrdProp(Instance, PropInfo, Ord(Data.Values[PropInfo.Name][1]));
    tkEnumeration:
      SetOrdProp(Instance, PropInfo, StrToInt(Data.Values[PropInfo.Name]));
    tkFloat:
      SetFloatProp(Instance, PropInfo, MySqlStrToFloat(Data.Values[PropInfo.Name]));
    tkString, tkLString:
      SetStrProp(Instance, PropInfo, Data.Values[PropInfo.Name]);
    tkWString:
      SetWideStrProp(Instance, PropInfo, Data.Values[PropInfo.Name]);
    tkSet:
      LogMessage('Unsupported reader property type: Set');
      //SetOrdProp(Instance, PropInfo, ReadSet(PropType));
    tkClass: ProcessObjectProp;
      (*
      case NextValue of
        vaNil:
          begin
            ReadValue;
            SetOrdProp(Instance, PropInfo, 0);
          end;
        vaCollection:
          begin
            ReadValue;
            ReadCollection(TCollection(GetOrdProp(Instance, PropInfo)));
          end
      else
        SetObjectIdent(Instance, PropInfo, ReadIdent);
      end;
      *)
(*    tkMethod:
      if NextValue = vaNil then
      begin
        ReadValue;
        SetMethodProp(Instance, PropInfo, NilMethod);
      end
      else
      begin
        Method.Code :=  FindMethod(Root, ReadIdent);
        Method.Data := Root;
        if Method.Code <> nil then SetMethodProp(Instance, PropInfo, Method);
      end;
    tkVariant:
      SetVariantReference;
    tkInt64:
      SetInt64Prop(Instance, PropInfo, ReadInt64);
    tkInterface:
      SetInterfaceReference;
*)
  end;
  finally
  end;
end;

procedure TDbObject.Init;
begin
end;

destructor TDbObject.Destroy(Depth: Integer = 100);
var
  I, Count: Integer;
  PropInfo: PPropInfo;
  PropList: PPropList;
//  Name: string;
begin
  LogMessage('Destroy class: ' + Self.ClassName);
  if Depth >= 0 then begin
  Store(0);
  if Self.ClassInfo = nil then raise Exception.Create('Class ' + Self.ClassName + ' doesn''t provide RTTI information!');
  Count := GetTypeData(Self.ClassInfo)^.PropCount;
  if Count > 0 then with FDatabase do begin
    ProcessedClass := Self;
    GetMem(PropList, Count * SizeOf(Pointer));
    try
      GetPropInfos(Self.ClassInfo, PropList);
      for I := 0 to Count - 1 do
      begin
        PropInfo := PropList^[I];
        if PropInfo = nil then
          Break;
        if IsStoredProp(Self, PropInfo) then
          DestroyProperty(Self, PropInfo, Depth);
      end;
    finally
      FreeMem(PropList, Count * SizeOf(Pointer));
    end;
  end;
  inherited Destroy;
  end;
end;

procedure TDbObject.Store(Depth: Integer = 1);
var
  Data: TAssociativeArray;
  I, Count: Integer;
  PropInfo: PPropInfo;
  PropList: PPropList;
//  Name: string;
begin
  LogMessage('Write class: ' + Self.ClassName);
  if Depth >= 0 then begin
  Data := TAssociativeArray.Create;
  if Self.ClassInfo = nil then raise Exception.Create('Trida '+Self.ClassName+' neposkytuje RTTI informace!');
  Count := GetTypeData(Self.ClassInfo)^.PropCount;
  if Count > 0 then with FDatabase do begin
    GetMem(PropList, Count * SizeOf(Pointer));
    try
      GetPropInfos(Self.ClassInfo, PropList);
      for I := 0 to Count - 1 do
      begin
        PropInfo := PropList^[I];
        if PropInfo = nil then
          Break;
        if IsStoredProp(Self, PropInfo) then
          WriteProperty(Self, PropInfo, Data, Depth);
      end;

      ProcessedClass := Self;
      repeat
        Replace(Self.ClassName, Data);
      until not RepeatLastAction;
      FId := FDatabase.LastInsertId;
    finally
      FreeMem(PropList, Count * SizeOf(Pointer));
    end;
  end;
//  Instance.DefineProperties(Self);
  end;
end;

function TDbObject.SearchPropertyByPointer(P: Pointer): string;
var
//  Data: TAssocArray;
  I, Count: Integer;
  PropInfo: PPropInfo;
  PropList: PPropList;
  Instance: TObject;
//  Name: string;
begin
  Instance := Self;
  if Self.ClassInfo = nil then raise Exception.Create('Trida '+Self.ClassName+' neposkytuje RTTI informace!');
  Count := GetTypeData(Self.ClassInfo)^.PropCount;
  if Count > 0 then with FDatabase do begin
    ProcessedClass := Self;
    GetMem(PropList, Count * SizeOf(Pointer));
    try
      GetPropInfos(Self.ClassInfo, PropList);
      for I := 0 to Count - 1 do
      begin
        PropInfo := PropList^[I];
        if PropInfo = nil then
          Break;
        if IsStoredProp(Instance, PropInfo) then
          if GetObjectProp(Self,PropInfo) = P then begin
            Result := PropInfo.Name;
            Break;
          end;
      end;
    finally
      FreeMem(PropList, Count * SizeOf(Pointer));
    end;
  end;
end;

{ TDbList }

procedure TDbList.CheckId;
var
  Rows: TDbRows;
begin
  if FId = 0 then begin
    FDatabase.ProcessedClass := Self;
    Rows := FDatabase.Select(Self.ClassName, 'MAX(ListId)');
//    ShowMessage(Rows[0].Values['MAX(ListId)']);
    if Rows.Count > 0 then begin
      if Rows[0].Values['MAX(ListId)'] = '' then FId := 1 else
      FId := StrToInt(Rows[0].Values['MAX(ListId)']) + 1;
    end else FId := 1;
    Rows.Free;
  end;
end;

constructor TDbList.Create(ADatabase: TDatabase; Id: Integer);
begin
  FId := Id;
  FDatabase := ADatabase;
//  inherited Create(FDatabase);
  //Load;
end;

procedure TDbList.Delete;
var
  I: Integer;
begin
  for I := 0 to Count-1 do Items[I].Delete;
  FDatabase.Select(Self.ClassName, 'ListId=' + IntToStr(FId))
end;

destructor TDbList.Destroy(Depth: Integer = 100);
var
  I: Integer;
begin
  LogMessage('Destroy DbList: ' + Self.ClassName);
  Store(0);
  if Depth >= 0 then begin
    if Depth > 0 then for I := 0 to Count-1 do if Assigned(Items[I]) then TDbObject(Items[I]).Destroy(Depth);
    inherited Destroy;
  end;
end;

function TDbList.Get(Index: Integer): TDbObject;
begin
  Result := inherited Get(Index);
end;

procedure TDbList.Load(Depth: Integer = 1);
var
//  B: TObject;
  DbRows: TDbRows;
  I: Integer;
//  d: TPersistentList;
begin
//  d:= TPersistentList.Create;
//  ShowMessage(IntToStr(Integer(d.ClassInfo)));
  FDatabase.ProcessedClass := Self;
  //ShowMessage(IntToStr(Integer(FDatabase.ProcessedClass.ClassInfo)));
  FDatabase.Table := Self.ClassName;
  DbRows := FDatabase.Select(FDatabase.Table, '*', 'ListId=' + IntToStr(FId) + ' ORDER BY id');
  Count := DbRows.Count;
  for I := 0 to DbRows.Count-1 do begin
    Items[I] := ItemsClass.Create(FDatabase);
    if Depth > 0 then Items[I].LoadById(StrToInt(DbRows.Data[I].Values['ItemId']), Depth-1);
   // FromRow(Items[I], DbRows.Data[I]);
  end;
end;

procedure TDbList.Put(Index: Integer; const Value: TDbObject);
begin
  inherited Put(Index, Value);
end;

procedure TDbList.Store(Depth: Integer = 1);
var
  I: Integer;
  Data: TAssociativeArray;
begin
  if Depth >= 0 then begin
  CheckId;
  FDatabase.ProcessedClass := Self;
  FDatabase.Delete(Self.ClassName, 'ListId='+IntToStr(FId));
  if Self.ClassName = 'tmeasurepointsetlist' then LogMessage('d');
  Data := TAssociativeArray.Create;
  Data.AddKeyValue('ListId', IntToStr(FId));
  Data.AddKeyValue('ItemId', '0');
  for I := 0 to Count-1 do
  if Assigned(Items[I]) then begin
    if Depth > 0 then Items[I].Store(Depth);
    Data.Values['ItemId'] := IntToStr(TDbObject(Items[I]).FId);
    FDatabase.ProcessedClass := Self;
    FDatabase.Insert(Self.ClassName, Data);
  end else raise Exception.Create('Item '+IntToStr(I)+' in '+Self.ClassName+' is nil!');
  Data.Free;
//  inherited StoreClassName(FItemsClass.ClassName+'_list', Depth);
  end;
end;

{ TDatabase }

procedure TDatabase.CheckTable;
begin

end;

constructor TDatabase.Create;
begin
  inherited;
end;

destructor TDatabase.Destroy;
begin
  Disconnect;
  inherited;
end;

procedure TDbObject.LoadFromRow(Row: TAssociativeArray; Depth: Integer = 1);
var
  I, Count: Integer;
  PropInfo: PPropInfo;
  PropList: PPropList;
begin
  LogMessage('Load class: ' + Self.ClassName);
//  ShowMessage(Row.GetAllValues);
  FRow := Row;
  if Self.ClassInfo = nil then raise Exception.Create('Trida '+Self.ClassName+' neposkytuje RTTI informace!');
  Count := GetTypeData(Self.ClassInfo)^.PropCount;
  if Count > 0 then with FDatabase do begin
    ProcessedClass := Self;
    GetMem(PropList, Count * SizeOf(Pointer));
    try
      GetPropInfos(Self.ClassInfo, PropList);
      for I := 0 to Count - 1 do
      begin
        PropInfo := PropList^[I];
        if PropInfo = nil then
          Break;
        if IsStoredProp(Self, PropInfo) then
          ReadProperty(Self, PropInfo, Row, Depth);
      end;
    finally
      FreeMem(PropList, Count * SizeOf(Pointer));
    end;
  end;
//  Instance.DefineProperties(Self);
//  Data.Free;
  FRow := nil;
end;

procedure TDatabase.HandleError(Sender: TObject);
var
  Name: string;
  PropInfo: PPropInfo;
begin
  if LastErrorNumber = 1146 then begin    // Table doesn't exist
    CreateTable(Table);
    RepeatLastAction := True;
  end else
  if LastErrorNumber = 1054 then begin    // Unknown column
    Name := Copy(LastErrorMessage, Pos('''', LastErrorMessage) + 1, Length(LastErrorMessage));
    Name := Copy(Name, 1, Pos('''', Name)-1);
    //ShowMessage(IntToStr(Integer(ProcessedClass.ClassInfo)));
    //ShowMessage(ProcessedClass.ClassName);
    PropInfo := GetPropInfo(ProcessedClass.ClassInfo, Name);
    if PropInfo = nil then
      raise Exception.Create('Missing published property '+Name+' in class '+ProcessedClass.ClassName)
    else CreateColumn(Table, PropInfo.Name, PropInfo.PropType^.Kind);
    RepeatLastAction := True;
  end else begin
    if Assigned(FOnError) then FOnError(Self);
  end;
end;

constructor TDbObject.Create(ADatabase: TDatabase);
begin
  FDatabase := ADatabase;
  FId := 0;
end;

procedure TDbObject.LoadById(Id: Integer; Depth: Integer = 1);
var
  Rows: TDbRows;
begin
  FId := Id;
  Rows := FDatabase.Select(Self.ClassName, '*', 'id=' + IntToStr(FId));
  if Rows.Count > 0 then LoadFromRow(Rows[0], Depth) else begin
    Store;
    Rows.Free;
    Rows := FDatabase.Select(Self.ClassName, '*', 'id=' + IntToStr(FId));
    LoadFromRow(Rows[0], Depth);
  end;
  Rows.Free;
end;

{ TPersistentList }

destructor TPersistentList.Destroy;
begin
  Clear;
end;

function TPersistentList.Add(Item: Pointer): Integer;
begin
  Result := FCount;
  if Result = FCapacity then
    Grow;
  FList^[Result] := Item;
  Inc(FCount);
  if Item <> nil then
    Notify(Item, lnAdded);
end;

procedure TPersistentList.Clear;
begin
  SetCount(0);
  SetCapacity(0);
end;

procedure TPersistentList.Delete(Index: Integer);
var
  Temp: Pointer;
begin
  if (Index < 0) or (Index >= FCount) then
    Error(@SListIndexError, Index);
  Temp := Items[Index];
  Dec(FCount);
  if Index < FCount then
    System.Move(FList^[Index + 1], FList^[Index],
      (FCount - Index) * SizeOf(Pointer));
  if Temp <> nil then
    Notify(Temp, lnDeleted);
end;

class procedure TPersistentList.Error(const Msg: string; Data: Integer);

  (*
  function ReturnAddr: Pointer;
  asm
          MOV     EAX,[EBP+4]
  end;
  *)

begin
//  raise EListError.CreateFmt(Msg, [Data]) at ReturnAddr;
end;

class procedure TPersistentList.Error(Msg: PResStringRec; Data: Integer);
begin
  TPersistentList.Error(LoadResString(Msg), Data);
end;

procedure TPersistentList.Exchange(Index1, Index2: Integer);
var
  Item: Pointer;
begin
  if (Index1 < 0) or (Index1 >= FCount) then
    Error(@SListIndexError, Index1);
  if (Index2 < 0) or (Index2 >= FCount) then
    Error(@SListIndexError, Index2);
  Item := FList^[Index1];
  FList^[Index1] := FList^[Index2];
  FList^[Index2] := Item;
end;

function TPersistentList.Expand: TPersistentList;
begin
  if FCount = FCapacity then
    Grow;
  Result := Self;
end;

function TPersistentList.First: Pointer;
begin
  Result := Get(0);
end;

function TPersistentList.Get(Index: Integer): Pointer;
begin
  if (Index < 0) or (Index >= FCount) then
    Error(@SListIndexError, Index);
  Result := FList^[Index];
end;

procedure TPersistentList.Grow;
var
  Delta: Integer;
begin
  if FCapacity > 64 then
    Delta := FCapacity div 4
  else
    if FCapacity > 8 then
      Delta := 16
    else
      Delta := 4;
  SetCapacity(FCapacity + Delta);
end;

function TPersistentList.IndexOf(Item: Pointer): Integer;
begin
  Result := 0;
  while (Result < FCount) and (FList^[Result] <> Item) do
    Inc(Result);
  if Result = FCount then
    Result := -1;
end;

procedure TPersistentList.Insert(Index: Integer; Item: Pointer);
begin
  if (Index < 0) or (Index > FCount) then
    Error(@SListIndexError, Index);
  if FCount = FCapacity then
    Grow;
  if Index < FCount then
    System.Move(FList^[Index], FList^[Index + 1],
      (FCount - Index) * SizeOf(Pointer));
  FList^[Index] := Item;
  Inc(FCount);
  if Item <> nil then
    Notify(Item, lnAdded);
end;

function TPersistentList.Last: Pointer;
begin
  Result := Get(FCount - 1);
end;

procedure TPersistentList.Move(CurIndex, NewIndex: Integer);
var
  Item: Pointer;
begin
  if CurIndex <> NewIndex then
  begin
    if (NewIndex < 0) or (NewIndex >= FCount) then
      Error(@SListIndexError, NewIndex);
    Item := Get(CurIndex);
    FList^[CurIndex] := nil;
    Delete(CurIndex);
    Insert(NewIndex, nil);
    FList^[NewIndex] := Item;
  end;
end;

procedure TPersistentList.Put(Index: Integer; Item: Pointer);
var
  Temp: Pointer;
begin
  if (Index < 0) or (Index >= FCount) then
    Error(@SListIndexError, Index);
  if Item <> FList^[Index] then
  begin
    Temp := FList^[Index];
    FList^[Index] := Item;
    if Temp <> nil then
      Notify(Temp, lnDeleted);
    if Item <> nil then
      Notify(Item, lnAdded);
  end;
end;

function TPersistentList.Remove(Item: Pointer): Integer;
begin
  Result := IndexOf(Item);
  if Result >= 0 then
    Delete(Result);
end;

procedure TPersistentList.Pack;
var
  I: Integer;
begin
  for I := FCount - 1 downto 0 do
    if Items[I] = nil then
      Delete(I);
end;

procedure TPersistentList.SetCapacity(NewCapacity: Integer);
begin
  if (NewCapacity < FCount) or (NewCapacity > MaxListSize) then
    Error(@SListCapacityError, NewCapacity);
  if NewCapacity <> FCapacity then
  begin
    ReallocMem(FList, NewCapacity * SizeOf(Pointer));
    FCapacity := NewCapacity;
  end;
end;

procedure TPersistentList.SetCount(NewCount: Integer);
var
  I: Integer;
begin
  if (NewCount < 0) or (NewCount > MaxListSize) then
    Error(@SListCountError, NewCount);
  if NewCount > FCapacity then
    SetCapacity(NewCount);
  if NewCount > FCount then
    FillChar(FList^[FCount], (NewCount - FCount) * SizeOf(Pointer), 0)
  else
    for I := FCount - 1 downto NewCount do
      Delete(I);
  FCount := NewCount;
end;

procedure QuickSort(SortList: PPointerList; L, R: Integer;
  SCompare: TListSortCompare);
var
  I, J: Integer;
  P, T: Pointer;
begin
  repeat
    I := L;
    J := R;
    P := SortList^[(L + R) shr 1];
    repeat
      while SCompare(SortList^[I], P) < 0 do
        Inc(I);
      while SCompare(SortList^[J], P) > 0 do
        Dec(J);
      if I <= J then
      begin
        T := SortList^[I];
        SortList^[I] := SortList^[J];
        SortList^[J] := T;
        Inc(I);
        Dec(J);
      end;
    until I > J;
    if L < J then
      QuickSort(SortList, L, J, SCompare);
    L := I;
  until I >= R;
end;

procedure TPersistentList.Sort(Compare: TListSortCompare);
begin
  if (FList <> nil) and (Count > 0) then
    QuickSort(FList, 0, Count - 1, Compare);
end;

function TPersistentList.Extract(Item: Pointer): Pointer;
var
  I: Integer;
begin
  Result := nil;
  I := IndexOf(Item);
  if I >= 0 then
  begin
    Result := Item;
    FList^[I] := nil;
    Delete(I);
    Notify(Result, lnExtracted);
  end;
end;

procedure TPersistentList.Notify(Ptr: Pointer; Action: TListNotification);
begin
end;

procedure TPersistentList.Assign(ListA: TPersistentList; AOperator: TListAssignOp; ListB: TPersistentList);
var
  I: Integer;
  LTemp, LSource: TPersistentList;
begin
  // ListB given?
  if ListB <> nil then
  begin
    LSource := ListB;
    Assign(ListA);
  end
  else
    LSource := ListA;

  // on with the show
  case AOperator of

    // 12345, 346 = 346 : only those in the new list
    laCopy:
      begin
        Clear;
        Capacity := LSource.Capacity;
        for I := 0 to LSource.Count - 1 do
          Add(LSource[I]);
      end;

    // 12345, 346 = 34 : intersection of the two lists
    laAnd:
      for I := Count - 1 downto 0 do
        if LSource.IndexOf(Items[I]) = -1 then
          Delete(I);

    // 12345, 346 = 123456 : union of the two lists
    laOr:
      for I := 0 to LSource.Count - 1 do
        if IndexOf(LSource[I]) = -1 then
          Add(LSource[I]);

    // 12345, 346 = 1256 : only those not in both lists
    laXor:
      begin
        LTemp := TPersistentList.Create; // Temp holder of 4 byte values
        try
          LTemp.Capacity := LSource.Count;
          for I := 0 to LSource.Count - 1 do
            if IndexOf(LSource[I]) = -1 then
              LTemp.Add(LSource[I]);
          for I := Count - 1 downto 0 do
            if LSource.IndexOf(Items[I]) <> -1 then
              Delete(I);
          I := Count + LTemp.Count;
          if Capacity < I then
            Capacity := I;
          for I := 0 to LTemp.Count - 1 do
            Add(LTemp[I]);
        finally
          LTemp.Free;
        end;
      end;

    // 12345, 346 = 125 : only those unique to source
    laSrcUnique:
      for I := Count - 1 downto 0 do
        if LSource.IndexOf(Items[I]) <> -1 then
          Delete(I);

    // 12345, 346 = 6 : only those unique to dest
    laDestUnique:
      begin
        LTemp := TPersistentList.Create;
        try
          LTemp.Capacity := LSource.Count;
          for I := LSource.Count - 1 downto 0 do
            if IndexOf(LSource[I]) = -1 then
              LTemp.Add(LSource[I]);
          Assign(LTemp);
        finally
          LTemp.Free;
        end;
      end;
  end;
end;

procedure TDbObject.DeleteProperty(Instance: TDbObject; PropInfo: PPropInfo);
var
  PropType: PTypeInfo;

  procedure WriteObjectProp;
  var
    Value: TObject;
//    OldAncestor: TPersistent;
//    SavePropPath, ComponentValue: string;
    Setter: Longint;
    TargetObject: ^TObject;
  begin
    Value := TObject(GetOrdProp(Instance, PropInfo));
    if Value = nil then begin
    end else begin
      if Value is TDbObject then begin
        TDbObject(Value).Delete;
      end else if Value is TDbList then begin
        TDbList(Value).Delete;
      end;

      // Set object reference to nil
      Setter := Longint(PropInfo^.SetProc);
      if (Setter and $FF000000) = $FF000000 then
      begin  // field - Setter is the field's offset in the instance data
        TargetObject := Pointer(Integer(Instance) + (Setter and $00FFFFFF));
        TargetObject^ :=  nil;   // auto ref count
      end;
     end;
  end;


begin
  // Using IsDefaultPropertyValue will tell us if we should write out
  // a given property because it was different from the default or
  // different from the Ancestor (if applicable).
  if (PropInfo^.GetProc <> nil) and
     ((PropInfo^.SetProc <> nil) or
     ((PropInfo^.PropType^.Kind = tkClass) and
      (TObject(GetOrdProp(Instance, PropInfo)) is TComponent) and
      (csSubComponent in TComponent(GetOrdProp(Instance, PropInfo)).ComponentStyle))) then
  begin
    LogMessage('Destroy property: '+Instance.ClassName+'.'+PropInfo.Name);
    //if not IsDefaultPropertyValue(Instance, PropInfo, GetLookupInfo) then
    begin
      //AncestorValid := AncestorIsValid(Ancestor, Root, RootAncestor);
      PropType := PropInfo^.PropType;
      case PropType^.Kind of
        tkClass:
          WriteObjectProp;
      end;
    end;
  end;
end;

procedure TDbObject.DestroyProperty(Instance: TDbObject; PropInfo: PPropInfo; Depth: Integer);
var
  PropType: PTypeInfo;

  procedure WriteObjectProp;
  var
    Value: TObject;
//    OldAncestor: TPersistent;
//    SavePropPath, ComponentValue: string;
    Setter: Longint;
    TargetObject: ^TObject;
  begin
    Value := TObject(GetOrdProp(Instance, PropInfo));
    if Value = nil then begin
    end else begin
      if Value is TDbObject then begin
        TDbObject(Value).Destroy(Depth - 1);
      end else if Value is TDbList then begin
        TDbList(Value).Destroy(Depth - 1);
      end;

      // Set object reference to nil
      Setter := Longint(PropInfo^.SetProc);
      if (Setter and $FF000000) = $FF000000 then
      begin  // field - Setter is the field's offset in the instance data
        TargetObject := Pointer(Integer(Instance) + (Setter and $00FFFFFF));
        TargetObject^ :=  nil;   // auto ref count
      end;
     end;
  end;


begin
  // Using IsDefaultPropertyValue will tell us if we should write out
  // a given property because it was different from the default or
  // different from the Ancestor (if applicable).
  if (PropInfo^.GetProc <> nil) and
     ((PropInfo^.SetProc <> nil) or
     ((PropInfo^.PropType^.Kind = tkClass) and
      (TObject(GetOrdProp(Instance, PropInfo)) is TComponent) and
      (csSubComponent in TComponent(GetOrdProp(Instance, PropInfo)).ComponentStyle))) then
  begin
    LogMessage('Destroy property: '+Instance.ClassName+'.'+PropInfo.Name);
    //if not IsDefaultPropertyValue(Instance, PropInfo, GetLookupInfo) then
    begin
      //AncestorValid := AncestorIsValid(Ancestor, Root, RootAncestor);
      PropType := PropInfo^.PropType;
      case PropType^.Kind of
        tkClass:
          WriteObjectProp;
      end;
    end;
  end;
end;

procedure TDbObject.Load(Depth: Integer);
begin
  LoadById(Id, Depth);
end;

procedure TDbObject.Delete;
var
  I, Count: Integer;
  PropInfo: PPropInfo;
  PropList: PPropList;
//  Name: string;
begin
  LogMessage('Delete class: '+Self.ClassName);
  if Self.ClassInfo = nil then raise Exception.Create('Class '+Self.ClassName+' doesn''t provide RTTI information!');
  Count := GetTypeData(Self.ClassInfo)^.PropCount;
  if Count > 0 then with FDatabase do begin
    ProcessedClass := Self;
    GetMem(PropList, Count * SizeOf(Pointer));
    try
      GetPropInfos(Self.ClassInfo, PropList);
      for I := 0 to Count - 1 do
      begin
        PropInfo := PropList^[I];
        if PropInfo = nil then
          Break;
        if IsStoredProp(Self, PropInfo) then
          DeleteProperty(Self, PropInfo);
      end;
    finally
      FreeMem(PropList, Count * SizeOf(Pointer));
    end;
  end;
  Database.Delete(Self.ClassName, 'id=' + IntToStr(Id));
  inherited Destroy;
end;

end.