unit Aurelius.Schema.Firebird;

{$I Aurelius.Inc}

interface

uses
  Aurelius.Drivers.Interfaces,
  Aurelius.Schema.AbstractImporter,
  Aurelius.Sql.Metadata;

type
  TFirebirdSchemaImporter = class(TAbstractSchemaImporter)
  strict protected
    procedure GetDatabaseMetadata(Connection: IDBConnection; Database: TDatabaseMetadata); override;
  end;

  TFirebirdSchemaRetriever = class(TSchemaRetriever)
  strict private
    FRetrieveIdentity: Boolean;
    procedure GetTables;
    procedure GetColumns;
    procedure GetPrimaryKeys;
    procedure GetUniqueKeys;
    procedure GetDBIndexes;
    procedure GetForeignKeys;
    procedure GetSequences;
    procedure GetFieldDefinition(Column: TColumnMetadata; AType, ASize,
      APrecision, AScale, ASubType, ASegment: integer; const ACharset: string);
  protected
    property RetrieveIdentity: Boolean read FRetrieveIdentity write FRetrieveIdentity;
  public
    constructor Create(AConnection: IDBConnection; ADatabase: TDatabaseMetadata); override;
    procedure RetrieveDatabase; override;
  end;

implementation

uses
  SysUtils,
  Aurelius.Schema.Register;

const
  {$IFDEF MSWINDOWS}
  sqlLineBreak = #13#10;
  {$ELSE}
  sqlLineBreak = ' ';
  {$ENDIF}

{ TFirebirdSchemaImporter }

procedure TFirebirdSchemaImporter.GetDatabaseMetadata(Connection: IDBConnection;
  Database: TDatabaseMetadata);
var
  Retriever: TSchemaRetriever;
begin
  Retriever := TFirebirdSchemaRetriever.Create(Connection, Database);
  try
    Retriever.RetrieveDatabase;
  finally
    Retriever.Free;
  end;
end;

{ TFirebirdSchemaRetriever }

constructor TFirebirdSchemaRetriever.Create(AConnection: IDBConnection;
  ADatabase: TDatabaseMetadata);
begin
  inherited Create(AConnection, ADatabase);
  TrimStringValues := true;
end;

procedure TFirebirdSchemaRetriever.GetColumns;
var
  IdentityCondition: string;
begin
  if RetrieveIdentity then
    IdentityCondition :=
      'f.rdb$identity_type as IDENTITY_TYPE, ' + sqlLineBreak
  else
    IdentityCondition := '';

  RetrieveColumns(
    'select '+
    'f.rdb$relation_name as TABLE_NAME, ' + sqlLineBreak +
    'f.rdb$field_name as COLUMN_NAME, ' + sqlLineBreak +
    'f.rdb$null_flag as NULL_FLAG, ' + sqlLineBreak +
    IdentityCondition +
    'fs.rdb$field_type as DATA_TYPE, ' + sqlLineBreak +
    'COALESCE(fs.RDB$CHARACTER_LENGTH, fs.RDB$FIELD_LENGTH) as FIELD_LENGTH, ' + sqlLineBreak +
    'fs.rdb$field_scale as FIELD_SCALE, ' + sqlLineBreak +
    'fs.rdb$field_precision as FIELD_PRECISION, ' + sqlLineBreak +
    'fs.rdb$field_sub_type as FIELD_SUBTYPE, ' + sqlLineBreak +
    'fs.rdb$segment_length as SEGMENT_LENGTH, ' + sqlLineBreak +
    'cr.rdb$character_set_name as CHARACTER_SET ' + sqlLineBreak +
    'from rdb$relation_fields f ' + sqlLineBreak +
    'left join rdb$fields fs on fs.rdb$field_name = f.rdb$field_source ' + sqlLineBreak +
    'left join rdb$field_dimensions d on d.rdb$field_name = fs.rdb$field_name ' + sqlLineBreak +
    'left join rdb$character_sets cr on fs.rdb$character_set_id = cr.rdb$character_set_id ' + sqlLineBreak +
    'order by f.rdb$relation_name, f.rdb$field_position, d.rdb$dimension',
    procedure (Column: TColumnMetadata; ResultSet: IDBResultSet)
    begin
      Column.NotNull := (AsInteger(ResultSet.GetFieldValue('NULL_FLAG')) = 1);
      GetFieldDefinition(Column,
        AsInteger(ResultSet.GetFieldValue('DATA_TYPE')),
        AsInteger(ResultSet.GetFieldValue('FIELD_LENGTH')),
        AsInteger(ResultSet.GetFieldValue('FIELD_PRECISION')),
        AsInteger(ResultSet.GetFieldValue('FIELD_SCALE')),
        AsInteger(ResultSet.GetFieldValue('FIELD_SUBTYPE')),
        AsInteger(ResultSet.GetFieldValue('SEGMENT_LENGTH')),
        AsString(ResultSet.GetFieldValue('CHARACTER_SET'))
      );
      Column.AutoGenerated := RetrieveIdentity and (ResultSet.GetFieldValue('IDENTITY_TYPE') = 1);
    end
  );
