{******************************************}
{                                          }
{             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
{$IFDEF Delphi16}
  , System.Types
{$ENDIF}
{$IFDEF DELPHI16}, Controls{$ENDIF};

type
{$i frxPlatformsAttribute.inc}
  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 := frxInteger(TFields(Instance)[Caller.Params[0]])
  end
  else if ClassType = TFieldDefs then
  begin
    if MethodName = 'ITEMS.GET' then
      Result := frxInteger(TFieldDefs(Instance)[Caller.Params[0]])
    else if MethodName = 'ADD' then
      TFieldDefs(Instance).Add(Caller.Params[0], TFieldType(Caller.Params[1]), Caller.Params[2], Caller.Params[3])
    else if MethodName = 'ADDFIELDDEF' then
      Result := frxInteger(TFieldDefs(Instance).AddFieldDef)
    else if MethodName = 'CLEAR' then
      TFieldDefs(Instance).Clear
    else if MethodName = 'FIND' then
      Result := frxInteger(TFieldDefs(Instance).Find(Caller.Params[0]))
    else if MethodName = 'UPDATE' then
      TFieldDefs(Instance).Update
  end
  else if ClassType = TBlobField then
  begin
    if MethodName = 'LOADFROMFILE' then
      TBlobField(Instance).LoadFromFile(Caller.Params[0])
    else if MethodName = 'LOADFROMSTREAM' then
      TBlobField(Instance).LoadFromStream(TStream(frxInteger(Caller.Params[0])))
    else if MethodName = 'SAVETOFILE' then
      TBlobField(Instance).SaveToFile(Caller.Params[0])
    else if MethodName = 'SAVETOSTREAM' then
      TBlobField(Instance).SaveToStream(TStream(frxInteger(Caller.Params[0])))
  end
  else if ClassType = TDataSet then
  begin
    _TDataSet := TDataSet(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])))

    else if MethodName = 'GETBOOKMARK' then
{$IFDEF DELPHI16}
      Result := Variant(_TDataSet.GetBookmark)
{$ELSE}
      Result := Variant(frxInteger(_TDataSet.GetBookmark))
{$ENDIF}
    else if MethodName = 'GOTOBOOKMARK' then
{$IFDEF DELPHI16}
      _TDataSet.GotoBookmark(TBookMark(Variant(Caller.Params[0])))
{$ELSE}
      _TDataSet.GotoBookmark(TBookMark(frxInteger(Caller.Params[0])))
{$ENDIF}
    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
  end
  else if ClassType = TParam then
  begin
    if MethodName = 'CLEAR' then
      TParam(Instance).Clear
  end
  else if ClassType = TParams then
  begin
    if MethodName = 'PARAMBYNAME' then
      Result := frxInteger(TParams(Instance).ParamByName(Caller.Params[0]))
    else if MethodName = 'FINDPARAM' then
      Result := frxInteger(TParams(Instance).FindParam(Caller.Params[0]))
    else if MethodName = 'ITEMS.GET' then
      Result := frxInteger(TParams(Instance)[Caller.Params[0]])
  end
end;

function TFunctions.GetProp(Instance: TObject; ClassType: TClass;
  const PropName: String): Variant;
