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, 1 month ago) by tony
Content type:	text/x-pascal
File size:	15171 byte(s)
Log Message:	Committing updates for Release R1-2-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	ibxTransactionNotEnding
192	);
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	IBPalette3 = 'Firebird Data Controls'; {do not localize}
202
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	SFieldSizeError,
327	STransactionNotEnding
328	);
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	// IsMultiThread := True;
518	InitCriticalSection(IBCS);
519	IBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];
520
521	finalization
522	DoneCriticalSection(IBCS);
523
524	end.