fastscript增加三方控件之二

unit fs_BsDataSet;

interface

{$i fs.inc}

uses

SysUtils, Classes, fs_iinterpreter, fs_itools, fs_ievents,

DB,Bs_DataSet,fs_iclassesrtti,System.Variants;

type

TBsDBRTTI = class(TBsDataSet); // fake component

TBsDatasetNotifyEvent = class(TfsCustomEvent)

public

procedure DoEvent(Dataset: TBsDataSet);

function GetMethod: Pointer; override;

end;

TBsDataSetErrorEvent = class(TfsCustomEvent)

public

procedure DoEvent(DataSet: TDataSet; E: EDatabaseError;var Action: TDataAction);

function GetMethod: Pointer; override;

end;

TBsFilterRecordEvent = class(TfsCustomEvent)

public

procedure DoEvent(DataSet: TBsDataSet; var Accept: Boolean);

function GetMethod: Pointer; override;

end;

TBsFieldGetTextEvent = class(TfsCustomEvent)

public

procedure DoEvent(Sender: TField; var Text: String; DisplayText: Boolean);

function GetMethod: Pointer; override;

end;

type

TBsFunctions = 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;

VAR BsFunctions:TBsFunctions;

implementation

type

TByteSet = set of 0..7;

PByteSet = ^TByteSet;

{ TfsDatasetNotifyEvent }

procedure TBsDatasetNotifyEvent.DoEvent(Dataset: TBsDataSet);

begin

CallHandler([Dataset]);

end;

function TBsDatasetNotifyEvent.GetMethod: Pointer;

begin

Result := @TBsDatasetNotifyEvent.DoEvent;

end;

procedure TBsDataSetErrorEvent.DoEvent(DataSet: TDataSet; E: EDatabaseError;var Action: TDataAction);

begin

CallHandler([Dataset,@E,@Action]);

Action := Handler.Params[2].Value;

end;

function TBsDataSetErrorEvent.GetMethod: Pointer;

begin

Result := @TBsDataSetErrorEvent.DoEvent;

end;

{ TfsFilterRecordEvent }

procedure TBsFilterRecordEvent.DoEvent(DataSet: TBsDataSet; var Accept: Boolean);

begin

CallHandler([DataSet, Accept]);

Accept := Handler.Params[1].Value;

end;

function TBsFilterRecordEvent.GetMethod: Pointer;

begin

Result := @TBsFilterRecordEvent.DoEvent;

end;

{ TfsFieldGetTextEvent }

procedure TBsFieldGetTextEvent.DoEvent(Sender: TField; var Text: String; DisplayText: Boolean);

begin

CallHandler([Sender, Text, DisplayText]);

Text := Handler.Params[1].Value;

end;

function TBsFieldGetTextEvent.GetMethod: Pointer;

begin

Result := @TBsFieldGetTextEvent.DoEvent;

end;

{ TFunctions }

constructor TBsFunctions.Create(AScript: TfsScript);

begin

inherited Create(AScript);

with AScript do

begin

AddEnum('TDataAction','daFail, daAbort, daRetry');

AddEnumSet('TIndexOptions', 'ixPrimary, ixUnique, ixDescending, ixCaseInsensitive,ixExpression, ixNonMaintained');

with AddClass(Exception,'TObject') do

begin

end;

with AddClass(EDatabaseError,'Exception') do

begin

end;

with AddClass(TIndexDefs,'TCollection') do

begin

AddMethod('procedure Add(const Name,Fields:string;Options: TIndexOptions)',CallMethod);

end;

with AddClass(TBsDataSet, 'TDataSet') do

begin

AddMethod('procedure OpenData', CallMethod);

AddMethod('procedure OpenList', CallMethod);

AddMethod('procedure OpenPackList', CallMethod);

AddMethod('procedure OpenListUP', CallMethod);

AddMethod('procedure OpenListDown', CallMethod);

AddMethod('procedure SaveData', CallMethod);

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', TBsDatasetNotifyEvent);

AddEvent('AfterOpen', TBsDatasetNotifyEvent);

AddEvent('BeforeClose', TBsDatasetNotifyEvent);

