source: trunk/UDatabase.pas

unit UDatabase;

interface

uses
  Classes, SysUtils, ExtCtrls, Dialogs, USqlDatabase, URegistry, UGenerics,
  Generics.Collections;

type
  TTable = class;
  TDbClientType = class;
  TDbClient = class;
  TDataType = class;
  TDbManager = class;

  TFieldType = (ftString, ftInteger, ftDateTime, ftBoolean, ftFloat, ftImage,
    ftDate, ftTime, ftMapPosition, ftReference);

  { TValue }

  TValue = class
    procedure Assign(Source: TValue); virtual;
    function GetString: string; virtual;
    procedure SetString(Value: string); virtual;
    function GetStringSQL: string; virtual;
    procedure SetStringSQL(Value: string); virtual;
  end;

  TValueClass = class of TValue;

  { TValues }

  TValues = class(TObjectList<TValue>)
    procedure Assign(Source: TValues);
  end;

  { TFieldTypeSpecific }

  TFieldTypeSpecific = class
    procedure Assign(Source: TFieldTypeSpecific); virtual;
    function GetValueClass: TValueClass; virtual;
  end;

  TFieldTypeSpecificClass = class of TFieldTypeSpecific;

  { TField }

  TField = class
  private
    FDataType: TDataType;
    procedure SetDataType(AValue: TDataType);
  public
    Name: string;
    TypeRelated: TFieldTypeSpecific;
    Required: Boolean;
    ReadOnly: Boolean;
    TextBefore: string;
    TextAfter: string;
    Description: string;
    AllowNull: string;
    Pos: TPoint;
    Size: TPoint;
    Table: TTable;
    procedure Assign(Source: TField);
    function GetValueClass: TValueClass;
    property DataType: TDataType read FDataType write SetDataType;
    constructor Create;
    destructor Destroy; override;
  end;

  { TFields }

  TFields = class(TObjectList<TField>)
    Table: TTable;
    function SearchByName(Name: string): TField;
    procedure Assign(Source: TFields);
    function AddNew(Name: string; DataType: TDataType): TField;
    procedure Load;
  end;

  { TRecord }

  TRecord = class
    Table: TTable;
    Values: TValues;
    function Match(AValues: TStrings): Boolean;
    procedure InitValues;
    procedure Assign(Source: TRecord);
    constructor Create;
    destructor Destroy; override;
  end;

  { TRecords }

  TRecords = class(TObjectList<TRecord>)
    Table: TTable;
    procedure Assign(Source: TRecords);
    function SearchByValue(Name, Value: string): TRecord;
    function SearchByValues(Values: TStrings): TRecord;
    function AddNew: TRecord;
    procedure Load;
  end;

  { TTable }

  TTable = class
    Id: Integer;
    Name: string;
    Caption: string;
    Records: TRecords;
    Fields: TFields;
    DbClient: TDbClient;
    RecordsCount: Integer;
    procedure LoadRecordsCount;
    procedure Assign(Source: TTable);
    constructor Create;
    destructor Destroy; override;
  end;

  { TTables }

  TTables = class(TObjectList<TTable>)
    DbClient: TDbClient;
    function SearchByName(Name: string): TTable;
    function AddNew(Name: string): TTable;
  end;

  { TDbConnectParams }

  TDbConnectParams = class
  protected
    FConnectionString: string;
    function GetConnectionString: string; virtual;
    procedure SetConnectionString(AValue: string); virtual;
  public
    property ConnectionString: string read GetConnectionString
      write SetConnectionString;
  end;

  TDbConnectParamsClass = class of TDbConnectParams;

  { TDbConnectProfile }

  TDbConnectProfile = class
  private
    FClientType: TDbClientType;
    procedure SetClientType(AValue: TDbClientType);
  public
    Name: string;
    Params: TDbConnectParams;
    DbManager: TDbManager;
    destructor Destroy; override;
    function GetClient: TDbClient;
    property ClientType: TDbClientType read FClientType write SetClientType;
  end;

  { TDbConnectProfiles }

  TDbConnectProfiles = class(TObjectList<TDbConnectProfile>)
    DbManager: TDbManager;
    procedure LoadFromRegistry(Context: TRegistryContext);
    procedure SaveToRegistry(Context: TRegistryContext);
    function SearchByName(Name: string): TDbConnectProfile;
  end;

  { TDataType }

  TDataType = class
    Id: Integer;
    Name: string;
    Title: string;
    FieldType: TFieldType;
    FieldTypeClass: TFieldTypeSpecificClass;
  end;

  { TDataTypes }

  TDataTypes = class(TObjectList<TDataType>)
    function RegisterType(Id: Integer; Name, Title: string;
      FieldType: TFieldType; FieldTypeClass: TFieldTypeSpecificClass): TDataType;
    function SearchByType(FieldType: TFieldType): TDataType;
    function SearchByName(Name: string): TDataType;
  end;

  TDbRows = USqlDatabase.TDbRows;

  { TDbClient }

  TDbClient = class
  private
    function GetClientType: TDbClientType;
  protected
    FConnectProfile: TDbConnectProfile;
    procedure SetConnectProfile(AValue: TDbConnectProfile); virtual;
  public
    DbManager: TDbManager;
    procedure Query(Text: string; DbRows: TDbRows = nil); virtual;
    constructor Create; virtual;
    procedure Load; virtual;
    procedure Save; virtual;
    property ClientType: TDbClientType read GetClientType;
    property ConnectProfile: TDbConnectProfile read FConnectProfile
      write SetConnectProfile;
  end;

  TDbClientClass = class of TDbClient;

  TFieldTypeSet = set of TFieldType;

  { TDbClientType }

  TDbClientType = class
    Name: string;
    DataTypes: TDataTypes;
    DatabaseClientClass: TDbClientClass;
    ConnectParmasClass: TDbConnectParamsClass;
    procedure UseTypes(ADataTypes: TDataTypes; Types: TFieldTypeSet);
    constructor Create;
    destructor Destroy; override;
  end;

  { TDbClientTypes }

  TDbClientTypes = class(TObjectList<TDbClientType>)
    function RegisterClientType(Name: string; DatabaseClass: TDbClientClass;
      ConnectParamsClass: TDbConnectParamsClass): TDbClientType;
    function FindByName(Name: string): TDbClientType;
  end;

  TPreferences = class
    RememberDatabase: Boolean;
    LastDatabaseName: string;
  end;

  { TDbManager }

  TDbManager = class
  private
    procedure InitClientTypes;
    procedure InitDataTypes;
  public
    ConnectProfiles: TDbConnectProfiles;
    ClientTypes: TDbClientTypes;
    DataTypes: TDataTypes;
    constructor Create;
    destructor Destroy; override;
  end;

