ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IB.pas
Revision: 5
Committed: Fri Feb 18 16:26:16 2011 UTC (13 years, 1 month ago) by tony
Content type: text/x-pascal
File size: 14027 byte(s)
Log Message:
Committing updates for Release pre-release

File Contents

# User Rev Content
1 tony 1 {************************************************************************}
2     { }
3     { Borland Delphi Visual Component Library }
4     { InterBase Express core components }
5     { }
6     { Copyright (c) 1998-2000 Inprise Corporation }
7     { }
8     { InterBase Express is based in part on the product }
9     { Free IB Components, written by Gregory H. Deatz for }
10     { Hoagland, Longo, Moran, Dunst & Doukas Company. }
11     { Free IB Components is used under license. }
12     { }
13     { The contents of this file are subject to the InterBase }
14     { Public License Version 1.0 (the "License"); you may not }
15     { use this file except in compliance with the License. You }
16     { may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17     { Software distributed under the License is distributed on }
18     { an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
19     { express or implied. See the License for the specific language }
20     { governing rights and limitations under the License. }
21     { The Original Code was created by InterBase Software Corporation }
22     { and its successors. }
23     { Portions created by Inprise Corporation are Copyright (C) Inprise }
24     { Corporation. All Rights Reserved. }
25     { Contributor(s): Jeff Overcash }
26     { }
27     {************************************************************************}
28    
29     unit IB;
30    
31 tony 5 {$Mode Delphi}
32    
33 tony 1 interface
34    
35     uses
36 tony 5 {$IFDEF LINUX }
37     unix,
38     {$ELSE}
39     Windows,
40     {$ENDIF}
41     SysUtils, Classes, IBExternals, IBUtils, DB, IBXConst;
42 tony 1
43     type
44     TTraceFlag = (tfQPrepare, tfQExecute, tfQFetch, tfError, tfStmt, tfConnect,
45     tfTransact, tfBlob, tfService, tfMisc);
46     TTraceFlags = set of TTraceFlag;
47    
48     EIBError = class(EDatabaseError)
49     private
50     FSQLCode: Long;
51     FIBErrorCode: Long;
52     public
53     constructor Create(ASQLCode: Long; Msg: string); overload;
54     constructor Create(ASQLCode: Long; AIBErrorCode: Long; Msg: string); overload;
55     property SQLCode: Long read FSQLCode;
56     property IBErrorCode: Long read FIBErrorCode;
57     end;
58    
59     EIBInterBaseError = class(EIBError);
60     EIBClientError = class(EIBError);
61    
62     TIBDataBaseErrorMessage = (ShowSQLCode,
63     ShowIBMessage,
64     ShowSQLMessage);
65     TIBDataBaseErrorMessages = set of TIBDataBaseErrorMessage;
66     TIBClientError = (
67     ibxeUnknownError,
68     ibxeInterBaseMissing,
69     ibxeInterBaseInstallMissing,
70     ibxeIB60feature,
71     ibxeNotSupported,
72     ibxeNotPermitted,
73     ibxeFileAccessError,
74     ibxeConnectionTimeout,
75     ibxeCannotSetDatabase,
76     ibxeCannotSetTransaction,
77     ibxeOperationCancelled,
78     ibxeDPBConstantNotSupported,
79     ibxeDPBConstantUnknown,
80     ibxeTPBConstantNotSupported,
81     ibxeTPBConstantUnknown,
82     ibxeDatabaseClosed,
83     ibxeDatabaseOpen,
84     ibxeDatabaseNameMissing,
85     ibxeNotInTransaction,
86     ibxeInTransaction,
87     ibxeTimeoutNegative,
88     ibxeNoDatabasesInTransaction,
89     ibxeUpdateWrongDB,
90     ibxeUpdateWrongTR,
91     ibxeDatabaseNotAssigned,
92     ibxeTransactionNotAssigned,
93     ibxeXSQLDAIndexOutOfRange,
94     ibxeXSQLDANameDoesNotExist,
95     ibxeEOF,
96     ibxeBOF,
97     ibxeInvalidStatementHandle,
98     ibxeSQLOpen,
99     ibxeSQLClosed,
100     ibxeDatasetOpen,
101     ibxeDatasetClosed,
102     ibxeUnknownSQLDataType,
103     ibxeInvalidColumnIndex,
104     ibxeInvalidParamColumnIndex,
105     ibxeInvalidDataConversion,
106     ibxeColumnIsNotNullable,
107     ibxeBlobCannotBeRead,
108     ibxeBlobCannotBeWritten,
109     ibxeEmptyQuery,
110     ibxeCannotOpenNonSQLSelect,
111     ibxeNoFieldAccess,
112     ibxeFieldReadOnly,
113     ibxeFieldNotFound,
114     ibxeNotEditing,
115     ibxeCannotInsert,
116     ibxeCannotPost,
117     ibxeCannotUpdate,
118     ibxeCannotDelete,
119     ibxeCannotRefresh,
120     ibxeBufferNotSet,
121     ibxeCircularReference,
122     ibxeSQLParseError,
123     ibxeUserAbort,
124     ibxeDataSetUniDirectional,
125     ibxeCannotCreateSharedResource,
126     ibxeWindowsAPIError,
127     ibxeColumnListsDontMatch,
128     ibxeColumnTypesDontMatch,
129     ibxeCantEndSharedTransaction,
130     ibxeFieldUnsupportedType,
131     ibxeCircularDataLink,
132     ibxeEmptySQLStatement,
133     ibxeIsASelectStatement,
134     ibxeRequiredParamNotSet,
135     ibxeNoStoredProcName,
136     ibxeIsAExecuteProcedure,
137     ibxeUpdateFailed,
138     ibxeNotCachedUpdates,
139     ibxeNotLiveRequest,
140     ibxeNoProvider,
141     ibxeNoRecordsAffected,
142     ibxeNoTableName,
143     ibxeCannotCreatePrimaryIndex,
144     ibxeCannotDropSystemIndex,
145     ibxeTableNameMismatch,
146     ibxeIndexFieldMissing,
147     ibxeInvalidCancellation,
148     ibxeInvalidEvent,
149     ibxeMaximumEvents,
150     ibxeNoEventsRegistered,
151     ibxeInvalidQueueing,
152     ibxeInvalidRegistration,
153     ibxeInvalidBatchMove,
154     ibxeSQLDialectInvalid,
155     ibxeSPBConstantNotSupported,
156     ibxeSPBConstantUnknown,
157     ibxeServiceActive,
158     ibxeServiceInActive,
159     ibxeServerNameMissing,
160     ibxeQueryParamsError,
161     ibxeStartParamsError,
162     ibxeOutputParsingError,
163     ibxeUseSpecificProcedures,
164 tony 5 ibxeSQLMonitorAlreadyPresent,
165     ibxeCantPrintValue,
166     ibxeEOFReached,
167     ibxeEOFInComment,
168     ibxeEOFInString,
169     ibxeParamNameExpected,
170     ibxeSuccess,
171     ibxeDelphiException,
172     ibxeNoOptionsSet,
173     ibxeNoDestinationDirectory,
174     ibxeNosourceDirectory,
175     ibxeNoUninstallFile,
176     ibxeOptionNeedsClient,
177     ibxeOptionNeedsServer,
178     ibxeInvalidOption,
179     ibxeInvalidOnErrorResult,
180     ibxeInvalidOnStatusResult,
181     ibxeDPBConstantUnknownEx,
182     ibxeTPBConstantUnknownEx
183 tony 1 );
184    
185     TStatusVector = array[0..19] of ISC_STATUS;
186     PStatusVector = ^TStatusVector;
187    
188    
189     const
190 tony 5 IBPalette1 = 'Firebird'; {do not localize}
191     IBPalette2 = 'Firebird Admin'; {do not localize}
192 tony 1
193     IBLocalBufferLength = 512;
194     IBBigLocalBufferLength = IBLocalBufferLength * 2;
195     IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;
196    
197     IBErrorMessages: array[TIBClientError] of string = (
198     SUnknownError,
199     SInterBaseMissing,
200     SInterBaseInstallMissing,
201     SIB60feature,
202     SNotSupported,
203     SNotPermitted,
204     SFileAccessError,
205     SConnectionTimeout,
206     SCannotSetDatabase,
207     SCannotSetTransaction,
208     SOperationCancelled,
209     SDPBConstantNotSupported,
210     SDPBConstantUnknown,
211     STPBConstantNotSupported,
212     STPBConstantUnknown,
213     SDatabaseClosed,
214     SDatabaseOpen,
215     SDatabaseNameMissing,
216     SNotInTransaction,
217     SInTransaction,
218     STimeoutNegative,
219     SNoDatabasesInTransaction,
220     SUpdateWrongDB,
221     SUpdateWrongTR,
222     SDatabaseNotAssigned,
223     STransactionNotAssigned,
224     SXSQLDAIndexOutOfRange,
225     SXSQLDANameDoesNotExist,
226     SEOF,
227     SBOF,
228     SInvalidStatementHandle,
229     SSQLOpen,
230     SSQLClosed,
231     SDatasetOpen,
232     SDatasetClosed,
233     SUnknownSQLDataType,
234     SInvalidColumnIndex,
235     SInvalidParamColumnIndex,
236     SInvalidDataConversion,
237     SColumnIsNotNullable,
238     SBlobCannotBeRead,
239     SBlobCannotBeWritten,
240     SEmptyQuery,
241     SCannotOpenNonSQLSelect,
242     SNoFieldAccess,
243     SFieldReadOnly,
244     SFieldNotFound,
245     SNotEditing,
246     SCannotInsert,
247     SCannotPost,
248     SCannotUpdate,
249     SCannotDelete,
250     SCannotRefresh,
251     SBufferNotSet,
252     SCircularReference,
253     SSQLParseError,
254     SUserAbort,
255     SDataSetUniDirectional,
256     SCannotCreateSharedResource,
257     SWindowsAPIError,
258     SColumnListsDontMatch,
259     SColumnTypesDontMatch,
260     SCantEndSharedTransaction,
261     SFieldUnsupportedType,
262     SCircularDataLink,
263     SEmptySQLStatement,
264     SIsASelectStatement,
265     SRequiredParamNotSet,
266     SNoStoredProcName,
267     SIsAExecuteProcedure,
268     SUpdateFailed,
269     SNotCachedUpdates,
270     SNotLiveRequest,
271     SNoProvider,
272     SNoRecordsAffected,
273     SNoTableName,
274     SCannotCreatePrimaryIndex,
275     SCannotDropSystemIndex,
276     STableNameMismatch,
277     SIndexFieldMissing,
278     SInvalidCancellation,
279     SInvalidEvent,
280     SMaximumEvents,
281     SNoEventsRegistered,
282     SInvalidQueueing,
283     SInvalidRegistration,
284     SInvalidBatchMove,
285     SSQLDialectInvalid,
286     SSPBConstantNotSupported,
287     SSPBConstantUnknown,
288     SServiceActive,
289     SServiceInActive,
290     SServerNameMissing,
291     SQueryParamsError,
292     SStartParamsError,
293     SOutputParsingError,
294     SUseSpecificProcedures,
295 tony 5 SSQLMonitorAlreadyPresent,
296     SCantPrintValue,
297     SEOFReached,
298     SEOFInComment,
299     SEOFInString,
300     SParamNameExpected,
301     SSuccess,
302     SDelphiException,
303     SNoOptionsSet,
304     SNoDestinationDirectory,
305     SNosourceDirectory,
306     SNoUninstallFile,
307     SOptionNeedsClient,
308     SOptionNeedsServer,
309     SInvalidOption,
310     SInvalidOnErrorResult,
311     SInvalidOnStatusResult,
312     SDPBConstantUnknownEx,
313     STPBConstantUnknownEx
314 tony 1 );
315    
316     var
317     IBCS: TRTLCriticalSection;
318    
319     procedure IBAlloc(var P; OldSize, NewSize: Integer);
320    
321     procedure IBError(ErrMess: TIBClientError; const Args: array of const);
322     procedure IBDataBaseError;
323    
324     function StatusVector: PISC_STATUS;
325     function StatusVectorArray: PStatusVector;
326     function CheckStatusVector(ErrorCodes: array of ISC_STATUS): Boolean;
327     function StatusVectorAsText: string;
328    
329     procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
330     function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
331    
332     implementation
333    
334     uses
335     IBIntf;
336    
337     var
338     IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
339     threadvar
340     FStatusVector : TStatusVector;
341    
342     procedure IBAlloc(var P; OldSize, NewSize: Integer);
343     var
344     i: Integer;
345     begin
346     ReallocMem(Pointer(P), NewSize);
347     for i := OldSize to NewSize - 1 do PChar(P)[i] := #0;
348     end;
349    
350     procedure IBError(ErrMess: TIBClientError; const Args: array of const);
351     begin
352     raise EIBClientError.Create(Ord(ErrMess),
353     Format(IBErrorMessages[ErrMess], Args));
354     end;
355    
356     procedure IBDataBaseError;
357     var
358     sqlcode: Long;
359     IBErrorCode: Long;
360     local_buffer: array[0..IBHugeLocalBufferLength - 1] of char;
361     usr_msg: string;
362     status_vector: PISC_STATUS;
363     IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
364     begin
365     usr_msg := '';
366    
367     { Get a local reference to the status vector.
368     Get a local copy of the IBDataBaseErrorMessages options.
369     Get the SQL error code }
370     status_vector := StatusVector;
371     IBErrorCode := StatusVectorArray[1];
372     IBDataBaseErrorMessages := GetIBDataBaseErrorMessages;
373     sqlcode := isc_sqlcode(status_vector);
374    
375     if (ShowSQLCode in IBDataBaseErrorMessages) then
376     usr_msg := usr_msg + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
377     Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
378     if (ShowSQLMessage in IBDataBaseErrorMessages) then
379     begin
380     isc_sql_interprete(sqlcode, local_buffer, IBLocalBufferLength);
381     if (ShowSQLCode in IBDataBaseErrorMessages) then
382     usr_msg := usr_msg + CRLF;
383 tony 5 usr_msg := usr_msg + strpas(local_buffer);
384 tony 1 end;
385    
386     if (ShowIBMessage in IBDataBaseErrorMessages) then
387     begin
388     if (ShowSQLCode in IBDataBaseErrorMessages) or
389     (ShowSQLMessage in IBDataBaseErrorMessages) then
390     usr_msg := usr_msg + CRLF;
391     while (isc_interprete(local_buffer, @status_vector) > 0) do
392     begin
393     if (usr_msg <> '') and (usr_msg[Length(usr_msg)] <> LF) then
394     usr_msg := usr_msg + CRLF;
395 tony 5 usr_msg := usr_msg + strpas(local_buffer);
396 tony 1 end;
397     end;
398     if (usr_msg <> '') and (usr_msg[Length(usr_msg)] = '.') then
399     Delete(usr_msg, Length(usr_msg), 1);
400     raise EIBInterBaseError.Create(sqlcode, IBErrorCode, usr_msg);
401     end;
402    
403     { Return the status vector for the current thread }
404     function StatusVector: PISC_STATUS;
405     begin
406     result := @FStatusVector;
407     end;
408    
409     function StatusVectorArray: PStatusVector;
410     begin
411     result := @FStatusVector;
412     end;
413    
414     function CheckStatusVector(ErrorCodes: array of ISC_STATUS): Boolean;
415     var
416     p: PISC_STATUS;
417     i: Integer;
418     procedure NextP(i: Integer);
419     begin
420     p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
421     end;
422     begin
423     p := @FStatusVector;
424     result := False;
425     while (p^ <> 0) and (not result) do
426     case p^ of
427     3: NextP(3);
428     1, 4:
429     begin
430     NextP(1);
431     i := 0;
432     while (i <= High(ErrorCodes)) and (not result) do
433     begin
434     result := p^ = ErrorCodes[i];
435     Inc(i);
436     end;
437     NextP(1);
438     end;
439     else
440     NextP(2);
441     end;
442     end;
443    
444     function StatusVectorAsText: string;
445     var
446     p: PISC_STATUS;
447     function NextP(i: Integer): PISC_STATUS;
448     begin
449     p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
450     result := p;
451     end;
452     begin
453     p := @FStatusVector;
454     result := '';
455     while (p^ <> 0) do
456     if (p^ = 3) then
457     begin
458     result := result + Format('%d %d %d', [p^, NextP(1)^, NextP(1)^]) + CRLF;
459     NextP(1);
460     end
461     else begin
462     result := result + Format('%d %d', [p^, NextP(1)^]) + CRLF;
463     NextP(1);
464     end;
465     end;
466    
467    
468     { EIBError }
469     constructor EIBError.Create(ASQLCode: Long; Msg: string);
470     begin
471     inherited Create(Msg);
472     FSQLCode := ASQLCode;
473     end;
474    
475     constructor EIBError.Create(ASQLCode: Long; AIBErrorCode: Long; Msg: string);
476     begin
477     inherited Create(Msg);
478     FSQLCode := ASQLCode;
479     FIBErrorCode := AIBErrorCode;
480     end;
481    
482     procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
483     begin
484     EnterCriticalSection(IBCS);
485     try
486     IBDataBaseErrorMessages := Value;
487     finally
488     LeaveCriticalSection(IBCS);
489     end;
490     end;
491    
492     function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
493     begin
494     EnterCriticalSection(IBCS);
495     try
496     result := IBDataBaseErrorMessages;
497     finally
498     LeaveCriticalSection(IBCS);
499     end;
500     end;
501    
502     initialization
503     IsMultiThread := True;
504 tony 5 InitCriticalSection(IBCS);
505 tony 1 IBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];
506    
507     finalization
508 tony 5 DoneCriticalSection(IBCS);
509 tony 1
510     end.