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(var AServerName: string;
                               var AUserName, APassword: string): Boolean;
    function LoginDialogEx(var ADatabaseName: string;
                               var AUserName, APassword: string;
                               NameReadOnly: Boolean): Boolean;
    procedure SetCursor;
    procedure RestoreCursor;
  end;
  
  {$IF FPC_FULLVERSION < 20700 }
  RawByteString = AnsiString; {Needed for backwards compatibility}
  {$ENDIF}

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