end;

procedure TFirebirdSchemaRetriever.GetDBIndexes;
begin
  RetrieveDBIndexes(
    'select i.rdb$index_name as INDEX_NAME, '#13#10+
    'i.rdb$relation_name as TABLE_NAME, '#13#10+
    'isg.rdb$field_name as COLUMN_NAME '#13#10+
    'from rdb$indices i '#13#10+
    'LEFT JOIN rdb$index_segments isg ON (isg.rdb$index_name = i.rdb$index_name) '#13#10+
    'LEFT JOIN rdb$relation_constraints c ON (i.rdb$index_name = c.rdb$index_name) '#13#10+
    'where ((rdb$system_flag is null) or (rdb$system_flag = 0)) '#13#10+
    'and (c.rdb$constraint_name is null) '#13#10+
    'and ((i.rdb$unique_flag <> 1) or (i.rdb$unique_flag is null)) '#13#10+
    'order by i.rdb$relation_name, i.rdb$index_name, isg.rdb$field_position'
  );
end;

procedure TFirebirdSchemaRetriever.GetFieldDefinition(Column: TColumnMetadata; AType, ASize,
  APrecision, AScale, ASubType, ASegment: integer; const ACharset: string);

  function CheckNumeric: boolean;
  begin
    Result := ASubType in [1, 2];
    if Result then
    begin
      Column.DataType := 'NUMERIC';
      Column.Precision := APrecision;
      Column.Scale := abs(AScale);
    end;
  end;

//  function IsNChar: boolean;
//  begin
//    Result := SameText('ISO8859_1', ACharset);
//  end;

const
  fb__blob = 261;
  fb__cstring = 40;
  fb__char = 14;
  fb__dfloat = 11;
  fb__double = 27;
  fb__float = 10;
  fb__int64 = 16;
  fb__integer = 8;
  fb__quad = 9;
  fb__smallint = 7;
  fb__date = 12;
  fb__time = 13;
  fb__timestamp = 35;
  fb__varchar = 37;
  fb__boolean = 23;
begin
  case AType of
    fb__blob, fb__cstring, fb__dfloat, fb__quad:
      begin
        if ASubType = 1 then
          Column.DataType := 'BLOB SUB_TYPE TEXT'
        else
          Column.DataType := 'BLOB';
      end;
    fb__char:
      begin
        Column.Length := ASize;
//        if IsNChar then
//          Column.DataType := 'NCHAR'
//        else
          Column.DataType := 'CHAR'
      end;
    fb__varchar:
      begin
        Column.Length := ASize;
//        if IsNChar then
//          Column.DataType := 'NCHAR VARYING'
//        else
        Column.DataType := 'VARCHAR'
      end;
    fb__smallint:
      if not CheckNumeric then
        Column.DataType := 'SMALLINT';
    fb__integer:
      if not CheckNumeric then
        Column.DataType := 'INTEGER';
    fb__int64:
      if not CheckNumeric then
      begin
        Column.DataType := 'NUMERIC';
        Column.Precision := 18;
      end;
    fb__double, fb__float:
        Column.DataType := 'DOUBLE PRECISION';
    fb__date:
      Column.DataType := 'DATE';
    fb__time:
      Column.DataType := 'TIME';
    fb__timestamp:
      Column.DataType := 'TIMESTAMP';
    fb__boolean:
      Column.DataType := 'BOOLEAN';
  end;
end;