resourcestring
  STypeString = 'String';
  STypeInteger = 'Integer';
  STypeFloat = 'Float';
  STypeBoolean = 'Boolean';
  STypeMapPosition = 'Map position';
  STypeImage = 'Image';
  STypeDate = 'Date';
  STypeTime = 'Time';
  STypeDateTime = 'Date and time';
  STypeReference = 'Reference';
  SFieldNotFound = 'Field %s not found';


implementation

uses
  UDataTypes, UEngineXML, UEngineMySQL, UEngineSQLite, UDbClientRegistry;

{ TDbManager }

procedure TDbManager.InitClientTypes;
var
  ClientType: TDbClientType;
begin
  ClientTypes.Clear;

  ClientType := ClientTypes.RegisterClientType('XML file', TDatabaseXML, TDbConnectParamsXml);
  ClientType.UseTypes(DataTypes, [ftString, ftInteger, ftDateTime, ftBoolean, ftFloat]);

  ClientType := ClientTypes.RegisterClientType('MySQL', TDatabaseMySQL, TDbConnectParamsMySql);
  ClientType.UseTypes(DataTypes, [ftString, ftInteger, ftDateTime, ftBoolean, ftFloat,
    ftReference]);

  ClientType := ClientTypes.RegisterClientType('SQLite', TDatabaseSQLite, TDbConnectParamsSqlite);
  ClientType.UseTypes(DataTypes, [ftString, ftInteger, ftDateTime, ftBoolean, ftFloat]);

  ClientType := ClientTypes.RegisterClientType('Registry', TDbClientRegistry, TDbConnectParamsRegistry);
  ClientType.UseTypes(DataTypes, [ftString, ftInteger]);
