unit fulltest1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, PaxScripter, PaxPascal
{$IFDEF VER150}
,variants,varutils,
{$ENDIF};
type
{$M+}
tnewobj=class
private
fname:string;
published
property name:string read fname write fname;
end;
{$M-}
TForm1 = class(TForm)
Button1: TButton;
Memo2: TMemo;
cbShowOk: TCheckBox;
cbAuto: TCheckBox;
PaxScripter1: TPaxScripter;
PaxPascal1: TPaxPascal;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
fvar,v,r: Variant;
failcount:integer;
Fobj1:tnewobj;
procedure doOnPrint(Sender: TPaxScripter; const S: String);
procedure doOnError(Sender: TPaxScripter);
procedure say(a: variant);
procedure testglobals;
procedure simpleparam;
procedure check(cond: boolean; msg: String);
procedure arrayParam;
procedure hostAccess;
function myfunc(a:string):string;
function myfunc2(a:variant):variant;
function myfunc3(a:variant):variant;
procedure myException;
function _test(script: string; const params: array of const): variant;
function test(script:string;
const params:array of const):variant;
procedure exceptions;
public
procedure automation;
published
property var1: variant read fvar write fvar;
property obj1:TnewObj read Fobj1;
end;
var
Form1: TForm1;
implementation
uses
ComObj,
ActiveX,
IMP_ActiveX,
imp_pascal;
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
registerclasstype(tnewobj,-1);
registerclassType(tform1,-1);
registerMethod(tform1,'function myfunc(a:string):string;',@tform1.myfunc);
registerMethod(tform1,'function myfunc2(a: variant): variant;',@tform1.myfunc2);
registerMethod(tform1,'function myfunc3(a: variant): variant;',@tform1.myfunc3);
registerMethod(tform1,'procedure MyException;',@tform1.myException);
fobj1:=tnewobj.create;
end;
procedure TForm1.doOnPrint(Sender: TPaxScripter; const S: String);
begin
memo2.lines.Add(S);
end;
procedure tform1.say(a:variant);
begin
memo2.lines.add(string(a));
end;
procedure tform1.check(cond:boolean; msg:String);
begin
if cond then if cbshowok.checked then say(msg+' ok') else
else
begin
say(msg+' failed');
inc(failCount)
end;
end;
function TForm1._test(script: string; const params: array of const): variant;
begin
PaxScripter1.ResetScripter;
PaxScripter1.AddModule('1', 'paxPascal');
PaxScripter1.AddCode('1',script);
PaxScripter1.Run;
result := PaxScripter1.CallFunction('f',params);
end;
function TForm1.test(script: string;
const params: array of const): variant;
begin
try
result:=_test(script,params);
except
say(exception(exceptObject).Message);
result:=unassigned;
end;
end;
procedure tform1.testglobals;
begin
test('var a; function f; begin a:="global"; end;',[]);
v := PaxScripter1.Values['a'];
check(v='global','read global');
PaxScripter1.Values['a']:='global changed';
check(PaxScripter1.Values['a']='global changed','write global');
end;
procedure tform1.simpleparam;
procedure test1(msg:string; v1:variant);
begin
r:=test('function f(a); begin print(a); result:=a; end;',
[v1]);
check(r=v1,msg);
end;
function getParam(fname:string; index:integer):variant;
var subid,paramid:integer;
begin
SubID := PaxScripter1.GetMemberID(fname);
if SubID = 0 then raise Exception.Create('Function not found');
ParamID := PaxScripter1.GetParamID(SubID, index);
result := PaxScripter1.GetValueByID(ParamID);
end;
begin
test1('integer',1000);
test1('string','mike');
test1('Date',now());
test1('byte',1);
test1('boolean',true);
test1('double',1.23);
v:=100;
r:=test('function f(var a); begin a:=a+10; end;',[v]);
check(getParam('f',1)=110,'param by ref');
r:=test('function f(a); begin result:=a.caption; end;',[self]);
check(r=caption,'Delphi Object parameter');
end;
procedure tform1.arrayParam;
begin
v:=varArrayof([1,2,3]);
r:=test('function f(a); begin result:=a; end;',
[v]);
check(r[1]=2,'array invariance');
r:=test('function f(a); begin result:=a[1]; end;',
[v]);
check(r=2,'array access');
v:=vararrayof([VarArrayof([1,2,3]),4,5]);
r:=test('function f(a); var a1; begin a1:=a[0]; result:=a1[1]; end;',
[v]);
check(r=2,'nested array access');
r:=test('function f(a); begin result:=a[0][1]; end;',
[v]);
check(r=2,'nested array access2');
r:=test('function f(a); begin result:=toInteger(a[0])+toInteger(a[1]); end;',
[varArrayOf(['1','2'])]);
check(r=3,'conversion of string parameters');
end;
procedure tform1.hostAccess;
begin
fvar := VarArrayOf([1, 2, 3]);
r:=test('function f; begin print(form1.var1); result:=form1.var1; end;',
[]);
check(r[1]=2,'host access 1');
r:=test('function f; begin print(form1.var1[1]); result:=form1.var1[1]; end;',
[]);
check(r=2,'host access 2');
fobj1.name:='mike';
r:=test('function f; begin result:=form1.obj1.name; end;',[]);
check(r='mike','class property');
r:=test('function f; begin result:=form1.myfunc("pa"); end;',[]);
check(r='papa','host function call');
r:=test('function f; begin result:=form1.myfunc2(10); end;',[]);
check(r=20,'host function call2');
r:=test('function f(a); begin result:=form1.myfunc2(a[1]); end;',
[vararrayof([1000,2000])]);
check(r=2010,'host function call3');
r:=test(
'function f; var a = VarArrayCreate([0,1], varVariant); begin a[0]:=1; a[1]:=2;'#13#10+
'result:=form1.myfunc3(a); end;',[]);
check(r=3,'array parameter to host');
end;
procedure tform1.automation;
var fword:olevariant;
begin
fword:=createoleobject('word.application');
r:=test('function f(a); begin result:=a.path; end;',
[fword]);
fword.quit;
check(pos('\',r)>0,'automation parameter');
end;
procedure tform1.exceptions;
var ok:boolean;
begin
r:=test(
' function f;'#13#10+
' begin'#13#10+
' try'#13#10+
' raise 100;'#13#10+
' result:=1;'#13#10+
' except'#13#10+
' result:=2;'#13#10+
' end;'#13#10+
' end;',[]);
check(r=2,'simple exception handling');
try
r:=_test(
' function f; begin raise 100; end;',[]);
if PaxScripter1.IsError then
raise Exception.Create(PaxScripter1.ErrorDescription);
ok:=false;
except
ok:=true;
end;
check(ok,'exception in script propagates to host');
r:=test(
' function f;'#13#10+
' begin'#13#10+
' try'#13#10+
' form1.myException;'#13#10+
' result:=1;'#13#10+
' except'#13#10+
' result:=2;'#13#10+
' end;'#13#10+
' end;',[]);
check(r=2, 'Exception from host is caught');
try
r:=_test(
' function f; begin form1.myException; end;',[]);
if PaxScripter1.IsError then
raise Exception.Create(PaxScripter1.ErrorDescription);
ok:=false;
except
ok:=true;
end;
check(ok,'exception from host callback propagates to host');
try
r:=_test(
' function f; begin form1.noSuchVariable; end;',[]);
if PaxScripter1.IsError then
raise Exception.Create(PaxScripter1.ErrorDescription);
ok:=false;
except
ok:=true;
end;
check(ok,'undefined identifier raises exception');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
try
failcount:=0;
PaxScripter1.OnPrint:=DoOnPrint;
PaxScripter1.OnShowError:=doOnError;
PaxScripter1.RegisterObject('Form1', self);
memo2.clear;
testglobals;
simpleparam;
ArrayParam;
hostAccess;
if cbauto.checked then automation;
exceptions;
finally
if failcount>0 then say(format('%d failures!',[failcount]))
else say('congatulations');
end;
end;
function TForm1.myfunc(a: string): string;
begin
result:=a+a;
end;
function TForm1.myfunc2(a: variant): variant;
begin
result:=integer(a)+10;
end;
procedure TForm1.myException;
begin
raise exception.create('exception from host');
end;
procedure TForm1.doOnError(Sender: TPaxScripter);
begin
say('error from script');
end;
function TForm1.myfunc3(a: variant): variant;
begin
result:=a[0]+a[1];
end;
end.