fs_idbrtti.pas

这个是功能强大的报表软件

{******************************************}
{                                          }
{             FastScript v1.9              }
{       DB.pas classes and functions       }
{                                          }
{  (c) 2003-2007 by Alexander Tzyganenko,  }
{             Fast Reports Inc             }
{                                          }
{******************************************}

unit fs_idbrtti;

interface

{$i fs.inc}

uses
  SysUtils, Classes, fs_iinterpreter, fs_itools, fs_iclassesrtti, fs_ievents,
  DB;

type
  TfsDBRTTI = class(TComponent); // fake component

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

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

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


implementation

type
  TFunctions = 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;


{ TfsDatasetNotifyEvent }

procedure TfsDatasetNotifyEvent.DoEvent(Dataset: TDataset);
begin
  CallHandler([Dataset]);
end;

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


{ TfsFilterRecordEvent }

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

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


{ TfsFieldGetTextEvent }

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

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


{ TFunctions }

constructor TFunctions.Create(AScript: TfsScript);
begin
  inherited Create(AScript);
  with AScript do
  begin
    AddEnum('TFieldType', 'ftUnknown, ftString, ftSmallint, ftInteger, ftWord,' +
      'ftBoolean, ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime,' +
      'ftBytes, ftVarBytes, ftAutoInc, ftBlob, ftMemo, ftGraphic, ftFmtMemo,' +
      'ftParadoxOle, ftDBaseOle, ftTypedBinary, ftCursor, ftFixedChar, ftWideString,' +
      'ftLargeint, ftADT, ftArray, ftReference, ftDataSet, ftOraBlob, ftOraClob,' +
      'ftVariant, ftInterface, ftIDispatch, ftGuid, ftTimeStamp, ftFMTBcd');
    AddEnum('TBlobStreamMode', 'bmRead, bmWrite, bmReadWrite');
    AddEnumSet('TLocateOptions', 'loCaseInsensitive, loPartialKey');
    AddEnumSet('TFilterOptions', 'foCaseInsensitive, foNoPartialCompare');
    AddEnum('TParamType', 'ptUnknown, ptInput, ptOutput, ptInputOutput, ptResult');

    with AddClass(TField, 'TComponent') do
    begin
      AddProperty('AsBoolean', 'Boolean', GetProp, SetProp);
      AddProperty('AsCurrency', 'Currency', GetProp, SetProp);
      AddProperty('AsDateTime', 'TDateTime', GetProp, SetProp);
      AddProperty('AsFloat', 'Double', GetProp, SetProp);
      AddProperty('AsInteger', 'Integer', GetProp, SetProp);
      AddProperty('AsString', 'String', GetProp, SetProp);
      AddProperty('AsVariant', 'Variant', GetProp, SetProp);
      AddProperty('DataType', 'TFieldType', GetProp, nil);
      AddProperty('DisplayName', 'String', GetProp, nil);
      AddProperty('DisplayText', 'String', GetProp, nil);
      AddProperty('IsNull', 'Boolean', GetProp, nil);
      AddProperty('Size', 'Integer', GetProp, SetProp);
      AddProperty('Value', 'Variant', GetProp, SetProp);
      AddProperty('OldValue', 'Variant', GetProp, nil);
      AddEvent('OnGetText', TfsFieldGetTextEvent);
    end;
    with AddClass(TFields, 'TObject') do
      AddDefaultProperty('Fields', 'Integer', 'TField', CallMethod, True);
    AddClass(TStringField, 'TField');
    AddClass(TNumericField, 'TField');
    AddClass(TIntegerField, 'TNumericField');
    AddClass(TSmallIntField, 'TIntegerField');
    AddClass(TWordField, 'TIntegerField');
    AddClass(TAutoIncField, 'TIntegerField');
    AddClass(TFloatField, 'TNumericField');
    AddClass(TCurrencyField, 'TFloatField');
    AddClass(TBooleanField, 'TField');
    AddClass(TDateTimeField, 'TField');
    AddClass(TDateField, 'TDateTimeField');
    AddClass(TTimeField, 'TDateTimeField');
    AddClass(TBinaryField, 'TField');
    AddClass(TBytesField, 'TBinaryField');
    AddClass(TVarBytesField, 'TBinaryField');
    AddClass(TBCDField, 'TNumericField');
    with AddClass(TBlobField, 'TField') do
    begin
      AddMethod('procedure LoadFromFile(const FileName: String)', CallMethod);
      AddMethod('procedure LoadFromStream(Stream: TStream)', CallMethod);
      AddMethod('procedure SaveToFile(const FileName: String)', CallMethod);
      AddMethod('procedure SaveToStream(Stream: TStream)', CallMethod);
    end;
    AddClass(TMemoField, 'TBlobField');
    AddClass(TGraphicField, 'TBlobField');
    AddClass(TFieldDef, 'TPersistent');
    with AddClass(TFieldDefs, 'TObject') do
    begin
      AddMethod('function AddFieldDef: TFieldDef', CallMethod);
      AddMethod('function Find(const Name: string): TFieldDef', CallMethod);
      AddMethod('procedure Add(const Name: string; DataType: TFieldType; Size: Word; Required: Boolean)', CallMethod);
      AddMethod('procedure Clear', CallMethod);
      AddMethod('procedure Update', CallMethod);
      AddDefaultProperty('Items', 'Integer', 'TFieldDef', CallMethod, True);
    end;
    AddClass(TDataSource, 'TComponent');
    AddType('TBookmark', fvtVariant);
    with AddClass(TDataSet, 'TComponent') 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);

      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);

      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);

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

    with AddClass(TParam, 'TPersistent') do
    begin
      AddMethod('procedure Clear', CallMethod);
      AddProperty('AsBoolean', 'Boolean', GetProp, SetProp);
      AddProperty('AsCurrency', 'Currency', GetProp, SetProp);
      AddProperty('AsDateTime', 'TDateTime', GetProp, SetProp);
      AddProperty('AsFloat', 'Double', GetProp, SetProp);
      AddProperty('AsInteger', 'Integer', GetProp, SetProp);
      AddProperty('AsDate', 'TDate', GetProp, SetProp);
      AddProperty('AsTime', 'TTime', GetProp, SetProp);
      AddProperty('AsString', 'String', GetProp, SetProp);
      AddProperty('Bound', 'Boolean', GetProp, SetProp);
      AddProperty('IsNull', 'Boolean', GetProp, nil);
      AddProperty('Text', 'String', GetProp, SetProp);
    end;
    with AddClass(TParams, 'TPersistent') do
    begin
      AddMethod('function ParamByName(const Value: string): TParam', CallMethod);
      AddMethod('function FindParam(const Value: string): TParam', CallMethod);
      AddDefaultProperty('Items', 'Integer', 'TParam', CallMethod, True);
    end;
  end;
end;

function TFunctions.CallMethod(Instance: TObject; ClassType: TClass;
  const MethodName: String; Caller: TfsMethodHelper): Variant;
var
  _TDataSet: TDataSet;

  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;

begin
  Result := 0;

  if ClassType = TFields then
  begin
    if MethodName = 'FIELDS.GET' then
      Result := Integer(TFields(Instance)[Caller.Params[0]])
  end
  else if ClassType = TFieldDefs then