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