はじめに

これは Delphi Advent Calendar 2017 14日目の記事です。

ちょっと前に IBConsole を更新したのですが、修正した IBX の内容を公開しないと片手落ちという事に気づいて、この記事を書くことにしました。

Firebird には InterBase 6 互換モードがありますので、Firebird の大抵の機能は IBX で動作するのですが、InterBase に特化した実装部分は Firebird ではちゃんと動かない事があります。IBX でマトモに Firebird を扱えるようにするには IBX を修正する必要があります。

記事は Delphi 10.2 Tokyo を対象に書かれていますが、Delphi 2009 以降は似たようなコードでイケると思います。

コードの修正

以下の修正が行われます。

UTF-8 が使えるようになる。
(若干) 高速化する。
Firebird 3.0 で追加された Boolean 型が使えるようになる。

IBX のソースコードを修正しますが、オリジナルを書き換えてはいけません。[ファイル | 新規作成 | VCL フォームアプリケーション - Delphi] でプロジェクトを新規作成し、プロジェクトフォルダに以下のファイルをコピーしてきてください。

IBX.IB.pas ※ 11.0 Alexandria 以降では不要
IBX.IBCustomDataSet.pas
IBX.IBDatabase.pas
IBX.IBExtract.pas
IBX.IBHeader.pas
IBX.IBInputOutput.pas
IBX.IBSQL.pas
IBX.IBStoredProc.pas

IBX のソースファイルは $(BDS)\source\IBX にあります。

UTF-8 対応

InterBase と Firebird で UTF-8 の SqlSubtype の値が異なるため、Firebird で UTF-8 を使うと文字の長さを間違ってしまう件を修正します。

IBX.IBSQL.pas

function TIBXSQLVAR.GetCharsetSize: Integer;
begin
{
  case SQLVar.SQLSubtype and $FF of
    0, 1, 2, 10, 11, 12, 13, 14, 19, 21, 22, 39,
    45, 46, 47, 50, 51, 52, 53, 54, 55, 58 :  Result := 1;
    5, 6, 8, 44, 56, 57, 64 : Result := 2;
    3 :
    begin
      // System Tables incorrectly state they are in Unicode_Fss character set but they are not
      if SQLVar.RelName.StartsWith('RDB$') or
         (SQLVar.SqlLen mod 3 <> 0) then
        Result := 1
      else
        Result := 3;
    end;
    59 : Result := 4;
    else
      Result := 1;
  end;
}
  case SqlVar.SqlSubtype and $FF of
     5, // SJIS_0208
     6, // EUCJ_0208
     8, // UNICODE_BE / UCS2BE (InterBase)
    44, // KSC_5601
    56, // BIG_5
    57, // GB_2312
    64, // UNICODE_LE / UCS2LE (InterBase)
    67, // GBK (Firebird)
    68: // CP943C (Firebird)
      result := 2;
    3: // UNICODE_FSS
      begin
        // System Tables incorrectly state they are in Unicode_Fss character set but they are not
        if SqlVar.RelName.StartsWith('RDB$') or (SqlVar.SqlLen mod 3 <> 0) then
          result := 1
        else
          result := 3;
      end;
     4, // UTF8 (Firebird)
    59, // UTF8 / UTF_8 (InterBase)
    69: // GB18030 (Firebird)
      result := 4;
  else
    result := 1;
  end;  
end;

Firebird にしかない文字コードや InterBase にしかない文字コードがあります。しかも
InterBase と Firebird で両対応しようとしてもできない文字コードがあります。仕方ないので、大筋は InterBase に合わせておきます。

IBX.IBDatabase.pas

