trunk/runtime/IB.pas

{************************************************************************}
{                                                                        }
{       Borland Delphi Visual Component Library                          }
{       InterBase Express core components                                }
{                                                                        }
{       Copyright (c) 1998-2000 Inprise Corporation                      }
{                                                                        }
{    InterBase Express is based in part on the product                   }
{    Free IB Components, written by Gregory H. Deatz for                 }
{    Hoagland, Longo, Moran, Dunst & Doukas Company.                     }
{    Free IB Components is used under license.                           }
{                                                                        }
{    The contents of this file are subject to the InterBase              }
{    Public License Version 1.0 (the "License"); you may not             }
{    use this file except in compliance with the License. You            }
{    may obtain a copy of the License at http://www.Inprise.com/IPL.html }
{    Software distributed under the License is distributed on            }
{    an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either              }
{    express or implied. See the License for the specific language       }
{    governing rights and limitations under the License.                 }
{    The Original Code was created by InterBase Software Corporation     }
{       and its successors.                                              }
{    Portions created by Inprise Corporation are Copyright (C) Inprise   }
{       Corporation. All Rights Reserved.                                }
{    Contributor(s): Jeff Overcash                                       }
{                                                                        }
{************************************************************************}

unit IB;

interface

uses
  Windows, SysUtils, Classes, IBHeader, IBExternals, IBUtils, DB, IBXConst;

type
  TTraceFlag = (tfQPrepare, tfQExecute, tfQFetch, tfError, tfStmt, tfConnect,
     tfTransact, tfBlob, tfService, tfMisc);
  TTraceFlags = set of TTraceFlag;

  EIBError                  = class(EDatabaseError)
  private
    FSQLCode: Long;
    FIBErrorCode: Long;
  public
    constructor Create(ASQLCode: Long; Msg: string); overload;
    constructor Create(ASQLCode: Long; AIBErrorCode: Long; Msg: string); overload;
    property SQLCode: Long read FSQLCode;
    property IBErrorCode: Long read FIBErrorCode;
  end;

  EIBInterBaseError         = class(EIBError);
  EIBClientError            = class(EIBError);

  TIBDataBaseErrorMessage    = (ShowSQLCode,
                                ShowIBMessage,
                                ShowSQLMessage);
  TIBDataBaseErrorMessages   = set of TIBDataBaseErrorMessage;
  TIBClientError            = (
    ibxeUnknownError,
    ibxeInterBaseMissing,
    ibxeInterBaseInstallMissing,
    ibxeIB60feature,
    ibxeNotSupported,
    ibxeNotPermitted,
    ibxeFileAccessError,
    ibxeConnectionTimeout,
    ibxeCannotSetDatabase,
    ibxeCannotSetTransaction,
    ibxeOperationCancelled,
    ibxeDPBConstantNotSupported,
    ibxeDPBConstantUnknown,
    ibxeTPBConstantNotSupported,
    ibxeTPBConstantUnknown,
    ibxeDatabaseClosed,
    ibxeDatabaseOpen,
    ibxeDatabaseNameMissing,
    ibxeNotInTransaction,
    ibxeInTransaction,
    ibxeTimeoutNegative,
    ibxeNoDatabasesInTransaction,
    ibxeUpdateWrongDB,
    ibxeUpdateWrongTR,
    ibxeDatabaseNotAssigned,
    ibxeTransactionNotAssigned,
    ibxeXSQLDAIndexOutOfRange,
    ibxeXSQLDANameDoesNotExist,
    ibxeEOF,
    ibxeBOF,
    ibxeInvalidStatementHandle,
    ibxeSQLOpen,
    ibxeSQLClosed,
    ibxeDatasetOpen,
    ibxeDatasetClosed,
    ibxeUnknownSQLDataType,
    ibxeInvalidColumnIndex,
    ibxeInvalidParamColumnIndex,
    ibxeInvalidDataConversion,
    ibxeColumnIsNotNullable,
    ibxeBlobCannotBeRead,
    ibxeBlobCannotBeWritten,
    ibxeEmptyQuery,
    ibxeCannotOpenNonSQLSelect,
    ibxeNoFieldAccess,
    ibxeFieldReadOnly,
    ibxeFieldNotFound,
    ibxeNotEditing,
    ibxeCannotInsert,
    ibxeCannotPost,
    ibxeCannotUpdate,
    ibxeCannotDelete,
    ibxeCannotRefresh,
    ibxeBufferNotSet,
    ibxeCircularReference,
    ibxeSQLParseError,
    ibxeUserAbort,
    ibxeDataSetUniDirectional,
    ibxeCannotCreateSharedResource,
    ibxeWindowsAPIError,
    ibxeColumnListsDontMatch,
    ibxeColumnTypesDontMatch,
    ibxeCantEndSharedTransaction,
    ibxeFieldUnsupportedType,
    ibxeCircularDataLink,
    ibxeEmptySQLStatement,
    ibxeIsASelectStatement,
    ibxeRequiredParamNotSet,
    ibxeNoStoredProcName,
    ibxeIsAExecuteProcedure,
    ibxeUpdateFailed,
    ibxeNotCachedUpdates,
    ibxeNotLiveRequest,
    ibxeNoProvider,
    ibxeNoRecordsAffected,
    ibxeNoTableName,
    ibxeCannotCreatePrimaryIndex,
    ibxeCannotDropSystemIndex,
    ibxeTableNameMismatch,
    ibxeIndexFieldMissing,
    ibxeInvalidCancellation,
    ibxeInvalidEvent,
    ibxeMaximumEvents,
    ibxeNoEventsRegistered,
    ibxeInvalidQueueing,
    ibxeInvalidRegistration,
    ibxeInvalidBatchMove,
    ibxeSQLDialectInvalid,
    ibxeSPBConstantNotSupported,
    ibxeSPBConstantUnknown,
    ibxeServiceActive,
    ibxeServiceInActive,
    ibxeServerNameMissing,
    ibxeQueryParamsError,
    ibxeStartParamsError,
    ibxeOutputParsingError,
    ibxeUseSpecificProcedures,
    ibxeSQLMonitorAlreadyPresent
    );

  TStatusVector              = array[0..19] of ISC_STATUS;
  PStatusVector              = ^TStatusVector;


const
  IBPalette1 = 'InterBase'; {do not localize}
  IBPalette2 = 'InterBase Admin'; {do not localize}

  IBLocalBufferLength = 512;
  IBBigLocalBufferLength = IBLocalBufferLength * 2;
  IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;

  IBErrorMessages: array[TIBClientError] of string = (
    SUnknownError,
    SInterBaseMissing,
    SInterBaseInstallMissing,
    SIB60feature,
    SNotSupported,
    SNotPermitted,
    SFileAccessError,
    SConnectionTimeout,
    SCannotSetDatabase,
    SCannotSetTransaction,
    SOperationCancelled,
    SDPBConstantNotSupported,
    SDPBConstantUnknown,
    STPBConstantNotSupported,
    STPBConstantUnknown,
    SDatabaseClosed,
    SDatabaseOpen,
    SDatabaseNameMissing,
    SNotInTransaction,
    SInTransaction,
    STimeoutNegative,
    SNoDatabasesInTransaction,
    SUpdateWrongDB,
    SUpdateWrongTR,
    SDatabaseNotAssigned,
    STransactionNotAssigned,
    SXSQLDAIndexOutOfRange,
    SXSQLDANameDoesNotExist,
    SEOF,
    SBOF,
    SInvalidStatementHandle,
    SSQLOpen,
    SSQLClosed,
    SDatasetOpen,
    SDatasetClosed,
    SUnknownSQLDataType,
    SInvalidColumnIndex,
    SInvalidParamColumnIndex,
    SInvalidDataConversion,
    SColumnIsNotNullable,
    SBlobCannotBeRead,
    SBlobCannotBeWritten,
    SEmptyQuery,
    SCannotOpenNonSQLSelect,
    SNoFieldAccess,
    SFieldReadOnly,
    SFieldNotFound,
    SNotEditing,
    SCannotInsert,
    SCannotPost,
    SCannotUpdate,
    SCannotDelete,
    SCannotRefresh,
    SBufferNotSet,
    SCircularReference,
    SSQLParseError,
    SUserAbort,
    SDataSetUniDirectional,
    SCannotCreateSharedResource,
    SWindowsAPIError,
    SColumnListsDontMatch,
    SColumnTypesDontMatch,
    SCantEndSharedTransaction,
    SFieldUnsupportedType,
    SCircularDataLink,
    SEmptySQLStatement,
    SIsASelectStatement,
    SRequiredParamNotSet,
    SNoStoredProcName,
    SIsAExecuteProcedure,
    SUpdateFailed,
    SNotCachedUpdates,
    SNotLiveRequest,
    SNoProvider,
    SNoRecordsAffected,
    SNoTableName,
    SCannotCreatePrimaryIndex,
    SCannotDropSystemIndex,
    STableNameMismatch,
    SIndexFieldMissing,
    SInvalidCancellation,
    SInvalidEvent,
    SMaximumEvents,
    SNoEventsRegistered,
    SInvalidQueueing,
    SInvalidRegistration,
    SInvalidBatchMove,
    SSQLDialectInvalid,
    SSPBConstantNotSupported,
    SSPBConstantUnknown,
    SServiceActive,
    SServiceInActive,
    SServerNameMissing,
    SQueryParamsError,
    SStartParamsError,
    SOutputParsingError,
    SUseSpecificProcedures,
    SSQLMonitorAlreadyPresent
  );

var
  IBCS: TRTLCriticalSection;

procedure IBAlloc(var P; OldSize, NewSize: Integer);

procedure IBError(ErrMess: TIBClientError; const Args: array of const);
procedure IBDataBaseError;

function StatusVector: PISC_STATUS;
function StatusVectorArray: PStatusVector;
function CheckStatusVector(ErrorCodes: array of ISC_STATUS): Boolean;
function StatusVectorAsText: string;

procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;

implementation

uses
  IBIntf;

var
  IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
threadvar
  FStatusVector : TStatusVector;

procedure IBAlloc(var P; OldSize, NewSize: Integer);
var
  i: Integer;
begin
  ReallocMem(Pointer(P), NewSize);
  for i := OldSize to NewSize - 1 do PChar(P)[i] := #0;
end;

procedure IBError(ErrMess: TIBClientError; const Args: array of const);
begin
  raise EIBClientError.Create(Ord(ErrMess),
                              Format(IBErrorMessages[ErrMess], Args));
end;

procedure IBDataBaseError;
var
  sqlcode: Long;
  IBErrorCode: Long;
  local_buffer: array[0..IBHugeLocalBufferLength - 1] of char;
  usr_msg: string;
  status_vector: PISC_STATUS;
  IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
begin
  usr_msg := '';

  { Get a local reference to the status vector.
    Get a local copy of the IBDataBaseErrorMessages options.
    Get the SQL error code }
  status_vector := StatusVector;
  IBErrorCode := StatusVectorArray[1];
  IBDataBaseErrorMessages := GetIBDataBaseErrorMessages;
  sqlcode := isc_sqlcode(status_vector);

  if (ShowSQLCode in IBDataBaseErrorMessages) then
    usr_msg := usr_msg + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
  Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
  if (ShowSQLMessage in IBDataBaseErrorMessages) then
  begin
    isc_sql_interprete(sqlcode, local_buffer, IBLocalBufferLength);
    if (ShowSQLCode in IBDataBaseErrorMessages) then
      usr_msg := usr_msg + CRLF;
    usr_msg := usr_msg + string(local_buffer);
  end;

  if (ShowIBMessage in IBDataBaseErrorMessages) then
  begin
    if (ShowSQLCode in IBDataBaseErrorMessages) or
       (ShowSQLMessage in IBDataBaseErrorMessages) then
      usr_msg := usr_msg + CRLF;
    while (isc_interprete(local_buffer, @status_vector) > 0) do
    begin
      if (usr_msg <> '') and (usr_msg[Length(usr_msg)] <> LF) then
        usr_msg := usr_msg + CRLF;
      usr_msg := usr_msg + string(local_buffer);
    end;
  end;
  if (usr_msg <> '') and (usr_msg[Length(usr_msg)] = '.') then
    Delete(usr_msg, Length(usr_msg), 1);
  raise EIBInterBaseError.Create(sqlcode, IBErrorCode, usr_msg);
end;

{ Return the status vector for the current thread }
function StatusVector: PISC_STATUS;
begin
  result := @FStatusVector;
end;

function StatusVectorArray: PStatusVector;
begin
  result := @FStatusVector;
end;

function CheckStatusVector(ErrorCodes: array of ISC_STATUS): Boolean;
var
  p: PISC_STATUS;
  i: Integer;
  procedure NextP(i: Integer);
  begin
    p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
  end;
begin
  p := @FStatusVector;
  result := False;
  while (p^ <> 0) and (not result) do
    case p^ of
      3: NextP(3);
      1, 4:
      begin
        NextP(1);
        i := 0;
        while (i <= High(ErrorCodes)) and (not result) do
        begin
          result := p^ = ErrorCodes[i];
          Inc(i);
        end;
        NextP(1);
      end;
      else
        NextP(2);
    end;
end;

function StatusVectorAsText: string;
var
  p: PISC_STATUS;
  function NextP(i: Integer): PISC_STATUS;
  begin
    p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
    result := p;
  end;
begin
  p := @FStatusVector;
  result := '';
  while (p^ <> 0) do
    if (p^ = 3) then
    begin
      result := result + Format('%d %d %d', [p^, NextP(1)^, NextP(1)^]) + CRLF;
      NextP(1);
    end
    else begin
      result := result + Format('%d %d', [p^, NextP(1)^]) + CRLF;
      NextP(1);
    end;
end;


{ EIBError }
constructor EIBError.Create(ASQLCode: Long; Msg: string);
begin
  inherited Create(Msg);
  FSQLCode := ASQLCode;
end;

constructor EIBError.Create(ASQLCode: Long; AIBErrorCode: Long; Msg: string);
begin
  inherited Create(Msg);
  FSQLCode :=  ASQLCode;
  FIBErrorCode := AIBErrorCode;
end;

procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
begin
  EnterCriticalSection(IBCS);
  try
    IBDataBaseErrorMessages := Value;
  finally
    LeaveCriticalSection(IBCS);
  end;
end;

function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
begin
  EnterCriticalSection(IBCS);
  try
    result := IBDataBaseErrorMessages;
  finally
    LeaveCriticalSection(IBCS);
  end;
end;

initialization
  IsMultiThread := True;
  InitializeCriticalSection(IBCS);
  IBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];

finalization
  DeleteCriticalSection(IBCS);

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