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                                       }
{                                                                        }
{    IBX For Lazarus (Firebird Express)                                  }
{    Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
{    Portions created by MWA Software are copyright McCallum Whyman      }
{    Associates Ltd 2011                                                 }
{                                                                        }
{************************************************************************}

unit IB;

{$Mode Delphi}

interface

uses
{$IFDEF WINDOWS }
  Windows,
{$ELSE}
  unix,
{$ENDIF}
  SysUtils, Classes, 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,
    ibxeCantPrintValue,
    ibxeEOFReached,
    ibxeEOFInComment,
    ibxeEOFInString,
    ibxeParamNameExpected,
    ibxeSuccess,
    ibxeDelphiException,
    ibxeNoOptionsSet,
    ibxeNoDestinationDirectory,
    ibxeNosourceDirectory,
    ibxeNoUninstallFile,
    ibxeOptionNeedsClient,
    ibxeOptionNeedsServer,
    ibxeInvalidOption,
    ibxeInvalidOnErrorResult,
    ibxeInvalidOnStatusResult,
    ibxeDPBConstantUnknownEx,
    ibxeTPBConstantUnknownEx,
    ibxeSV5APIError,
    ibxeThreadFailed,
    ibxeFieldSizeError
    );

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


const
  IBPalette1 = 'Firebird'; {do not localize}
  IBPalette2 = 'Firebird 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,
    SCantPrintValue,
    SEOFReached,
    SEOFInComment,
    SEOFInString,
    SParamNameExpected,
    SSuccess,
    SDelphiException,
    SNoOptionsSet,
    SNoDestinationDirectory,
    SNosourceDirectory,
    SNoUninstallFile,
    SOptionNeedsClient,
    SOptionNeedsServer,
    SInvalidOption,
    SInvalidOnErrorResult,
    SInvalidOnStatusResult,
    SDPBConstantUnknownEx,
    STPBConstantUnknownEx,
    SSV5APIError,
    SThreadFailed,
    SFieldSizeError
  );

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 + strpas(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 + strpas(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;
  InitCriticalSection(IBCS);
  IBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];

finalization
  DoneCriticalSection(IBCS);

end.
Revision:	7
Committed:	Sun Aug 5 18:28:19 2012 UTC (12 years, 3 months ago) by tony
Content type:	text/x-pascal
File size:	14531 byte(s)
Log Message:	Committing updates for Release R1-0-0
#	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	{ 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.