TClientDataSet的 fastscript封装

TClientDataSet的 fastscript封装

// 陈新光 2017-2-10
// TClientDataSet's fastscript

unit fs_ClientDataSet;

interface

{$i fs.inc}

uses
  SysUtils, Classes, fs_iinterpreter, fs_itools, fs_ievents, DB, fs_iclassesrtti,
  Variants, DBClient
{$IFDEF Delphi16}
    , System.Types, Controls
{$ENDIF}
;

type
  TCDSRTTI = class(TClientDataSet);

  TCDSNotifyEvent = class(TfsCustomEvent)
  public
    procedure DoEvent(Dataset: TClientDataSet);
    function GetMethod: Pointer; override;
  end;

  TCDSErrorEvent = class(TfsCustomEvent)
  public
    procedure DoEvent(DataSet: TDataSet; E: EDatabaseError; var Action: TDataAction);
    function GetMethod: Pointer; override;
  end;

  TCDSFilterRecordEvent = class(TfsCustomEvent)
  public
    procedure DoEvent(DataSet: TClientDataSet; var Accept: Boolean);
    function GetMethod: Pointer; override;
  end;

  TCDSFieldGetTextEvent = class(TfsCustomEvent)
  public
    procedure DoEvent(Sender: TField; var Text: string; DisplayText: Boolean);
    function GetMethod: Pointer; override;
  end;

type
  TCDSFunctions = class(TfsRTTIModule)
  private
    function CallMethod(Instance: TObject; ClassType: TClass; const MethodName: string; Caller: TfsMethodHelper): Variant;
    function GetProp(Instance: TObject; ClassType: TClass; const PropName: string): Variant;
    procedure SetProp(Instance: TObject; ClassType: TClass; const PropName: string; Value: Variant);
  public
    constructor Create(AScript: TfsScript); override;
  end;

implementation

type
  TByteSet = set of 0..7;

  PByteSet = ^TByteSet;

procedure TCDSNotifyEvent.DoEvent(Dataset: TClientDataSet);
begin
  CallHandler([Dataset]);
end;

function TCDSNotifyEvent.GetMethod: Pointer;
begin
  Result := @TCDSNotifyEvent.DoEvent;
end;

procedure TCDSErrorEvent.DoEvent(DataSet: TDataSet; E: EDatabaseError; var Action: TDataAction);
begin
  CallHandler([DataSet, @E, @Action]);
  Action := Handler.Params[2].Value;
end;

function TCDSErrorEvent.GetMethod: Pointer;
begin
  Result := @TCDSErrorEvent.DoEvent;
end;

procedure TCDSFilterRecordEvent.DoEvent(DataSet: Tclientdataset; var Accept: Boolean);
begin
  CallHandler([DataSet, Accept]);
  Accept := Handler.Params[1].Value;
end;

function TCDSFilterRecordEvent.GetMethod: Pointer;
begin
  Result := @TCDSFilterRecordEvent.DoEvent;
end;

procedure TCDSFieldGetTextEvent.DoEvent(Sender: TField; var Text: string; DisplayText: Boolean);
begin
  CallHandler([Sender, Text, DisplayText]);
  Text := Handler.Params[1].Value;
end;

function TCDSFieldGetTextEvent.GetMethod: Pointer;
begin
  Result := @TCDSFieldGetTextEvent.DoEvent;
end;

