pfibclientdataset.pas

FIBPlus version 6-96. This is somewhat usefull interbase database components. TFIBDatabase, TFIBTab

{***************************************************************}
{ 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 pFIBClientDataSet;

interface
{$I FIBPlus.inc}
uses
  pFIBInterfaces,
  {$IFNDEF LINUX}
  Windows, Messages, SysUtils, Classes,
  Db, DbConsts,DBClient,Provider,DSIntf,MidConst
  {$IFDEF D6+},FMTBcd,Variants{$ENDIF};
  {$ELSE}
  SysUtils, Classes, DBClient, DB, Provider, FmtBcd,
  DbConsts, Variants, DSIntf, MidConst;
  {$ENDIF}


{$T-,H+,X+}
type

  TOnApplyUpdateKind =(aukBefore,aukAfter);

  TpFIBClientDataSet = class(TClientDataSet,ISQLObject)
  protected
    function  GetFieldClass(FieldType: TFieldType): TFieldClass; override;
    procedure DataConvert(Field: TField; Source, Dest: Pointer; ToNative: Boolean); override;
//ISQLObject
   function  ParamCount:integer;
   function  ParamName(ParamIndex:integer):string;
   function  FieldsCount:integer;
   function  FieldExist(const FieldName:string; var FieldIndex:integer):boolean;
   function  ParamExist(const ParamName:string; var ParamIndex:integer):boolean;
   function  FieldValue(const FieldName:string; Old:boolean):variant;   overload;
   function  FieldValue(const FieldIndex:integer;Old:boolean):variant; overload;
   function  ParamValue(const ParamName:string):variant;   overload;
   function  ParamValue(const ParamIndex:integer):variant; overload;
   procedure SetParamValue(const ParamIndex:integer; aValue:Variant);
   function  FieldName(FieldIndex:integer):string;
   function  IEof:boolean;
   procedure INext;
//
  public
    procedure   OpenWP(ParamValues: array of Variant);
    procedure   Commit;
    procedure   RollBack;
    function    TransactionIsActive:boolean;
  published
    { Published declarations }
  end;

  TpFIBClientBCDField=class (TBCDField)
  private
  protected
     function  GetAsCurrency: Currency; override;
     function  GetAsFloat: Double; override;

{$IFNDEF NO_USE_COMP}
     function  GetAsComp : Comp  ;  virtual;
     procedure SetAsComp(Value: comp); virtual;
{$ENDIF}
     function  GetAsExtended: Extended;  override;
     function  GetAsString: string; override;
     function  GetAsInt64: Int64; virtual;
     function  GetAsVariant: Variant; override;
     procedure SetAsFloat(Value: Double); override;

     procedure SetAsExtended(Value: Extended); override;
     procedure SetAsString(const Value: string); override;
     procedure SetAsCurrency(Value: Currency); override;
     procedure SetAsInt64(Value: Int64); virtual;
     procedure SetVarValue(const Value: Variant); override;
     procedure GetText(var Text: string; DisplayText: Boolean); override;
  public
     procedure Assign(Source: TPersistent); override;
     property AsExtended :Extended read GetAsExtended write SetAsExtended;
     property AsInt64    :Int64    read GetAsInt64    write SetAsInt64;
{$IFNDEF NO_USE_COMP}
     property AsComp     :Comp     read GetAsComp     write SetAsComp;
{$ENDIF}     
     property Value      :Extended read GetAsExtended write SetAsExtended;
  end;

{  TpFIBClientGuidField=class(TGuidField)
  protected
  end ;
 }
  TpFIBDataSetProvider = class(TDataSetProvider)
  protected
    function FindRecord(Source, Delta: TDataSet; UpdateMode: TUpdateMode): Boolean; {$IFDEF D9+}override;{$ENDIF}
    procedure UpdateRecord(Source, Delta: TDataSet; BlobsOnly, KeyOnly: Boolean); override;
    function CreateResolver: TCustomResolver; override;
  end
  ;


procedure Register;

implementation

{$R fibplus_midas.dcr}

uses StdFuncs;

type
  TpFIBDataSetResolver = class(TDataSetResolver)
  private
    procedure PutRecord(Tree: TUpdateTree);

  protected
    procedure InternalBeforeResolve(Tree: TUpdateTree); override;
    procedure DoUpdate(Tree: TUpdateTree); override;
    procedure DoDelete(Tree: TUpdateTree); override;
    procedure DoInsert(Tree: TUpdateTree); override;
  end;


{ TpFIBClientDataSet }

procedure TpFIBClientDataSet.Commit;
var
  DummyOwnerData: OleVariant;
  DummyParams   : OleVariant;
begin
   if Assigned(AppServer) then
    AppServer.AS_Execute(ProviderName, 'COMMIT', DummyParams, DummyOwnerData);
end;

function TpFIBClientDataSet.TransactionIsActive: boolean;
var
  DummyOwnerData: OleVariant;
  Params   : OleVariant;
  v:Variant;
begin
  if Assigned(AppServer) then
  begin
   AppServer.AS_Execute(ProviderName, 'GET_INTRANSACTION', Params, DummyOwnerData);
   v:=Params[0];
   Result:=v[1];
  end
  else
   Result:=False
end;


procedure TpFIBClientDataSet.DataConvert(Field: TField; Source,
  Dest: Pointer; ToNative: Boolean);
var
 Scale :byte;
begin
 if  (Field.DataType<>ftBCD) or (Field.Size=4)
 then
   inherited DataConvert(Field,Source,  Dest,ToNative)
 else
   if ToNative then
        Int64ToBCD(Int64(Source^), Field.Size, TBcd(Dest^))
   else
    if not BCDToCompWithScale(TBcd(Source^), Int64(Dest^),Scale ) then
        raise EOverFlow.CreateFmt(SFieldOutOfRange, [Field.DisplayName]);

end;



function TpFIBClientDataSet.FieldExist(const FieldName: string;
  var FieldIndex: integer): boolean;
var
  tf:TField;
begin
 tf:=FindField(FieldName);
 Result:= Assigned(tf);
 if Result then
  FieldIndex:=tf.Index;
end;

function TpFIBClientDataSet.FieldName(FieldIndex: integer): string;
begin
  Result:=Fields[FieldIndex].FieldName;
end;

function TpFIBClientDataSet.FieldsCount: integer;
begin
  Result:=FieldCount
end;

function TpFIBClientDataSet.FieldValue(const FieldName: string;
  Old: boolean): variant;
var
  tf:TField;
begin
 tf:=FieldByName(FieldName);
 if Old then
  Result:= tf.OldValue
 else
  Result:= tf.Value
end;

function TpFIBClientDataSet.FieldValue(const FieldIndex: integer;
  Old: boolean): variant;
var
  tf:TField;
begin
 tf:=Fields[FieldIndex];
 if Old and (State<>dsInsert) then
  Result:= tf.OldValue
 else
  Result:= tf.Value
end;

function TpFIBClientDataSet.GetFieldClass(
  FieldType: TFieldType): TFieldClass;
begin
 case FieldType of
  ftBCD :  Result:=TpFIBClientBCDField;
 else
  Result:=inherited GetFieldClass( FieldType)
 end
end;

function TpFIBClientDataSet.IEof: boolean;
begin
 Result:=Eof;
end;

procedure TpFIBClientDataSet.INext;
begin
  Next
end;

procedure TpFIBClientDataSet.OpenWP(ParamValues: array of Variant);
var i :integer;
    pc:integer;
begin
// Exec Query with ParamValues
 if High(ParamValues)<Pred(Params.Count) then
  pc:=High(ParamValues)
 else
  pc:=Pred(Params.Count);
 for i:=Low(ParamValues)  to pc do
  Params[i].Value:=ParamValues[i];
 Open
end;

function TpFIBClientDataSet.ParamCount: integer;
begin
 Result:=Params.Count
end;

function TpFIBClientDataSet.ParamExist(const ParamName: string;
  var ParamIndex: integer): boolean;
var
   par:TParam;
begin
 par:=Params.FindParam(ParamName);
 Result :=par<>nil;
 if Result then
  ParamIndex:=par.Index
end;

function TpFIBClientDataSet.ParamName(ParamIndex: integer): string;
begin
 Result:=Params[ParamIndex].Name;
end;

function TpFIBClientDataSet.ParamValue(const ParamIndex: integer): variant;
begin
 Result:=Params[ParamIndex].Value
end;

procedure TpFIBClientDataSet.RollBack;
var
  DummyOwnerData: OleVariant;
  DummyParams   : OleVariant;
begin
  if Assigned(AppServer) then
   AppServer.AS_Execute(ProviderName, 'ROLLBACK', DummyParams, DummyOwnerData);
end;

function TpFIBClientDataSet.ParamValue(const ParamName: string): variant;
begin
 Result:=Params.ParamByName(ParamName).Value
end;

procedure TpFIBClientDataSet.SetParamValue(const ParamIndex: integer;
  aValue: Variant);