end;

procedure TDbManager.InitDataTypes;
begin
  DataTypes.Clear;
  with DataTypes do begin
    RegisterType(1, 'String', STypeString, ftString, TFieldString);
    RegisterType(2, 'Integer', STypeInteger, ftInteger, TFieldInteger);
    RegisterType(3, 'DateTime', STypeDateTime, ftDateTime, TFieldDateTime);
    RegisterType(4, 'Boolean', STypeBoolean, ftBoolean, TFieldBoolean);
    RegisterType(5, 'Float', STypeFloat, ftFloat, TFieldFloat);
    RegisterType(6, 'MapPosition', STypeMapPosition, ftMapPosition, TFieldMapPosition);
    RegisterType(7, 'Date', STypeDate, ftDate, TFieldDate);
    RegisterType(8, 'Time', STypeTime, ftTime, TFieldTime);
    RegisterType(9, 'Image', STypeImage, ftImage, TFieldImage);
    RegisterType(10, 'Reference', STypeReference, ftReference, TFieldReference);
  end;
end;

constructor TDbManager.Create;
begin
  ConnectProfiles := TDbConnectProfiles.Create;
  ConnectProfiles.DbManager := Self;
  ClientTypes := TDbClientTypes.Create;
  DataTypes := TDataTypes.Create;
  InitDataTypes;
  InitClientTypes;
end;

destructor TDbManager.Destroy;
begin
  FreeAndNil(DataTypes);
  FreeAndNil(ClientTypes);
  FreeAndNil(ConnectProfiles);
  inherited;
end;

{ TDbConnectParams }

procedure TDbConnectParams.SetConnectionString(AValue: string);
begin
  if FConnectionString = AValue then Exit;
  FConnectionString := AValue;
end;

function TDbConnectParams.GetConnectionString: string;
begin
  Result := FConnectionString;
end;

{ TDbConnectProfiles }

procedure TDbConnectProfiles.LoadFromRegistry(Context: TRegistryContext);
var
  I: Integer;
  ConnectProfile: TDbConnectProfile;
  ClientType: TDbClientType;
begin
  with TRegistryEx.Create do
  try
    CurrentContext := Context;
    Count := GetValue('Count', 0);
    for I := 0 to Count - 1 do begin
      OpenKey(Context.Key + '\Item' + IntToStr(I), True);
      ClientType := DbManager.ClientTypes.FindByName(GetValue('ClientType', ''));
      if not Assigned(ClientType) and (DbManager.ClientTypes.Count > 0) then
        ClientType := TDbClientType(DbManager.ClientTypes[0]);

      ConnectProfile := TDbConnectProfile.Create;
      ConnectProfile.DbManager := DbManager;
      ConnectProfile.ClientType := ClientType;
      ConnectProfile.Name := GetValue('Name', '');
      ConnectProfile.Params.ConnectionString := GetValue('ConnectionString', '');
      Items[I] := ConnectProfile;
    end;
  finally
    Free;
  end;
end;

procedure TDbConnectProfiles.SaveToRegistry(Context: TRegistryContext);
var
  I: Integer;
begin
  with TRegistryEx.Create do
  try
    CurrentContext := Context;
    SetValue('Count', Count);
    for I := 0 to Count - 1 do begin
      OpenKey(Context.Key + '\Item' + IntToStr(I), True);
      SetValue('Name', Items[I].Name);
      SetValue('ConnectionString', Items[I].Params.ConnectionString);
      SetValue('ClientType', Items[I].ClientType.Name);
    end;
  finally
    Free;
  end;
end;