constructor TCDSFunctions.Create(AScript: TfsScript);
begin
  inherited Create(AScript);
  with AScript do
  begin
    with AddClass(TClientDataSet, 'TDataSet') do
    begin
      AddMethod('procedure Open', CallMethod);
      AddMethod('procedure Close', CallMethod);
      AddMethod('procedure First', CallMethod);
      AddMethod('procedure Last', CallMethod);
      AddMethod('procedure Next', CallMethod);
      AddMethod('procedure Prior', CallMethod);
      AddMethod('procedure Cancel', CallMethod);
      AddMethod('procedure Delete', CallMethod);
      AddMethod('procedure Post', CallMethod);
      AddMethod('procedure Append', CallMethod);
      AddMethod('procedure Insert', CallMethod);
      AddMethod('procedure Edit', CallMethod);
      AddConstructor('constructor Create(AOwner: TComponent)', CallMethod);

      AddMethod('function FieldByName(const FieldName: string): TField', CallMethod);
      AddMethod('procedure GetFieldNames(List: TStrings)', CallMethod);
      AddMethod('function FindFirst: Boolean', CallMethod);
      AddMethod('function FindLast: Boolean', CallMethod);
      AddMethod('function FindNext: Boolean', CallMethod);
      AddMethod('function FindPrior: Boolean', CallMethod);
      AddMethod('procedure FreeBookmark(Bookmark: TBookmark)', CallMethod);
      AddMethod('function GetBookmark: TBookmark', CallMethod);
      AddMethod('procedure GotoBookmark(Bookmark: TBookmark)', CallMethod);
      AddMethod('function Locate(const KeyFields: string; const KeyValues: Variant;' + 'Options: TLocateOptions): Boolean', CallMethod);
      AddMethod('function IsEmpty: Boolean', CallMethod);
      AddMethod('procedure EnableControls', CallMethod);
      AddMethod('procedure DisableControls', CallMethod);
      AddMethod('procedure AddIndex(const Name, Fields: string;Options: TIndexOptions)', CallMethod);

      AddProperty('Bof', 'Boolean', GetProp, nil);
      AddProperty('Eof', 'Boolean', GetProp, nil);
      AddProperty('FieldCount', 'Integer', GetProp, nil);
      AddProperty('FieldDefs', 'TFieldDefs', GetProp, nil);
      AddProperty('Fields', 'TFields', GetProp, nil);
      AddProperty('Filter', 'string', GetProp, SetProp);
      AddProperty('Filtered', 'Boolean', GetProp, SetProp);
      AddProperty('FilterOptions', 'TFilterOptions', GetProp, SetProp);
      AddProperty('Active', 'Boolean', GetProp, SetProp);
      AddProperty('Data', 'OleVariant', GetProp, SetProp);
      AddProperty('Params', 'TParams', GetProp, NIL);
      AddProperty('IndexDefs', 'TIndexDefs', GetProp, nil);
      AddProperty('FilterCode', 'string', GetProp, SetProp);
      AddProperty('FilterLineListText', 'string', GetProp, SetProp);
      AddProperty('FilterLineSQL', 'string', GetProp, SetProp);
      AddProperty('FbMustFilter', 'Boolean', GetProp, SetProp);
      AddProperty('FbPost', 'Boolean', GetProp, SetProp);
      AddProperty('FbMultTable', 'Boolean', GetProp, SetProp);
      AddProperty('RecordCount', 'Integer', GetProp, nil);
      AddProperty('QFDataSetOpenSQL', 'string', GetProp, SetProp);

      AddEvent('BeforeOpen', TCDSNotifyEvent);
      AddEvent('AfterOpen', TCDSNotifyEvent);
      AddEvent('BeforeClose', TCDSNotifyEvent);
      AddEvent('AfterClose', TCDSNotifyEvent);
      AddEvent('BeforeInsert', TCDSNotifyEvent);
      AddEvent('AfterInsert', TCDSNotifyEvent);
      AddEvent('BeforeEdit', TCDSNotifyEvent);
      AddEvent('AfterEdit', TCDSNotifyEvent);
      AddEvent('BeforePost', TCDSNotifyEvent);
      AddEvent('AfterPost', TCDSNotifyEvent);
      AddEvent('BeforeCancel', TCDSNotifyEvent);
      AddEvent('AfterCancel', TCDSNotifyEvent);
      AddEvent('BeforeDelete', TCDSNotifyEvent);
      AddEvent('AfterDelete', TCDSNotifyEvent);
      AddEvent('BeforeScroll', TCDSNotifyEvent);
      AddEvent('AfterScroll', TCDSNotifyEvent);
      AddEvent('OnCalcFields', TCDSNotifyEvent);
      AddEvent('OnFilterRecord', TCDSFilterRecordEvent);
      AddEvent('OnNewRecord', TCDSNotifyEvent);
      AddEvent('OnPostError', TCDSErrorEvent);
    end;
  end;
