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
#	Content
1	{************************************************************************}
2	{ }
3	{ Borland Delphi Visual Component Library }
4	{ InterBase Express core components }
5	{ }
6	{ Copyright (c) 1998-2000 Inprise Corporation }
7	{ }
8	{ InterBase Express is based in part on the product }
9	{ Free IB Components, written by Gregory H. Deatz for }
10	{ Hoagland, Longo, Moran, Dunst & Doukas Company. }
11	{ Free IB Components is used under license. }
12	{ }
13	{ The contents of this file are subject to the InterBase }
14	{ Public License Version 1.0 (the "License"); you may not }
15	{ use this file except in compliance with the License. You }
16	{ may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17	{ Software distributed under the License is distributed on }
18	{ an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
19	{ express or implied. See the License for the specific language }
20	{ governing rights and limitations under the License. }
21	{ The Original Code was created by InterBase Software Corporation }
22	{ and its successors. }
23	{ Portions created by Inprise Corporation are Copyright (C) Inprise }
24	{ Corporation. All Rights Reserved. }
25	{ Contributor(s): Jeff Overcash }
26	{ }
27	{ IBX For Lazarus (Firebird Express) }
28	{ Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29	{ Portions created by MWA Software are copyright McCallum Whyman }
30	{ Associates Ltd 2011 }
31	{ }
32	{************************************************************************}
33
34	unit IB;
35
36	{$Mode Delphi}
37
38	interface
39
40	uses
41	{$IFDEF WINDOWS }
42	Windows,
43	{$ELSE}
44	unix,
45	{$ENDIF}
46	SysUtils, Classes, IBExternals, IBUtils, DB, IBXConst, CustApp;
47
48	type
49	TIBGUIInterface = interface
50	function ServerLoginDialog(var AServerName: string;
51	var AUserName, APassword: string): Boolean;
52	function LoginDialogEx(var ADatabaseName: string;
53	var AUserName, APassword: string;
54	NameReadOnly: Boolean): Boolean;
55	procedure SetCursor;
56	procedure RestoreCursor;
57	end;
58
59	{$IF FPC_FULLVERSION < 20700 }
60	RawByteString = AnsiString; {Needed for backwards compatibility}
61	{$ENDIF}
62
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.