測試RemObjects Pascal Script

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, uPSComponent, StdCtrls, uPSCompiler, uPSUtils, uPSRuntime;

type

TTestFunction = function (Param1: Double; Data: string): LongInt of object;

TForm1 = class(TForm)
    st: TPSScript;
    Button1: TButton;
    Button2: TButton;
    procedure stCompile(Sender: TPSScript);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure stVerifyProc(Sender: TPSScript; Proc: TPSInternalProcedure;
      const Decl: string; var Error: Boolean);
private
    procedure ShowNewMessage(const AMessage: string);

end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
with st.Script do
begin
    Add('Program test;');
    Add('function TestFunction(Param1: Double; Data: String): Longint;');
    Add('begin');
    Add(' ShowNewMessage(''Param1:''+ FloatToStr(Param1)+ #13#10+ ''Data''+ Data);');
    Add(' Result := 1234567;');
    Add('end;');
    Add('var MyVar: Integer;');
    Add('begin');
    Add(' MyVar := 1000;');
    Add(' ShowNewMessage(''全局變量MyVar=''+IntToStr(MyVar)+'' '');//調用了Delphi中的方法');
    Add('end.');
end;
if not st.Compile then
    raise Exception.Create('編譯的時候發生錯誤！');
st.Execute;
end;

//Delphi調用腳本中的方法
procedure TForm1.Button2Click(Sender: TObject);
var
meth: TTestFunction;
begin
meth := TTestFunction(st.GetProcMethod('TESTFUNCTION'));
if @meth= nil then
    raise Exception.Create('Unable call TestFunction');
ShowMessage('Result:'+ IntToStr(meth(Pi, DateTimeToStr(Now))));
end;

//Delphi聲明的方法 能夠在腳本中調用
procedure TForm1.ShowNewMessage(const AMessage: string);
begin
ShowMessage('ShowNewMessage invoked:'+ #13#10+ AMessage);
end;

//在TPSScript控件的Compile事件中導出方法 這樣就能夠在腳本中調用了
procedure TForm1.stCompile(Sender: TPSScript);
begin
Sender.AddMethod(Self, @TForm1.ShowNewMessage,
                   'procedure ShowNewMessage (const AMessage: string);');
end;

//在調用腳本中的方法前觸發TPSScript控件的VerifyProc事件驗證函數類型[返回值,參數等信息]
procedure TForm1.stVerifyProc(Sender: TPSScript; Proc: TPSInternalProcedure;
const Decl: string; var Error: Boolean);
begin
if Proc.Name = 'TESTFUNCTION' then
begin
    if not ExportCheck(Sender.Comp, Proc, [btS32, btDouble, btString], [pmIn, pmIn]) then
    begin
      Sender.Comp.MakeError('',ecCustomError, 'Function header for TestFunction does not match.');
      Error := True;
    end
    else
    begin
      Error := False;
    end;

end
else
    Error := False;
end;

end.//還有一些功能沒有測試 如設置腳本變量的值 獲取腳本變量的值等