PageRenderTime 33ms CodeModel.GetById 18ms RepoModel.GetById 1ms app.codeStats 0ms

/Components/FastReport3/FastScript/fs_iinterpreter.pas

http://github.com/mitshel/tech-inv
Pascal | 2621 lines | 2060 code | 377 blank | 184 comment | 166 complexity | 072a256b3caa9dbc8c728e8031521295 MD5 | raw file
Possible License(s): AGPL-3.0
  1. {******************************************}
  2. { }
  3. { FastScript v1.7 }
  4. { Main module }
  5. { }
  6. { (c) 2003, 2004 by Alexander Tzyganenko, }
  7. { Fast Reports, Inc }
  8. { }
  9. {******************************************}
  10. unit fs_iinterpreter;
  11. interface
  12. {$I fs.inc}
  13. uses
  14. SysUtils, Classes, fs_xml
  15. {$IFDEF Delphi6}
  16. , Variants
  17. {$ENDIF};
  18. type
  19. TfsStatement = class;
  20. TfsDesignator = class;
  21. TfsCustomVariable = class;
  22. TfsClassVariable = class;
  23. TfsScript = class;
  24. { List of supported types. Actually all values are variants; types needed
  25. only to know what kind of operations can be implemented to the variable }
  26. TfsVarType = (fvtInt, fvtBool, fvtFloat, fvtChar, fvtString, fvtClass,
  27. fvtArray, fvtVariant, fvtEnum, fvtConstructor);
  28. TfsTypeRec = record
  29. Typ: TfsVarType;
  30. TypeName: String[32];
  31. end;
  32. { Events for get/set non-published property values and call methods }
  33. TfsGetValueEvent = function(Instance: TObject; ClassType: TClass;
  34. const PropName: String): Variant of object;
  35. TfsSetValueEvent = procedure(Instance: TObject; ClassType: TClass;
  36. const PropName: String; Value: Variant) of object;
  37. TfsCallMethodEvent = function(Instance: TObject; ClassType: TClass;
  38. const MethodName: String; var Params: Variant): Variant of object;
  39. TfsRunLineEvent = procedure(Sender: TfsScript;
  40. const UnitName, SourcePos: String) of object;
  41. TfsGetUnitEvent = procedure(Sender: TfsScript;
  42. const UnitName: String; var UnitText: String) of object;
  43. { List of objects. Unlike TList, Destructor frees all objects in the list }
  44. TfsItemList = class(TObject)
  45. protected
  46. FItems: TList;
  47. public
  48. constructor Create;
  49. destructor Destroy; override;
  50. procedure Clear; virtual;
  51. function Count: Integer;
  52. procedure Add(Item: TObject);
  53. procedure Remove(Item: TObject);
  54. end;
  55. { TfsScript represents the main script. It holds the list of local variables,
  56. constants, procedures in the Items. Entry point is the Statement.
  57. There is one global object fsGlobalUnit: TfsScript that holds all information
  58. about external classes, global variables, methods and constants. To use
  59. such globals, pass fsGlobalUnit to the TfsScript.Create.
  60. If you want, you can add classes/variables/methods to the TfsScript - they
  61. will be local for it and not visible in other programs.
  62. To execute a program, compile it first by calling Compile method. If error
  63. occurs, the ErrorMsg will contain the error message and ErrorPos will point
  64. to an error position in the source text. For example:
  65. if not Prg.Compile then
  66. begin
  67. ErrorLabel.Caption := Prg.ErrorMsg;
  68. Memo1.SetFocus;
  69. Memo1.Perform(EM_SETSEL, Prg.ErrorPos - 1, Prg.ErrorPos - 1);
  70. Memo1.Perform(EM_SCROLLCARET, 0, 0);
  71. end;
  72. If no errors occured, call Execute method to execute the program }
  73. TfsScript = class(TComponent)
  74. private
  75. FAddedBy: TObject;
  76. FBreakCalled: Boolean;
  77. FContinueCalled: Boolean;
  78. FExitCalled: Boolean;
  79. FErrorMsg: String;
  80. FErrorPos: String;
  81. FErrorUnit: String;
  82. FItems: TList;
  83. FIsRunning: Boolean;
  84. FLines: TStrings;
  85. FOnGetILUnit: TfsGetUnitEvent;
  86. FOnGetUnit: TfsGetUnitEvent;
  87. FOnRunLine: TfsRunLineEvent;
  88. FParent: TfsScript;
  89. FProgRunning: TfsScript;
  90. FStatement: TfsStatement;
  91. FSyntaxType: String;
  92. FTerminated: Boolean;
  93. FUnitLines: TStringList;
  94. function GetItem(Index: Integer): TfsCustomVariable;
  95. procedure RunLine(const UnitName, Index: String);
  96. function GetVariables(Index: String): Variant;
  97. procedure SetVariables(Index: String; const Value: Variant);
  98. procedure SetLines(const Value: TStrings);
  99. public
  100. constructor Create(AOwner: TComponent); override;
  101. destructor Destroy; override;
  102. procedure Add(Item: TObject);
  103. procedure AddCodeLine(const UnitName, APos: String);
  104. procedure Remove(Item: TObject);
  105. procedure RemoveItems(Owner: TObject);
  106. procedure Clear;
  107. function Count: Integer;
  108. { Adds a class. Example:
  109. with AddClass(TComponent, 'TPersistent') do
  110. begin
  111. ... add properties and methods ...
  112. end }
  113. function AddClass(AClass: TClass; const Ancestor: String): TfsClassVariable;
  114. { Adds a constant. Example:
  115. AddConst('pi', 'Double', 3.14159) }
  116. procedure AddConst(const Name, Typ: String; const Value: Variant);
  117. { Adds an enumeration constant. Example:
  118. AddEnum('TFontPitch', 'fpDefault, fpFixed, fpVariable')
  119. all constants gets type fvtEnum and values 0,1,2,3.. }
  120. procedure AddEnum(const Typ, Names: String);
  121. { Adds an set constant. Example:
  122. AddEnumSet('TFontStyles', 'fsBold, fsItalic, fsUnderline')
  123. all constants gets type fvtEnum and values 1,2,4,8,.. }
  124. procedure AddEnumSet(const Typ, Names: String);
  125. { Adds a form or datamodule with all its child components }
  126. procedure AddComponent(Form: TComponent);
  127. procedure AddForm(Form: TComponent);
  128. { Adds a method. Syntax is the same as for TfsClassVariable.AddMethod }
  129. procedure AddMethod(const Syntax: String; CallEvent: TfsCallMethodEvent;
  130. const Category: String = ''; const Description: String = '');
  131. { Adds an external object. Example:
  132. AddObject('Memo1', Memo1) }
  133. procedure AddObject(const Name: String; Obj: TObject);
  134. { Adds a variable. Example:
  135. AddVariable('n', 'Variant', 0) }
  136. procedure AddVariable(const Name, Typ: String; const Value: Variant);
  137. { Adds a type. Example:
  138. AddType('TDateTime', fvtFloat) }
  139. procedure AddType(const TypeName: String; ParentType: TfsVarType);
  140. { Calls internal procedure or function. Example:
  141. val := CallFunction('ScriptFunc1', VarArrayOf([2003, 3])) }
  142. function CallFunction(const Name: String; const Params: Variant): Variant;
  143. function CallFunction1(const Name: String; var Params: Variant): Variant;
  144. { Compiles the source code. Example:
  145. Lines.Text := 'begin i := 0 end.';
  146. SyntaxType := 'PascalScript';
  147. if Compile then ... }
  148. function Compile: Boolean;
  149. { Executes compiled code }
  150. procedure Execute;
  151. { Same as if Compile then Execute. Returns False if compile failed }
  152. function Run: Boolean;
  153. { terminates the script }
  154. procedure Terminate;
  155. { Evaluates an expression (useful for debugging purposes). Example:
  156. val := Evaluate('i+1'); }
  157. function Evaluate(const Expression: String): Variant;
  158. { checks whether is the line is executable }
  159. function IsExecutableLine(LineN: Integer; const UnitName: String = ''): Boolean;
  160. { Generates intermediate language. You can save it and compile later
  161. by SetILCode method }
  162. function GetILCode(Stream: TStream): Boolean;
  163. { Compiles intermediate language }
  164. function SetILCode(Stream: TStream): Boolean;
  165. function Find(const Name: String): TfsCustomVariable;
  166. function FindClass(const Name: String): TfsClassVariable;
  167. function FindLocal(const Name: String): TfsCustomVariable;
  168. property AddedBy: TObject read FAddedBy write FAddedBy;
  169. property ErrorMsg: String read FErrorMsg write FErrorMsg;
  170. property ErrorPos: String read FErrorPos write FErrorPos;
  171. property ErrorUnit: String read FErrorUnit write FErrorUnit;
  172. property Items[Index: Integer]: TfsCustomVariable read GetItem;
  173. property IsRunning: Boolean read FIsRunning;
  174. property Parent: TfsScript read FParent write FParent;
  175. property Statement: TfsStatement read FStatement;
  176. property Variables[Index: String]: Variant read GetVariables write SetVariables;
  177. published
  178. { the source code }
  179. property Lines: TStrings read FLines write SetLines;
  180. { the language name }
  181. property SyntaxType: String read FSyntaxType write FSyntaxType;
  182. property OnGetILUnit: TfsGetUnitEvent read FOnGetILUnit write FOnGetILUnit;
  183. property OnGetUnit: TfsGetUnitEvent read FOnGetUnit write FOnGetUnit;
  184. property OnRunLine: TfsRunLineEvent read FOnRunLine write FOnRunLine;
  185. end;
  186. TfsCustomExpression = class;
  187. TfsSetExpression = class;
  188. { Statements }
  189. TfsStatement = class(TfsItemList)
  190. private
  191. FProgram: TfsScript;
  192. FSourcePos: String;
  193. FUnitName: String;
  194. function GetItem(Index: Integer): TfsStatement;
  195. procedure RunLine;
  196. public
  197. constructor Create(AProgram: TfsScript; const UnitName, SourcePos: String); virtual;
  198. procedure Execute; virtual;
  199. property Items[Index: Integer]: TfsStatement read GetItem;
  200. end;
  201. TfsAssignmentStmt = class(TfsStatement)
  202. private
  203. FDesignator: TfsDesignator;
  204. FExpression: TfsCustomExpression;
  205. FVar: TfsCustomVariable;
  206. FExpr: TfsCustomVariable;
  207. public
  208. destructor Destroy; override;
  209. procedure Execute; override;
  210. procedure Optimize;
  211. property Designator: TfsDesignator read FDesignator write FDesignator;
  212. property Expression: TfsCustomExpression read FExpression write FExpression;
  213. end;
  214. TfsAssignPlusStmt = class(TfsAssignmentStmt)
  215. public
  216. procedure Execute; override;
  217. end;
  218. TfsAssignMinusStmt = class(TfsAssignmentStmt)
  219. public
  220. procedure Execute; override;
  221. end;
  222. TfsAssignMulStmt = class(TfsAssignmentStmt)
  223. public
  224. procedure Execute; override;
  225. end;
  226. TfsAssignDivStmt = class(TfsAssignmentStmt)
  227. public
  228. procedure Execute; override;
  229. end;
  230. TfsCallStmt = class(TfsStatement)
  231. private
  232. FDesignator: TfsDesignator;
  233. FModificator: String;
  234. public
  235. destructor Destroy; override;
  236. procedure Execute; override;
  237. property Designator: TfsDesignator read FDesignator write FDesignator;
  238. property Modificator: String read FModificator write FModificator;
  239. end;
  240. TfsIfStmt = class(TfsStatement)
  241. private
  242. FCondition: TfsCustomExpression;
  243. FElseStmt: TfsStatement;
  244. public
  245. constructor Create(AProgram: TfsScript; const UnitName, SourcePos: String); override;
  246. destructor Destroy; override;
  247. procedure Execute; override;
  248. property Condition: TfsCustomExpression read FCondition write FCondition;
  249. property ElseStmt: TfsStatement read FElseStmt write FElseStmt;
  250. end;
  251. TfsCaseSelector = class(TfsStatement)
  252. private
  253. FSetExpression: TfsSetExpression;
  254. public
  255. destructor Destroy; override;
  256. function Check(const Value: Variant): Boolean;
  257. property SetExpression: TfsSetExpression read FSetExpression write FSetExpression;
  258. end;
  259. TfsCaseStmt = class(TfsStatement)
  260. private
  261. FCondition: TfsCustomExpression;
  262. FElseStmt: TfsStatement;
  263. public
  264. constructor Create(AProgram: TfsScript; const UnitName, SourcePos: String); override;
  265. destructor Destroy; override;
  266. procedure Execute; override;
  267. property Condition: TfsCustomExpression read FCondition write FCondition;
  268. property ElseStmt: TfsStatement read FElseStmt write FElseStmt;
  269. end;
  270. TfsRepeatStmt = class(TfsStatement)
  271. private
  272. FCondition: TfsCustomExpression;
  273. FInverseCondition: Boolean;
  274. public
  275. destructor Destroy; override;
  276. procedure Execute; override;
  277. property Condition: TfsCustomExpression read FCondition write FCondition;
  278. property InverseCondition: Boolean read FInverseCondition write FInverseCondition;
  279. end;
  280. TfsWhileStmt = class(TfsStatement)
  281. private
  282. FCondition: TfsCustomExpression;
  283. public
  284. destructor Destroy; override;
  285. procedure Execute; override;
  286. property Condition: TfsCustomExpression read FCondition write FCondition;
  287. end;
  288. TfsForStmt = class(TfsStatement)
  289. private
  290. FBeginValue: TfsCustomExpression;
  291. FDown: Boolean;
  292. FEndValue: TfsCustomExpression;
  293. FVariable: TfsCustomVariable;
  294. public
  295. destructor Destroy; override;
  296. procedure Execute; override;
  297. property BeginValue: TfsCustomExpression read FBeginValue write FBeginValue;
  298. property Down: Boolean read FDown write FDown;
  299. property EndValue: TfsCustomExpression read FEndValue write FEndValue;
  300. property Variable: TfsCustomVariable read FVariable write FVariable;
  301. end;
  302. TfsVbForStmt = class(TfsStatement)
  303. private
  304. FBeginValue: TfsCustomExpression;
  305. FEndValue: TfsCustomExpression;
  306. FStep: TfsCustomExpression;
  307. FVariable: TfsCustomVariable;
  308. public
  309. destructor Destroy; override;
  310. procedure Execute; override;
  311. property BeginValue: TfsCustomExpression read FBeginValue write FBeginValue;
  312. property EndValue: TfsCustomExpression read FEndValue write FEndValue;
  313. property Step: TfsCustomExpression read FStep write FStep;
  314. property Variable: TfsCustomVariable read FVariable write FVariable;
  315. end;
  316. TfsCppForStmt = class(TfsStatement)
  317. private
  318. FFirstStmt: TfsStatement;
  319. FExpression: TfsCustomExpression;
  320. FSecondStmt: TfsStatement;
  321. public
  322. constructor Create(AProgram: TfsScript; const UnitName, SourcePos: String); override;
  323. destructor Destroy; override;
  324. procedure Execute; override;
  325. property FirstStmt: TfsStatement read FFirstStmt write FFirstStmt;
  326. property Expression: TfsCustomExpression read FExpression write FExpression;
  327. property SecondStmt: TfsStatement read FSecondStmt write FSecondStmt;
  328. end;
  329. TfsTryStmt = class(TfsStatement)
  330. private
  331. FIsExcept: Boolean;
  332. FExceptStmt: TfsStatement;
  333. public
  334. constructor Create(AProgram: TfsScript; const UnitName, SourcePos: String); override;
  335. destructor Destroy; override;
  336. procedure Execute; override;
  337. property IsExcept: Boolean read FIsExcept write FIsExcept;
  338. property ExceptStmt: TfsStatement read FExceptStmt write FExceptStmt;
  339. end;
  340. TfsBreakStmt = class(TfsStatement)
  341. public
  342. procedure Execute; override;
  343. end;
  344. TfsContinueStmt = class(TfsStatement)
  345. public
  346. procedure Execute; override;
  347. end;
  348. TfsExitStmt = class(TfsStatement)
  349. public
  350. procedure Execute; override;
  351. end;
  352. TfsWithStmt = class(TfsStatement)
  353. private
  354. FDesignator: TfsDesignator;
  355. FVariable: TfsCustomVariable;
  356. public
  357. destructor Destroy; override;
  358. procedure Execute; override;
  359. property Designator: TfsDesignator read FDesignator write FDesignator;
  360. property Variable: TfsCustomVariable read FVariable write FVariable;
  361. end;
  362. { TfsCustomVariable is the generic class for variables, constants, arrays,
  363. properties, methods and procedures/functions }
  364. TfsParamItem = class;
  365. TfsCustomVariable = class(TfsItemList)
  366. private
  367. FAddedBy: TObject;
  368. FIsReadOnly: Boolean;
  369. FName: String;
  370. FNeedResult: Boolean;
  371. FRefItem: TfsCustomVariable;
  372. FSourcePos: String;
  373. FTyp: TfsVarType;
  374. FTypeName: String;
  375. FValue: Variant;
  376. function GetParam(Index: Integer): TfsParamItem;
  377. function GetPValue: PVariant;
  378. protected
  379. procedure SetValue(const Value: Variant); virtual;
  380. function GetValue: Variant; virtual;
  381. public
  382. constructor Create(const AName: String; ATyp: TfsVarType;
  383. const ATypeName: String);
  384. function GetFullTypeName: String;
  385. function GetNumberOfRequiredParams: Integer;
  386. property AddedBy: TObject read FAddedBy;
  387. property IsReadOnly: Boolean read FIsReadOnly write FIsReadOnly;
  388. property Name: String read FName;
  389. property NeedResult: Boolean read FNeedResult write FNeedResult;
  390. property Params[Index: Integer]: TfsParamItem read GetParam; default;
  391. property PValue: PVariant read GetPValue;
  392. property RefItem: TfsCustomVariable read FRefItem write FRefItem;
  393. property SourcePos: String read FSourcePos write FSourcePos;
  394. property Typ: TfsVarType read FTyp write FTyp;
  395. property TypeName: String read FTypeName write FTypeName;
  396. property Value: Variant read GetValue write SetValue;
  397. end;
  398. { TfsVariable represents constant or variable }
  399. TfsVariable = class(TfsCustomVariable)
  400. end;
  401. TfsTypeVariable = class(TfsCustomVariable)
  402. end;
  403. TfsStringVariable = class(TfsVariable)
  404. private
  405. FStr: String;
  406. protected
  407. procedure SetValue(const Value: Variant); override;
  408. function GetValue: Variant; override;
  409. end;
  410. { TfsParamItem describes one parameter of procedure/function/method call }
  411. TfsParamItem = class(TfsCustomVariable)
  412. private
  413. FDefValue: Variant;
  414. FIsOptional: Boolean;
  415. FIsVarParam: Boolean;
  416. public
  417. constructor Create(const AName: String; ATyp: TfsVarType;
  418. const ATypeName: String; AIsOptional, AIsVarParam: Boolean);
  419. property DefValue: Variant read FDefValue write FDefValue;
  420. property IsOptional: Boolean read FIsOptional;
  421. property IsVarParam: Boolean read FIsVarParam;
  422. end;
  423. { TfsProcVariable is a local internal procedure/function. Formal parameters
  424. are in Params, and statement to execute is in Prog: TfsScript }
  425. TfsProcVariable = class(TfsCustomVariable)
  426. private
  427. FExecuting: Boolean;
  428. FIsFunc: Boolean;
  429. FProgram: TfsScript;
  430. protected
  431. function GetValue: Variant; override;
  432. public
  433. constructor Create(const AName: String; ATyp: TfsVarType;
  434. const ATypeName: String; AParent: TfsScript; AIsFunc: Boolean = True);
  435. destructor Destroy; override;
  436. property Executing: Boolean read FExecuting;
  437. property IsFunc: Boolean read FIsFunc;
  438. property Prog: TfsScript read FProgram;
  439. end;
  440. TfsCustomExpression = class(TfsCustomVariable)
  441. end;
  442. { TfsCustomHelper is the generic class for the "helpers". Helper is
  443. a object that takes the data from the parent object and performs some
  444. actions. Helpers needed for properties, methods and arrays }
  445. TfsCustomHelper = class(TfsCustomVariable)
  446. private
  447. FParentRef: TfsCustomVariable;
  448. FParentValue: Variant;
  449. FProgram: TfsScript;
  450. public
  451. property ParentRef: TfsCustomVariable read FParentRef write FParentRef;
  452. property ParentValue: Variant read FParentValue write FParentValue;
  453. property Prog: TfsScript read FProgram write FProgram;
  454. end;
  455. { TfsArrayHelper performs access to array elements }
  456. TfsArrayHelper = class(TfsCustomHelper)
  457. protected
  458. procedure SetValue(const Value: Variant); override;
  459. function GetValue: Variant; override;
  460. public
  461. constructor Create(const AName: String; DimCount: Integer; Typ: TfsVarType;
  462. const TypeName: String);
  463. end;
  464. { TfsStringHelper performs access to string elements }
  465. TfsStringHelper = class(TfsCustomHelper)
  466. protected
  467. procedure SetValue(const Value: Variant); override;
  468. function GetValue: Variant; override;
  469. public
  470. constructor Create;
  471. end;
  472. { TfsPropertyHelper gets/sets the property value. Object instance is
  473. stored as Integer in the ParentValue property }
  474. TfsPropertyHelper = class(TfsCustomHelper)
  475. private
  476. FClassRef: TClass;
  477. FIsPublished: Boolean;
  478. FOnGetValue: TfsGetValueEvent;
  479. FOnSetValue: TfsSetValueEvent;
  480. protected
  481. procedure SetValue(const Value: Variant); override;
  482. function GetValue: Variant; override;
  483. public
  484. property IsPublished: Boolean read FIsPublished;
  485. property OnGetValue: TfsGetValueEvent read FOnGetValue write FOnGetValue;
  486. property OnSetValue: TfsSetValueEvent read FOnSetValue write FOnSetValue;
  487. end;
  488. { TfsMethodHelper gets/sets the method value. Object instance is
  489. stored as Integer in the ParentValue property. SetValue is called
  490. if the method represents the indexes property. }
  491. TfsMethodHelper = class(TfsCustomHelper)
  492. private
  493. FCategory: String;
  494. FClassRef: TClass;
  495. FDescription: String;
  496. FIndexMethod: Boolean;
  497. FOnCall: TfsCallMethodEvent;
  498. FSyntax: String;
  499. protected
  500. procedure SetValue(const Value: Variant); override;
  501. function GetValue: Variant; override;
  502. public
  503. constructor Create(const Syntax: String; CallEvent: TfsCallMethodEvent;
  504. Script: TfsScript);
  505. property Category: String read FCategory write FCategory;
  506. property Description: String read FDescription write FDescription;
  507. property IndexMethod: Boolean read FIndexMethod;
  508. property Syntax: String read FSyntax;
  509. property OnCall: TfsCallMethodEvent read FOnCall write FOnCall;
  510. end;
  511. { TfsComponentHelper gets the component inside an owner, e.g. Form1.Button1 }
  512. TfsComponentHelper = class(TfsCustomHelper)
  513. private
  514. FComponent: TComponent;
  515. protected
  516. function GetValue: Variant; override;
  517. public
  518. constructor Create(Component: TComponent);
  519. end;
  520. { Event helper maintains VCL events }
  521. TfsCustomEvent = class(TObject)
  522. private
  523. FHandler: TfsProcVariable;
  524. FInstance: TObject;
  525. protected
  526. procedure CallHandler(Params: array of const);
  527. public
  528. constructor Create(AObject: TObject; AHandler: TfsProcVariable); virtual;
  529. function GetMethod: Pointer; virtual; abstract;
  530. property Handler: TfsProcVariable read FHandler;
  531. property Instance: TObject read FInstance;
  532. end;
  533. TfsEventClass = class of TfsCustomEvent;
  534. TfsEventHelper = class(TfsCustomHelper)
  535. private
  536. FClassRef: TClass;
  537. FEvent: TfsEventClass;
  538. protected
  539. procedure SetValue(const Value: Variant); override;
  540. function GetValue: Variant; override;
  541. public
  542. constructor Create(const Name: String; AEvent: TfsEventClass);
  543. end;
  544. { TfsClassVariable holds information about external class. Call to
  545. AddXXX methods adds properties and methods items to the items list }
  546. TfsClassVariable = class(TfsCustomVariable)
  547. private
  548. FAncestor: String;
  549. FClassRef: TClass;
  550. FDefProperty: TfsCustomHelper;
  551. FMembers: TfsItemList;
  552. FProgram: TfsScript;
  553. procedure AddComponent(c: TComponent);
  554. procedure AddPublishedProperties(AClass: TClass);
  555. function GetMembers(Index: Integer): TfsCustomHelper;
  556. function GetMembersCount: Integer;
  557. protected
  558. function GetValue: Variant; override;
  559. public
  560. constructor Create(AClass: TClass; const Ancestor: String);
  561. destructor Destroy; override;
  562. { Adds a contructor. Example:
  563. AddConstructor('constructor Create(AOwner: TComponent)', MyCallEvent) }
  564. procedure AddConstructor(Syntax: String; CallEvent: TfsCallMethodEvent);
  565. { Adds a property. Example:
  566. AddProperty('Font', 'TFont', MyGetEvent, MySetEvent) }
  567. procedure AddProperty(const Name, Typ: String;
  568. GetEvent: TfsGetValueEvent; SetEvent: TfsSetValueEvent = nil);
  569. { Adds a default property. Example:
  570. AddDefaultProperty('Cell', 'Integer,Integer', 'String', MyCallEvent)
  571. will describe real property Cell[Index1, Index2: Integer]: String
  572. Note: in the CallEvent you'll get the MethodName parameter
  573. 'CELL.GET' and 'CELL.SET', not 'CELL' }
  574. procedure AddDefaultProperty(const Name, Params, Typ: String;
  575. CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False);
  576. { Adds an indexed property. Example and behavior are the same as
  577. for AddDefaultProperty }
  578. procedure AddIndexProperty(const Name, Params, Typ: String;
  579. CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False);
  580. { Adds a method. Example:
  581. AddMethod('function IsVisible: Boolean', MyCallEvent) }
  582. procedure AddMethod(const Syntax: String; CallEvent: TfsCallMethodEvent);
  583. { Adds an event. Example:
  584. AddEvent('OnClick', TfsNotifyEvent) }
  585. procedure AddEvent(const Name: String; AEvent: TfsEventClass);
  586. function Find(const Name: String): TfsCustomHelper;
  587. property Ancestor: String read FAncestor;
  588. property ClassRef: TClass read FClassRef;
  589. property DefProperty: TfsCustomHelper read FDefProperty;
  590. property Members[Index: Integer]: TfsCustomHelper read GetMembers;
  591. property MembersCount: Integer read GetMembersCount;
  592. end;
  593. { TfsDesignator holds the parts of function/procedure/variable/method/property
  594. calls. Items are of type TfsDesignatorItem.
  595. For example, Table1.FieldByName('N').AsString[1] will be represented as
  596. items[0]: name 'Table1', no params
  597. items[1]: name 'FieldByName', 1 param: 'N'
  598. items[2]: name 'AsString', no params
  599. items[3]: name '[', 1 param: '1'
  600. Call to Value calculates and returns the designator value }
  601. TfsDesignatorKind = (dkOther, dkVariable, dkStringArray, dkArray);
  602. TfsDesignatorItem = class(TfsItemList)
  603. private
  604. FFlag: Boolean; { needed for index methods }
  605. FRef: TfsCustomVariable;
  606. FSourcePos: String;
  607. function GetItem(Index: Integer): TfsCustomExpression;
  608. public
  609. property Items[Index: Integer]: TfsCustomExpression read GetItem; default;
  610. property Flag: Boolean read FFlag write FFlag;
  611. property Ref: TfsCustomVariable read FRef write FRef;
  612. property SourcePos: String read FSourcePos write FSourcePos;
  613. end;
  614. TfsDesignator = class(TfsCustomVariable)
  615. private
  616. FKind: TfsDesignatorKind;
  617. FProgram: TfsScript;
  618. FRef1: TfsCustomVariable;
  619. FRef2: TfsDesignatorItem;
  620. FLateBindingXmlSource: TfsXMLItem;
  621. procedure CheckLateBinding;
  622. function DoCalc(const AValue: Variant; Flag: Boolean): Variant;
  623. function GetItem(Index: Integer): TfsDesignatorItem;
  624. protected
  625. function GetValue: Variant; override;
  626. procedure SetValue(const Value: Variant); override;
  627. public
  628. constructor Create(AProgram: TfsScript);
  629. procedure Borrow(ADesignator: TfsDesignator);
  630. procedure Finalize;
  631. property Items[Index: Integer]: TfsDesignatorItem read GetItem; default;
  632. property Kind: TfsDesignatorKind read FKind;
  633. property LateBindingXmlSource: TfsXMLItem read FLateBindingXmlSource
  634. write FLateBindingXmlSource;
  635. end;
  636. TfsVariableDesignator = class(TfsDesignator)
  637. protected
  638. function GetValue: Variant; override;
  639. procedure SetValue(const Value: Variant); override;
  640. end;
  641. TfsStringDesignator = class(TfsDesignator)
  642. protected
  643. function GetValue: Variant; override;
  644. procedure SetValue(const Value: Variant); override;
  645. end;
  646. TfsArrayDesignator = class(TfsDesignator)
  647. protected
  648. function GetValue: Variant; override;
  649. procedure SetValue(const Value: Variant); override;
  650. end;
  651. { TfsSetExpression represents a set of values like ['_', '0'..'9'] }
  652. TfsSetExpression = class(TfsCustomVariable)
  653. private
  654. function GetItem(Index: Integer): TfsCustomExpression;
  655. protected
  656. function GetValue: Variant; override;
  657. public
  658. function Check(const Value: Variant): Boolean;
  659. property Items[Index: Integer]: TfsCustomExpression read GetItem;
  660. end;
  661. { TfsEventList maintains all event handlers attached to a VCL controls }
  662. TfsEventList = class(TfsItemList)
  663. public
  664. procedure FreeObjectEvents(Instance: TObject);
  665. end;
  666. function fsGlobalUnit: TfsScript;
  667. function fsEventList: TfsEventList;
  668. implementation
  669. //{$DEFINE Trial}
  670. uses
  671. TypInfo, fs_isysrtti, fs_iexpression, fs_iparser, fs_iilparser,
  672. fs_itools, fs_iconst
  673. {$IFDEF CLX}
  674. , QForms, QDialogs, Types
  675. {$ELSE}
  676. {$IFDEF NOFORMS}
  677. , Windows, Messages
  678. {$ELSE}
  679. , Windows, Forms, Dialogs
  680. {$ENDIF}
  681. {$ENDIF};
  682. var
  683. FGlobalUnit: TfsScript;
  684. FEventList: TfsEventList;
  685. FGlobalUnitDestroyed: Boolean = False;
  686. { TfsItemsList }
  687. constructor TfsItemList.Create;
  688. begin
  689. FItems := TList.Create;
  690. end;
  691. destructor TfsItemList.Destroy;
  692. begin
  693. Clear;
  694. FItems.Free;
  695. inherited;
  696. end;
  697. procedure TfsItemList.Clear;
  698. begin
  699. while FItems.Count > 0 do
  700. begin
  701. TObject(FItems[0]).Free;
  702. FItems.Delete(0);
  703. end;
  704. end;
  705. function TfsItemList.Count: Integer;
  706. begin
  707. Result := FItems.Count;
  708. end;
  709. procedure TfsItemList.Add(Item: TObject);
  710. begin
  711. FItems.Add(Item);
  712. end;
  713. procedure TfsItemList.Remove(Item: TObject);
  714. begin
  715. FItems.Remove(Item);
  716. end;
  717. { TfsCustomVariable }
  718. constructor TfsCustomVariable.Create(const AName: String; ATyp: TfsVarType;
  719. const ATypeName: String);
  720. begin
  721. inherited Create;
  722. FName := AName;
  723. FTyp := ATyp;
  724. FTypeName := ATypeName;
  725. FValue := Null;
  726. FNeedResult := True;
  727. end;
  728. function TfsCustomVariable.GetValue: Variant;
  729. begin
  730. Result := FValue;
  731. end;
  732. procedure TfsCustomVariable.SetValue(const Value: Variant);
  733. begin
  734. if not FIsReadOnly then
  735. FValue := Value;
  736. end;
  737. function TfsCustomVariable.GetParam(Index: Integer): TfsParamItem;
  738. begin
  739. Result := FItems[Index];
  740. end;
  741. function TfsCustomVariable.GetPValue: PVariant;
  742. begin
  743. Result := @FValue;
  744. end;
  745. function TfsCustomVariable.GetFullTypeName: String;
  746. begin
  747. case FTyp of
  748. fvtInt: Result := 'Integer';
  749. fvtBool: Result := 'Boolean';
  750. fvtFloat: Result := 'Extended';
  751. fvtChar: Result := 'Char';
  752. fvtString: Result := 'String';
  753. fvtClass: Result := 'Class ' + FTypeName;
  754. fvtArray: Result := 'Array';
  755. fvtEnum: Result := FTypeName;
  756. else
  757. Result := 'Variant';
  758. end;
  759. end;
  760. function TfsCustomVariable.GetNumberOfRequiredParams: Integer;
  761. var
  762. i: Integer;
  763. begin
  764. Result := 0;
  765. for i := 0 to Count - 1 do
  766. if not Params[i].IsOptional then
  767. Inc(Result);
  768. end;
  769. { TfsStringVariable }
  770. function TfsStringVariable.GetValue: Variant;
  771. begin
  772. Result := FStr;
  773. end;
  774. procedure TfsStringVariable.SetValue(const Value: Variant);
  775. begin
  776. FStr := Value;
  777. end;
  778. { TfsParamItem }
  779. constructor TfsParamItem.Create(const AName: String; ATyp: TfsVarType;
  780. const ATypeName: String; AIsOptional, AIsVarParam: Boolean);
  781. begin
  782. inherited Create(AName, ATyp, ATypeName);
  783. FIsOptional := AIsOptional;
  784. FIsVarParam := AIsVarParam;
  785. FDefValue := Null;
  786. end;
  787. { TfsProcVariable }
  788. constructor TfsProcVariable.Create(const AName: String; ATyp: TfsVarType;
  789. const ATypeName: String; AParent: TfsScript; AIsFunc: Boolean = True);
  790. begin
  791. inherited Create(AName, ATyp, ATypeName);
  792. FIsReadOnly := True;
  793. FIsFunc := AIsFunc;
  794. FProgram := TfsScript.Create(nil);
  795. FProgram.Parent := AParent;
  796. if FIsFunc then
  797. begin
  798. FRefItem := TfsVariable.Create('Result', ATyp, ATypeName);
  799. FProgram.Add(FRefItem);
  800. end;
  801. end;
  802. destructor TfsProcVariable.Destroy;
  803. var
  804. i: Integer;
  805. begin
  806. { avoid destroying the param objects twice }
  807. for i := 0 to Count - 1 do
  808. FProgram.FItems.Remove(Params[i]);
  809. FProgram.Free;
  810. inherited;
  811. end;
  812. function TfsProcVariable.GetValue: Variant;
  813. var
  814. Temp: Boolean;
  815. ParentProg, SaveProg: TfsScript;
  816. begin
  817. Temp := FExecuting;
  818. FExecuting := True;
  819. ParentProg := FProgram;
  820. SaveProg := nil;
  821. while ParentProg <> nil do
  822. if Assigned(ParentProg.FOnRunLine) then
  823. begin
  824. SaveProg := ParentProg.FProgRunning;
  825. ParentProg.FProgRunning := FProgram;
  826. break;
  827. end
  828. else
  829. ParentProg := ParentProg.FParent;
  830. try
  831. // avoid trial message
  832. // same as FProgram.Execute
  833. with FProgram do
  834. begin
  835. FExitCalled := False;
  836. FTerminated := False;
  837. FIsRunning := True;
  838. try
  839. FStatement.Execute;
  840. finally
  841. FExitCalled := False;
  842. FTerminated := False;
  843. FIsRunning := False;
  844. end;
  845. end;
  846. //
  847. if FIsFunc then
  848. Result := FRefItem.Value else
  849. Result := Null;
  850. finally
  851. if ParentProg <> nil then
  852. ParentProg.FProgRunning := SaveProg;
  853. FExecuting := Temp;
  854. end;
  855. end;
  856. { TfsPropertyHelper }
  857. function TfsPropertyHelper.GetValue: Variant;
  858. var
  859. p: PPropInfo;
  860. Instance: TObject;
  861. begin
  862. Result := Null;
  863. Instance := TObject(Integer(ParentValue));
  864. if FIsPublished then
  865. begin
  866. p := GetPropInfo(Instance.ClassInfo, Name);
  867. if p <> nil then
  868. case p.PropType^.Kind of
  869. tkInteger, tkSet, tkEnumeration, tkClass:
  870. Result := GetOrdProp(Instance, p);
  871. tkFloat:
  872. Result := GetFloatProp(Instance, p);
  873. tkString, tkLString, tkWString:
  874. Result := GetStrProp(Instance, p);
  875. tkChar, tkWChar:
  876. Result := Chr(GetOrdProp(Instance, p));
  877. tkVariant:
  878. Result := GetVariantProp(Instance, p);
  879. end;
  880. end
  881. else if Assigned(FOnGetValue) then
  882. Result := FOnGetValue(Instance, FClassRef, AnsiUpperCase(Name));
  883. if Typ = fvtBool then
  884. if Result = 0 then
  885. Result := False else
  886. Result := True;
  887. end;
  888. procedure TfsPropertyHelper.SetValue(const Value: Variant);
  889. var
  890. p: PPropInfo;
  891. Instance: TObject;
  892. IntVal: Integer;
  893. begin
  894. if IsReadOnly then Exit;
  895. Instance := TObject(Integer(ParentValue));
  896. if FIsPublished then
  897. begin
  898. p := GetPropInfo(Instance.ClassInfo, Name);
  899. if p <> nil then
  900. case p.PropType^.Kind of
  901. tkInteger, tkSet, tkEnumeration, tkClass:
  902. begin
  903. if Typ = fvtBool then
  904. if Value = True then
  905. IntVal := 1 else
  906. IntVal := 0
  907. else
  908. IntVal := Integer(Value);
  909. SetOrdProp(Instance, p, IntVal);
  910. end;
  911. tkFloat:
  912. SetFloatProp(Instance, p, Extended(Value));
  913. tkString, tkLString, tkWString:
  914. SetStrProp(Instance, p, String(Value));
  915. tkChar, tkWChar:
  916. SetOrdProp(Instance, p, Ord(String(Value)[1]));
  917. tkVariant:
  918. SetVariantProp(Instance, p, Value);
  919. end;
  920. end
  921. else if Assigned(FOnSetValue) then
  922. FOnSetValue(Instance, FClassRef, AnsiUpperCase(Name), Value);
  923. end;
  924. { TfsMethodHelper }
  925. constructor TfsMethodHelper.Create(const Syntax: String;
  926. CallEvent: TfsCallMethodEvent; Script: TfsScript);
  927. var
  928. i: Integer;
  929. v: TfsCustomVariable;
  930. begin
  931. v := ParseMethodSyntax(Syntax, Script);
  932. inherited Create(v.Name, v.Typ, v.TypeName);
  933. FOnCall := CallEvent;
  934. FIsReadOnly := True;
  935. FSyntax := Syntax;
  936. { copying params }
  937. for i := 0 to v.Count - 1 do
  938. Add(v.Params[i]);
  939. while v.Count > 0 do
  940. v.FItems.Delete(0);
  941. v.Free;
  942. end;
  943. function TfsMethodHelper.GetValue: Variant;
  944. var
  945. v: Variant;
  946. i: Integer;
  947. s: String;
  948. Instance: TObject;
  949. begin
  950. if Assigned(FOnCall) then
  951. begin
  952. v := VarArrayCreate([0, Count - 1], varVariant);
  953. for i := 0 to Count - 1 do
  954. v[i] := Params[i].Value;
  955. s := Name;
  956. if FIndexMethod then
  957. s := s + '.Get';
  958. Instance := nil;
  959. if ParentValue <> Null then
  960. Instance := TObject(Integer(ParentValue));
  961. Result := FOnCall(Instance, FClassRef, AnsiUpperCase(s), v);
  962. for i := 0 to Count - 1 do
  963. if Params[i].IsVarParam then
  964. Params[i].Value := v[i];
  965. v := Null;
  966. end
  967. else
  968. Result := 0;
  969. end;
  970. procedure TfsMethodHelper.SetValue(const Value: Variant);
  971. var
  972. v: Variant;
  973. i: Integer;
  974. begin
  975. if Assigned(FOnCall) and FIndexMethod then
  976. begin
  977. v := VarArrayCreate([0, Count], varVariant);
  978. for i := 0 to Count - 1 do
  979. v[i] := Params[i].Value;
  980. v[Count] := Value;
  981. FOnCall(TObject(Integer(ParentValue)), FClassRef, AnsiUpperCase(Name + '.Set'), v);
  982. v := Null;
  983. end;
  984. end;
  985. { TfsComponentHelper }
  986. constructor TfsComponentHelper.Create(Component: TComponent);
  987. begin
  988. inherited Create(Component.Name, fvtClass, Component.ClassName);
  989. FComponent := Component;
  990. end;
  991. function TfsComponentHelper.GetValue: Variant;
  992. begin
  993. Result := Integer(FComponent);
  994. end;
  995. { TfsEventHelper }
  996. constructor TfsEventHelper.Create(const Name: String; AEvent: TfsEventClass);
  997. begin
  998. inherited Create(Name, fvtString, '');
  999. FEvent := AEvent;
  1000. end;
  1001. function TfsEventHelper.GetValue: Variant;
  1002. begin
  1003. Result := '';
  1004. end;
  1005. procedure TfsEventHelper.SetValue(const Value: Variant);
  1006. var
  1007. Instance: TPersistent;
  1008. v: TfsCustomVariable;
  1009. e: TfsCustomEvent;
  1010. p: PPropInfo;
  1011. m: TMethod;
  1012. begin
  1013. Instance := TPersistent(Integer(ParentValue));
  1014. if VarToStr(Value) = '0' then
  1015. begin
  1016. m.Code := nil;
  1017. m.Data := nil;
  1018. end
  1019. else
  1020. begin
  1021. v := FProgram.Find(Value);
  1022. if (v = nil) or not (v is TfsProcVariable) then
  1023. raise Exception.Create(SEventError);
  1024. e := TfsCustomEvent(FEvent.NewInstance);
  1025. e.Create(Instance, TfsProcVariable(v));
  1026. fsEventList.Add(e);
  1027. m.Code := e.GetMethod;
  1028. m.Data := e;
  1029. end;
  1030. p := GetPropInfo(Instance.ClassInfo, Name);
  1031. SetMethodProp(Instance, p, m);
  1032. end;
  1033. { TfsClassVariable }
  1034. constructor TfsClassVariable.Create(AClass: TClass; const Ancestor: String);
  1035. begin
  1036. inherited Create(AClass.ClassName, fvtClass, AClass.ClassName);
  1037. FMembers := TfsItemList.Create;
  1038. FAncestor := Ancestor;
  1039. FClassRef := AClass;
  1040. AddPublishedProperties(AClass);
  1041. Add(TfsParamItem.Create('', fvtVariant, '', True, False));
  1042. end;
  1043. destructor TfsClassVariable.Destroy;
  1044. begin
  1045. FMembers.Free;
  1046. inherited;
  1047. end;
  1048. function TfsClassVariable.GetMembers(Index: Integer): TfsCustomHelper;
  1049. begin
  1050. Result := FMembers.FItems[Index];
  1051. end;
  1052. function TfsClassVariable.GetMembersCount: Integer;
  1053. begin
  1054. Result := FMembers.Count;
  1055. end;
  1056. procedure TfsClassVariable.AddConstructor(Syntax: String; CallEvent: TfsCallMethodEvent);
  1057. var
  1058. i: Integer;
  1059. begin
  1060. i := Pos(' ', Syntax);
  1061. Delete(Syntax, 1, i - 1);
  1062. Syntax := 'function' + Syntax + ': ' + 'Constructor';
  1063. AddMethod(Syntax, CallEvent);
  1064. end;
  1065. procedure TfsClassVariable.AddMethod(const Syntax: String; CallEvent: TfsCallMethodEvent);
  1066. var
  1067. m: TfsMethodHelper;
  1068. begin
  1069. m := TfsMethodHelper.Create(Syntax, CallEvent, FProgram);
  1070. m.FClassRef := FClassRef;
  1071. FMembers.Add(m);
  1072. end;
  1073. procedure TfsClassVariable.AddEvent(const Name: String; AEvent: TfsEventClass);
  1074. var
  1075. e: TfsEventHelper;
  1076. begin
  1077. e := TfsEventHelper.Create(Name, AEvent);
  1078. e.FClassRef := FClassRef;
  1079. FMembers.Add(e);
  1080. end;
  1081. procedure TfsClassVariable.AddProperty(const Name, Typ: String;
  1082. GetEvent: TfsGetValueEvent; SetEvent: TfsSetValueEvent);
  1083. var
  1084. p: TfsPropertyHelper;
  1085. begin
  1086. p := TfsPropertyHelper.Create(Name, StrToVarType(Typ, FProgram), Typ);
  1087. p.FClassRef := FClassRef;
  1088. p.FOnGetValue := GetEvent;
  1089. p.FOnSetValue := SetEvent;
  1090. p.IsReadOnly := not Assigned(SetEvent);
  1091. FMembers.Add(p);
  1092. end;
  1093. procedure TfsClassVariable.AddDefaultProperty(const Name, Params, Typ: String;
  1094. CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False);
  1095. begin
  1096. AddIndexProperty(Name, Params, Typ, CallEvent, AReadOnly);
  1097. FDefProperty := Members[FMembers.Count - 1];
  1098. end;
  1099. procedure TfsClassVariable.AddIndexProperty(const Name, Params,
  1100. Typ: String; CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False);
  1101. var
  1102. i: Integer;
  1103. sl: TStringList;
  1104. s: String;
  1105. begin
  1106. sl := TStringList.Create;
  1107. sl.CommaText := Params;
  1108. s := '';
  1109. for i := 0 to sl.Count - 1 do
  1110. s := s + 'p' + IntToStr(i) + ': ' + sl[i] + '; ';
  1111. SetLength(s, Length(s) - 2);
  1112. try
  1113. AddMethod('function ' + Name + '(' + s + '): ' + Typ, CallEvent);
  1114. with TfsMethodHelper(Members[FMembers.Count - 1]) do
  1115. begin
  1116. IsReadOnly := AReadOnly;
  1117. FIndexMethod := True;
  1118. end;
  1119. finally
  1120. sl.Free;
  1121. end;
  1122. end;
  1123. procedure TfsClassVariable.AddComponent(c: TComponent);
  1124. begin
  1125. FMembers.Add(TfsComponentHelper.Create(c));
  1126. end;
  1127. procedure TfsClassVariable.AddPublishedProperties(AClass: TClass);
  1128. var
  1129. TypeInfo: PTypeInfo;
  1130. PropCount: Integer;
  1131. PropList: PPropList;
  1132. i: Integer;
  1133. cl: String;
  1134. t: TfsVarType;
  1135. FClass: TClass;
  1136. p: TfsPropertyHelper;
  1137. begin
  1138. TypeInfo := AClass.ClassInfo;
  1139. if TypeInfo = nil then Exit;
  1140. PropCount := GetPropList(TypeInfo, tkProperties, nil);
  1141. GetMem(PropList, PropCount * SizeOf(PPropInfo));
  1142. GetPropList(TypeInfo, tkProperties, PropList);
  1143. try
  1144. for i := 0 to PropCount - 1 do
  1145. begin
  1146. t := fvtInt;
  1147. cl := '';
  1148. case PropList[i].PropType^.Kind of
  1149. tkInteger:
  1150. t := fvtInt;
  1151. tkSet:
  1152. begin
  1153. t := fvtEnum;
  1154. cl := PropList[i].PropType^.Name;
  1155. end;
  1156. tkEnumeration:
  1157. begin
  1158. t := fvtEnum;
  1159. cl := PropList[i].PropType^.Name;
  1160. if CompareText(cl, 'Boolean') = 0 then
  1161. t := fvtBool;
  1162. end;
  1163. tkFloat:
  1164. t := fvtFloat;
  1165. tkChar, tkWChar:
  1166. t := fvtChar;
  1167. tkString, tkLString, tkWString:
  1168. t := fvtString;
  1169. tkVariant:
  1170. t := fvtVariant;
  1171. tkClass:
  1172. begin
  1173. t := fvtClass;
  1174. FClass := GetTypeData(PropList[i].PropType^).ClassType;
  1175. cl := FClass.ClassName;
  1176. end;
  1177. end;
  1178. p := TfsPropertyHelper.Create(PropList[i].Name, t, cl);
  1179. p.FClassRef := FClassRef;
  1180. p.FIsPublished := True;
  1181. FMembers.Add(p);
  1182. end;
  1183. finally
  1184. FreeMem(PropList, PropCount * SizeOf(PPropInfo));
  1185. end;
  1186. end;
  1187. function TfsClassVariable.Find(const Name: String): TfsCustomHelper;
  1188. var
  1189. cl: TfsClassVariable;
  1190. function DoFind(const Name: String): TfsCustomHelper;
  1191. var
  1192. i: Integer;
  1193. begin
  1194. Result := nil;
  1195. for i := 0 to FMembers.Count - 1 do
  1196. if CompareText(Name, Members[i].Name) = 0 then
  1197. begin
  1198. Result := Members[i];
  1199. Exit;
  1200. end;
  1201. end;
  1202. begin
  1203. Result := DoFind(Name);
  1204. if Result = nil then
  1205. begin
  1206. cl := FProgram.FindClass(FAncestor);
  1207. if cl <> nil then
  1208. Result := cl.Find(Name);
  1209. end;
  1210. end;
  1211. function TfsClassVariable.GetValue: Variant;
  1212. begin
  1213. if Params[0].Value = Null then
  1214. Result := Integer(FClassRef.NewInstance) else { constructor call }
  1215. Result := Params[0].Value; { typecast }
  1216. Params[0].Value := Null;
  1217. end;
  1218. { TfsDesignatorItem }
  1219. function TfsDesignatorItem.GetItem(Index: Integer): TfsCustomExpression;
  1220. begin
  1221. Result := FItems[Index];
  1222. end;
  1223. { TfsDesignator }
  1224. constructor TfsDesignator.Create(AProgram: TfsScript);
  1225. begin
  1226. inherited Create('', fvtInt, '');
  1227. FProgram := AProgram;
  1228. end;
  1229. procedure TfsDesignator.Borrow(ADesignator: TfsDesignator);
  1230. var
  1231. SaveItems: TList;
  1232. begin
  1233. SaveItems := FItems;
  1234. FItems := ADesignator.FItems;
  1235. ADesignator.FItems := SaveItems;
  1236. FKind := ADesignator.FKind;
  1237. FRef1 := ADesignator.FRef1;
  1238. FRef2 := ADesignator.FRef2;
  1239. FTyp := ADesignator.Typ;
  1240. FTypeName := ADesignator.TypeName;
  1241. FIsReadOnly := ADesignator.IsReadOnly;
  1242. RefItem := ADesignator.RefItem;
  1243. end;
  1244. procedure TfsDesignator.Finalize;
  1245. var
  1246. Item: TfsDesignatorItem;
  1247. begin
  1248. Item := Items[Count - 1];
  1249. FTyp := Item.Ref.Typ;
  1250. FTypeName := Item.Ref.TypeName;
  1251. if FTyp = fvtConstructor then
  1252. begin
  1253. FTyp := fvtClass;
  1254. FTypeName := Items[Count - 2].Ref.TypeName;
  1255. end;
  1256. FIsReadOnly := Item.Ref.IsReadOnly;
  1257. { speed optimization for access to single variable, string element or array }
  1258. if (Count = 1) and (Items[0].Ref is TfsVariable) then
  1259. begin
  1260. RefItem := Items[0].Ref;
  1261. FKind := dkVariable;
  1262. end
  1263. else if (Count = 2) and (Items[0].Ref is TfsStringVariable) then
  1264. begin
  1265. RefItem := Items[0].Ref;
  1266. FRef1 := Items[1][0];
  1267. FKind := dkStringArray;
  1268. end
  1269. else if (Count = 2) and (Items[0].Ref is TfsVariable) and (Items[0].Ref.Typ = fvtArray) then
  1270. begin
  1271. RefItem := Items[0].Ref;
  1272. FRef1 := RefItem.RefItem;
  1273. FRef2 := Items[1];
  1274. FKind := dkArray;
  1275. end
  1276. else
  1277. FKind := dkOther;
  1278. end;
  1279. function TfsDesignator.GetItem(Index: Integer): TfsDesignatorItem;
  1280. begin
  1281. Result := FItems[Index];
  1282. end;
  1283. function TfsDesignator.DoCalc(const AValue: Variant; Flag: Boolean): Variant;
  1284. var
  1285. i, j: Integer;
  1286. Item: TfsCustomVariable;
  1287. Val: Variant;
  1288. Ref: TfsCustomVariable;
  1289. Temp, Temp1: array of Variant;
  1290. { copy local variables to Temp }
  1291. procedure SaveLocalVariables(Item: TfsCustomVariable);
  1292. var
  1293. i: Integer;
  1294. begin
  1295. with TfsProcVariable(Item) do
  1296. begin
  1297. SetLength(Temp, Prog.Count);
  1298. for i := 0 to Prog.Count - 1 do
  1299. if (Prog.Items[i] is TfsVariable) or (Prog.Items[i] is TfsParamItem) then
  1300. Temp[i] := Prog.Items[i].Value;
  1301. end;
  1302. end;
  1303. { restore local variables from Temp}
  1304. procedure RestoreLocalVariables(Item: TfsCustomVariable);
  1305. var
  1306. i: Integer;
  1307. begin
  1308. with TfsProcVariable(Item) do
  1309. for i := 0 to Prog.Count - 1 do
  1310. if (Prog.Items[i] is TfsVariable) or (Prog.Items[i] is TfsParamItem) then
  1311. Prog.Items[i].Value := Temp[i];
  1312. Temp := nil;
  1313. end;
  1314. begin
  1315. Ref := nil;
  1316. Val := Null;
  1317. for i := 0 to Count - 1 do
  1318. begin
  1319. Item := Items[i].Ref;
  1320. if Item is TfsDesignator then { it is true for "WITH" statements }
  1321. begin
  1322. Ref := Item;
  1323. Val := Item.Value;
  1324. continue;
  1325. end;
  1326. { we're trying to call the local procedure that is already executing -
  1327. i.e. we have a recursion }
  1328. if (Item is TfsProcVariable) and TfsProcVariable(Item).Executing then
  1329. SaveLocalVariables(Item);
  1330. if Item.Count > 0 then
  1331. begin
  1332. SetLength(Temp1, Item.Count);
  1333. try
  1334. { calculate params and copy param values to the temp1 array }
  1335. for j := 0 to Item.Count - 1 do
  1336. Temp1[j] := Items[i][j].Value;
  1337. { copy calculated values to the item params }
  1338. for j := 0 to Item.Count - 1 do
  1339. Item.Params[j].Value := Temp1[j];
  1340. finally
  1341. Temp1 := nil;
  1342. end;
  1343. end;
  1344. { copy value and var reference to the helper object }
  1345. if Item is TfsCustomHelper then
  1346. begin
  1347. TfsCustomHelper(Item).ParentRef := Ref;
  1348. TfsCustomHelper(Item).ParentValue := Val;
  1349. TfsCustomHelper(Item).Prog := FProgram;
  1350. end;
  1351. Ref := Item;
  1352. { assign a value to the last designator node if called from SetValue }
  1353. if Flag and (i = Count - 1) then
  1354. Item.Value := AValue
  1355. else
  1356. begin
  1357. Item.NeedResult := (i <> Count - 1) or NeedResult;
  1358. Val := Item.Value;
  1359. end;
  1360. { copy back var params }
  1361. for j := 0 to Item.Count - 1 do
  1362. if Item.Params[j].IsVarParam then
  1363. Items[i][j].Value := Item.Params[j].Value;
  1364. { restore proc variables if it was called from itself }
  1365. if (Item is TfsProcVariable) and TfsProcVariable(Item).Executing then
  1366. RestoreLocalVariables(Item);
  1367. end;
  1368. Result := Val;
  1369. end;
  1370. procedure TfsDesignator.CheckLateBinding;
  1371. var
  1372. NewDesignator: TfsDesignator;
  1373. Parser: TfsILParser;
  1374. begin
  1375. if FLateBindingXMLSource <> nil then
  1376. begin
  1377. Parser := TfsILParser.Create(FProgram);
  1378. try
  1379. NewDesignator := Parser.DoDesignator(FLateBindingXMLSource, FProgram);
  1380. Borrow(NewDesignator);
  1381. NewDesignator.Free;
  1382. finally
  1383. Parser.Free;
  1384. FLateBindingXMLSource.Free;
  1385. FLateBindingXMLSource := nil;
  1386. end;
  1387. end;
  1388. end;
  1389. function TfsDesignator.GetValue: Variant;
  1390. begin
  1391. CheckLateBinding;
  1392. Result := DoCalc(Null, False);
  1393. end;
  1394. procedure TfsDesignator.SetValue(const Value: Variant);
  1395. begin
  1396. CheckLateBinding;
  1397. DoCalc(Value, True);
  1398. end;
  1399. { TfsVariableDesignator }
  1400. function TfsVariableDesignator.GetValue: Variant;
  1401. begin
  1402. Result := RefItem.Value;
  1403. end;
  1404. procedure TfsVariableDesignator.SetValue(const Value: Variant);
  1405. begin
  1406. RefItem.Value := Value;
  1407. end;
  1408. { TfsStringDesignator }
  1409. function TfsStringDesignator.GetValue: Variant;
  1410. begin
  1411. Result := TfsStringVariable(RefItem).FStr[Integer(FRef1.Value)];
  1412. end;
  1413. procedure TfsStringDesignator.SetValue(const Value: Variant);
  1414. begin
  1415. TfsStringVariable(RefItem).FStr[Integer(FRef1.Value)] := VarToStr(Value)[1];
  1416. end;
  1417. { TfsArrayDesignator }
  1418. function TfsArrayDesignator.GetValue: Variant;
  1419. var
  1420. i: Integer;
  1421. begin
  1422. TfsCustomHelper(FRef1).ParentRef := RefItem;
  1423. for i := 0 to FRef2.Count - 1 do
  1424. FRef1.Params[i].Value := FRef2[i].Value;
  1425. Result := FRef1.Value;
  1426. end;
  1427. procedure TfsArrayDesignator.SetValue(const Value: Variant);
  1428. var
  1429. i: Integer;
  1430. begin
  1431. TfsCustomHelper(FRef1).ParentRef := RefItem;
  1432. for i := 0 to FRef2.Count - 1 do
  1433. FRef1.Params[i].Value := FRef2[i].Value;
  1434. FRef1.Value := Value;
  1435. end;
  1436. { TfsSetExpression }
  1437. function TfsSetExpression.Check(const Value: Variant): Boolean;
  1438. var
  1439. i: Integer;
  1440. Expr: TfsCustomExpression;
  1441. begin
  1442. Result := False;
  1443. (* TfsSetExpression encapsulates the set like [1,2,3..10]
  1444. In the example above we'll have the following Items:
  1445. TfsExpression {1}
  1446. TfsExpression {2}
  1447. TfsExpression {3}
  1448. nil (indicates the range )
  1449. TfsExpression {10} *)
  1450. i := 0;
  1451. while i < Count do
  1452. begin
  1453. Expr := Items[i];
  1454. if (i < Count - 1) and (Items[i + 1] = nil) then { subrange }
  1455. begin
  1456. Result := (Value >= Expr.Value) and (Value <= Items[i + 2].Value);
  1457. Inc(i, 2);
  1458. end
  1459. else
  1460. Result := Value = Expr.Value;
  1461. if Result then break;
  1462. Inc(i);
  1463. end;
  1464. end;
  1465. function TfsSetExpression.GetItem(Index: Integer): TfsCustomExpression;
  1466. begin
  1467. Result := FItems[Index];
  1468. end;
  1469. function TfsSetExpression.GetValue: Variant;
  1470. var
  1471. i: Integer;
  1472. begin
  1473. Result := VarArrayCreate([0, Count - 1], varVariant);
  1474. for i := 0 to Count - 1 do
  1475. if Items[i] = nil then
  1476. Result[i] := 0 else
  1477. Result[i] := Items[i].Value;
  1478. end;
  1479. { TfsScript }
  1480. constructor TfsScript.Create(AOwner: TComponent);
  1481. begin
  1482. inherited;
  1483. FItems := TList.Create;
  1484. FLines := TStringList.Create;
  1485. FStatement := TfsStatement.Create(Self, '', '');
  1486. FSyntaxType := 'PascalScript';
  1487. FUnitLines := TStringList.Create;
  1488. Add(TfsStringHelper.Create);
  1489. Add(TfsArrayHelper.Create('__ArrayHelper', -1, fvtVariant, ''));
  1490. end;
  1491. destructor TfsScript.Destroy;
  1492. begin
  1493. inherited;
  1494. Clear;
  1495. FItems.Free;
  1496. FLines.Free;
  1497. FStatement.Free;
  1498. FUnitLines.Free;
  1499. end;
  1500. procedure TfsScript.Add(Item: TObject);
  1501. begin
  1502. FItems.Add(Item);
  1503. end;
  1504. function TfsScript.Count: Integer;
  1505. begin
  1506. Result := FItems.Count;
  1507. end;
  1508. procedure TfsScript.Remove(Item: TObject);
  1509. begin
  1510. FItems.Remove(Item);
  1511. end;
  1512. procedure TfsScript.Clear;
  1513. begin
  1514. while FItems.Count > 0 do
  1515. begin
  1516. TObject(FItems[0]).Free;
  1517. FItems.Delete(0);
  1518. end;
  1519. FStatement.Clear;
  1520. FUnitLines.Clear;
  1521. end;
  1522. procedure TfsScript.RemoveItems(Owner: TObject);
  1523. var
  1524. i: Integer;
  1525. begin
  1526. for i := Count - 1 downto 0 do
  1527. if Items[i].AddedBy = Owner then
  1528. begin
  1529. Items[i].Free;
  1530. Remove(Items[i]);
  1531. end;
  1532. end;
  1533. function TfsScript.GetItem(Index: Integer): TfsCustomVariable;
  1534. begin
  1535. Result := FItems[Index];
  1536. end;
  1537. function TfsScript.Find(const Name: String): TfsCustomVariable;
  1538. begin
  1539. Result := FindLocal(Name);
  1540. { trying to find the identifier in all parent programs }
  1541. if (Result = nil) and (FParent <> nil) then
  1542. Result := FParent.Find(Name);
  1543. end;
  1544. function TfsScript.FindLocal(const Name: String): TfsCustomVariable;
  1545. var
  1546. i: Integer;
  1547. begin
  1548. Result := nil;
  1549. for i := 0 to Count - 1 do
  1550. if AnsiCompareText(Name, TfsCustomVariable(FItems[i]).Name) = 0 then
  1551. begin
  1552. Result := FItems[i];
  1553. Exit;
  1554. end;
  1555. end;
  1556. function TfsScript.Compile: Boolean;
  1557. var
  1558. p: TfsILParser;
  1559. begin
  1560. Result := False;
  1561. FErrorMsg := '';
  1562. p := TfsILParser.Create(Self);
  1563. try
  1564. p.SelectLanguage(FSyntaxType);
  1565. if p.MakeILScript(FLines.Text) then
  1566. p.ParseILScript;
  1567. finally
  1568. p.Free;
  1569. end;
  1570. if FErrorMsg = '' then
  1571. begin
  1572. Result := True;
  1573. FErrorPos := '';
  1574. end
  1575. end;
  1576. procedure TfsScript.Execute;
  1577. begin
  1578. {$IFDEF Trial}
  1579. ShowMessage('Unregistered version of FastScript.');
  1580. {$ENDIF}
  1581. FExitCalled := False;
  1582. FTerminated := False;
  1583. FIsRunning := True;
  1584. try
  1585. FStatement.Execute;
  1586. finally
  1587. FExitCalled := False;
  1588. FTerminated := False;
  1589. FIsRunning := False;
  1590. end;
  1591. end;
  1592. function TfsScript.Run: Boolean;
  1593. begin
  1594. Result := Compile;
  1595. if Result then
  1596. Execute;
  1597. end;
  1598. function TfsScript.GetILCode(Stream: TStream): Boolean;
  1599. var
  1600. p: TfsILParser;
  1601. begin
  1602. Result := False;
  1603. FErrorMsg := '';
  1604. p := TfsILParser.Create(Self);
  1605. try
  1606. p.SelectLanguage(FSyntaxType);
  1607. if p.MakeILScript(FLines.Text) then
  1608. p.ILScript.SaveToStream(Stream);
  1609. finally
  1610. p.Free;
  1611. end;
  1612. if FErrorMsg = '' then
  1613. begin
  1614. Result := True;
  1615. FErrorPos := '';
  1616. end;
  1617. end;
  1618. function TfsScript.SetILCode(Stream: TStream): Boolean;
  1619. var
  1620. p: TfsILParser;
  1621. begin
  1622. Result := False;
  1623. FErrorMsg := '';
  1624. p := TfsILParser.Create(Self);
  1625. try
  1626. p.ILScript.LoadFromStream(Stream);
  1627. p.ParseILScript;
  1628. finally
  1629. p.Free;
  1630. end;
  1631. if FErrorMsg = '' then
  1632. begin
  1633. Result := True;
  1634. FErrorPos := '';
  1635. end;
  1636. end;
  1637. procedure TfsScript.AddType(const TypeName: String; ParentType: TfsVarType);
  1638. var
  1639. v: TfsTypeVariable;
  1640. begin
  1641. if Find(TypeName) <> nil then Exit;
  1642. v := TfsTypeVariable.Create(TypeName, ParentType, '');
  1643. v.FAddedBy := AddedBy;
  1644. Add(v);
  1645. end;
  1646. function TfsScript.AddClass(AClass: TClass; const Ancestor: String): TfsClassVariable;
  1647. var
  1648. cl: TfsClassVariable;
  1649. begin
  1650. Result := nil;
  1651. if Find(AClass.ClassName) <> nil then Exit;
  1652. Result := TfsClassVariable.Create(AClass, Ancestor);
  1653. Result.FAddedBy := AddedBy;
  1654. Result.FProgram := Self;
  1655. Add(Result);
  1656. cl := TfsClassVariable(Find(Ancestor));
  1657. if cl <> nil then
  1658. Result.FDefProperty := cl.DefProperty;
  1659. end;
  1660. procedure TfsScript.AddConst(const Name, Typ: String; const Value: Variant);
  1661. var
  1662. v: TfsVariable;
  1663. begin
  1664. if Find(Name) <> nil then Exit;
  1665. v := TfsVariable.Create(Name, StrToVarType(Typ, Self), Typ);
  1666. v.Value := Value;
  1667. v.IsReadOnly := True;
  1668. v.FAddedBy := AddedBy;
  1669. Add(v);
  1670. end;
  1671. procedure TfsScript.AddEnum(const Typ, Names: String);
  1672. var
  1673. i: Integer;
  1674. v: TfsVariable;
  1675. sl: TStringList;
  1676. begin
  1677. v := TfsVariable.Create(Typ, fvtEnum, Typ);
  1678. v.FAddedBy := AddedBy;
  1679. Add(v);
  1680. sl := TStringList.Create;
  1681. sl.CommaText := Names;
  1682. try
  1683. for i := 0 to sl.Count - 1 do
  1684. begin
  1685. v := TfsVariable.Create(Trim(sl[i]), fvtEnum, Typ);
  1686. v.Value := i;
  1687. v.IsReadOnly := True;
  1688. v.FAddedBy := AddedBy;
  1689. Add(v);
  1690. end;
  1691. finally
  1692. sl.Free;
  1693. end;
  1694. end;
  1695. procedure TfsScript.AddEnumSet(const Typ, Names: String);
  1696. var
  1697. i, j: Integer;
  1698. v: TfsVariable;
  1699. sl: TStringList;
  1700. begin
  1701. v := TfsVariable.Create(Typ, fvtEnum, Typ);
  1702. v.FAddedBy := AddedBy;
  1703. Add(v);
  1704. sl := TStringList.Create;
  1705. sl.CommaText := Names;
  1706. try
  1707. j := 1;
  1708. for i := 0 to sl.Count - 1 do
  1709. begin
  1710. v := TfsVariable.Create(Trim(sl[i]), fvtEnum, Typ);
  1711. v.Value := j;
  1712. v.IsReadOnly := True;
  1713. v.FAddedBy := AddedBy;
  1714. Add(v);
  1715. j := j * 2;
  1716. end;
  1717. finally
  1718. sl.Free;
  1719. end;
  1720. end;
  1721. procedure TfsScript.AddMethod(const Syntax: String; CallEvent: TfsCallMethodEvent;
  1722. const Category: String = ''; const Description: String = '');
  1723. var
  1724. v: TfsMethodHelper;
  1725. begin
  1726. v := TfsMethodHelper.Create(Syntax, CallEvent, Self);
  1727. v.FAddedBy := AddedBy;
  1728. if Description = '' then
  1729. v.FDescription := v.Name else
  1730. v.FDescription := Description;
  1731. v.FCategory := Category;
  1732. Add(v);
  1733. end;
  1734. procedure TfsScript.AddObject(const Name: String; Obj: TObject);
  1735. begin
  1736. AddConst(Name, Obj.ClassName, Integer(Obj));
  1737. end;
  1738. procedure TfsScript.AddVariable(const Name, Typ: String; const Value: Variant);
  1739. var
  1740. v: TfsVariable;
  1741. begin
  1742. if Find(Name) <> nil then Exit;
  1743. v := TfsVariable.Create(Name, StrToVarType(Typ, Self), Typ);
  1744. v.Value := Value;
  1745. v.FAddedBy := AddedBy;
  1746. Add(v);
  1747. end;
  1748. procedure TfsScript.AddForm(Form: TComponent);
  1749. begin
  1750. AddComponent(Form);
  1751. end;
  1752. procedure TfsScript.AddComponent(Form: TComponent);
  1753. var
  1754. i: Integer;
  1755. v: TfsClassVariable;
  1756. begin
  1757. {$IFNDEF NOFORMS}
  1758. v := FindClass(Form.ClassName);
  1759. if v = nil then
  1760. begin
  1761. if Form.InheritsFrom(TForm) then
  1762. AddClass(Form.ClassType, 'TForm')
  1763. else if Form.InheritsFrom(TDataModule) then
  1764. AddClass(Form.ClassType, 'TDataModule')
  1765. else
  1766. Exit;
  1767. v := FindClass(Form.ClassName);
  1768. end;
  1769. for i := 0 to Form.ComponentCount - 1 do
  1770. v.AddComponent(Form.Components[i]);
  1771. AddObject(Form.Name, Form);
  1772. {$ENDIF}
  1773. end;
  1774. function TfsScript.CallFunction(const Name: String; const Params: Variant): Variant;
  1775. var
  1776. i: Integer;
  1777. v: TfsCustomVariable;
  1778. p: TfsProcVariable;
  1779. begin
  1780. v := FindLocal(Name);
  1781. if (v <> nil) and (v is TfsProcVariable) then
  1782. begin
  1783. p := TfsProcVariable(v);
  1784. if VarIsArray(Params) then
  1785. for i := 0 to VarArrayHighBound(Params, 1) do
  1786. p.Params[i].Value := Params[i];
  1787. Result := p.Value;
  1788. end
  1789. else
  1790. Result := Null;
  1791. end;
  1792. function TfsScript.CallFunction1(const Name: String; var Params: Variant): Variant;
  1793. var
  1794. i: Integer;
  1795. v: TfsCustomVariable;
  1796. p: TfsProcVariable;
  1797. begin
  1798. v := FindLocal(Name);
  1799. if (v <> nil) and (v is TfsProcVariable) then
  1800. begin
  1801. p := TfsProcVariable(v);
  1802. if VarIsArray(Params) then
  1803. for i := 0 to VarArrayHighBound(Params, 1) do
  1804. p.Params[i].Value := Params[i];
  1805. Result := p.Value;
  1806. if VarIsArray(Params) then
  1807. for i := 0 to VarArrayHighBound(Params, 1) do
  1808. Params[i] := p.Params[i].Value;
  1809. end
  1810. else
  1811. Result := Null;
  1812. end;
  1813. function TfsScript.Evaluate(const Expression: String): Variant;
  1814. var
  1815. p: TfsScript;
  1816. Prog: TfsScript;
  1817. SaveEvent: TfsRunLineEvent;
  1818. begin
  1819. Result := Null;
  1820. if FProgRunning = nil then
  1821. p := Self else
  1822. p := FProgRunning;
  1823. Prog := TfsScript.Create(nil);
  1824. Prog.Parent := p;
  1825. SaveEvent := FOnRunLine;
  1826. FOnRunLine := nil;
  1827. try
  1828. Prog.Lines.Text := 'function __f__: Variant; begin Result := ' + Expression +
  1829. ' end; begin end.';
  1830. if not Prog.Compile then
  1831. Result := Prog.ErrorMsg else
  1832. Result := Prog.FindLocal('__f__').Value;
  1833. finally
  1834. Prog.Free;
  1835. FOnRunLine := SaveEvent;
  1836. end;
  1837. end;
  1838. function TfsScript.FindClass(const Name: String): TfsClassVariable;
  1839. var
  1840. Item: TfsCustomVariable;
  1841. begin
  1842. Item := Find(Name);
  1843. if (Item <> nil) and (Item is TfsClassVariable) then
  1844. Result := TfsClassVariable(Item) else
  1845. Result := nil
  1846. end;
  1847. procedure TfsScript.RunLine(const UnitName, Index: String);
  1848. var
  1849. p: TfsScript;
  1850. begin
  1851. p := Self;
  1852. while p <> nil do
  1853. if Assigned(p.FOnRunLine) then
  1854. begin
  1855. p.FOnRunLine(Self, UnitName, Index);
  1856. break;
  1857. end
  1858. else
  1859. p := p.FParent;
  1860. end;
  1861. function TfsScript.GetVariables(Index: String): Variant;
  1862. var
  1863. v: TfsCustomVariable;
  1864. begin
  1865. v := Find(Index);
  1866. if v <> nil then
  1867. Result := v.Value else
  1868. Result := Null;
  1869. end;
  1870. procedure TfsScript.SetVariables(Index: String; const Value: Variant);
  1871. var
  1872. v: TfsCustomVariable;
  1873. begin
  1874. v := Find(Index);
  1875. if v <> nil then
  1876. v.Value := Value else
  1877. AddVariable(Index, 'Variant', Value);
  1878. end;
  1879. procedure TfsScript.SetLines(const Value: TStrings);
  1880. begin
  1881. FLines.Assign(Value);
  1882. end;
  1883. procedure TfsScript.Terminate;
  1884. procedure TerminateAll(Script: TfsScript);
  1885. var
  1886. i: Integer;
  1887. begin
  1888. Script.FExitCalled := True;
  1889. Script.FTerminated := True;
  1890. for i := 0 to Script.Count - 1 do
  1891. if Script.Items[i] is TfsProcVariable then
  1892. TerminateAll(TfsProcVariable(Script.Items[i]).Prog);
  1893. end;
  1894. begin
  1895. TerminateAll(Self);
  1896. end;
  1897. procedure TfsScript.AddCodeLine(const UnitName, APos: String);
  1898. var
  1899. sl: TStringList;
  1900. LineN: String;
  1901. begin
  1902. if FUnitLines.IndexOfName(UnitName) = -1 then
  1903. FUnitLines.Add(UnitName + '=');
  1904. sl := TStringList.Create;
  1905. sl.CommaText := FUnitLines.Values[UnitName];
  1906. LineN := Copy(APos, 1, Pos(':', APos) - 1);
  1907. if sl.IndexOf(LineN) = -1 then
  1908. FUnitLines.Values[UnitName] := FUnitLines.Values[UnitName] + LineN + ',';
  1909. sl.Free;
  1910. end;
  1911. function TfsScript.IsExecutableLine(LineN: Integer; const UnitName: String = ''): Boolean;
  1912. var
  1913. sl: TStringList;
  1914. begin
  1915. Result := False;
  1916. if FUnitLines.IndexOfName(UnitName) = -1 then Exit;
  1917. sl := TStringList.Create;
  1918. sl.CommaText := FUnitLines.Values[UnitName];
  1919. if sl.IndexOf(IntToStr(LineN)) <> -1 then
  1920. Result := True;
  1921. sl.Free;
  1922. end;
  1923. { TfsStatement }
  1924. constructor TfsStatement.Create(AProgram: TfsScript; const UnitName,
  1925. SourcePos: String);
  1926. begin
  1927. inherited Create;
  1928. FProgram := AProgram;
  1929. FSourcePos := SourcePos;
  1930. FUnitName := UnitName;
  1931. end;
  1932. function TfsStatement.GetItem(Index: Integer): TfsStatement;
  1933. begin
  1934. Result := FItems[Index];
  1935. end;
  1936. procedure TfsStatement.Execute;
  1937. var
  1938. i: Integer;
  1939. begin
  1940. for i := 0 to Count - 1 do
  1941. begin
  1942. if FProgram.FTerminated then break;
  1943. Items[i].Execute;
  1944. if FProgram.FBreakCalled or FProgram.FContinueCalled or
  1945. FProgram.FExitCalled then break;
  1946. end;
  1947. end;
  1948. procedure TfsStatement.RunLine;
  1949. begin
  1950. FProgram.RunLine(FUnitName, FSourcePos);
  1951. end;
  1952. { TfsAssignmentStmt }
  1953. destructor TfsAssignmentStmt.Destroy;
  1954. begin
  1955. FDesignator.Free;
  1956. FExpression.Free;
  1957. inherited;
  1958. end;
  1959. procedure TfsAssignmentStmt.Optimize;
  1960. begin
  1961. FVar := FDesignator;
  1962. FExpr := FExpression;
  1963. if FDesignator is TfsVariableDesignator then
  1964. FVar := FDesignator.RefItem;
  1965. if TfsExpression(FExpression).SingleItem <> nil then
  1966. FExpr := TfsExpression(FExpression).SingleItem;
  1967. end;
  1968. procedure TfsAssignmentStmt.Execute;
  1969. begin
  1970. RunLine;
  1971. if FProgram.FTerminated then Exit;
  1972. FVar.Value := FExpr.Value;
  1973. end;
  1974. procedure TfsAssignPlusStmt.Execute;
  1975. begin
  1976. RunLine;
  1977. if FProgram.FTerminated then Exit;
  1978. FVar.Value := FVar.Value + FExpr.Value;
  1979. end;
  1980. procedure TfsAssignMinusStmt.Execute;
  1981. begin
  1982. RunLine;
  1983. if FProgram.FTerminated then Exit;
  1984. FVar.Value := FVar.Value - FExpr.Value;
  1985. end;
  1986. procedure TfsAssignMulStmt.Execute;
  1987. begin
  1988. RunLine;
  1989. if FProgram.FTerminated then Exit;
  1990. FVar.Value := FVar.Value * FExpr.Value;
  1991. end;
  1992. procedure TfsAssignDivStmt.Execute;
  1993. begin
  1994. RunLine;
  1995. if FProgram.FTerminated then Exit;
  1996. FVar.Value := FVar.Value / FExpr.Value;
  1997. end;
  1998. { TfsCallStmt }
  1999. destructor TfsCallStmt.Destroy;
  2000. begin
  2001. FDesignator.Free;
  2002. inherited;
  2003. end;
  2004. procedure TfsCallStmt.Execute;
  2005. begin
  2006. RunLine;
  2007. if FProgram.FTerminated then Exit;
  2008. if FModificator = '' then
  2009. begin
  2010. FDesignator.NeedResult := False;
  2011. FDesignator.Value;
  2012. end
  2013. else if FModificator = '+' then
  2014. FDesignator.Value := FDesignator.Value + 1
  2015. else if FModificator = '-' then
  2016. FDesignator.Value := FDesignator.Value - 1
  2017. end;
  2018. { TfsIfStmt }
  2019. constructor TfsIfStmt.Create(AProgram: TfsScript; const UnitName,
  2020. SourcePos: String);
  2021. begin
  2022. inherited;
  2023. FElseStmt := TfsStatement.Create(FProgram, UnitName, SourcePos);
  2024. end;
  2025. destructor TfsIfStmt.Destroy;
  2026. begin
  2027. FCondition.Free;
  2028. FElseStmt.Free;
  2029. inherited;
  2030. end;
  2031. procedure TfsIfStmt.Execute;
  2032. begin
  2033. RunLine;
  2034. if FProgram.FTerminated then Exit;
  2035. if Boolean(FCondition.Value) = True then
  2036. inherited Execute else
  2037. FElseStmt.Execute;
  2038. end;
  2039. { TfsRepeatStmt }
  2040. destructor TfsRepeatStmt.Destroy;
  2041. begin
  2042. FCondition.Free;
  2043. inherited;
  2044. end;
  2045. procedure TfsRepeatStmt.Execute;
  2046. begin
  2047. RunLine;
  2048. if FProgram.FTerminated then Exit;
  2049. repeat
  2050. inherited Execute;
  2051. if FProgram.FBreakCalled or FProgram.FExitCalled then break;
  2052. FProgram.FContinueCalled := False;
  2053. until Boolean(FCondition.Value) = not FInverseCondition;
  2054. FProgram.FBreakCalled := False;
  2055. end;
  2056. { TfsWhileStmt }
  2057. destructor TfsWhileStmt.Destroy;
  2058. begin
  2059. FCondition.Free;
  2060. inherited;
  2061. end;
  2062. procedure TfsWhileStmt.Execute;
  2063. begin
  2064. RunLine;
  2065. if FProgram.FTerminated then Exit;
  2066. while Boolean(FCondition.Value) = True do
  2067. begin
  2068. inherited Execute;
  2069. if FProgram.FBreakCalled or FProgram.FExitCalled then break;
  2070. FProgram.FContinueCalled := False;
  2071. end;
  2072. FProgram.FBreakCalled := False;
  2073. end;
  2074. { TfsForStmt }
  2075. destructor TfsForStmt.Destroy;
  2076. begin
  2077. FBeginValue.Free;
  2078. FEndValue.Free;
  2079. inherited;
  2080. end;
  2081. procedure TfsForStmt.Execute;
  2082. var
  2083. i, bValue, eValue: Integer;
  2084. begin
  2085. bValue := FBeginValue.Value;
  2086. eValue := FEndValue.Value;
  2087. RunLine;
  2088. if FProgram.FTerminated then Exit;
  2089. if FDown then
  2090. for i := bValue downto eValue do
  2091. begin
  2092. FVariable.FValue := i;
  2093. inherited Execute;
  2094. if FProgram.FBreakCalled or FProgram.FExitCalled then break;
  2095. FProgram.FContinueCalled := False;
  2096. end
  2097. else
  2098. for i := bValue to eValue do
  2099. begin
  2100. FVariable.FValue := i;
  2101. inherited Execute;
  2102. if FProgram.FBreakCalled or FProgram.FExitCalled then break;
  2103. FProgram.FContinueCalled := False;
  2104. end;
  2105. FProgram.FBreakCalled := False;
  2106. end;
  2107. { TfsVbForStmt }
  2108. destructor TfsVbForStmt.Destroy;
  2109. begin
  2110. FBeginValue.Free;
  2111. FEndValue.Free;
  2112. if FStep <> nil then
  2113. FStep.Free;
  2114. inherited;
  2115. end;
  2116. procedure TfsVbForStmt.Execute;
  2117. var
  2118. i, bValue, eValue, sValue: Variant;
  2119. Down: Boolean;
  2120. begin
  2121. bValue := FBeginValue.Value;
  2122. eValue := FEndValue.Value;
  2123. if FStep <> nil then
  2124. sValue := FStep.Value else
  2125. sValue := 1;
  2126. Down := sValue < 0;
  2127. RunLine;
  2128. if FProgram.FTerminated then Exit;
  2129. i := bValue;
  2130. if Down then
  2131. while i >= eValue do
  2132. begin
  2133. FVariable.FValue := i;
  2134. inherited Execute;
  2135. if FProgram.FBreakCalled or FProgram.FExitCalled then break;
  2136. FProgram.FContinueCalled := False;
  2137. i := i + sValue;
  2138. end
  2139. else
  2140. while i <= eValue do
  2141. begin
  2142. FVariable.FValue := i;
  2143. inherited Execute;
  2144. if FProgram.FBreakCalled or FProgram.FExitCalled then break;
  2145. FProgram.FContinueCalled := False;
  2146. i := i + sValue;
  2147. end;
  2148. FProgram.FBreakCalled := False;
  2149. end;
  2150. { TfsCppForStmt }
  2151. constructor TfsCppForStmt.Create(AProgram: TfsScript; const UnitName,
  2152. SourcePos: String);
  2153. begin
  2154. inherited;
  2155. FFirstStmt := TfsStatement.Create(FProgram, UnitName, SourcePos);
  2156. FSecondStmt := TfsStatement.Create(FProgram, UnitName, SourcePos);
  2157. end;
  2158. destructor TfsCppForStmt.Destroy;
  2159. begin
  2160. FFirstStmt.Free;
  2161. FExpression.Free;
  2162. FSecondStmt.Free;
  2163. inherited;
  2164. end;
  2165. procedure TfsCppForStmt.Execute;
  2166. begin
  2167. RunLine;
  2168. if FProgram.FTerminated then Exit;
  2169. FFirstStmt.Execute;
  2170. if FProgram.FTerminated then Exit;
  2171. while Boolean(FExpression.Value) = True do
  2172. begin
  2173. inherited Execute;
  2174. if FProgram.FBreakCalled or FProgram.FExitCalled then break;
  2175. FProgram.FContinueCalled := False;
  2176. FSecondStmt.Execute;
  2177. end;
  2178. FProgram.FBreakCalled := False;
  2179. end;
  2180. { TfsCaseSelector }
  2181. destructor TfsCaseSelector.Destroy;
  2182. begin
  2183. FSetExpression.Free;
  2184. inherited;
  2185. end;
  2186. function TfsCaseSelector.Check(const Value: Variant): Boolean;
  2187. begin
  2188. Result := FSetExpression.Check(Value);
  2189. end;
  2190. { TfsCaseStmt }
  2191. constructor TfsCaseStmt.Create(AProgram: TfsScript; const UnitName,
  2192. SourcePos: String);
  2193. begin
  2194. inherited;
  2195. FElseStmt := TfsStatement.Create(FProgram, UnitName, SourcePos);
  2196. end;
  2197. destructor TfsCaseStmt.Destroy;
  2198. begin
  2199. FCondition.Free;
  2200. FElseStmt.Free;
  2201. inherited;
  2202. end;
  2203. procedure TfsCaseStmt.Execute;
  2204. var
  2205. i: Integer;
  2206. Value: Variant;
  2207. Executed: Boolean;
  2208. begin
  2209. Value := FCondition.Value;
  2210. Executed := False;
  2211. RunLine;
  2212. if FProgram.FTerminated then Exit;
  2213. for i := 0 to Count - 1 do
  2214. if TfsCaseSelector(Items[i]).Check(Value) then
  2215. begin
  2216. Items[i].Execute;
  2217. Executed := True;
  2218. break;
  2219. end;
  2220. if not Executed then
  2221. FElseStmt.Execute;
  2222. end;
  2223. { TfsTryStmt }
  2224. constructor TfsTryStmt.Create(AProgram: TfsScript; const UnitName,
  2225. SourcePos: String);
  2226. begin
  2227. inherited;
  2228. FExceptStmt := TfsStatement.Create(AProgram, UnitName, SourcePos);
  2229. end;
  2230. destructor TfsTryStmt.Destroy;
  2231. begin
  2232. FExceptStmt.Free;
  2233. inherited;
  2234. end;
  2235. procedure TfsTryStmt.Execute;
  2236. var
  2237. SaveExitCalled: Boolean;
  2238. begin
  2239. RunLine;
  2240. if FProgram.FTerminated then E