Changeset 158


Ignore:
Timestamp:
Feb 18, 2009, 12:11:53 PM (16 years ago)
Author:
george
Message:
  • Upraveno: Přepracován databázový objektový subsystém.
Location:
devel/web
Files:
6 edited

Legend:

Unmodified
Added
Removed

  • devel/web/UBill.pas

    r142 r158  
    1717  { TBillItem }
    1818
    19   TBillItem = class(TDbObject)
     19  TBillItem = class
     20    Id: Integer;
    2021    Description: string;
    2122    Quantity: Integer;
    2223    Price: Double;
    23     procedure Load;  override;
    24     procedure Store; override;
    25   end;
    26 
    27   TBillItemList = class(TDbList)
     24    procedure Load;
     25    procedure Store;
     26  end;
     27
     28  TBillItemList = class
    2829  end;
    2930
    3031  { TBill }
    3132
    32   TBill = class(TDbObject)
     33  TBill = class
    3334  private
    3435    function CreateBill: Integer;
    3536  public
     37    Id: Integer;
    3638    Items: TBillItemList;
    3739    User: TUser;
    … …  
    4345    TimeDue: TDateTime;
    4446    function GenerateBill: string;
    45     procedure Load; override;
    46     procedure Store; override;
     47    procedure Load;
     48    procedure Store;
    4749  end;
    4850
    … …  
    5961  T: TUser;
    6062begin
     63 (*
    6164  T.FirstName:= 'ss';
    6265
    6366  DbRows := Database.Select('finance_bills', '*', 'id=' + IntToStr(Id));
    64   LoadFromDbRecord(DbRows[0]);
     67//  LoadFromDbRecord(DbRows[0]);
    6568  DbRows.Free;
    6669
    … …  
    7477    BillItem := TBillItem.Create;
    7578//    BillItem.LoadFromDbRecord(DbRows[I]);
    76     Items.Add(BillItem);
     79//    Items.Add(BillItem);
    7780  end;
    7881
    … …  
    132135    '<tr><td colspan="2"><hr></td></tr>' +
    133136    '</table>';
     137    *)
    134138end;
    135139
    136140procedure TBill.Load;
    137141begin
     142(*
    138143  Id := StrToInt(DbRow.Values['id']);
    139144  BillCode := DbRow.Values['BillCode'];
    … …  
    143148  TimeCreate := UnixToDateTime(StrToInt(DbRow.Values['time_create']));
    144149  UserId := StrToInt(DbRow.Values['user_id']);
     150*)
    145151end;
    146152
    … …  
    158164  Database.Update('finance_bills', Data, 'id=' + IntToStr(Id));
    159165  Data.Free;
    160   inherited Store;
    161166end;
    162167

  • 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 

  • devel/web/UFinancePage.pas

    r138 r158  
    44
    55interface
     6
     7uses
     8  UDatabase, UConfig;
     9
     10type
     11
     12  { TBaseObject }
     13
     14  TBaseObject = class(TDbObject)
     15  private
     16    FName: string;
     17  published
     18    property Name: string read FName write FName;
     19  end;
    620
    721function FinanceOverviewPage: string;
    … …  
    94108end;
    95109
     110function Test: string;
     111var
     112  Base: TBaseObject;
     113begin
     114  Result := ShowHeader('<strong>ZděchovNET</strong> - komunitní počítačová síť', 'Finance');
     115  Base := TBaseObject.Create(nil);
     116  Base.Database := TDatabase.Create;
     117  Base.Database.Hostname := DatabaseHostname;
     118  Base.Database.Database := 'centrala';
     119  Base.Database.UserName := DatabaseUserName;
     120  Base.Database.Password := DatabasePassword;
     121  Base.Database.Connect;
     122  //Base.Store;
     123
     124  Result := Result + ShowFooter;
     125end;
     126
     127{ TBaseObject }
     128
    96129begin
    97130  RegisterPage('finance', @FinanceOverviewPage);   
    98   RegisterPage('finance-clenove', @FinanceClientList);   
     131  RegisterPage('finance-clenove', @FinanceClientList);
     132  RegisterPage('test', @Test);
    99133end.

  • devel/web/UNews.pas

    r139 r158  
    1212  { TNewsCategory }
    1313
    14   TNewsCategory = class(TDbObject)
     14  TNewsCategory = class
     15    Id: Integer;
    1516    Title: string;
    1617    Permission: Integer;
    1718    procedure LoadFromDbRecord(DbRow: TAssocArray);
    18     procedure Store; override;
     19    procedure Store;
    1920  end;
    2021 
    2122  { TNewsItem }
    2223
    23   TNewsItem = class(TDbObject)
     24  TNewsItem = class
     25    Id: Integer;
    2426    Title: string;
    2527    Content: string;
    … …  
    2931    Category: Integer;
    3032    procedure LoadFromDbRecord(DbRow: TAssocArray);
    31     procedure Store; override;
     33    procedure Store;
    3234  end;
    3335

  • devel/web/UUser.pas

    r142 r158  
    1212  { TUser }
    1313
    14   TUser = class(TDbObject)
     14  TUser = class
     15    Id: Integer;
    1516    SubjectName: string;
    1617    FirstName: string;
    … …  
    2627    DIC: string;
    2728    procedure LoadFromDbRecord(DbRow: TAssocArray);
    28     procedure Store; override;
     29    procedure Store;
    2930  end;
    3031

  • devel/web/index.lpi

    r142 r158  
    1212      <MainUnit Value="0"/>
    1313      <TargetFileExt Value=".exe"/>
    14       <ActiveEditorIndexAtStart Value="3"/>
     14      <ActiveEditorIndexAtStart Value="5"/>
    1515    </General>
    1616    <VersionInfo>
    … …  
    2929      </local>
    3030    </RunParams>
    31     <Units Count="24">
     31    <Units Count="25">
    3232      <Unit0>
    3333        <Filename Value="index.pas"/>
    3434        <IsPartOfProject Value="True"/>
    3535        <UnitName Value="Index"/>
    36         <CursorPos X="44" Y="7"/>
    37         <TopLine Value="1"/>
    38         <EditorIndex Value="4"/>
    39         <UsageCount Value="90"/>
     36        <CursorPos X="64" Y="17"/>
     37        <TopLine Value="1"/>
     38        <EditorIndex Value="5"/>
     39        <UsageCount Value="95"/>
    4040        <Loaded Value="True"/>
    4141      </Unit0>
    … …  
    4646        <CursorPos X="80" Y="21"/>
    4747        <TopLine Value="1"/>
    48         <EditorIndex Value="6"/>
    49         <UsageCount Value="90"/>
    50         <Loaded Value="True"/>
     48        <UsageCount Value="95"/>
    5149      </Unit1>
    5250      <Unit2>
    … …  
    5755        <TopLine Value="197"/>
    5856        <EditorIndex Value="0"/>
    59         <UsageCount Value="90"/>
     57        <UsageCount Value="95"/>
    6058        <Loaded Value="True"/>
    6159      </Unit2>
    … …  
    6361        <Filename Value="UXmlClasses.pas"/>
    6462        <IsPartOfProject Value="True"/>
    65         <UsageCount Value="90"/>
     63        <UsageCount Value="95"/>
    6664      </Unit3>
    6765      <Unit4>
    … …  
    7169        <CursorPos X="10" Y="96"/>
    7270        <TopLine Value="76"/>
    73         <EditorIndex Value="9"/>
    74         <UsageCount Value="90"/>
     71        <EditorIndex Value="7"/>
     72        <UsageCount Value="95"/>
    7573        <Loaded Value="True"/>
    7674      </Unit4>
    … …  
    8179        <CursorPos X="1" Y="1"/>
    8280        <TopLine Value="81"/>
    83         <UsageCount Value="90"/>
     81        <UsageCount Value="95"/>
    8482      </Unit5>
    8583      <Unit6>
    … …  
    8785        <IsPartOfProject Value="True"/>
    8886        <UnitName Value="UFinancePage"/>
    89         <CursorPos X="31" Y="19"/>
    90         <TopLine Value="11"/>
    91         <EditorIndex Value="11"/>
    92         <UsageCount Value="90"/>
     87        <CursorPos X="42" Y="101"/>
     88        <TopLine Value="90"/>
     89        <EditorIndex Value="8"/>
     90        <UsageCount Value="95"/>
    9391        <Loaded Value="True"/>
    9492      </Unit6>
    … …  
    9997        <CursorPos X="34" Y="30"/>
    10098        <TopLine Value="17"/>
    101         <UsageCount Value="90"/>
     99        <UsageCount Value="95"/>
    102100      </Unit7>
    103101      <Unit8>
    … …  
    105103        <IsPartOfProject Value="True"/>
    106104        <UnitName Value="UNews"/>
    107         <CursorPos X="15" Y="49"/>
    108         <TopLine Value="34"/>
    109         <EditorIndex Value="10"/>
    110         <UsageCount Value="90"/>
    111         <Loaded Value="True"/>
     105        <CursorPos X="1" Y="16"/>
     106        <TopLine Value="12"/>
     107        <UsageCount Value="95"/>
    112108      </Unit8>
    113109      <Unit9>
    … …  
    117113        <CursorPos X="28" Y="149"/>
    118114        <TopLine Value="109"/>
    119         <EditorIndex Value="8"/>
    120         <UsageCount Value="90"/>
     115        <EditorIndex Value="6"/>
     116        <UsageCount Value="95"/>
    121117        <Loaded Value="True"/>
    122118      </Unit9>
    … …  
    143139        <Filename Value="../../../../other/powtils/main/pwmain.pas"/>
    144140        <UnitName Value="pwmain"/>
    145         <CursorPos X="24" Y="364"/>
    146         <TopLine Value="351"/>
     141        <CursorPos X="30" Y="2342"/>
     142        <TopLine Value="2320"/>
    147143        <UsageCount Value="19"/>
    148144      </Unit13>
    … …  
    153149        <CursorPos X="56" Y="16"/>
    154150        <TopLine Value="1"/>
    155         <EditorIndex Value="12"/>
    156         <UsageCount Value="78"/>
    157         <Loaded Value="True"/>
     151        <UsageCount Value="83"/>
    158152      </Unit14>
    159153      <Unit15>
    … …  
    173167        <IsPartOfProject Value="True"/>
    174168        <UnitName Value="UConfig"/>
    175         <CursorPos X="28" Y="14"/>
    176         <TopLine Value="1"/>
    177         <EditorIndex Value="5"/>
    178         <UsageCount Value="65"/>
     169        <CursorPos X="3" Y="14"/>
     170        <TopLine Value="1"/>
     171        <EditorIndex Value="9"/>
     172        <UsageCount Value="70"/>
    179173        <Loaded Value="True"/>
    180174      </Unit17>
    … …  
    184178        <CursorPos X="1" Y="134"/>
    185179        <TopLine Value="108"/>
    186         <UsageCount Value="65"/>
     180        <UsageCount Value="70"/>
    187181        <SyntaxHighlighter Value="None"/>
    188182      </Unit18>
    … …  
    192186        <CursorPos X="1" Y="1"/>
    193187        <TopLine Value="1"/>
    194         <UsageCount Value="65"/>
     188        <UsageCount Value="70"/>
    195189        <SyntaxHighlighter Value="JScript"/>
    196190      </Unit19>
    … …  
    199193        <IsPartOfProject Value="True"/>
    200194        <UnitName Value="UDatabase"/>
    201         <CursorPos X="26" Y="52"/>
    202         <TopLine Value="23"/>
     195        <CursorPos X="17" Y="1129"/>
     196        <TopLine Value="1107"/>
    203197        <EditorIndex Value="1"/>
    204         <UsageCount Value="59"/>
     198        <UsageCount Value="64"/>
    205199        <Loaded Value="True"/>
    206200      </Unit20>
    … …  
    209203        <IsPartOfProject Value="True"/>
    210204        <UnitName Value="UUser"/>
    211         <CursorPos X="41" Y="34"/>
    212         <TopLine Value="16"/>
    213         <EditorIndex Value="7"/>
    214         <UsageCount Value="59"/>
     205        <CursorPos X="31" Y="36"/>
     206        <TopLine Value="14"/>
     207        <EditorIndex Value="3"/>
     208        <UsageCount Value="64"/>
    215209        <Loaded Value="True"/>
    216210      </Unit21>
    … …  
    219213        <IsPartOfProject Value="True"/>
    220214        <UnitName Value="UUserPage"/>
    221         <CursorPos X="55" Y="23"/>
     215        <CursorPos X="69" Y="19"/>
    222216        <TopLine Value="1"/>
    223217        <EditorIndex Value="2"/>
    224         <UsageCount Value="55"/>
     218        <UsageCount Value="60"/>
    225219        <Loaded Value="True"/>
    226220      </Unit22>
    … …  
    229223        <IsPartOfProject Value="True"/>
    230224        <UnitName Value="UBill"/>
    231         <CursorPos X="25" Y="156"/>
    232         <TopLine Value="136"/>
    233         <EditorIndex Value="3"/>
    234         <UsageCount Value="52"/>
     225        <CursorPos X="26" Y="75"/>
     226        <TopLine Value="39"/>
     227        <EditorIndex Value="4"/>
     228        <UsageCount Value="57"/>
    235229        <Loaded Value="True"/>
    236230      </Unit23>
     231      <Unit24>
     232        <Filename Value="../../../../../../../usr/share/fpcsrc/packages/fv/src/dialogs.pas"/>
     233        <UnitName Value="Dialogs"/>
     234        <CursorPos X="19" Y="4"/>
     235        <TopLine Value="1"/>
     236        <UsageCount Value="10"/>
     237      </Unit24>
    237238    </Units>
    238     <JumpHistory Count="30" HistoryIndex="29">
     239    <JumpHistory Count="29" HistoryIndex="28">
    239240      <Position1>
    240         <Filename Value="UDatabase.pas"/>
    241         <Caret Line="28" Column="1" TopLine="1"/>
     241        <Filename Value="UBill.pas"/>
     242        <Caret Line="146" Column="51" TopLine="136"/>
    242243      </Position1>
    243244      <Position2>
    244         <Filename Value="UDatabase.pas"/>
    245         <Caret Line="63" Column="1" TopLine="27"/>
     245        <Filename Value="UBill.pas"/>
     246        <Caret Line="28" Column="24" TopLine="3"/>
    246247      </Position2>
    247248      <Position3>
    248         <Filename Value="UDatabase.pas"/>
    249         <Caret Line="97" Column="34" TopLine="79"/>
     249        <Filename Value="UBill.pas"/>
     250        <Caret Line="25" Column="21" TopLine="6"/>
    250251      </Position3>
    251252      <Position4>
    252         <Filename Value="UDatabase.pas"/>
    253         <Caret Line="32" Column="23" TopLine="14"/>
     253        <Filename Value="UBill.pas"/>
     254        <Caret Line="37" Column="17" TopLine="28"/>
    254255      </Position4>
    255256      <Position5>
    256         <Filename Value="UDatabase.pas"/>
    257         <Caret Line="12" Column="14" TopLine="1"/>
     257        <Filename Value="UBill.pas"/>
     258        <Caret Line="33" Column="16" TopLine="19"/>
    258259      </Position5>
    259260      <Position6>
    260         <Filename Value="UDatabase.pas"/>
    261         <Caret Line="98" Column="35" TopLine="80"/>
     261        <Filename Value="UBill.pas"/>
     262        <Caret Line="66" Column="3" TopLine="48"/>
    262263      </Position6>
    263264      <Position7>
    264         <Filename Value="UUser.pas"/>
    265         <Caret Line="16" Column="1" TopLine="1"/>
     265        <Filename Value="UBill.pas"/>
     266        <Caret Line="78" Column="3" TopLine="60"/>
    266267      </Position7>
    267268      <Position8>
    268269        <Filename Value="UBill.pas"/>
    269         <Caret Line="151" Column="57" TopLine="141"/>
     270        <Caret Line="137" Column="7" TopLine="105"/>
    270271      </Position8>
    271272      <Position9>
    272         <Filename Value="UDatabase.pas"/>
    273         <Caret Line="117" Column="25" TopLine="96"/>
     273        <Filename Value="UBill.pas"/>
     274        <Caret Line="151" Column="1" TopLine="124"/>
    274275      </Position9>
    275276      <Position10>
    276         <Filename Value="UDatabase.pas"/>
    277         <Caret Line="83" Column="5" TopLine="47"/>
     277        <Filename Value="UFinancePage.pas"/>
     278        <Caret Line="9" Column="50" TopLine="1"/>
    278279      </Position10>
    279280      <Position11>
    280         <Filename Value="UDatabase.pas"/>
    281         <Caret Line="138" Column="20" TopLine="108"/>
     281        <Filename Value="UFinancePage.pas"/>
     282        <Caret Line="8" Column="1" TopLine="1"/>
    282283      </Position11>
    283284      <Position12>
    284         <Filename Value="UDatabase.pas"/>
    285         <Caret Line="139" Column="18" TopLine="108"/>
     285        <Filename Value="UFinancePage.pas"/>
     286        <Caret Line="14" Column="3" TopLine="1"/>
    286287      </Position12>
    287288      <Position13>
    288         <Filename Value="UDatabase.pas"/>
    289         <Caret Line="49" Column="27" TopLine="36"/>
     289        <Filename Value="UFinancePage.pas"/>
     290        <Caret Line="16" Column="3" TopLine="14"/>
    290291      </Position13>
    291292      <Position14>
    292         <Filename Value="UDatabase.pas"/>
    293         <Caret Line="105" Column="8" TopLine="87"/>
     293        <Filename Value="UFinancePage.pas"/>
     294        <Caret Line="117" Column="10" TopLine="90"/>
    294295      </Position14>
    295296      <Position15>
    296         <Filename Value="UDatabase.pas"/>
    297         <Caret Line="48" Column="34" TopLine="35"/>
     297        <Filename Value="UFinancePage.pas"/>
     298        <Caret Line="123" Column="45" TopLine="91"/>
    298299      </Position15>
    299300      <Position16>
    300         <Filename Value="UDatabase.pas"/>
    301         <Caret Line="106" Column="24" TopLine="88"/>
     301        <Filename Value="UFinancePage.pas"/>
     302        <Caret Line="12" Column="1" TopLine="8"/>
    302303      </Position16>
    303304      <Position17>
    304         <Filename Value="UDatabase.pas"/>
    305         <Caret Line="137" Column="1" TopLine="105"/>
     305        <Filename Value="UFinancePage.pas"/>
     306        <Caret Line="116" Column="34" TopLine="96"/>
    306307      </Position17>
    307308      <Position18>
    308         <Filename Value="UDatabase.pas"/>
    309         <Caret Line="133" Column="17" TopLine="105"/>
     309        <Filename Value="UFinancePage.pas"/>
     310        <Caret Line="118" Column="45" TopLine="96"/>
    310311      </Position18>
    311312      <Position19>
    312         <Filename Value="UDatabase.pas"/>
    313         <Caret Line="48" Column="27" TopLine="30"/>
     313        <Filename Value="UFinancePage.pas"/>
     314        <Caret Line="8" Column="21" TopLine="1"/>
    314315      </Position19>
    315316      <Position20>
    316         <Filename Value="UBill.pas"/>
    317         <Caret Line="292" Column="26" TopLine="265"/>
     317        <Filename Value="UFinancePage.pas"/>
     318        <Caret Line="17" Column="17" TopLine="1"/>
    318319      </Position20>
    319320      <Position21>
    320         <Filename Value="UBill.pas"/>
    321         <Caret Line="304" Column="5" TopLine="268"/>
     321        <Filename Value="UFinancePage.pas"/>
     322        <Caret Line="122" Column="10" TopLine="95"/>
    322323      </Position21>
    323324      <Position22>
    324         <Filename Value="UBill.pas"/>
    325         <Caret Line="312" Column="44" TopLine="278"/>
     325        <Filename Value="UDatabase.pas"/>
     326        <Caret Line="1164" Column="10" TopLine="1129"/>
    326327      </Position22>
    327328      <Position23>
    328         <Filename Value="UBill.pas"/>
    329         <Caret Line="72" Column="3" TopLine="54"/>
     329        <Filename Value="index.pas"/>
     330        <Caret Line="14" Column="16" TopLine="1"/>
    330331      </Position23>
    331332      <Position24>
    332333        <Filename Value="UBill.pas"/>
    333         <Caret Line="310" Column="49" TopLine="282"/>
     334        <Caret Line="166" Column="1" TopLine="282"/>
    334335      </Position24>
    335336      <Position25>
    336         <Filename Value="UBill.pas"/>
    337         <Caret Line="313" Column="15" TopLine="281"/>
     337        <Filename Value="UUserPage.pas"/>
     338        <Caret Line="6" Column="31" TopLine="1"/>
    338339      </Position25>
    339340      <Position26>
    340         <Filename Value="USqlDatabase.pas"/>
    341         <Caret Line="369" Column="15" TopLine="337"/>
     341        <Filename Value="UUser.pas"/>
     342        <Caret Line="29" Column="21" TopLine="1"/>
    342343      </Position26>
    343344      <Position27>
    344345        <Filename Value="UDatabase.pas"/>
    345         <Caret Line="114" Column="5" TopLine="78"/>
     346        <Caret Line="442" Column="35" TopLine="434"/>
    346347      </Position27>
    347348      <Position28>
    348349        <Filename Value="UDatabase.pas"/>
    349         <Caret Line="124" Column="5" TopLine="88"/>
     350        <Caret Line="1132" Column="25" TopLine="1110"/>
    350351      </Position28>
    351352      <Position29>
    352         <Filename Value="UBill.pas"/>
    353         <Caret Line="133" Column="21" TopLine="97"/>
     353        <Filename Value="UDatabase.pas"/>
     354        <Caret Line="1131" Column="7" TopLine="1109"/>
    354355      </Position29>
    355       <Position30>
    356         <Filename Value="UDatabase.pas"/>
    357         <Caret Line="38" Column="17" TopLine="27"/>
    358       </Position30>
    359356    </JumpHistory>
    360357  </ProjectOptions>
    … …  
    374371    </Parsing>
    375372    <CodeGeneration>
    376       <SmartLinkUnit Value="True"/>
    377373      <Checks>
    378374        <IOChecks Value="True"/>
    … …  
    383379      <VerifyObjMethodCallValidity Value="True"/>
    384380    </CodeGeneration>
    385     <Linking>
    386       <LinkSmart Value="True"/>
    387     </Linking>
    388381    <Other>
     382      <Verbosity>
     383        <ShoLineNum Value="True"/>
     384      </Verbosity>
    389385      <CompilerPath Value="$(CompPath)"/>
    390386    </Other>
Note: See TracChangeset for help on using the changeset viewer.