Ignore:
Timestamp:
Feb 18, 2009, 12:11:53 PM (15 years ago)
Author:
george
Message:
  • Upraveno: Přepracován databázový objektový subsystém.
File:
1 edited

Legend:

Unmodified
Added
Removed

  • devel/web/UDatabase.pas

    r142 r158  
    11unit UDatabase;
    22
    3 {$mode objfpc}{$H+}
     3{$mode delphi}{$H+}
    44
    55interface
    66
    77uses
    8   Classes, SysUtils, USqlDatabase;
     8  SysUtils, Variants, Classes, TypInfo, USqlDatabase, RTLConsts, Contnrs, Dialogs;
    99
    1010type
    1111  TDatabase = class;
    12 
    13   { TDbObject }
    14 
     12  TDbList = class;
     13  TDbListClass = class of TDbList;
     14  TDbObject = class;
     15  TDbObjectClass = class of TDbObject;
     16
     17  {$M+}
    1518  TDbObject = class
    16     Id: Integer;
    17     Loaded: Boolean;
    18     Database: TDatabase;
    19     procedure Store; virtual;
    20     procedure Load; virtual;
     19  private
     20    FDatabase: TDatabase;
     21    FId: Integer;
     22    FRow: TAssocArray;
     23    procedure WriteProperty(Instance: TDbObject; PropInfo: PPropInfo; Data: TAssocArray; Depth: Integer);
     24    procedure DeleteProperty(Instance: TDbObject; PropInfo: PPropInfo);
     25    procedure DestroyProperty(Instance: TDbObject; PropInfo: PPropInfo; Depth: Integer);
     26    procedure ReadProperty(Instance: TObject; PropInfo: PPropInfo; Data: TAssocArray; Depth: Integer);
     27    function SearchPropertyByPointer(P: Pointer): string;
     28  public
     29    constructor Create(ADatabase: TDatabase); virtual;
     30    procedure Init;
     31    procedure Store(Depth: Integer = 1); virtual;
    2132    procedure Delete;
     33    procedure LoadById(Id: Integer; Depth: Integer = 1);
     34    procedure Load(Depth: Integer = 1);
     35    procedure LoadFromRow(Row: TAssocArray; Depth: Integer = 1);
     36    destructor Destroy(Depth: Integer = 100); virtual;
     37    property Database: TDatabase read FDatabase write FDatabase;
     38  published
     39    property Id: Integer read FId write Fid;
     40  end;
     41
     42  // TList with RTTI information
     43  TPersistentList = class
     44  private
     45    FList: PPointerList;
     46    FCount: Integer;
     47    FCapacity: Integer;
     48  protected
     49    function Get(Index: Integer): Pointer;
     50    procedure Grow; virtual;
     51    procedure Put(Index: Integer; Item: Pointer);
     52    procedure Notify(Ptr: Pointer; Action: TListNotification); virtual;
     53    procedure SetCapacity(NewCapacity: Integer);
     54    procedure SetCount(NewCount: Integer);
     55  public
     56    destructor Destroy; override;
     57    function Add(Item: Pointer): Integer;
     58    procedure Clear; virtual;
     59    procedure Delete(Index: Integer);
     60    class procedure Error(const Msg: string; Data: Integer); overload; virtual;
     61    class procedure Error(Msg: PResStringRec; Data: Integer); overload;
     62    procedure Exchange(Index1, Index2: Integer);
     63    function Expand: TPersistentList;
     64    function Extract(Item: Pointer): Pointer;
     65    function First: Pointer;
     66    function IndexOf(Item: Pointer): Integer;
     67    procedure Insert(Index: Integer; Item: Pointer);
     68    function Last: Pointer;
     69    procedure Move(CurIndex, NewIndex: Integer);
     70    function Remove(Item: Pointer): Integer;
     71    procedure Pack;
     72    procedure Sort(Compare: TListSortCompare);
     73    procedure Assign(ListA: TPersistentList; AOperator: TListAssignOp = laCopy; ListB: TPersistentList = nil);
     74    property Capacity: Integer read FCapacity write SetCapacity;
     75    property Count: Integer read FCount write SetCount;
     76    property Items[Index: Integer]: Pointer read Get write Put; default;
     77    property List: PPointerList read FList;
     78  end;
     79
     80  TDbList = class(TObjectList)
     81  private
     82    FId: Integer;
     83    FItemId: Integer;
     84    FDatabase: TDatabase;
     85    FItemsClass: TDbObjectClass;
     86    procedure Put(Index: Integer; const Value: TDbObject); virtual;
     87    function Get(Index: Integer): TDbObject; virtual;
     88    procedure CheckId;
     89  public
     90    procedure Store(Depth: Integer = 1);
     91    procedure Load(Depth: Integer = 1);
     92    procedure Delete;
     93    constructor Create(ADatabase: TDatabase; Id: Integer); virtual;
     94    destructor Destroy(Depth: Integer = 100);
     95//    property Id: Integer read FId write Fid;
     96    property Items[Index: Integer]: TDbObject read Get write Put; default;
     97    property ItemsClass: TDbObjectClass read FItemsClass write FItemsClass;
     98  published
     99    property ListId: Integer read FId write Fid;
     100    property ItemId: Integer read FItemId write FItemId;
     101  end;
     102  {$M-}
     103
     104  TDatabase = class(TSqlDatabase)
     105  private
     106    FOnError: TNotifyEvent;
     107    procedure HandleError(Sender: TObject);
     108  public
     109    ProcessedClass: TObject;
     110    DbObject: TDbObject;
    22111    constructor Create;
     112    property OnError: TNotifyEvent read FOnError write FOnError;
     113    procedure CheckTable;
    23114    destructor Destroy; override;
    24115  end;
    25116
    26   TDbObjectClass = class of TDbObject;
    27 
    28   { TDbList }
    29 
    30   TDbList = class
    31     Id: Integer;
    32     Database: TDatabase;
    33     ItemClassType: TDbObjectClass;
    34     Items: TList;
    35     constructor Create;
    36     destructor Destroy; override;
    37     function Add: TDbObject;
    38     procedure Store;
    39     procedure Load;
    40   end;
    41 
    42   { TDbResultSet }
    43 
    44   TDbResultSet = class
    45     Items: TList;
    46     procedure Delete;
    47   end;
    48 
    49   { TDatabase }
    50 
    51   TDatabase = class(TSqlDatabase)
    52     BaseObject: TDbObject;
    53     constructor Create;
    54     destructor Destroy; override;
    55     procedure Init;
    56   end;
     117  procedure LogMessage(Text: string);
    57118
    58119implementation
    59120
    60 procedure TDbObject.Store;
    61 begin
    62 
    63 end;
    64 
    65 procedure TDbObject.Load;
    66 begin
    67 
    68 end;
    69 
    70 procedure TDbObject.Delete;
    71 begin
    72 
    73 end;
    74 
    75 constructor TDbObject.Create;
    76 begin
    77 end;
    78 
    79 destructor TDbObject.Destroy;
    80 begin
     121procedure LogMessage(Text: string);
     122begin
     123
     124end;
     125
     126{ TDbObject }
     127
     128procedure TDbObject.WriteProperty(Instance: TDbObject; PropInfo: PPropInfo; Data: TAssocArray; Depth: Integer);
     129var
     130  PropType: PTypeInfo;
     131//  AncestorValid: Boolean;
     132
     133  procedure WriteSet(Value: Longint);
     134//  var
     135//    I: Integer;
     136//    BaseType: PTypeInfo;
     137  begin
     138(*
     139    BaseType := GetTypeData(PropType)^.CompType^;
     140    WriteValue(vaSet);
     141    for I := 0 to SizeOf(TIntegerSet) * 8 - 1 do
     142      if I in TIntegerSet(Value) then WriteStr(GetEnumName(BaseType, I));
     143    WriteStr('');
     144*)
     145  end;
     146
     147  procedure WriteIntProp(IntType: PTypeInfo; Value: Longint);
     148  var
     149    Ident: string;
     150    IntToIdent: TIntToIdent;
     151  begin
     152    IntToIdent := FindIntToIdent(IntType);
     153    if Assigned(IntToIdent) and IntToIdent(Value, Ident) then
     154      //WriteIdent(Ident)
     155    else
     156      Data.AddKeyValue(PropInfo.Name, IntToStr(Value));
     157  end;
     158
     159  procedure WriteOrdProp;
     160  var
     161    Value: Longint;
     162  begin
     163    Value := GetOrdProp(Instance, PropInfo);
     164    case PropType^.Kind of
     165      tkInteger:
     166        WriteIntProp(PPropInfo(PropInfo)^.PropType, Value);
     167      tkChar:
     168        Data.AddKeyValue(PropInfo.Name, Chr(Value));
     169      tkSet:
     170        LogMessage('Unsupported writer persistent type: Set');
     171      //  WriteSet(Value);
     172      tkEnumeration:
     173        Data.AddKeyValue(PropInfo.Name, IntToStr(Value));
     174    end;
     175  end;
     176
     177  procedure WriteFloatProp;
     178  var
     179    Value: Extended;
     180  begin
     181    Value := GetFloatProp(Instance, PropInfo);
     182    Data.AddKeyValue(PropInfo.Name, MysqlFloatToStr(Value));
     183  end;
     184
     185  procedure WriteInt64Prop;
     186//  var
     187//    Value: Int64;
     188  begin
     189(*
     190    Value := GetInt64Prop(Instance, PropInfo);
     191    WritePropPath;
     192    WriteInteger(Value);
     193*)
     194  end;
     195
     196  procedure WriteStrProp;
     197  begin
     198    Data.AddKeyValue(PropInfo.Name, GetWideStrProp(Instance, PropInfo));
     199  end;
     200
     201  procedure WriteObjectProp;
     202  var
     203    Value: TObject;
     204//    OldAncestor: TPersistent;
     205//    SavePropPath, ComponentValue: string;
     206  begin
     207    Value := TObject(GetOrdProp(Instance, PropInfo));
     208    if Value = nil then begin
     209      Data.AddKeyValue(PropInfo.Name, IntToStr(0));
     210    end else if Value is TDbObject then begin
     211      TDbObject(Value).Store(Depth-1);
     212      Data.AddKeyValue(PropInfo.Name, IntToStr(TDbObject(Value).Id));
     213    end else if Value is TDbList then begin
     214      if Value = nil then raise Exception.Create('WriteObjectProp: Unbelievable! Value is nil!');
     215      TDbList(Value).Store(Depth-1);
     216      Data.AddKeyValue(PropInfo.Name, IntToStr(TDbList(Value).FId));
     217    end;
     218  end;
     219
     220
     221begin
     222  // Using IsDefaultPropertyValue will tell us if we should write out
     223  // a given property because it was different from the default or
     224  // different from the Ancestor (if applicable).
     225  if (PropInfo^.GetProc <> nil) and
     226     ((PropInfo^.SetProc <> nil) or
     227     ((PropInfo^.PropType^.Kind = tkClass) and
     228      (TObject(GetOrdProp(Instance, PropInfo)) is TComponent) and
     229      (csSubComponent in TComponent(GetOrdProp(Instance, PropInfo)).ComponentStyle))) then
     230  begin
     231    LogMessage('Write property: '+Instance.ClassName+'.'+PropInfo.Name);
     232    //if not IsDefaultPropertyValue(Instance, PropInfo, GetLookupInfo) then
     233    begin
     234      //AncestorValid := AncestorIsValid(Ancestor, Root, RootAncestor);
     235      PropType := PropInfo^.PropType;
     236      case PropType^.Kind of
     237        tkInteger, tkChar, tkEnumeration, tkSet:
     238          WriteOrdProp;
     239        tkFloat:
     240          WriteFloatProp;
     241        tkString, tkLString, tkWString:
     242          WriteStrProp;
     243        tkClass:
     244          WriteObjectProp;
     245        //tkMethod:
     246        //  WriteMethodProp;
     247        //tkVariant:
     248        //  WriteVariantProp;
     249        tkInt64:
     250          WriteInt64Prop;
     251        //tkInterface:
     252        //  WriteInterfaceProp;
     253      else
     254        raise Exception.Create('Not supported class property '+GetEnumName(PropType, Integer(PropType^.Kind)));
     255      end;
     256    end;
     257  end;
     258end;
     259
     260
     261procedure TDbObject.ReadProperty(Instance: TObject; PropInfo: PPropInfo; Data: TAssocArray; Depth: Integer);
     262const
     263  NilMethod: TMethod = (Code: nil; Data: nil);
     264var
     265  PropType: PTypeInfo;
     266//  Method: TMethod;
     267
     268  procedure SetIntIdent(Instance: TPersistent; PropInfo: Pointer;
     269    const Ident: string);
     270  var
     271    V: Longint;
     272    IdentToInt: TIdentToInt;
     273  begin
     274    IdentToInt := FindIdentToInt(PPropInfo(PropInfo)^.PropType);
     275    if Assigned(IdentToInt) and IdentToInt(Ident, V) then
     276      SetOrdProp(Instance, PropInfo, V)
     277    else
     278      //PropValueError;
     279  end;
     280
     281  procedure ProcessObjectProp;
     282  var
     283    Setter: Longint;
     284    Value: TObject;
     285    TypeData: PTypeData;
     286    TargetObject: ^TObject;
     287    TargetClass: TClass;
     288    DbListClass: TDbListClass;
     289    DbObjectClass: TDbObjectClass;
     290  begin
     291    if Depth > 0 then begin
     292  //  List := TDbList.Create(AClass, FDatabase, FId);
     293    Value := TObject(GetOrdProp(Instance, PropInfo));
     294    TypeData := GetTypeData(PropInfo.PropType);
     295//    ShowMessage(PropInfo.Name+' '+TypeData.ClassType.ClassName);
     296    if Value = nil then begin
     297      Setter := Longint(PropInfo^.SetProc);
     298      if (Setter and $FF000000) = $FF000000 then
     299      begin  // field - Setter is the field's offset in the instance data
     300        TargetObject := Pointer(Integer(Instance) + (Setter and $00FFFFFF));
     301        TargetClass := TypeData.ClassType;
     302//        TargetClass := TargetClass.ClassParent;
     303//        ShowMessage(TargetClass.ClassName);
     304        if TargetClass.ClassParent = TDbObject then begin
     305          DbObjectClass := TDbObjectClass(TargetClass);
     306          TargetObject^ :=  DbObjectClass.Create(FDatabase);   // auto ref count
     307        end else
     308        if TargetClass.ClassParent = TDbList then begin
     309          DbListClass := TDbListClass(TargetClass);
     310        //ShowMessage(DbListClass.ClassName);
     311
     312          TargetObject^ :=  DbListClass.Create(FDatabase, StrToInt(FRow.Values[PropInfo.Name]));   // auto ref count
     313        end else TargetObject^ :=  TargetClass.Create;   // auto ref count
     314        Value := TObject(GetOrdProp(Instance, PropInfo));
     315      end else raise Exception.Create('Object property '+PropInfo.Name+' in object '+Instance.ClassName+' is not mapped directly to variable!');
     316    end;
     317    //ShowMessage(IntToStr(Integer(Value.ClassInfo)));
     318    if Value is TDbObject then begin
     319      (Value as TDbObject).LoadById(StrToInt(FRow.Values[PropInfo.Name]), Depth-1);
     320      //ShowMessage(Value.ClassName);
     321    end else if Value is TDbList then begin
     322      (Value as TDbList).Load(Depth);
     323      //ShowMessage(Value.ClassName);
     324    end;
     325    end;
     326  end;
     327
     328begin
     329  LogMessage('Read property: ' + Instance.ClassName + '.' + PropInfo.Name);
     330//  if PPropInfo(PropInfo)^.SetProc = nil then
     331//    if not ((PPropInfo(PropInfo)^.PropType^.Kind = tkClass) and
     332//       (TObject(GetOrdProp(Instance, PropInfo)) is TComponent) and
     333//       (csSubComponent in TComponent(GetOrdProp(Instance, PropInfo)).ComponentStyle)) then
     334//      ReadError(@SReadOnlyProperty);
     335  PropType := PPropInfo(PropInfo)^.PropType;
     336  try
     337  case PropType^.Kind of
     338    tkInteger:
     339//      if NextValue = vaIdent then
     340//        SetIntIdent(Instance, PropInfo, Data)
     341//      else
     342        SetOrdProp(Instance, PropInfo, StrToInt(Data.Values[PropInfo.Name]));
     343    tkChar:
     344      SetOrdProp(Instance, PropInfo, Ord(Data.Values[PropInfo.Name][1]));
     345    tkEnumeration:
     346      SetOrdProp(Instance, PropInfo, StrToInt(Data.Values[PropInfo.Name]));
     347    tkFloat:
     348      SetFloatProp(Instance, PropInfo, MySqlStrToFloat(Data.Values[PropInfo.Name]));
     349    tkString, tkLString:
     350      SetStrProp(Instance, PropInfo, Data.Values[PropInfo.Name]);
     351    tkWString:
     352      SetWideStrProp(Instance, PropInfo, Data.Values[PropInfo.Name]);
     353    tkSet:
     354      LogMessage('Unsupported reader property type: Set');
     355      //SetOrdProp(Instance, PropInfo, ReadSet(PropType));
     356    tkClass: ProcessObjectProp;
     357      (*
     358      case NextValue of
     359        vaNil:
     360          begin
     361            ReadValue;
     362            SetOrdProp(Instance, PropInfo, 0);
     363          end;
     364        vaCollection:
     365          begin
     366            ReadValue;
     367            ReadCollection(TCollection(GetOrdProp(Instance, PropInfo)));
     368          end
     369      else
     370        SetObjectIdent(Instance, PropInfo, ReadIdent);
     371      end;
     372      *)
     373(*    tkMethod:
     374      if NextValue = vaNil then
     375      begin
     376        ReadValue;
     377        SetMethodProp(Instance, PropInfo, NilMethod);
     378      end
     379      else
     380      begin
     381        Method.Code :=  FindMethod(Root, ReadIdent);
     382        Method.Data := Root;
     383        if Method.Code <> nil then SetMethodProp(Instance, PropInfo, Method);
     384      end;
     385    tkVariant:
     386      SetVariantReference;
     387    tkInt64:
     388      SetInt64Prop(Instance, PropInfo, ReadInt64);
     389    tkInterface:
     390      SetInterfaceReference;
     391*)
     392  end;
     393  finally
     394  end;
     395end;
     396
     397procedure TDbObject.Init;
     398begin
     399end;
     400
     401destructor TDbObject.Destroy(Depth: Integer = 100);
     402var
     403  I, Count: Integer;
     404  PropInfo: PPropInfo;
     405  PropList: PPropList;
     406//  Name: string;
     407begin
     408  LogMessage('Destroy class: ' + Self.ClassName);
     409  if Depth >= 0 then begin
     410  Store(0);
     411  if Self.ClassInfo = nil then raise Exception.Create('Class ' + Self.ClassName + ' doesn''t provide RTTI information!');
     412  Count := GetTypeData(Self.ClassInfo)^.PropCount;
     413  if Count > 0 then with FDatabase do begin
     414    ProcessedClass := Self;
     415    GetMem(PropList, Count * SizeOf(Pointer));
     416    try
     417      GetPropInfos(Self.ClassInfo, PropList);
     418      for I := 0 to Count - 1 do
     419      begin
     420        PropInfo := PropList^[I];
     421        if PropInfo = nil then
     422          Break;
     423        if IsStoredProp(Self, PropInfo) then
     424          DestroyProperty(Self, PropInfo, Depth);
     425      end;
     426    finally
     427      FreeMem(PropList, Count * SizeOf(Pointer));
     428    end;
     429  end;
    81430  inherited Destroy;
     431  end;
     432end;
     433
     434procedure TDbObject.Store(Depth: Integer = 1);
     435var
     436  Data: TAssocArray;
     437  I, Count: Integer;
     438  PropInfo: PPropInfo;
     439  PropList: PPropList;
     440//  Name: string;
     441begin
     442  LogMessage('Write class: ' + Self.ClassName);
     443  if Depth >= 0 then begin
     444  Data := TAssocArray.Create;
     445  if Self.ClassInfo = nil then raise Exception.Create('Trida '+Self.ClassName+' neposkytuje RTTI informace!');
     446  Count := GetTypeData(Self.ClassInfo)^.PropCount;
     447  if Count > 0 then with FDatabase do begin
     448    GetMem(PropList, Count * SizeOf(Pointer));
     449    try
     450      GetPropInfos(Self.ClassInfo, PropList);
     451      for I := 0 to Count - 1 do
     452      begin
     453        PropInfo := PropList^[I];
     454        if PropInfo = nil then
     455          Break;
     456        if IsStoredProp(Self, PropInfo) then
     457          WriteProperty(Self, PropInfo, Data, Depth);
     458      end;
     459
     460      ProcessedClass := Self;
     461      repeat
     462        Replace(Self.ClassName, Data);
     463      until not RepeatLastAction;
     464      FId := FDatabase.LastInsertId;
     465    finally
     466      FreeMem(PropList, Count * SizeOf(Pointer));
     467    end;
     468  end;
     469//  Instance.DefineProperties(Self);
     470  end;
     471end;
     472
     473function TDbObject.SearchPropertyByPointer(P: Pointer): string;
     474var
     475//  Data: TAssocArray;
     476  I, Count: Integer;
     477  PropInfo: PPropInfo;
     478  PropList: PPropList;
     479  Instance: TObject;
     480//  Name: string;
     481begin
     482  Instance := Self;
     483  if Self.ClassInfo = nil then raise Exception.Create('Trida '+Self.ClassName+' neposkytuje RTTI informace!');
     484  Count := GetTypeData(Self.ClassInfo)^.PropCount;
     485  if Count > 0 then with FDatabase do begin
     486    ProcessedClass := Self;
     487    GetMem(PropList, Count * SizeOf(Pointer));
     488    try
     489      GetPropInfos(Self.ClassInfo, PropList);
     490      for I := 0 to Count - 1 do
     491      begin
     492        PropInfo := PropList^[I];
     493        if PropInfo = nil then
     494          Break;
     495        if IsStoredProp(Instance, PropInfo) then
     496          if GetObjectProp(Self,PropInfo) = P then begin
     497            Result := PropInfo.Name;
     498            Break;
     499          end;
     500      end;
     501    finally
     502      FreeMem(PropList, Count * SizeOf(Pointer));
     503    end;
     504  end;
    82505end;
    83506
    84507{ TDbList }
    85508
    86 constructor TDbList.Create;
    87 begin
    88   Items := TList.Create;
    89 end;
    90 
    91 destructor TDbList.Destroy;
     509procedure TDbList.CheckId;
     510var
     511  Rows: TDbRows;
     512begin
     513  if FId = 0 then begin
     514    FDatabase.ProcessedClass := Self;
     515    Rows := FDatabase.Select(Self.ClassName, 'MAX(ListId)');
     516//    ShowMessage(Rows[0].Values['MAX(ListId)']);
     517    if Rows.Count > 0 then begin
     518      if Rows[0].Values['MAX(ListId)'] = '' then FId := 1 else
     519      FId := StrToInt(Rows[0].Values['MAX(ListId)']) + 1;
     520    end else FId := 1;
     521    Rows.Free;
     522  end;
     523end;
     524
     525constructor TDbList.Create(ADatabase: TDatabase; Id: Integer);
     526begin
     527  FId := Id;
     528  FDatabase := ADatabase;
     529//  inherited Create(FDatabase);
     530  //Load;
     531end;
     532
     533procedure TDbList.Delete;
    92534var
    93535  I: Integer;
    94536begin
    95   for I := 0 to Items.Count - 1 do
    96     TDbObject(Items[I]).Free;
    97   Items.Free;
    98   inherited Destroy;
    99 end;
    100 
    101 function TDbList.Add: TDbObject;
    102 var
    103   Data: TAssocArray;
    104 begin
    105   Result := ItemClassType.Create;
    106   Data := TAssocArray.Create;
    107   Data.AddKeyValue('id', '');
    108   Database.Insert(ClassName, Data);
    109   Result.Id := Database.LastInsertId;;
    110   Items.Add(Result);
    111 end;
    112 
    113 procedure TDbList.Store;
     537  for I := 0 to Count-1 do Items[I].Delete;
     538  FDatabase.Select(Self.ClassName, 'ListId=' + IntToStr(FId))
     539end;
     540
     541destructor TDbList.Destroy(Depth: Integer = 100);
     542var
     543  I: Integer;
     544begin
     545  LogMessage('Destroy DbList: ' + Self.ClassName);
     546  Store(0);
     547  if Depth >= 0 then begin
     548    if Depth > 0 then for I := 0 to Count-1 do if Assigned(Items[I]) then TDbObject(Items[I]).Destroy(Depth);
     549    inherited Destroy;
     550  end;
     551end;
     552
     553function TDbList.Get(Index: Integer): TDbObject;
     554begin
     555  Result := inherited Get(Index);
     556end;
     557
     558procedure TDbList.Load(Depth: Integer = 1);
     559var
     560//  B: TObject;
     561  DbRows: TDbRows;
     562  I: Integer;
     563//  d: TPersistentList;
     564begin
     565//  d:= TPersistentList.Create;
     566//  ShowMessage(IntToStr(Integer(d.ClassInfo)));
     567  FDatabase.ProcessedClass := Self;
     568  //ShowMessage(IntToStr(Integer(FDatabase.ProcessedClass.ClassInfo)));
     569  FDatabase.Table := Self.ClassName;
     570  DbRows := FDatabase.Select(FDatabase.Table, '*', 'ListId=' + IntToStr(FId) + ' ORDER BY id');
     571  Count := DbRows.Count;
     572  for I := 0 to DbRows.Count-1 do begin
     573    Items[I] := ItemsClass.Create(FDatabase);
     574    if Depth > 0 then Items[I].LoadById(StrToInt(DbRows.Data[I].Values['ItemId']), Depth-1);
     575   // FromRow(Items[I], DbRows.Data[I]);
     576  end;
     577end;
     578
     579procedure TDbList.Put(Index: Integer; const Value: TDbObject);
     580begin
     581  inherited Put(Index, Value);
     582end;
     583
     584procedure TDbList.Store(Depth: Integer = 1);
    114585var
    115586  I: Integer;
    116587  Data: TAssocArray;
    117588begin
     589  if Depth >= 0 then begin
     590  CheckId;
     591  FDatabase.ProcessedClass := Self;
     592  FDatabase.Delete(Self.ClassName, 'ListId='+IntToStr(FId));
     593  if Self.ClassName = 'tmeasurepointsetlist' then LogMessage('d');
    118594  Data := TAssocArray.Create;
    119   Database.Insert(ClassName, Data);
    120   for I := 0 to Items.Count - 1 do begin
    121     Database.Insert(ClassName, Data);
    122   end;
    123 end;
    124 
    125 procedure TDbList.Load;
    126 begin
    127 
    128 end;
    129 
    130 { TDbResultSet }
    131 
    132 procedure TDbResultSet.Delete;
     595  Data.AddKeyValue('ListId', IntToStr(FId));
     596  Data.AddKeyValue('ItemId', '0');
     597  for I := 0 to Count-1 do
     598  if Assigned(Items[I]) then begin
     599    if Depth > 0 then Items[I].Store(Depth);
     600    Data.Values['ItemId'] := IntToStr(TDbObject(Items[I]).FId);
     601    FDatabase.ProcessedClass := Self;
     602    FDatabase.Insert(Self.ClassName, Data);
     603  end else raise Exception.Create('Item '+IntToStr(I)+' in '+Self.ClassName+' is nil!');
     604  Data.Free;
     605//  inherited StoreClassName(FItemsClass.ClassName+'_list', Depth);
     606  end;
     607end;
     608
     609{ TDatabase }
     610
     611procedure TDatabase.CheckTable;
     612begin
     613
     614end;
     615
     616constructor TDatabase.Create;
     617begin
     618  inherited;
     619  inherited OnError := HandleError;
     620end;
     621
     622destructor TDatabase.Destroy;
     623begin
     624  Disconnect;
     625  inherited;
     626end;
     627
     628procedure TDbObject.LoadFromRow(Row: TAssocArray; Depth: Integer = 1);
     629var
     630  I, Count: Integer;
     631  PropInfo: PPropInfo;
     632  PropList: PPropList;
     633begin
     634  LogMessage('Load class: ' + Self.ClassName);
     635//  ShowMessage(Row.GetAllValues);
     636  FRow := Row;
     637  if Self.ClassInfo = nil then raise Exception.Create('Trida '+Self.ClassName+' neposkytuje RTTI informace!');
     638  Count := GetTypeData(Self.ClassInfo)^.PropCount;
     639  if Count > 0 then with FDatabase do begin
     640    ProcessedClass := Self;
     641    GetMem(PropList, Count * SizeOf(Pointer));
     642    try
     643      GetPropInfos(Self.ClassInfo, PropList);
     644      for I := 0 to Count - 1 do
     645      begin
     646        PropInfo := PropList^[I];
     647        if PropInfo = nil then
     648          Break;
     649        if IsStoredProp(Self, PropInfo) then
     650          ReadProperty(Self, PropInfo, Row, Depth);
     651      end;
     652    finally
     653      FreeMem(PropList, Count * SizeOf(Pointer));
     654    end;
     655  end;
     656//  Instance.DefineProperties(Self);
     657//  Data.Free;
     658  FRow := nil;
     659end;
     660
     661procedure TDatabase.HandleError(Sender: TObject);
     662var
     663  Name: string;
     664  PropInfo: PPropInfo;
     665begin
     666  if LastErrorNumber = 1146 then begin    // Table doesn't exist
     667    CreateTable(Table);
     668    RepeatLastAction := True;
     669  end else
     670  if LastErrorNumber = 1054 then begin    // Unknown column
     671    Name := Copy(LastErrorMessage, Pos('''', LastErrorMessage) + 1, Length(LastErrorMessage));
     672    Name := Copy(Name, 1, Pos('''', Name)-1);
     673    //ShowMessage(IntToStr(Integer(ProcessedClass.ClassInfo)));
     674    //ShowMessage(ProcessedClass.ClassName);
     675    PropInfo := GetPropInfo(ProcessedClass.ClassInfo, Name);
     676    if PropInfo = nil then
     677      raise Exception.Create('Missing published property '+Name+' in class '+ProcessedClass.ClassName)
     678    else CreateColumn(Table, PropInfo.Name, PropInfo.PropType^.Kind);
     679    RepeatLastAction := True;
     680  end else begin
     681    if Assigned(FOnError) then FOnError(Self);
     682  end;
     683end;
     684
     685constructor TDbObject.Create(ADatabase: TDatabase);
     686begin
     687  FDatabase := ADatabase;
     688  FId := 0;
     689end;
     690
     691procedure TDbObject.LoadById(Id: Integer; Depth: Integer = 1);
     692var
     693  Rows: TDbRows;
     694begin
     695  FId := Id;
     696  Rows := FDatabase.Select(Self.ClassName, '*', 'id=' + IntToStr(FId));
     697  if Rows.Count > 0 then LoadFromRow(Rows[0], Depth) else begin
     698    Store;
     699    Rows.Free;
     700    Rows := FDatabase.Select(Self.ClassName, '*', 'id=' + IntToStr(FId));
     701    LoadFromRow(Rows[0], Depth);
     702  end;
     703  Rows.Free;
     704end;
     705
     706{ TPersistentList }
     707
     708destructor TPersistentList.Destroy;
     709begin
     710  Clear;
     711end;
     712
     713function TPersistentList.Add(Item: Pointer): Integer;
     714begin
     715  Result := FCount;
     716  if Result = FCapacity then
     717    Grow;
     718  FList^[Result] := Item;
     719  Inc(FCount);
     720  if Item <> nil then
     721    Notify(Item, lnAdded);
     722end;
     723
     724procedure TPersistentList.Clear;
     725begin
     726  SetCount(0);
     727  SetCapacity(0);
     728end;
     729
     730procedure TPersistentList.Delete(Index: Integer);
     731var
     732  Temp: Pointer;
     733begin
     734  if (Index < 0) or (Index >= FCount) then
     735    Error(@SListIndexError, Index);
     736  Temp := Items[Index];
     737  Dec(FCount);
     738  if Index < FCount then
     739    System.Move(FList^[Index + 1], FList^[Index],
     740      (FCount - Index) * SizeOf(Pointer));
     741  if Temp <> nil then
     742    Notify(Temp, lnDeleted);
     743end;
     744
     745class procedure TPersistentList.Error(const Msg: string; Data: Integer);
     746
     747  (*
     748  function ReturnAddr: Pointer;
     749  asm
     750          MOV     EAX,[EBP+4]
     751  end;
     752  *)
     753
     754begin
     755//  raise EListError.CreateFmt(Msg, [Data]) at ReturnAddr;
     756end;
     757
     758class procedure TPersistentList.Error(Msg: PResStringRec; Data: Integer);
     759begin
     760  TPersistentList.Error(LoadResString(Msg), Data);
     761end;
     762
     763procedure TPersistentList.Exchange(Index1, Index2: Integer);
     764var
     765  Item: Pointer;
     766begin
     767  if (Index1 < 0) or (Index1 >= FCount) then
     768    Error(@SListIndexError, Index1);
     769  if (Index2 < 0) or (Index2 >= FCount) then
     770    Error(@SListIndexError, Index2);
     771  Item := FList^[Index1];
     772  FList^[Index1] := FList^[Index2];
     773  FList^[Index2] := Item;
     774end;
     775
     776function TPersistentList.Expand: TPersistentList;
     777begin
     778  if FCount = FCapacity then
     779    Grow;
     780  Result := Self;
     781end;
     782
     783function TPersistentList.First: Pointer;
     784begin
     785  Result := Get(0);
     786end;
     787
     788function TPersistentList.Get(Index: Integer): Pointer;
     789begin
     790  if (Index < 0) or (Index >= FCount) then
     791    Error(@SListIndexError, Index);
     792  Result := FList^[Index];
     793end;
     794
     795procedure TPersistentList.Grow;
     796var
     797  Delta: Integer;
     798begin
     799  if FCapacity > 64 then
     800    Delta := FCapacity div 4
     801  else
     802    if FCapacity > 8 then
     803      Delta := 16
     804    else
     805      Delta := 4;
     806  SetCapacity(FCapacity + Delta);
     807end;
     808
     809function TPersistentList.IndexOf(Item: Pointer): Integer;
     810begin
     811  Result := 0;
     812  while (Result < FCount) and (FList^[Result] <> Item) do
     813    Inc(Result);
     814  if Result = FCount then
     815    Result := -1;
     816end;
     817
     818procedure TPersistentList.Insert(Index: Integer; Item: Pointer);
     819begin
     820  if (Index < 0) or (Index > FCount) then
     821    Error(@SListIndexError, Index);
     822  if FCount = FCapacity then
     823    Grow;
     824  if Index < FCount then
     825    System.Move(FList^[Index], FList^[Index + 1],
     826      (FCount - Index) * SizeOf(Pointer));
     827  FList^[Index] := Item;
     828  Inc(FCount);
     829  if Item <> nil then
     830    Notify(Item, lnAdded);
     831end;
     832
     833function TPersistentList.Last: Pointer;
     834begin
     835  Result := Get(FCount - 1);
     836end;
     837
     838procedure TPersistentList.Move(CurIndex, NewIndex: Integer);
     839var
     840  Item: Pointer;
     841begin
     842  if CurIndex <> NewIndex then
     843  begin
     844    if (NewIndex < 0) or (NewIndex >= FCount) then
     845      Error(@SListIndexError, NewIndex);
     846    Item := Get(CurIndex);
     847    FList^[CurIndex] := nil;
     848    Delete(CurIndex);
     849    Insert(NewIndex, nil);
     850    FList^[NewIndex] := Item;
     851  end;
     852end;
     853
     854procedure TPersistentList.Put(Index: Integer; Item: Pointer);
     855var
     856  Temp: Pointer;
     857begin
     858  if (Index < 0) or (Index >= FCount) then
     859    Error(@SListIndexError, Index);
     860  if Item <> FList^[Index] then
     861  begin
     862    Temp := FList^[Index];
     863    FList^[Index] := Item;
     864    if Temp <> nil then
     865      Notify(Temp, lnDeleted);
     866    if Item <> nil then
     867      Notify(Item, lnAdded);
     868  end;
     869end;
     870
     871function TPersistentList.Remove(Item: Pointer): Integer;
     872begin
     873  Result := IndexOf(Item);
     874  if Result >= 0 then
     875    Delete(Result);
     876end;
     877
     878procedure TPersistentList.Pack;
    133879var
    134880  I: Integer;
    135881begin
    136   for I := 0 to Items.Count - 1 do
    137     TDbObject(Items[I]).Free;
    138   Items.Free;
    139 end;
    140 
    141 { TDatabase }
    142 
    143 constructor TDatabase.Create;
    144 begin
    145   BaseObject := TDbObject.Create;;
    146 end;
    147 
    148 destructor TDatabase.Destroy;
    149 begin
    150   BaseObject.Free;
    151 end;
    152 
    153 procedure TDatabase.Init;
    154 begin
    155   BaseObject.Id := 1;
    156   BaseObject.Database := Self;
    157   BaseObject.Load;
     882  for I := FCount - 1 downto 0 do
     883    if Items[I] = nil then
     884      Delete(I);
     885end;
     886
     887procedure TPersistentList.SetCapacity(NewCapacity: Integer);
     888begin
     889  if (NewCapacity < FCount) or (NewCapacity > MaxListSize) then
     890    Error(@SListCapacityError, NewCapacity);
     891  if NewCapacity <> FCapacity then
     892  begin
     893    ReallocMem(FList, NewCapacity * SizeOf(Pointer));
     894    FCapacity := NewCapacity;
     895  end;
     896end;
     897
     898procedure TPersistentList.SetCount(NewCount: Integer);
     899var
     900  I: Integer;
     901begin
     902  if (NewCount < 0) or (NewCount > MaxListSize) then
     903    Error(@SListCountError, NewCount);
     904  if NewCount > FCapacity then
     905    SetCapacity(NewCount);
     906  if NewCount > FCount then
     907    FillChar(FList^[FCount], (NewCount - FCount) * SizeOf(Pointer), 0)
     908  else
     909    for I := FCount - 1 downto NewCount do
     910      Delete(I);
     911  FCount := NewCount;
     912end;
     913
     914procedure QuickSort(SortList: PPointerList; L, R: Integer;
     915  SCompare: TListSortCompare);
     916var
     917  I, J: Integer;
     918  P, T: Pointer;
     919begin
     920  repeat
     921    I := L;
     922    J := R;
     923    P := SortList^[(L + R) shr 1];
     924    repeat
     925      while SCompare(SortList^[I], P) < 0 do
     926        Inc(I);
     927      while SCompare(SortList^[J], P) > 0 do
     928        Dec(J);
     929      if I <= J then
     930      begin
     931        T := SortList^[I];
     932        SortList^[I] := SortList^[J];
     933        SortList^[J] := T;
     934        Inc(I);
     935        Dec(J);
     936      end;
     937    until I > J;
     938    if L < J then
     939      QuickSort(SortList, L, J, SCompare);
     940    L := I;
     941  until I >= R;
     942end;
     943
     944procedure TPersistentList.Sort(Compare: TListSortCompare);
     945begin
     946  if (FList <> nil) and (Count > 0) then
     947    QuickSort(FList, 0, Count - 1, Compare);
     948end;
     949
     950function TPersistentList.Extract(Item: Pointer): Pointer;
     951var
     952  I: Integer;
     953begin
     954  Result := nil;
     955  I := IndexOf(Item);
     956  if I >= 0 then
     957  begin
     958    Result := Item;
     959    FList^[I] := nil;
     960    Delete(I);
     961    Notify(Result, lnExtracted);
     962  end;
     963end;
     964
     965procedure TPersistentList.Notify(Ptr: Pointer; Action: TListNotification);
     966begin
     967end;
     968
     969procedure TPersistentList.Assign(ListA: TPersistentList; AOperator: TListAssignOp; ListB: TPersistentList);
     970var
     971  I: Integer;
     972  LTemp, LSource: TPersistentList;
     973begin
     974  // ListB given?
     975  if ListB <> nil then
     976  begin
     977    LSource := ListB;
     978    Assign(ListA);
     979  end
     980  else
     981    LSource := ListA;
     982
     983  // on with the show
     984  case AOperator of
     985
     986    // 12345, 346 = 346 : only those in the new list
     987    laCopy:
     988      begin
     989        Clear;
     990        Capacity := LSource.Capacity;
     991        for I := 0 to LSource.Count - 1 do
     992          Add(LSource[I]);
     993      end;
     994
     995    // 12345, 346 = 34 : intersection of the two lists
     996    laAnd:
     997      for I := Count - 1 downto 0 do
     998        if LSource.IndexOf(Items[I]) = -1 then
     999          Delete(I);
     1000
     1001    // 12345, 346 = 123456 : union of the two lists
     1002    laOr:
     1003      for I := 0 to LSource.Count - 1 do
     1004        if IndexOf(LSource[I]) = -1 then
     1005          Add(LSource[I]);
     1006
     1007    // 12345, 346 = 1256 : only those not in both lists
     1008    laXor:
     1009      begin
     1010        LTemp := TPersistentList.Create; // Temp holder of 4 byte values
     1011        try
     1012          LTemp.Capacity := LSource.Count;
     1013          for I := 0 to LSource.Count - 1 do
     1014            if IndexOf(LSource[I]) = -1 then
     1015              LTemp.Add(LSource[I]);
     1016          for I := Count - 1 downto 0 do
     1017            if LSource.IndexOf(Items[I]) <> -1 then
     1018              Delete(I);
     1019          I := Count + LTemp.Count;
     1020          if Capacity < I then
     1021            Capacity := I;
     1022          for I := 0 to LTemp.Count - 1 do
     1023            Add(LTemp[I]);
     1024        finally
     1025          LTemp.Free;
     1026        end;
     1027      end;
     1028
     1029    // 12345, 346 = 125 : only those unique to source
     1030    laSrcUnique:
     1031      for I := Count - 1 downto 0 do
     1032        if LSource.IndexOf(Items[I]) <> -1 then
     1033          Delete(I);
     1034
     1035    // 12345, 346 = 6 : only those unique to dest
     1036    laDestUnique:
     1037      begin
     1038        LTemp := TPersistentList.Create;
     1039        try
     1040          LTemp.Capacity := LSource.Count;
     1041          for I := LSource.Count - 1 downto 0 do
     1042            if IndexOf(LSource[I]) = -1 then
     1043              LTemp.Add(LSource[I]);
     1044          Assign(LTemp);
     1045        finally
     1046          LTemp.Free;
     1047        end;
     1048      end;
     1049  end;
     1050end;
     1051
     1052procedure TDbObject.DeleteProperty(Instance: TDbObject; PropInfo: PPropInfo);
     1053var
     1054  PropType: PTypeInfo;
     1055
     1056  procedure WriteObjectProp;
     1057  var
     1058    Value: TObject;
     1059//    OldAncestor: TPersistent;
     1060//    SavePropPath, ComponentValue: string;
     1061    Setter: Longint;
     1062    TargetObject: ^TObject;
     1063  begin
     1064    Value := TObject(GetOrdProp(Instance, PropInfo));
     1065    if Value = nil then begin
     1066    end else begin
     1067      if Value is TDbObject then begin
     1068        TDbObject(Value).Delete;
     1069      end else if Value is TDbList then begin
     1070        TDbList(Value).Delete;
     1071      end;
     1072
     1073      // Set object reference to nil
     1074      Setter := Longint(PropInfo^.SetProc);
     1075      if (Setter and $FF000000) = $FF000000 then
     1076      begin  // field - Setter is the field's offset in the instance data
     1077        TargetObject := Pointer(Integer(Instance) + (Setter and $00FFFFFF));
     1078        TargetObject^ :=  nil;   // auto ref count
     1079      end;
     1080     end;
     1081  end;
     1082
     1083
     1084begin
     1085  // Using IsDefaultPropertyValue will tell us if we should write out
     1086  // a given property because it was different from the default or
     1087  // different from the Ancestor (if applicable).
     1088  if (PropInfo^.GetProc <> nil) and
     1089     ((PropInfo^.SetProc <> nil) or
     1090     ((PropInfo^.PropType^.Kind = tkClass) and
     1091      (TObject(GetOrdProp(Instance, PropInfo)) is TComponent) and
     1092      (csSubComponent in TComponent(GetOrdProp(Instance, PropInfo)).ComponentStyle))) then
     1093  begin
     1094    LogMessage('Destroy property: '+Instance.ClassName+'.'+PropInfo.Name);
     1095    //if not IsDefaultPropertyValue(Instance, PropInfo, GetLookupInfo) then
     1096    begin
     1097      //AncestorValid := AncestorIsValid(Ancestor, Root, RootAncestor);
     1098      PropType := PropInfo^.PropType;
     1099      case PropType^.Kind of
     1100        tkClass:
     1101          WriteObjectProp;
     1102      end;
     1103    end;
     1104  end;
     1105end;
     1106
     1107procedure TDbObject.DestroyProperty(Instance: TDbObject; PropInfo: PPropInfo; Depth: Integer);
     1108var
     1109  PropType: PTypeInfo;
     1110
     1111  procedure WriteObjectProp;
     1112  var
     1113    Value: TObject;
     1114//    OldAncestor: TPersistent;
     1115//    SavePropPath, ComponentValue: string;
     1116    Setter: Longint;
     1117    TargetObject: ^TObject;
     1118  begin
     1119    Value := TObject(GetOrdProp(Instance, PropInfo));
     1120    if Value = nil then begin
     1121    end else begin
     1122      if Value is TDbObject then begin
     1123        TDbObject(Value).Destroy(Depth - 1);
     1124      end else if Value is TDbList then begin
     1125        TDbList(Value).Destroy(Depth - 1);
     1126      end;
     1127
     1128      // Set object reference to nil
     1129      Setter := Longint(PropInfo^.SetProc);
     1130      if (Setter and $FF000000) = $FF000000 then
     1131      begin  // field - Setter is the field's offset in the instance data
     1132        TargetObject := Pointer(Integer(Instance) + (Setter and $00FFFFFF));
     1133        TargetObject^ :=  nil;   // auto ref count
     1134      end;
     1135     end;
     1136  end;
     1137
     1138
     1139begin
     1140  // Using IsDefaultPropertyValue will tell us if we should write out
     1141  // a given property because it was different from the default or
     1142  // different from the Ancestor (if applicable).
     1143  if (PropInfo^.GetProc <> nil) and
     1144     ((PropInfo^.SetProc <> nil) or
     1145     ((PropInfo^.PropType^.Kind = tkClass) and
     1146      (TObject(GetOrdProp(Instance, PropInfo)) is TComponent) and
     1147      (csSubComponent in TComponent(GetOrdProp(Instance, PropInfo)).ComponentStyle))) then
     1148  begin
     1149    LogMessage('Destroy property: '+Instance.ClassName+'.'+PropInfo.Name);
     1150    //if not IsDefaultPropertyValue(Instance, PropInfo, GetLookupInfo) then
     1151    begin
     1152      //AncestorValid := AncestorIsValid(Ancestor, Root, RootAncestor);
     1153      PropType := PropInfo^.PropType;
     1154      case PropType^.Kind of
     1155        tkClass:
     1156          WriteObjectProp;
     1157      end;
     1158    end;
     1159  end;
     1160end;
     1161
     1162procedure TDbObject.Load(Depth: Integer);
     1163begin
     1164  LoadById(Id, Depth);
     1165end;
     1166
     1167procedure TDbObject.Delete;
     1168var
     1169  I, Count: Integer;
     1170  PropInfo: PPropInfo;
     1171  PropList: PPropList;
     1172//  Name: string;
     1173begin
     1174  LogMessage('Delete class: '+Self.ClassName);
     1175  if Self.ClassInfo = nil then raise Exception.Create('Class '+Self.ClassName+' doesn''t provide RTTI information!');
     1176  Count := GetTypeData(Self.ClassInfo)^.PropCount;
     1177  if Count > 0 then with FDatabase do begin
     1178    ProcessedClass := Self;
     1179    GetMem(PropList, Count * SizeOf(Pointer));
     1180    try
     1181      GetPropInfos(Self.ClassInfo, PropList);
     1182      for I := 0 to Count - 1 do
     1183      begin
     1184        PropInfo := PropList^[I];
     1185        if PropInfo = nil then
     1186          Break;
     1187        if IsStoredProp(Self, PropInfo) then
     1188          DeleteProperty(Self, PropInfo);
     1189      end;
     1190    finally
     1191      FreeMem(PropList, Count * SizeOf(Pointer));
     1192    end;
     1193  end;
     1194  Database.Delete(Self.ClassName, 'id=' + IntToStr(Id));
     1195  inherited Destroy;
    1581196end;
    1591197
    1601198end.
    161 
Note: See TracChangeset for help on using the changeset viewer.