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, 9 months ago) by tony
Content type:	text/x-pascal
File size:	13122 byte(s)
Log Message:	Borland IBX Open Source Release
#	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	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.