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

type
  TIBGUIInterface = interface
    function ServerLoginDialog(const AServerName: string;
                               var AUserName, APassword: string): Boolean;
    function LoginDialogEx(const ADatabaseName: string;
                               var AUserName, APassword: string;
                               NameReadOnly: Boolean): Boolean;
    procedure SetCursor;
    procedure RestoreCursor;
  end;

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

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

const
  IBGUIInterface: TIBGUIInterface = nil;


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:	31
Committed:	Tue Jul 14 15:31:25 2015 UTC (8 years, 9 months ago) by tony
Content type:	text/x-pascal
File size:	20068 byte(s)
Log Message:	Committing updates for Release R1-3-0
#	User	Rev	Content
1	tony	17	{************************************************************************}
2			{ }
3			{ Borland Delphi Visual Component Library }
4			{ InterBase Express core components }
5			{ }
6			{ Copyright (c) 1998-2000 Inprise Corporation }
7			{ }
8			{ InterBase Express is based in part on the product }
9			{ Free IB Components, written by Gregory H. Deatz for }
10			{ Hoagland, Longo, Moran, Dunst & Doukas Company. }
11			{ Free IB Components is used under license. }
12			{ }
13			{ The contents of this file are subject to the InterBase }
14			{ Public License Version 1.0 (the "License"); you may not }
15			{ use this file except in compliance with the License. You }
16			{ may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17			{ Software distributed under the License is distributed on }
18			{ an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
19			{ express or implied. See the License for the specific language }
20			{ governing rights and limitations under the License. }
21			{ The Original Code was created by InterBase Software Corporation }
22			{ and its successors. }
23			{ Portions created by Inprise Corporation are Copyright (C) Inprise }
24			{ Corporation. All Rights Reserved. }
25			{ Contributor(s): Jeff Overcash }
26			{ }
27			{ IBX For Lazarus (Firebird Express) }
28			{ Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29			{ Portions created by MWA Software are copyright McCallum Whyman }
30			{ Associates Ltd 2011 }
31			{ }
32			{************************************************************************}
33
34			unit IB;
35
36			{$Mode Delphi}
37
38			interface
39
40			uses
41			{$IFDEF WINDOWS }
42			Windows,
43			{$ELSE}
44			unix,
45			{$ENDIF}
46	tony	31	SysUtils, Classes, IBExternals, IBUtils, DB, IBXConst, CustApp;
47	tony	17
48			type
49	tony	31	TIBGUIInterface = interface
50			function ServerLoginDialog(const AServerName: string;
51			var AUserName, APassword: string): Boolean;
52			function LoginDialogEx(const ADatabaseName: string;
53			var AUserName, APassword: string;
54			NameReadOnly: Boolean): Boolean;
55			procedure SetCursor;
56			procedure RestoreCursor;
57			end;
58
59	tony	17	TTraceFlag = (tfQPrepare, tfQExecute, tfQFetch, tfError, tfStmt, tfConnect,
60			tfTransact, tfBlob, tfService, tfMisc);
61			TTraceFlags = set of TTraceFlag;
62
63			EIBError = class(EDatabaseError)
64			private
65			FSQLCode: Long;
66			FIBErrorCode: Long;
67			public
68			constructor Create(ASQLCode: Long; Msg: string); overload;
69			constructor Create(ASQLCode: Long; AIBErrorCode: Long; Msg: string); overload;
70			property SQLCode: Long read FSQLCode;
71			property IBErrorCode: Long read FIBErrorCode;
72			end;
73
74			EIBInterBaseError = class(EIBError);
75			EIBClientError = class(EIBError);
76
77			TIBDataBaseErrorMessage = (ShowSQLCode,
78			ShowIBMessage,
79			ShowSQLMessage);
80			TIBDataBaseErrorMessages = set of TIBDataBaseErrorMessage;
81			TIBClientError = (
82			ibxeUnknownError,
83			ibxeInterBaseMissing,
84			ibxeInterBaseInstallMissing,
85			ibxeIB60feature,
86			ibxeNotSupported,
87			ibxeNotPermitted,
88			ibxeFileAccessError,
89			ibxeConnectionTimeout,
90			ibxeCannotSetDatabase,
91			ibxeCannotSetTransaction,
92			ibxeOperationCancelled,
93			ibxeDPBConstantNotSupported,
94			ibxeDPBConstantUnknown,
95			ibxeTPBConstantNotSupported,
96			ibxeTPBConstantUnknown,
97			ibxeDatabaseClosed,
98			ibxeDatabaseOpen,
99			ibxeDatabaseNameMissing,
100			ibxeNotInTransaction,
101			ibxeInTransaction,
102			ibxeTimeoutNegative,
103			ibxeNoDatabasesInTransaction,
104			ibxeUpdateWrongDB,
105			ibxeUpdateWrongTR,
106			ibxeDatabaseNotAssigned,
107			ibxeTransactionNotAssigned,
108			ibxeXSQLDAIndexOutOfRange,
109			ibxeXSQLDANameDoesNotExist,
110			ibxeEOF,
111			ibxeBOF,
112			ibxeInvalidStatementHandle,
113			ibxeSQLOpen,
114			ibxeSQLClosed,
115			ibxeDatasetOpen,
116			ibxeDatasetClosed,
117			ibxeUnknownSQLDataType,
118			ibxeInvalidColumnIndex,
119			ibxeInvalidParamColumnIndex,
120			ibxeInvalidDataConversion,
121			ibxeColumnIsNotNullable,
122			ibxeBlobCannotBeRead,
123			ibxeBlobCannotBeWritten,
124			ibxeEmptyQuery,
125			ibxeCannotOpenNonSQLSelect,
126			ibxeNoFieldAccess,
127			ibxeFieldReadOnly,
128			ibxeFieldNotFound,
129			ibxeNotEditing,
130			ibxeCannotInsert,
131			ibxeCannotPost,
132			ibxeCannotUpdate,
133			ibxeCannotDelete,
134			ibxeCannotRefresh,
135			ibxeBufferNotSet,
136			ibxeCircularReference,
137			ibxeSQLParseError,
138			ibxeUserAbort,
139			ibxeDataSetUniDirectional,
140			ibxeCannotCreateSharedResource,
141			ibxeWindowsAPIError,
142			ibxeColumnListsDontMatch,
143			ibxeColumnTypesDontMatch,
144			ibxeCantEndSharedTransaction,
145			ibxeFieldUnsupportedType,
146			ibxeCircularDataLink,
147			ibxeEmptySQLStatement,
148			ibxeIsASelectStatement,
149			ibxeRequiredParamNotSet,
150			ibxeNoStoredProcName,
151			ibxeIsAExecuteProcedure,
152			ibxeUpdateFailed,
153			ibxeNotCachedUpdates,
154			ibxeNotLiveRequest,
155			ibxeNoProvider,
156			ibxeNoRecordsAffected,
157			ibxeNoTableName,
158			ibxeCannotCreatePrimaryIndex,
159			ibxeCannotDropSystemIndex,
160			ibxeTableNameMismatch,
161			ibxeIndexFieldMissing,
162			ibxeInvalidCancellation,
163			ibxeInvalidEvent,
164			ibxeMaximumEvents,
165			ibxeNoEventsRegistered,
166			ibxeInvalidQueueing,
167			ibxeInvalidRegistration,
168			ibxeInvalidBatchMove,
169			ibxeSQLDialectInvalid,
170			ibxeSPBConstantNotSupported,
171			ibxeSPBConstantUnknown,
172			ibxeServiceActive,
173			ibxeServiceInActive,
174			ibxeServerNameMissing,
175			ibxeQueryParamsError,
176			ibxeStartParamsError,
177			ibxeOutputParsingError,
178			ibxeUseSpecificProcedures,
179			ibxeSQLMonitorAlreadyPresent,
180			ibxeCantPrintValue,
181			ibxeEOFReached,
182			ibxeEOFInComment,
183			ibxeEOFInString,
184			ibxeParamNameExpected,
185			ibxeSuccess,
186			ibxeDelphiException,
187			ibxeNoOptionsSet,
188			ibxeNoDestinationDirectory,
189			ibxeNosourceDirectory,
190			ibxeNoUninstallFile,
191			ibxeOptionNeedsClient,
192			ibxeOptionNeedsServer,
193			ibxeInvalidOption,
194			ibxeInvalidOnErrorResult,
195			ibxeInvalidOnStatusResult,
196			ibxeDPBConstantUnknownEx,
197			ibxeTPBConstantUnknownEx,
198			ibxeSV5APIError,
199			ibxeThreadFailed,
200	tony	21	ibxeFieldSizeError,
201	tony	27	ibxeTransactionNotEnding,
202	tony	31	ibxeDscInfoTokenMissing,
203			ibxeNoLoginDialog
204	tony	17	);
205
206			TStatusVector = array[0..19] of ISC_STATUS;
207			PStatusVector = ^TStatusVector;
208
209	tony	27	{TResultBuffer inspired by IBPP RB class - access a isc_dsql_sql_info result buffer}
210	tony	17
211	tony	27	TResultBuffer = class
212			private
213			mBuffer: PChar;
214			mSize: short;
215			function FindToken(token: char): PChar; overload;
216			function FindToken(token: char; subtoken: char): PChar; overload;
217			public
218			constructor Create(aSize: integer = 1024);
219			destructor Destroy; override;
220			function Size: short;
221			procedure Reset;
222			function GetValue(token: char): integer; overload;
223			function GetValue(token: char; subtoken: char): integer; overload;
224			function GetCountValue(token: char): integer;
225			function GetBool(token: char): boolean;
226			function GetString(token: char; var data: string): integer;
227			function buffer: PChar;
228			end;
229
230	tony	17	const
231			IBPalette1 = 'Firebird'; {do not localize}
232			IBPalette2 = 'Firebird Admin'; {do not localize}
233	tony	21	IBPalette3 = 'Firebird Data Controls'; {do not localize}
234	tony	17
235			IBLocalBufferLength = 512;
236			IBBigLocalBufferLength = IBLocalBufferLength * 2;
237			IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;
238
239			IBErrorMessages: array[TIBClientError] of string = (
240			SUnknownError,
241			SInterBaseMissing,
242			SInterBaseInstallMissing,
243			SIB60feature,
244			SNotSupported,
245			SNotPermitted,
246			SFileAccessError,
247			SConnectionTimeout,
248			SCannotSetDatabase,
249			SCannotSetTransaction,
250			SOperationCancelled,
251			SDPBConstantNotSupported,
252			SDPBConstantUnknown,
253			STPBConstantNotSupported,
254			STPBConstantUnknown,
255			SDatabaseClosed,
256			SDatabaseOpen,
257			SDatabaseNameMissing,
258			SNotInTransaction,
259			SInTransaction,
260			STimeoutNegative,
261			SNoDatabasesInTransaction,
262			SUpdateWrongDB,
263			SUpdateWrongTR,
264			SDatabaseNotAssigned,
265			STransactionNotAssigned,
266			SXSQLDAIndexOutOfRange,
267			SXSQLDANameDoesNotExist,
268			SEOF,
269			SBOF,
270			SInvalidStatementHandle,
271			SSQLOpen,
272			SSQLClosed,
273			SDatasetOpen,
274			SDatasetClosed,
275			SUnknownSQLDataType,
276			SInvalidColumnIndex,
277			SInvalidParamColumnIndex,
278			SInvalidDataConversion,
279			SColumnIsNotNullable,
280			SBlobCannotBeRead,
281			SBlobCannotBeWritten,
282			SEmptyQuery,
283			SCannotOpenNonSQLSelect,
284			SNoFieldAccess,
285			SFieldReadOnly,
286			SFieldNotFound,
287			SNotEditing,
288			SCannotInsert,
289			SCannotPost,
290			SCannotUpdate,
291			SCannotDelete,
292			SCannotRefresh,
293			SBufferNotSet,
294			SCircularReference,
295			SSQLParseError,
296			SUserAbort,
297			SDataSetUniDirectional,
298			SCannotCreateSharedResource,
299			SWindowsAPIError,
300			SColumnListsDontMatch,
301			SColumnTypesDontMatch,
302			SCantEndSharedTransaction,
303			SFieldUnsupportedType,
304			SCircularDataLink,
305			SEmptySQLStatement,
306			SIsASelectStatement,
307			SRequiredParamNotSet,
308			SNoStoredProcName,
309			SIsAExecuteProcedure,
310			SUpdateFailed,
311			SNotCachedUpdates,
312			SNotLiveRequest,
313			SNoProvider,
314			SNoRecordsAffected,
315			SNoTableName,
316			SCannotCreatePrimaryIndex,
317			SCannotDropSystemIndex,
318			STableNameMismatch,
319			SIndexFieldMissing,
320			SInvalidCancellation,
321			SInvalidEvent,
322			SMaximumEvents,
323			SNoEventsRegistered,
324			SInvalidQueueing,
325			SInvalidRegistration,
326			SInvalidBatchMove,
327			SSQLDialectInvalid,
328			SSPBConstantNotSupported,
329			SSPBConstantUnknown,
330			SServiceActive,
331			SServiceInActive,
332			SServerNameMissing,
333			SQueryParamsError,
334			SStartParamsError,
335			SOutputParsingError,
336			SUseSpecificProcedures,
337			SSQLMonitorAlreadyPresent,
338			SCantPrintValue,
339			SEOFReached,
340			SEOFInComment,
341			SEOFInString,
342			SParamNameExpected,
343			SSuccess,
344			SDelphiException,
345			SNoOptionsSet,
346			SNoDestinationDirectory,
347			SNosourceDirectory,
348			SNoUninstallFile,
349			SOptionNeedsClient,
350			SOptionNeedsServer,
351			SInvalidOption,
352			SInvalidOnErrorResult,
353			SInvalidOnStatusResult,
354			SDPBConstantUnknownEx,
355			STPBConstantUnknownEx,
356			SSV5APIError,
357			SThreadFailed,
358	tony	21	SFieldSizeError,
359	tony	27	STransactionNotEnding,
360	tony	31	SDscInfoTokenMissing,
361			SNoLoginDialog
362	tony	17	);
363
364	tony	31	const
365			IBGUIInterface: TIBGUIInterface = nil;
366
367
368	tony	17	var
369			IBCS: TRTLCriticalSection;
370
371			procedure IBAlloc(var P; OldSize, NewSize: Integer);
372
373			procedure IBError(ErrMess: TIBClientError; const Args: array of const);
374			procedure IBDataBaseError;
375
376			function StatusVector: PISC_STATUS;
377			function StatusVectorArray: PStatusVector;
378			function CheckStatusVector(ErrorCodes: array of ISC_STATUS): Boolean;
379			function StatusVectorAsText: string;
380
381			procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
382			function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
383
384			implementation
385
386			uses
387	tony	27	IBIntf, IBHeader;
388	tony	17
389			var
390			IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
391			threadvar
392			FStatusVector : TStatusVector;
393
394			procedure IBAlloc(var P; OldSize, NewSize: Integer);
395			var
396			i: Integer;
397			begin
398			ReallocMem(Pointer(P), NewSize);
399			for i := OldSize to NewSize - 1 do PChar(P)[i] := #0;
400			end;
401
402			procedure IBError(ErrMess: TIBClientError; const Args: array of const);
403			begin
404			raise EIBClientError.Create(Ord(ErrMess),
405			Format(IBErrorMessages[ErrMess], Args));
406			end;
407
408			procedure IBDataBaseError;
409			var
410			sqlcode: Long;
411			IBErrorCode: Long;
412			local_buffer: array[0..IBHugeLocalBufferLength - 1] of char;
413			usr_msg: string;
414			status_vector: PISC_STATUS;
415			IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
416			begin
417			usr_msg := '';
418
419			{ Get a local reference to the status vector.
420			Get a local copy of the IBDataBaseErrorMessages options.
421			Get the SQL error code }
422			status_vector := StatusVector;
423			IBErrorCode := StatusVectorArray[1];
424			IBDataBaseErrorMessages := GetIBDataBaseErrorMessages;
425			sqlcode := isc_sqlcode(status_vector);
426
427			if (ShowSQLCode in IBDataBaseErrorMessages) then
428			usr_msg := usr_msg + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
429			Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
430			if (ShowSQLMessage in IBDataBaseErrorMessages) then
431			begin
432			isc_sql_interprete(sqlcode, local_buffer, IBLocalBufferLength);
433			if (ShowSQLCode in IBDataBaseErrorMessages) then
434			usr_msg := usr_msg + CRLF;
435			usr_msg := usr_msg + strpas(local_buffer);
436			end;
437
438			if (ShowIBMessage in IBDataBaseErrorMessages) then
439			begin
440			if (ShowSQLCode in IBDataBaseErrorMessages) or
441			(ShowSQLMessage in IBDataBaseErrorMessages) then
442			usr_msg := usr_msg + CRLF;
443			while (isc_interprete(local_buffer, @status_vector) > 0) do
444			begin
445			if (usr_msg <> '') and (usr_msg[Length(usr_msg)] <> LF) then
446			usr_msg := usr_msg + CRLF;
447			usr_msg := usr_msg + strpas(local_buffer);
448			end;
449			end;
450			if (usr_msg <> '') and (usr_msg[Length(usr_msg)] = '.') then
451			Delete(usr_msg, Length(usr_msg), 1);
452			raise EIBInterBaseError.Create(sqlcode, IBErrorCode, usr_msg);
453			end;
454
455			{ Return the status vector for the current thread }
456			function StatusVector: PISC_STATUS;
457			begin
458			result := @FStatusVector;
459			end;
460
461			function StatusVectorArray: PStatusVector;
462			begin
463			result := @FStatusVector;
464			end;
465
466			function CheckStatusVector(ErrorCodes: array of ISC_STATUS): Boolean;
467			var
468			p: PISC_STATUS;
469			i: Integer;
470			procedure NextP(i: Integer);
471			begin
472			p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
473			end;
474			begin
475			p := @FStatusVector;
476			result := False;
477			while (p^ <> 0) and (not result) do
478			case p^ of
479			3: NextP(3);
480			1, 4:
481			begin
482			NextP(1);
483			i := 0;
484			while (i <= High(ErrorCodes)) and (not result) do
485			begin
486			result := p^ = ErrorCodes[i];
487			Inc(i);
488			end;
489			NextP(1);
490			end;
491			else
492			NextP(2);
493			end;
494			end;
495
496			function StatusVectorAsText: string;
497			var
498			p: PISC_STATUS;
499			function NextP(i: Integer): PISC_STATUS;
500			begin
501			p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
502			result := p;
503			end;
504			begin
505			p := @FStatusVector;
506			result := '';
507			while (p^ <> 0) do
508			if (p^ = 3) then
509			begin
510			result := result + Format('%d %d %d', [p^, NextP(1)^, NextP(1)^]) + CRLF;
511			NextP(1);
512			end
513			else begin
514			result := result + Format('%d %d', [p^, NextP(1)^]) + CRLF;
515			NextP(1);
516			end;
517			end;
518
519	tony	27	{ TResultBuffer }
520	tony	17
521	tony	27	constructor TResultBuffer.Create(aSize: integer);
522			begin
523			inherited Create;
524			mSize := aSize;
525			GetMem(mBuffer,aSize);
526			FillChar(mBuffer^,mSize,255);
527			end;
528
529			destructor TResultBuffer.Destroy;
530			begin
531			if mBuffer <> nil then FreeMem(mBuffer);
532			inherited;
533			end;
534
535			function TResultBuffer.buffer: PChar;
536			begin
537			Result := mBuffer;
538			end;
539
540			function TResultBuffer.FindToken(token: char): PChar;
541			var p: PChar;
542			len: integer;
543			begin
544			Result := nil;
545			p := mBuffer;
546
547			while p^ <> char(isc_info_end) do
548			begin
549			if p^ = token then
550			begin
551			Result := p;
552			Exit;
553			end;
554			len := isc_vax_integer(p+1,2);
555			Inc(p,len+3);
556			end;
557			end;
558
559			function TResultBuffer.FindToken(token: char; subtoken: char): PChar;
560			var p: PChar;
561			len, inlen: integer;
562			begin
563			Result := nil;
564			p := mBuffer;
565
566			while p^ <> char(isc_info_end) do
567			begin
568			if p^ = token then
569			begin
570			{Found token, now find subtoken}
571			inlen := isc_vax_integer(p+1, 2);
572			Inc(p,3);
573			while inlen > 0 do
574			begin
575			if p^ = subtoken then
576			begin
577			Result := p;
578			Exit;
579			end;
580			len := isc_vax_integer(p+1, 2);
581			Inc(p,len + 3);
582			Dec(inlen,len + 3);
583			end;
584			Exit;
585			end;
586			len := isc_vax_integer(p+1, 2);
587			inc(p,len+3);
588			end;
589			end;
590
591			function TResultBuffer.GetBool(token: char): boolean;
592			var aValue: integer;
593			p: PChar;
594			begin
595			p := FindToken(token);
596
597			if p = nil then
598			IBError(ibxeDscInfoTokenMissing,[token]);
599
600			aValue := isc_vax_integer(p+1, 4);
601			Result := aValue <> 0;
602			end;
603
604			function TResultBuffer.GetCountValue(token: char): integer;
605			var len: integer;
606			p: PChar;
607			begin
608			{Specifically used on tokens like isc_info_insert_count and the like
609			which return detailed counts per relation. We sum up the values.}
610
611			p := FindToken(token);
612
613			if p = nil then
614			IBError(ibxeDscInfoTokenMissing,[token]);
615
616			{len is the number of bytes in the following array}
617
618			len := isc_vax_integer(p+1, 2);
619			Inc(p,3);
620			Result := 0;
621			while len > 0 do
622			begin
623			{Each array item is 6 bytes : 2 bytes for the relation_id which
624			we skip, and 4 bytes for the count value which we sum up across
625			all tables.}
626
627			Inc(Result,isc_vax_integer(p+2, 4));
628			Inc(p,6);
629			Dec(len,6);
630			end;
631			end;
632
633			function TResultBuffer.GetString(token: char; var data: string): integer;
634			var p: PChar;
635			begin
636			Result := 0;
637			p := FindToken(token);
638
639			if p = nil then
640			IBError(ibxeDscInfoTokenMissing,[token]);
641
642			Result := isc_vax_integer(p+1, 2);
643			SetString(data,p+3,Result);
644			end;
645
646			function TResultBuffer.GetValue(token: char): integer;
647			var len: integer;
648			p: PChar;
649			begin
650			Result := 0;
651			p := FindToken(token);
652
653			if p = nil then
654			IBError(ibxeDscInfoTokenMissing,[token]);
655
656			len := isc_vax_integer(p+1, 2);
657			if (len <> 0) then
658			Result := isc_vax_integer(p+3, len);
659			end;
660
661			function TResultBuffer.GetValue(token: char; subtoken: char): integer;
662			var len: integer;
663			p: PChar;
664			begin
665			Result := 0;
666			p := FindToken(token, subtoken);
667
668			if p = nil then
669			IBError(ibxeDscInfoTokenMissing,[token]);
670
671			len := isc_vax_integer(p+1, 2);
672			if (len <> 0) then
673			Result := isc_vax_integer(p+3, len);
674			end;
675
676			function TResultBuffer.Size: short;
677			begin
678			Result := mSize;
679			end;
680
681			procedure TResultBuffer.Reset;
682			begin
683			if mBuffer <> nil then FreeMem(mBuffer);
684			GetMem(mBuffer,mSize);
685			FillChar(mBuffer^,mSize,255);
686			end;
687
688
689	tony	17	{ EIBError }
690			constructor EIBError.Create(ASQLCode: Long; Msg: string);
691			begin
692			inherited Create(Msg);
693			FSQLCode := ASQLCode;
694			end;
695
696			constructor EIBError.Create(ASQLCode: Long; AIBErrorCode: Long; Msg: string);
697			begin
698			inherited Create(Msg);
699			FSQLCode := ASQLCode;
700			FIBErrorCode := AIBErrorCode;
701			end;
702
703			procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
704			begin
705			EnterCriticalSection(IBCS);
706			try
707			IBDataBaseErrorMessages := Value;
708			finally
709			LeaveCriticalSection(IBCS);
710			end;
711			end;
712
713			function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
714			begin
715			EnterCriticalSection(IBCS);
716			try
717			result := IBDataBaseErrorMessages;
718			finally
719			LeaveCriticalSection(IBCS);
720			end;
721			end;
722
723			initialization
724	tony	21	// IsMultiThread := True;
725	tony	17	InitCriticalSection(IBCS);
726			IBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];
727
728			finalization
729			DoneCriticalSection(IBCS);
730
731	tony	27	end.