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

# Content
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 {$Mode Delphi}
32
33 interface
34
35 uses
36 {$IFDEF LINUX }
37 unix,
38 {$ELSE}
39 Windows,
40 {$ENDIF}
41 SysUtils, Classes, IBExternals, IBUtils, DB, IBXConst;
42
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 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 );
184
185 TStatusVector = array[0..19] of ISC_STATUS;
186 PStatusVector = ^TStatusVector;
187
188
189 const
190 IBPalette1 = 'Firebird'; {do not localize}
191 IBPalette2 = 'Firebird Admin'; {do not localize}
192
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 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 );
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 usr_msg := usr_msg + strpas(local_buffer);
384 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 usr_msg := usr_msg + strpas(local_buffer);
396 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 InitCriticalSection(IBCS);
505 IBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];
506
507 finalization
508 DoneCriticalSection(IBCS);
509
510 end.