ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IB.pas
(Generate patch)

Comparing ibx/trunk/runtime/IB.pas (file contents):
Revision 16 by tony, Sun Aug 5 18:28:19 2012 UTC vs.
Revision 17 by tony, Sat Dec 28 19:22:24 2013 UTC

# Line 1 | Line 1
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.
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.

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines