fs_idacrtti.pas

devent UniDAC 2.003 include sources

{******************************************}
{                                          }
{             FastScript v1.9              }
{        DAC classes and functions         }
{                                          }
{          Created by: Devart              }
{        E-mail: [e-mail]        }
{                                          }
{******************************************}

unit fs_idacrtti;

interface

{$i fs.inc}

uses
  SysUtils, Classes, fs_iinterpreter, fs_itools, fs_idbrtti, DB,
  MemData, MemDS, DBAccess;

type
  TfsNotifyEvent = class(TfsCustomEvent)
  public
    procedure DoEvent(Sender: TObject);
    function GetMethod: Pointer; override;
  end;

  TfsLoginEvent = class(TfsCustomEvent)
  public
    procedure DoEvent(Sender: TObject; Username, Password: string);
    function GetMethod: Pointer; override;
  end;

  TfsUpdateErrorEvent = class(TfsCustomEvent)
  public
    procedure DoEvent(DataSet: TDataSet; E: EDatabaseError; UpdateKind: TUpdateKind; var UpdateAction: TUpdateAction);
    function GetMethod: Pointer; override;
  end;

  TfsUpdateRecordEvent = class(TfsCustomEvent)
  public
    procedure DoEvent(DataSet: TDataSet; UpdateKind: TUpdateKind; var UpdateAction: TUpdateAction);
    function GetMethod: Pointer; override;
  end;

  TfsAfterExecuteEvent = class(TfsCustomEvent)
  public
    procedure DoEvent(Sender: TObject; Result: boolean);
    function GetMethod: Pointer; override;
  end;
  
  TfsUpdateExecuteEvent = class(TfsCustomEvent)
  public
    procedure DoEvent(Sender: TDataSet; StatementTypes: TStatementTypes; Params: TDAParams);
    function GetMethod: Pointer; override;
  end;
  
implementation

type
  TfsDAConnectionErrorEvent = class(TfsCustomEvent)
  public
    procedure DoEvent(Sender: TObject; E: EDAError; var Fail: boolean);
    function GetMethod: Pointer; override;
  end;

  TfsConnectionLostEvent = class(TfsCustomEvent)
  public
    procedure DoEvent(Sender: TObject; Component: TComponent; ConnLostCause: TConnLostCause; var RetryMode: TRetryMode);
    function GetMethod: Pointer; override;
  end;

  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;

{ TfsDAConnectionErrorEvent }

procedure TfsDAConnectionErrorEvent.DoEvent(Sender: TObject; E: EDAError; var Fail: boolean);
begin
  CallHandler([Sender, E, Fail]);
  Fail := Handler.Params[2].Value;
end;

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

{ TfsNotifyEvent }

procedure TfsNotifyEvent.DoEvent(Sender: TObject);
begin
  CallHandler([Sender]);
end;

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

{ TfsLoginEvent }

procedure TfsLoginEvent.DoEvent(Sender: TObject; Username, Password: string);
begin
  CallHandler([Sender, Username, Password]);
end;

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

{ TfsConnectionLostEvent }

procedure TfsConnectionLostEvent.DoEvent(Sender: TObject; Component: TComponent; ConnLostCause: TConnLostCause; var RetryMode: TRetryMode);
begin
  CallHandler([Sender, Component, Integer(ConnLostCause), Integer(RetryMode)]);
  RetryMode := Handler.Params[3].Value;
end;

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

{ TfsUpdateErrorEvent }

procedure TfsUpdateErrorEvent.DoEvent(DataSet: TDataSet; E: EDatabaseError; UpdateKind: TUpdateKind; var UpdateAction: TUpdateAction);
begin
  CallHandler([DataSet, E, Integer(UpdateKind), Integer(UpdateAction)]);
  UpdateAction := Handler.Params[3].Value;
end;

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

{ TfsUpdateRecordEvent }

procedure TfsUpdateRecordEvent.DoEvent(DataSet: TDataSet; UpdateKind: TUpdateKind; var UpdateAction: TUpdateAction);
begin
  CallHandler([DataSet, Integer(UpdateKind), Integer(UpdateAction)]);
  UpdateAction := Handler.Params[3].Value;
end;

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

{ TfsAfterExecuteEvent }

procedure TfsAfterExecuteEvent.DoEvent(Sender: TObject; Result: boolean);
begin
  CallHandler([Sender, Result]);
end;

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

{ TfsUpdateExecuteEvent }

procedure TfsUpdateExecuteEvent.DoEvent(Sender: TDataSet; StatementTypes: TStatementTypes; Params: TDAParams);
begin
  CallHandler([Sender, 0{StatementTypes}, Params]);
end;

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

{ TFunctions }

constructor TFunctions.Create(AScript: TfsScript);
begin
  inherited Create(AScript);
  
  with AScript do
  begin
    with AddClass(TCustomDAConnection, 'TComponent') do begin
      AddMethod('procedure Open', CallMethod);
      AddMethod('procedure Close', CallMethod);
      
      AddMethod('procedure Connect', CallMethod);
      AddMethod('procedure Disconnect', CallMethod);
      
      AddMethod('function ExecSQL(Text: string; const Params: array of variant): variant', CallMethod);
      
      AddMethod('procedure GetTableNames(List: TStrings)', CallMethod);
      AddMethod('procedure GetDatabaseNames(List: TStrings)', CallMethod);
      AddMethod('procedure GetStoredProcNames(List: TStrings)', CallMethod);

      AddMethod('procedure StartTransaction', CallMethod);
      AddMethod('procedure Commit', CallMethod);
      AddMethod('procedure Rollback', CallMethod);

      AddMethod('procedure ApplyUpdates', CallMethod);
      //AddMethod('procedure ApplyUpdates(DataSets: array of TCustomDADataSet)', CallMethod);
      
      AddMethod('function CreateDataSet: TCustomDADataSet', CallMethod);

      AddMethod('procedure RemoveFromPool', CallMethod);
      AddMethod('procedure MonitorMessage(const Msg: string)', CallMethod);
      
      AddProperty('InTransaction', 'boolean', GetProp);
      
      AddIndexProperty('DataSets', 'Integer', 'TDataSet', CallMethod, True);
      AddProperty('DataSetCount', 'Integer', GetProp);

      AddEvent('OnError', TfsDAConnectionErrorEvent);
      AddEvent('OnConnectionLost', TfsConnectionLostEvent);
      AddEvent('AfterConnect', TfsNotifyEvent);
      AddEvent('BeforeConnect', TfsNotifyEvent);
      AddEvent('AfterDisconnect', TfsNotifyEvent);
      AddEvent('BeforeDisconnect', TfsNotifyEvent);
      AddEvent('OnLogin', TfsLoginEvent);
    end;
    AddClass(TDAConnectionOptions, 'TPersistent');
    AddClass(TPoolingOptions, 'TPersistent');

    AddEnum('TDANumericType', 'ntFloat, ntBCD'{$IFNDEF VER130} + ', ntFmtBCD'{$ENDIF});
    AddEnum('TConnLostCause', 'clUnknown, clExecute, clOpen, clRefresh, clApply, clServiceQuery, clTransStart, clConnectionApply, clConnect');
    AddEnum('TRetryMode', 'rmRaise, rmReconnect, rmReconnectExecute');

    AddEnum('TLabelSet', 'lsCustom, lsEnglish, lsFrench, lsGerman, lsItalian, lsPolish, lsPortuguese, lsRussian, lsSpanish');
   
    with AddClass(TCustomConnectDialog, 'TComponent') do begin
      AddMethod('function Execute: boolean', CallMethod);
      AddMethod('procedure GetServerList(List: TStrings)', CallMethod);

      AddProperty('Connection', 'TCustomDAConnection', GetProp);
      AddProperty('Retries', 'word', GetProp, SetProp);
      AddProperty('SavePassword', 'boolean', GetProp, SetProp);
      AddProperty('StoreLogInfo', 'boolean', GetProp, SetProp);
      AddProperty('DialogClass', 'string', GetProp, SetProp);
      AddProperty('Caption', 'string', GetProp, SetProp);
      AddProperty('UsernameLabel', 'string', GetProp, SetProp);
      AddProperty('PasswordLabel', 'string', GetProp, SetProp);
      AddProperty('ServerLabel', 'string', GetProp, SetProp);
      AddProperty('ConnectButton', 'string', GetProp, SetProp);
      AddProperty('CancelButton', 'string', GetProp, SetProp);
      AddProperty('LabelSet', 'TLabelSet', GetProp, SetProp);
    end;

    with AddClass(TMemDataSet, 'TDataSet') do begin
      AddMethod('procedure Prepare', CallMethod);
      AddMethod('procedure UnPrepare', CallMethod);
      AddMethod('procedure CheckPrepared', CallMethod); 

      AddMethod('function UpdateStatus: TUpdateStatus', CallMethod); 
      AddMethod('function UpdateResult: TUpdateAction', CallMethod);
      AddMethod('procedure ApplyUpdates', CallMethod);
      AddMethod('procedure CommitUpdates', CallMethod);
      AddMethod('procedure CancelUpdates', CallMethod);
      AddMethod('procedure RestoreUpdates', CallMethod);
      AddMethod('procedure RevertRecord', CallMethod);

      AddMethod('procedure SaveToXML(const FileName: string)', CallMethod);

      AddProperty('Prepared', 'boolean', GetProp, SetProp);
      AddProperty('RecordCount', 'Integer', GetProp);
      
      AddEvent('OnUpdateError', TfsUpdateErrorEvent);
      AddEvent('OnUpdateRecord', TfsUpdateRecordEvent);
    end;
    AddEnum('TUpdateStatus', 'usUnmodified, usModified, usInserted, usDeleted');
    AddEnum('TUpdateAction', 'uaFail, uaAbort, uaSkip, uaRetry, uaApplied');

    with AddClass(TCustomDADataSet, 'TMemDataSet') do begin
      AddMethod('procedure Execute', CallMethod);
      AddMethod('function Executing', CallMethod);
      AddMethod('function Fetching', CallMethod);

      AddMethod('procedure RefreshRecord', CallMethod);

      AddMethod('function FindMacro(const Value: string): TMacro', CallMethod);
      AddMethod('function MacroByName(const Value: string): TMacro', CallMethod);

      AddMethod('procedure SaveSQL', CallMethod);
      AddMethod('procedure RestoreSQL', CallMethod);
      AddMethod('function SQLSaved: boolean', CallMethod);

      AddMethod('procedure AddWhere(Condition: string)', CallMethod);
      AddMethod('procedure DeleteWhere', CallMethod);
      AddMethod('procedure SetOrderBy(Fields: string)', CallMethod);
      AddMethod('function GetOrderBy: string', CallMethod);

      AddEvent('AfterExecute', TfsAfterExecuteEvent);
      AddEvent('BeforeUpdateExecute', TfsUpdateExecuteEvent);
      AddEvent('AfterUpdateExecute', TfsUpdateExecuteEvent);
    end;

    AddClass(TDAParams, 'TParams');
    AddEnum('TStatementType', 'stQuery, stInsert, stUpdate, stDelete, stLock, stRefresh, stCheck, stCustom, stRefreshQuick, stRefreshCheckDeleted, stBatchUpdate');
    AddEnumSet('TStatementTypes', 'stQuery, stInsert, stUpdate, stDelete, stLock, stRefresh, stCheck, stCustom, stRefreshQuick, stRefreshCheckDeleted, stBatchUpdate');

    AddClass(TDADataSetOptions, 'TPersistent');
    AddEnum('TCompressBlobMode', 'cbNone, cbClient, cbServer, cbClientServer');