Absolute Database support

BIZ TMS Aurelius
1

Following two units implement ComponentAce "Absolute Database" support in Aurelius 1.4.
WARNING: They have been tested in many situations (Aurelius MusicLibrary sample, blob experimentations etc.) but not inside a complete test suite.

<code>
unit Aurelius.Sql.AbsoluteDatabase;

{$I Aurelius.inc}

{
Version 1.0
Date: 29/05/2012
Author: Gwihen Etienne  (gwihen.etienne@wanadoo.fr)
Tested within:
  Aurelius 1.4
  ComponentAce "Absolute Database" version 6.20
  Delphi XE2 Enterprise
}

interface

uses
  DB,
  Aurelius.Sql.AnsiSqlGenerator,
  Aurelius.Sql.BaseTypes,
  Aurelius.Sql.Commands,
  Aurelius.Sql.Interfaces,
  Aurelius.Sql.Register,
  Aurelius.Global.Utils,
  Variants,
  SysUtils,
  Generics.Collections;

type
  TABSSQLGenerator = class(TAnsiSQLGenerator)
  protected
    function GetMaxConstraintNameLength: Integer; override;
    function FieldTypeToSQL(FieldDef: TSQLFieldDefinition): string; override;
    function GetGeneratorName: string; override;
    function GetSqlDialect: string; override;
    function GenerateCreateTable(Command: TCreateTableCommand): string; override;
    function GenerateGetLastInsertId(SQLField: TSQLField): string; override;
    function GenerateLimitedSelect(SelectSql: TSelectSql; Command: TSelectCommand): string;
      override;
    // Disable/Enable foreign keys (even if Absolute Database has no foreign keys!)
    function GenerateEnableForeignKeys(Command: TEnableForeignKeysCommand): string; override;
    function GeneratePrimaryKey(APkName: string; AFields: TList<string>): string; override;
    function GetSupportedFeatures: TDBFeatures; override;
  private
  end;

implementation

const
  NULL_SQL_COMMAND = 'DROP TABLE IF EXISTS MEMORY "";'; // a placeholder NULL command (see explanations below)

{ TABSSQLGenerator }

function TABSSQLGenerator.FieldTypeToSQL(FieldDef: TSQLFieldDefinition): string;
var
  sAbsType: string;
begin
  (* See "Absolute Database" unit Source\ABSConverts.pas )
  case FieldDef.FieldType of
    ftBCD:
      sAbsType := 'FLOAT';
    ftBlob, ftDBaseOle, ftParadoxOle, ftTypedBinary:
      sAbsType := 'BLOB';
    ftBoolean:
      sAbsType := 'BOOLEAN';
    ftBytes:
      sAbsType := 'BYTES';
    ftCurrency:
      sAbsType := 'CURRENCY';
    ftDate:
      sAbsType := 'DATE';
    ftDateTime:
      sAbsType := 'DATETIME';
    ftFixedChar:
      sAbsType := 'FIXEDCHAR';
    ftFloat:
      sAbsType := 'DOUBLE';
    ftFmtMemo:
      sAbsType := 'FORMATTEDMEMO';
    ftGraphic:
      sAbsType := 'GRAPHIC';
    ftGuid:
      sAbsType := 'GUID';
    ftInteger:
      sAbsType := 'INTEGER';
    ftLargeint:
      sAbsType := 'LARGEINT';
    ftMemo:
      sAbsType := 'MEMO';
    ftSmallint:
      sAbsType := 'SHORTINT';
    ftString:
      sAbsType := Format('VARCHAR(%d)', [FieldDef.Length]);
    ftTime:
      sAbsType := 'TIME';
    ftTimeStamp:
      sAbsType := 'TIMESTAMP';
    ftVarBytes:
      sAbsType := 'VARBYTES';
    ftWideMemo:
      sAbsType := 'WIDEMEMO';
    ftWideString:
      sAbsType := Format('WIDESTRING(%d)', [FieldDef.Length]);
    ftWord:
      sAbsType := 'WORD';
  else
    sAbsType := inherited FieldTypeToSQL(FieldDef);
  end;

  if FieldDef.AutoGenerated then
    Result := Result + ' AUTOINC(' + sAbsType + ')'
  else
    Result := sAbsType;
