1
0
mirror of https://github.com/moparisthebest/Simba synced 2024-12-25 08:48:51 -05:00
Simba/Units/PascalScript/uPSComponent.pas
Merlijn Wajer 8558ae66d5 Simba/PS: Added extra directive ``FIXME''.
Not totally done yet. I also want to add ERROR.
Also modified the Pascalscript preprocessor a bit more, it never passed a
filename to the custom define functions. I'm open for more elegant solutions!
2011-02-21 14:36:55 +01:00

1554 lines
42 KiB
ObjectPascal

unit uPSComponent;
{$I PascalScript.inc}
interface
uses
SysUtils, Classes, uPSRuntime, uPSDebugger, uPSUtils,
uPSCompiler, uPSC_dll, uPSR_dll, uPSPreProcessor;
const
{alias to @link(ifps3.cdRegister)}
cdRegister = uPSRuntime.cdRegister;
{alias to @link(ifps3.cdPascal)}
cdPascal = uPSRuntime.cdPascal;
CdCdecl = uPSRuntime.CdCdecl;
CdStdCall = uPSRuntime.CdStdCall;
type
TPSScript = class;
TDelphiCallingConvention = uPSRuntime.TPSCallingConvention;
{Alias to @link(ifps3.TPSRuntimeClassImporter)}
TPSRuntimeClassImporter = uPSRuntime.TPSRuntimeClassImporter;
TPSPlugin = class(TComponent)
public
procedure CompOnUses(CompExec: TPSScript); virtual;
procedure ExecOnUses(CompExec: TPSScript); virtual;
procedure CompileImport1(CompExec: TPSScript); virtual;
procedure CompileImport2(CompExec: TPSScript); virtual;
procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); virtual;
procedure ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); virtual;
end;
TIFPS3Plugin = class(TPSPlugin);
TPSDllPlugin = class(TPSPlugin)
public
procedure CompOnUses(CompExec: TPSScript); override;
procedure ExecOnUses(CompExec: TPSScript); override;
end;
TIFPS3DllPlugin = class(TPSDllPlugin);
TPSPluginItem = class(TCollectionItem)
private
FPlugin: TPSPlugin;
procedure SetPlugin(const Value: TPSPlugin);
protected
function GetDisplayName: string; override;
public
procedure Assign(Source: TPersistent); override; //Birb
published
property Plugin: TPSPlugin read FPlugin write SetPlugin;
end;
TIFPS3CEPluginItem = class(TPSPluginItem);
TPSPlugins = class(TCollection)
private
FCompExec: TPSScript;
protected
function GetOwner: TPersistent; override;
public
constructor Create(CE: TPSScript);
end;
TIFPS3CEPlugins = class(TPSPlugins);
TPSOnGetNotVariant = function (Sender: TPSScript; const Name: tbtstring): Variant of object;
TPSOnSetNotVariant = procedure (Sender: TPSScript; const Name: tbtstring; V: Variant) of object;
TPSCompOptions = set of (icAllowNoBegin, icAllowUnit, icAllowNoEnd, icBooleanShortCircuit);
TPSVerifyProc = procedure (Sender: TPSScript; Proc: TPSInternalProcedure; const Decl: tbtstring; var Error: Boolean) of object;
TPSEvent = procedure (Sender: TPSScript) of object;
TPSOnCompImportEvent = procedure (Sender: TObject; x: TPSPascalCompiler) of object;
TPSOnExecImportEvent = procedure (Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter) of object;
{Script engine event function}
TPSOnNeedFile = function (Sender: TObject; const OrginFileName: tbtstring; var FileName, Output: tbtstring): Boolean of object;
{ Added by Wizzup }
TPSOnFileAlreadyIncluded = function (Sender: TObject; FileName: tbtstring): Boolean of object;
{ Wizzup out }
TPSOnProcessDirective = procedure (
Sender: TPSPreProcessor;
Parser: TPSPascalPreProcessorParser;
const Active: Boolean;
const DirectiveName, DirectiveParam: tbtstring;
Var Continue: Boolean;
Filename: tbtString) of Object; // jgv
TPSScript = class(TComponent)
private
FOnGetNotificationVariant: TPSOnGetNotVariant;
FOnSetNotificationVariant: TPSOnSetNotVariant;
FCanAdd: Boolean;
FComp: TPSPascalCompiler;
FCompOptions: TPSCompOptions;
FExec: TPSDebugExec;
FSuppressLoadData: Boolean;
FScript: TStrings;
FOnLine: TNotifyEvent;
FUseDebugInfo: Boolean;
FOnAfterExecute, FOnCompile, FOnExecute: TPSEvent;
FOnCompImport: TPSOnCompImportEvent;
FOnExecImport: TPSOnExecImportEvent;
RI: TPSRuntimeClassImporter;
FPlugins: TPSPlugins;
FPP: TPSPreProcessor;
FMainFileName: tbtstring;
FOnNeedFile: TPSOnNeedFile;
{ Added by Wizzup }
FOnFileAlreadyIncluded: TPSOnFileAlreadyIncluded;
{ Wizzup out }
FUsePreProcessor: Boolean;
FDefines: TStrings;
FOnVerifyProc: TPSVerifyProc;
FOnProcessDirective: TPSOnProcessDirective;
FOnProcessUnknowDirective: TPSOnProcessDirective;
FOnFindUnknownFile: TPSOnNeedFile;
function GetRunning: Boolean;
procedure SetScript(const Value: TStrings);
function GetCompMsg(i: Integer): TPSPascalCompilerMessage;
function GetCompMsgCount: Longint;
function GetAbout: tbtstring;
function ScriptUses(Sender: TPSPascalCompiler; const Name: tbtstring): Boolean;
function GetExecErrorByteCodePosition: Cardinal;
function GetExecErrorCode: TIFError;
function GetExecErrorParam: tbtstring;
function GetExecErrorProcNo: Cardinal;
function GetExecErrorString: tbtstring;
function GetExecErrorPosition: Cardinal;
function GetExecErrorCol: Cardinal;
function GetExecErrorRow: Cardinal;
function GetExecErrorFileName: tbtstring;
procedure SetDefines(const Value: TStrings);
protected
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
protected
//jgv move where private before - not very usefull
procedure OnLineEvent; virtual;
procedure SetMainFileName(const Value: tbtstring); virtual;
//--jgv new
function DoOnNeedFile (Sender: TObject; const OrginFileName: tbtstring; var FileName, Output: tbtstring): Boolean; virtual;
{ Added by Wizzup }
function DoOnFileAlreadyIncluded (Sender: TObject; FileName: tbtstring): Boolean; virtual;
{ Wizzup out }
function DoOnUnknowUses (Sender: TPSPascalCompiler; const Name: tbtstring): Boolean; virtual; // return true if processed
procedure DoOnCompImport; virtual;
procedure DoOnCompile; virtual;
function DoVerifyProc (Sender: TPSScript; Proc: TPSInternalProcedure; const Decl: tbtstring): Boolean; virtual;
procedure DoOnExecImport (RunTimeImporter: TPSRuntimeClassImporter); virtual;
procedure DoOnExecute (RunTimeImporter: TPSRuntimeClassImporter); virtual;
procedure DoAfterExecute; virtual;
function DoOnGetNotificationVariant (const Name: tbtstring): Variant; virtual;
procedure DoOnSetNotificationVariant (const Name: tbtstring; V: Variant); virtual;
procedure DoOnProcessDirective (Sender: TPSPreProcessor;
Parser: TPSPascalPreProcessorParser;
const Active: Boolean;
const DirectiveName, DirectiveParam: tbtstring;
Var Continue: Boolean;
Filename: tbtString); virtual;
procedure DoOnProcessUnknowDirective (Sender: TPSPreProcessor;
Parser: TPSPascalPreProcessorParser;
const Active: Boolean;
const DirectiveName, DirectiveParam: tbtstring;
Var Continue: Boolean;
Filename: tbtString); virtual;
public
property RuntimeImporter: TPSRuntimeClassImporter read RI;
function FindNamedType(const Name: tbtstring): TPSTypeRec;
function FindBaseType(Bt: TPSBaseType): TPSTypeRec;
property SuppressLoadData: Boolean read FSuppressLoadData write FSuppressLoadData;
function LoadExec: Boolean;
procedure Stop; virtual;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function Compile: Boolean; virtual;
function Execute: Boolean; virtual;
property Running: Boolean read GetRunning;
procedure GetCompiled(var data: tbtstring);
procedure SetCompiled(const Data: tbtstring);
property Comp: TPSPascalCompiler read FComp;
property Exec: TPSDebugExec read FExec;
property CompilerMessageCount: Longint read GetCompMsgCount;
property CompilerMessages[i: Longint]: TPSPascalCompilerMessage read GetCompMsg;
function CompilerErrorToStr(I: Longint): tbtstring;
property ExecErrorCode: TIFError read GetExecErrorCode;
property ExecErrorParam: tbtstring read GetExecErrorParam;
property ExecErrorToString: tbtstring read GetExecErrorString;
property ExecErrorProcNo: Cardinal read GetExecErrorProcNo;
property ExecErrorByteCodePosition: Cardinal read GetExecErrorByteCodePosition;
property ExecErrorPosition: Cardinal read GetExecErrorPosition;
property ExecErrorRow: Cardinal read GetExecErrorRow;
property ExecErrorCol: Cardinal read GetExecErrorCol;
property ExecErrorFileName: tbtstring read GetExecErrorFileName;
function AddFunctionEx(Ptr: Pointer; const Decl: tbtstring; CallingConv: TDelphiCallingConvention): Boolean;
function AddFunction(Ptr: Pointer; const Decl: tbtstring): Boolean;
function AddMethodEx(Slf, Ptr: Pointer; const Decl: tbtstring; CallingConv: TDelphiCallingConvention): Boolean;
function AddMethod(Slf, Ptr: Pointer; const Decl: tbtstring): Boolean;
function AddRegisteredVariable(const VarName, VarType: tbtstring): Boolean;
function AddNotificationVariant(const VarName: tbtstring): Boolean;
function AddRegisteredPTRVariable(const VarName, VarType: tbtstring): Boolean;
function GetVariable(const Name: tbtstring): PIFVariant;
function SetVarToInstance(const VarName: tbtstring; cl: TObject): Boolean;
procedure SetPointerToData(const VarName: tbtstring; Data: Pointer; aType: TIFTypeRec);
function TranslatePositionPos(Proc, Position: Cardinal; var Pos: Cardinal; var fn: tbtstring): Boolean;
function TranslatePositionRC(Proc, Position: Cardinal; var Row, Col: Cardinal; var fn: tbtstring): Boolean;
function GetProcMethod(const ProcName: tbtstring): TMethod;
function ExecuteFunction(const Params: array of Variant; const ProcName: tbtstring): Variant;
published
property About: tbtstring read GetAbout stored false;
property Script: TStrings read FScript write SetScript;
property CompilerOptions: TPSCompOptions read FCompOptions write FCompOptions;
property OnLine: TNotifyEvent read FOnLine write FOnLine;
property OnCompile: TPSEvent read FOnCompile write FOnCompile;
property OnExecute: TPSEvent read FOnExecute write FOnExecute;
property OnAfterExecute: TPSEvent read FOnAfterExecute write FOnAfterExecute;
property OnCompImport: TPSOnCompImportEvent read FOnCompImport write FOnCompImport;
property OnExecImport: TPSOnExecImportEvent read FOnExecImport write FOnExecImport;
property UseDebugInfo: Boolean read FUseDebugInfo write FUseDebugInfo default True;
property Plugins: TPSPlugins read FPlugins write FPlugins;
property MainFileName: tbtstring read FMainFileName write SetMainFileName;
property UsePreProcessor: Boolean read FUsePreProcessor write FUsePreProcessor;
property OnNeedFile: TPSOnNeedFile read FOnNeedFile write FOnNeedFile;
{ Added by Wizzup }
property OnFileAlreadyIncluded: TPSOnFileAlreadyIncluded read FOnFileAlreadyIncluded write FOnFileAlreadyIncluded;
{ Wizzup out }
property Defines: TStrings read FDefines write SetDefines;
property OnVerifyProc: TPSVerifyProc read FOnVerifyProc write FOnVerifyProc;
property OnGetNotificationVariant: TPSOnGetNotVariant read FOnGetNotificationVariant write FOnGetNotificationVariant;
property OnSetNotificationVariant: TPSOnSetNotVariant read FOnSetNotificationVariant write FOnSetNotificationVariant;
property OnFindUnknownFile: TPSOnNeedFile read FOnFindUnknownFile write FOnFindUnknownFile;
published
//-- jgv
property OnProcessDirective: TPSOnProcessDirective read FOnProcessDirective write FOnProcessDirective;
property OnProcessUnknowDirective: TPSOnProcessDirective read FOnProcessUnknowDirective write FOnProcessUnknowDirective;
end;
TIFPS3CompExec = class(TPSScript);
TPSBreakPointInfo = class
private
FLine: Longint;
FFileNameHash: Longint;
FFileName: tbtstring;
procedure SetFileName(const Value: tbtstring);
public
property FileName: tbtstring read FFileName write SetFileName;
property FileNameHash: Longint read FFileNameHash;
property Line: Longint read FLine write FLine;
end;
TPSOnLineInfo = procedure (Sender: TObject; const FileName: tbtstring; Position, Row, Col: Cardinal) of object;
TPSScriptDebugger = class(TPSScript)
private
FOnIdle: TNotifyEvent;
FBreakPoints: TIFList;
FOnLineInfo: TPSOnLineInfo;
FLastRow: Cardinal;
FOnBreakpoint: TPSOnLineInfo;
function GetBreakPoint(I: Integer): TPSBreakPointInfo;
function GetBreakPointCount: Longint;
protected
procedure SetMainFileName(const Value: tbtstring); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Pause; virtual;
procedure Resume; virtual;
procedure StepInto; virtual;
procedure StepOver; virtual;
procedure SetBreakPoint(const Fn: tbtstring; Line: Longint);
procedure ClearBreakPoint(const Fn: tbtstring; Line: Longint);
property BreakPointCount: Longint read GetBreakPointCount;
property BreakPoint[I: Longint]: TPSBreakPointInfo read GetBreakPoint;
function HasBreakPoint(const Fn: tbtstring; Line: Longint): Boolean;
procedure ClearBreakPoints;
function GetVarContents(const Name: tbtstring): tbtstring;
published
property OnIdle: TNotifyEvent read FOnIdle write FOnIdle;
property OnLineInfo: TPSOnLineInfo read FOnLineInfo write FOnLineInfo;
property OnBreakpoint: TPSOnLineInfo read FOnBreakpoint write FOnBreakpoint;
end;
TIFPS3DebugCompExec = class(TPSScriptDebugger);
TPSCustomPlugin = class(TPSPlugin)
private
FOnCompileImport2: TPSEvent;
FOnExecOnUses: TPSEvent;
FOnCompOnUses: TPSEvent;
FOnCompileImport1: TPSEvent;
FOnExecImport1: TPSOnExecImportEvent;
FOnExecImport2: TPSOnExecImportEvent;
public
procedure CompOnUses(CompExec: TPSScript); override;
procedure ExecOnUses(CompExec: TPSScript); override;
procedure CompileImport1(CompExec: TPSScript); override;
procedure CompileImport2(CompExec: TPSScript); override;
procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
procedure ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
public
published
property OnCompOnUses : TPSEvent read FOnCompOnUses write FOnCompOnUses;
property OnExecOnUses: TPSEvent read FOnExecOnUses write FOnExecOnUses;
property OnCompileImport1: TPSEvent read FOnCompileImport1 write FOnCompileImport1;
property OnCompileImport2: TPSEvent read FOnCompileImport2 write FOnCompileImport2;
property OnExecImport1: TPSOnExecImportEvent read FOnExecImport1 write FOnExecImport1;
property OnExecImport2: TPSOnExecImportEvent read FOnExecImport2 write FOnExecImport2;
end;
implementation
{$IFDEF DELPHI3UP }
resourceString
{$ELSE }
const
{$ENDIF }
RPS_UnableToReadVariant = 'Unable to read variant';
RPS_UnableToWriteVariant = 'Unable to write variant';
RPS_ScripEngineAlreadyRunning = 'Script engine already running';
RPS_ScriptNotCompiled = 'Script is not compiled';
RPS_NotRunning = 'Not running';
RPS_UnableToFindVariable = 'Unable to find variable';
RPS_UnknownIdentifier = 'Unknown Identifier';
RPS_NoScript = 'No script';
function MyGetVariant(Sender: TPSExec; const Name: tbtstring): Variant;
begin
Result := TPSScript (Sender.Id).DoOnGetNotificationVariant(Name);
end;
procedure MySetVariant(Sender: TPSExec; const Name: tbtstring; V: Variant);
begin
TPSScript (Sender.Id).DoOnSetNotificationVariant(Name, V);
end;
function CompScriptUses(Sender: TPSPascalCompiler; const Name: tbtstring): Boolean;
begin
Result := TPSScript(Sender.ID).ScriptUses(Sender, Name);
end;
procedure ExecOnLine(Sender: TPSExec);
begin
if assigned(TPSScript(Sender.ID).FOnLine) then
begin
TPSScript(Sender.ID).OnLineEvent;
end;
end;
function CompExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; const ProcDecl: tbtstring): Boolean;
begin
Result := TPSScript(Sender.ID).DoVerifyProc (Sender.ID, Proc, ProcDecl);
end;
procedure callObjectOnProcessDirective (
Sender: TPSPreProcessor;
Parser: TPSPascalPreProcessorParser;
const Active: Boolean;
const DirectiveName, DirectiveParam: tbtstring;
Var Continue: Boolean; Filename: tbtstring);
begin
TPSScript (Sender.ID).DoOnProcessDirective(Sender, Parser, Active, DirectiveName, DirectiveParam, Continue, Filename);
end;
procedure callObjectOnProcessUnknowDirective (
Sender: TPSPreProcessor;
Parser: TPSPascalPreProcessorParser;
const Active: Boolean;
const DirectiveName, DirectiveParam: tbtstring;
Var Continue: Boolean; Filename: tbtString);
begin
TPSScript (Sender.ID).DoOnProcessUnknowDirective(Sender, Parser, Active, DirectiveName, DirectiveParam, Continue, Filename);
end;
{ TPSPlugin }
procedure TPSPlugin.CompileImport1(CompExec: TPSScript);
begin
// do nothing
end;
procedure TPSPlugin.CompileImport2(CompExec: TPSScript);
begin
// do nothing
end;
procedure TPSPlugin.CompOnUses(CompExec: TPSScript);
begin
// do nothing
end;
procedure TPSPlugin.ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
begin
// do nothing
end;
procedure TPSPlugin.ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
begin
// do nothing
end;
procedure TPSPlugin.ExecOnUses(CompExec: TPSScript);
begin
// do nothing
end;
{ TPSScript }
function TPSScript.AddFunction(Ptr: Pointer;
const Decl: tbtstring): Boolean;
begin
Result := AddFunctionEx(Ptr, Decl, cdRegister);
end;
function TPSScript.AddFunctionEx(Ptr: Pointer; const Decl: tbtstring;
CallingConv: TDelphiCallingConvention): Boolean;
var
P: TPSRegProc;
begin
if not FCanAdd then begin Result := False; exit; end;
p := Comp.AddDelphiFunction(Decl);
if p <> nil then
begin
Exec.RegisterDelphiFunction(Ptr, p.Name, CallingConv);
Result := True;
end else Result := False;
end;
function TPSScript.AddRegisteredVariable(const VarName,
VarType: tbtstring): Boolean;
var
FVar: TPSVar;
begin
if not FCanAdd then begin Result := False; exit; end;
FVar := FComp.AddUsedVariableN(varname, vartype);
if fvar = nil then
result := False
else begin
fvar.exportname := fvar.Name;
Result := True;
end;
end;
function CENeedFile(Sender: TPSPreProcessor; const callingfilename: tbtstring; var FileName, Output: tbtstring): Boolean;
begin
Result := TPSScript (Sender.ID).DoOnNeedFile(Sender.ID, CallingFileName, FileName, Output);
end;
{ Added by Wizzup }
function CEOnFileAlreadyIncluded(Sender: TPSPreProcessor; FileName: tbtstring): Boolean;
begin
Result := TPSScript (Sender.ID).DoOnFileAlreadyIncluded(Sender.ID, Filename);
end;
{ Wizzup out }
procedure CompTranslateLineInfo(Sender: TPSPascalCompiler; var Pos, Row, Col: Cardinal; var Name: tbtstring);
var
res: TPSLineInfoResults;
begin
if TPSScript(Sender.ID).FPP.CurrentLineInfo.GetLineInfo(Name, Pos, Res) then
begin
Pos := Res.Pos;
Row := Res.Row;
Col := Res.Col;
Name := Res.Name;
end;
end;
function TPSScript.Compile: Boolean;
var
i: Longint;
dta: tbtstring;
begin
FExec.Clear;
FExec.CMD_Err(erNoError);
FExec.ClearspecialProcImports;
FExec.ClearFunctionList;
if ri <> nil then
begin
RI.Free;
RI := nil;
end;
RI := TPSRuntimeClassImporter.Create;
for i := 0 to FPlugins.Count -1 do
begin
if (TPSPluginItem(FPlugins.Items[i]) <> nil) and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then
TPSPluginItem(FPlugins.Items[i]).Plugin.ExecImport1(Self, ri);
end;
DoOnExecImport (RI);
for i := 0 to FPlugins.Count -1 do
begin
if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then
TPSPluginItem(FPlugins.Items[i]).Plugin.ExecImport2(Self, ri);
end;
RegisterClassLibraryRuntime(Exec, RI);
for i := 0 to FPlugins.Count -1 do
begin
if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then
TPSPluginItem(FPlugins.Items[i]).Plugin.ExecOnUses(Self);
end;
FCanAdd := True;
FComp.BooleanShortCircuit := icBooleanShortCircuit in FCompOptions;
FComp.AllowNoBegin := icAllowNoBegin in FCompOptions;
FComp.AllowUnit := icAllowUnit in FCompOptions;
FComp.AllowNoEnd := icAllowNoEnd in FCompOptions;
if FUsePreProcessor then
begin
FPP.Clear;
FPP.Defines.Assign(FDefines);
FComp.OnTranslateLineInfo := CompTranslateLineInfo;
Fpp.OnProcessDirective := callObjectOnProcessDirective;
Fpp.OnProcessUnknowDirective := callObjectOnProcessUnknowDirective;
Fpp.MainFile := FScript.Text;
Fpp.MainFileName := FMainFileName;
Fpp.PreProcess(FMainFileName, dta);
if FComp.Compile(dta) then
begin
FCanAdd := False;
if (not SuppressLoadData) and (not LoadExec) then
begin
Result := False;
end else
Result := True;
end else Result := False;
Fpp.AdjustMessages(Comp);
end else
begin
FComp.OnTranslateLineInfo := nil;
if FComp.Compile(FScript.Text) then
begin
FCanAdd := False;
if not LoadExec then
begin
Result := False;
end else
Result := True;
end else Result := False;
end;
end;
function TPSScript.CompilerErrorToStr(I: Integer): tbtstring;
begin
Result := CompilerMessages[i].MessageToString;
end;
constructor TPSScript.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FComp := TPSPascalCompiler.Create;
FExec := TPSDebugExec.Create;
FScript := TStringList.Create;
FPlugins := TPSPlugins.Create(self);
FComp.ID := Self;
FComp.OnUses := CompScriptUses;
FComp.OnExportCheck := CompExportCheck;
FExec.Id := Self;
FExec.OnRunLine:= ExecOnLine;
FExec.OnGetNVariant := MyGetVariant;
FExec.OnSetNVariant := MySetVariant;
FUseDebugInfo := True;
FPP := TPSPreProcessor.Create;
FPP.Id := Self;
FPP.OnNeedFile := CENeedFile;
{ Added by Wizzup }
FPP.OnFileAlreadyIncluded:= CEOnFileAlreadyIncluded;
{ Wizzup out }
FDefines := TStringList.Create;
end;
destructor TPSScript.Destroy;
begin
FDefines.Free;
FPP.Free;
RI.Free;
FPlugins.Free;
FPlugins := nil;
FScript.Free;
FExec.Free;
FComp.Free;
inherited Destroy;
end;
function TPSScript.Execute: Boolean;
begin
if Running then raise Exception.Create(RPS_ScripEngineAlreadyRunning);
if SuppressLoadData then
LoadExec;
DoOnExecute (RI);
FExec.DebugEnabled := FUseDebugInfo;
Result := FExec.RunScript and (FExec.ExceptionCode = erNoError) ;
DoAfterExecute;
end;
function TPSScript.GetAbout: tbtstring;
begin
Result := TPSExec.About;
end;
procedure TPSScript.GetCompiled(var data: tbtstring);
begin
if not FComp.GetOutput(Data) then
raise Exception.Create(RPS_ScriptNotCompiled);
end;
function TPSScript.GetCompMsg(i: Integer): TPSPascalCompilerMessage;
begin
Result := FComp.Msg[i];
end;
function TPSScript.GetCompMsgCount: Longint;
begin
Result := FComp.MsgCount;
end;
function TPSScript.GetExecErrorByteCodePosition: Cardinal;
begin
Result := Exec.ExceptionPos;
end;
function TPSScript.GetExecErrorCode: TIFError;
begin
Result := Exec.ExceptionCode;
end;
function TPSScript.GetExecErrorParam: tbtstring;
begin
Result := Exec.ExceptionString;
end;
function TPSScript.GetExecErrorPosition: Cardinal;
begin
Result := FExec.TranslatePosition(Exec.ExceptionProcNo, Exec.ExceptionPos);
end;
function TPSScript.GetExecErrorProcNo: Cardinal;
begin
Result := Exec.ExceptionProcNo;
end;
function TPSScript.GetExecErrorString: tbtstring;
begin
Result := TIFErrorToString(Exec.ExceptionCode, Exec.ExceptionString);
end;
function TPSScript.GetVariable(const Name: tbtstring): PIFVariant;
begin
Result := FExec.GetVar2(name);
end;
function TPSScript.LoadExec: Boolean;
var
s: tbtstring;
begin
if (not FComp.GetOutput(s)) or (not FExec.LoadData(s)) then
begin
Result := False;
exit;
end;
if FUseDebugInfo then
begin
FComp.GetDebugOutput(s);
FExec.LoadDebugData(s);
end;
Result := True;
end;
function TPSScript.ScriptUses(Sender: TPSPascalCompiler;
const Name: tbtstring): Boolean;
var
i: Longint;
begin
if Name = 'SYSTEM' then
begin
for i := 0 to FPlugins.Count -1 do
begin
if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then
TPSPluginItem(FPlugins.Items[i]).Plugin.CompOnUses(Self);
end;
for i := 0 to FPlugins.Count -1 do
begin
if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then
TPSPluginItem(FPlugins.Items[i]).Plugin.CompileImport1(self);
end;
DoOnCompImport;
for i := 0 to FPlugins.Count -1 do
begin
if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then
TPSPluginItem(FPlugins.Items[i]).Plugin.CompileImport2(Self);
end;
DoOnCompile;
Result := true;
for i := 0 to Sender.MsgCount -1 do begin
if Sender.Msg[i] is TPSPascalCompilerError then Result := false;
end;
end
else begin
Result := DoOnUnknowUses (Sender, Name);
{ If Not Result then
Sender.MakeError('', ecUnknownIdentifier, Name);}
end;
end;
procedure TPSScript.SetCompiled(const Data: tbtstring);
var
i: Integer;
begin
FExec.Clear;
FExec.ClearspecialProcImports;
FExec.ClearFunctionList;
if ri <> nil then
begin
RI.Free;
RI := nil;
end;
RI := TPSRuntimeClassImporter.Create;
for i := 0 to FPlugins.Count -1 do
begin
if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then
TPSPluginItem(FPlugins.Items[i]).Plugin.ExecImport1(Self, ri);
end;
DoOnExecImport(RI);
for i := 0 to FPlugins.Count -1 do
begin
if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then
TPSPluginItem(FPlugins.Items[i]).Plugin.ExecImport2(Self, ri);
end;
RegisterClassLibraryRuntime(Exec, RI);
for i := 0 to FPlugins.Count -1 do
begin
if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then
TPSPluginItem(FPlugins.Items[i]).Plugin.ExecOnUses(Self);
end;
if not FExec.LoadData(Data) then
raise Exception.Create(GetExecErrorString);
end;
function TPSScript.SetVarToInstance(const VarName: tbtstring; cl: TObject): Boolean;
var
p: PIFVariant;
begin
p := GetVariable(VarName);
if p <> nil then
begin
SetVariantToClass(p, cl);
result := true;
end else result := false;
end;
procedure TPSScript.SetScript(const Value: TStrings);
begin
FScript.Assign(Value);
end;
function TPSScript.AddMethod(Slf, Ptr: Pointer;
const Decl: tbtstring): Boolean;
begin
Result := AddMethodEx(Slf, Ptr, Decl, cdRegister);
end;
function TPSScript.AddMethodEx(Slf, Ptr: Pointer; const Decl: tbtstring;
CallingConv: TDelphiCallingConvention): Boolean;
var
P: TPSRegProc;
begin
if not FCanAdd then begin Result := False; exit; end;
p := Comp.AddDelphiFunction(Decl);
if p <> nil then
begin
Exec.RegisterDelphiMethod(Slf, Ptr, p.Name, CallingConv);
Result := True;
end else Result := False;
end;
procedure TPSScript.OnLineEvent;
begin
if @FOnLine <> nil then FOnLine(Self);
end;
function TPSScript.GetRunning: Boolean;
begin
Result := FExec.Status = isRunning;
end;
function TPSScript.GetExecErrorCol: Cardinal;
var
s: tbtstring;
D1: Cardinal;
begin
if not TranslatePositionRC(Exec.ExceptionProcNo, Exec.ExceptionPos, D1, Result, s) then
Result := 0;
end;
function TPSScript.TranslatePositionPos(Proc, Position: Cardinal;
var Pos: Cardinal; var fn: tbtstring): Boolean;
var
D1, D2: Cardinal;
begin
Result := Exec.TranslatePositionEx(Exec.ExceptionProcNo, Exec.ExceptionPos, Pos, D1, D2, fn);
end;
function TPSScript.TranslatePositionRC(Proc, Position: Cardinal;
var Row, Col: Cardinal; var fn: tbtstring): Boolean;
var
d1: Cardinal;
begin
Result := Exec.TranslatePositionEx(Proc, Position, d1, Row, Col, fn);
end;
function TPSScript.GetExecErrorRow: Cardinal;
var
D1: Cardinal;
s: tbtstring;
begin
if not TranslatePositionRC(Exec.ExceptionProcNo, Exec.ExceptionPos, Result, D1, s) then
Result := 0;
end;
procedure TPSScript.Stop;
begin
if (FExec.Status = isRunning) or (Fexec.Status = isPaused) then
FExec.Stop
else
raise Exception.Create(RPS_NotRunning);
end;
function TPSScript.GetProcMethod(const ProcName: tbtstring): TMethod;
begin
Result := FExec.GetProcAsMethodN(ProcName)
end;
procedure TPSScript.SetMainFileName(const Value: tbtstring);
begin
FMainFileName := Value;
end;
function TPSScript.GetExecErrorFileName: tbtstring;
var
D1, D2: Cardinal;
begin
if not TranslatePositionRC(Exec.ExceptionProcNo, Exec.ExceptionPos, D1, D2, Result) then
Result := '';
end;
procedure TPSScript.SetPointerToData(const VarName: tbtstring;
Data: Pointer; aType: TIFTypeRec);
var
v: PIFVariant;
t: TPSVariantIFC;
begin
v := GetVariable(VarName);
if (Atype = nil) or (v = nil) then raise Exception.Create(RPS_UnableToFindVariable);
t.Dta := @PPSVariantData(v).Data;
t.aType := v.FType;
t.VarParam := false;
VNSetPointerTo(t, Data, aType);
end;
function TPSScript.AddRegisteredPTRVariable(const VarName,
VarType: tbtstring): Boolean;
var
FVar: TPSVar;
begin
if not FCanAdd then begin Result := False; exit; end;
FVar := FComp.AddUsedVariableN(varname, vartype);
if fvar = nil then
result := False
else begin
fvar.exportname := fvar.Name;
fvar.SaveAsPointer := true;
Result := True;
end;
end;
procedure TPSScript.SetDefines(const Value: TStrings);
begin
FDefines.Assign(Value);
end;
function TPSScript.ExecuteFunction(const Params: array of Variant;
const ProcName: tbtstring): Variant;
begin
if SuppressLoadData then
LoadExec;
DoOnExecute (RI);
FExec.DebugEnabled := FUseDebugInfo;
Result := Exec.RunProcPN(Params, ProcName);
DoAfterExecute;
end;
function TPSScript.FindBaseType(Bt: TPSBaseType): TPSTypeRec;
begin
Result := Exec.FindType2(Bt);
end;
function TPSScript.FindNamedType(const Name: tbtstring): TPSTypeRec;
begin
Result := Exec.GetTypeNo(Exec.GetType(Name));
end;
procedure TPSScript.Notification(AComponent: TComponent;
Operation: TOperation);
var
i: Longint;
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (aComponent is TPSPlugin) then
begin
if Plugins <> nil then
for i := Plugins.Count -1 downto 0 do
begin
if (Plugins.Items[i] as TPSPluginItem).Plugin = aComponent then
{$IFDEF FPC_COL_NODELETE}
TCollectionItem(Plugins.Items[i]).Free;
{$ELSE}
Plugins.Delete(i);
{$ENDIF}
end;
end;
end;
function TPSScript.AddNotificationVariant(const VarName: tbtstring): Boolean;
begin
Result := AddRegisteredVariable(VarName, '!NOTIFICATIONVARIANT');
end;
procedure TPSScript.DoOnProcessDirective(Sender: TPSPreProcessor;
Parser: TPSPascalPreProcessorParser; const Active: Boolean;
const DirectiveName, DirectiveParam: tbtstring; var Continue: Boolean;
Filename: tbtString);
begin
If Assigned (OnProcessDirective) then
OnProcessDirective (Sender, Parser, Active, DirectiveName, DirectiveParam, Continue, Filename);
end;
procedure TPSScript.DoOnProcessUnknowDirective(Sender: TPSPreProcessor;
Parser: TPSPascalPreProcessorParser; const Active: Boolean;
const DirectiveName, DirectiveParam: tbtstring; var Continue: Boolean;
FileName: tbtString);
begin
If Assigned (OnProcessUnknowDirective) then
OnProcessUnknowDirective (Sender, Parser, Active, DirectiveName, DirectiveParam, Continue,Filename);
end;
function TPSScript.DoOnNeedFile(Sender: TObject;
const OrginFileName: tbtstring; var FileName, Output: tbtstring): Boolean;
begin
If Assigned (OnNeedFile) then
Result := OnNeedFile(Sender, OrginFileName, FileName, Output)
else
Result := False;
end;
{ Added by Wizzup }
function TPSScript.DoOnFileAlreadyIncluded(Sender: TObject;
FileName: tbtstring): Boolean;
begin
If Assigned (OnFileAlreadyIncluded) then
Result := OnFileAlreadyIncluded(Sender, FileName)
else
Result := False;
end;
{ Wizzup out }
function TPSScript.DoOnUnknowUses(Sender: TPSPascalCompiler;
const Name: tbtstring): Boolean;
var
lPrevAllowUnit: Boolean;
lData, lName: tbtstring;
begin
if assigned(FOnFindUnknownFile) then begin
lName := Name;
if FOnFindUnknownFile(self, '', lName, lData) then begin
lPrevAllowUnit := FComp.AllowUnit;
FComp.AllowUnit := true;
if FUsePreProcessor then
begin
FPP.Defines.Assign(FDefines);
Fpp.MainFile := lData;
Fpp.MainFileName := lName;
Fpp.PreProcess(lName, lData);
Result := FComp.Compile(lData);
Fpp.AdjustMessages(FComp);
end else
begin
FComp.OnTranslateLineInfo := nil;
Result := FComp.Compile(lData);
end;
FComp.AllowUnit := lPrevAllowUnit;
end else begin
FComp.MakeError(FComp.UnitName, ecUnknownIdentifier, lName);
Result := false;
end;
end else begin
FComp.MakeError(FComp.UnitName, ecUnknownIdentifier, lName);
result := false;
end;
end;
procedure TPSScript.DoOnCompImport;
begin
if assigned(OnCompImport) then
OnCompImport(Self, Comp);
end;
procedure TPSScript.DoOnCompile;
begin
if assigned(OnCompile) then
OnCompile(Self);
end;
procedure TPSScript.DoOnExecute;
begin
If Assigned (OnExecute) then
OnExecute (Self);
end;
procedure TPSScript.DoAfterExecute;
begin
if Assigned (OnAfterExecute) then
OnAfterExecute(Self);
end;
function TPSScript.DoVerifyProc(Sender: TPSScript;
Proc: TPSInternalProcedure; const Decl: tbtstring): Boolean;
begin
if Assigned(OnVerifyProc) then begin
Result := false;
OnVerifyProc(Sender, Proc, Decl, Result);
Result := not Result;
end
else
Result := True;
end;
procedure TPSScript.DoOnExecImport(
RunTimeImporter: TPSRuntimeClassImporter);
begin
if assigned(OnExecImport) then
OnExecImport(Self, FExec, RunTimeImporter);
end;
function TPSScript.DoOnGetNotificationVariant(const Name: tbtstring): Variant;
begin
if Not Assigned (OnGetNotificationVariant) then
raise Exception.Create(RPS_UnableToReadVariant);
Result := OnGetNotificationVariant(Self, Name);
end;
procedure TPSScript.DoOnSetNotificationVariant(const Name: tbtstring;
V: Variant);
begin
if Not Assigned (OnSetNotificationVariant) then
raise Exception.Create(RPS_UnableToWriteVariant);
OnSetNotificationVariant(Self, Name, v);
end;
{ TPSDllPlugin }
procedure TPSDllPlugin.CompOnUses;
begin
CompExec.Comp.OnExternalProc := DllExternalProc;
end;
procedure TPSDllPlugin.ExecOnUses;
begin
RegisterDLLRuntime(CompExec.Exec);
end;
{ TPS3DebugCompExec }
procedure LineInfo(Sender: TPSDebugExec; const FileName: tbtstring; Position, Row, Col: Cardinal);
var
Dc: TPSScriptDebugger;
h, i: Longint;
bi: TPSBreakPointInfo;
lFileName: tbtstring;
begin
Dc := Sender.Id;
if FileName = '' then
lFileName := dc.MainFileName
else
lFileName := FileName;
if @dc.FOnLineInfo <> nil then dc.FOnLineInfo(dc, lFileName, Position, Row, Col);
if row = dc.FLastRow then exit;
dc.FLastRow := row;
h := MakeHash(lFileName);
bi := nil;
for i := DC.FBreakPoints.Count -1 downto 0 do
begin
bi := Dc.FBreakpoints[i];
if (h = bi.FileNameHash) and (lFileName = bi.FileName) and (Cardinal(bi.Line) = Row) then
begin
Break;
end;
Bi := nil;
end;
if bi <> nil then
begin
if @dc.FOnBreakpoint <> nil then dc.FOnBreakpoint(dc, lFileName, Position, Row, Col);
dc.Pause;
end;
end;
procedure IdleCall(Sender: TPSDebugExec);
var
Dc: TPSScriptDebugger;
begin
Dc := Sender.Id;
if @dc.FOnIdle <> nil then
dc.FOnIdle(DC)
else
dc.Exec.Run;
end;
procedure TPSScriptDebugger.ClearBreakPoint(const Fn: tbtstring; Line: Integer);
var
h, i: Longint;
bi: TPSBreakPointInfo;
begin
h := MakeHash(Fn);
for i := FBreakPoints.Count -1 downto 0 do
begin
bi := FBreakpoints[i];
if (h = bi.FileNameHash) and (Fn = bi.FileName) and (bi.Line = Line) then
begin
FBreakPoints.Delete(i);
bi.Free;
Break;
end;
end;
end;
procedure TPSScriptDebugger.ClearBreakPoints;
var
i: Longint;
begin
for i := FBreakPoints.Count -1 downto 0 do
TPSBreakPointInfo(FBreakPoints[i]).Free;
FBreakPoints.Clear;;
end;
constructor TPSScriptDebugger.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FBreakPoints := TIFList.Create;
FExec.OnSourceLine := LineInfo;
FExec.OnIdleCall := IdleCall;
end;
destructor TPSScriptDebugger.Destroy;
var
i: Longint;
begin
for i := FBreakPoints.Count -1 downto 0 do
begin
TPSBreakPointInfo(FBreakPoints[i]).Free;
end;
FBreakPoints.Free;
inherited Destroy;
end;
function TPSScriptDebugger.GetBreakPoint(I: Integer): TPSBreakPointInfo;
begin
Result := FBreakPoints[i];
end;
function TPSScriptDebugger.GetBreakPointCount: Longint;
begin
Result := FBreakPoints.Count;
end;
function TPSScriptDebugger.GetVarContents(const Name: tbtstring): tbtstring;
var
i: Longint;
pv: PIFVariant;
s1, s: tbtstring;
begin
s := Uppercase(Name);
if pos('.', s) > 0 then
begin
s1 := copy(s,1,pos('.', s) -1);
delete(s,1,pos('.', Name));
end else begin
s1 := s;
s := '';
end;
pv := nil;
for i := 0 to Exec.CurrentProcVars.Count -1 do
begin
if Uppercase(Exec.CurrentProcVars[i]) = s1 then
begin
pv := Exec.GetProcVar(i);
break;
end;
end;
if pv = nil then
begin
for i := 0 to Exec.CurrentProcParams.Count -1 do
begin
if Uppercase(Exec.CurrentProcParams[i]) = s1 then
begin
pv := Exec.GetProcParam(i);
break;
end;
end;
end;
if pv = nil then
begin
for i := 0 to Exec.GlobalVarNames.Count -1 do
begin
if Uppercase(Exec.GlobalVarNames[i]) = s1 then
begin
pv := Exec.GetGlobalVar(i);
break;
end;
end;
end;
if pv = nil then
Result := RPS_UnknownIdentifier
else
Result := PSVariantToString(NewTPSVariantIFC(pv, False), s);
end;
function TPSScriptDebugger.HasBreakPoint(const Fn: tbtstring; Line: Integer): Boolean;
var
h, i: Longint;
bi: TPSBreakPointInfo;
begin
h := MakeHash(Fn);
for i := FBreakPoints.Count -1 downto 0 do
begin
bi := FBreakpoints[i];
if (h = bi.FileNameHash) and (Fn = bi.FileName) and (bi.Line = Line) then
begin
Result := true;
exit;
end;
end;
Result := False;
end;
procedure TPSScriptDebugger.Pause;
begin
if FExec.Status = isRunning then
FExec.Pause
else
raise Exception.Create(RPS_NotRunning);
end;
procedure TPSScriptDebugger.Resume;
begin
if FExec.Status = isRunning then
FExec.Run
else
raise Exception.Create(RPS_NotRunning);
end;
procedure TPSScriptDebugger.SetBreakPoint(const fn: tbtstring; Line: Integer);
var
i, h: Longint;
BI: TPSBreakPointInfo;
begin
h := MakeHash(fn);
for i := FBreakPoints.Count -1 downto 0 do
begin
bi := FBreakpoints[i];
if (h = bi.FileNameHash) and (fn = bi.FileName) and (bi.Line = Line) then
exit;
end;
bi := TPSBreakPointInfo.Create;
FBreakPoints.Add(bi);
bi.FileName := fn;
bi.Line := Line;
end;
procedure TPSScriptDebugger.SetMainFileName(const Value: tbtstring);
var
OldFn: tbtstring;
h1, h2,i: Longint;
bi: TPSBreakPointInfo;
begin
OldFn := FMainFileName;
inherited SetMainFileName(Value);
h1 := MakeHash(OldFn);
h2 := MakeHash(Value);
if OldFn <> Value then
begin
for i := FBreakPoints.Count -1 downto 0 do
begin
bi := FBreakPoints[i];
if (bi.FileNameHash = h1) and (bi.FileName = OldFn) then
begin
bi.FFileNameHash := h2;
bi.FFileName := Value;
end else if (bi.FileNameHash = h2) and (bi.FileName = Value) then
begin
// It's already the new filename, that can't be right, so remove all the breakpoints there
FBreakPoints.Delete(i);
bi.Free;
end;
end;
end;
end;
procedure TPSScriptDebugger.StepInto;
begin
if (FExec.Status = isRunning) or (FExec.Status = isLoaded) then
FExec.StepInto
else
raise Exception.Create(RPS_NoScript);
end;
procedure TPSScriptDebugger.StepOver;
begin
if (FExec.Status = isRunning) or (FExec.Status = isLoaded) then
FExec.StepOver
else
raise Exception.Create(RPS_NoScript);
end;
{ TPSPluginItem }
procedure TPSPluginItem.Assign(Source: TPersistent); //Birb
begin
if Source is TPSPluginItem then
plugin:=((source as TPSPluginItem).plugin)
else
inherited;
end;
function TPSPluginItem.GetDisplayName: string;
begin
if FPlugin <> nil then
Result := string(FPlugin.Name)
else
Result := '<nil>';
end;
procedure TPSPluginItem.SetPlugin(const Value: TPSPlugin);
begin
FPlugin := Value;
If Value <> nil then
Value.FreeNotification(TPSPlugins(Collection).FCompExec);
Changed(False);
end;
{ TPSPlugins }
constructor TPSPlugins.Create(CE: TPSScript);
begin
inherited Create(TPSPluginItem);
FCompExec := CE;
end;
function TPSPlugins.GetOwner: TPersistent;
begin
Result := FCompExec;
end;
{ TPSBreakPointInfo }
procedure TPSBreakPointInfo.SetFileName(const Value: tbtstring);
begin
FFileName := Value;
FFileNameHash := MakeHash(Value);
end;
{ TPSCustomPlugin }
procedure TPSCustomPlugin.CompileImport1(CompExec: TPSScript);
begin
IF @FOnCompileImport1 <> nil then
FOnCompileImport1(CompExec)
else
inherited;
end;
procedure TPSCustomPlugin.CompileImport2(CompExec: TPSScript);
begin
IF @FOnCompileImport2 <> nil then
FOnCompileImport2(CompExec)
else
inherited;
end;
procedure TPSCustomPlugin.CompOnUses(CompExec: TPSScript);
begin
IF @FOnCompOnUses <> nil then
FOnCompOnUses(CompExec)
else
inherited;
end;
procedure TPSCustomPlugin.ExecImport1(CompExec: TPSScript;
const ri: TPSRuntimeClassImporter);
begin
IF @FOnExecImport1 <> nil then
FOnExecImport1(CompExec, compExec.Exec, ri)
else
inherited;
end;
procedure TPSCustomPlugin.ExecImport2(CompExec: TPSScript;
const ri: TPSRuntimeClassImporter);
begin
IF @FOnExecImport2 <> nil then
FOnExecImport1(CompExec, compExec.Exec, ri)
else
inherited;
end;
procedure TPSCustomPlugin.ExecOnUses(CompExec: TPSScript);
begin
IF @FOnExecOnUses <> nil then
FOnExecOnUses(CompExec)
else
inherited;
end;
end.