fib.pas

FIBPlus is a component suite intended for work with InterBase. It is direct, fast and flexible Inter

{***************************************************************}
{ FIBPlus - component library for direct access to Firebird and }
{ InterBase databases                                           }
{                                                               }
{    FIBPlus is based in part on the product                    }
{    Free IB Components, written by Gregory H. Deatz for        }
{    Hoagland, Longo, Moran, Dunst & Doukas Company.            }
{    mailto:[e-mail]                                    }
{                                                               }
{    Copyright (c) 1998-2007 Devrace Ltd.                       }
{    Written by Serge Buzadzhy ([e-mail])               }
{                                                               }
{ ------------------------------------------------------------- }
{    FIBPlus home page: http://www.fibplus.com/                 }
{    FIBPlus support  : http://www.devrace.com/support/         }
{ ------------------------------------------------------------- }
{                                                               }
{  Please see the file License.txt for full license information }
{***************************************************************}


unit fib;

{$I FIBPlus.inc}
{$T-}

interface

uses
 {$IFDEF WINDOWS}
  Windows, SysUtils, Classes, ibase,IB_Intf, ib_externals,Db
  ;
 {$ENDIF}
 {$IFDEF LINUX}
  Types, SysUtils, Classes, ibase,IB_Intf, IB_Externals,Db,
  Libc;
 {$ENDIF}

type

  (*
   * It might seem more natural for the EFIBError constructor to
   * include the Msg parameter first, and the ASQLCode second, but
   * to get this to work easily with C++-Builder, the parameter
   * order is switched.
   *)


  EFIBError                  = class(EDatabaseError)
  private
    FSQLCode: Long;
    FIBErrorCode: Long;
    FRaiserName: string; // IMS
    FSQLMessage :string;
    FIBMessage  :string;
    FCustomMessage: string; // IMS
    FMsg: string;
    SenderObj :TObject;
    procedure RebuildMessage; // IMS
    procedure SetSQLMessage(Value: string); // IMS
    procedure SetIBMessage(Value: string); // IMS
    procedure SetCustomMessage(const Value: string); // IMS
    procedure SetMsg(const Value: string); // IMS
  public
    constructor Create(ASQLCode: Long; const aMsg: String;Sender:TObject);
    constructor CreateEx(ASQLCode: Long; const IBMsg,SQLMsg,CstmMsg: String;Sender:TObject);
    property    SQLCode    : Long read FSQLCode ;
    property    IBErrorCode: Long read FIBErrorCode ;
    property    RaiserName: string read FRaiserName write FRaiserName; // IMS
    // IMS - SQLMessage and IBMessage write permissions
    property    SQLMessage :string read FSQLMessage write SetSQLMessage;
    property    IBMessage  :string read FIBMessage write SetIBMessage;
    property    CustomMessage: string read FCustomMessage write SetCustomMessage; // IMS
    property    Msg: string read FMsg write SetMsg; // IMS
  end;


  EFIBInterBaseError         = class(EFIBError);
  EFIBClientError            = class(EFIBError);



  TIBErrorMessage            = (ShowSQLCode,
                                ShowIBMessage,
                                ShowSQLMessage,
                                ShowRaiserName
                               );
  TIBErrorMessages          = set of TIBErrorMessage;


  TFIBClientError            = (
                                feUnknownError,
                                feNotSupported,
                                feNotPermitted,
                                feFileAccessError,
                                feConnectionTimeout,
                                feCannotSetDatabase,
                                feCannotSetTransaction,
                                feOperationCancelled,
                                feDPBConstantNotSupported,
                                feDPBConstantUnknown,
                                feTPBConstantNotSupported,
                                feTPBConstantUnknown,
                                feDatabaseClosed,
                                feDatabaseOpen,
                                feDatabaseNameMissing,
                                feNotInTransaction,
                                feInTransaction,
                                feTimeoutNegative,
                                feNoDatabasesInTransaction,
                                feUpdateWrongDB,
                                feUpdateWrongTR,
                                feDatabaseNotAssigned,
                                feTransactionNotAssigned,
                                feXSQLDAIndexOutOfRange,
                                feXSQLDANameDoesNotExist,
                                feEOF,
                                feBOF,
                                feInvalidStatementHandle,
                                feDatasetOpen,
                                feDatasetClosed,
                                feUnknownSQLDataType,
                                feInvalidColumnIndex,
                                feInvalidParamColumnIndex,
                                feInvalidDataConversion,
                                feColumnIsNotNullable,
                                feBlobCannotBeRead,
                                feBlobCannotBeWritten,
                                feEmptyQuery,
                                feCannotOpenNonSQLSelect,
                                feNoFieldAccess,
                                feFieldReadOnly,
                                feFieldNotFound,
                                feNotInEditState,
                                feNotEditing,
                                feCannotInsert,
                                feCannotPost,
                                feCannotUpdate,
                                feCannotDelete,
                                feCannotRefresh,
                                feBufferNotSet,
                                feCircularReference,
                                feSQLParseError,
                                feUserAbort,
                                feDataSetUniDirectional,
                                feCannotCreateSharedResource,
                                feWindowsAPIError,
                                feColumnListsDontMatch,
                                feColumnTypesDontMatch,
                                feCantEndSharedTransaction,
                                // Added
                                feNotIsArrayField,
                                feWrongDimension,
                                feSQLDialectInvalid,
                                feIBMissing,
                                feIB60feature,
                                // Added by Serg Vostrikov
                                feInterBaseInstallMissing,
                                feServiceActive,
                                feServiceInActive,
                                feServerNameMissing,
                                feQueryParamsError,
                                feStartParamsError,
                                feOutputParsingError,
                                feUseSpecificProcedures,
                                feSPBConstantNotSupported,
                                feSPBConstantUnknown,
                                feFieldSizeMismatch,

                                feCantUseLimitedCache,
                                feFieldListEmpty,
                                feCantUseField,
                                feFB2feature

                                );

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


  (* TFIBTLGlobals *)
  (* A single structure will be used to maintain all thread-local "globals".
    Right now, the only thread-local "global" is FStatusVector, although
    this can certainly change. *)

const
  {$I pFIBVersion.inc}

  (* For building buffers to send to IB *)
  CRLF = #13#10;
  FIBLocalBufferLength = 512;
  FIBBigLocalBufferLength = FIBLocalBufferLength * 2;
  FIBHugeLocalBufferLength = FIBBigLocalBufferLength * 20;
  (* Default "Prefix" to show in error messages. *)

  {$I FIB_MESSAGES.INC}

  DPBPrefix = 'isc_dpb_';
  DPBConstantNames: array[1..isc_dpb_last_dpb_constant] of String = (
    'cdd_pathname',
    'allocation',
    'journal',
    'page_size',
    'num_buffers',
    'buffer_length',
    'debug',
    'garbage_collect',
    'verify',
    'sweep',
    'enable_journal',
    'disable_journal',
    'dbkey_scope',
    'number_of_users',
    'trace',
    'no_garbage_collect',
    'damaged',
    'license',
    'sys_user_name',
    'encrypt_key',
    'activate_shadow',
    'sweep_interval',
    'delete_shadow',
    'force_write',
    'begin_log',
    'quit_log',
    'no_reserve',
    'user_name',
    'password',
    'password_enc',
    'sys_user_name_enc',
    'interp',
    'online_dump',
    'old_file_size',
    'old_num_files',
    'old_file',
    'old_start_page',
    'old_start_seqno',
    'old_start_file',
    'drop_walfile',
    'old_dump_id',
    'wal_backup_dir',
    'wal_chkptlen',
    'wal_numbufs',
    'wal_bufsize',
    'wal_grp_cmt_wait',
    'lc_messages',
    'lc_ctype',
    'cache_manager',
    'shutdown',
    'online',
    'shutdown_delay',
    'reserved',
    'overwrite',
    'sec_attach',
    'disable_wal',
    'connect_timeout',
    'dummy_packet_interval',
    'gbak_attach',
    'sql_role_name',
    'set_page_buffers',
    'working_directory',
    'sql_dialect',
    'set_db_readonly',
    'set_db_sql_dialect',
    'gfix_attach',
    'gstat_attach',
//IB2007
    'gbak_ods_version',              
    'gbak_ods_minor_version',        
    'set_group_commit',              
    'gbak_validate',                 
    'client_interbase_var',          
    'admin_option',                  
    'flush_interval',                
    'instance_name',                 
    'old_overwrite',                 
    'archive_database',              
    'archive_journals',              
    'archive_sweep',                 
    'archive_dumps',                 
    'archive_recover',               
    'recover_until',                 
    'force'

  );
  TPBPrefix = 'isc_tpb_';
  TPBConstantNames: array[1..isc_tpb_last_tpb_constant] of String = (
    'consistency',
    'concurrency',
    'shared',
    'protected',
    'exclusive',
    {$IFDEF LINUX}
    'isc_tpb_wait', {SVD}
    'isc_tpb_nowait',{SVD}
    {$ELSE}
    'wait',
    'nowait',
    {$ENDIF}
    'read',
    'write',
    'lock_read',
    'lock_write',
    'verb_time',
    'commit_time',
    'ignore_limbo',
    'read_committed',
    'autocommit',
    'rec_version',
    'no_rec_version',
    'restart_requests',
    'no_auto_undo',
    'no_savepoint'
  );


type
TpFIBLoginDialog=
 function (const ADatabaseName: string; var AUserName, APassword,ARoleName: string): Boolean;



const
  SQLDecimalSeparator='.';

resourcestring
  TrueStr='True';
  FalseStr='False';
var
  FIBCS: TRTLCriticalSection;
  hFIBTLGlobals: DWord;
  pFIBLoginDialog :TpFIBLoginDialog;

(* FIBAlloc acts like Realloc, except that it guarantees that
   the "newly" allocated memory is initialized to 0's *)
procedure FIBAlloc(var p; OldSize, NewSize: DWord);
(* Error message routines. *)
procedure FIBError(ErrMess: TFIBClientError; const Args: array of const);
procedure FIBErrorEx(const ErrMess:string; const Args: array of const);

procedure IBError(ClientLibrary:IIbClientLibrary;Sender:TObject);

procedure RegisterErrorHandler(aErrorHandler:TComponent);
procedure UnRegisterErrorHandler;
function ErrorHandlerRegistered:boolean;

(* Management of the thread-local TFIBTLGlobals structure. *)
//procedure InitializeFIBTLGlobals;
//procedure FreeFIBTLGlobals;
(* Manage the thread-local status vector *)
function StatusVector: PISC_STATUS;
function StatusVectorArray: PStatusVector;
function CheckStatusVector(ErrorCodes: array of ISC_STATUS): Boolean;
function StatusVectorAsText: String;

(* Generate a DPB *)
procedure GenerateDPB(sl: TStrings; var DPB: String; var DPBLength: Short);
procedure GenerateTPB(sl: TStrings; var TPB: String; var TPBLength: Short);
(* Manage global options *)
procedure SetIBErrorMessages(Value: TIBErrorMessages);
function GetIBErrorMessages: TIBErrorMessages;


var
  IBErrorMessages: TIBErrorMessages;


implementation

uses pFIBErrorHandler,StdFuncs,StrUtil;

var
  IBErrorHandler :TpFibErrorHandler;
  TPBConstants    :TStringList;
  DPBConstants    :TStringList;

threadvar
  FStatusVector : TStatusVector;


{$IFDEF LINUX}
Const
 libpthreadmodulename = 'libpthread.so.0';
type
  TKeyValueDestructor = procedure(ValueInKey: Pointer); cdecl;
function TlsGetValue(Key : Integer) : Pointer; cdecl;
  external libpthreadmodulename name 'pthread_getspecific';
function TlsSetValue(Key : Integer; Ptr : Pointer) : Integer; cdecl;
  external libpthreadmodulename name 'pthread_setspecific';
function pthread_key_create(var Key: DWord; KeyValueDestructor: TKeyValueDestructor): Integer; cdecl;
  external libpthreadmodulename name 'pthread_key_create';

function pthread_key_delete(Key: DWord): Integer; cdecl;
  external libpthreadmodulename name 'pthread_key_delete';

procedure FreeTLSBuffer(ValueInKey: Pointer); export cdecl;
begin
  // called upon destruction of each thread.  ValueInKey guaranteed non-nil
  free(ValueInKey);
end;

{$ENDIF}


procedure FIBAlloc(var p; OldSize, NewSize: DWord);
begin
  if Pointer(p)=nil then
    GetMem(Pointer(p), NewSize)
  else
    ReallocMem(Pointer(P), NewSize);
  if NewSize>OldSize then
   FillChar((PChar(p)+OldSize)^,NewSize-OldSize,0);
end;

/// ErrorHandler

procedure RegisterErrorHandler(aErrorHandler:TComponent);
begin
 if aErrorHandler is TpFibErrorHandler then
  IBErrorHandler:=TpFibErrorHandler(aErrorHandler)
end;

procedure UnRegisterErrorHandler;
begin
 IBErrorHandler:=nil
end;

function ErrorHandlerRegistered:boolean;
begin
 Result:= (IBErrorHandler<>nil) and not(csDesigning in IBErrorHandler.ComponentState)
end;
(*
 * FIBError -
 *  Given an error code and some possible string arguments, raise
 *  an exception.
 *)

procedure FIBError(ErrMess: TFIBClientError; const Args: array of const);
begin
  raise EFIBClientError.Create(
          Ord(ErrMess),
          Format(FIBErrorMessages[ErrMess], Args),nil);
end;

procedure FIBErrorEx(const ErrMess:string; const Args: array of const);
begin
  raise EFIBClientError.Create(-1,Format(ErrMess, Args),nil);
end;

(*
 * IBError -
 *  Examine the status vector, and raise an
 *  exception based on the current values in it.
 *)
procedure IBError(ClientLibrary:IIbClientLibrary;Sender:TObject);
var
  sqlcode: Long;
  local_buffer: array[0..FIBHugeLocalBufferLength - 1] of char;
  vIBMessage:string;
  vSQLMessage:string;
  status_vector: PISC_STATUS;
  IBErrorMessages: TIBErrorMessages;

  vEFIBInterBaseError                   : EFIBInterBaseError  ;
  vRaiseExcept :boolean;
  tmpStr  :string;
begin
  (*
   * Initialize the working user message.
   * Get a local reference to the status vector.