end;

function TABSSQLGenerator.GenerateCreateTable(Command: TCreateTableCommand): string;
var
  I: Integer;
  PkName: string;
begin
  Result := 'CREATE TABLE ';

  Result := Result + Command.Table.name + ' ('#13#10'  ';

  for I := 0 to Command.Fields.Count - 1 do
  begin
    if I > 0 then
      Result := Result + ','#13#10'  ';
    Result := Result + GenerateFieldDefinition(Command.Fields);
  end;

  // Primary Key (Aurelius generated tables always have primary keys)
  if Command.IdFields.Count > 0 then
  begin
    PkName := 'PK_';
    PkName := PkName + Command.Table.Name;
    PkName := Copy(PkName, 1, GetMaxConstraintNameLength);
    Result := Result + ','#13#10 + '  ' + GeneratePrimaryKey(PkName, Command.IdFields);
  end;

  Result := Result + ');';
end;

function TABSSQLGenerator.GenerateEnableForeignKeys(Command: TEnableForeignKeysCommand): string;
(
  Absolute Database has no foreign keys.
  Before dropping a table, Aurelius offers the following strategies:
  - create an 'ALTER TABLE ... DROP CONSTRAINT ...' SQL command, to drop foreign keys;
  - disable foreign keys before dropping tables then enable foreign keys again (as in Aurelius.SQL.SQLite).
  We have chosen the second solution so we need a placeholder.
  As there is no 'NULL' SQL command in Absolute Database, we use a SQL command with no effect.
)
begin
  Result := NULL_SQL_COMMAND
end;

function TABSSQLGenerator.GenerateGetLastInsertId(SQLField: TSQLField): string;
begin
  Result := 'SELECT LastAutoinc(' + SQLField.Table.Name + ', ' + SQLField.Field + ') FROM ' + SQLField.Table.Name;
end;

function TABSSQLGenerator.GenerateLimitedSelect(SelectSql: TSelectSql;
  Command: TSelectCommand): string;
begin
  ( "Absolute Database" select command:
    SELECT
    [ ALL | DISTINCT ]
    [ TOP row_count [, offset ] ]
    * | column_reference | select_expr [ [ AS ] column_alias ] [, ...]
    [ INTO output_table ]
    FROM from_item [, ...]
    [ WHERE condition ]
    [ GROUP BY { column_name | expression } [, ...] ]
    [ HAVING condition ]
    [ { UNION | INTERSECT | EXCEPT } [ ALL ] [ CORRESPONDING  [ BY (column_list) ] ] SELECT ... ]
    [ ORDER BY { unsigned_integer | column_name } [ ASC | DESC ] [, ...] ]
  )
  Result := GenerateRegularSelect(SelectSql) + #13#10;
  if Command.HasMaxRows then
  begin
    if Command.HasFirstRow then
      Result := Result + Format('TOP %d, %d', [Command.MaxRows, Command.FirstRow + 1])
    else
      Result := Result + Format('TOP %d', [Command.MaxRows]);
  end
  else if Command.HasFirstRow then
    Result := Result + Format('TOP 3000000000, %d', [Command.FirstRow + 1]);
end;

function TABSSQLGenerator.GeneratePrimaryKey(APkName: string; AFields: TList<string>): string;
begin
  Result := 'PRIMARY KEY ' + APkName + '(';
  Result := Result + TUtils.ConcatStrings(AFields, ', ');
  Result := Result + ')';
end;

function TABSSQLGenerator.GetGeneratorName: string;
begin
  Result := 'AbsoluteDatabase SQL Generator';
end;

function TABSSQLGenerator.GetMaxConstraintNameLength: Integer;
begin
  Result := 255; // Identifier max length (in characters)
end;

function TABSSQLGenerator.GetSqlDialect: string;
begin
  Result := 'AbsoluteDatabase';
end;

function TABSSQLGenerator.GetSupportedFeatures: TDBFeatures;
begin
  Result := AllDBFeatures - [TDBFeature.Sequences, TDBFeature.AlterTableForeignKey];