procedure BuildDPBConstants;
begin

  ...

  CodePages.Add('DOS775', 775);      {do not localize} // 15
  CodePages.Add('DOS858', 858);      {do not localize} // 16
  CodePages.Add('DOS862', 862);      {do not localize} // 17
  CodePages.Add('DOS864', 864);      {do not localize} // 18
  CodePages.Add('ISO8859_2', 28592); {do not localize} // 22
  CodePages.Add('ISO8859_8', 1255);  {do not localize} // 38
  CodePages.Add('DOS866', 866);      {do not localize} // 48
  CodePages.Add('DOS869', 1255);     {do not localize} // 49
  CodePages.Add('BIG_5', 950);       {do not localize} // 56
  CodePages.Add('WIN1255', 1255);    {do not localize} // 58
  CodePages.Add('WIN1256', 1256);    {do not localize} // 59
  CodePages.Add('WIN1257', 1257);    {do not localize} // 60
  CodePages.Add('KOI8R', 20866);     {do not localize} // 63
  CodePages.Add('WIN1258', 1258);    {do not localize} // 65
  CodePages.Add('GBK', 936);         {do not localize} // 67
  CodePages.Add('TIS620', 874);      {do not localize} // 66
  CodePages.Add('CP943C', 932);      {do not localize} // 68
  CodePages.Add('GB18030', 54936);   {do not localize} // 69
end;

IBExtract を使う際に一部コメントアウトしておかないと動作しない非互換部分があります。

IBX.IBExtract.pas

function TIBExtract.ExtractDDL(Flag: Boolean; TableName: String) : Boolean;
begin

  ...

  if TableName <> '' then
  begin
    if not ExtractListTable(TableName, '', true) then
      Result := false;
  end
  else
  begin
    ListCreateDb;
//    ListEUAUsers;
//    ListEncryptions;
//    if ConnectAsOwner then
//      BuildConnectString;
    ListFilters;
    ListFunctions;
    ListDomains;
    ListAllTables(flag);
    ListIndex;
    ListForeign;
    ListGenerators;
    ListSubscriptions;
    ListViews;
    ListCheck;
    ListException;
    ListProcs;
    ListTriggers;
    ListGrants;
  end;

  ...

end;

IBX の高速化 (10.4 Sydney 以前)

元ネタはこちらです。

IBX.IB.pas

procedure IBAlloc(var P; OldSize, NewSize: NativeInt);
var
  i: Integer;
begin
  if Assigned(Pointer(P)) then
    ReallocMem(Pointer(P), NewSize)
  else
    GetMem(Pointer(P), NewSize);

//  for i := OldSize to NewSize - 1 do
//    PByte(P)[i] := 0;
  if NewSize > OldSize then
    FillChar((PByte(P) + OldSize)^, NewSize - OldSize, 0);
end;

{$IFDEF NEXTGEN}
procedure IBAlloc(var p : TRecBuf; OldSize, NewSize: NativeInt);
var
  i: Integer;
begin
  ReallocMem(Pointer(p), NewSize);
  for i := OldSize to NewSize - 1 do
    PByte(p)[i] := 0;
end;
{$ELSE}
procedure IBAlloc(var p : TRecordBuffer; OldSize, NewSize: NativeInt);
var
  i: Integer;
begin
  ReallocMem(p, NewSize);
//  for i := OldSize to NewSize - 1 do
//    p[i] := 0;
  if NewSize > OldSize then
    FillChar((PByte(P) + OldSize)^, NewSize - OldSize, 0);
end;
{$ENDIF NEXTGEN}

２か所あるのでご注意！

この修正は 11.0 Alexandria 以降では不要です。同等の修正が最初から入っています。

Boolean 型 (Firebird 3.0 以降) への対応

Firebird と InterBase で Boolean 型に対する定数が異なる場合があるのでそれを修正します。

IBX.IBHeader.pas


  ...

const
  isc_blob_filter_open           =          0;
  isc_blob_filter_get_segment    =          1;
  isc_blob_filter_close          =          2;
  isc_blob_filter_create         =          3;
  isc_blob_filter_put_segment    =          4;
  isc_blob_filter_alloc          =          5;
  isc_blob_filter_free           =          6;
  isc_blob_filter_seek           =          7;

(*********************)
(** Blr definitions **)
(*********************)

  // In pascal, how does one deal with the below "#define"?
  // blr_word(n) ((n) % 256), ((n) / 256)
  blr_text                       =         14;
  blr_text2                      =         15;
  blr_short                      =          7;
  blr_long                       =          8;
  blr_quad                       =          9;
  blr_float                      =         10;
  blr_double                     =         27;
  blr_d_float                    =         11;
  blr_timestamp                  =         35;
  blr_varying                    =         37;
  blr_varying2                   =         38;
  blr_blob                       =        261;
  blr_cstring                    =         40;
  blr_cstring2                   =         41;
  blr_blob_id                    =         45;
  blr_sql_date                   =         12;
  blr_sql_time                   =         13;
  blr_int64                      =         16;
