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
#	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	tony	7	{ 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	tony	1	{************************************************************************}
33
34			unit IB;
35
36	tony	5	{$Mode Delphi}
37
38	tony	1	interface
39
40			uses
41	tony	7	{$IFDEF WINDOWS }
42			Windows,
43			{$ELSE}
44	tony	5	unix,
45			{$ENDIF}
46			SysUtils, Classes, IBExternals, IBUtils, DB, IBXConst;
47	tony	1
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	tony	5	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	tony	7	ibxeTPBConstantUnknownEx,
188			ibxeSV5APIError,
189			ibxeThreadFailed,
190			ibxeFieldSizeError
191	tony	1	);
192
193			TStatusVector = array[0..19] of ISC_STATUS;
194			PStatusVector = ^TStatusVector;
195
196
197			const
198	tony	5	IBPalette1 = 'Firebird'; {do not localize}
199			IBPalette2 = 'Firebird Admin'; {do not localize}
200	tony	1
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	tony	5	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	tony	7	STPBConstantUnknownEx,
322			SSV5APIError,
323			SThreadFailed,
324			SFieldSizeError
325	tony	1	);
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	tony	5	usr_msg := usr_msg + strpas(local_buffer);
395	tony	1	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	tony	5	usr_msg := usr_msg + strpas(local_buffer);
407	tony	1	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	tony	7	// IsMultiThread := True;
515	tony	5	InitCriticalSection(IBCS);
516	tony	1	IBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];
517
518			finalization
519	tony	5	DoneCriticalSection(IBCS);
520	tony	1
521			end.