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,
    ibxeTransactionNotEnding,
    ibxeDscInfoTokenMissing
    );

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

  {TResultBuffer inspired by IBPP RB class - access a isc_dsql_sql_info result buffer}

  TResultBuffer = class
  private
    mBuffer: PChar;
    mSize: short;
    function FindToken(token: char): PChar; overload;
    function FindToken(token: char; subtoken: char): PChar; overload;
  public
    constructor Create(aSize: integer = 1024);
    destructor Destroy; override;
    function Size: short;
    procedure Reset;
    function GetValue(token: char): integer; overload;
    function GetValue(token: char; subtoken: char): integer; overload;
    function GetCountValue(token: char): integer;
    function GetBool(token: char): boolean;
    function GetString(token: char; var data: string): integer;
    function buffer: PChar;
  end;

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

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, IBHeader;

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;

{ TResultBuffer }

constructor TResultBuffer.Create(aSize: integer);
begin
  inherited Create;
  mSize := aSize;
  GetMem(mBuffer,aSize);
  FillChar(mBuffer^,mSize,255);
end;

destructor TResultBuffer.Destroy;
begin
  if mBuffer <> nil then FreeMem(mBuffer);
  inherited;
end;

function TResultBuffer.buffer: PChar;
begin
  Result := mBuffer;
end;

function TResultBuffer.FindToken(token: char): PChar;
var p: PChar;
    len: integer;
begin
  Result := nil;
  p := mBuffer;

  while p^ <> char(isc_info_end) do
  begin
    if p^ = token then
    begin
      Result := p;
      Exit;
    end;
    len := isc_vax_integer(p+1,2);
    Inc(p,len+3);
  end;
end;

function TResultBuffer.FindToken(token: char; subtoken: char): PChar;
var p: PChar;
    len, inlen: integer;
begin
  Result := nil;
  p := mBuffer;

  while p^ <> char(isc_info_end) do
  begin
    if p^ = token then
    begin
      {Found token, now find subtoken}
      inlen := isc_vax_integer(p+1, 2);
      Inc(p,3);
      while inlen > 0 do
      begin
        if p^ = subtoken then
        begin
          Result := p;
          Exit;
        end;
        len := isc_vax_integer(p+1, 2);
        Inc(p,len + 3);
        Dec(inlen,len + 3);
      end;
      Exit;
    end;
    len := isc_vax_integer(p+1, 2);
    inc(p,len+3);
  end;
end;

function TResultBuffer.GetBool(token: char): boolean;
var aValue: integer;
    p: PChar;
begin
  p := FindToken(token);

  if p = nil then
    IBError(ibxeDscInfoTokenMissing,[token]);

  aValue := isc_vax_integer(p+1, 4);
  Result := aValue <> 0;
end;

function TResultBuffer.GetCountValue(token: char): integer;
var len: integer;
    p: PChar;
begin
  {Specifically used on tokens like isc_info_insert_count and the like
   which return detailed counts per relation. We sum up the values.}

  p := FindToken(token);

  if p = nil then
    IBError(ibxeDscInfoTokenMissing,[token]);

  {len is the number of bytes in the following array}

  len := isc_vax_integer(p+1, 2);
  Inc(p,3);
  Result := 0;
  while len > 0 do
  begin
    {Each array item is 6 bytes : 2 bytes for the relation_id which
     we skip, and 4 bytes for the count value which we sum up across
     all tables.}

     Inc(Result,isc_vax_integer(p+2, 4));
     Inc(p,6);
     Dec(len,6);
  end;
end;

function TResultBuffer.GetString(token: char; var data: string): integer;
var p: PChar;
begin
  Result := 0;
  p := FindToken(token);

  if p = nil then
    IBError(ibxeDscInfoTokenMissing,[token]);

  Result := isc_vax_integer(p+1, 2);
  SetString(data,p+3,Result);
end;

function TResultBuffer.GetValue(token: char): integer;
var len: integer;
    p: PChar;
begin
  Result := 0;
  p := FindToken(token);

  if p = nil then
    IBError(ibxeDscInfoTokenMissing,[token]);

  len := isc_vax_integer(p+1, 2);
  if (len <> 0) then
    Result := isc_vax_integer(p+3, len);
end;

function TResultBuffer.GetValue(token: char; subtoken: char): integer;
var len: integer;
    p: PChar;
