はじめに
これは 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 を使いましょう。