function TDbConnectProfiles.SearchByName(Name: string): TDbConnectProfile;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (Items[I].Name <> Name) do Inc(I);
  if (I < Count) then Result := Items[I]
    else Result := nil;
end;

{ TDbConnectProfile }

procedure TDbConnectProfile.SetClientType(AValue: TDbClientType);
begin
  if FClientType = AValue then Exit;
  if Assigned(FClientType) then begin
    FreeAndNil(Params);
  end;
  FClientType := AValue;
  if Assigned(FClientType) then begin
    Params := FClientType.ConnectParmasClass.Create;
  end;
end;

destructor TDbConnectProfile.Destroy;
begin
  ClientType := nil;
  if Assigned(Params) then Params.Free;
  inherited;
end;

function TDbConnectProfile.GetClient: TDbClient;
begin
  Result := ClientType.DatabaseClientClass.Create;
  Result.ConnectProfile := Self;
  Result.DbManager := DbManager;
end;

{ TTables }

function TTables.SearchByName(Name: string): TTable;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (Items[I].Name <> Name) do Inc(I);
  if I < Count then Result := Items[I]
    else Result := nil;
end;

function TTables.AddNew(Name: string): TTable;
begin
  Result := TTable.Create;
  Result.DbClient := DbClient;
  Result.Name := Name;
  Add(Result);
end;

{ TDbClient }

function TDbClient.GetClientType: TDbClientType;
begin
  Result := FConnectProfile.ClientType;
end;

procedure TDbClient.SetConnectProfile(AValue: TDbConnectProfile);
begin
  if FConnectProfile = AValue then Exit;
  FConnectProfile := AValue;
end;

procedure TDbClient.Query(Text: string; DbRows: TDbRows = nil);
begin
end;

constructor TDbClient.Create;
begin
  inherited;
end;

procedure TDbClient.Load;
begin
end;

procedure TDbClient.Save;
begin
end;

{ TDbClientTypes }

function TDbClientTypes.RegisterClientType(Name: string;
  DatabaseClass: TDbClientClass; ConnectParamsClass: TDbConnectParamsClass): TDbClientType;
begin
  Result := TDbClientType.Create;
  Result.Name := Name;
  Result.DatabaseClientClass := DatabaseClass;
  Result.ConnectParmasClass := ConnectParamsClass;
  Add(Result);
end;

function TDbClientTypes.FindByName(Name: string): TDbClientType;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (Items[I].Name <> Name) do Inc(I);
  if I < Count then Result := Items[I]
    else Result := nil;
end;

{ TDataTypes }

function TDataTypes.RegisterType(Id: Integer; Name, Title: string;
  FieldType: TFieldType; FieldTypeClass: TFieldTypeSpecificClass): TDataType;
begin
  Result := TDataType.Create;
  Result.Id := Id;
  Result.Name := Name;
  Result.Title := Title;
  Result.FieldType := FieldType;
  Result.FieldTypeClass := FieldTypeClass;
  Add(Result);
end;

function TDataTypes.SearchByType(FieldType: TFieldType): TDataType;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (Items[I].FieldType <> FieldType) do Inc(I);
  if I < Count then Result := Items[I]
    else Result := nil;
end;

function TDataTypes.SearchByName(Name: string): TDataType;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (Items[I].Name <> Name) do Inc(I);
  if I < Count then Result := Items[I]
    else Result := nil;
end;

{ TDbClientType }

procedure TDbClientType.UseTypes(ADataTypes: TDataTypes; Types: TFieldTypeSet);
var
  I: TFieldType;
begin
  DataTypes.Clear;
  for I := Low(TFieldType) to High(TFieldType) do
    if I in Types then DataTypes.Add(ADataTypes.SearchByType(I));
end;

constructor TDbClientType.Create;
begin
  DataTypes := TDataTypes.Create;
  DataTypes.OwnsObjects := False;
end;

destructor TDbClientType.Destroy;
begin
  FreeAndNil(DataTypes);
  inherited;
end;

{ TValues }

procedure TValues.Assign(Source: TValues);
var
  I: Integer;
  OldCount: Integer;
