paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-08 11:58:12 +02:00
Code Issues Packages Projects Releases Wiki Activity

MacroScript: start selftests

Browse Source 
git-svn-id: trunk@42256 -
This commit is contained in:
martin 2013-08-02 08:01:20 +00:00
parent e6c9e3ce81
commit 47c1423ff2
5 changed files with 137 additions and 155 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
components/macroscript/editormacroscript.lpk
View File

@ -1,4 +1,4 @@
<?xml version="1.0"?>
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
@ -23,7 +23,7 @@ This package requires: PascalScript from REM Objects (http://www.remobjects.com/
Extends the Editors macro recorder and player. Macros can be written in pascal script. They also have access to additional properties and methods."/>
<License Value="GPL"/>
<Files Count="3">
<Files Count="4">
<Item1>
<Filename Value="registerems.pas"/>
<HasRegisterProc Value="True"/>
@ -37,6 +37,10 @@ Extends the Editors macro recorder and player. Macros can be written in pascal s
<Filename Value="emscriptclasses.pas"/>
<UnitName Value="EMScriptClasses"/>
</Item3>
<Item4>
<Filename Value="emsselftest.pas"/>
<UnitName Value="emsselftest"/>
</Item4>
</Files>
<Type Value="RunAndDesignTime"/>
<RequiredPkgs Count="4">

2
components/macroscript/editormacroscript.pas
View File

@ -7,7 +7,7 @@ unit EditorMacroScript;
interface
uses
RegisterEMS, EMScriptMacro, EMScriptClasses, LazarusPackageIntf;
RegisterEMS, EMScriptMacro, EMScriptClasses, EMSSelfTest, LazarusPackageIntf;
implementation

213
components/macroscript/emscriptclasses.pas
View File

@ -22,17 +22,15 @@ type
{ TEMSTPSExec }
TEMSTPSExec = class(TPSDebugExec)
private
protected
FCLassImp: TPSRuntimeClassImporter;
FSynEdit: TCustomSynEdit;
procedure AddFuncToExec;
procedure AddFuncToExec; virtual;
procedure AddECFuncToExecEnum(const s: String); // ec... commands
public
constructor Create;
destructor Destroy; override;
procedure AddSelfTests;
property SynEdit: TCustomSynEdit read FSynEdit write FSynEdit;
end;
@ -40,30 +38,32 @@ type
TEMSPSPascalCompiler = class(TPSPascalCompiler)
private
FSelfTests: Boolean;
procedure AddECFuncToCompEnum(const s: String);
public
constructor Create;
procedure AddSelfTests;
end;
{$IFDEF PasMacroNoNativeCalls}
PPoint = ^TPoint;
function GetSetFromStack(Stack: TPSStack; Idx: Integer): Cardinal;
function GetEnumFromStack(Stack: TPSStack; Idx: Integer): Cardinal;
function GetVarPointFromStack(Stack: TPSStack; Idx: Integer): PPoint;
function GetPointFromStack(Stack: TPSStack; Idx: Integer): TPoint;
{$ENDIF}
procedure CompRegisterBasics(AComp: TPSPascalCompiler);
procedure ExecRegisterBasics(AExec: TEMSTPSExec);
procedure CompRegisterTSynEdit(AComp: TPSPascalCompiler);
procedure ExecRegisterTSynEdit(AExec: TEMSTPSExec);
procedure CompRegisterTClipboard(AComp: TPSPascalCompiler);
procedure ExecRegisterTClipboard(AExec: TEMSTPSExec);
procedure CompRegisterSelfTests(AComp: TPSPascalCompiler);
procedure ExecRegisterSelfTests(AExec: TEMSTPSExec);
implementation
procedure CompRegisterBasics(AComp: TPSPascalCompiler); forward;
procedure ExecRegisterBasics(AExec: TEMSTPSExec); forward;
procedure CompRegisterTSynEdit(AComp: TPSPascalCompiler); forward;
procedure ExecRegisterTSynEdit(AExec: TEMSTPSExec); forward;
procedure CompRegisterTClipboard(AComp: TPSPascalCompiler); forward;
procedure ExecRegisterTClipboard(AExec: TEMSTPSExec); forward;
{$IFDEF NeedTPointFix}
type TPoint2 = record x,y,a,b,c: Longint; end;
{$ENDIF}
@ -89,9 +89,6 @@ begin
CompRegisterTSynEdit(S);
S.AddFunction('function Caller: TSynEdit;');
CompRegisterTClipboard(S);
if S.FSelfTests then
CompRegisterSelfTests(S);
end;
Result := True;
@ -118,12 +115,6 @@ begin
inherited Create;
OnUses := @CompilerOnUses;
BooleanShortCircuit := True;
FSelfTests := False;
end;
procedure TEMSPSPascalCompiler.AddSelfTests;
begin
FSelfTests := True;
end;
{ TEMSTPSExec }
@ -195,12 +186,6 @@ begin
ExecRegisterTClipboard(Self);
end;
procedure TEMSTPSExec.AddSelfTests;
begin
ExecRegisterSelfTests(Self);
end;
{%region RegisterBasics}
Function EMS_MessageDlg(Msg: string; DlgType :TMsgDlgType; Buttons :TMsgDlgButtons; HelpCtx: Longint): Integer;
@ -238,16 +223,6 @@ begin
Result.Y := AY;
end;
function test_ord_mt(AType: TMsgDlgType): Integer;
begin
Result := ord(AType);
end;
function test_ord_mb(ABtn: TMsgDlgBtn): Integer;
begin
Result := ord(ABtn);
end;
const
DeclMessageDlg = 'Function MessageDlg(Msg: string; DlgType :TMsgDlgType; Buttons :TMsgDlgButtons; HelpCtx: Longint): Integer';
DeclMessageDlgPos = 'Function MessageDlgPos(Msg: string; DlgType :TMsgDlgType; Buttons :TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer): Integer';
@ -268,11 +243,6 @@ const
DeclPoint = 'function Point(AX, AY: Integer): TPoint;';
FuncPoint: function(AX, AY: Integer): {$IFDEF NeedTPointFix}TPoint2{$ELSE}TPoint{$ENDIF} = @EMS_Point; // @Classes.Point;
Decltest_ord_mt = 'function test_ord_mt(AType: TMsgDlgType): Integer;';
Decltest_ord_mb = 'function test_ord_mb(ABtn: TMsgDlgBtn): Integer;';
Functest_ord_mt: function(AType: TMsgDlgType): Integer = @test_ord_mt;
Functest_ord_mb: function(ABtn: TMsgDlgBtn): Integer = @test_ord_mb;
procedure CompRegisterBasics(AComp: TPSPascalCompiler);
procedure AddConst(const Name, FType: TbtString; I: Integer);
begin
@ -305,35 +275,77 @@ begin
AComp.AddDelphiFunction(DeclShowMessagePos);
AComp.AddDelphiFunction(DeclInputBox);
AComp.AddDelphiFunction(DeclInputQuery);
// for tests
AComp.AddDelphiFunction(Decltest_ord_mb);
AComp.AddDelphiFunction(Decltest_ord_mt);
end;
function ExecBasicHandler({%H-}Caller: TPSExec; p: TPSExternalProcRec; {%H-}Global, Stack: TPSStack): Boolean;
function GetSetFromStack(Idx: Integer): Cardinal;
var
val: PPSVariant;
dat: Pointer;
begin
if Idx < 0 then Idx := Idx + Stack.Count;
val := Stack[Idx];
if val^.FType.BaseType <> btSet then raise TEMScriptBadParamException.Create('Invalid set');
dat := @PPSVariantData(val)^.Data;
Result := tbtu32(dat^);
end;
function GetEnumFromStack(Idx: Integer): Cardinal;
var
val: PPSVariant;
dat: Pointer;
begin
if Idx < 0 then Idx := Idx + Stack.Count;
val := Stack[Idx];
if val^.FType.BaseType <> btEnum then raise TEMScriptBadParamException.Create('Invalid set');
dat := @PPSVariantData(val)^.Data;
Result := tbtu32(dat^);
end;
{$IFDEF PasMacroNoNativeCalls}
function GetSetFromStack(Stack: TPSStack; Idx: Integer): Cardinal;
var
val: PPSVariant;
dat: Pointer;
begin
if Idx < 0 then Idx := Idx + Stack.Count;
val := Stack[Idx];
if val^.FType.BaseType <> btSet then raise TEMScriptBadParamException.Create('Invalid set');
dat := @PPSVariantData(val)^.Data;
Result := tbtu32(dat^);
end;
function GetEnumFromStack(Stack: TPSStack; Idx: Integer): Cardinal;
var
val: PPSVariant;
dat: Pointer;
begin
if Idx < 0 then Idx := Idx + Stack.Count;
val := Stack[Idx];
if val^.FType.BaseType <> btEnum then raise TEMScriptBadParamException.Create('Invalid set');
dat := @PPSVariantData(val)^.Data;
Result := tbtu32(dat^);
end;
function GetVarPointFromStack(Stack: TPSStack; Idx: Integer): PPoint;
var
res: PPSVariant;
data: Pointer;
typerec: TPSTypeRec;
begin
if Idx < 0 then Idx := Idx + Stack.Count;
res := Stack[Idx];
typerec := res^.FType;
if typerec.BaseType = btPointer then begin
typerec := PPSVariantPointer(res)^.DestType;
Result := PPSVariantPointer(res)^.DataDest;
end
else
Result := @(PPSVariantRecord(res)^.data);
if typerec.BaseType <> btRecord then raise TEMScriptBadParamException.Create('Invalid result type for "point(x,y)"');
if typerec.RealSize <> SizeOf({$IFDEF NeedTPointFix}TPoint2{$ELSE}TPoint{$ENDIF}) then raise TEMScriptBadParamException.Create('Invalid result size for "point(x,y)"');
if Result = nil then raise TEMScriptBadParamException.Create('Invalid result data for "point(x,y)"');
end;
function GetPointFromStack(Stack: TPSStack; Idx: Integer): TPoint;
var
res: PPSVariant;
data: Pointer;
typerec: TPSTypeRec;
begin
if Idx < 0 then Idx := Idx + Stack.Count;
res := Stack[Idx];
typerec := res^.FType;
if typerec.BaseType <> btRecord then raise TEMScriptBadParamException.Create('Invalid result type for "point(x,y)"');
if typerec.RealSize <> SizeOf({$IFDEF NeedTPointFix}TPoint2{$ELSE}TPoint{$ENDIF}) then raise TEMScriptBadParamException.Create('Invalid result size for "point(x,y)"');
data := @(PPSVariantRecord(res)^.data);
if data = nil then raise TEMScriptBadParamException.Create('Invalid result data for "point(x,y)"');
Result := PPoint(data)^;
end;
function ExecBasicHandler({%H-}Caller: TPSExec; p: TPSExternalProcRec;
{%H-}Global, Stack: TPSStack): Boolean;
var
res: PPSVariant;
data: Pointer;
@ -345,33 +357,21 @@ begin
case Longint(p.Ext1) of
0: begin // POINT()
if Stack.Count < 3 then raise TEMScriptBadParamException.Create('Invalid param count for "Point"');;
res := Stack[Stack.Count-1];
typerec := res^.FType;
if typerec.BaseType = btPointer then begin
typerec := PPSVariantPointer(res)^.DestType;
data := PPSVariantPointer(res)^.DataDest;
end
else
data := @(PPSVariantRecord(res)^.data);
if typerec.BaseType <> btRecord then raise TEMScriptBadParamException.Create('Invalid result type for "point(x,y)"');
if typerec.RealSize <> SizeOf(TPoint) then raise TEMScriptBadParamException.Create('Invalid result size for "point(x,y)"');
if data = nil then raise TEMScriptBadParamException.Create('Invalid result data for "point(x,y)"');
data := GetVarPointFromStack(Stack, -1);
TPoint(data^) := Point(Stack.GetInt(-2), Stack.GetInt(-3));
end;
50: begin // MessageDlg(Msg: string; DlgType :TMsgDlgType; Buttons :TMsgDlgButtons; HelpCtx: Longint): Integer';
if Stack.Count < 5 then raise TEMScriptBadParamException.Create('Invalid param count for "MessageDlg"');;
Stack.SetInt(-1,
MessageDlg(Stack.GetAnsiString(-2), TMsgDlgType(Stack.GetUInt(-3)),
TMsgDlgButtons(GetSetFromStack(-4)), Stack.GetInt(-5))
TMsgDlgButtons(GetSetFromStack(Stack, -4)), Stack.GetInt(-5))
);
end;
51: begin // MessageDlgPos(Msg: string; DlgType :TMsgDlgType; Buttons :TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer): Integer
if Stack.Count < 7 then raise TEMScriptBadParamException.Create('Invalid param count for "MessageDlgPos"');;
Stack.SetInt(-1,
MessageDlgPos(Stack.GetAnsiString(-2), TMsgDlgType(Stack.GetUInt(-3)),
TMsgDlgButtons(GetSetFromStack(-4)), Stack.GetInt(-5),
TMsgDlgButtons(GetSetFromStack(Stack, -4)), Stack.GetInt(-5),
Stack.GetInt(-6), Stack.GetInt(-7) )
);
end;
@ -379,7 +379,7 @@ begin
if Stack.Count < 8 then raise TEMScriptBadParamException.Create('Invalid param count for "MessageDlgPosHelp"');;
Stack.SetInt(-1,
MessageDlgPosHelp(Stack.GetAnsiString(-2), TMsgDlgType(Stack.GetUInt(-3)),
TMsgDlgButtons(GetSetFromStack(-4)), Stack.GetInt(-5),
TMsgDlgButtons(GetSetFromStack(Stack, -4)), Stack.GetInt(-5),
Stack.GetInt(-6), Stack.GetInt(-7), Stack.GetAnsiString(-8))
);
end;
@ -408,19 +408,11 @@ begin
);
tbtstring(temp.Dta^) := s;
end;
900: begin // test_ord_mb(ABtn: TMsgDlgBtn): Integer;
if Stack.Count < 2 then raise TEMScriptBadParamException.Create('Invalid param count for "test_ord_mb"');
Stack.SetInt(-1, test_ord_mb(TMsgDlgBtn(Stack.GetUInt(-2))) );
end;
901: begin // test_ord_mt(AType: TMsgDlgType): Integer;
if Stack.Count < 2 then raise TEMScriptBadParamException.Create('Invalid param count for "test_ord_mt"');
// Stack[Stack.Count-2]^.FType.ExportName = 'TMSGDLGTYPE'
Stack.SetInt(-1, test_ord_mt(TMsgDlgType(Stack.GetUInt(-2))) );
end;
else
Result := False;
end;
end;
{$ENDIF}
procedure ExecRegisterBasics(AExec: TEMSTPSExec);
begin
@ -791,25 +783,4 @@ end;
{%endregion RegisterTClipboard}
{%region RegisterSelfTests}
procedure CompRegisterSelfTests(AComp: TPSPascalCompiler);
begin
end;
procedure ExecRegisterSelfTests(AExec: TEMSTPSExec);
begin
// for tests
{$IFnDEF PasMacroNoNativeCalls}
AExec.RegisterDelphiFunction(Functest_ord_mb, 'test_ord_mb', cdRegister);
AExec.RegisterDelphiFunction(Functest_ord_mt, 'test_ord_mt', cdRegister);
{$ELSE}
AExec.RegisterFunctionName('test_ord_mb', @ExecBasicHandler, Pointer(900), nil);
AExec.RegisterFunctionName('test_ord_mt', @ExecBasicHandler, Pointer(901), nil);
{$ENDIF}
end;
{%endregion RegisterSelfTests}
end.