end;

function TCDSFunctions.CallMethod(Instance: TObject; ClassType: TClass; const MethodName: string; Caller: TfsMethodHelper): Variant;
var
  _TDataSet: TClientDataSet;
  _TIndexDefs: TIndexDefs;

  function IntToLocateOptions(i: Integer): TLocateOptions;
  begin
    Result := [];
    if (i and 1) <> 0 then
      Result := Result + [loCaseInsensitive];
    if (i and 2) <> 0 then
      Result := Result + [loPartialKey];
  end;

  function IntToIndexOptions(i: Integer): TIndexOptions;
  begin
    Result := [];
    if (i = 1) then
      Result := Result + [ixPrimary];
    if (i = 2) then
      Result := Result + [ixUnique];
    if (i = 3) then
      Result := Result + [ixDescending];
    if (i = 4) then
      Result := Result + [ixCaseInsensitive];
    if (i = 5) then
      Result := Result + [ixExpression];
    if (i = 6) then
      Result := Result + [ixNonMaintained];
  end;

  procedure IndexDefsAdd(QName, QFields: string; QArgs: Variant);
  var
    ar: TIndexOptions;
    i, n: Integer;
  begin
    n := VarArrayHighBound(QArgs, 1) + 1;
    for i := 0 to n - 1 do
    begin
      ar := ar + IntToIndexOptions(QArgs[i]);
    end;
    _TIndexDefs.Add(QName, QFields, ar);
  end;

  procedure BsAddIndex(QName, QFields: string; QArgs: Variant);
  var
    ar: TIndexOptions;
    i, n: Integer;
  begin
    n := VarArrayHighBound(QArgs, 1) + 1;
    for i := 0 to n - 1 do
    begin
      ar := ar + IntToIndexOptions(QArgs[i]);
    end;
    _TDataSet.AddIndex(QName, QFields, ar);
  end;

begin
  Result := 0;
  if ClassType = TClientDataSet then
  begin
    _TDataSet := TClientDataSet(Instance);
    if MethodName = 'OPEN' then
      _TDataSet.Open
    else if MethodName = 'CLOSE' then
      _TDataSet.Close
    else if MethodName = 'FIRST' then
      _TDataSet.First
    else if MethodName = 'LAST' then
      _TDataSet.Last
    else if MethodName = 'NEXT' then
      _TDataSet.Next
    else if MethodName = 'PRIOR' then
      _TDataSet.Prior
    else if MethodName = 'CANCEL' then
      _TDataSet.Cancel
    else if MethodName = 'DELETE' then
      _TDataSet.Delete
    else if MethodName = 'POST' then
      _TDataSet.Post
    else if MethodName = 'APPEND' then
      _TDataSet.Append
    else if MethodName = 'INSERT' then
      _TDataSet.Insert
    else if MethodName = 'EDIT' then
      _TDataSet.Edit
    else if MethodName = 'FIELDBYNAME' then
      Result := frxInteger(_TDataSet.FieldByName(Caller.Params[0]))
    else if MethodName = 'GETFIELDNAMES' then
      _TDataSet.GetFieldNames(TStrings(frxInteger(Caller.Params[0])))
    else if MethodName = 'FINDFIRST' then
      Result := _TDataSet.FindFirst
    else if MethodName = 'FINDLAST' then
      Result := _TDataSet.FindLast
    else if MethodName = 'FINDNEXT' then
      Result := _TDataSet.FindNext
    else if MethodName = 'FINDPRIOR' then
      Result := _TDataSet.FindPrior
    else if MethodName = 'FREEBOOKMARK' then
      _TDataSet.FreeBookmark(TBookMark(frxInteger(Caller.Params[0]))){$IFNDEF WIN64}
    else if MethodName = 'GETBOOKMARK' then
      Result := frxInteger(_TDataSet.GetBookmark){$ENDIF}
    else if MethodName = 'GOTOBOOKMARK' then
      _TDataSet.GotoBookmark(TBookMark(frxInteger(Caller.Params[0])))
    else if MethodName = 'LOCATE' then
      Result := _TDataSet.Locate(Caller.Params[0], Caller.Params[1], IntToLocateOptions(Caller.Params[2]))
    else if MethodName = 'ISEMPTY' then
      Result := _TDataSet.IsEmpty
    else if MethodName = 'ENABLECONTROLS' then
      _TDataSet.EnableControls
    else if MethodName = 'DISABLECONTROLS' then
      _TDataSet.DisableControls
    else if MethodName = 'CREATE' then
      Result := frxInteger(TComponent(Instance).Create(TComponent(frxInteger(Caller.Params[0]))))
    else if MethodName = 'ADDINDEX' then
      BsAddIndex(Caller.Params[0], Caller.Params[1], Caller.Params[2])
  end
  else if ClassType = TIndexDefs then
  begin
    _TIndexDefs := TIndexDefs(Instance);
    if MethodName = 'ADD' then
      IndexDefsAdd(Caller.Params[0], Caller.Params[1], Caller.Params[2])
  end;