begin
  OldCount := Count;
  Count := Source.Count;
  for I := OldCount to Count - 1 do
    Items[I] := TValueClass(Source.Items[I].ClassType).Create;
  for I := 0 to Count - 1 do
    if TValue(Items[I]).ClassType <> Source.Items[I].ClassType then begin
      Items[I] := TValueClass(Source.Items[I].ClassType).Create;
    end;
  for I := 0 to Source.Count - 1 do begin
    Items[I].Assign(Source.Items[I]);
  end;
end;

{ TRecords }

procedure TRecords.Assign(Source: TRecords);
var
  I: Integer;
  OldCount: Integer;
begin
  OldCount := Count;
  Count := Source.Count;
  for I := OldCount to Count - 1 do
    Items[I] := TRecord.Create;
  for I := 0 to Source.Count - 1 do begin
    Items[I].Assign(Source.Items[I]);
  end;
end;

function TRecords.SearchByValue(Name, Value: string): TRecord;
var
  I: Integer;
  FieldIndex: Integer;
  Field: TField;
begin
  Result := nil;
  Field := Table.Fields.SearchByName(Name);
  if Assigned(Field) then begin
    FieldIndex := Table.Fields.IndexOf(Field);
    I := 0;
    while (I < Count) and (Items[I].Values[FieldIndex].GetString <> Value) do Inc(I);
    if I < Count then Result := Items[I]
      else Result := nil;
  end;
end;

function TRecords.SearchByValues(Values: TStrings): TRecord;
var
  I: Integer;
begin
  Result := nil;
  I := 0;
  while (I < Count) and (Items[I].Match(Values)) do Inc(I);
  if I < Count then Result := Items[I]
    else Result := nil;
end;

function TRecords.AddNew: TRecord;
begin
  Result := TRecord.Create;
  Result.Table := Table;
  Result.InitValues;
  Add(Result);
end;

procedure TRecords.Load;
var
  DbRows: TDbRows;
  I: Integer;
  F: Integer;
  NewRecord: TRecord;
  NewValue: TValue;
  Value: string;
begin
  Clear;
  DbRows := TDbRows.Create;
  try
    Table.DbClient.Query('SELECT * FROM ' + Table.Name, DbRows);
    for I := 0 to DbRows.Count - 1 do begin
      NewRecord := TRecord.Create;
      for F := 0 to Table.Fields.Count - 1 do begin
        NewValue := Table.Fields[F].GetValueClass.Create;
        if DbRows[I].TryGetValue(Table.Fields[F].Name, Value) then begin
          NewValue.SetString(Value);
          NewRecord.Values.Add(NewValue);
        end else begin
          //NewValue.SetString('');
          NewRecord.Values.Add(NewValue);
        end;
      end;
      Add(NewRecord);
    end;
  finally
    DbRows.Free;
  end;
end;

{ TFields }

function TFields.SearchByName(Name: string): TField;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (Items[I].Name <> Name) do Inc(I);
  if I < Count then Result := Items[I]
    else Result := nil;
end;

procedure TFields.Assign(Source: TFields);
var
  I: Integer;
  OldCount: Integer;
begin
  OldCount := Count;
  Count := Source.Count;
  for I := OldCount to Count - 1 do
    Items[I] := TField.Create;
  for I := 0 to Source.Count - 1 do begin
    Items[I].Assign(Source.Items[I]);
  end;
end;

function TFields.AddNew(Name: string; DataType: TDataType): TField;
begin
  Result := TField.Create;
  Result.Table := Table;
  Result.Name := Name;
  Result.DataType := DataType;
  Add(Result);
end;

procedure TFields.Load;
var
  DbRows: TDbRows;
  NewField: TField;
  I: Integer;
begin
  Clear;
  DbRows := TDbRows.Create;
  try
    Table.DbClient.Query('SELECT * FROM ModelField WHERE Model = ' + Table.Name, DbRows);
    for I := 0 to DbRows.Count - 1 do begin
      NewField := AddNew(DbRows[I].Items['Name'],
        Table.DbClient.DbManager.DataTypes.SearchByName(DbRows[I].Items['DataType']));
      NewField.TextBefore := DbRows[I].Items['Caption'];
    end;
  finally
    DbRows.Free;
  end;