procedure TFirebirdSchemaRetriever.GetForeignKeys;
begin
  RetrieveForeignKeys(
    'select ' + sqlLineBreak +
    'C.RDB$RELATION_NAME as PK_TABLE_NAME, ' + sqlLineBreak +
    'A.RDB$RELATION_NAME as FK_TABLE_NAME, ' + sqlLineBreak +
    'D.RDB$FIELD_NAME as PK_COLUMN_NAME, ' + sqlLineBreak +
    'E.RDB$FIELD_NAME as FK_COLUMN_NAME, ' + sqlLineBreak +
    'A.RDB$CONSTRAINT_NAME as CONSTRAINT_NAME ' + sqlLineBreak +
    'from RDB$REF_CONSTRAINTS B, RDB$RELATION_CONSTRAINTS A, RDB$RELATION_CONSTRAINTS C, ' + sqlLineBreak +
    'RDB$INDEX_SEGMENTS D, RDB$INDEX_SEGMENTS E ' + sqlLineBreak +
    'where (A.RDB$CONSTRAINT_TYPE = ''FOREIGN KEY'') and ' + sqlLineBreak +
    '(A.RDB$CONSTRAINT_NAME = B.RDB$CONSTRAINT_NAME) and ' + sqlLineBreak +
    '(B.RDB$CONST_NAME_UQ=C.RDB$CONSTRAINT_NAME) and ' + sqlLineBreak +
    '(C.RDB$INDEX_NAME=D.RDB$INDEX_NAME) and ' + sqlLineBreak +
    '(A.RDB$INDEX_NAME=E.RDB$INDEX_NAME) and ' + sqlLineBreak +
    '(D.RDB$FIELD_POSITION = E.RDB$FIELD_POSITION) ' + sqlLineBreak +
    'order by A.RDB$RELATION_NAME, A.RDB$CONSTRAINT_NAME,  ' + sqlLineBreak +
    'D.RDB$FIELD_POSITION, E.RDB$FIELD_POSITION');
end;

procedure TFirebirdSchemaRetriever.GetPrimaryKeys;
begin
  RetrievePrimaryKeys(
    'select rc.rdb$constraint_name as CONSTRAINT_NAME, ' + sqlLineBreak +
    'rc.rdb$relation_name as TABLE_NAME, ' + sqlLineBreak +
    'i.rdb$field_name as COLUMN_NAME, ' + sqlLineBreak +
    'i.rdb$field_position as ORDINAL_POSITION, ' + sqlLineBreak +
    'rc.rdb$index_name ' + sqlLineBreak +
    'from rdb$relation_constraints rc, rdb$index_segments i ' + sqlLineBreak +
    'where (i.rdb$index_name = rc.rdb$index_name) and ' + sqlLineBreak +
    '(rc.rdb$constraint_type = ''PRIMARY KEY'') ' + sqlLineBreak +
    'order by rc.rdb$relation_name, rc.rdb$constraint_name, i.rdb$field_position');
end;

procedure TFirebirdSchemaRetriever.GetSequences;
begin
  RetrieveSequences(
    'select RDB$GENERATOR_NAME AS SEQUENCE_NAME ' +
    'from RDB$GENERATORS ' +
    'where (RDB$SYSTEM_FLAG is NULL) or (RDB$SYSTEM_FLAG = 0)' +
    'order by RDB$GENERATOR_NAME');
end;

procedure TFirebirdSchemaRetriever.GetTables;
begin
  RetrieveTables(
    'SELECT RDB$RELATION_NAME AS TABLE_NAME '+
    'FROM RDB$RELATIONS '+
    'WHERE ' +
    'RDB$VIEW_BLR IS NULL AND '+
    '(RDB$SYSTEM_FLAG = 0 OR RDB$SYSTEM_FLAG IS NULL) '+
    'ORDER BY RDB$RELATION_NAME');
end;

procedure TFirebirdSchemaRetriever.GetUniqueKeys;
begin
  RetrieveUniqueKeys(
    'select rc.rdb$constraint_name as CONSTRAINT_NAME, ' + sqlLineBreak +
    'rc.rdb$relation_name as TABLE_NAME, ' + sqlLineBreak +
    'i.rdb$field_name as COLUMN_NAME, ' + sqlLineBreak +
    'i.rdb$field_position as ORDINAL_POSITION, ' + sqlLineBreak +
    'rc.rdb$index_name ' + sqlLineBreak +
    'from rdb$relation_constraints rc, rdb$index_segments i ' + sqlLineBreak +
    'where (i.rdb$index_name = rc.rdb$index_name) and ' + sqlLineBreak +
    '(rc.rdb$constraint_type = ''UNIQUE'') ' + sqlLineBreak +
    'order by rc.rdb$relation_name, rc.rdb$constraint_name, i.rdb$field_position');
end;

procedure TFirebirdSchemaRetriever.RetrieveDatabase;
begin
  Database.Clear;
  GetTables;
  GetColumns;
  GetPrimaryKeys;
  GetUniqueKeys;
  GetDBIndexes;
  GetForeignKeys;
  GetSequences;
end;

initialization
  TSchemaImporterRegister.GetInstance.RegisterImporter('Firebird', TFirebirdSchemaImporter.Create);

end.