50
components/macroscript/emscriptmacro.pas
View File

@ -5,8 +5,9 @@ unit EMScriptMacro;
interface
uses
Classes, SysUtils, SrcEditorIntf, IDEMsgIntf, Controls, SynEdit, EMScriptClasses, Laz2_XMLCfg, uPSRuntime,
uPSUtils, LazLoggerBase;
Classes, SysUtils, SrcEditorIntf, IDEMsgIntf, Controls, SynEdit,
EMScriptClasses, Laz2_XMLCfg, uPSRuntime, uPSUtils,
LazLoggerBase;
type
@ -24,6 +25,8 @@ type
FPrivateExec: TEMSTPSExec;
function GetCompiler: TEMSPSPascalCompiler;
function GetExec: TEMSTPSExec;
procedure SetCompiler(AValue: TEMSPSPascalCompiler);
procedure SetExec(AValue: TEMSTPSExec);
protected
function GetMacroName: String; override;
procedure SetMacroName(AValue: string); override;
@ -39,8 +42,8 @@ type
procedure Compile;
procedure FixBeginEnd;
property Compiler: TEMSPSPascalCompiler read GetCompiler;
property Exec: TEMSTPSExec read GetExec;
property Compiler: TEMSPSPascalCompiler read GetCompiler write SetCompiler;
property Exec: TEMSTPSExec read GetExec write SetExec;
public
constructor Create({%H-}aOwner: TComponent); override;
destructor Destroy; override;
@ -57,7 +60,6 @@ type
function IsInvalid: Boolean; override;
function IsRecording({%H-}AnEditor: TWinControl): Boolean; override;
procedure MakeTestable;
property PrivateCompiler: TEMSPSPascalCompiler read FPrivateCompiler write FPrivateCompiler;
property PrivateExec: TEMSTPSExec read FPrivateExec write FPrivateExec;
end;
@ -66,19 +68,19 @@ type
implementation
var
TheCompiler: TEMSPSPascalCompiler;
TheExec: TEMSTPSExec;
GlobalCompiler: TEMSPSPascalCompiler;
GlobalExec: TEMSTPSExec;
{ Create global objects }
procedure CreateCompiler;
begin
TheCompiler := TEMSPSPascalCompiler.Create;
GlobalCompiler := TEMSPSPascalCompiler.Create;
end;
procedure CreateExec;
begin
TheExec := TEMSTPSExec.Create;
GlobalExec := TEMSTPSExec.Create;
end;
{ TEMSEditorMacro }
@ -87,14 +89,26 @@ function TEMSEditorMacro.GetCompiler: TEMSPSPascalCompiler;
begin
Result := FPrivateCompiler;
if Result = nil then
Result := TheCompiler;
Result := GlobalCompiler;
end;
function TEMSEditorMacro.GetExec: TEMSTPSExec;
begin
Result := FPrivateExec;
if Result = nil then
Result := TheExec;
Result := GlobalExec;
end;
procedure TEMSEditorMacro.SetCompiler(AValue: TEMSPSPascalCompiler);
begin
FreeAndNil(FPrivateCompiler);
FPrivateCompiler := AValue;
end;
procedure TEMSEditorMacro.SetExec(AValue: TEMSTPSExec);
begin
FreeAndNil(FPrivateExec);
FPrivateExec := AValue;
end;
function TEMSEditorMacro.GetMacroName: String;
@ -314,23 +328,13 @@ begin
Result := False;
end;
procedure TEMSEditorMacro.MakeTestable;
begin
FreeAndNil(FPrivateExec);
FreeAndNil(FPrivateCompiler);
TheCompiler := TEMSPSPascalCompiler.Create;
TheCompiler.AddSelfTests;
TheExec := TEMSTPSExec.Create;
TheExec.AddSelfTests;
end;
initialization
CreateCompiler;
CreateExec;
finalization
FreeAndNil(TheExec);
FreeAndNil(TheCompiler);
FreeAndNil(GlobalExec);
FreeAndNil(GlobalCompiler);
end.