end;

{ TRecord }

function TRecord.Match(AValues: TStrings): Boolean;
var
  I: Integer;
  Field: TField;
  FieldIndex: Integer;
begin
  Result := True;
  for I := 0 to aValues.Count - 1 do begin
    Field := Table.Fields.SearchByName(AValues.Names[I]);
    FieldIndex := Table.Fields.IndexOf(Field);
    if Assigned(Field) then begin
      if Values[FieldIndex].GetString <> AValues.ValueFromIndex[I] then begin
        Result := False;
        Break;
      end;
    end else raise Exception.Create(Format(SFieldNotFound, [AValues.Names[I]]));
  end;
end;

procedure TRecord.InitValues;
var
  I: Integer;
begin
  Values.Clear;
  for I := 0 to Table.Fields.Count - 1 do
    Values.Add(Table.Fields[I].GetValueClass.Create);
end;

procedure TRecord.Assign(Source: TRecord);
begin
  Values.Assign(Source.Values);
end;

constructor TRecord.Create;
begin
  Values := TValues.Create;
end;

destructor TRecord.Destroy;
begin
  FreeAndNil(Values);
  inherited;
end;

{ TValue }

procedure TValue.Assign(Source: TValue);
begin
end;

function TValue.GetString: string;
begin
  Result := '';
end;

procedure TValue.SetString(Value: string);
begin
end;

function TValue.GetStringSQL: string;
begin
  Result := '';
end;

procedure TValue.SetStringSQL(Value: string);
begin
end;

{ TFieldTypeSpecific }

procedure TFieldTypeSpecific.Assign(Source: TFieldTypeSpecific);
begin
end;

function TFieldTypeSpecific.GetValueClass: TValueClass;
begin
  Result := TValue;
end;

{ TField }

procedure TField.SetDataType(AValue: TDataType);
begin
  if FDataType = AValue then Exit;
  if Assigned(TypeRelated) then TypeRelated.Free;
  FDataType := AValue;
  if Assigned(AValue) then
    TypeRelated := AValue.FieldTypeClass.Create
    else TypeRelated := nil;
end;

procedure TField.Assign(Source: TField);
begin
  Name := Source.Name;
  DataType := Source.DataType;
  TextAfter := Source.TextAfter;
  TextBefore := Source.TextBefore;
  Required := Source.Required;
  ReadOnly := Source.ReadOnly;
  Description := Source.Description;
  AllowNull := Source.AllowNull;
  TypeRelated.Assign(Source.TypeRelated);
end;

function TField.GetValueClass: TValueClass;
begin
  if Assigned(TypeRelated) then Result := TypeRelated.GetValueClass
    else Result := TValue;
end;

constructor TField.Create;
begin
  TypeRelated := TFieldString.Create;
end;

destructor TField.Destroy;
begin
  DataType := nil;
  inherited;
end;

procedure TTable.LoadRecordsCount;
var
  DbRows: TDbRows;
begin
  Records.Clear;
  DbRows := TDbRows.Create;
  try
    DbClient.Query('SELECT COUNT(*) FROM ' + Name, DbRows);
    if DbRows.Count = 1 then begin
      RecordsCount := StrToInt(DbRows[0].Items['COUNT(*)']);
    end else RecordsCount := 0;
  finally
    DbRows.Free;
  end;
end;

procedure TTable.Assign(Source: TTable);
begin
  Name := Source.Name;
  Caption := Source.Caption;
  Fields.Assign(Source.Fields);
  Records.Assign(Source.Records);
end;

constructor TTable.Create;
begin
  Records := TRecords.Create;
  Records.Table := Self;
  Fields := TFields.Create;
  Fields.Table := Self;
end;

destructor TTable.Destroy;
begin
  FreeAndNil(Fields);
  FreeAndNil(Records);
  inherited;
end;

end.