AddEvent('AfterClose', TBsDatasetNotifyEvent);

AddEvent('BeforeInsert', TBsDatasetNotifyEvent);

AddEvent('AfterInsert', TBsDatasetNotifyEvent);

AddEvent('BeforeEdit', TBsDatasetNotifyEvent);

AddEvent('AfterEdit', TBsDatasetNotifyEvent);

AddEvent('BeforePost', TBsDatasetNotifyEvent);

AddEvent('AfterPost', TBsDatasetNotifyEvent);

AddEvent('BeforeCancel', TBsDatasetNotifyEvent);

AddEvent('AfterCancel', TBsDatasetNotifyEvent);

AddEvent('BeforeDelete', TBsDatasetNotifyEvent);

AddEvent('AfterDelete', TBsDatasetNotifyEvent);

AddEvent('BeforeScroll', TBsDatasetNotifyEvent);

AddEvent('AfterScroll', TBsDatasetNotifyEvent);

AddEvent('OnCalcFields', TBsDatasetNotifyEvent);

AddEvent('OnFilterRecord', TBsFilterRecordEvent);

AddEvent('OnNewRecord', TBsDatasetNotifyEvent);

AddEvent('OnPostError', TBsDataSetErrorEvent);

end;

end;

end;

function TBsFunctions.CallMethod(Instance: TObject; ClassType: TClass;

const MethodName: String; Caller: TfsMethodHelper): Variant;

var

_TDataSet: TBsDataSet;

_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 = TBsDataSet then

begin

_TDataSet := TBsDataSet(Instance);

if MethodName='OPENDATA' then

_TDataSet.OpenData

ELSE

if MethodName='OPENLIST' then

_TDataSet.OpenList

ELSE

if MethodName='OPENPACKLIST' then

_TDataSet.OpenPackList

ELSE

if MethodName='OPENLISTUP' then

_TDataSet.OpenListUP

ELSE

if MethodName='OPENLISTDOWN' then

_TDataSet.OpenListDown

ELSE

if MethodName='SAVEDATA' then

_TDataSet.SaveData

ELSE

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 TBsFunctions.GetProp(Instance: TObject; ClassType: TClass;

const PropName: String): Variant;

var

_TField: TField;

_TParam: TParam;

_TDataSet: TBsDataSet;

_TIndexDefs:TIndexDefs;

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 = TBsDataSet then

begin

_TDataSet := TBsDataSet(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 = 'FILTERCODE' then

Result := _TDataSet.FilterCode

else if PropName = uppercase('FilterLineListText') then

Result := _TDataSet.FilterLineListText

else if PropName = uppercase('FilterLineSQL') then

Result := _TDataSet.FilterLineSQL

else if PropName = 'FBMUSTFILTER' then

Result := _TDataSet.FbMustFilter

else if PropName = 'FBPOST' then

Result := _TDataSet.FbPost

else if PropName = 'FBMULTTABLE' then

Result := _TDataSet.FbMultTable

else if PropName = 'RECORDCOUNT' then

Result := _TDataSet.RecordCount

else if PropName = 'QFDATASETOPENSQL' then

Result := _TDataSet.QFDataSetOpenSQL;

end

end;

procedure TBsFunctions.SetProp(Instance: TObject; ClassType: TClass;

const PropName: String; Value: Variant);

var

_TField: TField;

_TParam: TParam;

_TDataSet: TBsDataSet;

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 = TBsDataSet then

begin

_TDataSet := TBsDataSet(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

else if PropName = 'FILTERCODE' then

_TDataSet.FilterCode := Value

else if PropName = uppercase('FilterLineListText') then

_TDataSet.FilterLineListText := Value

else if PropName = uppercase('FilterLineSQL') then

_TDataSet.FilterLineSQL := Value

else if PropName = 'FBMUSTFILTER' then

_TDataSet.FbMustFilter := Value

else if PropName = 'FBPOST' then

_TDataSet.Fbpost := Value

else if PropName = 'FBMULTTABLE' then

_TDataSet.FbMultTable := Value

else if PropName = 'QFDATASETOPENSQL' then

_TDataSet.QFDataSetOpenSQL := Value;

end

end;

initialization

finalization

end.