begin
  Result := 0;
  p := FindToken(token, subtoken);

  if p = nil then
    IBError(ibxeDscInfoTokenMissing,[token]);

  len := isc_vax_integer(p+1, 2);
  if (len <> 0) then
    Result := isc_vax_integer(p+3, len);
end;

function TResultBuffer.Size: short;
begin
  Result := mSize;
end;

procedure TResultBuffer.Reset;
begin
  if mBuffer <> nil then FreeMem(mBuffer);
  GetMem(mBuffer,mSize);
  FillChar(mBuffer^,mSize,255);
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:	27
Committed:	Tue Apr 14 13:10:23 2015 UTC (9 years, 7 months ago) by tony
Content type:	text/x-pascal
File size:	19541 byte(s)
Log Message:	Committing updates for Release R1-2-3
#	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	tony	27	ibxeTransactionNotEnding,
192			ibxeDscInfoTokenMissing
193	tony	17	);
194
195			TStatusVector = array[0..19] of ISC_STATUS;
196			PStatusVector = ^TStatusVector;
197
198	tony	27	{TResultBuffer inspired by IBPP RB class - access a isc_dsql_sql_info result buffer}
199	tony	17
200	tony	27	TResultBuffer = class
201			private
202			mBuffer: PChar;
203			mSize: short;
204			function FindToken(token: char): PChar; overload;
205			function FindToken(token: char; subtoken: char): PChar; overload;
206			public
207			constructor Create(aSize: integer = 1024);
208			destructor Destroy; override;
209			function Size: short;
210			procedure Reset;
211			function GetValue(token: char): integer; overload;
212			function GetValue(token: char; subtoken: char): integer; overload;
213			function GetCountValue(token: char): integer;
214			function GetBool(token: char): boolean;
215			function GetString(token: char; var data: string): integer;
216			function buffer: PChar;
217			end;
218
219	tony	17	const
220			IBPalette1 = 'Firebird'; {do not localize}
221			IBPalette2 = 'Firebird Admin'; {do not localize}
222	tony	21	IBPalette3 = 'Firebird Data Controls'; {do not localize}
223	tony	17
224			IBLocalBufferLength = 512;
225			IBBigLocalBufferLength = IBLocalBufferLength * 2;
226			IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;
227
228			IBErrorMessages: array[TIBClientError] of string = (
229			SUnknownError,
230			SInterBaseMissing,
231			SInterBaseInstallMissing,
232			SIB60feature,
233			SNotSupported,
234			SNotPermitted,
235			SFileAccessError,
236			SConnectionTimeout,
237			SCannotSetDatabase,
238			SCannotSetTransaction,
239			SOperationCancelled,
240			SDPBConstantNotSupported,
241			SDPBConstantUnknown,
242			STPBConstantNotSupported,
243			STPBConstantUnknown,
244			SDatabaseClosed,
245			SDatabaseOpen,
246			SDatabaseNameMissing,
247			SNotInTransaction,
248			SInTransaction,
249			STimeoutNegative,
250			SNoDatabasesInTransaction,
251			SUpdateWrongDB,
252			SUpdateWrongTR,
253			SDatabaseNotAssigned,
254			STransactionNotAssigned,
255			SXSQLDAIndexOutOfRange,
256			SXSQLDANameDoesNotExist,
257			SEOF,
258			SBOF,
259			SInvalidStatementHandle,
260			SSQLOpen,
261			SSQLClosed,
262			SDatasetOpen,
263			SDatasetClosed,
264			SUnknownSQLDataType,
265			SInvalidColumnIndex,
266			SInvalidParamColumnIndex,
267			SInvalidDataConversion,
268			SColumnIsNotNullable,
269			SBlobCannotBeRead,
270			SBlobCannotBeWritten,
271			SEmptyQuery,
272			SCannotOpenNonSQLSelect,
273			SNoFieldAccess,
274			SFieldReadOnly,
275			SFieldNotFound,
276			SNotEditing,
277			SCannotInsert,
278			SCannotPost,
279			SCannotUpdate,
280			SCannotDelete,
281			SCannotRefresh,
282			SBufferNotSet,
283			SCircularReference,
284			SSQLParseError,
285			SUserAbort,
286			SDataSetUniDirectional,
287			SCannotCreateSharedResource,
288			SWindowsAPIError,
289			SColumnListsDontMatch,
290			SColumnTypesDontMatch,
291			SCantEndSharedTransaction,
292			SFieldUnsupportedType,
293			SCircularDataLink,
294			SEmptySQLStatement,
295			SIsASelectStatement,
296			SRequiredParamNotSet,
297			SNoStoredProcName,
298			SIsAExecuteProcedure,
299			SUpdateFailed,
300			SNotCachedUpdates,
301			SNotLiveRequest,
302			SNoProvider,
303			SNoRecordsAffected,
304			SNoTableName,
305			SCannotCreatePrimaryIndex,
306			SCannotDropSystemIndex,
307			STableNameMismatch,
308			SIndexFieldMissing,
309			SInvalidCancellation,
310			SInvalidEvent,
311			SMaximumEvents,
312			SNoEventsRegistered,
313			SInvalidQueueing,
314			SInvalidRegistration,
315			SInvalidBatchMove,
316			SSQLDialectInvalid,
317			SSPBConstantNotSupported,
318			SSPBConstantUnknown,
319			SServiceActive,
320			SServiceInActive,
321			SServerNameMissing,
322			SQueryParamsError,
323			SStartParamsError,
324			SOutputParsingError,
325			SUseSpecificProcedures,
326			SSQLMonitorAlreadyPresent,
327			SCantPrintValue,
328			SEOFReached,
329			SEOFInComment,
330			SEOFInString,
331			SParamNameExpected,
332			SSuccess,
333			SDelphiException,
334			SNoOptionsSet,
335			SNoDestinationDirectory,
336			SNosourceDirectory,
337			SNoUninstallFile,
338			SOptionNeedsClient,
339			SOptionNeedsServer,
340			SInvalidOption,
341			SInvalidOnErrorResult,
342			SInvalidOnStatusResult,
343			SDPBConstantUnknownEx,
344			STPBConstantUnknownEx,
345			SSV5APIError,
346			SThreadFailed,
347	tony	21	SFieldSizeError,
348	tony	27	STransactionNotEnding,
349			SDscInfoTokenMissing
350	tony	17	);
351
352			var
353			IBCS: TRTLCriticalSection;
354
355			procedure IBAlloc(var P; OldSize, NewSize: Integer);
356
357			procedure IBError(ErrMess: TIBClientError; const Args: array of const);
358			procedure IBDataBaseError;
359
360			function StatusVector: PISC_STATUS;
361			function StatusVectorArray: PStatusVector;
362			function CheckStatusVector(ErrorCodes: array of ISC_STATUS): Boolean;
363			function StatusVectorAsText: string;
364
365			procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
366			function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
367
368			implementation
369
370			uses
371	tony	27	IBIntf, IBHeader;
372	tony	17
373			var
374			IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
375			threadvar
376			FStatusVector : TStatusVector;
377
378			procedure IBAlloc(var P; OldSize, NewSize: Integer);
379			var
380			i: Integer;
381			begin
382			ReallocMem(Pointer(P), NewSize);
383			for i := OldSize to NewSize - 1 do PChar(P)[i] := #0;
384			end;
385
386			procedure IBError(ErrMess: TIBClientError; const Args: array of const);
387			begin
388			raise EIBClientError.Create(Ord(ErrMess),
389			Format(IBErrorMessages[ErrMess], Args));
390			end;
391
392			procedure IBDataBaseError;
393			var
394			sqlcode: Long;
395			IBErrorCode: Long;
396			local_buffer: array[0..IBHugeLocalBufferLength - 1] of char;
397			usr_msg: string;
398			status_vector: PISC_STATUS;
399			IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
400			begin
401			usr_msg := '';
402
403			{ Get a local reference to the status vector.
404			Get a local copy of the IBDataBaseErrorMessages options.
405			Get the SQL error code }
406			status_vector := StatusVector;
407			IBErrorCode := StatusVectorArray[1];
408			IBDataBaseErrorMessages := GetIBDataBaseErrorMessages;
409			sqlcode := isc_sqlcode(status_vector);
410
411			if (ShowSQLCode in IBDataBaseErrorMessages) then
412			usr_msg := usr_msg + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
413			Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
414			if (ShowSQLMessage in IBDataBaseErrorMessages) then
415			begin
416			isc_sql_interprete(sqlcode, local_buffer, IBLocalBufferLength);
417			if (ShowSQLCode in IBDataBaseErrorMessages) then
418			usr_msg := usr_msg + CRLF;
419			usr_msg := usr_msg + strpas(local_buffer);
420			end;
421
422			if (ShowIBMessage in IBDataBaseErrorMessages) then
423			begin
424			if (ShowSQLCode in IBDataBaseErrorMessages) or
425			(ShowSQLMessage in IBDataBaseErrorMessages) then
426			usr_msg := usr_msg + CRLF;
427			while (isc_interprete(local_buffer, @status_vector) > 0) do
428			begin
429			if (usr_msg <> '') and (usr_msg[Length(usr_msg)] <> LF) then
430			usr_msg := usr_msg + CRLF;
431			usr_msg := usr_msg + strpas(local_buffer);
432			end;
433			end;
434			if (usr_msg <> '') and (usr_msg[Length(usr_msg)] = '.') then
435			Delete(usr_msg, Length(usr_msg), 1);
436			raise EIBInterBaseError.Create(sqlcode, IBErrorCode, usr_msg);
437			end;
438
439			{ Return the status vector for the current thread }
440			function StatusVector: PISC_STATUS;
441			begin
442			result := @FStatusVector;
443			end;
444
445			function StatusVectorArray: PStatusVector;
446			begin
447			result := @FStatusVector;
448			end;
449
450			function CheckStatusVector(ErrorCodes: array of ISC_STATUS): Boolean;
451			var
452			p: PISC_STATUS;
453			i: Integer;
454			procedure NextP(i: Integer);
455			begin
456			p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
457			end;
458			begin
459			p := @FStatusVector;
460			result := False;
461			while (p^ <> 0) and (not result) do
462			case p^ of
463			3: NextP(3);
464			1, 4:
465			begin
466			NextP(1);
467			i := 0;
468			while (i <= High(ErrorCodes)) and (not result) do
469			begin
470			result := p^ = ErrorCodes[i];
471			Inc(i);
472			end;
473			NextP(1);
474			end;
475			else
476			NextP(2);
477			end;
478			end;
479
480			function StatusVectorAsText: string;
481			var
482			p: PISC_STATUS;
483			function NextP(i: Integer): PISC_STATUS;
484			begin
485			p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
486			result := p;
487			end;
488			begin
489			p := @FStatusVector;
490			result := '';
491			while (p^ <> 0) do
492			if (p^ = 3) then
493			begin
494			result := result + Format('%d %d %d', [p^, NextP(1)^, NextP(1)^]) + CRLF;
495			NextP(1);
496			end
497			else begin
498			result := result + Format('%d %d', [p^, NextP(1)^]) + CRLF;
499			NextP(1);
500			end;
501			end;
502
503	tony	27	{ TResultBuffer }
504	tony	17
505	tony	27	constructor TResultBuffer.Create(aSize: integer);
506			begin
507			inherited Create;
508			mSize := aSize;
509			GetMem(mBuffer,aSize);
510			FillChar(mBuffer^,mSize,255);
511			end;
512
513			destructor TResultBuffer.Destroy;
514			begin
515			if mBuffer <> nil then FreeMem(mBuffer);
516			inherited;
517			end;
518
519			function TResultBuffer.buffer: PChar;
520			begin
521			Result := mBuffer;
522			end;
523
524			function TResultBuffer.FindToken(token: char): PChar;
525			var p: PChar;
526			len: integer;
527			begin
528			Result := nil;
529			p := mBuffer;
530
531			while p^ <> char(isc_info_end) do
532			begin
533			if p^ = token then
534			begin
535			Result := p;
536			Exit;
537			end;
538			len := isc_vax_integer(p+1,2);
539			Inc(p,len+3);
540			end;
541			end;
542
543			function TResultBuffer.FindToken(token: char; subtoken: char): PChar;
544			var p: PChar;
545			len, inlen: integer;
546			begin
547			Result := nil;
548			p := mBuffer;
549
550			while p^ <> char(isc_info_end) do
551			begin
552			if p^ = token then
553			begin
554			{Found token, now find subtoken}
555			inlen := isc_vax_integer(p+1, 2);
556			Inc(p,3);
557			while inlen > 0 do
558			begin
559			if p^ = subtoken then
560			begin
561			Result := p;
562			Exit;
563			end;
564			len := isc_vax_integer(p+1, 2);
565			Inc(p,len + 3);
566			Dec(inlen,len + 3);
567			end;
568			Exit;
569			end;
570			len := isc_vax_integer(p+1, 2);
571			inc(p,len+3);
572			end;
573			end;
574
575			function TResultBuffer.GetBool(token: char): boolean;
576			var aValue: integer;
577			p: PChar;
578			begin
579			p := FindToken(token);
580
581			if p = nil then
582			IBError(ibxeDscInfoTokenMissing,[token]);
583
584			aValue := isc_vax_integer(p+1, 4);
585			Result := aValue <> 0;
586			end;
587
588			function TResultBuffer.GetCountValue(token: char): integer;
589			var len: integer;
590			p: PChar;
591			begin
592			{Specifically used on tokens like isc_info_insert_count and the like
593			which return detailed counts per relation. We sum up the values.}
594
595			p := FindToken(token);
596
597			if p = nil then
598			IBError(ibxeDscInfoTokenMissing,[token]);
599
600			{len is the number of bytes in the following array}
601
602			len := isc_vax_integer(p+1, 2);
603			Inc(p,3);
604			Result := 0;
605			while len > 0 do
606			begin
607			{Each array item is 6 bytes : 2 bytes for the relation_id which
608			we skip, and 4 bytes for the count value which we sum up across
609			all tables.}
610
611			Inc(Result,isc_vax_integer(p+2, 4));
612			Inc(p,6);
613			Dec(len,6);
614			end;
615			end;
616
617			function TResultBuffer.GetString(token: char; var data: string): integer;
618			var p: PChar;
619			begin
620			Result := 0;
621			p := FindToken(token);
622
623			if p = nil then
624			IBError(ibxeDscInfoTokenMissing,[token]);
625
626			Result := isc_vax_integer(p+1, 2);
627			SetString(data,p+3,Result);
628			end;
629
630			function TResultBuffer.GetValue(token: char): integer;
631			var len: integer;
632			p: PChar;
633			begin
634			Result := 0;
635			p := FindToken(token);
636
637			if p = nil then
638			IBError(ibxeDscInfoTokenMissing,[token]);
639
640			len := isc_vax_integer(p+1, 2);
641			if (len <> 0) then
642			Result := isc_vax_integer(p+3, len);
643			end;
644
645			function TResultBuffer.GetValue(token: char; subtoken: char): integer;
646			var len: integer;
647			p: PChar;
648			begin
649			Result := 0;
650			p := FindToken(token, subtoken);
651
652			if p = nil then
653			IBError(ibxeDscInfoTokenMissing,[token]);
654
655			len := isc_vax_integer(p+1, 2);
656			if (len <> 0) then
657			Result := isc_vax_integer(p+3, len);
658			end;
659
660			function TResultBuffer.Size: short;
661			begin
662			Result := mSize;
663			end;
664
665			procedure TResultBuffer.Reset;
666			begin
667			if mBuffer <> nil then FreeMem(mBuffer);
668			GetMem(mBuffer,mSize);
669			FillChar(mBuffer^,mSize,255);
670			end;
671
672
673	tony	17	{ EIBError }
674			constructor EIBError.Create(ASQLCode: Long; Msg: string);
675			begin
676			inherited Create(Msg);
677			FSQLCode := ASQLCode;
678			end;
679
680			constructor EIBError.Create(ASQLCode: Long; AIBErrorCode: Long; Msg: string);
681			begin
682			inherited Create(Msg);
683			FSQLCode := ASQLCode;
684			FIBErrorCode := AIBErrorCode;
685			end;
686
687			procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
688			begin
689			EnterCriticalSection(IBCS);
690			try
691			IBDataBaseErrorMessages := Value;
692			finally
693			LeaveCriticalSection(IBCS);
694			end;
695			end;
696
697			function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
698			begin
699			EnterCriticalSection(IBCS);
700			try
701			result := IBDataBaseErrorMessages;
702			finally
703			LeaveCriticalSection(IBCS);
704			end;
705			end;
706
707			initialization
708	tony	21	// IsMultiThread := True;
709	tony	17	InitCriticalSection(IBCS);
710			IBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];
711
712			finalization
713			DoneCriticalSection(IBCS);
714
715	tony	27	end.