end;

function TCDSFunctions.GetProp(Instance: TObject; ClassType: TClass; const PropName: string): Variant;
var
  _TDataSet: TClientDataSet;

  function FilterOptionsToInt(f: TFilterOptions): Integer;
  begin
    Result := 0;
    if foCaseInsensitive in f then
      Result := Result or 1;
    if foNoPartialCompare in f then
      Result := Result or 2;
  end;

begin
  Result := 0;
  if ClassType = TClientDataSet then
  begin
    _TDataSet := TClientDataSet(Instance);
    if PropName = 'BOF' then
      Result := _TDataSet.Bof
    else if PropName = 'EOF' then
      Result := _TDataSet.Eof
    else if PropName = 'FIELDCOUNT' then
      Result := _TDataSet.FieldCount
    else if PropName = 'FIELDDEFS' then
      Result := frxInteger(_TDataSet.FieldDefs)
    else if PropName = 'FIELDS' then
      Result := frxInteger(_TDataSet.Fields)
    else if PropName = 'FILTER' then
      Result := _TDataSet.Filter
    else if PropName = 'FILTERED' then
      Result := _TDataSet.Filtered
    else if PropName = 'FILTEROPTIONS' then
      Result := FilterOptionsToInt(_TDataSet.FilterOptions)
    else if PropName = 'ACTIVE' then
      Result := _TDataSet.Active
    else if PropName = 'DATA' then
      Result := _TDataSet.Data
    else if PropName = 'PARAMS' then
      Result := frxInteger(_TDataSet.Params)
    else if PropName = 'INDEXDEFS' then
      Result := frxInteger(_TDataSet.IndexDefs)
    else if PropName = 'RECORDCOUNT' then
      Result := _TDataSet.RecordCount;
  end
end;

procedure TCDSFunctions.SetProp(Instance: TObject; ClassType: TClass; const PropName: string; Value: Variant);
var
  _TDataSet: TClientDataSet;

  function IntToFilterOptions(i: Integer): TFilterOptions;
  begin
    Result := [];
    if (i and 1) <> 0 then
      Result := Result + [foCaseInsensitive];
    if (i and 2) <> 0 then
      Result := Result + [foNoPartialCompare];
  end;

begin
  if ClassType = TClientDataSet then
  begin
    _TDataSet := TClientDataSet(Instance);
    if PropName = 'FILTER' then
      _TDataSet.Filter := Value
    else if PropName = 'FILTERED' then
      _TDataSet.Filtered := Value
    else if PropName = 'FILTEROPTIONS' then
      _TDataSet.FilterOptions := IntToFilterOptions(Value)
    else if PropName = 'ACTIVE' then
      _TDataSet.Active := Value
    else if PropName = 'DATA' then
      _TDataSet.Data := Value;
  end
end;

initialization
  fsRTTIModules.Add(TCDSFunctions);

finalization
  fsRTTIModules.Remove(TCDSFunctions);

end.