pfibclientdataset.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 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
    constructor Create(AOwner: TComponent); override;
    procedure   OpenWP(ParamValues: array of Variant);
  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;  virtual;
     function  GetAsString: string; override;
     function  GetAsInt64: Int64; virtual;
     function  GetAsVariant: Variant; override;
     procedure SetAsFloat(Value: Double); override;

     procedure SetAsExtended(Value: Extended); virtual;
     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 }

constructor TpFIBClientDataSet.Create(AOwner: TComponent);
begin
  inherited;
end;

procedure TpFIBClientDataSet.DataConvert(Field: TField; Source,
  Dest: Pointer; ToNative: Boolean);
var
 Scale :byte;
{$IFDEF D10+}
 ws  :WideString;
 s   :String;
 L   :Word;
 //BDS2006  玎漯嚯!!!!
{$ENDIF D10+}
begin
 if  (Field.DataType<>ftBCD) or (Field.Size=4)
 then
 {$IFDEF D10+}
  if Field.DataType = ftWideString then
   begin
    if ToNative then
    begin
      s := UTF8Encode(pWideChar(Source));
      L :=Length(s);
      Move(L,Dest^,SizeOf(Word));
      if L>0 then
       Move(s[1], PChar(PChar(Dest)+2)^, (L+1)*SizeOf(Char));
    end
    else
    begin
     ws:=UTF8Decode(PChar(PChar(Source)+2));
     if Length(ws)>0 then
      Move((PWideChar(ws))^, PWideChar(Dest)^, (Length(ws)+1)*SizeOf(WideChar))
     else
      PWideChar(Dest)^:=#$00;
//     (PWideChar(Dest)+ Length(ws)*SizeOf(WideChar))^ := #$00;
//      SetString(ws, PChar(PChar(Source)+2), Word(Source^) div 2);

    end;
  end
  else
{$ENDIF D10+}
   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;

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

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