3551 lines
89 KiB
ObjectPascal
3551 lines
89 KiB
ObjectPascal
|
|
{******************************************}
|
|
{ }
|
|
{ FastScript v1.9 }
|
|
{ Main module }
|
|
{ }
|
|
{ (c) 2003-2007 by Alexander Tzyganenko, }
|
|
{ Fast Reports Inc }
|
|
{ }
|
|
{******************************************}
|
|
|
|
//VCL uses section
|
|
{$IFNDEF FMX}
|
|
unit fs_iinterpreter;
|
|
|
|
interface
|
|
|
|
{$I fs.inc}
|
|
|
|
uses
|
|
SysUtils, Classes, fs_xml
|
|
{$IFDEF Delphi6}
|
|
, Variants
|
|
{$ENDIF}
|
|
|
|
, SyncObjs
|
|
{$IFDEF Delphi16}
|
|
, System.Types
|
|
{$ENDIF};
|
|
//FMX uses section
|
|
{$ELSE}
|
|
interface
|
|
|
|
{$I fs.inc}
|
|
|
|
uses
|
|
System.SysUtils, System.Classes, FMX.fs_xml
|
|
, System.Variants
|
|
, System.SyncObjs, System.Types;
|
|
{$ENDIF}
|
|
|
|
|
|
type
|
|
TfsStatement = class;
|
|
TfsDesignator = class;
|
|
TfsCustomVariable = class;
|
|
TfsClassVariable = class;
|
|
TfsProcVariable = class;
|
|
TfsMethodHelper = class;
|
|
TfsPropertyHelper = class;
|
|
TfsScript = class;
|
|
TfsDesignatorItem = class;
|
|
|
|
{ List of supported types. Actually all values are variants; types needed
|
|
only to know what kind of operations can be implemented to the variable }
|
|
|
|
TfsVarType = (fvtInt, fvtBool, fvtFloat, fvtChar, fvtString, fvtClass,
|
|
fvtArray, fvtVariant, fvtEnum, fvtConstructor, fvtInt64);
|
|
{$IFDEF DELPHI16}
|
|
frxInteger = NativeInt;
|
|
{$ELSE}
|
|
{$IFDEF FPC}
|
|
frxInteger = PtrInt;
|
|
{$ELSE}
|
|
frxInteger = Integer;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
|
|
TfsTypeRec = {$IFDEF Delphi12}{$ELSE}packed{$ENDIF} record
|
|
Typ: TfsVarType;
|
|
{$IFDEF Delphi12}
|
|
TypeName: String;
|
|
{$ELSE}
|
|
TypeName: String[64];
|
|
{$ENDIF}
|
|
end;
|
|
|
|
{ Events for get/set non-published property values and call methods }
|
|
|
|
TfsGetValueEvent = function(Instance: TObject; ClassType: TClass;
|
|
const PropName: String): Variant of object;
|
|
TfsSetValueEvent = procedure(Instance: TObject; ClassType: TClass;
|
|
const PropName: String; Value: Variant) of object;
|
|
|
|
TfsGetValueNewEvent = function(Instance: TObject; ClassType: TClass;
|
|
const PropName: String; Caler: TfsPropertyHelper): Variant of object;
|
|
TfsSetValueNewEvent = procedure(Instance: TObject; ClassType: TClass;
|
|
const PropName: String; Value: Variant; Caller: TfsPropertyHelper) of object;
|
|
|
|
TfsCallMethodNewEvent = function(Instance: TObject; ClassType: TClass;
|
|
const MethodName: String; Caller: TfsMethodHelper): Variant of object;
|
|
TfsCallMethodEvent = function(Instance: TObject; ClassType: TClass;
|
|
const MethodName: String; var Params: Variant): Variant of object;
|
|
TfsRunLineEvent = procedure(Sender: TfsScript;
|
|
const UnitName, SourcePos: String) of object;
|
|
TfsGetUnitEvent = procedure(Sender: TfsScript;
|
|
const UnitName: String; var UnitText: String) of object;
|
|
TfsGetVariableValueEvent = function(VarName: String;
|
|
VarTyp: TfsVarType; OldValue: Variant): Variant of object;
|
|
|
|
{ List of objects. Unlike TList, Destructor frees all objects in the list }
|
|
|
|
TfsItemList = class(TObject)
|
|
protected
|
|
FItems: TList;
|
|
protected
|
|
procedure Clear; virtual;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
procedure Add(Item: TObject);
|
|
function Count: Integer;
|
|
procedure Remove(Item: TObject);
|
|
end;
|
|
|
|
|
|
{ TfsScript represents the main script. It holds the list of local variables,
|
|
constants, procedures in the Items. Entry point is the Statement.
|
|
|
|
There is one global object fsGlobalUnit: TfsScript that holds all information
|
|
about external classes, global variables, methods and constants. To use
|
|
such globals, pass fsGlobalUnit to the TfsScript.Create.
|
|
If you want, you can add classes/variables/methods to the TfsScript - they
|
|
will be local for it and not visible in other programs.
|
|
|
|
To execute a program, compile it first by calling Compile method. If error
|
|
occurs, the ErrorMsg will contain the error message and ErrorPos will point
|
|
to an error position in the source text. For example:
|
|
|
|
if not Prg.Compile then
|
|
begin
|
|
ErrorLabel.Caption := Prg.ErrorMsg;
|
|
Memo1.SetFocus;
|
|
Memo1.Perform(EM_SETSEL, Prg.ErrorPos - 1, Prg.ErrorPos - 1);
|
|
Memo1.Perform(EM_SCROLLCARET, 0, 0);
|
|
end;
|
|
|
|
If no errors occured, call Execute method to execute the program }
|
|
|
|
{$i frxPlatformsAttribute.inc}
|
|
|
|
TfsScript = class(TComponent)
|
|
|
|
private
|
|
FAddedBy: TObject;
|
|
FBreakCalled: Boolean;
|
|
FContinueCalled: Boolean;
|
|
FExitCalled: Boolean;
|
|
FErrorMsg: String;
|
|
FErrorPos: String;
|
|
FErrorUnit: String;
|
|
FExtendedCharset: Boolean;
|
|
FItems: TStringList;
|
|
FIsRunning: Boolean;
|
|
FLines: TStrings;
|
|
FMacros: TStrings;
|
|
FMainProg: Boolean;
|
|
FOnGetILUnit: TfsGetUnitEvent;
|
|
FOnGetUnit: TfsGetUnitEvent;
|
|
FOnRunLine: TfsRunLineEvent;
|
|
FOnGetVarValue: TfsGetVariableValueEvent;
|
|
FParent: TfsScript;
|
|
FProgRunning: TfsScript;
|
|
FRTTIAdded: Boolean;
|
|
FStatement: TfsStatement;
|
|
FSyntaxType: String;
|
|
FTerminated: Boolean;
|
|
FUnitLines: TStringList;
|
|
FIncludePath: TStrings;
|
|
FUseClassLateBinding: Boolean;
|
|
FEvaluteRiseError: Boolean;
|
|
FClearLocalVars: Boolean;
|
|
FLastSourcePos : String;
|
|
FProgName : String;
|
|
function GetItem(Index: Integer): TfsCustomVariable;
|
|
procedure RunLine(const UnitName, Index: String);
|
|
function GetVariables(Index: String): Variant;
|
|
procedure SetVariables(Index: String; const Value: Variant);
|
|
procedure SetLines(const Value: TStrings);
|
|
function GetProgName: String;
|
|
procedure SetProgName(const Value: String);
|
|
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure Add(const Name: String; Item: TObject);
|
|
procedure AddCodeLine(const UnitName, APos: String);
|
|
procedure AddRTTI;
|
|
procedure Remove(Item: TObject);
|
|
procedure RemoveItems(Owner: TObject);
|
|
procedure Clear;
|
|
procedure ClearItems(Owner: TObject);
|
|
procedure ClearRTTI;
|
|
function Count: Integer;
|
|
|
|
{ Adds a class. Example:
|
|
with AddClass(TComponent, 'TPersistent') do
|
|
begin
|
|
... add properties and methods ...
|
|
end }
|
|
function AddClass(AClass: TClass; const Ancestor: String): TfsClassVariable; dynamic;
|
|
{ Adds a constant. Example:
|
|
AddConst('pi', 'Double', 3.14159) }
|
|
procedure AddConst(const Name, Typ: String; const Value: Variant); dynamic;
|
|
{ Adds an enumeration constant. Example:
|
|
AddEnum('TFontPitch', 'fpDefault, fpFixed, fpVariable')
|
|
all constants gets type fvtEnum and values 0,1,2,3.. }
|
|
procedure AddEnum(const Typ, Names: String); dynamic;
|
|
{ Adds an set constant. Example:
|
|
AddEnumSet('TFontStyles', 'fsBold, fsItalic, fsUnderline')
|
|
all constants gets type fvtEnum and values 1,2,4,8,.. }
|
|
procedure AddEnumSet(const Typ, Names: String); dynamic;
|
|
{ Adds a form or datamodule with all its child components }
|
|
procedure AddComponent(Form: TComponent); dynamic;
|
|
procedure AddForm(Form: TComponent); dynamic;
|
|
{ Adds a method. Syntax is the same as for TfsClassVariable.AddMethod }
|
|
procedure AddMethod(const Syntax: String; CallEvent: TfsCallMethodNewEvent;
|
|
const Category: String = ''; const Description: String = ''); overload; dynamic;
|
|
procedure AddMethod(const Syntax: String; CallEvent: TfsCallMethodEvent;
|
|
const Category: String = ''; const Description: String = ''); overload; dynamic;
|
|
{ Adds an external object. Example:
|
|
AddObject('Memo1', Memo1) }
|
|
procedure AddObject(const Name: String; Obj: TObject); dynamic;
|
|
{ Adds a variable. Example:
|
|
AddVariable('n', 'Variant', 0) }
|
|
procedure AddVariable(const Name, Typ: String; const Value: Variant); dynamic;
|
|
{ Adds a type. Example:
|
|
AddType('TDateTime', fvtFloat) }
|
|
procedure AddType(const TypeName: String; ParentType: TfsVarType); dynamic;
|
|
{ Calls internal procedure or function. Example:
|
|
val := CallFunction('ScriptFunc1', VarArrayOf([2003, 3])) }
|
|
function CallFunction(const Name: String; const Params: Variant; sGlobal: Boolean = false): Variant;
|
|
function CallFunction1(const Name: String; var Params: Variant; sGlobal: Boolean = false): Variant;
|
|
function CallFunction2(const Func: TfsProcVariable; const Params: Variant): Variant;
|
|
|
|
{ Compiles the source code. Example:
|
|
Lines.Text := 'begin i := 0 end.';
|
|
SyntaxType := 'PascalScript';
|
|
if Compile then ... }
|
|
function Compile: Boolean;
|
|
{ Executes compiled code }
|
|
procedure Execute;
|
|
{ Same as if Compile then Execute. Returns False if compile failed }
|
|
function Run: Boolean;
|
|
{ terminates the script }
|
|
procedure Terminate;
|
|
{ Evaluates an expression (useful for debugging purposes). Example:
|
|
val := Evaluate('i+1'); }
|
|
function Evaluate(const Expression: String): Variant;
|
|
{ checks whether is the line is executable }
|
|
function IsExecutableLine(LineN: Integer; const UnitName: String = ''): Boolean;
|
|
|
|
{ Generates intermediate language. You can save it and compile later
|
|
by SetILCode method }
|
|
function GetILCode(Stream: TStream): Boolean;
|
|
{ Compiles intermediate language }
|
|
function SetILCode(Stream: TStream): Boolean;
|
|
|
|
function Find(const Name: String): TfsCustomVariable;
|
|
function FindClass(const Name: String): TfsClassVariable;
|
|
function FindLocal(const Name: String): TfsCustomVariable;
|
|
|
|
property AddedBy: TObject read FAddedBy write FAddedBy;
|
|
property ClearLocalVars: Boolean read FClearLocalVars write FClearLocalVars;
|
|
property ErrorMsg: String read FErrorMsg write FErrorMsg;
|
|
property ErrorPos: String read FErrorPos write FErrorPos;
|
|
property ErrorUnit: String read FErrorUnit write FErrorUnit;
|
|
property ExtendedCharset: Boolean read FExtendedCharset write FExtendedCharset;
|
|
property Items[Index: Integer]: TfsCustomVariable read GetItem;
|
|
property IsRunning: Boolean read FIsRunning;
|
|
property Macros: TStrings read FMacros;
|
|
property MainProg: Boolean read FMainProg write FMainProg;
|
|
property Parent: TfsScript read FParent write FParent;
|
|
property ProgRunning: TfsScript read FProgRunning;
|
|
property ProgName: String read GetProgName write SetProgName;
|
|
property Statement: TfsStatement read FStatement;
|
|
property Variables[Index: String]: Variant read GetVariables write SetVariables;
|
|
property IncludePath: TStrings read FIncludePath;
|
|
property UseClassLateBinding: Boolean read FUseClassLateBinding write FUseClassLateBinding;
|
|
property EvaluteRiseError: Boolean read FEvaluteRiseError;
|
|
published
|
|
{ the source code }
|
|
property Lines: TStrings read FLines write SetLines;
|
|
{ the language name }
|
|
property SyntaxType: String read FSyntaxType write FSyntaxType;
|
|
property OnGetILUnit: TfsGetUnitEvent read FOnGetILUnit write FOnGetILUnit;
|
|
property OnGetUnit: TfsGetUnitEvent read FOnGetUnit write FOnGetUnit;
|
|
property OnRunLine: TfsRunLineEvent read FOnRunLine write FOnRunLine;
|
|
property OnGetVarValue: TfsGetVariableValueEvent read FOnGetVarValue write FOnGetVarValue;
|
|
end;
|
|
|
|
|
|
TfsCustomExpression = class;
|
|
TfsSetExpression = class;
|
|
|
|
{ Statements }
|
|
|
|
TfsStatement = class(TfsItemList)
|
|
private
|
|
FProgram: TfsScript;
|
|
FSourcePos: String;
|
|
FUnitName: String;
|
|
function GetItem(Index: Integer): TfsStatement;
|
|
procedure RunLine;
|
|
public
|
|
constructor Create(AProgram: TfsScript; const UnitName, SourcePos: String); virtual;
|
|
procedure Execute; virtual;
|
|
property Items[Index: Integer]: TfsStatement read GetItem;
|
|
end;
|
|
|
|
TfsAssignmentStmt = class(TfsStatement)
|
|
private
|
|
FDesignator: TfsDesignator;
|
|
FExpression: TfsCustomExpression;
|
|
FVar: TfsCustomVariable;
|
|
FExpr: TfsCustomVariable;
|
|
public
|
|
destructor Destroy; override;
|
|
procedure Execute; override;
|
|
procedure Optimize;
|
|
property Designator: TfsDesignator read FDesignator write FDesignator;
|
|
property Expression: TfsCustomExpression read FExpression write FExpression;
|
|
end;
|
|
|
|
TfsAssignPlusStmt = class(TfsAssignmentStmt)
|
|
public
|
|
procedure Execute; override;
|
|
end;
|
|
|
|
TfsAssignMinusStmt = class(TfsAssignmentStmt)
|
|
public
|
|
procedure Execute; override;
|
|
end;
|
|
|
|
TfsAssignMulStmt = class(TfsAssignmentStmt)
|
|
public
|
|
procedure Execute; override;
|
|
end;
|
|
|
|
TfsAssignDivStmt = class(TfsAssignmentStmt)
|
|
public
|
|
procedure Execute; override;
|
|
end;
|
|
|
|
TfsCallStmt = class(TfsStatement)
|
|
private
|
|
FDesignator: TfsDesignator;
|
|
FModificator: String;
|
|
public
|
|
destructor Destroy; override;
|
|
procedure Execute; override;
|
|
property Designator: TfsDesignator read FDesignator write FDesignator;
|
|
property Modificator: String read FModificator write FModificator;
|
|
end;
|
|
|
|
TfsIfStmt = class(TfsStatement)
|
|
private
|
|
FCondition: TfsCustomExpression;
|
|
FElseStmt: TfsStatement;
|
|
public
|
|
constructor Create(AProgram: TfsScript; const UnitName, SourcePos: String); override;
|
|
destructor Destroy; override;
|
|
procedure Execute; override;
|
|
property Condition: TfsCustomExpression read FCondition write FCondition;
|
|
property ElseStmt: TfsStatement read FElseStmt write FElseStmt;
|
|
end;
|
|
|
|
TfsCaseSelector = class(TfsStatement)
|
|
private
|
|
FSetExpression: TfsSetExpression;
|
|
public
|
|
destructor Destroy; override;
|
|
function Check(const Value: Variant): Boolean;
|
|
property SetExpression: TfsSetExpression read FSetExpression write FSetExpression;
|
|
end;
|
|
|
|
TfsCaseStmt = class(TfsStatement)
|
|
private
|
|
FCondition: TfsCustomExpression;
|
|
FElseStmt: TfsStatement;
|
|
public
|
|
constructor Create(AProgram: TfsScript; const UnitName, SourcePos: String); override;
|
|
destructor Destroy; override;
|
|
procedure Execute; override;
|
|
property Condition: TfsCustomExpression read FCondition write FCondition;
|
|
property ElseStmt: TfsStatement read FElseStmt write FElseStmt;
|
|
end;
|
|
|
|
TfsRepeatStmt = class(TfsStatement)
|
|
private
|
|
FCondition: TfsCustomExpression;
|
|
FInverseCondition: Boolean;
|
|
public
|
|
destructor Destroy; override;
|
|
procedure Execute; override;
|
|
property Condition: TfsCustomExpression read FCondition write FCondition;
|
|
property InverseCondition: Boolean read FInverseCondition write FInverseCondition;
|
|
end;
|
|
|
|
TfsWhileStmt = class(TfsStatement)
|
|
private
|
|
FCondition: TfsCustomExpression;
|
|
public
|
|
destructor Destroy; override;
|
|
procedure Execute; override;
|
|
property Condition: TfsCustomExpression read FCondition write FCondition;
|
|
end;
|
|
|
|
TfsForStmt = class(TfsStatement)
|
|
private
|
|
FBeginValue: TfsCustomExpression;
|
|
FDown: Boolean;
|
|
FEndValue: TfsCustomExpression;
|
|
FVariable: TfsCustomVariable;
|
|
public
|
|
destructor Destroy; override;
|
|
procedure Execute; override;
|
|
property BeginValue: TfsCustomExpression read FBeginValue write FBeginValue;
|
|
property Down: Boolean read FDown write FDown;
|
|
property EndValue: TfsCustomExpression read FEndValue write FEndValue;
|
|
property Variable: TfsCustomVariable read FVariable write FVariable;
|
|
end;
|
|
|
|
TfsVbForStmt = class(TfsStatement)
|
|
private
|
|
FBeginValue: TfsCustomExpression;
|
|
FEndValue: TfsCustomExpression;
|
|
FStep: TfsCustomExpression;
|
|
FVariable: TfsCustomVariable;
|
|
public
|
|
destructor Destroy; override;
|
|
procedure Execute; override;
|
|
property BeginValue: TfsCustomExpression read FBeginValue write FBeginValue;
|
|
property EndValue: TfsCustomExpression read FEndValue write FEndValue;
|
|
property Step: TfsCustomExpression read FStep write FStep;
|
|
property Variable: TfsCustomVariable read FVariable write FVariable;
|
|
end;
|
|
|
|
TfsCppForStmt = class(TfsStatement)
|
|
private
|
|
FFirstStmt: TfsStatement;
|
|
FExpression: TfsCustomExpression;
|
|
FSecondStmt: TfsStatement;
|
|
public
|
|
constructor Create(AProgram: TfsScript; const UnitName, SourcePos: String); override;
|
|
destructor Destroy; override;
|
|
procedure Execute; override;
|
|
property FirstStmt: TfsStatement read FFirstStmt write FFirstStmt;
|
|
property Expression: TfsCustomExpression read FExpression write FExpression;
|
|
property SecondStmt: TfsStatement read FSecondStmt write FSecondStmt;
|
|
end;
|
|
|
|
TfsTryStmt = class(TfsStatement)
|
|
private
|
|
FIsExcept: Boolean;
|
|
FExceptStmt: TfsStatement;
|
|
public
|
|
constructor Create(AProgram: TfsScript; const UnitName, SourcePos: String); override;
|
|
destructor Destroy; override;
|
|
procedure Execute; override;
|
|
property IsExcept: Boolean read FIsExcept write FIsExcept;
|
|
property ExceptStmt: TfsStatement read FExceptStmt write FExceptStmt;
|
|
end;
|
|
|
|
TfsBreakStmt = class(TfsStatement)
|
|
public
|
|
procedure Execute; override;
|
|
end;
|
|
|
|
TfsContinueStmt = class(TfsStatement)
|
|
public
|
|
procedure Execute; override;
|
|
end;
|
|
|
|
TfsExitStmt = class(TfsStatement)
|
|
public
|
|
procedure Execute; override;
|
|
end;
|
|
|
|
TfsWithStmt = class(TfsStatement)
|
|
private
|
|
FDesignator: TfsDesignator;
|
|
FVariable: TfsCustomVariable;
|
|
public
|
|
destructor Destroy; override;
|
|
procedure Execute; override;
|
|
property Designator: TfsDesignator read FDesignator write FDesignator;
|
|
property Variable: TfsCustomVariable read FVariable write FVariable;
|
|
end;
|
|
|
|
{ TfsCustomVariable is the generic class for variables, constants, arrays,
|
|
properties, methods and procedures/functions }
|
|
|
|
TfsParamItem = class;
|
|
|
|
TfsCustomVariable = class(TfsItemList)
|
|
private
|
|
FAddedBy: TObject;
|
|
FIsMacro: Boolean;
|
|
FIsReadOnly: Boolean;
|
|
FName: String;
|
|
FNeedResult: Boolean;
|
|
FRefItem: TfsCustomVariable;
|
|
FSourcePos: String;
|
|
FSourceUnit: String;
|
|
FTyp: TfsVarType;
|
|
FTypeName: String;
|
|
FUppercaseName: String;
|
|
FValue: Variant;
|
|
FOnGetVarValue: TfsGetVariableValueEvent;
|
|
function GetParam(Index: Integer): TfsParamItem;
|
|
function GetPValue: PVariant;
|
|
protected
|
|
procedure SetValue(const Value: Variant); virtual;
|
|
function GetValue: Variant; virtual;
|
|
public
|
|
constructor Create(const AName: String; ATyp: TfsVarType;
|
|
const ATypeName: String);
|
|
function GetFullTypeName: String;
|
|
function GetNumberOfRequiredParams: Integer;
|
|
|
|
property AddedBy: TObject read FAddedBy write FAddedBy;
|
|
property IsMacro: Boolean read FIsMacro write FIsMacro;
|
|
property IsReadOnly: Boolean read FIsReadOnly write FIsReadOnly;
|
|
property Name: String read FName;
|
|
property NeedResult: Boolean read FNeedResult write FNeedResult;
|
|
property Params[Index: Integer]: TfsParamItem read GetParam; default;
|
|
property PValue: PVariant read GetPValue;
|
|
property RefItem: TfsCustomVariable read FRefItem write FRefItem;
|
|
property SourcePos: String read FSourcePos write FSourcePos;
|
|
property SourceUnit: String read FSourceUnit write FSourceUnit;
|
|
property Typ: TfsVarType read FTyp write FTyp;
|
|
property TypeName: String read FTypeName write FTypeName;
|
|
property Value: Variant read GetValue write SetValue;
|
|
property OnGetVarValue: TfsGetVariableValueEvent read FOnGetVarValue write FOnGetVarValue;
|
|
end;
|
|
|
|
{ TfsVariable represents constant or variable }
|
|
|
|
TfsVariable = class(TfsCustomVariable)
|
|
protected
|
|
procedure SetValue(const Value: Variant); override;
|
|
function GetValue: Variant; override;
|
|
end;
|
|
|
|
TfsTypeVariable = class(TfsCustomVariable)
|
|
end;
|
|
|
|
TfsStringVariable = class(TfsVariable)
|
|
private
|
|
FStr: String;
|
|
protected
|
|
procedure SetValue(const Value: Variant); override;
|
|
function GetValue: Variant; override;
|
|
end;
|
|
|
|
{ TfsParamItem describes one parameter of procedure/function/method call }
|
|
|
|
TfsParamItem = class(TfsCustomVariable)
|
|
private
|
|
FDefValue: Variant;
|
|
FIsOptional: Boolean;
|
|
FIsVarParam: Boolean;
|
|
public
|
|
constructor Create(const AName: String; ATyp: TfsVarType;
|
|
const ATypeName: String; AIsOptional, AIsVarParam: Boolean);
|
|
property DefValue: Variant read FDefValue write FDefValue;
|
|
property IsOptional: Boolean read FIsOptional;
|
|
property IsVarParam: Boolean read FIsVarParam;
|
|
end;
|
|
|
|
{ TfsProcVariable is a local internal procedure/function. Formal parameters
|
|
are in Params, and statement to execute is in Prog: TfsScript }
|
|
|
|
TfsLocalVariablesHelper = class(TObject)
|
|
protected
|
|
FValue: Variant;
|
|
FVariableLink :TfsCustomVariable;
|
|
end;
|
|
|
|
|
|
TfsProcVariable = class(TfsCustomVariable)
|
|
private
|
|
FExecuting: Boolean;
|
|
FIsFunc: Boolean;
|
|
FProgram: TfsScript;
|
|
FVarsStack: TList;
|
|
protected
|
|
function GetValue: Variant; override;
|
|
public
|
|
constructor Create(const AName: String; ATyp: TfsVarType;
|
|
const ATypeName: String; AParent: TfsScript; AIsFunc: Boolean = True);
|
|
destructor Destroy; override;
|
|
function SaveLocalVariables: Integer;
|
|
procedure RestoreLocalVariables(StackIndex: Integer; bSkipVarParams: Boolean = False; dItem: TfsDesignatorItem = nil);
|
|
property Executing: Boolean read FExecuting;
|
|
property IsFunc: Boolean read FIsFunc;
|
|
property Prog: TfsScript read FProgram;
|
|
end;
|
|
|
|
TfsCustomExpression = class(TfsCustomVariable)
|
|
end;
|
|
|
|
{ TfsCustomHelper is the generic class for the "helpers". Helper is
|
|
a object that takes the data from the parent object and performs some
|
|
actions. Helpers needed for properties, methods and arrays }
|
|
|
|
TfsCustomHelper = class(TfsCustomVariable)
|
|
private
|
|
FParentRef: TfsCustomVariable;
|
|
FParentValue: Variant;
|
|
FProgram: TfsScript;
|
|
public
|
|
property ParentRef: TfsCustomVariable read FParentRef write FParentRef;
|
|
|
|
property ParentValue: Variant read FParentValue write FParentValue;
|
|
|
|
property Prog: TfsScript read FProgram write FProgram;
|
|
end;
|
|
|
|
{ TfsArrayHelper performs access to array elements }
|
|
|
|
TfsArrayHelper = class(TfsCustomHelper)
|
|
protected
|
|
procedure SetValue(const Value: Variant); override;
|
|
function GetValue: Variant; override;
|
|
public
|
|
constructor Create(const AName: String; DimCount: Integer; Typ: TfsVarType;
|
|
const TypeName: String);
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
{ TfsStringHelper performs access to string elements }
|
|
|
|
TfsStringHelper = class(TfsCustomHelper)
|
|
protected
|
|
procedure SetValue(const Value: Variant); override;
|
|
function GetValue: Variant; override;
|
|
public
|
|
constructor Create;
|
|
end;
|
|
|
|
{ TfsPropertyHelper gets/sets the property value. Object instance is
|
|
stored as Integer in the ParentValue property }
|
|
|
|
TfsPropertyHelper = class(TfsCustomHelper)
|
|
private
|
|
FClassRef: TClass;
|
|
FIsPublished: Boolean;
|
|
FOnGetValue: TfsGetValueEvent;
|
|
FOnSetValue: TfsSetValueEvent;
|
|
FOnGetValueNew: TfsGetValueNewEvent;
|
|
FOnSetValueNew: TfsSetValueNewEvent;
|
|
protected
|
|
procedure SetValue(const Value: Variant); override;
|
|
function GetValue: Variant; override;
|
|
public
|
|
property IsPublished: Boolean read FIsPublished;
|
|
property OnGetValue: TfsGetValueEvent read FOnGetValue write FOnGetValue;
|
|
property OnSetValue: TfsSetValueEvent read FOnSetValue write FOnSetValue;
|
|
property OnGetValueNew: TfsGetValueNewEvent read FOnGetValueNew write FOnGetValueNew;
|
|
property OnSetValueNew: TfsSetValueNewEvent read FOnSetValueNew write FOnSetValueNew;
|
|
end;
|
|
|
|
{ TfsMethodHelper gets/sets the method value. Object instance is
|
|
stored as Integer in the ParentValue property. SetValue is called
|
|
if the method represents the indexes property. }
|
|
|
|
TfsMethodHelper = class(TfsCustomHelper)
|
|
private
|
|
FCategory: String;
|
|
FClassRef: TClass;
|
|
FDescription: String;
|
|
FIndexMethod: Boolean;
|
|
FOnCall: TfsCallMethodEvent;
|
|
FOnCallNew: TfsCallMethodNewEvent;
|
|
FSetValue: Variant;
|
|
FSyntax: String;
|
|
FVarArray: Variant;
|
|
function GetVParam(Index: Integer): Variant;
|
|
procedure SetVParam(Index: Integer; const Value: Variant);
|
|
protected
|
|
procedure SetValue(const Value: Variant); override;
|
|
function GetValue: Variant; override;
|
|
public
|
|
constructor Create(const Syntax: String; Script: TfsScript);
|
|
destructor Destroy; override;
|
|
|
|
property Category: String read FCategory write FCategory;
|
|
property Description: String read FDescription write FDescription;
|
|
property IndexMethod: Boolean read FIndexMethod;
|
|
property Params[Index: Integer]: Variant read GetVParam write SetVParam; default;
|
|
property Syntax: String read FSyntax;
|
|
property OnCall: TfsCallMethodEvent read FOnCall write FOnCall;
|
|
property OnCallNew: TfsCallMethodNewEvent read FOnCallNew write FOnCallNew;
|
|
end;
|
|
|
|
{ TfsComponentHelper gets the component inside an owner, e.g. Form1.Button1 }
|
|
|
|
TfsComponentHelper = class(TfsCustomHelper)
|
|
protected
|
|
function GetValue: Variant; override;
|
|
procedure SetValue(const Value: Variant); override;
|
|
public
|
|
constructor Create(const Name: String; const ClassName: String);
|
|
end;
|
|
|
|
{ Event helper maintains VCL events }
|
|
|
|
TfsCustomEvent = class(TObject)
|
|
private
|
|
FHandler: TfsProcVariable;
|
|
FInstance: TObject;
|
|
protected
|
|
procedure CallHandler(Params: array of const);
|
|
public
|
|
constructor Create(AObject: TObject; AHandler: TfsProcVariable); virtual;
|
|
function GetMethod: Pointer; virtual; abstract;
|
|
property Handler: TfsProcVariable read FHandler;
|
|
property Instance: TObject read FInstance;
|
|
end;
|
|
|
|
TfsEventClass = class of TfsCustomEvent;
|
|
|
|
TfsEventHelper = class(TfsCustomHelper)
|
|
private
|
|
FClassRef: TClass;
|
|
FEvent: TfsEventClass;
|
|
protected
|
|
procedure SetValue(const Value: Variant); override;
|
|
function GetValue: Variant; override;
|
|
public
|
|
constructor Create(const Name: String; AEvent: TfsEventClass);
|
|
end;
|
|
|
|
{ TfsClassVariable holds information about external class. Call to
|
|
AddXXX methods adds properties and methods items to the items list }
|
|
|
|
TfsClassVariable = class(TfsCustomVariable)
|
|
private
|
|
FAncestor: String;
|
|
FClassRef: TClass;
|
|
FDefProperty: TfsCustomHelper;
|
|
FMembers: TfsItemList;
|
|
FProgram: TfsScript;
|
|
procedure AddPublishedProperties(AClass: TClass);
|
|
function GetMembers(Index: Integer): TfsCustomHelper;
|
|
function GetMembersCount: Integer;
|
|
protected
|
|
function GetValue: Variant; override;
|
|
public
|
|
constructor Create(AClass: TClass; const Ancestor: String);
|
|
destructor Destroy; override;
|
|
|
|
{ Adds a contructor. Example:
|
|
AddConstructor('constructor Create(AOwner: TComponent)', MyCallEvent) }
|
|
procedure AddConstructor(Syntax: String; CallEvent: TfsCallMethodNewEvent); overload;
|
|
procedure AddConstructor(Syntax: String; CallEvent: TfsCallMethodEvent); overload;
|
|
function AddComponent(c: TComponent): TfsComponentHelper ;
|
|
{ Adds a property. Example:
|
|
AddProperty('Font', 'TFont', MyGetEvent, MySetEvent) }
|
|
procedure AddProperty(const Name, Typ: String;
|
|
GetEvent: TfsGetValueEvent; SetEvent: TfsSetValueEvent = nil);
|
|
procedure AddPropertyEx(const Name, Typ: String;
|
|
GetEvent: TfsGetValueNewEvent; SetEvent: TfsSetValueNewEvent = nil);
|
|
{ Adds a default property. Example:
|
|
AddDefaultProperty('Cell', 'Integer,Integer', 'String', MyCallEvent)
|
|
will describe real property Cell[Index1, Index2: Integer]: String
|
|
Note: in the CallEvent you'll get the MethodName parameter
|
|
'CELL.GET' and 'CELL.SET', not 'CELL' }
|
|
procedure AddDefaultProperty(const Name, Params, Typ: String;
|
|
CallEvent: TfsCallMethodNewEvent; AReadOnly: Boolean = False); overload;
|
|
procedure AddDefaultProperty(const Name, Params, Typ: String;
|
|
CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False); overload;
|
|
{ Adds an indexed property. Example and behavior are the same as
|
|
for AddDefaultProperty }
|
|
procedure AddIndexProperty(const Name, Params, Typ: String;
|
|
CallEvent: TfsCallMethodNewEvent; AReadOnly: Boolean = False); overload;
|
|
procedure AddIndexProperty(const Name, Params, Typ: String;
|
|
CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False); overload;
|
|
{ Adds a method. Example:
|
|
AddMethod('function IsVisible: Boolean', MyCallEvent) }
|
|
procedure AddMethod(const Syntax: String; CallEvent: TfsCallMethodNewEvent); overload;
|
|
procedure AddMethod(const Syntax: String; CallEvent: TfsCallMethodEvent); overload;
|
|
{ Adds an event. Example:
|
|
AddEvent('OnClick', TfsNotifyEvent) }
|
|
procedure AddEvent(const Name: String; AEvent: TfsEventClass);
|
|
function Find(const Name: String; IncludeComponentHelper: Boolean = True): TfsCustomHelper;
|
|
|
|
property Ancestor: String read FAncestor;
|
|
property ClassRef: TClass read FClassRef;
|
|
property DefProperty: TfsCustomHelper read FDefProperty;
|
|
property Members[Index: Integer]: TfsCustomHelper read GetMembers;
|
|
property MembersCount: Integer read GetMembersCount;
|
|
end;
|
|
|
|
{ TfsDesignator holds the parts of function/procedure/variable/method/property
|
|
calls. Items are of type TfsDesignatorItem.
|
|
For example, Table1.FieldByName('N').AsString[1] will be represented as
|
|
items[0]: name 'Table1', no params
|
|
items[1]: name 'FieldByName', 1 param: 'N'
|
|
items[2]: name 'AsString', no params
|
|
items[3]: name '[', 1 param: '1'
|
|
Call to Value calculates and returns the designator value }
|
|
|
|
TfsDesignatorKind = (dkOther, dkVariable, dkStringArray, dkArray);
|
|
|
|
TfsDesignatorItem = class(TfsItemList)
|
|
private
|
|
FFlag: Boolean; { needed for index methods }
|
|
FRef: TfsCustomVariable;
|
|
FSourcePos: String;
|
|
function GetItem(Index: Integer): TfsCustomExpression;
|
|
public
|
|
property Items[Index: Integer]: TfsCustomExpression read GetItem; default;
|
|
property Flag: Boolean read FFlag write FFlag;
|
|
property Ref: TfsCustomVariable read FRef write FRef;
|
|
property SourcePos: String read FSourcePos write FSourcePos;
|
|
end;
|
|
|
|
TfsDesignator = class(TfsCustomVariable)
|
|
private
|
|
FKind: TfsDesignatorKind;
|
|
FMainProg: TfsScript;
|
|
FProgram: TfsScript;
|
|
FRef1: TfsCustomVariable;
|
|
FRef2: TfsDesignatorItem;
|
|
FLateBindingXmlSource: TfsXMLItem;
|
|
procedure CheckLateBinding;
|
|
function DoCalc(const AValue: Variant; Flag: Boolean): Variant;
|
|
function GetItem(Index: Integer): TfsDesignatorItem;
|
|
protected
|
|
function GetValue: Variant; override;
|
|
procedure SetValue(const Value: Variant); override;
|
|
public
|
|
constructor Create(AProgram: TfsScript);
|
|
destructor Destroy; override;
|
|
procedure Borrow(ADesignator: TfsDesignator);
|
|
procedure Finalize;
|
|
property Items[Index: Integer]: TfsDesignatorItem read GetItem; default;
|
|
property Kind: TfsDesignatorKind read FKind;
|
|
property LateBindingXmlSource: TfsXMLItem read FLateBindingXmlSource
|
|
write FLateBindingXmlSource;
|
|
end;
|
|
|
|
TfsVariableDesignator = class(TfsDesignator)
|
|
protected
|
|
function GetValue: Variant; override;
|
|
procedure SetValue(const Value: Variant); override;
|
|
end;
|
|
|
|
TfsStringDesignator = class(TfsDesignator)
|
|
protected
|
|
function GetValue: Variant; override;
|
|
procedure SetValue(const Value: Variant); override;
|
|
end;
|
|
|
|
TfsArrayDesignator = class(TfsDesignator)
|
|
protected
|
|
function GetValue: Variant; override;
|
|
procedure SetValue(const Value: Variant); override;
|
|
end;
|
|
|
|
{ TfsSetExpression represents a set of values like ['_', '0'..'9'] }
|
|
|
|
TfsSetExpression = class(TfsCustomVariable)
|
|
private
|
|
function GetItem(Index: Integer): TfsCustomExpression;
|
|
protected
|
|
function GetValue: Variant; override;
|
|
public
|
|
function Check(const Value: Variant): Boolean;
|
|
property Items[Index: Integer]: TfsCustomExpression read GetItem;
|
|
end;
|
|
|
|
TfsRTTIModule = class(TObject)
|
|
private
|
|
FScript: TfsScript;
|
|
public
|
|
constructor Create(AScript: TfsScript); virtual;
|
|
property Script: TfsScript read FScript;
|
|
end;
|
|
|
|
|
|
function fsGlobalUnit: TfsScript;
|
|
function fsIsGlobalUnitExist: Boolean;
|
|
function fsRTTIModules: TList;
|
|
|
|
|
|
implementation
|
|
//VCL uses section
|
|
{$IFNDEF FMX}
|
|
uses
|
|
TypInfo, fs_isysrtti, fs_iexpression, fs_iparser, fs_iilparser,
|
|
fs_itools, fs_iconst
|
|
{$IFDEF DELPHI16}
|
|
, Vcl.Controls
|
|
{$ENDIF}
|
|
{$IFDEF CLX}
|
|
, QForms, QDialogs, Types
|
|
{$ELSE}
|
|
{$IFDEF FPC}
|
|
{$IFDEF NOFORMS}
|
|
// nothing
|
|
{$ELSE}
|
|
, Forms, Dialogs
|
|
{$ENDIF}
|
|
{$ELSE}
|
|
, Windows
|
|
{$IFDEF NOFORMS}
|
|
, Messages
|
|
{$ELSE}
|
|
, Forms, Dialogs
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
{$ENDIF};
|
|
//FMX uses section
|
|
{$ELSE}
|
|
uses
|
|
System.TypInfo, FMX.fs_isysrtti, FMX.fs_iexpression, FMX.fs_iparser, FMX.fs_iilparser,
|
|
FMX.fs_itools, FMX.fs_iconst, FMX.Types
|
|
{$IFDEF NOFORMS}
|
|
, Windows, Messages
|
|
{$ELSE}
|
|
, FMX.Forms, FMX.Dialogs
|
|
{$ENDIF};
|
|
{$ENDIF}
|
|
|
|
var
|
|
FGlobalUnit: TfsScript = nil;
|
|
FGlobalUnitDestroyed: Boolean = False;
|
|
FRTTIModules: TList = nil;
|
|
FRTTIModulesDestroyed: Boolean = False;
|
|
|
|
|
|
{ TfsItemsList }
|
|
|
|
constructor TfsItemList.Create;
|
|
begin
|
|
FItems := TList.Create;
|
|
end;
|
|
|
|
destructor TfsItemList.Destroy;
|
|
begin
|
|
Clear;
|
|
FItems.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TfsItemList.Clear;
|
|
begin
|
|
while FItems.Count > 0 do
|
|
begin
|
|
TObject(FItems[0]).Free;
|
|
FItems.Delete(0);
|
|
end;
|
|
end;
|
|
|
|
function TfsItemList.Count: Integer;
|
|
begin
|
|
Result := FItems.Count;
|
|
end;
|
|
|
|
procedure TfsItemList.Add(Item: TObject);
|
|
begin
|
|
FItems.Add(Item);
|
|
end;
|
|
|
|
procedure TfsItemList.Remove(Item: TObject);
|
|
begin
|
|
FItems.Remove(Item);
|
|
end;
|
|
|
|
|
|
{ TfsCustomVariable }
|
|
|
|
constructor TfsCustomVariable.Create(const AName: String; ATyp: TfsVarType;
|
|
const ATypeName: String);
|
|
begin
|
|
inherited Create;
|
|
FName := AName;
|
|
FTyp := ATyp;
|
|
FTypeName := ATypeName;
|
|
FValue := Null;
|
|
FNeedResult := True;
|
|
FUppercaseName := AnsiUppercase(FName);
|
|
end;
|
|
|
|
function TfsCustomVariable.GetValue: Variant;
|
|
begin
|
|
Result := FValue;
|
|
end;
|
|
|
|
procedure TfsCustomVariable.SetValue(const Value: Variant);
|
|
begin
|
|
if not FIsReadOnly then
|
|
FValue := Value;
|
|
end;
|
|
|
|
function TfsCustomVariable.GetParam(Index: Integer): TfsParamItem;
|
|
begin
|
|
Result := FItems[Index];
|
|
end;
|
|
|
|
function TfsCustomVariable.GetPValue: PVariant;
|
|
begin
|
|
Result := @FValue;
|
|
end;
|
|
|
|
function TfsCustomVariable.GetFullTypeName: String;
|
|
begin
|
|
case FTyp of
|
|
fvtInt: Result := 'Integer';
|
|
fvtInt64: Result := 'Int64';
|
|
fvtBool: Result := 'Boolean';
|
|
fvtFloat: Result := 'Extended';
|
|
fvtChar: Result := 'Char';
|
|
fvtString: Result := 'String';
|
|
fvtClass: Result := FTypeName;
|
|
fvtArray: Result := 'Array';
|
|
fvtEnum: Result := FTypeName;
|
|
else
|
|
Result := 'Variant';
|
|
end;
|
|
end;
|
|
|
|
function TfsCustomVariable.GetNumberOfRequiredParams: Integer;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := 0;
|
|
for i := 0 to Count - 1 do
|
|
if not Params[i].IsOptional then
|
|
Inc(Result);
|
|
end;
|
|
|
|
|
|
{ TfsStringVariable }
|
|
|
|
function TfsStringVariable.GetValue: Variant;
|
|
begin
|
|
Result := FStr;
|
|
if Assigned(FOnGetVarValue) then
|
|
begin
|
|
Result := FOnGetVarValue(FName, FTyp, FStr);
|
|
if Result = null then Result := FStr;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsStringVariable.SetValue(const Value: Variant);
|
|
begin
|
|
FStr := Value;
|
|
end;
|
|
|
|
|
|
{ TfsParamItem }
|
|
|
|
constructor TfsParamItem.Create(const AName: String; ATyp: TfsVarType;
|
|
const ATypeName: String; AIsOptional, AIsVarParam: Boolean);
|
|
begin
|
|
inherited Create(AName, ATyp, ATypeName);
|
|
FIsOptional := AIsOptional;
|
|
FIsVarParam := AIsVarParam;
|
|
FDefValue := Null;
|
|
end;
|
|
|
|
|
|
{ TfsProcVariable }
|
|
|
|
constructor TfsProcVariable.Create(const AName: String; ATyp: TfsVarType;
|
|
const ATypeName: String; AParent: TfsScript; AIsFunc: Boolean = True);
|
|
begin
|
|
inherited Create(AName, ATyp, ATypeName);
|
|
FIsReadOnly := True;
|
|
FVarsStack := TList.Create;
|
|
FIsFunc := AIsFunc;
|
|
FProgram := TfsScript.Create(nil);
|
|
FProgram.Parent := AParent;
|
|
if FProgram.Parent <> nil then
|
|
FProgram.UseClassLateBinding := FProgram.Parent.UseClassLateBinding;
|
|
if FIsFunc then
|
|
begin
|
|
FRefItem := TfsVariable.Create('Result', ATyp, ATypeName);
|
|
FProgram.Add('Result', FRefItem);
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
destructor TfsProcVariable.Destroy;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
{ avoid destroying the param objects twice }
|
|
for i := 0 to Count - 1 do
|
|
FProgram.FItems.Delete(FProgram.FItems.IndexOfObject(Params[i]));
|
|
|
|
FProgram.Free;
|
|
FVarsStack.Free;
|
|
inherited;
|
|
end;
|
|
|
|
function TfsProcVariable.GetValue: Variant;
|
|
var
|
|
Temp: Boolean;
|
|
ParentProg, SaveProg: TfsScript;
|
|
i: Integer;
|
|
begin
|
|
Temp := FExecuting;
|
|
FExecuting := True;
|
|
if FIsFunc then
|
|
FRefItem.Value := Unassigned;
|
|
|
|
ParentProg := FProgram;
|
|
SaveProg := nil;
|
|
while ParentProg <> nil do
|
|
if ParentProg.FMainProg then
|
|
begin
|
|
SaveProg := ParentProg.FProgRunning;
|
|
ParentProg.FProgRunning := FProgram;
|
|
break;
|
|
end
|
|
else
|
|
ParentProg := ParentProg.FParent;
|
|
|
|
try
|
|
// avoid trial message
|
|
// same as FProgram.Execute
|
|
with FProgram do
|
|
begin
|
|
FExitCalled := False;
|
|
FTerminated := False;
|
|
FIsRunning := True;
|
|
FProgName := Self.FName;
|
|
try
|
|
FStatement.Execute;
|
|
finally
|
|
FExitCalled := False;
|
|
FTerminated := False;
|
|
FIsRunning := False;
|
|
FProgName := '';
|
|
end;
|
|
end;
|
|
//
|
|
|
|
if FIsFunc then
|
|
Result := FRefItem.Value else
|
|
Result := Null;
|
|
finally
|
|
if ParentProg <> nil then
|
|
ParentProg.FProgRunning := SaveProg;
|
|
FExecuting := Temp;
|
|
if (ParentProg <> nil) and ParentProg.FClearLocalVars then
|
|
for i := 0 to Prog.Count - 1 do
|
|
if (Prog.Items[i] is TfsVariable) and
|
|
(CompareText('Result', Prog.Items[i].Name) <> 0)
|
|
{$IFDEF DELPHI6}
|
|
and not VarIsClear(Prog.Items[i].Value)
|
|
{$ENDIF}
|
|
then
|
|
case TfsVariable(Prog.Items[i]).Typ of
|
|
fvtString:
|
|
TfsVariable(Prog.Items[i]).Value := '';
|
|
fvtInt, fvtFloat, fvtChar:
|
|
TfsVariable(Prog.Items[i]).Value := 0;
|
|
fvtVariant:
|
|
TfsVariable(Prog.Items[i]).Value := Null;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TfsProcVariable.SaveLocalVariables: Integer;
|
|
var
|
|
i: Integer;
|
|
LocalVars: TList;
|
|
StackItem: TfsLocalVariablesHelper;
|
|
begin
|
|
LocalVars := TList.Create;
|
|
FVarsStack.Add(LocalVars);
|
|
Result := FVarsStack.Count - 1;
|
|
for i := 0 to Prog.Count - 1 do
|
|
if (Prog.Items[i] is TfsVariable) or (Prog.Items[i] is TfsParamItem) then
|
|
begin
|
|
StackItem := TfsLocalVariablesHelper.Create;
|
|
StackItem.FValue := Prog.Items[i].Value;
|
|
StackItem.FVariableLink := Prog.Items[i];
|
|
LocalVars.Add(StackItem);
|
|
end;
|
|
end;
|
|
|
|
procedure TfsProcVariable.RestoreLocalVariables(StackIndex: Integer; bSkipVarParams: Boolean; dItem: TfsDesignatorItem);
|
|
var
|
|
i: Integer;
|
|
LocalVars: TList;
|
|
StackItem: TfsLocalVariablesHelper;
|
|
bIsVar: Boolean;
|
|
Temp1: array of Variant;
|
|
begin
|
|
if (FVarsStack.Count < StackIndex) or (StackIndex < 0) then Exit;
|
|
LocalVars := TList(FVarsStack[StackIndex]);
|
|
SetLength(Temp1, Count);
|
|
try
|
|
{ save var parameters value, need when pass same variable as VAR parameter }
|
|
if Assigned(dItem) then
|
|
for i := 0 to Count - 1 do
|
|
if Params[i].IsVarParam then
|
|
Temp1[i] := Params[i].Value;
|
|
for i := 0 to LocalVars.Count - 1 do
|
|
begin
|
|
StackItem := TfsLocalVariablesHelper(LocalVars[i]);
|
|
bIsVar := TfsParamItem(StackItem.FVariableLink).FIsVarParam;
|
|
if not (bSkipVarParams and (StackItem.FVariableLink is TfsParamItem) and bIsVar) then
|
|
StackItem.FVariableLink.Value := StackItem.FValue;
|
|
StackItem.Free;
|
|
end;
|
|
if Assigned(dItem) then
|
|
for i := 0 to Count - 1 do
|
|
if Params[i].IsVarParam then
|
|
dItem[i].Value := Temp1[i];
|
|
finally
|
|
Temp1 := nil;
|
|
LocalVars.Free;
|
|
FVarsStack.Delete(StackIndex);
|
|
end;
|
|
end;
|
|
|
|
|
|
{ TfsPropertyHelper }
|
|
|
|
function TfsPropertyHelper.GetValue: Variant;
|
|
var
|
|
p: PPropInfo;
|
|
Instance: TObject;
|
|
begin
|
|
|
|
Result := Null;
|
|
Instance := TObject(frxInteger(ParentValue));
|
|
|
|
if FIsPublished and Assigned(Instance) then
|
|
begin
|
|
p := GetPropInfo(Instance.ClassInfo, Name);
|
|
if p <> nil then
|
|
case p.PropType^.Kind of
|
|
tkInteger, tkSet, tkEnumeration, tkClass
|
|
{$IFDEF FPC} ,tkBool {$ENDIF}:
|
|
Result := GetOrdProp(Instance, p);
|
|
{$IFDEF FS_INT64}
|
|
tkInt64:
|
|
Result := GetInt64Prop(Instance, p);
|
|
{$ENDIF}
|
|
tkFloat:
|
|
Result := GetFloatProp(Instance, p);
|
|
|
|
// tkString, tkLString, tkWString{$IFDEF Delphi12}, tkUString{$ENDIF}:
|
|
// Result := GetStrProp(Instance, p);
|
|
|
|
tkChar, tkWChar:
|
|
Result := Chr(GetOrdProp(Instance, p));
|
|
|
|
tkVariant:
|
|
Result := GetVariantProp(Instance, p);
|
|
{$IFDEF Delphi12}
|
|
tkString, tkLString:
|
|
Result := GetAnsiStrProp(Instance, p);
|
|
tkWString, tkUString:
|
|
Result := GetUnicodeStrProp(Instance, p);
|
|
{$ELSE}
|
|
tkString, tkLString, tkWString{$ifdef FPC}, tkAString{$endif}:
|
|
Result := GetStrProp(Instance, p);
|
|
{$ENDIF}
|
|
end;
|
|
end
|
|
else if Assigned(FOnGetValue) then
|
|
Result := FOnGetValue(Instance, FClassRef, FUppercaseName)
|
|
else if Assigned(FOnGetValueNew) then
|
|
Result := FOnGetValueNew(Instance, FClassRef, FUppercaseName, Self);
|
|
|
|
if Typ = fvtBool then
|
|
if Result = 0 then
|
|
Result := False else
|
|
Result := True;
|
|
|
|
end;
|
|
|
|
procedure TfsPropertyHelper.SetValue(const Value: Variant);
|
|
var
|
|
p: PPropInfo;
|
|
Instance: TObject;
|
|
IntVal: frxInteger;
|
|
{$IFNDEF CPUX64}
|
|
{$IFDEF Delphi12}
|
|
Int64Val: Int64;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
begin
|
|
|
|
if IsReadOnly then Exit;
|
|
Instance := TObject(frxInteger(ParentValue));
|
|
|
|
|
|
|
|
if FIsPublished then
|
|
begin
|
|
p := GetPropInfo(Instance.ClassInfo, Name);
|
|
if p <> nil then
|
|
case p.PropType^.Kind of
|
|
tkInteger, tkSet, tkEnumeration, tkClass
|
|
{$IFDEF FPC} ,tkBool {$ENDIF}:
|
|
// {$IFDEF Delphi12}, tkInt64{$ENDIF}:
|
|
begin
|
|
{$IFNDEF Delphi4}
|
|
if VarType(Value) <> varInteger then
|
|
begin
|
|
SetSetProp(Instance, p, fsSetToString(p, Value));
|
|
end
|
|
else
|
|
{$ENDIF}
|
|
begin
|
|
if Typ = fvtBool then
|
|
if Value = True then
|
|
IntVal := 1 else
|
|
IntVal := 0
|
|
else
|
|
{$IFNDEF CPUX64}
|
|
{$IFDEF Delphi12}
|
|
if (VarType(Value) = varInt64)
|
|
or (VarType(Value) = varUInt64) then
|
|
begin
|
|
Int64Val := Value;
|
|
IntVal := Cardinal(Int64Rec(Int64Val).Lo);
|
|
end
|
|
else
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
IntVal := frxInteger(Value);
|
|
SetOrdProp(Instance, p, IntVal);
|
|
end;
|
|
end;
|
|
{$IFNDEF DELPHI16}
|
|
{$IFDEF FS_INT64}
|
|
tkInt64:
|
|
SetInt64Prop(Instance, p, Value);
|
|
{$ENDIF}
|
|
{$ELSE}
|
|
tkInt64:
|
|
SetInt64Prop(Instance, p, Int64(Value));
|
|
{$ENDIF}
|
|
tkFloat:
|
|
SetFloatProp(Instance, p, Extended(Value));
|
|
|
|
// tkString, tkLString:
|
|
// SetStrProp(Instance, p, String(Value));
|
|
|
|
// tkWString{$IFDEF Delphi12}, tkUString{$ENDIF}:
|
|
// SetStrProp(Instance, p, WideString(Value));
|
|
|
|
tkChar, tkWChar:
|
|
SetOrdProp(Instance, p, Ord(String(Value)[1]));
|
|
|
|
tkVariant:
|
|
SetVariantProp(Instance, p, Value);
|
|
|
|
{$IFDEF Delphi12}
|
|
tkString, tkLString:
|
|
SetAnsiStrProp(Instance, p, AnsiString(Value));
|
|
tkWString, tkUString:
|
|
SetUnicodeStrProp(Instance, p, WideString(Value));
|
|
{$ELSE}
|
|
tkString, tkLString, tkWString{$ifdef FPC}, tkAString{$endif}:
|
|
SetStrProp(Instance, p, String(Value));
|
|
{$ENDIF}
|
|
end;
|
|
end
|
|
else if Assigned(FOnSetValue) then
|
|
FOnSetValue(Instance, FClassRef, FUppercaseName, Value)
|
|
else if Assigned(FOnSetValueNew) then
|
|
FOnSetValueNew(Instance, FClassRef, FUppercaseName, Value, Self);
|
|
|
|
end;
|
|
|
|
|
|
{ TfsMethodHelper }
|
|
|
|
constructor TfsMethodHelper.Create(const Syntax: String; Script: TfsScript);
|
|
var
|
|
i: Integer;
|
|
v: TfsCustomVariable;
|
|
begin
|
|
v := ParseMethodSyntax(Syntax, Script);
|
|
inherited Create(v.Name, v.Typ, v.TypeName);
|
|
FIsReadOnly := True;
|
|
FSyntax := Syntax;
|
|
IsMacro := v.IsMacro;
|
|
|
|
{ copying params }
|
|
for i := 0 to v.Count - 1 do
|
|
Add(v.Params[i]);
|
|
while v.Count > 0 do
|
|
v.FItems.Delete(0);
|
|
v.Free;
|
|
|
|
// FPC and Delphi do this different way. FPC implementation more honest, so
|
|
// if Count = 0 then we get exception about bad bounds
|
|
if Count > 0 then
|
|
FVarArray := VarArrayCreate([0, Count - 1], varVariant);
|
|
end;
|
|
|
|
destructor TfsMethodHelper.Destroy;
|
|
begin
|
|
FVarArray := Null;
|
|
inherited;
|
|
end;
|
|
|
|
function TfsMethodHelper.GetVParam(Index: Integer): Variant;
|
|
begin
|
|
if Index = Count then
|
|
Result := FSetValue
|
|
else
|
|
Result := TfsParamItem(FItems[Index]).Value;
|
|
end;
|
|
|
|
procedure TfsMethodHelper.SetVParam(Index: Integer; const Value: Variant);
|
|
begin
|
|
TfsParamItem(FItems[Index]).Value := Value;
|
|
end;
|
|
|
|
function TfsMethodHelper.GetValue: Variant;
|
|
var
|
|
i: Integer;
|
|
Instance: TObject;
|
|
begin
|
|
if Assigned(FOnCall) then
|
|
begin
|
|
for i := 0 to Count - 1 do
|
|
FVarArray[i] := inherited Params[i].Value;
|
|
|
|
Instance := nil;
|
|
if not VarIsNull(ParentValue) then
|
|
Instance := TObject(frxInteger(ParentValue));
|
|
|
|
if FIndexMethod then
|
|
Result := FOnCall(Instance, FClassRef, FUppercaseName + '.GET', FVarArray)
|
|
else
|
|
Result := FOnCall(Instance, FClassRef, FUppercaseName, FVarArray);
|
|
for i := 0 to Count - 1 do
|
|
begin
|
|
if inherited Params[i].IsVarParam then
|
|
inherited Params[i].Value := FVarArray[i];
|
|
FVarArray[i] := Null;
|
|
end;
|
|
end
|
|
else if Assigned(FOnCallNew) then
|
|
begin
|
|
Instance := nil;
|
|
if not VarIsNull(ParentValue) then
|
|
Instance := TObject(frxInteger(ParentValue));
|
|
|
|
if FIndexMethod then
|
|
Result := FOnCallNew(Instance, FClassRef, FUppercaseName + '.GET', Self)
|
|
else
|
|
Result := FOnCallNew(Instance, FClassRef, FUppercaseName, Self);
|
|
end
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
procedure TfsMethodHelper.SetValue(const Value: Variant);
|
|
var
|
|
v: Variant;
|
|
i: Integer;
|
|
begin
|
|
if FIndexMethod then
|
|
if Assigned(FOnCall) then
|
|
begin
|
|
v := VarArrayCreate([0, Count], varVariant);
|
|
for i := 0 to Count - 1 do
|
|
v[i] := inherited Params[i].Value;
|
|
v[Count] := Value;
|
|
|
|
FOnCall(TObject(frxInteger(ParentValue)), FClassRef, FUppercaseName + '.SET', v);
|
|
v := Null;
|
|
end
|
|
else if Assigned(FOnCallNew) then
|
|
begin
|
|
FSetValue := Value;
|
|
FOnCallNew(TObject(frxInteger(ParentValue)), FClassRef, FUppercaseName + '.SET', Self);
|
|
FSetValue := Null;
|
|
end;
|
|
end;
|
|
|
|
|
|
{ TfsComponentHelper }
|
|
|
|
constructor TfsComponentHelper.Create(const Name: String; const ClassName: String);
|
|
begin
|
|
inherited Create(Name, fvtClass, ClassName);
|
|
end;
|
|
|
|
function TfsComponentHelper.GetValue: Variant;
|
|
var
|
|
c: TObject;
|
|
begin
|
|
c := TObject(frxInteger(ParentValue));
|
|
if c is TComponent then
|
|
c := TComponent(c).FindComponent(Name)
|
|
else
|
|
c := nil;
|
|
if Assigned(c) then
|
|
Result := frxInteger(c)
|
|
else
|
|
raise Exception.Create(Format(SComponentError, [Name]));
|
|
end;
|
|
|
|
procedure TfsComponentHelper.SetValue(const Value: Variant);
|
|
begin
|
|
raise Exception.Create(Format(SComponentAssignError, [Name]));
|
|
end;
|
|
|
|
{ TfsEventHelper }
|
|
|
|
constructor TfsEventHelper.Create(const Name: String; AEvent: TfsEventClass);
|
|
begin
|
|
inherited Create(Name, fvtString, '');
|
|
FEvent := AEvent;
|
|
end;
|
|
|
|
function TfsEventHelper.GetValue: Variant;
|
|
begin
|
|
Result := '';
|
|
end;
|
|
|
|
procedure TfsEventHelper.SetValue(const Value: Variant);
|
|
var
|
|
Instance: TPersistent;
|
|
v: TfsCustomVariable;
|
|
e: TfsCustomEvent;
|
|
p: PPropInfo;
|
|
m: TMethod;
|
|
begin
|
|
|
|
Instance := TPersistent(frxInteger(ParentValue));
|
|
if VarToStr(Value) = '0' then
|
|
begin
|
|
m.Code := nil;
|
|
m.Data := nil;
|
|
end
|
|
else
|
|
begin
|
|
v := FProgram.Find(Value);
|
|
if (v = nil) or not (v is TfsProcVariable) then
|
|
raise Exception.Create(SEventError);
|
|
|
|
e := TfsCustomEvent(FEvent.NewInstance);
|
|
e.Create(Instance, TfsProcVariable(v));
|
|
FProgram.Add('', e);
|
|
m.Code := e.GetMethod;
|
|
m.Data := e;
|
|
end;
|
|
|
|
p := GetPropInfo(Instance.ClassInfo, Name);
|
|
SetMethodProp(Instance, p, m);
|
|
end;
|
|
|
|
|
|
{ TfsClassVariable }
|
|
|
|
constructor TfsClassVariable.Create(AClass: TClass; const Ancestor: String);
|
|
begin
|
|
inherited Create(AClass.ClassName, fvtClass, AClass.ClassName);
|
|
FMembers := TfsItemList.Create;
|
|
FAncestor := Ancestor;
|
|
FClassRef := AClass;
|
|
|
|
AddPublishedProperties(AClass);
|
|
Add(TfsParamItem.Create('', fvtVariant, '', True, False));
|
|
end;
|
|
|
|
destructor TfsClassVariable.Destroy;
|
|
begin
|
|
FMembers.Free;
|
|
inherited;
|
|
end;
|
|
|
|
function TfsClassVariable.GetMembers(Index: Integer): TfsCustomHelper;
|
|
begin
|
|
Result := FMembers.FItems[Index];
|
|
end;
|
|
|
|
function TfsClassVariable.GetMembersCount: Integer;
|
|
begin
|
|
Result := FMembers.Count;
|
|
end;
|
|
|
|
procedure TfsClassVariable.AddConstructor(Syntax: String; CallEvent: TfsCallMethodEvent);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
i := Pos(' ', Syntax);
|
|
Delete(Syntax, 1, i - 1);
|
|
Syntax := 'function' + Syntax + ': ' + 'Constructor';
|
|
AddMethod(Syntax, CallEvent);
|
|
end;
|
|
|
|
procedure TfsClassVariable.AddConstructor(Syntax: String;
|
|
CallEvent: TfsCallMethodNewEvent);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
i := Pos(' ', Syntax);
|
|
Delete(Syntax, 1, i - 1);
|
|
Syntax := 'function' + Syntax + ': ' + 'Constructor';
|
|
AddMethod(Syntax, CallEvent);
|
|
end;
|
|
|
|
procedure TfsClassVariable.AddMethod(const Syntax: String; CallEvent: TfsCallMethodEvent);
|
|
var
|
|
m: TfsMethodHelper;
|
|
begin
|
|
m := TfsMethodHelper.Create(Syntax, FProgram);
|
|
m.FOnCall := CallEvent;
|
|
m.FClassRef := FClassRef;
|
|
FMembers.Add(m);
|
|
end;
|
|
|
|
procedure TfsClassVariable.AddMethod(const Syntax: String; CallEvent: TfsCallMethodNewEvent);
|
|
var
|
|
m: TfsMethodHelper;
|
|
begin
|
|
m := TfsMethodHelper.Create(Syntax, FProgram);
|
|
m.FOnCallNew := CallEvent;
|
|
m.FClassRef := FClassRef;
|
|
FMembers.Add(m);
|
|
end;
|
|
|
|
procedure TfsClassVariable.AddEvent(const Name: String; AEvent: TfsEventClass);
|
|
var
|
|
e: TfsEventHelper;
|
|
begin
|
|
e := TfsEventHelper.Create(Name, AEvent);
|
|
e.FClassRef := FClassRef;
|
|
FMembers.Add(e);
|
|
end;
|
|
|
|
procedure TfsClassVariable.AddProperty(const Name, Typ: String;
|
|
GetEvent: TfsGetValueEvent; SetEvent: TfsSetValueEvent);
|
|
var
|
|
p: TfsPropertyHelper;
|
|
begin
|
|
p := TfsPropertyHelper.Create(Name, StrToVarType(Typ, FProgram), Typ);
|
|
p.FClassRef := FClassRef;
|
|
p.FOnGetValue := GetEvent;
|
|
p.FOnSetValue := SetEvent;
|
|
p.IsReadOnly := not Assigned(SetEvent);
|
|
FMembers.Add(p);
|
|
end;
|
|
|
|
procedure TfsClassVariable.AddPropertyEx(const Name, Typ: String;
|
|
GetEvent: TfsGetValueNewEvent; SetEvent: TfsSetValueNewEvent);
|
|
var
|
|
p: TfsPropertyHelper;
|
|
begin
|
|
p := TfsPropertyHelper.Create(Name, StrToVarType(Typ, FProgram), Typ);
|
|
p.FClassRef := FClassRef;
|
|
p.FOnGetValueNew := GetEvent;
|
|
p.FOnSetValueNew := SetEvent;
|
|
p.IsReadOnly := not Assigned(SetEvent);
|
|
FMembers.Add(p);
|
|
end;
|
|
|
|
procedure TfsClassVariable.AddDefaultProperty(const Name, Params, Typ: String;
|
|
CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False);
|
|
begin
|
|
AddIndexProperty(Name, Params, Typ, CallEvent, AReadOnly);
|
|
FDefProperty := Members[FMembers.Count - 1];
|
|
end;
|
|
|
|
procedure TfsClassVariable.AddDefaultProperty(const Name, Params,
|
|
Typ: String; CallEvent: TfsCallMethodNewEvent; AReadOnly: Boolean);
|
|
begin
|
|
AddIndexProperty(Name, Params, Typ, CallEvent, AReadOnly);
|
|
FDefProperty := Members[FMembers.Count - 1];
|
|
end;
|
|
|
|
procedure TfsClassVariable.AddIndexProperty(const Name, Params,
|
|
Typ: String; CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False);
|
|
var
|
|
i: Integer;
|
|
sl: TStringList;
|
|
s: String;
|
|
begin
|
|
sl := TStringList.Create;
|
|
sl.CommaText := Params;
|
|
|
|
s := '';
|
|
for i := 0 to sl.Count - 1 do
|
|
s := s + 'p' + IntToStr(i) + ': ' + sl[i] + '; ';
|
|
|
|
SetLength(s, Length(s) - 2);
|
|
try
|
|
AddMethod('function ' + Name + '(' + s + '): ' + Typ, CallEvent);
|
|
with TfsMethodHelper(Members[FMembers.Count - 1]) do
|
|
begin
|
|
IsReadOnly := AReadOnly;
|
|
FIndexMethod := True;
|
|
end;
|
|
finally
|
|
sl.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsClassVariable.AddIndexProperty(const Name, Params,
|
|
Typ: String; CallEvent: TfsCallMethodNewEvent; AReadOnly: Boolean);
|
|
var
|
|
i: Integer;
|
|
sl: TStringList;
|
|
s: String;
|
|
begin
|
|
sl := TStringList.Create;
|
|
sl.CommaText := Params;
|
|
|
|
s := '';
|
|
for i := 0 to sl.Count - 1 do
|
|
s := s + 'p' + IntToStr(i) + ': ' + sl[i] + '; ';
|
|
|
|
SetLength(s, Length(s) - 2);
|
|
try
|
|
AddMethod('function ' + Name + '(' + s + '): ' + Typ, CallEvent);
|
|
with TfsMethodHelper(Members[FMembers.Count - 1]) do
|
|
begin
|
|
IsReadOnly := AReadOnly;
|
|
FIndexMethod := True;
|
|
end;
|
|
finally
|
|
sl.Free;
|
|
end;
|
|
end;
|
|
|
|
function TfsClassVariable.AddComponent(c: TComponent): TfsComponentHelper;
|
|
var
|
|
Helper: TfsCustomHelper;
|
|
begin
|
|
{ check if member alreeady exist }
|
|
Helper := Find(c.Name);
|
|
Result := nil;
|
|
{ member has different purpose, name conflict }
|
|
if Helper is TfsComponentHelper then
|
|
Result := TfsComponentHelper(Helper);
|
|
if Assigned(Helper) then Exit;
|
|
Result := TfsComponentHelper.Create(c.Name, c.ClassName);
|
|
FMembers.Add(Result);
|
|
end;
|
|
|
|
procedure TfsClassVariable.AddPublishedProperties(AClass: TClass);
|
|
var
|
|
TypeInfo: PTypeInfo;
|
|
PropCount: Integer;
|
|
PropList: PPropList;
|
|
i: Integer;
|
|
cl: String;
|
|
t: TfsVarType;
|
|
FClass: TClass;
|
|
p: TfsPropertyHelper;
|
|
begin
|
|
TypeInfo := AClass.ClassInfo;
|
|
if TypeInfo = nil then Exit;
|
|
|
|
PropCount := GetPropList(TypeInfo, tkProperties, nil);
|
|
GetMem(PropList, PropCount * SizeOf(PPropInfo));
|
|
GetPropList(TypeInfo, tkProperties, PropList);
|
|
|
|
try
|
|
for i := 0 to PropCount - 1 do
|
|
begin
|
|
t := fvtInt;
|
|
cl := '';
|
|
|
|
case PropList[i].PropType^.Kind of
|
|
tkInteger:
|
|
t := fvtInt;
|
|
{$IFDEF FS_INT64}
|
|
tkInt64:
|
|
t := fvtInt64;
|
|
{$ENDIF}
|
|
tkSet:
|
|
begin
|
|
t := fvtEnum;
|
|
cl := String(PropList[i].PropType^.Name);
|
|
end;
|
|
tkEnumeration:
|
|
begin
|
|
t := fvtEnum;
|
|
cl := String(PropList[i].PropType^.Name);
|
|
if (CompareText(cl, 'Boolean') = 0) or (CompareText(cl, 'bool') = 0) then
|
|
t := fvtBool;
|
|
end;
|
|
{$ifdef FPC}
|
|
tkBool:
|
|
t := fvtBool;
|
|
{$ENDIF}
|
|
tkFloat:
|
|
t := fvtFloat;
|
|
tkChar, tkWChar:
|
|
t := fvtChar;
|
|
tkString, tkLString, tkWString{$IFDEF Delphi12}, tkUString{$ENDIF}{$ifdef FPC},tkAString{$endif}:
|
|
t := fvtString;
|
|
tkVariant:
|
|
t := fvtVariant;
|
|
tkClass:
|
|
begin
|
|
t := fvtClass;
|
|
{$IFNDEF FPC}
|
|
FClass := GetTypeData(PropList[i].PropType^).ClassType;
|
|
{$ELSE}
|
|
FClass := GetTypeData(PropList[i].PropType).ClassType;
|
|
{$ENDIF}
|
|
cl := FClass.ClassName;
|
|
end;
|
|
end;
|
|
|
|
p := TfsPropertyHelper.Create(String(PropList[i].Name), t, cl);
|
|
p.FClassRef := FClassRef;
|
|
p.FIsPublished := True;
|
|
FMembers.Add(p);
|
|
end;
|
|
|
|
finally
|
|
FreeMem(PropList, PropCount * SizeOf(PPropInfo));
|
|
end;
|
|
end;
|
|
|
|
function TfsClassVariable.Find(const Name: String; IncludeComponentHelper: Boolean = True): TfsCustomHelper;
|
|
var
|
|
cl: TfsClassVariable;
|
|
|
|
function DoFind(const Name: String): TfsCustomHelper;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := nil;
|
|
for i := 0 to FMembers.Count - 1 do
|
|
if CompareText(Name, Members[i].Name) = 0 then
|
|
begin
|
|
Result := Members[i];
|
|
Exit;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
Result := DoFind(Name);
|
|
if Result = nil then
|
|
begin
|
|
cl := FProgram.FindClass(FAncestor);
|
|
if cl <> nil then
|
|
Result := cl.Find(Name);
|
|
end;
|
|
if not IncludeComponentHelper and (Result is TfsComponentHelper) then
|
|
Result := nil;
|
|
end;
|
|
|
|
function TfsClassVariable.GetValue: Variant;
|
|
begin
|
|
if Params[0].Value = Null then
|
|
Result := frxInteger(FClassRef.NewInstance) else { constructor call }
|
|
Result := Params[0].Value; { typecast }
|
|
Params[0].Value := Null;
|
|
end;
|
|
|
|
|
|
{ TfsDesignatorItem }
|
|
|
|
function TfsDesignatorItem.GetItem(Index: Integer): TfsCustomExpression;
|
|
begin
|
|
Result := FItems[Index];
|
|
end;
|
|
|
|
|
|
{ TfsDesignator }
|
|
|
|
constructor TfsDesignator.Create(AProgram: TfsScript);
|
|
var
|
|
ParentProg: TfsScript;
|
|
begin
|
|
{$IFDEF CPUX64}
|
|
inherited Create('', fvtInt64, '');
|
|
{$ELSE}
|
|
inherited Create('', fvtInt, '');
|
|
{$ENDIF}
|
|
FProgram := AProgram;
|
|
FMainProg := FProgram;
|
|
ParentProg := FProgram;
|
|
while ParentProg <> nil do
|
|
if ParentProg.FMainProg then
|
|
begin
|
|
FMainProg := ParentProg;
|
|
break;
|
|
end
|
|
else
|
|
ParentProg := ParentProg.FParent;
|
|
FProgram.UseClassLateBinding := FMainProg.UseClassLateBinding;
|
|
end;
|
|
|
|
destructor TfsDesignator.Destroy;
|
|
begin
|
|
if FLateBindingXMLSource <> nil then
|
|
FLateBindingXMLSource.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TfsDesignator.Borrow(ADesignator: TfsDesignator);
|
|
var
|
|
SaveItems: TList;
|
|
begin
|
|
SaveItems := FItems;
|
|
FItems := ADesignator.FItems;
|
|
ADesignator.FItems := SaveItems;
|
|
FKind := ADesignator.FKind;
|
|
FRef1 := ADesignator.FRef1;
|
|
FRef2 := ADesignator.FRef2;
|
|
FTyp := ADesignator.Typ;
|
|
FTypeName := ADesignator.TypeName;
|
|
FIsReadOnly := ADesignator.IsReadOnly;
|
|
RefItem := ADesignator.RefItem;
|
|
end;
|
|
|
|
procedure TfsDesignator.Finalize;
|
|
var
|
|
Item: TfsDesignatorItem;
|
|
begin
|
|
Item := Items[Count - 1];
|
|
FTyp := Item.Ref.Typ;
|
|
FTypeName := Item.Ref.TypeName;
|
|
if FTyp = fvtConstructor then
|
|
begin
|
|
FTyp := fvtClass;
|
|
FTypeName := Items[Count - 2].Ref.TypeName;
|
|
end;
|
|
|
|
FIsReadOnly := Item.Ref.IsReadOnly;
|
|
|
|
{ speed optimization for access to single variable, string element or array }
|
|
if (Count = 1) and (Items[0].Ref is TfsVariable) then
|
|
begin
|
|
RefItem := Items[0].Ref;
|
|
FKind := dkVariable;
|
|
end
|
|
else if (Count = 2) and (Items[0].Ref is TfsStringVariable) then
|
|
begin
|
|
RefItem := Items[0].Ref;
|
|
FRef1 := Items[1][0];
|
|
FKind := dkStringArray;
|
|
end
|
|
else if (Count = 2) and (Items[0].Ref is TfsVariable) and (Items[0].Ref.Typ = fvtArray) then
|
|
begin
|
|
RefItem := Items[0].Ref;
|
|
FRef1 := RefItem.RefItem;
|
|
FRef2 := Items[1];
|
|
FKind := dkArray;
|
|
end
|
|
else
|
|
FKind := dkOther;
|
|
end;
|
|
|
|
function TfsDesignator.GetItem(Index: Integer): TfsDesignatorItem;
|
|
begin
|
|
Result := FItems[Index];
|
|
end;
|
|
|
|
function TfsDesignator.DoCalc(const AValue: Variant; Flag: Boolean): Variant;
|
|
var
|
|
i, j: Integer;
|
|
Item: TfsCustomVariable;
|
|
Val: Variant;
|
|
Ref: TfsCustomVariable;
|
|
Temp1: array of Variant;
|
|
StackIndex: Integer;
|
|
begin
|
|
Ref := nil;
|
|
Val := Null;
|
|
StackIndex := -1;
|
|
for i := 0 to Count - 1 do
|
|
begin
|
|
Item := Items[i].Ref;
|
|
|
|
if Item is TfsDesignator then { it is true for "WITH" statements }
|
|
begin
|
|
Ref := Item;
|
|
Val := Item.Value;
|
|
continue;
|
|
end;
|
|
|
|
try
|
|
{ we're trying to call the local procedure that is already executing -
|
|
i.e. we have a recursion }
|
|
if (Item is TfsProcVariable) and TfsProcVariable(Item).Executing then
|
|
StackIndex := TfsProcVariable(Item).SaveLocalVariables;
|
|
|
|
if Item.Count > 0 then
|
|
begin
|
|
SetLength(Temp1, Item.Count);
|
|
try
|
|
{ calculate params and copy param values to the temp1 array }
|
|
for j := 0 to Item.Count - 1 do
|
|
if Item.IsMacro then
|
|
Temp1[j] := TfsExpression(Items[i][j]).Source
|
|
else
|
|
Temp1[j] := Items[i][j].Value;
|
|
{ copy calculated values to the item params }
|
|
for j := 0 to Item.Count - 1 do
|
|
Item.Params[j].Value := Temp1[j];
|
|
finally
|
|
Temp1 := nil;
|
|
end;
|
|
end;
|
|
|
|
{ copy value and var reference to the helper object }
|
|
if Item is TfsCustomHelper then
|
|
begin
|
|
TfsCustomHelper(Item).ParentRef := Ref;
|
|
TfsCustomHelper(Item).ParentValue := Val;
|
|
TfsCustomHelper(Item).Prog := FProgram;
|
|
end;
|
|
|
|
Ref := Item;
|
|
{ assign a value to the last designator node if called from SetValue }
|
|
if Flag and (i = Count - 1) then
|
|
begin
|
|
Item.Value := AValue
|
|
end
|
|
else
|
|
begin
|
|
Item.NeedResult := (i <> Count - 1) or NeedResult;
|
|
Val := Item.Value;
|
|
end;
|
|
|
|
{ copy back var params }
|
|
for j := 0 to Item.Count - 1 do
|
|
if Item.Params[j].IsVarParam then
|
|
Items[i][j].Value := Item.Params[j].Value;
|
|
|
|
finally
|
|
{ restore proc variables if it was called from itself }
|
|
if (Item is TfsProcVariable) and TfsProcVariable(Item).Executing then
|
|
TfsProcVariable(Item).RestoreLocalVariables(StackIndex, False, Items[i]);
|
|
end;
|
|
end;
|
|
|
|
Result := Val;
|
|
end;
|
|
|
|
procedure TfsDesignator.CheckLateBinding;
|
|
var
|
|
NewDesignator: TfsDesignator;
|
|
Parser: TfsILParser;
|
|
begin
|
|
if FLateBindingXMLSource <> nil then
|
|
begin
|
|
Parser := TfsILParser.Create(FProgram);
|
|
try
|
|
NewDesignator := Parser.DoDesignator(FLateBindingXMLSource, FProgram);
|
|
Borrow(NewDesignator);
|
|
NewDesignator.Free;
|
|
finally
|
|
Parser.Free;
|
|
FLateBindingXMLSource.Free;
|
|
FLateBindingXMLSource := nil;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TfsDesignator.GetValue: Variant;
|
|
begin
|
|
CheckLateBinding;
|
|
Result := DoCalc(Null, False);
|
|
end;
|
|
|
|
procedure TfsDesignator.SetValue(const Value: Variant);
|
|
begin
|
|
CheckLateBinding;
|
|
DoCalc(Value, True);
|
|
end;
|
|
|
|
|
|
{ TfsVariableDesignator }
|
|
|
|
function TfsVariableDesignator.GetValue: Variant;
|
|
begin
|
|
Result := RefItem.Value;
|
|
end;
|
|
|
|
procedure TfsVariableDesignator.SetValue(const Value: Variant);
|
|
begin
|
|
RefItem.Value := Value;
|
|
end;
|
|
|
|
|
|
{ TfsStringDesignator }
|
|
|
|
function TfsStringDesignator.GetValue: Variant;
|
|
begin
|
|
Result := TfsStringVariable(RefItem).FStr[Integer(FRef1.Value)];
|
|
end;
|
|
|
|
procedure TfsStringDesignator.SetValue(const Value: Variant);
|
|
begin
|
|
TfsStringVariable(RefItem).FStr[Integer(FRef1.Value)] := VarToStr(Value)[1];
|
|
end;
|
|
|
|
|
|
{ TfsArrayDesignator }
|
|
|
|
function TfsArrayDesignator.GetValue: Variant;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
TfsCustomHelper(FRef1).ParentRef := RefItem;
|
|
for i := 0 to FRef2.Count - 1 do
|
|
FRef1.Params[i].Value := FRef2[i].Value;
|
|
Result := FRef1.Value;
|
|
end;
|
|
|
|
procedure TfsArrayDesignator.SetValue(const Value: Variant);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
TfsCustomHelper(FRef1).ParentRef := RefItem;
|
|
for i := 0 to FRef2.Count - 1 do
|
|
FRef1.Params[i].Value := FRef2[i].Value;
|
|
FRef1.Value := Value;
|
|
end;
|
|
|
|
|
|
{ TfsSetExpression }
|
|
|
|
function TfsSetExpression.Check(const Value: Variant): Boolean;
|
|
var
|
|
i: Integer;
|
|
Expr: TfsCustomExpression;
|
|
begin
|
|
Result := False;
|
|
|
|
(* TfsSetExpression encapsulates the set like [1,2,3..10]
|
|
In the example above we'll have the following Items:
|
|
TfsExpression {1}
|
|
TfsExpression {2}
|
|
TfsExpression {3}
|
|
nil (indicates the range )
|
|
TfsExpression {10} *)
|
|
|
|
i := 0;
|
|
while i < Count do
|
|
begin
|
|
Expr := Items[i];
|
|
|
|
if (i < Count - 1) and (Items[i + 1] = nil) then { subrange }
|
|
begin
|
|
Result := (Value >= Expr.Value) and (Value <= Items[i + 2].Value);
|
|
Inc(i, 2);
|
|
end
|
|
else
|
|
Result := Value = Expr.Value;
|
|
|
|
if Result then break;
|
|
Inc(i);
|
|
end;
|
|
end;
|
|
|
|
function TfsSetExpression.GetItem(Index: Integer): TfsCustomExpression;
|
|
begin
|
|
Result := FItems[Index];
|
|
end;
|
|
|
|
function TfsSetExpression.GetValue: Variant;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := VarArrayCreate([0, Count - 1], varVariant);
|
|
|
|
for i := 0 to Count - 1 do
|
|
if Items[i] = nil then
|
|
Result[i] := Null else
|
|
Result[i] := Items[i].Value;
|
|
end;
|
|
|
|
|
|
{ TfsScript }
|
|
|
|
constructor TfsScript.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
FEvaluteRiseError := False;
|
|
FItems := TStringList.Create;
|
|
FItems.Sorted := True;
|
|
FItems.Duplicates := dupAccept;
|
|
FLines := TStringList.Create;
|
|
FMacros := TStringList.Create;
|
|
FIncludePath := TStringList.Create;
|
|
FIncludePath.Add('');
|
|
FStatement := TfsStatement.Create(Self, '', '');
|
|
FSyntaxType := 'PascalScript';
|
|
FUnitLines := TStringList.Create;
|
|
FUseClassLateBinding := False;
|
|
end;
|
|
|
|
destructor TfsScript.Destroy;
|
|
begin
|
|
inherited;
|
|
Clear;
|
|
ClearRTTI;
|
|
FItems.Free;
|
|
FLines.Free;
|
|
FMacros.Free;
|
|
FIncludePath.Free;
|
|
FStatement.Free;
|
|
FUnitLines.Free;
|
|
end;
|
|
|
|
procedure TfsScript.Add(const Name: String; Item: TObject);
|
|
begin
|
|
FItems.AddObject(Name, Item);
|
|
if Item is TfsCustomVariable then
|
|
TfsCustomVariable(Item).AddedBy := FAddedBy;
|
|
end;
|
|
|
|
function TfsScript.Count: Integer;
|
|
begin
|
|
Result := FItems.Count;
|
|
end;
|
|
|
|
procedure TfsScript.Remove(Item: TObject);
|
|
begin
|
|
FItems.Delete(FItems.IndexOfObject(Item));
|
|
end;
|
|
|
|
procedure TfsScript.Clear;
|
|
var
|
|
i: Integer;
|
|
item: TObject;
|
|
begin
|
|
i := 0;
|
|
while i < FItems.Count do
|
|
begin
|
|
item := FItems.Objects[i];
|
|
if (item is TfsRTTIModule) or
|
|
((item is TfsCustomVariable) and
|
|
(TfsCustomVariable(item).AddedBy = TObject(1))) then
|
|
Inc(i)
|
|
else
|
|
begin
|
|
item.Free;
|
|
FItems.Delete(i);
|
|
end;
|
|
end;
|
|
FStatement.Clear;
|
|
|
|
|
|
for i := 0 to FUnitLines.Count - 1 do
|
|
FUnitLines.Objects[i].Free;
|
|
|
|
FUnitLines.Clear;
|
|
|
|
FErrorPos := '';
|
|
FErrorMsg := '';
|
|
FErrorUnit := '';
|
|
end;
|
|
|
|
procedure TfsScript.ClearItems(Owner: TObject);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
RemoveItems(Owner);
|
|
FStatement.Clear;
|
|
|
|
for i := 0 to FUnitLines.Count - 1 do
|
|
FUnitLines.Objects[i].Free;
|
|
|
|
FUnitLines.Clear;
|
|
end;
|
|
|
|
procedure TfsScript.RemoveItems(Owner: TObject);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := Count - 1 downto 0 do
|
|
if FItems.Objects[i] is TfsCustomVariable then
|
|
if Items[i].AddedBy = Owner then
|
|
begin
|
|
Items[i].Free;
|
|
Remove(Items[i]);
|
|
end;
|
|
end;
|
|
|
|
function TfsScript.GetItem(Index: Integer): TfsCustomVariable;
|
|
begin
|
|
Result := TfsCustomVariable(FItems.Objects[Index]);
|
|
end;
|
|
|
|
function TfsScript.GetProgName: String;
|
|
begin
|
|
if Assigned(ProgRunning) then
|
|
Result := ProgRunning.ProgName
|
|
else
|
|
Result := FProgName;
|
|
end;
|
|
|
|
function TfsScript.Find(const Name: String): TfsCustomVariable;
|
|
begin
|
|
Result := FindLocal(Name);
|
|
|
|
{ trying to find the identifier in all parent programs }
|
|
if (Result = nil) and (FParent <> nil) then
|
|
Result := FParent.Find(Name);
|
|
end;
|
|
|
|
function TfsScript.FindLocal(const Name: String): TfsCustomVariable;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := nil;
|
|
i := FItems.IndexOf(Name);
|
|
if (i <> -1) and (FItems.Objects[i] is TfsCustomVariable) then
|
|
Result := TfsCustomVariable(FItems.Objects[i]);
|
|
end;
|
|
|
|
function TfsScript.Compile: Boolean;
|
|
var
|
|
p: TfsILParser;
|
|
begin
|
|
Result := False;
|
|
FErrorMsg := '';
|
|
|
|
p := TfsILParser.Create(Self);
|
|
try
|
|
p.SelectLanguage(FSyntaxType);
|
|
if p.MakeILScript(FLines.Text) then
|
|
p.ParseILScript;
|
|
finally
|
|
p.Free;
|
|
end;
|
|
|
|
if FErrorMsg = '' then
|
|
begin
|
|
Result := True;
|
|
FErrorPos := '';
|
|
end
|
|
end;
|
|
|
|
procedure TfsScript.Execute;
|
|
begin
|
|
|
|
FExitCalled := False;
|
|
FTerminated := False;
|
|
FIsRunning := True;
|
|
FMainProg := True;
|
|
try
|
|
FStatement.Execute;
|
|
finally
|
|
FExitCalled := False;
|
|
FTerminated := False;
|
|
FIsRunning := False;
|
|
end;
|
|
end;
|
|
|
|
function TfsScript.Run: Boolean;
|
|
begin
|
|
Result := Compile;
|
|
if Result then
|
|
Execute;
|
|
end;
|
|
|
|
function TfsScript.GetILCode(Stream: TStream): Boolean;
|
|
var
|
|
p: TfsILParser;
|
|
begin
|
|
Result := False;
|
|
FErrorMsg := '';
|
|
|
|
p := TfsILParser.Create(Self);
|
|
try
|
|
p.SelectLanguage(FSyntaxType);
|
|
if p.MakeILScript(FLines.Text) then
|
|
p.ILScript.SaveToStream(Stream);
|
|
finally
|
|
p.Free;
|
|
end;
|
|
|
|
if FErrorMsg = '' then
|
|
begin
|
|
Result := True;
|
|
FErrorPos := '';
|
|
end;
|
|
end;
|
|
|
|
function TfsScript.SetILCode(Stream: TStream): Boolean;
|
|
var
|
|
p: TfsILParser;
|
|
begin
|
|
Result := False;
|
|
FErrorMsg := '';
|
|
|
|
p := TfsILParser.Create(Self);
|
|
try
|
|
p.SelectLanguage(FSyntaxType);
|
|
p.ILScript.LoadFromStream(Stream);
|
|
p.ParseILScript;
|
|
finally
|
|
p.Free;
|
|
end;
|
|
|
|
if FErrorMsg = '' then
|
|
begin
|
|
Result := True;
|
|
FErrorPos := '';
|
|
end;
|
|
end;
|
|
|
|
procedure TfsScript.AddType(const TypeName: String; ParentType: TfsVarType);
|
|
var
|
|
v: TfsTypeVariable;
|
|
begin
|
|
if Find(TypeName) <> nil then Exit;
|
|
v := TfsTypeVariable.Create(TypeName, ParentType, '');
|
|
Add(TypeName, v);
|
|
end;
|
|
|
|
function TfsScript.AddClass(AClass: TClass; const Ancestor: String): TfsClassVariable;
|
|
var
|
|
cl: TfsClassVariable;
|
|
begin
|
|
Result := nil;
|
|
if Find(AClass.ClassName) <> nil then Exit;
|
|
|
|
Result := TfsClassVariable.Create(AClass, Ancestor);
|
|
Result.FProgram := Self;
|
|
Add(Result.Name, Result);
|
|
|
|
cl := TfsClassVariable(Find(Ancestor));
|
|
if cl <> nil then
|
|
Result.FDefProperty := cl.DefProperty;
|
|
end;
|
|
|
|
procedure TfsScript.AddConst(const Name, Typ: String; const Value: Variant);
|
|
var
|
|
v: TfsVariable;
|
|
begin
|
|
if Find(Name) <> nil then Exit;
|
|
|
|
v := TfsVariable.Create(Name, StrToVarType(Typ, Self), Typ);
|
|
v.Value := Value;
|
|
v.IsReadOnly := True;
|
|
Add(v.Name, v);
|
|
end;
|
|
|
|
procedure TfsScript.AddEnum(const Typ, Names: String);
|
|
var
|
|
i: Integer;
|
|
v: TfsVariable;
|
|
sl: TStringList;
|
|
begin
|
|
v := TfsVariable.Create(Typ, fvtEnum, Typ);
|
|
Add(v.Name, v);
|
|
|
|
sl := TStringList.Create;
|
|
sl.CommaText := Names;
|
|
|
|
try
|
|
for i := 0 to sl.Count - 1 do
|
|
begin
|
|
v := TfsVariable.Create(Trim(sl[i]), fvtEnum, Typ);
|
|
v.Value := i;
|
|
v.IsReadOnly := True;
|
|
Add(v.Name, v);
|
|
end;
|
|
finally
|
|
sl.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsScript.AddEnumSet(const Typ, Names: String);
|
|
var
|
|
i, j: Integer;
|
|
v: TfsVariable;
|
|
sl: TStringList;
|
|
begin
|
|
v := TfsVariable.Create(Typ, fvtEnum, Typ);
|
|
Add(v.Name, v);
|
|
|
|
sl := TStringList.Create;
|
|
sl.CommaText := Names;
|
|
|
|
try
|
|
j := 1;
|
|
for i := 0 to sl.Count - 1 do
|
|
begin
|
|
v := TfsVariable.Create(Trim(sl[i]), fvtEnum, Typ);
|
|
v.Value := j;
|
|
v.IsReadOnly := True;
|
|
Add(v.Name, v);
|
|
j := j * 2;
|
|
end;
|
|
finally
|
|
sl.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsScript.AddMethod(const Syntax: String; CallEvent: TfsCallMethodEvent;
|
|
const Category: String = ''; const Description: String = '');
|
|
var
|
|
v: TfsMethodHelper;
|
|
begin
|
|
v := TfsMethodHelper.Create(Syntax, Self);
|
|
v.FOnCall := CallEvent;
|
|
if Description = '' then
|
|
v.FDescription := v.Name else
|
|
v.FDescription := Description;
|
|
v.FCategory := Category;
|
|
Add(v.Name, v);
|
|
end;
|
|
|
|
procedure TfsScript.AddMethod(const Syntax: String; CallEvent: TfsCallMethodNewEvent;
|
|
const Category: String = ''; const Description: String = '');
|
|
var
|
|
v: TfsMethodHelper;
|
|
begin
|
|
v := TfsMethodHelper.Create(Syntax, Self);
|
|
v.FOnCallNew := CallEvent;
|
|
if Description = '' then
|
|
v.FDescription := v.Name else
|
|
v.FDescription := Description;
|
|
v.FCategory := Category;
|
|
Add(v.Name, v);
|
|
end;
|
|
|
|
procedure TfsScript.AddObject(const Name: String; Obj: TObject);
|
|
begin
|
|
AddVariable(Name, Obj.ClassName, frxInteger(Obj));
|
|
end;
|
|
|
|
procedure TfsScript.AddVariable(const Name, Typ: String; const Value: Variant);
|
|
var
|
|
v: TfsVariable;
|
|
begin
|
|
if Find(Name) <> nil then Exit;
|
|
|
|
v := TfsVariable.Create(Name, StrToVarType(Typ, Self), Typ);
|
|
v.Value := Value;
|
|
v.OnGetVarValue := FOnGetVarValue;
|
|
Add(v.Name, v);
|
|
end;
|
|
|
|
procedure TfsScript.AddForm(Form: TComponent);
|
|
begin
|
|
AddComponent(Form);
|
|
end;
|
|
|
|
procedure TfsScript.AddComponent(Form: TComponent);
|
|
{$IFNDEF NOFORMS}
|
|
var
|
|
i: Integer;
|
|
v: TfsClassVariable;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFNDEF NOFORMS}
|
|
v := FindClass(Form.ClassName);
|
|
if v = nil then
|
|
begin
|
|
if Form.InheritsFrom(TForm) then
|
|
AddClass(Form.ClassType, 'TForm')
|
|
else if Form.InheritsFrom(TDataModule) then
|
|
AddClass(Form.ClassType, 'TDataModule')
|
|
{$IFNDEF FMX}
|
|
{$IFDEF Delphi5}
|
|
else if Form.InheritsFrom(TFrame) then
|
|
AddClass(Form.ClassType, 'TFrame')
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
else
|
|
Exit;
|
|
v := FindClass(Form.ClassName);
|
|
end;
|
|
|
|
for i := 0 to Form.ComponentCount - 1 do
|
|
v.AddComponent(Form.Components[i]);
|
|
AddObject(Form.Name, Form);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TfsScript.AddRTTI;
|
|
var
|
|
i: Integer;
|
|
rtti: TfsRTTIModule;
|
|
obj: TClass;
|
|
begin
|
|
if FRTTIAdded then Exit;
|
|
|
|
AddedBy := TObject(1); // do not clear
|
|
for i := 0 to FRTTIModules.Count - 1 do
|
|
begin
|
|
obj := TClass(FRTTIModules[i]);
|
|
rtti := TfsRTTIModule(obj.NewInstance);
|
|
rtti.Create(Self);
|
|
Add('', rtti);
|
|
end;
|
|
AddedBy := nil;
|
|
|
|
FRTTIAdded := True;
|
|
end;
|
|
|
|
procedure TfsScript.ClearRTTI;
|
|
var
|
|
i: Integer;
|
|
item: TObject;
|
|
begin
|
|
if not FRTTIAdded then Exit;
|
|
|
|
i := 0;
|
|
while i < FItems.Count do
|
|
begin
|
|
item := FItems.Objects[i];
|
|
if (item is TfsRTTIModule) or
|
|
((item is TfsCustomVariable) and
|
|
(TfsCustomVariable(item).AddedBy = TObject(1))) then
|
|
begin
|
|
item.Free;
|
|
FItems.Delete(i);
|
|
end
|
|
else
|
|
Inc(i);
|
|
end;
|
|
|
|
FRTTIAdded := False;
|
|
end;
|
|
|
|
function TfsScript.CallFunction(const Name: String; const Params: Variant; sGlobal: Boolean): Variant;
|
|
var
|
|
i, StackIndex: Integer;
|
|
v: TfsCustomVariable;
|
|
p: TfsProcVariable;
|
|
begin
|
|
if sGlobal then
|
|
v := Find(Name)
|
|
else
|
|
v := FindLocal(Name);
|
|
if (v <> nil) and (v is TfsProcVariable) then
|
|
begin
|
|
p := TfsProcVariable(v);
|
|
|
|
StackIndex := -1;
|
|
if p.Executing then
|
|
StackIndex := p.SaveLocalVariables;
|
|
try
|
|
if VarIsArray(Params) then
|
|
for i := 0 to VarArrayHighBound(Params, 1) do
|
|
p.Params[i].Value := Params[i];
|
|
Result := p.Value;
|
|
finally
|
|
p.RestoreLocalVariables(StackIndex, True);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
Result := Null;
|
|
end
|
|
end;
|
|
|
|
function TfsScript.CallFunction1(const Name: String; var Params: Variant; sGlobal: Boolean): Variant;
|
|
var
|
|
i, StackIndex: Integer;
|
|
v: TfsCustomVariable;
|
|
p: TfsProcVariable;
|
|
begin
|
|
if sGlobal then
|
|
v := Find(Name)
|
|
else
|
|
v := FindLocal(Name);
|
|
if (v <> nil) and (v is TfsProcVariable) then
|
|
begin
|
|
p := TfsProcVariable(v);
|
|
|
|
StackIndex := -1;
|
|
if p.Executing then
|
|
StackIndex := p.SaveLocalVariables;
|
|
try
|
|
if VarIsArray(Params) then
|
|
for i := 0 to VarArrayHighBound(Params, 1) do
|
|
p.Params[i].Value := Params[i];
|
|
Result := p.Value;
|
|
if VarIsArray(Params) then
|
|
for i := 0 to VarArrayHighBound(Params, 1) do
|
|
Params[i] := p.Params[i].Value;
|
|
finally
|
|
p.RestoreLocalVariables(StackIndex, True);
|
|
end;
|
|
end
|
|
else
|
|
Result := Null;
|
|
end;
|
|
|
|
function TfsScript.CallFunction2(const Func: TfsProcVariable; const Params: Variant): Variant;
|
|
var
|
|
i, StackIndex: Integer;
|
|
begin
|
|
if (Func <> nil) then
|
|
begin
|
|
StackIndex := -1;
|
|
if Func.Executing then
|
|
StackIndex := Func.SaveLocalVariables;
|
|
try
|
|
if VarIsArray(Params) then
|
|
for i := 0 to VarArrayHighBound(Params, 1) do
|
|
Func.Params[i].Value := Params[i];
|
|
Result := Func.Value;
|
|
finally
|
|
Func.RestoreLocalVariables(StackIndex, True);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
Result := Null;
|
|
end
|
|
end;
|
|
|
|
function TfsScript.Evaluate(const Expression: String): Variant;
|
|
var
|
|
p: TfsScript;
|
|
Prog: TfsScript;
|
|
SaveEvent: TfsRunLineEvent;
|
|
begin
|
|
FEvaluteRiseError := False;
|
|
Result := Null;
|
|
if FProgRunning = nil then
|
|
p := Self else
|
|
p := FProgRunning;
|
|
|
|
Prog := TfsScript.Create(nil);
|
|
if not p.FRTTIAdded then
|
|
Prog.AddRTTI;
|
|
Prog.Parent := p;
|
|
Prog.OnGetVarValue := p.OnGetVarValue;
|
|
SaveEvent := FOnRunLine;
|
|
FOnRunLine := nil;
|
|
try
|
|
prog.SyntaxType := SyntaxType;
|
|
if CompareText(SyntaxType, 'PascalScript') = 0 then
|
|
Prog.Lines.Text := 'function fsEvaluateFUNC: Variant; begin Result := ' + Expression + ' end; begin end.'
|
|
else if CompareText(SyntaxType, 'C++Script') = 0 then
|
|
Prog.Lines.Text := 'Variant fsEvaluateFUNC() { return ' + Expression + '; } {}'
|
|
else if CompareText(SyntaxType, 'BasicScript') = 0 then
|
|
Prog.Lines.Text := 'function fsEvaluateFUNC' + #13#10 + 'return ' + Expression + #13#10 + 'end function'
|
|
else if CompareText(SyntaxType, 'JScript') = 0 then
|
|
Prog.Lines.Text := 'function fsEvaluateFUNC() { return (' + Expression + '); }';
|
|
if not Prog.Compile then
|
|
begin
|
|
Result := Prog.ErrorMsg;
|
|
FEvaluteRiseError := True;
|
|
end
|
|
else
|
|
Result := Prog.FindLocal('fsEvaluateFUNC').Value;
|
|
finally
|
|
Prog.Free;
|
|
FOnRunLine := SaveEvent;
|
|
end;
|
|
end;
|
|
|
|
function TfsScript.FindClass(const Name: String): TfsClassVariable;
|
|
var
|
|
Item: TfsCustomVariable;
|
|
begin
|
|
Item := Find(Name);
|
|
if (Item <> nil) and (Item is TfsClassVariable) then
|
|
Result := TfsClassVariable(Item) else
|
|
Result := nil
|
|
end;
|
|
|
|
procedure TfsScript.RunLine(const UnitName, Index: String);
|
|
var
|
|
p: TfsScript;
|
|
begin
|
|
p := Self;
|
|
while p <> nil do
|
|
if Assigned(p.FOnRunLine) then
|
|
begin
|
|
p.FOnRunLine(Self, UnitName, Index);
|
|
break;
|
|
end
|
|
else
|
|
p := p.FParent;
|
|
end;
|
|
|
|
function TfsScript.GetVariables(Index: String): Variant;
|
|
var
|
|
v: TfsCustomVariable;
|
|
begin
|
|
v := Find(Index);
|
|
if v <> nil then
|
|
Result := v.Value else
|
|
Result := Null;
|
|
end;
|
|
|
|
procedure TfsScript.SetVariables(Index: String; const Value: Variant);
|
|
var
|
|
v: TfsCustomVariable;
|
|
begin
|
|
v := Find(Index);
|
|
if v <> nil then
|
|
v.Value := Value else
|
|
AddVariable(Index, 'Variant', Value);
|
|
end;
|
|
|
|
procedure TfsScript.SetLines(const Value: TStrings);
|
|
begin
|
|
FLines.Assign(Value);
|
|
end;
|
|
|
|
procedure TfsScript.SetProgName(const Value: String);
|
|
begin
|
|
if Assigned(FProgRunning) then
|
|
FProgRunning.FProgName := Value
|
|
else
|
|
FProgName := Value;
|
|
end;
|
|
|
|
procedure TfsScript.Terminate;
|
|
|
|
procedure TerminateAll(Script: TfsScript);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Script.FExitCalled := True;
|
|
Script.FTerminated := True;
|
|
for i := 0 to Script.Count - 1 do
|
|
if Script.Items[i] is TfsProcVariable then
|
|
TerminateAll(TfsProcVariable(Script.Items[i]).Prog);
|
|
end;
|
|
|
|
begin
|
|
TerminateAll(Self);
|
|
end;
|
|
|
|
procedure TfsScript.AddCodeLine(const UnitName, APos: String);
|
|
var
|
|
sl: TStringList;
|
|
LineN: String;
|
|
i : Integer;
|
|
begin
|
|
i := FUnitLines.IndexOf(UnitName);
|
|
|
|
if (i = -1) then
|
|
begin
|
|
sl := TStringList.Create;
|
|
sl.Sorted := True;
|
|
FUnitLines.AddObject(UnitName, sl);
|
|
end else
|
|
begin
|
|
sl := TStringList(FUnitLines.Objects[i]);
|
|
end;
|
|
|
|
LineN := Copy(APos, 1, Pos(':', APos) - 1);
|
|
if sl.IndexOf(LineN) = -1 then
|
|
begin
|
|
sl.Add(LineN);
|
|
end;
|
|
end;
|
|
|
|
function TfsScript.IsExecutableLine(LineN: Integer; const UnitName: String = ''): Boolean;
|
|
var
|
|
sl: TStringList;
|
|
i: Integer;
|
|
begin
|
|
Result := False;
|
|
|
|
i := FUnitLines.IndexOf(UnitName);
|
|
if (i = -1) then Exit;
|
|
|
|
sl := TStringList(FUnitLines.Objects[i]);
|
|
if sl.IndexOf(IntToStr(LineN)) <> -1 then
|
|
Result := True;
|
|
end;
|
|
|
|
|
|
|
|
|
|
{ TfsStatement }
|
|
|
|
constructor TfsStatement.Create(AProgram: TfsScript; const UnitName,
|
|
SourcePos: String);
|
|
begin
|
|
inherited Create;
|
|
FProgram := AProgram;
|
|
FSourcePos := SourcePos;
|
|
FUnitName := UnitName;
|
|
end;
|
|
|
|
function TfsStatement.GetItem(Index: Integer): TfsStatement;
|
|
begin
|
|
Result := FItems[Index];
|
|
end;
|
|
|
|
procedure TfsStatement.Execute;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
FProgram.ErrorPos := '';
|
|
for i := 0 to Count - 1 do
|
|
begin
|
|
if FProgram.FTerminated then break;
|
|
try
|
|
FProgram.FLastSourcePos := Items[i].FSourcePos;
|
|
Items[i].Execute;
|
|
except
|
|
on E: Exception do
|
|
begin
|
|
if FProgram.ErrorPos = '' then
|
|
FProgram.ErrorPos := FProgram.FLastSourcePos;
|
|
raise;
|
|
end;
|
|
end;
|
|
if FProgram.FBreakCalled or FProgram.FContinueCalled or
|
|
FProgram.FExitCalled then break;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsStatement.RunLine;
|
|
begin
|
|
FProgram.RunLine(FUnitName, FSourcePos);
|
|
end;
|
|
|
|
|
|
{ TfsAssignmentStmt }
|
|
|
|
destructor TfsAssignmentStmt.Destroy;
|
|
begin
|
|
FDesignator.Free;
|
|
FExpression.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TfsAssignmentStmt.Optimize;
|
|
begin
|
|
FVar := FDesignator;
|
|
FExpr := FExpression;
|
|
|
|
if FDesignator is TfsVariableDesignator then
|
|
FVar := FDesignator.RefItem;
|
|
if TfsExpression(FExpression).SingleItem <> nil then
|
|
FExpr := TfsExpression(FExpression).SingleItem;
|
|
end;
|
|
|
|
procedure TfsAssignmentStmt.Execute;
|
|
begin
|
|
RunLine;
|
|
if FProgram.FTerminated then Exit;
|
|
FVar.Value := FExpr.Value;
|
|
end;
|
|
|
|
procedure TfsAssignPlusStmt.Execute;
|
|
begin
|
|
RunLine;
|
|
if FProgram.FTerminated then Exit;
|
|
FVar.Value := FVar.Value + FExpr.Value;
|
|
end;
|
|
|
|
procedure TfsAssignMinusStmt.Execute;
|
|
begin
|
|
RunLine;
|
|
if FProgram.FTerminated then Exit;
|
|
FVar.Value := FVar.Value - FExpr.Value;
|
|
end;
|
|
|
|
procedure TfsAssignMulStmt.Execute;
|
|
begin
|
|
RunLine;
|
|
if FProgram.FTerminated then Exit;
|
|
FVar.Value := FVar.Value * FExpr.Value;
|
|
end;
|
|
|
|
procedure TfsAssignDivStmt.Execute;
|
|
begin
|
|
RunLine;
|
|
if FProgram.FTerminated then Exit;
|
|
FVar.Value := FVar.Value / FExpr.Value;
|
|
end;
|
|
|
|
|
|
{ TfsCallStmt }
|
|
|
|
destructor TfsCallStmt.Destroy;
|
|
begin
|
|
FDesignator.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TfsCallStmt.Execute;
|
|
begin
|
|
RunLine;
|
|
if FProgram.FTerminated then Exit;
|
|
if FModificator = '' then
|
|
begin
|
|
FDesignator.NeedResult := False;
|
|
FDesignator.Value;
|
|
end
|
|
else if FModificator = '+' then
|
|
FDesignator.Value := FDesignator.Value + 1
|
|
else if FModificator = '-' then
|
|
FDesignator.Value := FDesignator.Value - 1
|
|
end;
|
|
|
|
|
|
{ TfsIfStmt }
|
|
|
|
constructor TfsIfStmt.Create(AProgram: TfsScript; const UnitName,
|
|
SourcePos: String);
|
|
begin
|
|
inherited;
|
|
FElseStmt := TfsStatement.Create(FProgram, UnitName, SourcePos);
|
|
end;
|
|
|
|
destructor TfsIfStmt.Destroy;
|
|
begin
|
|
FCondition.Free;
|
|
FElseStmt.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TfsIfStmt.Execute;
|
|
begin
|
|
RunLine;
|
|
if FProgram.FTerminated then Exit;
|
|
if Boolean(FCondition.Value) = True then
|
|
inherited Execute else
|
|
FElseStmt.Execute;
|
|
end;
|
|
|
|
|
|
{ TfsRepeatStmt }
|
|
|
|
destructor TfsRepeatStmt.Destroy;
|
|
begin
|
|
FCondition.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TfsRepeatStmt.Execute;
|
|
begin
|
|
RunLine;
|
|
if FProgram.FTerminated then Exit;
|
|
|
|
repeat
|
|
inherited Execute;
|
|
if FProgram.FBreakCalled or FProgram.FExitCalled then break;
|
|
FProgram.FContinueCalled := False;
|
|
until Boolean(FCondition.Value) = not FInverseCondition;
|
|
|
|
FProgram.FBreakCalled := False;
|
|
end;
|
|
|
|
|
|
{ TfsWhileStmt }
|
|
|
|
destructor TfsWhileStmt.Destroy;
|
|
begin
|
|
FCondition.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TfsWhileStmt.Execute;
|
|
begin
|
|
RunLine;
|
|
if FProgram.FTerminated then Exit;
|
|
|
|
while Boolean(FCondition.Value) = True do
|
|
begin
|
|
inherited Execute;
|
|
if FProgram.FBreakCalled or FProgram.FExitCalled then break;
|
|
FProgram.FContinueCalled := False;
|
|
end;
|
|
|
|
FProgram.FBreakCalled := False;
|
|
end;
|
|
|
|
|
|
{ TfsForStmt }
|
|
|
|
destructor TfsForStmt.Destroy;
|
|
begin
|
|
FBeginValue.Free;
|
|
FEndValue.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TfsForStmt.Execute;
|
|
var
|
|
i, bValue, eValue: Integer;
|
|
begin
|
|
try
|
|
bValue := FBeginValue.Value;
|
|
eValue := FEndValue.Value;
|
|
finally
|
|
RunLine;
|
|
end;
|
|
if FProgram.FTerminated then Exit;
|
|
|
|
if FDown then
|
|
for i := bValue downto eValue do
|
|
begin
|
|
FVariable.FValue := i;
|
|
inherited Execute;
|
|
if FProgram.FBreakCalled or FProgram.FExitCalled then break;
|
|
FProgram.FContinueCalled := False;
|
|
end
|
|
else
|
|
for i := bValue to eValue do
|
|
begin
|
|
FVariable.FValue := i;
|
|
inherited Execute;
|
|
if FProgram.FBreakCalled or FProgram.FExitCalled then break;
|
|
FProgram.FContinueCalled := False;
|
|
end;
|
|
|
|
FProgram.FBreakCalled := False;
|
|
end;
|
|
|
|
|
|
{ TfsVbForStmt }
|
|
|
|
destructor TfsVbForStmt.Destroy;
|
|
begin
|
|
FBeginValue.Free;
|
|
FEndValue.Free;
|
|
if FStep <> nil then
|
|
FStep.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TfsVbForStmt.Execute;
|
|
var
|
|
i, bValue, eValue, sValue: Variant;
|
|
Down: Boolean;
|
|
begin
|
|
bValue := FBeginValue.Value;
|
|
eValue := FEndValue.Value;
|
|
if FStep <> nil then
|
|
sValue := FStep.Value else
|
|
sValue := 1;
|
|
Down := sValue < 0;
|
|
|
|
RunLine;
|
|
if FProgram.FTerminated then Exit;
|
|
i := bValue;
|
|
if Down then
|
|
while i >= eValue do
|
|
begin
|
|
FVariable.FValue := i;
|
|
inherited Execute;
|
|
if FProgram.FBreakCalled or FProgram.FExitCalled then break;
|
|
FProgram.FContinueCalled := False;
|
|
i := i + sValue;
|
|
end
|
|
else
|
|
while i <= eValue do
|
|
begin
|
|
FVariable.FValue := i;
|
|
inherited Execute;
|
|
if FProgram.FBreakCalled or FProgram.FExitCalled then break;
|
|
FProgram.FContinueCalled := False;
|
|
i := i + sValue;
|
|
end;
|
|
|
|
FProgram.FBreakCalled := False;
|
|
end;
|
|
|
|
|
|
{ TfsCppForStmt }
|
|
|
|
constructor TfsCppForStmt.Create(AProgram: TfsScript; const UnitName,
|
|
SourcePos: String);
|
|
begin
|
|
inherited;
|
|
FFirstStmt := TfsStatement.Create(FProgram, UnitName, SourcePos);
|
|
FSecondStmt := TfsStatement.Create(FProgram, UnitName, SourcePos);
|
|
end;
|
|
|
|
destructor TfsCppForStmt.Destroy;
|
|
begin
|
|
FFirstStmt.Free;
|
|
FExpression.Free;
|
|
FSecondStmt.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TfsCppForStmt.Execute;
|
|
begin
|
|
RunLine;
|
|
if FProgram.FTerminated then Exit;
|
|
FFirstStmt.Execute;
|
|
if FProgram.FTerminated then Exit;
|
|
while Boolean(FExpression.Value) = True do
|
|
begin
|
|
inherited Execute;
|
|
if FProgram.FBreakCalled or FProgram.FExitCalled then break;
|
|
FProgram.FContinueCalled := False;
|
|
FSecondStmt.Execute;
|
|
end;
|
|
|
|
FProgram.FBreakCalled := False;
|
|
end;
|
|
|
|
|
|
{ TfsCaseSelector }
|
|
|
|
destructor TfsCaseSelector.Destroy;
|
|
begin
|
|
FSetExpression.Free;
|
|
inherited;
|
|
end;
|
|
|
|
function TfsCaseSelector.Check(const Value: Variant): Boolean;
|
|
begin
|
|
Result := FSetExpression.Check(Value);
|
|
end;
|
|
|
|
|
|
{ TfsCaseStmt }
|
|
|
|
constructor TfsCaseStmt.Create(AProgram: TfsScript; const UnitName,
|
|
SourcePos: String);
|
|
begin
|
|
inherited;
|
|
FElseStmt := TfsStatement.Create(FProgram, UnitName, SourcePos);
|
|
end;
|
|
|
|
destructor TfsCaseStmt.Destroy;
|
|
begin
|
|
FCondition.Free;
|
|
FElseStmt.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TfsCaseStmt.Execute;
|
|
var
|
|
i: Integer;
|
|
Value: Variant;
|
|
Executed: Boolean;
|
|
begin
|
|
Value := FCondition.Value;
|
|
Executed := False;
|
|
|
|
RunLine;
|
|
if FProgram.FTerminated then Exit;
|
|
for i := 0 to Count - 1 do
|
|
if TfsCaseSelector(Items[i]).Check(Value) then
|
|
begin
|
|
Items[i].Execute;
|
|
Executed := True;
|
|
break;
|
|
end;
|
|
|
|
if not Executed then
|
|
FElseStmt.Execute;
|
|
end;
|
|
|
|
|
|
{ TfsTryStmt }
|
|
|
|
constructor TfsTryStmt.Create(AProgram: TfsScript; const UnitName,
|
|
SourcePos: String);
|
|
begin
|
|
inherited;
|
|
FExceptStmt := TfsStatement.Create(AProgram, UnitName, SourcePos);
|
|
end;
|
|
|
|
destructor TfsTryStmt.Destroy;
|
|
begin
|
|
FExceptStmt.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TfsTryStmt.Execute;
|
|
var
|
|
SaveExitCalled: Boolean;
|
|
begin
|
|
RunLine;
|
|
if FProgram.FTerminated then Exit;
|
|
if IsExcept then
|
|
begin
|
|
try
|
|
inherited Execute;
|
|
except
|
|
on E: Exception do
|
|
begin
|
|
FProgram.SetVariables('ExceptionClassName', E.ClassName);
|
|
FProgram.SetVariables('ExceptionMessage', E.Message);
|
|
FProgram.ErrorPos := FProgram.FLastSourcePos;
|
|
ExceptStmt.Execute;
|
|
end;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
try
|
|
inherited Execute;
|
|
finally
|
|
SaveExitCalled := FProgram.FExitCalled;
|
|
FProgram.FExitCalled := False;
|
|
ExceptStmt.Execute;
|
|
FProgram.FExitCalled := SaveExitCalled;
|
|
end
|
|
end;
|
|
end;
|
|
|
|
{ TfsBreakStmt }
|
|
|
|
procedure TfsBreakStmt.Execute;
|
|
begin
|
|
FProgram.FBreakCalled := True;
|
|
end;
|
|
|
|
|
|
{ TfsContinueStmt }
|
|
|
|
procedure TfsContinueStmt.Execute;
|
|
begin
|
|
FProgram.FContinueCalled := True;
|
|
end;
|
|
|
|
|
|
{ TfsExitStmt }
|
|
|
|
procedure TfsExitStmt.Execute;
|
|
begin
|
|
RunLine;
|
|
FProgram.FExitCalled := True;
|
|
end;
|
|
|
|
|
|
{ TfsWithStmt }
|
|
|
|
destructor TfsWithStmt.Destroy;
|
|
begin
|
|
FDesignator.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TfsWithStmt.Execute;
|
|
begin
|
|
inherited;
|
|
FVariable.Value := FDesignator.Value;
|
|
end;
|
|
|
|
|
|
{ TfsArrayHelper }
|
|
|
|
constructor TfsArrayHelper.Create(const AName: String; DimCount: Integer;
|
|
Typ: TfsVarType; const TypeName: String);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
inherited Create(AName, Typ, TypeName);
|
|
|
|
if DimCount <> -1 then
|
|
begin
|
|
for i := 0 to DimCount - 1 do
|
|
{$IFDEF CPUX64}
|
|
Add(TfsParamItem.Create('', fvtInt64, '', False, False));
|
|
{$ELSE}
|
|
Add(TfsParamItem.Create('', fvtInt, '', False, False));
|
|
{$ENDIF}
|
|
end
|
|
else
|
|
for i := 0 to 2 do
|
|
{$IFDEF CPUX64}
|
|
Add(TfsParamItem.Create('', fvtInt64, '', i > 0, False));
|
|
{$ELSE}
|
|
Add(TfsParamItem.Create('', fvtInt, '', i > 0, False));
|
|
{$ENDIF}
|
|
end;
|
|
|
|
destructor TfsArrayHelper.Destroy;
|
|
begin
|
|
inherited;
|
|
end;
|
|
|
|
function TfsArrayHelper.GetValue: Variant;
|
|
var
|
|
DimCount: Integer;
|
|
begin
|
|
DimCount := VarArrayDimCount(ParentRef.PValue^);
|
|
case DimCount of
|
|
1: Result := ParentRef.PValue^[Params[0].Value];
|
|
2: Result := ParentRef.PValue^[Params[0].Value, Params[1].Value];
|
|
3: Result := ParentRef.PValue^[Params[0].Value, Params[1].Value, Params[2].Value];
|
|
else
|
|
Result := Null;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsArrayHelper.SetValue(const Value: Variant);
|
|
var
|
|
DimCount: Integer;
|
|
begin
|
|
DimCount := VarArrayDimCount(ParentRef.PValue^);
|
|
case DimCount of
|
|
1: ParentRef.PValue^[Params[0].Value] := Value;
|
|
2: ParentRef.PValue^[Params[0].Value, Params[1].Value] := Value;
|
|
3: ParentRef.PValue^[Params[0].Value, Params[1].Value, Params[2].Value] := Value;
|
|
end;
|
|
end;
|
|
|
|
|
|
{ TfsStringHelper }
|
|
|
|
constructor TfsStringHelper.Create;
|
|
begin
|
|
inherited Create('__StringHelper', fvtChar, '');
|
|
Add(TfsParamItem.Create('', fvtInt, '', False, False));
|
|
end;
|
|
|
|
function TfsStringHelper.GetValue: Variant;
|
|
begin
|
|
Result := String(ParentValue)[Integer(Params[0].Value)];
|
|
end;
|
|
|
|
procedure TfsStringHelper.SetValue(const Value: Variant);
|
|
var
|
|
s: String;
|
|
begin
|
|
s := ParentValue;
|
|
s[Integer(Params[0].Value)] := String(Value)[1];
|
|
TfsCustomVariable(frxInteger(ParentRef)).Value := s;
|
|
end;
|
|
|
|
|
|
{ TfsCustomEvent }
|
|
|
|
constructor TfsCustomEvent.Create(AObject: TObject; AHandler: TfsProcVariable);
|
|
begin
|
|
FInstance := AObject;
|
|
FHandler := AHandler;
|
|
end;
|
|
|
|
procedure TfsCustomEvent.CallHandler(Params: array of const);
|
|
var
|
|
i, StackIndex: Integer;
|
|
begin
|
|
StackIndex := -1;
|
|
if FHandler.Executing then
|
|
StackIndex := FHandler.SaveLocalVariables;
|
|
try
|
|
for i := 0 to FHandler.Count - 1 do
|
|
FHandler.Params[i].Value := VarRecToVariant(Params[i]);
|
|
FHandler.Value;
|
|
finally
|
|
FHandler.RestoreLocalVariables(StackIndex, True);
|
|
end;
|
|
end;
|
|
|
|
|
|
{ TfsRTTIModule }
|
|
|
|
constructor TfsRTTIModule.Create(AScript: TfsScript);
|
|
begin
|
|
FScript := AScript;
|
|
end;
|
|
|
|
|
|
function fsGlobalUnit: TfsScript;
|
|
begin
|
|
if (FGlobalUnit = nil) and not FGlobalUnitDestroyed then
|
|
begin
|
|
FGlobalUnit := TfsScript.Create(nil);
|
|
FGlobalUnit.AddRTTI;
|
|
end;
|
|
Result := FGlobalUnit;
|
|
end;
|
|
|
|
function fsIsGlobalUnitExist: Boolean;
|
|
begin
|
|
Result := Assigned(FGlobalUnit);
|
|
end;
|
|
|
|
function fsRTTIModules: TList;
|
|
begin
|
|
if (FRTTIModules = nil) and not FRTTIModulesDestroyed then
|
|
begin
|
|
FRTTIModules := TList.Create;
|
|
FRTTIModules.Add(TfsSysFunctions);
|
|
end;
|
|
Result := FRTTIModules;
|
|
end;
|
|
|
|
{ TfsVariable }
|
|
|
|
function TfsVariable.GetValue: Variant;
|
|
begin
|
|
Result := inherited GetValue;
|
|
if Assigned(FOnGetVarValue) then
|
|
begin
|
|
Result := FOnGetVarValue(FName, FTyp, FValue);
|
|
if Result = null then Result := FValue;
|
|
end;
|
|
end;
|
|
|
|
procedure TfsVariable.SetValue(const Value: Variant);
|
|
begin
|
|
if not FIsReadOnly then
|
|
case FTyp of
|
|
fvtInt: FValue := VarAsType(Value, varInteger);
|
|
{$IFDEF FS_INT64}
|
|
fvtInt64: FValue := VarAsType(Value, varInt64);
|
|
{$ENDIF}
|
|
fvtBool: FValue := VarAsType(Value, varBoolean);
|
|
fvtFloat:
|
|
if (VarType(Value) = varDate) then
|
|
FValue := VarAsType(Value, varDate)
|
|
else
|
|
FValue := VarAsType(Value, varDouble);
|
|
{$IFDEF Delphi12}
|
|
fvtString: FValue := VarAsType(Value, varUString);
|
|
{$ELSE}
|
|
fvtString: FValue := VarAsType(Value, varString);
|
|
{$ENDIF}
|
|
else
|
|
FValue := Value;
|
|
end;
|
|
end;
|
|
|
|
initialization
|
|
{$IFDEF FMX}
|
|
StartClassGroup(TFmxObject);
|
|
ActivateClassGroup(TFmxObject);
|
|
GroupDescendentsWith(TfsScript, TFmxObject);
|
|
{$ELSE}
|
|
{$IFDEF Delphi16}
|
|
StartClassGroup(TControl);
|
|
ActivateClassGroup(TControl);
|
|
GroupDescendentsWith(TfsScript, TControl);
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
FGlobalUnitDestroyed := False;
|
|
FRTTIModulesDestroyed := False;
|
|
fsRTTIModules;
|
|
|
|
finalization
|
|
if FGlobalUnit <> nil then
|
|
FGlobalUnit.Free;
|
|
FGlobalUnit := nil;
|
|
FGlobalUnitDestroyed := True;
|
|
FRTTIModules.Free;
|
|
FRTTIModules := nil;
|
|
FRTTIModulesDestroyed := True;
|
|
|
|
end. |