end;

initialization

TSQLGeneratorRegister.GetInstance.RegisterGenerator(TABSSQLGenerator.Create);

end.

</code>

**************************************************************************************************************

<code>
unit Aurelius.Drivers.AbsoluteDatabase;

{
Version 1.0
Date: 29/05/2012
Author: G. Etienne (gwihen.etienne@wanadoo.fr)
Tested within:
  Aurelius 1.4
  ComponentAce "Absolute Database" version 6.20
  Delphi XE2 Enterprise
}

interface

uses
  Classes, SysUtils, Data.DB, Variants, Generics.Collections,
  ABSMain,
  Aurelius.Drivers.Base,
  Aurelius.Drivers.Interfaces,
  Aurelius.Global.Utils;

type
  TABSResultSetAdapter = class(TDriverResultSetAdapter<TABSQuery>)
  public
    property Dataset;
    (
      Making "Dataset" member public is not mandatory
      but can be useful to open a dataset from Aurelius framework:
      var
        stmt: TABSStatementAdapter;
        rs: TABSResultSetAdapter;
        ds: TDataset;
        sSQL: string;
      begin
        // GetDBConnection returns a TABSConnectionAdapter instance
        stmt := TABSStatementAdapter(GetDBConnection.CreateStatement);
        sSQL := 'SELECT AGENT., MESSAGE. FROM AGENT LEFT JOIN MESSAGE ON AGENT.ID = MESSAGE.AGENT_ID ORDER BY NAME';
        stmt.SetSQLCommand(sSQL);
        try
          rs := TABSResultSetAdapter(stmt.ExecuteQuery);
          ds := rs.Dataset;
        ...
    *)
  end;

  TABSStatementAdapter = class(TInterfacedObject, IDBStatement)
  private
    FQuery: TABSQuery;
  public
    constructor Create(AQuery: TABSQuery);
    destructor Destroy; override;
    procedure SetSQLCommand(SQLCommand: string);
    procedure SetParams(Params: TEnumerable<TDBParam>);
    procedure Execute;
    function ExecuteQuery: IDBResultSet;
  end;

  TABSConnectionAdapter = class(TDriverConnectionAdapter<TABSDatabase>, IDBConnection)
  public
    constructor Create(AConnection: TABSDatabase; AOwnsConnection: boolean); override;
    procedure Connect;
    procedure Disconnect;
    function IsConnected: Boolean;
    function CreateStatement: IDBStatement;
    function BeginTransaction: IDBTransaction;
    function RetrieveSqlDialect: string; override;
  end;

  TABSTransactionAdapter = class(TInterfacedObject, IDBTransaction)
  private
    FConnection: TABSDatabase;
  public
    constructor Create(AConnection: TABSDatabase);
    procedure Commit;
    procedure Rollback;
  end;

implementation

{ TABSConnectionAdapter }

function TABSConnectionAdapter.BeginTransaction: IDBTransaction;
begin
  if Connection = nil then
    Exit(nil);

  Connection.Connected := true;

  if not Connection.InTransaction then
  begin
    Connection.StartTransaction;
    Result := TABSTransactionAdapter.Create(Connection);
  end else
    raise Exception.Create('Already in transaction');
end;

procedure TABSConnectionAdapter.Connect;
begin
  if Connection <> nil then
    Connection.Connected := True;
end;

constructor TABSConnectionAdapter.Create(AConnection: TABSDatabase; AOwnsConnection: boolean);
begin
  if not FileExists(AConnection.DatabaseFileName) then
  begin
    AConnection.CreateDatabase;
  end;
  inherited;
end;

function TABSConnectionAdapter.CreateStatement: IDBStatement;
var
  Statement: TABSQuery;
begin
  if Connection = nil then
    Exit(nil);

  Statement := TABSQuery.Create(nil);
  try
    Statement.DatabaseName := Connection.DatabaseName;
  except
    Statement.Free;
    raise;
  end;
  Result := TABSStatementAdapter.Create(Statement);
end;

procedure TABSConnectionAdapter.Disconnect;
begin
  if Connection <> nil then
    Connection.Connected := False;
end;