//blr_boolean_dtype              =         17; // InterBase 用
  blr_boolean_dtype              =         23; // Firebird 用
  blr_date                       =         blr_timestamp;

  ...

(*********************)
(** SQL definitions **)
(*********************)
  SQL_VARYING                    =        448;
  SQL_TEXT                       =        452;
  SQL_DOUBLE                     =        480;
  SQL_FLOAT                      =        482;
  SQL_LONG                       =        496;
  SQL_SHORT                      =        500;
  SQL_TIMESTAMP                  =        510;
  SQL_BLOB                       =        520;
  SQL_D_FLOAT                    =        530;
  SQL_ARRAY                      =        540;
  SQL_QUAD                       =        550;
  SQL_TYPE_TIME                  =        560;
  SQL_TYPE_DATE                  =        570;
  SQL_INT64                      =        580;
  SQL_DATE                       =        SQL_TIMESTAMP;
  SQL_BOOLEAN                    =        590; 
  SQL_FIREBIRD_BOOLEAN           =        32764; // 追加
  SQL_NULL                       =        32766; // 追加

  ...

以下のファイルで SQL_BOOLEAN となっている所を SQL_BOOLEAN, SQL_FIREBIRD_BOOLEAN で置き換えます。

IBX.IBCustomDataSet.pas
IBX.Extract.pas
IBX.IBInputOutput.pas
IBX.IBSQL.pas
IBX.IBStoredProc.pas

ほぼ case 文での定数です。

例えばこのようなコードを...

IBX.IBExtract.pas

          SQL_SHORT, SQL_LONG, SQL_INT64,
          SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT, SQL_BOOLEAN:
            Values := Values + qrySelect.Fields[i].AsTrimString;

こんな感じで置換します。

IBX.IBExtract.pas

          SQL_SHORT, SQL_LONG, SQL_INT64,
          SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT, SQL_BOOLEAN, SQL_FIREBIRD_BOOLEAN:   // 追加
            Values := Values + qrySelect.Fields[i].AsTrimString;

たまにこんなのがあります。

IBX.IBSQL.pas

//      if (stype = SQL_BOOLEAN) then
        if (stype = SQL_BOOLEAN) or (stype = SQL_FIREBIRD_BOOLEAN) then

IBX.IBExtract の修正

TIBExtract.ListProcs()

エラーが発生するバージョンであれば、次のように改変してください。

IBX.IBExtract.pas

procedure TIBExtract.ListProcs(ProcedureName : String; AlterOnly : Boolean);
const
  CreateProcedureStr1 = 'CREATE PROCEDURE %s ';  {do not localize}
  CreateProcedureStr2 = 'BEGIN EXIT; END %s%s';  {do not localize}
  ProcedureSQL =
    'SELECT PRO.RDB$PROCEDURE_NAME, PRO.RDB$PROCEDURE_SOURCE, RDB$PARAMETER_NAME, RDB$PARAMETER_TYPE, ' +    {do not localize}
    '       RDB$FIELD_TYPE, RDB$FIELD_SCALE, RDB$FIELD_PRECISION, RDB$FIELD_SUB_TYPE, ' + {do not localize}
//  '       RDB$SEGMENT_LENGTH, RDB$COLLATION_ID, RDB$CHARACTER_SET_ID, RDB$CHARACTER_LENGTH, ' + {do not localize} // MOD
    '       RDB$SEGMENT_LENGTH, FLD.RDB$COLLATION_ID, RDB$CHARACTER_SET_ID, RDB$CHARACTER_LENGTH, ' + {do not localize} // MOD
    '       PRO.RDB$DESCRIPTION ProcDesc, PRM.RDB$DESCRIPTION ParamDesc ' + {do not localize}
    '  FROM RDB$PROCEDURES PRO LEFT OUTER join RDB$PROCEDURE_PARAMETERS PRM ON ' +    {do not localize}
    '       PRO.RDB$PROCEDURE_NAME = PRM.RDB$PROCEDURE_NAME LEFT OUTER JOIN RDB$FIELDS FLD ON ' +    {do not localize}
    '       PRM.RDB$FIELD_SOURCE = FLD.RDB$FIELD_NAME ' +    {do not localize}
    ' ORDER BY PRO.RDB$PROCEDURE_NAME, PRM.RDB$PARAMETER_TYPE, PRM.RDB$PARAMETER_NUMBER';    {do not localize}

  ProcedureNameSQL =
    'SELECT PRO.RDB$PROCEDURE_NAME, PRO.RDB$PROCEDURE_SOURCE, RDB$PARAMETER_NAME, RDB$PARAMETER_TYPE, ' +    {do not localize}
    '       RDB$FIELD_TYPE, RDB$FIELD_SCALE, RDB$FIELD_PRECISION, RDB$FIELD_SUB_TYPE, ' + {do not localize} // MOD