19
components/macroscript/test/testscriptprocs.pas
View File

@ -5,8 +5,8 @@ unit TestScriptProcs;
interface
uses
Classes, SysUtils, SynEdit, EMScriptMacro, Controls, Dialogs, Clipbrd, fpcunit, testutils,
testregistry;
Classes, SysUtils, SynEdit, EMScriptMacro, EMSSelfTest, Controls, Dialogs,
Clipbrd, fpcunit, testutils, testregistry;
type
@ -23,6 +23,7 @@ type
published
procedure TestBasics;
procedure TestSynProcs;
procedure TestSelfTest;
procedure TestInteractiv;
end;
@ -63,8 +64,7 @@ end;
procedure TTestCase1.TestBasics;
begin
FTestSyn := TSynEdit.Create(nil);
FTestMacro := TEMSEditorMacro.Create(nil);
FTestMacro.MakeTestable;
FTestMacro := TEMSelfTestEditorMacro.Create(nil);
try
DoTestSimple('SizeOf(TPoint)', '',
'var p: TPoint; begin if SizeOf(p) = ' +IntToStr(SizeOf(TPoint)) + ' then Caller.InsertTextAtCaret(''Y'', scamEnd); end.',
@ -159,8 +159,7 @@ end;
procedure TTestCase1.TestSynProcs;
begin
FTestSyn := TSynEdit.Create(nil);
FTestMacro := TEMSEditorMacro.Create(nil);
FTestMacro.MakeTestable;
FTestMacro := TEMSelfTestEditorMacro.Create(nil);
try
{%region Text / point / ecXXX *}
@ -581,11 +580,15 @@ begin
end;
end;
procedure TTestCase1.TestSelfTest;
begin
AssertTrue(DoSelfTest);
end;
procedure TTestCase1.TestInteractiv;
begin
FTestSyn := TSynEdit.Create(nil);
FTestMacro := TEMSEditorMacro.Create(nil);
FTestMacro.MakeTestable;
FTestMacro := TEMSelfTestEditorMacro.Create(nil);
try
DoTestSimple('ShowMessage', 'Y',