ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/client/FBAttachment.pas
Revision: 143
Committed: Fri Feb 23 12:11:21 2018 UTC (6 years, 9 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/FBAttachment.pas
File size: 32089 byte(s)
Log Message: 
Fixes Merged

File Contents

# User Rev Content
1 tony 45 (*
2     * Firebird Interface (fbintf). The fbintf components provide a set of
3     * Pascal language bindings for the Firebird API.
4     *
5     * The contents of this file are subject to the Initial Developer's
6     * Public License Version 1.0 (the "License"); you may not use this
7     * file except in compliance with the License. You may obtain a copy
8     * of the License here:
9     *
10     * http://www.firebirdsql.org/index.php?op=doc&id=idpl
11     *
12     * Software distributed under the License is distributed on an "AS
13     * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
14     * implied. See the License for the specific language governing rights
15     * and limitations under the License.
16     *
17     * The Initial Developer of the Original Code is Tony Whyman.
18     *
19     * The Original Code is (C) 2016 Tony Whyman, MWA Software
20     * (http://www.mwasoftware.co.uk).
21     *
22     * All Rights Reserved.
23     *
24     * Contributor(s): ______________________________________.
25     *
26     *)
27     unit FBAttachment;
28 tony 56 {$IFDEF MSWINDOWS}
29     {$DEFINE WINDOWS}
30     {$ENDIF}
31 tony 45
32     {$IFDEF FPC}
33 tony 56 {$mode delphi}
34 tony 45 {$interfaces COM}
35 tony 118 {$define HASREQEX}
36 tony 45 {$ENDIF}
37    
38     interface
39    
40     uses
41 tony 60 Classes, SysUtils, {$IFDEF WINDOWS} windows, {$ENDIF} IB, FBParamBlock, FBActivityMonitor;
42 tony 45
43     type
44 tony 60 TCharsetMap = record
45     CharsetID: integer;
46     CharSetName: AnsiString;
47     CharSetWidth: integer;
48     CodePage: TSystemCodePage;
49     AllowReverseLookup: boolean; {used to ensure that lookup of CP_UTF* does not return UNICODE_FSS}
50     end;
51 tony 45
52     { TFBAttachment }
53    
54     TFBAttachment = class(TActivityHandler)
55     private
56     FDPB: IDPB;
57     FFirebirdAPI: IFirebirdAPI;
58 tony 117 FODSMajorVersion: integer;
59     FODSMinorVersion: integer;
60 tony 60 FUserCharSetMap: array of TCharSetMap;
61 tony 45 protected
62 tony 56 FDatabaseName: AnsiString;
63 tony 45 FRaiseExceptionOnConnectError: boolean;
64     FSQLDialect: integer;
65     FHasDefaultCharSet: boolean;
66     FCharSetID: integer;
67     FCodePage: TSystemCodePage;
68 tony 117 FRemoteProtocol: AnsiString;
69 tony 143 FAuthMethod: AnsiString;
70 tony 56 constructor Create(DatabaseName: AnsiString; DPB: IDPB;
71 tony 45 RaiseExceptionOnConnectError: boolean);
72     procedure CheckHandle; virtual; abstract;
73 tony 56 function GenerateCreateDatabaseSQL(DatabaseName: AnsiString; aDPB: IDPB): AnsiString;
74 tony 117 procedure GetODSAndConnectionInfo;
75 tony 143 function GetDBInfo(ReqBuffer: PByte; ReqBufLen: integer): IDBInformation; virtual; abstract;
76 tony 117 function IsConnected: boolean; virtual; abstract;
77 tony 45 procedure EndAllTransactions;
78 tony 117 procedure DPBFromCreateSQL(CreateSQL: AnsiString);
79 tony 45 procedure SetParameters(SQLParams: ISQLParams; params: array of const);
80     public
81     destructor Destroy; override;
82     function getDPB: IDPB;
83     function AllocateBPB: IBPB;
84 tony 143 function AllocateDIRB: IDIRB;
85 tony 45 function StartTransaction(TPB: array of byte; DefaultCompletion: TTransactionCompletion): ITransaction; overload; virtual; abstract;
86     function StartTransaction(TPB: ITPB; DefaultCompletion: TTransactionCompletion): ITransaction; overload; virtual; abstract;
87     procedure Disconnect(Force: boolean=false); virtual; abstract;
88 tony 56 procedure ExecImmediate(transaction: ITransaction; sql: AnsiString; aSQLDialect: integer); overload; virtual; abstract;
89     procedure ExecImmediate(TPB: array of byte; sql: AnsiString; aSQLDialect: integer); overload;
90     procedure ExecImmediate(transaction: ITransaction; sql: AnsiString); overload;
91     procedure ExecImmediate(TPB: array of byte; sql: AnsiString); overload;
92     function ExecuteSQL(TPB: array of byte; sql: AnsiString; SQLDialect: integer; params: array of const): IResults; overload;
93     function ExecuteSQL(transaction: ITransaction; sql: AnsiString; SQLDialect: integer; params: array of const): IResults; overload;
94     function ExecuteSQL(TPB: array of byte; sql: AnsiString; params: array of const): IResults; overload;
95     function ExecuteSQL(transaction: ITransaction; sql: AnsiString; params: array of const): IResults; overload;
96     function OpenCursor(transaction: ITransaction; sql: AnsiString; aSQLDialect: integer): IResultSet; overload;
97     function OpenCursor(transaction: ITransaction; sql: AnsiString; aSQLDialect: integer;
98 tony 45 params: array of const): IResultSet; overload;
99 tony 56 function OpenCursor(transaction: ITransaction; sql: AnsiString): IResultSet; overload;
100     function OpenCursor(transaction: ITransaction; sql: AnsiString;
101 tony 45 params: array of const): IResultSet; overload;
102 tony 56 function OpenCursorAtStart(transaction: ITransaction; sql: AnsiString; aSQLDialect: integer): IResultSet; overload;
103     function OpenCursorAtStart(transaction: ITransaction; sql: AnsiString; aSQLDialect: integer;
104 tony 45 params: array of const): IResultSet; overload;
105 tony 56 function OpenCursorAtStart(transaction: ITransaction; sql: AnsiString): IResultSet; overload;
106     function OpenCursorAtStart(transaction: ITransaction; sql: AnsiString;
107 tony 45 params: array of const): IResultSet; overload;
108 tony 56 function OpenCursorAtStart(sql: AnsiString): IResultSet; overload;
109     function OpenCursorAtStart(sql: AnsiString;
110 tony 45 params: array of const): IResultSet; overload;
111 tony 56 function Prepare(transaction: ITransaction; sql: AnsiString; aSQLDialect: integer): IStatement; overload; virtual; abstract;
112     function Prepare(transaction: ITransaction; sql: AnsiString): IStatement; overload;
113     function PrepareWithNamedParameters(transaction: ITransaction; sql: AnsiString;
114 tony 45 aSQLDialect: integer; GenerateParamNames: boolean=false): IStatement; overload; virtual; abstract;
115 tony 56 function PrepareWithNamedParameters(transaction: ITransaction; sql: AnsiString;
116 tony 45 GenerateParamNames: boolean=false): IStatement; overload;
117     function GetEventHandler(Events: TStrings): IEvents; overload; virtual; abstract;
118 tony 56 function GetEventHandler(Event: AnsiString): IEvents; overload;
119 tony 45
120     function GetSQLDialect: integer;
121 tony 56 function OpenBlob(transaction: ITransaction; BlobMetaData: IBlobMetaData; BlobID: TISC_QUAD; BPB: IBPB=nil): IBlob; overload; virtual; abstract;
122 tony 45 function OpenBlob(transaction: ITransaction; Field: ISQLData; BPB: IBPB=nil): IBlob; overload;
123     property SQLDialect: integer read FSQLDialect;
124     property DPB: IDPB read FDPB;
125 tony 60 public
126 tony 143 function GetDBInformation(Requests: array of byte): IDBInformation; overload;
127     function GetDBInformation(Request: byte): IDBInformation; overload;
128     function GetDBInformation(Requests: IDIRB): IDBInformation; overload;
129 tony 117 function GetConnectString: AnsiString;
130     function GetRemoteProtocol: AnsiString;
131 tony 143 function GetAuthenticationMethod: AnsiString;
132 tony 117 function GetODSMajorVersion: integer;
133     function GetODSMinorVersion: integer;
134     {Character Sets}
135 tony 109 function HasDefaultCharSet: boolean;
136     function GetDefaultCharSetID: integer;
137 tony 60 function GetCharsetName(CharSetID: integer): AnsiString;
138     function CharSetID2CodePage(CharSetID: integer; var CodePage: TSystemCodePage): boolean;
139     function CodePage2CharSetID(CodePage: TSystemCodePage; var CharSetID: integer): boolean;
140     function CharSetName2CharSetID(CharSetName: AnsiString; var CharSetID: integer): boolean;
141     function CharSetWidth(CharSetID: integer; var Width: integer): boolean;
142     procedure RegisterCharSet(CharSetName: AnsiString; CodePage: TSystemCodePage;
143     AllowReverseLookup:boolean; out CharSetID: integer);
144     property CharSetID: integer read FCharSetID;
145     property CodePage: TSystemCodePage read FCodePage;
146 tony 45 end;
147    
148     implementation
149    
150 tony 143 uses FBMessages, IBUtils, FBTransaction {$IFDEF HASREQEX}, RegExpr{$ENDIF};
151 tony 45
152 tony 60 const
153     CharSetMap: array [0..69] of TCharsetMap = (
154     (CharsetID: 0; CharSetName: 'NONE'; CharSetWidth: 1; CodePage: CP_ACP; AllowReverseLookup: true),
155     (CharsetID: 1; CharSetName: 'OCTETS'; CharSetWidth: 1; CodePage: CP_NONE; AllowReverseLookup: true),
156     (CharsetID: 2; CharSetName: 'ASCII'; CharSetWidth: 1; CodePage: CP_ASCII; AllowReverseLookup: true),
157     (CharsetID: 3; CharSetName: 'UNICODE_FSS'; CharSetWidth: 3; CodePage: CP_UTF8; AllowReverseLookup: false),
158     (CharsetID: 4; CharSetName: 'UTF8'; CharSetWidth: 4; CodePage: CP_UTF8; AllowReverseLookup: true),
159     (CharsetID: 5; CharSetName: 'SJIS_0208'; CharSetWidth: 2; CodePage: 20932; AllowReverseLookup: true),
160     (CharsetID: 6; CharSetName: 'EUCJ_0208'; CharSetWidth: 2; CodePage: 20932; AllowReverseLookup: true),
161     (CharsetID: 7; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE; AllowReverseLookup: true),
162     (CharsetID: 8; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE; AllowReverseLookup: true),
163     (CharsetID: 9; CharSetName: 'DOS737'; CharSetWidth: 1; CodePage: 737; AllowReverseLookup: true),
164     (CharsetID: 10; CharSetName: 'DOS437'; CharSetWidth: 1; CodePage: 437; AllowReverseLookup: true),
165     (CharsetID: 11; CharSetName: 'DOS850'; CharSetWidth: 1; CodePage: 850; AllowReverseLookup: true),
166     (CharsetID: 12; CharSetName: 'DOS865'; CharSetWidth: 1; CodePage: 865; AllowReverseLookup: true),
167     (CharsetID: 13; CharSetName: 'DOS860'; CharSetWidth: 1; CodePage: 860; AllowReverseLookup: true),
168     (CharsetID: 14; CharSetName: 'DOS863'; CharSetWidth: 1; CodePage: 863; AllowReverseLookup: true),
169     (CharsetID: 15; CharSetName: 'DOS775'; CharSetWidth: 1; CodePage: 775; AllowReverseLookup: true),
170     (CharsetID: 16; CharSetName: 'DOS858'; CharSetWidth: 1; CodePage: 858; AllowReverseLookup: true),
171     (CharsetID: 17; CharSetName: 'DOS862'; CharSetWidth: 1; CodePage: 862; AllowReverseLookup: true),
172     (CharsetID: 18; CharSetName: 'DOS864'; CharSetWidth: 1; CodePage: 864; AllowReverseLookup: true),
173     (CharsetID: 19; CharSetName: 'NEXT'; CharSetWidth: 1; CodePage: CP_NONE; AllowReverseLookup: true),
174     (CharsetID: 20; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE; AllowReverseLookup: true),
175     (CharsetID: 21; CharSetName: 'ISO8859_1'; CharSetWidth: 1; CodePage: 28591; AllowReverseLookup: true),
176     (CharsetID: 22; CharSetName: 'ISO8859_2'; CharSetWidth: 1; CodePage: 28592; AllowReverseLookup: true),
177     (CharsetID: 23; CharSetName: 'ISO8859_3'; CharSetWidth: 1; CodePage: 28593; AllowReverseLookup: true),
178     (CharsetID: 24; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE; AllowReverseLookup: false),
179     (CharsetID: 25; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE; AllowReverseLookup: false),
180     (CharsetID: 26; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE; AllowReverseLookup: false),
181     (CharsetID: 27; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE; AllowReverseLookup: false),
182     (CharsetID: 28; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE; AllowReverseLookup: false),
183     (CharsetID: 29; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE; AllowReverseLookup: false),
184     (CharsetID: 30; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE; AllowReverseLookup: false),
185     (CharsetID: 31; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE; AllowReverseLookup: false),
186     (CharsetID: 32; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE; AllowReverseLookup: false),
187     (CharsetID: 33; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE; AllowReverseLookup: false),
188     (CharsetID: 34; CharSetName: 'ISO8859_4'; CharSetWidth: 1; CodePage: 28594; AllowReverseLookup: true),
189     (CharsetID: 35; CharSetName: 'ISO8859_5'; CharSetWidth: 1; CodePage: 28595; AllowReverseLookup: true),
190     (CharsetID: 36; CharSetName: 'ISO8859_6'; CharSetWidth: 1; CodePage: 28596; AllowReverseLookup: true),
191     (CharsetID: 37; CharSetName: 'ISO8859_7'; CharSetWidth: 1; CodePage: 28597; AllowReverseLookup: true),
192     (CharsetID: 38; CharSetName: 'ISO8859_8'; CharSetWidth: 1; CodePage: 28598; AllowReverseLookup: true),
193     (CharsetID: 39; CharSetName: 'ISO8859_9'; CharSetWidth: 1; CodePage: 28599; AllowReverseLookup: true),
194     (CharsetID: 40; CharSetName: 'ISO8859_13'; CharSetWidth: 1; CodePage: 28603; AllowReverseLookup: true),
195     (CharsetID: 41; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE; AllowReverseLookup: false),
196     (CharsetID: 42; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE; AllowReverseLookup: false),
197     (CharsetID: 43; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE; AllowReverseLookup: false),
198     (CharsetID: 44; CharSetName: 'KSC_5601'; CharSetWidth: 2; CodePage: 949; AllowReverseLookup: true),
199     (CharsetID: 45; CharSetName: 'DOS852'; CharSetWidth: 1; CodePage: 852; AllowReverseLookup: true),
200     (CharsetID: 46; CharSetName: 'DOS857'; CharSetWidth: 1; CodePage: 857; AllowReverseLookup: true),
201     (CharsetID: 47; CharSetName: 'DOS861'; CharSetWidth: 1; CodePage: 861; AllowReverseLookup: true),
202     (CharsetID: 48; CharSetName: 'DOS866'; CharSetWidth: 1; CodePage: 866; AllowReverseLookup: true),
203     (CharsetID: 49; CharSetName: 'DOS869'; CharSetWidth: 1; CodePage: 869; AllowReverseLookup: true),
204     (CharsetID: 50; CharSetName: 'CYRL'; CharSetWidth: 1; CodePage: 1251; AllowReverseLookup: true),
205     (CharsetID: 51; CharSetName: 'WIN1250'; CharSetWidth: 1; CodePage: 1250; AllowReverseLookup: true),
206     (CharsetID: 52; CharSetName: 'WIN1251'; CharSetWidth: 1; CodePage: 1251; AllowReverseLookup: true),
207     (CharsetID: 53; CharSetName: 'WIN1252'; CharSetWidth: 1; CodePage: 1252; AllowReverseLookup: true),
208     (CharsetID: 54; CharSetName: 'WIN1253'; CharSetWidth: 1; CodePage: 1253; AllowReverseLookup: true),
209     (CharsetID: 55; CharSetName: 'WIN1254'; CharSetWidth: 1; CodePage: 1254; AllowReverseLookup: true),
210     (CharsetID: 56; CharSetName: 'BIG_5'; CharSetWidth: 2; CodePage: 950; AllowReverseLookup: true),
211     (CharsetID: 57; CharSetName: 'GB_2312'; CharSetWidth: 2; CodePage: 936; AllowReverseLookup: true),
212     (CharsetID: 58; CharSetName: 'WIN1255'; CharSetWidth: 1; CodePage: 1255; AllowReverseLookup: true),
213     (CharsetID: 59; CharSetName: 'WIN1256'; CharSetWidth: 1; CodePage: 1256; AllowReverseLookup: true),
214     (CharsetID: 60; CharSetName: 'WIN1257'; CharSetWidth: 1; CodePage: 1257; AllowReverseLookup: true),
215     (CharsetID: 61; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE; AllowReverseLookup: false),
216     (CharsetID: 62; CharSetName: 'Unknown'; CharSetWidth: 0; CodePage: CP_NONE; AllowReverseLookup: false),
217     (CharsetID: 63; CharSetName: 'KOI8R'; CharSetWidth: 1; CodePage: 20866; AllowReverseLookup: true),
218     (CharsetID: 64; CharSetName: 'KOI8U'; CharSetWidth: 1; CodePage: 21866; AllowReverseLookup: true),
219     (CharsetID: 65; CharSetName: 'WIN1258'; CharSetWidth: 1; CodePage: 1258; AllowReverseLookup: true),
220     (CharsetID: 66; CharSetName: 'TIS620'; CharSetWidth: 1; CodePage: 874; AllowReverseLookup: true),
221     (CharsetID: 67; CharSetName: 'GBK'; CharSetWidth: 2; CodePage: 936; AllowReverseLookup: true),
222     (CharsetID: 68; CharSetName: 'CP943C'; CharSetWidth: 2; CodePage: 943; AllowReverseLookup: true),
223     (CharsetID: 69; CharSetName: 'GB18030'; CharSetWidth: 4; CodePage: 54936; AllowReverseLookup: true)
224     );
225    
226    
227    
228    
229 tony 45 { TFBAttachment }
230    
231 tony 117 procedure TFBAttachment.GetODSAndConnectionInfo;
232     var DBInfo: IDBInformation;
233     i: integer;
234     Stmt: IStatement;
235     ResultSet: IResultSet;
236     Param: IDPBItem;
237     begin
238     if not IsConnected then Exit;
239     DBInfo := GetDBInformation([isc_info_db_id,isc_info_ods_version,isc_info_ods_minor_version,
240     isc_info_db_SQL_Dialect]);
241     for i := 0 to DBInfo.GetCount - 1 do
242     with DBInfo[i] do
243     case getItemType of
244     isc_info_ods_minor_version:
245     FODSMinorVersion := getAsInteger;
246     isc_info_ods_version:
247     FODSMajorVersion := getAsInteger;
248     isc_info_db_SQL_Dialect:
249     FSQLDialect := getAsInteger;
250     end;
251    
252 tony 143 FCharSetID := 0;
253     FRemoteProtocol := '';
254     FAuthMethod := 'Legacy_Auth';
255     if FODSMajorVersion > 11 then
256 tony 117 begin
257     Stmt := Prepare(StartTransaction([isc_tpb_read,isc_tpb_nowait,isc_tpb_concurrency],taCommit),
258 tony 143 'Select MON$CHARACTER_SET_ID, MON$REMOTE_PROTOCOL, MON$AUTH_METHOD From MON$ATTACHMENTS '+
259     'Where MON$ATTACHMENT_ID = CURRENT_CONNECTION');
260     ResultSet := Stmt.OpenCursor;
261     if ResultSet.FetchNext then
262     begin
263     FCharSetID := ResultSet[0].AsInteger;
264     FRemoteProtocol := ResultSet[1].AsString;
265     FAuthMethod := ResultSet[2].AsString;
266     end
267     end
268     else
269     if (FODSMajorVersion = 11) and (FODSMinorVersion >= 1) then
270     begin
271     Stmt := Prepare(StartTransaction([isc_tpb_read,isc_tpb_nowait,isc_tpb_concurrency],taCommit),
272 tony 117 'Select MON$CHARACTER_SET_ID, MON$REMOTE_PROTOCOL From MON$ATTACHMENTS '+
273     'Where MON$ATTACHMENT_ID = CURRENT_CONNECTION');
274     ResultSet := Stmt.OpenCursor;
275     if ResultSet.FetchNext then
276     begin
277     FCharSetID := ResultSet[0].AsInteger;
278     FRemoteProtocol := ResultSet[1].AsString;
279     end
280     end
281     else
282     if DPB <> nil then
283     begin
284     Param := DPB.Find(isc_dpb_lc_ctype);
285     if (Param = nil) or not CharSetName2CharSetID(Param.AsString,FCharSetID) then
286     FCharSetID := 0;
287 tony 143 case GetProtocol(FDatabaseName) of
288     TCP: FRemoteProtocol := 'TCPv4';
289     Local: FRemoteProtocol := '';
290     NamedPipe: FRemoteProtocol := 'Netbui';
291     SPX: FRemoteProtocol := 'SPX'
292     end;
293 tony 117 end;
294     FHasDefaultCharSet := CharSetID2CodePage(FCharSetID,FCodePage) and (FCharSetID > 1);
295     end;
296    
297 tony 56 constructor TFBAttachment.Create(DatabaseName: AnsiString; DPB: IDPB;
298 tony 45 RaiseExceptionOnConnectError: boolean);
299     begin
300     inherited Create;
301     FFirebirdAPI := FirebirdAPI; {Keep reference to interface}
302     FSQLDialect := 3;
303     FDatabaseName := DatabaseName;
304     FDPB := DPB;
305 tony 60 SetLength(FUserCharSetMap,0);
306 tony 45 FRaiseExceptionOnConnectError := RaiseExceptionOnConnectError;
307 tony 117 FODSMajorVersion := 0;
308     FODSMinorVersion := 0;
309 tony 45 end;
310    
311 tony 56 function TFBAttachment.GenerateCreateDatabaseSQL(DatabaseName: AnsiString; aDPB: IDPB): AnsiString;
312     var CreateParams: AnsiString;
313 tony 45 DPBItem: IDPBItem;
314     begin
315     CreateParams := '';
316    
317     if aDPB <> nil then
318     begin
319     DPBItem := aDPB.Find(isc_dpb_user_name);
320     if DPBItem <> nil then
321 tony 56 CreateParams := CreateParams + ' USER ''' + DPBItem.AsString + '''';
322 tony 45
323     DPBItem := aDPB.Find(isc_dpb_password);
324     if DPBItem <> nil then
325 tony 56 CreateParams := CreateParams + ' Password ''' + DPBItem.AsString + '''';
326 tony 45
327     DPBItem := aDPB.Find(isc_dpb_page_size);
328     if DPBItem <> nil then
329 tony 56 CreateParams := CreateParams + ' PAGE_SIZE ' + DPBItem.AsString;
330 tony 45
331     DPBItem := aDPB.Find(isc_dpb_lc_ctype);
332     if DPBItem <> nil then
333 tony 56 CreateParams := CreateParams + ' DEFAULT CHARACTER SET ' + DPBItem.AsString;
334 tony 45
335     DPBItem := aDPB.Find(isc_dpb_sql_dialect);
336     if DPBItem <> nil then
337     FSQLDialect := DPBItem.AsInteger;
338     end;
339    
340     Result := 'CREATE DATABASE ''' + DatabaseName + ''' ' + CreateParams; {do not localize}
341     end;
342    
343     procedure TFBAttachment.EndAllTransactions;
344     var i: integer;
345     intf: TInterfacedObject;
346     begin
347     for i := 0 to InterfaceCount - 1 do
348     begin
349     intf := GetInterface(i);
350     if (intf <> nil) and (intf is TFBTransaction) then
351     TFBTransaction(intf).DoDefaultTransactionEnd(true);
352     end;
353     end;
354    
355 tony 118 {$IFDEF HASREQEX}
356 tony 117 procedure TFBAttachment.DPBFromCreateSQL(CreateSQL: AnsiString);
357     var RegexObj: TRegExpr;
358     begin
359     FDPB := FFirebirdAPI.AllocateDPB;
360     RegexObj := TRegExpr.Create;
361     try
362     {extact database file spec}
363     RegexObj.ModifierG := false; {turn off greedy matches}
364     RegexObj.ModifierI := true; {case insensitive match}
365     RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''.*'' +USER +''(.+)'' PASSWORD +''(.+)''';
366     if RegexObj.Exec(CreateSQL) then
367     begin
368     DPB.Add(isc_dpb_user_name).AsString := system.copy(CreateSQL,RegexObj.MatchPos[2],RegexObj.MatchLen[2]);
369     DPB.Add(isc_dpb_password).AsString := system.copy(CreateSQL,RegexObj.MatchPos[3],RegexObj.MatchLen[3]);
370     end
371     else
372     begin
373     RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +(''.*'') +USER +''(.+)''';
374     if RegexObj.Exec(CreateSQL) then
375     DPB.Add(isc_dpb_user_name).AsString := system.copy(CreateSQL,RegexObj.MatchPos[2],RegexObj.MatchLen[2]);
376     end;
377     finally
378     RegexObj.Free;
379     end;
380     if FCharSetID > 0 then
381     DPB.Add(isc_dpb_lc_ctype).AsString := GetCharSetName(FCharSetID);
382     DPB.Add(isc_dpb_set_db_SQL_dialect).setAsByte(FSQLDialect);
383     end;
384 tony 118 {$ELSE}
385     procedure TFBAttachment.DPBFromCreateSQL(CreateSQL: AnsiString);
386 tony 119 begin
387     FDPB := FFirebirdAPI.AllocateDPB;
388     if FCharSetID > 0 then
389     DPB.Add(isc_dpb_lc_ctype).AsString := GetCharSetName(FCharSetID);
390     DPB.Add(isc_dpb_set_db_SQL_dialect).setAsByte(FSQLDialect);
391 tony 118 end;
392     {$ENDIF}
393 tony 117
394 tony 45 procedure TFBAttachment.SetParameters(SQLParams: ISQLParams;
395     params: array of const);
396     var i: integer;
397     begin
398     if SQLParams.Count <> Length(params) then
399     IBError(ibxeInvalidParamCount,[SQLParams.Count,Length(params)]);
400    
401     for i := 0 to High(params) do
402     begin
403     case params[i].vtype of
404     vtinteger :
405     SQLParams[i].AsInteger := params[i].vinteger;
406 tony 70 vtInt64:
407     SQLParams[i].AsInt64 := params[i].VInt64^;
408     {$IF declared (vtQWord)}
409     vtQWord:
410     SQLParams[i].AsInt64 := params[i].VQWord^;
411     {$IFEND}
412 tony 45 vtboolean :
413     SQLParams[i].AsBoolean := params[i].vboolean;
414     vtchar :
415     SQLParams[i].AsString := params[i].vchar;
416     vtextended :
417     SQLParams[i].AsDouble := params[i].VExtended^;
418     vtCurrency:
419     SQLParams[i].AsDouble := params[i].VCurrency^;
420     vtString :
421 tony 70 SQLParams[i].AsString := strpas(PChar(params[i].VString));
422 tony 45 vtPChar :
423     SQLParams[i].AsString := strpas(params[i].VPChar);
424     vtAnsiString :
425 tony 70 SQLParams[i].AsString := strpas(PAnsiChar(params[i].VAnsiString));
426 tony 45 vtVariant:
427     SQLParams[i].AsVariant := params[i].VVariant^;
428 tony 70 vtWideChar:
429     SQLParams[i].AsString := UTF8Encode(WideCharLenToString(@params[i].VWideChar,1));
430     vtPWideChar:
431     SQLParams[i].AsString := UTF8Encode(strpas(PWideChar(params[i].VPWideChar)));
432     vtWideString:
433     SQLParams[i].AsString := UTF8Encode(strpas(PWideChar(params[i].VWideString)));
434     vtUnicodeString:
435     SQLParams[i].AsString := UTF8Encode(strpas(PWideChar(params[i].VUnicodeString)));
436 tony 45 else
437     IBError(ibxeInvalidVariantType,[nil]);
438     end;
439     end;
440     end;
441    
442     destructor TFBAttachment.Destroy;
443     begin
444     Disconnect(true);
445     inherited Destroy;
446     end;
447    
448     function TFBAttachment.getDPB: IDPB;
449     begin
450     Result := FDPB;
451     end;
452    
453     function TFBAttachment.AllocateBPB: IBPB;
454     begin
455     Result := TBPB.Create;
456     end;
457    
458 tony 143 function TFBAttachment.AllocateDIRB: IDIRB;
459     begin
460     Result := TDIRB.Create;
461     end;
462    
463 tony 56 procedure TFBAttachment.ExecImmediate(TPB: array of byte; sql: AnsiString;
464 tony 45 aSQLDialect: integer);
465     begin
466     ExecImmediate(StartTransaction(TPB,taCommit),sql,aSQLDialect);
467     end;
468    
469 tony 56 procedure TFBAttachment.ExecImmediate(transaction: ITransaction; sql: AnsiString);
470 tony 45 begin
471     ExecImmediate(transaction,sql,FSQLDialect);
472     end;
473    
474 tony 56 procedure TFBAttachment.ExecImmediate(TPB: array of byte; sql: AnsiString);
475 tony 45 begin
476     ExecImmediate(StartTransaction(TPB,taCommit),sql,FSQLDialect);
477     end;
478    
479 tony 56 function TFBAttachment.ExecuteSQL(TPB: array of byte; sql: AnsiString;
480 tony 45 SQLDialect: integer; params: array of const): IResults;
481     begin
482 tony 117 Result := ExecuteSQL(StartTransaction(TPB,taCommit),sql,SQLDialect,params);
483 tony 45 end;
484    
485 tony 56 function TFBAttachment.ExecuteSQL(transaction: ITransaction; sql: AnsiString;
486 tony 45 SQLDialect: integer; params: array of const): IResults;
487     begin
488     with Prepare(transaction,sql,SQLDialect) do
489     begin
490     SetParameters(SQLParams,params);
491     Result := Execute;
492     end;
493     end;
494    
495 tony 56 function TFBAttachment.ExecuteSQL(TPB: array of byte; sql: AnsiString;
496 tony 45 params: array of const): IResults;
497     begin
498     Result := ExecuteSQL(StartTransaction(TPB,taCommit),sql,params);
499     end;
500    
501 tony 56 function TFBAttachment.ExecuteSQL(transaction: ITransaction; sql: AnsiString;
502 tony 45 params: array of const): IResults;
503     begin
504     with Prepare(transaction,sql,FSQLDialect) do
505     begin
506     SetParameters(SQLParams,params);
507     Result := Execute;
508     end;
509     end;
510    
511 tony 56 function TFBAttachment.OpenCursor(transaction: ITransaction; sql: AnsiString;
512 tony 45 aSQLDialect: integer): IResultSet;
513     begin
514     Result := OpenCursor(transaction,sql,aSQLDialect,[]);
515     end;
516    
517 tony 56 function TFBAttachment.OpenCursor(transaction: ITransaction; sql: AnsiString;
518 tony 45 aSQLDialect: integer; params: array of const): IResultSet;
519     var Statement: IStatement;
520     begin
521     CheckHandle;
522     Statement := Prepare(transaction,sql,aSQLDialect);
523     SetParameters(Statement.SQLParams,params);
524     Result := Statement.OpenCursor;
525     end;
526    
527 tony 56 function TFBAttachment.OpenCursor(transaction: ITransaction; sql: AnsiString
528 tony 45 ): IResultSet;
529     begin
530     Result := OpenCursor(transaction,sql,FSQLDialect,[]);
531     end;
532    
533 tony 56 function TFBAttachment.OpenCursor(transaction: ITransaction; sql: AnsiString;
534 tony 45 params: array of const): IResultSet;
535     begin
536     Result := OpenCursor(transaction,sql,FSQLDialect,params);
537     end;
538    
539     function TFBAttachment.OpenCursorAtStart(transaction: ITransaction;
540 tony 56 sql: AnsiString; aSQLDialect: integer): IResultSet;
541 tony 45 begin
542     Result := OpenCursor(transaction,sql,aSQLDialect,[]);
543     Result.FetchNext;
544     end;
545    
546     function TFBAttachment.OpenCursorAtStart(transaction: ITransaction;
547 tony 56 sql: AnsiString; aSQLDialect: integer; params: array of const): IResultSet;
548 tony 45 begin
549     Result := OpenCursor(transaction,sql,aSQLDialect,params);
550     Result.FetchNext;
551     end;
552    
553 tony 56 function TFBAttachment.OpenCursorAtStart(transaction: ITransaction; sql: AnsiString
554 tony 45 ): IResultSet;
555     begin
556     Result := OpenCursorAtStart(transaction,sql,FSQLDialect,[]);
557     end;
558    
559     function TFBAttachment.OpenCursorAtStart(transaction: ITransaction;
560 tony 56 sql: AnsiString; params: array of const): IResultSet;
561 tony 45 begin
562     Result := OpenCursorAtStart(transaction,sql,FSQLDialect,params);
563     end;
564    
565 tony 56 function TFBAttachment.OpenCursorAtStart(sql: AnsiString): IResultSet;
566 tony 45 begin
567     Result := OpenCursorAtStart(sql,[]);
568     end;
569    
570 tony 56 function TFBAttachment.OpenCursorAtStart(sql: AnsiString;
571 tony 45 params: array of const): IResultSet;
572     begin
573     Result := OpenCursorAtStart(StartTransaction([isc_tpb_read,isc_tpb_wait,isc_tpb_concurrency],taCommit),sql,FSQLDialect,params);
574     end;
575    
576 tony 56 function TFBAttachment.Prepare(transaction: ITransaction; sql: AnsiString
577 tony 45 ): IStatement;
578     begin
579     Result := Prepare(transaction,sql,FSQLDialect);
580     end;
581    
582     function TFBAttachment.PrepareWithNamedParameters(transaction: ITransaction;
583 tony 56 sql: AnsiString; GenerateParamNames: boolean): IStatement;
584 tony 45 begin
585     Result := PrepareWithNamedParameters(transaction,sql,FSQLDialect,GenerateParamNames);
586     end;
587    
588 tony 56 function TFBAttachment.GetEventHandler(Event: AnsiString): IEvents;
589 tony 45 var S: TStringList;
590     begin
591     S := TStringList.Create;
592     try
593     S.Add(Event);
594     Result := GetEventHandler(S);
595     finally
596     S.Free;
597     end;
598     end;
599    
600     function TFBAttachment.GetSQLDialect: integer;
601     begin
602     Result := FSQLDialect;
603     end;
604    
605     function TFBAttachment.OpenBlob(transaction: ITransaction; Field: ISQLData;
606     BPB: IBPB): IBlob;
607     begin
608     Result := OpenBlob(Transaction,Field.GetBlobMetadata, Field.AsQuad,BPB);
609     end;
610    
611 tony 143 function TFBAttachment.GetDBInformation(Requests: array of byte
612     ): IDBInformation;
613     var ReqBuffer: PByte;
614     i: integer;
615     begin
616     CheckHandle;
617     if Length(Requests) = 1 then
618     Result := GetDBInformation(Requests[0])
619     else
620     begin
621     GetMem(ReqBuffer,Length(Requests));
622     try
623     for i := 0 to Length(Requests) - 1 do
624     ReqBuffer[i] := Requests[i];
625    
626     Result := GetDBInfo(ReqBuffer,Length(Requests));
627    
628     finally
629     FreeMem(ReqBuffer);
630     end;
631     end;
632     end;
633    
634     function TFBAttachment.GetDBInformation(Request: byte): IDBInformation;
635     begin
636     CheckHandle;
637     Result := GetDBInfo(@Request,1);
638     end;
639    
640     function TFBAttachment.GetDBInformation(Requests: IDIRB): IDBInformation;
641     begin
642     CheckHandle;
643     with Requests as TDIRB do
644     Result := GetDBInfo(getBuffer,getDataLength);
645     end;
646    
647 tony 117 function TFBAttachment.GetConnectString: AnsiString;
648     begin
649     Result := FDatabaseName;
650     end;
651    
652     function TFBAttachment.GetRemoteProtocol: AnsiString;
653     begin
654     Result := FRemoteProtocol;
655     end;
656    
657 tony 143 function TFBAttachment.GetAuthenticationMethod: AnsiString;
658     begin
659     Result := FAuthMethod;
660     end;
661    
662 tony 117 function TFBAttachment.GetODSMajorVersion: integer;
663     begin
664     Result := FODSMajorVersion;
665     end;
666    
667     function TFBAttachment.GetODSMinorVersion: integer;
668     begin
669     Result := FODSMinorVersion;
670     end;
671    
672 tony 109 function TFBAttachment.HasDefaultCharSet: boolean;
673     begin
674     Result := FHasDefaultCharSet
675     end;
676    
677     function TFBAttachment.GetDefaultCharSetID: integer;
678     begin
679     Result := FCharsetID;
680     end;
681    
682 tony 60 function TFBAttachment.GetCharsetName(CharSetID: integer): AnsiString;
683     var i: integer;
684     begin
685     Result := '';
686     if (CharSetID >= Low(CharSetMap)) and (CharSetID <= High(CharSetMap)) and
687     (CharSetMap[CharSetID].CharSetID = CharSetID) then
688     begin
689     Result := CharSetMap[CharSetID].CharSetName;
690     Exit;
691     end;
692    
693     for i := 0 to Length(FUserCharSetMap) - 1 do
694     if FUserCharSetMap[i].CharSetID = CharSetID then
695     begin
696     Result := FUserCharSetMap[i].CharSetName;
697     Exit;
698     end;
699     end;
700    
701     function TFBAttachment.CharSetID2CodePage(CharSetID: integer;
702     var CodePage: TSystemCodePage): boolean;
703     var i: integer;
704     begin
705     Result := (CharSetID >= Low(CharSetMap)) and (CharSetID <= High(CharSetMap))
706     and (CharSetMap[CharSetID].CharSetID = CharSetID);
707     if Result then
708     begin
709     CodePage := CharSetMap[CharSetID].CodePage;
710     Result := true;
711     Exit;
712     end;
713    
714     for i := 0 to Length(FUserCharSetMap) - 1 do
715     if FUserCharSetMap[i].CharSetID = CharSetID then
716     begin
717     CodePage := FUserCharSetMap[i].CodePage;
718     Result := true;
719     Exit;
720     end;
721     end;
722    
723     function TFBAttachment.CodePage2CharSetID(CodePage: TSystemCodePage;
724     var CharSetID: integer): boolean;
725     var i: integer;
726     begin
727     Result := false;
728     for i := Low(CharSetMap) to High(CharSetMap) do
729     if (CharSetMap[i].AllowReverseLookup) and (CharSetMap[i].CodePage = CodePage) then
730     begin
731     CharSetID := CharSetMap[i].CharSetID;
732     Result := true;
733     Exit;
734     end;
735    
736     for i := 0 to Length(FUserCharSetMap) - 1 do
737     if (FUserCharSetMap[i].AllowReverseLookup) and (FUserCharSetMap[i].CodePage = CodePage) then
738     begin
739     CharSetID := FUserCharSetMap[i].CharSetID;
740     Result := true;
741     Exit;
742     end;
743     end;
744    
745     function TFBAttachment.CharSetName2CharSetID(CharSetName: AnsiString;
746     var CharSetID: integer): boolean;
747     var i: integer;
748     begin
749     Result := false;
750     for i := Low(CharSetMap) to High(CharSetMap) do
751     if AnsiCompareStr(CharSetMap[i].CharSetName, CharSetName) = 0 then
752     begin
753     CharSetID := CharSetMap[i].CharSetID;
754     Result := true;
755     Exit;
756     end;
757    
758     for i := 0 to Length(FUserCharSetMap) - 1 do
759     if AnsiCompareStr(FUserCharSetMap[i].CharSetName, CharSetName) = 0 then
760     begin
761     CharSetID := FUserCharSetMap[i].CharSetID;
762     Result := true;
763     Exit;
764     end;
765     end;
766    
767     function TFBAttachment.CharSetWidth(CharSetID: integer; var Width: integer
768     ): boolean;
769     var i: integer;
770     begin
771     Result := (CharSetID >= Low(CharSetMap)) and (CharSetID <= High(CharSetMap))
772     and (CharSetMap[CharSetID].CharSetID = CharSetID);
773     if Result then
774     begin
775     Width := CharSetMap[CharSetID].CharSetWidth;
776     Result := true;
777     Exit;
778     end;
779    
780     for i := 0 to Length(FUserCharSetMap) - 1 do
781     if FUserCharSetMap[i].CharSetID = CharSetID then
782     begin
783     Width := FUserCharSetMap[i].CharSetWidth;
784     Result := true;
785     Exit;
786     end;
787     end;
788    
789     const
790     sqlLookupCharSet = 'Select RDB$CHARACTER_SET_ID, RDB$BYTES_PER_CHARACTER From RDB$CHARACTER_SETS '+
791     'Where RDB$SYSTEM_FLAG = 0 and RDB$CHARACTER_SET_NAME = UPPER(?)';
792    
793     procedure TFBAttachment.RegisterCharSet(CharSetName: AnsiString;
794     CodePage: TSystemCodePage; AllowReverseLookup: boolean; out CharSetID: integer
795     );
796     var CharSets: IResultSet;
797     idx: integer;
798     begin
799     if CharSetName2CharSetID(CharSetName,CharSetID) then
800     IBError(ibxeCharacterSetExists,[CharSetName]);
801    
802     CharSets := OpenCursorAtStart(sqlLookupCharSet,[CharSetName]);
803     if CharSets.IsEof then
804     IBError(ibxeUnknownUserCharSet,[CharSetName]);
805    
806     idx := Length(FUserCharSetMap);
807     SetLength(FUserCharSetMap,idx+1);
808     FUserCharSetMap[idx].AllowReverseLookup := AllowReverseLookup;
809     FUserCharSetMap[idx].CharSetID := CharSets[0].AsInteger;
810     FUserCharSetMap[idx].CharSetName := AnsiUpperCase(CharSetName);
811     FUserCharSetMap[idx].CharSetWidth := CharSets[1].AsInteger;
812     FUserCharSetMap[idx].CodePage := CodePage;
813     CharSetID := CharSets[0].AsInteger;
814     end;
815    
816 tony 45 end.
817