function TABSConnectionAdapter.IsConnected: Boolean;
begin
  if Connection <> nil then
    Result := Connection.Connected
  else
    Result := false;
end;

function TABSConnectionAdapter.RetrieveSqlDialect: string;
begin
  if Connection = nil then
    Exit('');
  Result := 'AbsoluteDatabase';
end;

{ TABSTransactionAdapter }

procedure TABSTransactionAdapter.Commit;
begin
  if (FConnection = nil) then
    Exit;

  FConnection.Commit;
end;

constructor TABSTransactionAdapter.Create(AConnection: TABSDatabase);
begin
  FConnection := AConnection;
end;

procedure TABSTransactionAdapter.Rollback;
begin
  if (FConnection = nil) then
    Exit;

  FConnection.Rollback;
end;

{ TABSStatementAdapter }

constructor TABSStatementAdapter.Create(AQuery: TABSQuery);
begin
  FQuery := AQuery;
end;

destructor TABSStatementAdapter.Destroy;
begin
  FQuery.Free;
  inherited;
end;

procedure TABSStatementAdapter.Execute;
begin
  FQuery.ExecSQL;
end;

function TABSStatementAdapter.ExecuteQuery: IDBResultSet;
var
  ResultSet: TABSQuery;
  I: Integer;
begin
  ResultSet := TABSQuery.Create(nil);
  try
    ResultSet.DatabaseName := FQuery.DatabaseName;
    ResultSet.SQL := FQuery.SQL;
    for I := 0 to FQuery.Params.Count - 1 do
      ResultSet.Params.Assign(FQuery.Params);

    ResultSet.Open;
  except
    ResultSet.Free;
    raise;
  end;
  Result := TABSResultSetAdapter.Create(ResultSet);
end;

procedure TABSStatementAdapter.SetParams(Params: TEnumerable<TDBParam>);
var
  P: TDBParam;
  Parameter: TParam;
  Bytes: TBytes;
begin
  for P in Params do
  begin
    Parameter := FQuery.ParamByName(P.ParamName);
    Parameter.DataType := P.ParamType;
    Parameter.ParamType := ptInput;

    if P.ParamType in [ftOraBlob, ftOraClob, ftBlob] then
    begin
      Bytes := TUtils.VariantToBytes(P.ParamValue);
      if VarIsNull(P.ParamValue) or (Length(Bytes) = 0) then
        Parameter.Clear
      else
      begin
        Parameter.DataType := P.ParamType;
        Parameter.AsBlob := Bytes;
      end;
    end
    else
    if P.ParamType in [ftMemo, ftWideMemo] then
    begin
      if VarIsNull(P.ParamValue) or (Length(VarToStr(P.ParamValue)) = 0) then
        Parameter.AsMemo := ''
      else
      begin
        Parameter.AsMemo := P.ParamValue;
      end;
    end
    else
      Parameter.Value := P.ParamValue;
  end;

end;

procedure TABSStatementAdapter.SetSQLCommand(SQLCommand: string);
begin
  FQuery.SQL.Text := SQLCommand;
end;

end.
</code>

1 Like
2

Thanks. Can we include these units in official distribution, supported by us, if it passes our tests?

3

You can use these units if they look correct.
So much the better if you find a straighter solution for the lack of foreign keys in Absolute Database.

Wish list

1) Indices
It would be nice if a table had attributes like [Index(<index name>, <[column1, column2, ...]>)].
These attributes would be taken in account when executing TDatabaseManager BuildDatabase.
I don't know if this request meets the ORM specifications or Aurelius "spirit", (ordinary indices - neither primary nor unique - don't intervene in ORM logic)
but building indices along with the tables is a true time saving. In addition to that, the more entities reflect database structure the more we appreciate them!

2) A test suite
Customers who want to write implementations for new databases would take advantage of a test case suite submitted by Aurelius team.

4

Hi Etienne,

 
thanks. About your items:
1. We can consider including this in future. Yes, it's not exactly related to the ORM, but it's an opportunity for users to optimize the database
2. Currently we keep the test suites as private. As in your example about absolute db, users can send the implementation to us and we run the tests here.