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,
    ibxTransactionNotEnding
    );

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


const
  IBPalette1 = 'Firebird'; {do not localize}
  IBPalette2 = 'Firebird Admin'; {do not localize}
  IBPalette3 = 'Firebird Data Controls';   {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,
    STransactionNotEnding
  );

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:	21
Committed:	Thu Feb 26 10:33:34 2015 UTC (9 years, 2 months ago) by tony
Content type:	text/x-pascal
File size:	15171 byte(s)
Log Message:	Committing updates for Release R1-2-0
#	User	Rev	Content
1	tony	17	{************************************************************************}
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	tony	21	ibxeFieldSizeError,
191			ibxTransactionNotEnding
192	tony	17	);
193
194			TStatusVector = array[0..19] of ISC_STATUS;
195			PStatusVector = ^TStatusVector;
196
197
198			const
199			IBPalette1 = 'Firebird'; {do not localize}
200			IBPalette2 = 'Firebird Admin'; {do not localize}
201	tony	21	IBPalette3 = 'Firebird Data Controls'; {do not localize}
202	tony	17
203			IBLocalBufferLength = 512;
204			IBBigLocalBufferLength = IBLocalBufferLength * 2;
205			IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;
206
207			IBErrorMessages: array[TIBClientError] of string = (
208			SUnknownError,
209			SInterBaseMissing,
210			SInterBaseInstallMissing,
211			SIB60feature,
212			SNotSupported,
213			SNotPermitted,
214			SFileAccessError,
215			SConnectionTimeout,
216			SCannotSetDatabase,
217			SCannotSetTransaction,
218			SOperationCancelled,
219			SDPBConstantNotSupported,
220			SDPBConstantUnknown,
221			STPBConstantNotSupported,
222			STPBConstantUnknown,
223			SDatabaseClosed,
224			SDatabaseOpen,
225			SDatabaseNameMissing,
226			SNotInTransaction,
227			SInTransaction,
228			STimeoutNegative,
229			SNoDatabasesInTransaction,
230			SUpdateWrongDB,
231			SUpdateWrongTR,
232			SDatabaseNotAssigned,
233			STransactionNotAssigned,
234			SXSQLDAIndexOutOfRange,
235			SXSQLDANameDoesNotExist,
236			SEOF,
237			SBOF,
238			SInvalidStatementHandle,
239			SSQLOpen,
240			SSQLClosed,
241			SDatasetOpen,
242			SDatasetClosed,
243			SUnknownSQLDataType,
244			SInvalidColumnIndex,
245			SInvalidParamColumnIndex,
246			SInvalidDataConversion,
247			SColumnIsNotNullable,
248			SBlobCannotBeRead,
249			SBlobCannotBeWritten,
250			SEmptyQuery,
251			SCannotOpenNonSQLSelect,
252			SNoFieldAccess,
253			SFieldReadOnly,
254			SFieldNotFound,
255			SNotEditing,
256			SCannotInsert,
257			SCannotPost,
258			SCannotUpdate,
259			SCannotDelete,
260			SCannotRefresh,
261			SBufferNotSet,
262			SCircularReference,
263			SSQLParseError,
264			SUserAbort,
265			SDataSetUniDirectional,
266			SCannotCreateSharedResource,
267			SWindowsAPIError,
268			SColumnListsDontMatch,
269			SColumnTypesDontMatch,
270			SCantEndSharedTransaction,
271			SFieldUnsupportedType,
272			SCircularDataLink,
273			SEmptySQLStatement,
274			SIsASelectStatement,
275			SRequiredParamNotSet,
276			SNoStoredProcName,
277			SIsAExecuteProcedure,
278			SUpdateFailed,
279			SNotCachedUpdates,
280			SNotLiveRequest,
281			SNoProvider,
282			SNoRecordsAffected,
283			SNoTableName,
284			SCannotCreatePrimaryIndex,
285			SCannotDropSystemIndex,
286			STableNameMismatch,
287			SIndexFieldMissing,
288			SInvalidCancellation,
289			SInvalidEvent,
290			SMaximumEvents,
291			SNoEventsRegistered,
292			SInvalidQueueing,
293			SInvalidRegistration,
294			SInvalidBatchMove,
295			SSQLDialectInvalid,
296			SSPBConstantNotSupported,
297			SSPBConstantUnknown,
298			SServiceActive,
299			SServiceInActive,
300			SServerNameMissing,
301			SQueryParamsError,
302			SStartParamsError,
303			SOutputParsingError,
304			SUseSpecificProcedures,
305			SSQLMonitorAlreadyPresent,
306			SCantPrintValue,
307			SEOFReached,
308			SEOFInComment,
309			SEOFInString,
310			SParamNameExpected,
311			SSuccess,
312			SDelphiException,
313			SNoOptionsSet,
314			SNoDestinationDirectory,
315			SNosourceDirectory,
316			SNoUninstallFile,
317			SOptionNeedsClient,
318			SOptionNeedsServer,
319			SInvalidOption,
320			SInvalidOnErrorResult,
321			SInvalidOnStatusResult,
322			SDPBConstantUnknownEx,
323			STPBConstantUnknownEx,
324			SSV5APIError,
325			SThreadFailed,
326	tony	21	SFieldSizeError,
327			STransactionNotEnding
328	tony	17	);
329
330			var
331			IBCS: TRTLCriticalSection;
332
333			procedure IBAlloc(var P; OldSize, NewSize: Integer);
334
335			procedure IBError(ErrMess: TIBClientError; const Args: array of const);
336			procedure IBDataBaseError;
337
338			function StatusVector: PISC_STATUS;
339			function StatusVectorArray: PStatusVector;
340			function CheckStatusVector(ErrorCodes: array of ISC_STATUS): Boolean;
341			function StatusVectorAsText: string;
342
343			procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
344			function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
345
346			implementation
347
348			uses
349			IBIntf;
350
351			var
352			IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
353			threadvar
354			FStatusVector : TStatusVector;
355
356			procedure IBAlloc(var P; OldSize, NewSize: Integer);
357			var
358			i: Integer;
359			begin
360			ReallocMem(Pointer(P), NewSize);
361			for i := OldSize to NewSize - 1 do PChar(P)[i] := #0;
362			end;
363
364			procedure IBError(ErrMess: TIBClientError; const Args: array of const);
365			begin
366			raise EIBClientError.Create(Ord(ErrMess),
367			Format(IBErrorMessages[ErrMess], Args));
368			end;
369
370			procedure IBDataBaseError;
371			var
372			sqlcode: Long;
373			IBErrorCode: Long;
374			local_buffer: array[0..IBHugeLocalBufferLength - 1] of char;
375			usr_msg: string;
376			status_vector: PISC_STATUS;
377			IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
378			begin
379			usr_msg := '';
380
381			{ Get a local reference to the status vector.
382			Get a local copy of the IBDataBaseErrorMessages options.
383			Get the SQL error code }
384			status_vector := StatusVector;
385			IBErrorCode := StatusVectorArray[1];
386			IBDataBaseErrorMessages := GetIBDataBaseErrorMessages;
387			sqlcode := isc_sqlcode(status_vector);
388
389			if (ShowSQLCode in IBDataBaseErrorMessages) then
390			usr_msg := usr_msg + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
391			Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
392			if (ShowSQLMessage in IBDataBaseErrorMessages) then
393			begin
394			isc_sql_interprete(sqlcode, local_buffer, IBLocalBufferLength);
395			if (ShowSQLCode in IBDataBaseErrorMessages) then
396			usr_msg := usr_msg + CRLF;
397			usr_msg := usr_msg + strpas(local_buffer);
398			end;
399
400			if (ShowIBMessage in IBDataBaseErrorMessages) then
401			begin
402			if (ShowSQLCode in IBDataBaseErrorMessages) or
403			(ShowSQLMessage in IBDataBaseErrorMessages) then
404			usr_msg := usr_msg + CRLF;
405			while (isc_interprete(local_buffer, @status_vector) > 0) do
406			begin
407			if (usr_msg <> '') and (usr_msg[Length(usr_msg)] <> LF) then
408			usr_msg := usr_msg + CRLF;
409			usr_msg := usr_msg + strpas(local_buffer);
410			end;
411			end;
412			if (usr_msg <> '') and (usr_msg[Length(usr_msg)] = '.') then
413			Delete(usr_msg, Length(usr_msg), 1);
414			raise EIBInterBaseError.Create(sqlcode, IBErrorCode, usr_msg);
415			end;
416
417			{ Return the status vector for the current thread }
418			function StatusVector: PISC_STATUS;
419			begin
420			result := @FStatusVector;
421			end;
422
423			function StatusVectorArray: PStatusVector;
424			begin
425			result := @FStatusVector;
426			end;
427
428			function CheckStatusVector(ErrorCodes: array of ISC_STATUS): Boolean;
429			var
430			p: PISC_STATUS;
431			i: Integer;
432			procedure NextP(i: Integer);
433			begin
434			p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
435			end;
436			begin
437			p := @FStatusVector;
438			result := False;
439			while (p^ <> 0) and (not result) do
440			case p^ of
441			3: NextP(3);
442			1, 4:
443			begin
444			NextP(1);
445			i := 0;
446			while (i <= High(ErrorCodes)) and (not result) do
447			begin
448			result := p^ = ErrorCodes[i];
449			Inc(i);
450			end;
451			NextP(1);
452			end;
453			else
454			NextP(2);
455			end;
456			end;
457
458			function StatusVectorAsText: string;
459			var
460			p: PISC_STATUS;
461			function NextP(i: Integer): PISC_STATUS;
462			begin
463			p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
464			result := p;
465			end;
466			begin
467			p := @FStatusVector;
468			result := '';
469			while (p^ <> 0) do
470			if (p^ = 3) then
471			begin
472			result := result + Format('%d %d %d', [p^, NextP(1)^, NextP(1)^]) + CRLF;
473			NextP(1);
474			end
475			else begin
476			result := result + Format('%d %d', [p^, NextP(1)^]) + CRLF;
477			NextP(1);
478			end;
479			end;
480
481
482			{ EIBError }
483			constructor EIBError.Create(ASQLCode: Long; Msg: string);
484			begin
485			inherited Create(Msg);
486			FSQLCode := ASQLCode;
487			end;
488
489			constructor EIBError.Create(ASQLCode: Long; AIBErrorCode: Long; Msg: string);
490			begin
491			inherited Create(Msg);
492			FSQLCode := ASQLCode;
493			FIBErrorCode := AIBErrorCode;
494			end;
495
496			procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
497			begin
498			EnterCriticalSection(IBCS);
499			try
500			IBDataBaseErrorMessages := Value;
501			finally
502			LeaveCriticalSection(IBCS);
503			end;
504			end;
505
506			function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
507			begin
508			EnterCriticalSection(IBCS);
509			try
510			result := IBDataBaseErrorMessages;
511			finally
512			LeaveCriticalSection(IBCS);
513			end;
514			end;
515
516			initialization
517	tony	21	// IsMultiThread := True;
518	tony	17	InitCriticalSection(IBCS);
519			IBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];
520
521			finalization
522			DoneCriticalSection(IBCS);
523
524	tony	21	end.