//  '       RDB$SEGMENT_LENGTH, RDB$COLLATION_ID, RDB$CHARACTER_SET_ID, RDB$CHARACTER_LENGTH, ' + {do not localize} // MOD
    '       RDB$SEGMENT_LENGTH, FLD.RDB$COLLATION_ID, RDB$CHARACTER_SET_ID, RDB$CHARACTER_LENGTH, ' + {do not localize}
    '       PRO.RDB$DESCRIPTION ProcDesc, PRM.RDB$DESCRIPTION ParamDesc ' + {do not localize}
    '  FROM RDB$PROCEDURES PRO LEFT OUTER join RDB$PROCEDURE_PARAMETERS PRM ON ' +    {do not localize}
    '       PRO.RDB$PROCEDURE_NAME = PRM.RDB$PROCEDURE_NAME LEFT OUTER JOIN RDB$FIELDS FLD ON ' +    {do not localize}
    '       PRM.RDB$FIELD_SOURCE = FLD.RDB$FIELD_NAME ' +    {do not localize}
    ' WHERE PRO.RDB$PROCEDURE_NAME = :ProcedureName ' + {do not localize}
    ' ORDER BY PRO.RDB$PROCEDURE_NAME, PRM.RDB$PARAMETER_TYPE, PRM.RDB$PARAMETER_NUMBER';    {do not localize}

TIBExtract.ListAllTables()

エラーが発生するバージョンであれば、次のように改変してください。

IBX.IBExtract.pas

procedure TIBExtract.ListAllTables(flag: Boolean);
const
  TableSQL =
       'SELECT rel.*, RFR.*, FLD.*, rel.rdb$description table_description, RFR.rdb$description field_description ' +
       '  FROM RDB$RELATIONS REL JOIN RDB$RELATION_FIELDS RFR ON ' + {do not localize}
       '       RFR.RDB$RELATION_NAME = REL.RDB$RELATION_NAME JOIN RDB$FIELDS FLD ON ' + {do not localize}
       '       RFR.RDB$FIELD_SOURCE = FLD.RDB$FIELD_NAME ' + {do not localize}
       ' where (RDB$SYSTEM_FLAG <> 1 OR RDB$SYSTEM_FLAG IS NULL) AND ' + {do not localize}
       '  RDB$VIEW_BLR IS NULL ' +  {do not localize}
//     ' ORDER BY RDB$RELATION_NAME, RFR.RDB$FIELD_POSITION, RFR.RDB$FIELD_NAME'; {do not localize} // MOD
       ' ORDER BY RFR.RDB$RELATION_NAME, RFR.RDB$FIELD_POSITION, RFR.RDB$FIELD_NAME'; {do not localize} // MOD

修正をすべて終えたら、IBX 関係のファイルをどこかに保存しておきます。IBX で Firebird を使いたくなったらこのファイルをプロジェクトフォルダにコピーして使ってください。

おわりに

修正を行っても InterBase との互換性は失われていませんので、InterBase / Firebird どちらにも接続可能なハズです。ぶっちゃけこの程度の違いしかないので、最初から IBX で Firebird 対応してくれるといいのにと思わなくもありません。

それから、IBX は Professional Edition 以上の SKU に含まれます。残念ながら Starter Edition では利用できませんので、Starter Edition で Firebird を使いたい方は ZeosLib を使いましょう。Enterprise Edition 以上の SKU をお持ちの方は素直に FireDAC を使いましょう。