var
  _TField: TField;
  _TParam: TParam;
  _TDataSet: TDataSet;

  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 = TField then
  begin
    _TField := TField(Instance);
    if PropName = 'ASBOOLEAN' then
      Result := _TField.AsBoolean
    else if PropName = 'ASCURRENCY' then
      Result := _TField.AsCurrency
    else if PropName = 'ASDATETIME' then
      Result := _TField.AsDateTime
    else if PropName = 'ASFLOAT' then
      Result := _TField.AsFloat
    else if PropName = 'ASINTEGER' then
      Result := _TField.AsInteger
    else if PropName = 'ASSTRING' then
      Result := _TField.AsString
    else if PropName = 'ASVARIANT' then
      Result := _TField.AsVariant
    else if PropName = 'DATATYPE' then
      Result := _TField.DataType
    else if PropName = 'DISPLAYNAME' then
      Result := _TField.DisplayName
    else if PropName = 'DISPLAYTEXT' then
      Result := _TField.DisplayText
    else if PropName = 'ISNULL' then
      Result := _TField.IsNull
    else if PropName = 'SIZE' then
      Result := _TField.Size
    else if PropName = 'VALUE' then
      Result := _TField.Value
    else if PropName = 'OLDVALUE' then
      Result := _TField.OldValue
  end
  else if ClassType = TDataSet then
  begin
    _TDataSet := TDataSet(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
  end
  else if ClassType = TParam then
  begin
    _TParam := TParam(Instance);
    if PropName = 'BOUND' then
      Result := _TParam.Bound
    else if PropName = 'ISNULL' then
      Result := _TParam.IsNull
    else if PropName = 'TEXT' then
      Result := _TParam.Text
    else if PropName = 'ASBOOLEAN' then
      Result := _TParam.AsBoolean
    else if PropName = 'ASCURRENCY' then
      Result := _TParam.AsCurrency
    else if PropName = 'ASDATETIME' then
      Result := _TParam.AsDateTime
    else if PropName = 'ASFLOAT' then
      Result := _TParam.AsFloat
    else if PropName = 'ASINTEGER' then
      Result := _TParam.AsInteger
    else if PropName = 'ASDATE' then
      Result := _TParam.AsDate
    else if PropName = 'ASTIME' then
      Result := _TParam.AsTime
    else if PropName = 'ASSTRING' then
      Result := _TParam.AsString
  end
end;

procedure TFunctions.SetProp(Instance: TObject; ClassType: TClass;
  const PropName: String; Value: Variant);
var
  _TField: TField;
  _TParam: TParam;
  _TDataSet: TDataSet;

  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 = TField then
  begin
    _TField := TField(Instance);
    if PropName = 'ASBOOLEAN' then
      _TField.AsBoolean := Value
    else if PropName = 'ASCURRENCY' then
      _TField.AsCurrency := Value
    else if PropName = 'ASDATETIME' then
      _TField.AsDateTime := Value
    else if PropName = 'ASFLOAT' then
      _TField.AsFloat := Value
    else if PropName = 'ASINTEGER' then
      _TField.AsInteger := Value
    else if PropName = 'ASSTRING' then
      _TField.AsString := Value
    else if PropName = 'ASVARIANT' then
      _TField.AsVariant := Value
    else if PropName = 'VALUE' then
      _TField.Value := Value
   else if PropName = 'SIZE' then
     _TField.Size := Value
  end
  else if ClassType = TDataSet then
  begin
    _TDataSet := TDataSet(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
  end
  else if ClassType = TParam then
  begin
    _TParam := TParam(Instance);
    if PropName = 'ASBOOLEAN' then
      _TParam.AsBoolean := Value
    else if PropName = 'ASCURRENCY' then
      _TParam.AsCurrency := Value
    else if PropName = 'ASDATETIME' then
      _TParam.AsDateTime := Value
    else if PropName = 'ASFLOAT' then
      _TParam.AsFloat := Value
    else if PropName = 'ASINTEGER' then
      _TParam.AsInteger := Value
    else if PropName = 'ASDATE' then
      _TParam.AsDate := Value
    else if PropName = 'ASTIME' then
      _TParam.AsTime := Value
    else if PropName = 'ASSTRING' then
      _TParam.AsString := Value
    else if PropName = 'BOUND' then
      _TParam.Bound := Value
    else if PropName = 'TEXT' then
      _TParam.Text := Value
  end
end;


initialization
{$IFDEF Delphi16}
  StartClassGroup(TControl);
  ActivateClassGroup(TControl);
  GroupDescendentsWith(TfsDBRTTI, TControl);
{$ENDIF}
  fsRTTIModules.Add(TFunctions);

finalization
  fsRTTIModules.Remove(TFunctions);

end.