1 {
2  ***************************************************************************
3  *                                                                         *
4  *   This source is free software; you can redistribute it and/or modify   *
5  *   it under the terms of the GNU General Public License as published by  *
6  *   the Free Software Foundation; either version 2 of the License, or     *
7  *   (at your option) any later version.                                   *
8  *                                                                         *
9  *   This code is distributed in the hope that it will be useful, but      *
10  *   WITHOUT ANY WARRANTY; without even the implied warranty of            *
11  *   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU     *
12  *   General Public License for more details.                              *
13  *                                                                         *
14  *   A copy of the GNU General Public License is available on the World    *
15  *   Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also      *
16  *   obtain it by writing to the Free Software Foundation,                 *
17  *   Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA.   *
18  *                                                                         *
19  ***************************************************************************
20 
21   Author: Mattias Gaertner
22 
23   Abstract:
24     TCTConfigScriptEngine implements an interpreter for a simple scripting
25     language, enough for configurations.
26 
27   Working:
28     if, then, else, begin..end, ;
29     ()
30     boolean operators: not, and, or, xor
31     operators: =, <>, >, <, <=, >=, +
32     variables
33     constants: decimal, $hex, &octal, %binary, 'string', #character
34     functions: string(), integer(), int64(), defined(), undefined()
35     procedures: undefine()
36     assignments: :=, +=
37 
38   Not supported:
39     - floats
40     - types
41     - objects
42     - loops
43     - custom functions
44 }
45 unit CodeToolsCfgScript;
46 
47 {$mode objfpc}{$H+}
48 {$inline on}
49 
50 {off $Define VerboseCTCfgScript}
51 {off $DEFINE CheckCTCfgVars}
52 
53 interface
54 
55 uses
56   Classes, SysUtils, typinfo, Laz_AVL_Tree,
57   // Codetools
58   BasicCodeTools, KeywordFuncLists, FileProcs, CodeToolsStrConsts;
59 
60 type
61   ECodeToolCfgScript = class(Exception);
62 
63   TCTCSValueType = (
64     ctcsvNone,
65     ctcsvString,
66     ctcsvNumber
67     );
68 
69   { TCTCfgScriptVariable }
70 
71   TCTCfgScriptVariable = record
72     Name: PChar;
73     ValueType: TCTCSValueType;
74     case Integer of
75     0: (StrStart: PChar; StrLen: integer);
76     1: (Number: int64);
77   end;
78   PCTCfgScriptVariable = ^TCTCfgScriptVariable;
79 
80 
81   { TCTCfgScriptVariables }
82 
83   TCTCfgScriptVariables = class
84   private
85     FItems: TAVLTree; // tree of PCTCfgScriptVariable sorted for name
GetValuesnull86     function GetValues(const Name: string): string;
87     procedure SetValues(const Name: string; const AValue: string);
88   public
89     constructor Create;
90     destructor Destroy; override;
91     procedure Clear;
Equalsnull92     function Equals(Vars: TCTCfgScriptVariables): boolean; reintroduce;
93     procedure Assign(Source: TCTCfgScriptVariables); overload;
94     procedure Assign(Source: TStrings); overload;
95     procedure AddOverrides(Source: TCTCfgScriptVariables);
96     procedure AddOverride(Source: PCTCfgScriptVariable);
GetVariablenull97     function GetVariable(const Name: PChar;
98                       CreateIfNotExists: Boolean = false): PCTCfgScriptVariable;
99     property Values[const Name: string]: string read GetValues write SetValues; default;
100     procedure Undefine(Name: PChar);
101     procedure Define(Name: PChar; const Value: string);
IsDefinednull102     function IsDefined(Name: PChar): boolean;
103     property Tree: TAVLTree read FItems;
104     procedure WriteDebugReport(const Title: string; const Prefix: string = '');
105   end;
106   PCTCfgScriptVariables = ^TCTCfgScriptVariables;
107 
108 type
109   TCTCfgScriptOperator = (
110     ctcsoNone,
111     ctcsoNot,
112     ctcsoAnd,
113     ctcsoOr,
114     ctcsoXOr,
115     ctcsoShL,
116     ctcsoShR,
117     ctcsoDiv,
118     ctcsoMod,
119     ctcsoPlus,
120     ctcsoMinus,
121     ctcsoMultiply,
122     ctcsoDivide,
123     ctcsoEqual,
124     ctcsoNotEqual,
125     ctcsoLowerThan,
126     ctcsoLowerOrEqualThan,
127     ctcsoGreaterThan,
128     ctcsoGreaterOrEqualThan
129     );
130   TCTCfgScriptOperators = set of TCTCfgScriptOperator;
131 const
132   CTCfgScriptOperatorLvl: array[TCTCfgScriptOperator] of integer = (
133     0, //ctcsoNone,
134     1, //ctcsoNot,
135     1, //ctcsoAnd,
136     2, //ctcsoOr,
137     2, //ctcsoXOr,
138     1, //ctcsoShL,
139     1, //ctcsoShR,
140     1, //ctcsoDiv,
141     1, //ctcsoMod,
142     2, //ctcsoPlus,
143     2, //ctcsoMinus,
144     1, //ctcsoMultiply,
145     1, //ctcsoDivide,
146     4, //ctcsoEqual,
147     4, //ctcsoNotEqual,
148     4, //ctcsoLowerThan,
149     4, //ctcsoLowerOrEqualThan,
150     4, //ctcsoGreaterThan,
151     4  //ctcsoGreaterOrEqualThan
152     );
153 type
154   TCTCfgScriptStackItemType = (
155     ctcssNone,
156     ctcssStatement,
157     ctcssBegin,
158     ctcssIf,
159     ctcssIfThen,
160     ctcssIfElse,
161     ctcssExpression,
162     ctcssRoundBracketOpen,
163     ctcssOperand,
164     ctcssOperator,
165     ctcssAssignment
166     );
167 const
168   ctcssAllStatementStarts = [ctcssNone,ctcssIfThen,ctcssIfElse,ctcssBegin];
169 type
170   TCTCfgScriptStackItem = record
171     Typ: TCTCfgScriptStackItemType;
172     StartPos: PChar;
173     Operand: TCTCfgScriptVariable;
174   end;
175   PCTCfgScriptStackItem = ^TCTCfgScriptStackItem;
176 
177 type
178   { TCTCfgScriptStack }
179 
180   TCTCfgScriptStack = class
181   public
182     Items: PCTCfgScriptStackItem;
183     Top: integer; // current item, -1 = empty
184     TopTyp: TCTCfgScriptStackItemType;
185     Capacity: integer;
186     constructor Create;
187     destructor Destroy; override;
188     procedure Clear;
189     procedure Push(Typ: TCTCfgScriptStackItemType; const StartPos: PChar);
190     procedure Pop(Count: integer = 1);
191     procedure Delete(Index: integer);
TopItemnull192     function TopItem: PCTCfgScriptStackItem;
TopItemOperandnull193     function TopItemOperand: PCTCfgScriptVariable;
194     {$IFDEF CheckCTCfgVars}
195     procedure CheckOperands;
196     {$ENDIF}
197   end;
198 
199   { TCTCfgScriptError }
200 
201   TCTCfgScriptError = class
202   public
203     Msg: string;
204     Position: integer;
205     Line: integer;
206     Column: integer;
207     constructor Create(const aMsg: string; aPos, aLine, aCol: integer);
208     constructor Create(const aMsg: string);
209   end;
210 
211   { TCTConfigScriptEngine }
212 
213   TCTConfigScriptEngine = class
214   protected
215     FVariables: TCTCfgScriptVariables;
216     FStack: TCTCfgScriptStack;
217     FErrors: TFPList; // list of TCTCfgScriptError
GetErrorsnull218     function GetErrors(Index: integer): TCTCfgScriptError;
219     procedure AddError(const aMsg: string; ErrorPos: PChar); overload;
220     procedure AddError(const aMsg: string); overload;
221     procedure PushNumberConstant;
222     procedure PushBooleanValue(b: boolean);
223     procedure PushNumberValue(const Number: int64);
RunDefinednull224     function RunDefined(Negate: boolean): boolean;
RunFunctionnull225     function RunFunction: boolean;
226     procedure PushStringConstant;
227     procedure RunStatement(Skip: boolean);
228     procedure RunBegin(Skip: boolean);
229     procedure RunIf(Skip: boolean);
230     procedure RunUndefine(Skip: boolean);
231     procedure RunAssignment(Skip: boolean);
RunExpressionnull232     function RunExpression: boolean; // if true the stack top has an operand
ExecuteStacknull233     function ExecuteStack(MaxLevel: integer): boolean;
GetOperatorLevelnull234     function GetOperatorLevel(P: PChar): integer;
IsKeyWordnull235     function IsKeyWord(P: PChar): boolean;
IsFunctionnull236     function IsFunction(P: PChar): boolean;
IsCustomFunctionnull237     function IsCustomFunction({%H-}FunctionName: PChar): boolean; virtual;
238     procedure RunCustomSimpleFunction({%H-}FunctionName: PChar; {%H-}Value: PCTCfgScriptVariable); virtual;
239   public
240     Src: PChar;
241     AtomStart: PChar;
242     SrcStart, SrcEnd: PChar;
243     MaxErrorCount: integer;
244     constructor Create;
245     destructor Destroy; override;
246     procedure ClearErrors;
247     property Variables: TCTCfgScriptVariables read FVariables;
Executenull248     function Execute(const Source: string; StopAfterErrors: integer = 1): boolean;// true if no errors
ErrorCountnull249     function ErrorCount: integer;
250     property Errors[Index: integer]: TCTCfgScriptError read GetErrors;
GetAtomnull251     function GetAtom: string;
GetAtomOrNothingnull252     function GetAtomOrNothing: string;
GetAtomnull253     function GetAtom(P: PChar): string;
PosToLineColnull254     function PosToLineCol(p: PChar; out Line, Column: integer): boolean;
PosToStrnull255     function PosToStr(p: PChar): string;
GetErrorStrnull256     function GetErrorStr(Index: integer): string;
257 
258     procedure WriteDebugReportStack(Title: string);
259   end;
260 
261 procedure RenameCTCSVariable(var Src: string; const OldName, NewName: string);
262 
CompareCTCSVariablesnull263 function CompareCTCSVariables(Var1, Var2: Pointer): integer;
ComparePCharWithCTCSVariableNamenull264 function ComparePCharWithCTCSVariableName(Name, aVar: Pointer): integer;
AreCTCSVariablesEqualnull265 function AreCTCSVariablesEqual(const V1, V2: PCTCfgScriptVariable): Boolean;
AreCTCSVariablesExactEqualnull266 function AreCTCSVariablesExactEqual(const V1, V2: PCTCfgScriptVariable): Boolean;
CompareCTCSVariablesnull267 function CompareCTCSVariables(const Left, Right: PCTCfgScriptVariable;
268                            out Equal, LeftIsLowerThanRight: boolean): boolean;
NewCTCSVariablenull269 function NewCTCSVariable: PCTCfgScriptVariable;
NewCTCSVariablenull270 function NewCTCSVariable(CloneName: PChar): PCTCfgScriptVariable;
CloneCTCSVariablenull271 function CloneCTCSVariable(const V: PCTCfgScriptVariable): PCTCfgScriptVariable;
272 procedure FreeCTCSVariable(var V: PCTCfgScriptVariable);
273 procedure ClearCTCSVariable(const V: PCTCfgScriptVariable);
274 procedure SetCTCSVariableAsString(const V: PCTCfgScriptVariable; const s: string);
275 procedure SetCTCSVariableAsNumber(const V: PCTCfgScriptVariable; const i: int64);
276 procedure SetCTCSVariableValue(const Src, Dest: PCTCfgScriptVariable);
GetCTCSVariableAsStringnull277 function GetCTCSVariableAsString(const V: PCTCfgScriptVariable): string;
278 procedure MakeCTCSVariableString(const V: PCTCfgScriptVariable);
279 procedure MakeCTCSVariableInt64(const V: PCTCfgScriptVariable);
280 procedure MakeCTCSVariableInteger(const V: PCTCfgScriptVariable);
281 procedure AddCTCSVariables(const AddVar, SumVar: PCTCfgScriptVariable);
CTCSNumberEqualsStringnull282 function CTCSNumberEqualsString(const Number: int64; const P: PChar): boolean; inline;
CTCSVariableIsTruenull283 function CTCSVariableIsTrue(const V: PCTCfgScriptVariable): boolean; inline;
CTCSVariableIsFalsenull284 function CTCSVariableIsFalse(const V: PCTCfgScriptVariable): boolean;
285 
CTCSStringToNumbernull286 function CTCSStringToNumber(P: PChar; out Number: int64): boolean;
AtomToCTCfgOperatornull287 function AtomToCTCfgOperator(p: PChar): TCTCfgScriptOperator;
288 
289 procedure CheckCTCSVariable(const V: PCTCfgScriptVariable);
dbgsnull290 function dbgs(const t: TCTCfgScriptStackItemType): string; overload;
dbgsnull291 function dbgs(const t: TCTCSValueType): string; overload;
dbgsnull292 function dbgs(const t: TCTCfgScriptOperator): string; overload;
dbgsnull293 function dbgs(const V: PCTCfgScriptVariable): string; overload;
294 
295 
296 implementation
297 
298 procedure RenameCTCSVariable(var Src: string; const OldName, NewName: string);
299 var
300   p: PChar;
301   AtomStart: PChar;
302   SrcPos: PtrUInt;
303 begin
304   if (Src='') or not IsValidIdent(OldName) or (NewName='') then exit;
305   p:=PChar(Src);
306   //debugln(['RenameCTCSVariable START ',dbgstr(Src)]);
307   repeat
308     ReadRawNextPascalAtom(p,AtomStart,nil,false,true);
309     if (p=AtomStart) then break;
310     if IsIdentStartChar[AtomStart^]
311     and (CompareIdentifierPtrs(PChar(OldName),AtomStart)=0)
312     then begin
313       SrcPos:=PtrUInt(AtomStart-PChar(Src))+1;
314 
315       Src:=copy(Src,1,SrcPos-1)+NewName+copy(Src,SrcPos+PtrUInt(length(OldName)),length(Src));
316       p:=@Src[SrcPos]+length(NewName);
317     end;
318   until false;
319   //debugln(['RenameCTCSVariable END ',dbgstr(Src)]);
320 end;
321 
CompareCTCSVariablesnull322 function CompareCTCSVariables(Var1, Var2: Pointer): integer;
323 var
324   v1: PCTCfgScriptVariable absolute Var1;
325   v2: PCTCfgScriptVariable absolute Var2;
326 begin
327   {$IFDEF CheckCTCfgVars}
328   CheckCTCSVariable(v1);
329   CheckCTCSVariable(v2);
330   {$ENDIF}
331   Result:=CompareIdentifiers(v1^.Name,v2^.Name);
332 end;
333 
ComparePCharWithCTCSVariableNamenull334 function ComparePCharWithCTCSVariableName(Name, aVar: Pointer): integer;
335 var
336   n: PChar absolute Name;
337   v: PCTCfgScriptVariable absolute aVar;
338 begin
339   {$IFDEF CheckCTCfgVars}CheckCTCSVariable(v);{$ENDIF}
340   Result:=CompareIdentifiers(n,v^.Name);
341 end;
342 
AreCTCSVariablesEqualnull343 function AreCTCSVariablesEqual(const V1, V2: PCTCfgScriptVariable): Boolean;
344 begin
345   {$IFDEF CheckCTCfgVars}
346   CheckCTCSVariable(v1);
347   CheckCTCSVariable(v2);
348   {$ENDIF}
349   Result:=false;
350   case V1^.ValueType of
351   ctcsvNone:
352     exit; // invalid is never equal to anything
353   ctcsvString:
354     case V2^.ValueType of
355     ctcsvNone: exit;
356     ctcsvString:
357       if (V1^.StrLen<>V2^.StrLen)
358           or ((V1^.StrStart<>nil)
359               and (not CompareMem(V1^.StrStart,V2^.StrStart,V1^.StrLen)))
360       then exit;
361     ctcsvNumber:
362       if not CTCSNumberEqualsString(V2^.Number,V1^.StrStart) then exit;
363     end;
364   ctcsvNumber:
365     case V2^.ValueType of
366     ctcsvNone: exit;
367     ctcsvString:
368       if not CTCSNumberEqualsString(V1^.Number,V2^.StrStart) then exit;
369     ctcsvNumber:
370       if V1^.Number<>V2^.Number then exit;
371     end;
372   end;
373   Result:=true;
374 end;
375 
AreCTCSVariablesExactEqualnull376 function AreCTCSVariablesExactEqual(const V1, V2: PCTCfgScriptVariable
377   ): Boolean;
378 begin
379   {$IFDEF CheckCTCfgVars}
380   CheckCTCSVariable(v1);
381   CheckCTCSVariable(v2);
382   {$ENDIF}
383   Result:=false;
384   if V1^.ValueType<>V2^.ValueType then exit;
385   case V1^.ValueType of
386   ctcsvNone: ;
387   ctcsvString: if (V1^.StrLen<>V2^.StrLen)
388                  or ((V1^.StrStart<>nil)
389                      and (not CompareMem(V1^.StrStart,V2^.StrStart,V1^.StrLen)))
390                then exit;
391   ctcsvNumber: if V1^.Number<>V2^.Number then exit;
392   end;
393   Result:=true;
394 end;
395 
CompareCTCSVariablesnull396 function CompareCTCSVariables(const Left, Right: PCTCfgScriptVariable; out
397   Equal, LeftIsLowerThanRight: boolean): boolean;
398 { Rules:
399     If one of the values is invalid, return false
400     If both are numbers, compare as numbers
401     Otherwise compare as string alphabetically case sensitive A<B, A<AA
402 }
403 
404   procedure CompareNumberWithString(Number: int64; p: PChar);
405   var
406     i: Integer;
407     Cnt: integer;
408     s: array[0..30] of char;
409   begin
410     if p=nil then begin
411       Equal:=false;
412       LeftIsLowerThanRight:=false;
413       exit;
414     end;
415     // convert number to decimal string
416     if Number=0 then begin
417       Cnt:=1;
418       s[0]:='0';
419     end else begin
420       Cnt:=0;
421       if Number<0 then begin
422         Cnt:=1;
423         s[0]:='-';
424         Number:=-Number;
425       end;
426       while Number>0 do begin
427         s[Cnt]:=chr(Number mod 10+ord('0'));
428         inc(Cnt);
429         Number:=Number div 10;
430       end;
431     end;
432     for i:=0 to Cnt-1 do begin
433       if p^<>s[i] then begin
434         Equal:=false;
435         LeftIsLowerThanRight:=s[i]<p^;
436         exit;
437       end;
438       inc(p);
439     end;
440     if p^=#0 then begin
441       Equal:=true;
442       LeftIsLowerThanRight:=false;
443     end else begin
444       Equal:=False;
445       LeftIsLowerThanRight:=true;
446     end;
447   end;
448 
449 var
450   V1: PChar;
451   V2: PChar;
452 begin
453   {$IFDEF CheckCTCfgVars}
454   CheckCTCSVariable(Left);
455   CheckCTCSVariable(Right);
456   {$ENDIF}
457   //debugln(['CompareCTCSVariables START Left=',dbgs(Left),' Right=',dbgs(Right)]);
458   Result:=false;
459   Equal:=false;
460   LeftIsLowerThanRight:=false;
461   case Left^.ValueType of
462   ctcsvNone:
463     exit; // invalid is never equal to anything
464   ctcsvString:
465     case Right^.ValueType of
466     ctcsvNone: exit;
467     ctcsvString:
468       begin
469         // compare two strings
470         V1:=Left^.StrStart;
471         V2:=Right^.StrStart;
472         if V1=nil then begin
473           if V2=nil then begin
474             Equal:=true;
475             LeftIsLowerThanRight:=false;
476           end else begin
477             Equal:=False;
478             LeftIsLowerThanRight:=true; // left is shorter than right
479           end;
480         end else begin
481           if V2=nil then begin
482             Equal:=False;
483             LeftIsLowerThanRight:=false; // left is longer than right
484           end else begin
485             repeat
486               if V1^=V2^ then begin
487                 if V1^=#0 then begin
488                   Equal:=true;
489                   LeftIsLowerThanRight:=false;
490                   break;
491                 end else begin
492                   inc(V1);
493                   inc(V2);
494                 end;
495               end else begin
496                 Equal:=false;
497                 LeftIsLowerThanRight:=V1^<V2^;
498                 break;
499               end;
500             until false;
501           end;
502         end;
503       end;
504     ctcsvNumber:
505       begin
506         CompareNumberWithString(Right^.Number,Left^.StrStart);
507         LeftIsLowerThanRight:=not LeftIsLowerThanRight;
508       end;
509     end;
510   ctcsvNumber:
511     case Right^.ValueType of
512     ctcsvNone: exit;
513     ctcsvString:
514       CompareNumberWithString(Left^.Number,Right^.StrStart);
515     ctcsvNumber:
516       begin
517         Equal:=Left^.Number=Right^.Number;
518         LeftIsLowerThanRight:=Left^.Number<Right^.Number;
519       end;
520     end;
521   end;
522   Result:=true;
523 end;
524 
NewCTCSVariablenull525 function NewCTCSVariable: PCTCfgScriptVariable;
526 begin
527   New(Result);
528   FillByte(Result^,SizeOf(TCTCfgScriptVariable),0);
529   {$IFDEF CheckCTCfgVars}
530   CheckCTCSVariable(Result);
531   {$ENDIF}
532 end;
533 
NewCTCSVariablenull534 function NewCTCSVariable(CloneName: PChar): PCTCfgScriptVariable;
535 var
536   l: LongInt;
537 begin
538   Result:=NewCTCSVariable();
539   l:=GetIdentLen(CloneName);
540   if l>0 then begin
541     Result^.Name:=GetMem(l+1);
542     System.Move(CloneName^,Result^.Name^,l);
543     Result^.Name[l]:=#0;
544   end;
545   {$IFDEF CheckCTCfgVars}
546   CheckCTCSVariable(Result);
547   {$ENDIF}
548 end;
549 
CloneCTCSVariablenull550 function CloneCTCSVariable(const V: PCTCfgScriptVariable): PCTCfgScriptVariable;
551 var
552   l: LongInt;
553 begin
554   {$IFDEF CheckCTCfgVars}
555   CheckCTCSVariable(v);
556   {$ENDIF}
557   Result:=NewCTCSVariable(V^.Name);
558   {$IFDEF CheckCTCfgVars}
559   CheckCTCSVariable(Result);
560   {$ENDIF}
561   Result^.ValueType:=V^.ValueType;
562   {$IFDEF CheckCTCfgVars}
563   CheckCTCSVariable(Result);
564   {$ENDIF}
565   case V^.ValueType of
566   ctcsvNone: ;
567   ctcsvString:
568     begin
569       l:=V^.StrLen;
570       if l>0 then begin
571         Result^.StrLen:=l;
572         Result^.StrStart:=GetMem(l+1);
573         System.Move(V^.StrStart^,Result^.StrStart^,l);
574         Result^.StrStart[l]:=#0;
575       end;
576     end;
577   ctcsvNumber:
578     Result^.Number:=V^.Number;
579   end;
580   {$IFDEF CheckCTCfgVars}
581   CheckCTCSVariable(Result);
582   {$ENDIF}
583 end;
584 
585 procedure SetCTCSVariableValue(const Src, Dest: PCTCfgScriptVariable);
586 var
587   l: LongInt;
588 begin
589   {$IFDEF CheckCTCfgVars}
590   CheckCTCSVariable(Src);
591   CheckCTCSVariable(Dest);
592   {$ENDIF}
593   if Src=Dest then exit;
594   case Src^.ValueType of
595   ctcsvNone:
596     ClearCTCSVariable(Dest);
597   ctcsvString:
598     begin
599       if Dest^.ValueType<>ctcsvString then begin
600         Dest^.ValueType:=ctcsvString;
601         Dest^.StrStart:=nil;
602       end;
603       l:=Src^.StrLen;
604       Dest^.StrLen:=l;
605       if l>0 then begin
606         ReAllocMem(Dest^.StrStart,l+1);
607         System.Move(Src^.StrStart^,Dest^.StrStart^,l);
608         Dest^.StrStart[l]:=#0;
609       end else
610         ReAllocMem(Dest^.StrStart,0);
611     end;
612   ctcsvNumber:
613     begin
614       case Dest^.ValueType of
615       ctcsvNone:
616         Dest^.ValueType:=ctcsvNumber;
617       ctcsvString:
618         begin
619           Dest^.ValueType:=ctcsvNumber;
620           if Dest^.StrStart<>nil then
621             Freemem(Dest^.StrStart);
622         end;
623       ctcsvNumber: ;
624       end;
625       Dest^.Number:=Src^.Number;
626     end;
627   end;
628   {$IFDEF CheckCTCfgVars}
629   CheckCTCSVariable(Src);
630   CheckCTCSVariable(Dest);
631   {$ENDIF}
632 end;
633 
634 procedure FreeCTCSVariable(var V: PCTCfgScriptVariable);
635 begin
636   {$IFDEF CheckCTCfgVars}
637   CheckCTCSVariable(v);
638   {$ENDIF}
639   ClearCTCSVariable(V);
640   ReAllocMem(V^.Name,0);
641   Dispose(V);
642 end;
643 
644 procedure ClearCTCSVariable(const V: PCTCfgScriptVariable);
645 begin
646   {$IFDEF CheckCTCfgVars}
647   CheckCTCSVariable(v);
648   {$ENDIF}
649   if V^.ValueType=ctcsvString then
650     ReAllocMem(V^.StrStart,0);
651   V^.ValueType:=ctcsvNone;
652   {$IFDEF CheckCTCfgVars}
653   CheckCTCSVariable(v);
654   {$ENDIF}
655 end;
656 
657 procedure MakeCTCSVariableString(const V: PCTCfgScriptVariable);
658 var
659   s: String;
660 begin
661   {$IFDEF CheckCTCfgVars}
662   CheckCTCSVariable(V);
663   {$ENDIF}
664   case V^.ValueType of
665   ctcsvNone:
666     begin
667       V^.StrLen:=0;
668       V^.StrStart:=nil;
669       V^.ValueType:=ctcsvString;
670     end;
671   ctcsvString: ;
672   ctcsvNumber:
673     begin
674       s:=IntToStr(V^.Number);
675       V^.StrLen:=length(s);
676       V^.StrStart:=GetMem(length(s)+1);
677       System.Move(s[1],V^.StrStart^,length(s)+1);
678       V^.ValueType:=ctcsvString;
679     end;
680   end;
681   {$IFDEF CheckCTCfgVars}
682   CheckCTCSVariable(V);
683   {$ENDIF}
684 end;
685 
686 procedure MakeCTCSVariableInt64(const V: PCTCfgScriptVariable);
687 var
688   i: Int64;
689 begin
690   {$IFDEF CheckCTCfgVars}
691   CheckCTCSVariable(V);
692   {$ENDIF}
693   case V^.ValueType of
694   ctcsvNone:
695     begin
696       V^.Number:=0;
697       V^.ValueType:=ctcsvNumber;
698     end;
699   ctcsvString:
700     begin
701       if V^.StrStart<>nil then begin
702         i:=StrToInt64Def(V^.StrStart,0);
703         FreeMem(V^.StrStart);
704         V^.Number:=i;
705       end else
706         V^.Number:=0;
707       V^.ValueType:=ctcsvNumber;
708     end;
709   ctcsvNumber: ;
710   end;
711   {$IFDEF CheckCTCfgVars}
712   CheckCTCSVariable(V);
713   {$ENDIF}
714 end;
715 
716 procedure MakeCTCSVariableInteger(const V: PCTCfgScriptVariable);
717 var
718   i: integer;
719 begin
720   {$IFDEF CheckCTCfgVars}
721   CheckCTCSVariable(V);
722   {$ENDIF}
723   case V^.ValueType of
724   ctcsvNone:
725     begin
726       V^.Number:=0;
727       V^.ValueType:=ctcsvNumber;
728     end;
729   ctcsvString:
730     begin
731       if V^.StrStart<>nil then begin
732         i:=StrToIntDef(V^.StrStart,0);
733         FreeMem(V^.StrStart);
734         V^.Number:=i;
735       end else
736         V^.Number:=0;
737       V^.ValueType:=ctcsvNumber;
738     end;
739   ctcsvNumber: ;
740   end;
741   {$IFDEF CheckCTCfgVars}
742   CheckCTCSVariable(V);
743   {$ENDIF}
744 end;
745 
746 procedure AddCTCSVariables(const AddVar, SumVar: PCTCfgScriptVariable);
747 { If one of them is none, then save in sum the other value
748   If both are numbers, add them.
749   Otherwise concatenate as strings.
750 }
751 var
752   OldLen: LongInt;
753   s: String;
754 begin
755   {$IFDEF CheckCTCfgVars}
756   CheckCTCSVariable(AddVar);
757   CheckCTCSVariable(SumVar);
758   {$ENDIF}
759   case SumVar^.ValueType of
760   ctcsvNone:
761     SetCTCSVariableValue(AddVar,SumVar);
762   ctcsvString:
763     case AddVar^.ValueType of
764     ctcsvNone:
765       ;
766     ctcsvString:
767       if AddVar^.StrLen>0 then begin
768         // append
769         OldLen:=SumVar^.StrLen;
770         SumVar^.StrLen+=AddVar^.StrLen;
771         ReAllocMem(SumVar^.StrStart,SumVar^.StrLen+1);
772         System.Move(AddVar^.StrStart^,SumVar^.StrStart[OldLen],AddVar^.StrLen+1);
773       end;
774     ctcsvNumber:
775       begin
776         // append as string
777         s:=IntToStr(AddVar^.Number);
778         OldLen:=SumVar^.StrLen;
779         SumVar^.StrLen+=length(s);
780         ReAllocMem(SumVar^.StrStart,SumVar^.StrLen+1);
781         System.Move(s[1],SumVar^.StrStart[OldLen],length(s)+1);
782       end;
783     end;
784   ctcsvNumber:
785     case AddVar^.ValueType of
786     ctcsvNone:
787       ;
788     ctcsvString:
789       begin
790         // convert SumVar from number to string and append
791         s:=IntToStr(SumVar^.Number);
792         SumVar^.ValueType:=ctcsvString;
793         SumVar^.StrLen:=length(s)+AddVar^.StrLen;
794         SumVar^.StrStart:=GetMem(SumVar^.StrLen+1);
795         System.Move(s[1],SumVar^.StrStart^,length(s));
796         if AddVar^.StrStart<>nil then
797           System.Move(AddVar^.StrStart^,SumVar^.StrStart[length(s)],AddVar^.StrLen+1)
798         else
799           SumVar^.StrStart[SumVar^.StrLen]:=#0;
800       end;
801     ctcsvNumber:
802       try
803         SumVar^.Number+=AddVar^.Number;
804       except
805       end;
806     end;
807   end;
808   {$IFDEF CheckCTCfgVars}
809   CheckCTCSVariable(AddVar);
810   CheckCTCSVariable(SumVar);
811   {$ENDIF}
812 end;
813 
CTCSNumberEqualsStringnull814 function CTCSNumberEqualsString(const Number: int64; const P: PChar): boolean;
815 var
816   n: int64;
817 begin
818   Result:=CTCSStringToNumber(P,n) and (n=Number);
819 end;
820 
CTCSStringToNumbernull821 function CTCSStringToNumber(P: PChar; out Number: int64): boolean;
822 var
823   n: int64;
824   Negated: Boolean;
825 begin
826   Result:=false;
827   if (P=nil) or (P^=#0) then exit;
828   try
829     n:=0;
830     if p^='-' then begin
831       Negated:=true;
832       inc(p);
833     end else
834       Negated:=false;
835     if p^='$' then begin
836       // hex
837       repeat
838         case p^ of
839         '0'..'9': n:=n*16+Ord(p^)-Ord('0');
840         'a'..'f': n:=n*16+Ord(p^)-Ord('a')+10;
841         'A'..'F': n:=n*16+Ord(p^)-Ord('A')+10;
842         #0: break;
843         else exit;
844         end;
845         inc(p);
846       until false;
847     end else if p^='%' then begin
848       // binary
849       repeat
850         case p^ of
851         '0': n:=n*2;
852         '1': n:=n*2+1;
853         #0: break;
854         else exit;
855         end;
856         inc(p);
857       until false;
858     end else begin
859       // decimal
860       repeat
861         case p^ of
862         '0'..'9': n:=n*10+Ord(p^)-Ord('0');
863         #0: break;
864         else exit;
865         end;
866         inc(p);
867       until false;
868     end;
869     if Negated then n:=-n;
870   except
871     exit;
872   end;
873   Number:=n;
874   Result:=true;
875 end;
876 
CTCSVariableIsTruenull877 function CTCSVariableIsTrue(const V: PCTCfgScriptVariable): boolean;
878 begin
879   Result:=not CTCSVariableIsFalse(V);
880 end;
881 
CTCSVariableIsFalsenull882 function CTCSVariableIsFalse(const V: PCTCfgScriptVariable): boolean;
883 begin
884   case V^.ValueType of
885   ctcsvNone:
886     Result:=false;
887   ctcsvString:
888     Result:=(V^.StrLen=1) and (V^.StrStart^='0');
889   ctcsvNumber:
890     Result:=V^.Number=0;
891   end;
892 end;
893 
AtomToCTCfgOperatornull894 function AtomToCTCfgOperator(p: PChar): TCTCfgScriptOperator;
895 begin
896   Result:=ctcsoNone;
897   case UpChars[p^] of
898   'A':
899     if CompareIdentifiers('and',p)=0 then Result:=ctcsoAnd;
900   'D':
901     if CompareIdentifiers('div',p)=0 then Result:=ctcsoDiv;
902   'M':
903     if CompareIdentifiers('mod',p)=0 then Result:=ctcsoMod;
904   'N':
905     if CompareIdentifiers('not',p)=0 then Result:=ctcsoNot;
906   'O':
907     if CompareIdentifiers('or',p)=0 then Result:=ctcsoOr;
908   'S':
909     case UpChars[p[1]] of
910     'H':
911       case UpChars[p[2]] of
912       'L': if CompareIdentifiers('shl',p)=0 then Result:=ctcsoShL;
913       'R': if CompareIdentifiers('shr',p)=0 then Result:=ctcsoShR;
914       end;
915     end;
916   'X':
917     if CompareIdentifiers('xor',p)=0 then Result:=ctcsoXOr;
918   '=':
919     Result:=ctcsoEqual;
920   '<':
921     case p[1] of
922     '>': Result:=ctcsoNotEqual;
923     '=': Result:=ctcsoLowerOrEqualThan;
924     else { < lower than } Result:=ctcsoLowerThan;
925     end;
926   '>':
927     case p[1] of
928     '=': Result:=ctcsoGreaterOrEqualThan;
929     else { > greater than } Result:=ctcsoGreaterThan;
930     end;
931   '*':
932     case p[1] of
933     '*': ;
934     '=': ;
935     else { * multiply } Result:=ctcsoMultiply;
936     end;
937   '/':
938     case p[1] of
939     '/': ;
940     '=': ;
941     else { / divide } Result:=ctcsoDivide;
942     end;
943   '+':
944     case p[1] of
945     '=': ;
946     else { + plus } Result:=ctcsoPlus;
947     end;
948   '-':
949     case p[1] of
950     '=': ;
951     else { - minus } Result:=ctcsoMinus;
952     end;
953   ':':
954     case p[1] of
955     '=': ;
956     else { : colon } ;
957     end;
958   end;
959 end;
960 
961 procedure CheckCTCSVariable(const V: PCTCfgScriptVariable);
962 begin
963   if V=nil then
964     RaiseCatchableException('');
965   if (V^.Name<>nil) and (strlen(V^.Name)>255) then
966     RaiseCatchableException('');
967   case V^.ValueType of
968   ctcsvNone: ;
969   ctcsvString:
970     begin
971       if V^.StrLen=0 then begin
972         if V^.StrStart<>nil then
973           RaiseCatchableException('');
974       end else begin
975         if V^.StrStart=nil then
976           RaiseCatchableException('');
977         if strlen(V^.StrStart)<>V^.StrLen then
978           RaiseCatchableException('');
979       end;
980     end;
981   ctcsvNumber: ;
982   end;
983 end;
984 
dbgsnull985 function dbgs(const t: TCTCfgScriptStackItemType): string;
986 begin
987   Result:=GetEnumName(typeinfo(t),ord(t));
988 end;
989 
dbgsnull990 function dbgs(const t: TCTCSValueType): string;
991 begin
992   Result:=GetEnumName(typeinfo(t),ord(t));
993 end;
994 
dbgsnull995 function dbgs(const t: TCTCfgScriptOperator): string;
996 begin
997   Result:=GetEnumName(typeinfo(t),ord(t));
998 end;
999 
dbgsnull1000 function dbgs(const V: PCTCfgScriptVariable): string;
1001 var
1002   l: Integer;
1003 begin
1004   Result:=GetIdentifier(V^.Name)+':';
1005   case V^.ValueType of
1006   ctcsvNone:
1007     Result:=Result+'none';
1008   ctcsvString:
1009     begin
1010       Result:=Result+'string=';
1011       l:=length(Result);
1012       if V^.StrLen>0 then begin
1013         SetLength(Result,l+V^.StrLen);
1014         System.Move(V^.StrStart^,Result[l+1],V^.StrLen);
1015       end;
1016     end;
1017   ctcsvNumber:
1018     Result:=Result+'int64='+IntToStr(V^.Number);
1019   end;
1020 end;
1021 
GetCTCSVariableAsStringnull1022 function GetCTCSVariableAsString(const V: PCTCfgScriptVariable): string;
1023 begin
1024   {$IFDEF CheckCTCfgVars}
1025   CheckCTCSVariable(V);
1026   {$ENDIF}
1027   case V^.ValueType of
1028   ctcsvNone: Result:='';
1029   ctcsvString:
1030     begin
1031       SetLength(Result,V^.StrLen);
1032       if Result<>'' then
1033         System.Move(V^.StrStart^,Result[1],length(Result));
1034     end;
1035   ctcsvNumber: Result:=IntToStr(V^.Number);
1036   else Result:='';
1037   end;
1038 end;
1039 
1040 procedure SetCTCSVariableAsString(const V: PCTCfgScriptVariable; const s: string);
1041 var
1042   l: Integer;
1043 begin
1044   {$IFDEF CheckCTCfgVars}
1045   CheckCTCSVariable(v);
1046   {$ENDIF}
1047   if V^.ValueType<>ctcsvString then begin
1048     V^.ValueType:=ctcsvString;
1049     V^.StrLen:=0;
1050     V^.StrStart:=nil;
1051   end;
1052   l:=length(s);
1053   V^.StrLen:=l;
1054   if l>0 then begin
1055     ReAllocMem(V^.StrStart,l+1);
1056     System.Move(s[1],V^.StrStart^,l+1); // +1 for the #0
1057   end else
1058     ReAllocMem(V^.StrStart,0);
1059   {$IFDEF CheckCTCfgVars}
1060   CheckCTCSVariable(v);
1061   {$ENDIF}
1062 end;
1063 
1064 procedure SetCTCSVariableAsNumber(const V: PCTCfgScriptVariable; const i: int64);
1065 begin
1066   {$IFDEF CheckCTCfgVars}
1067   CheckCTCSVariable(v);
1068   {$ENDIF}
1069   if (V^.ValueType=ctcsvString) and (V^.StrStart<>nil) then
1070     Freemem(V^.StrStart);
1071   V^.ValueType:=ctcsvNumber;
1072   V^.Number:=i;
1073   {$IFDEF CheckCTCfgVars}
1074   CheckCTCSVariable(v);
1075   {$ENDIF}
1076 end;
1077 
1078 { TCTCfgScriptVariables }
1079 
GetValuesnull1080 function TCTCfgScriptVariables.GetValues(const Name: string): string;
1081 var
1082   v: PCTCfgScriptVariable;
1083 begin
1084   if Name='' then
1085     exit('');
1086   v:=GetVariable(PChar(Name));
1087   if v=nil then
1088     exit('');
1089   Result:=GetCTCSVariableAsString(v);
1090 end;
1091 
1092 procedure TCTCfgScriptVariables.SetValues(const Name: string;
1093   const AValue: string);
1094 var
1095   v: PCTCfgScriptVariable;
1096 begin
1097   if Name='' then
1098     exit;
1099   v:=GetVariable(PChar(Name),true);
1100   SetCTCSVariableAsString(v,AValue);
1101 end;
1102 
1103 constructor TCTCfgScriptVariables.Create;
1104 begin
1105   FItems:=TAVLTree.Create(@CompareCTCSVariables);
1106 end;
1107 
1108 destructor TCTCfgScriptVariables.Destroy;
1109 begin
1110   Clear;
1111   FreeAndNil(FItems);
1112   inherited Destroy;
1113 end;
1114 
1115 procedure TCTCfgScriptVariables.Clear;
1116 var
1117   Node: TAVLTreeNode;
1118   Item: PCTCfgScriptVariable;
1119 begin
1120   Node:=FItems.FindLowest;
1121   while Node<>nil do begin
1122     Item:=PCTCfgScriptVariable(Node.Data);
1123     FreeCTCSVariable(Item);
1124     Node:=FItems.FindSuccessor(Node);
1125   end;
1126   FItems.Clear;
1127 end;
1128 
Equalsnull1129 function TCTCfgScriptVariables.Equals(Vars: TCTCfgScriptVariables): boolean;
1130 var
1131   Node1: TAVLTreeNode;
1132   Node2: TAVLTreeNode;
1133   Item1: PCTCfgScriptVariable;
1134   Item2: PCTCfgScriptVariable;
1135 begin
1136   Result:=false;
1137   if Vars=nil then exit;
1138   if FItems.Count<>Vars.FItems.Count then exit;
1139   Node1:=FItems.FindLowest;
1140   Node2:=Vars.FItems.FindLowest;
1141   while Node1<>nil do begin
1142     Item1:=PCTCfgScriptVariable(Node1.Data);
1143     Item2:=PCTCfgScriptVariable(Node2.Data);
1144     if CompareIdentifiers(Item1^.Name,Item2^.Name)<>0 then exit;
1145     if Item1^.ValueType<>Item2^.ValueType then exit;
1146     case Item1^.ValueType of
1147     ctcsvNone: ;
1148     ctcsvString: if (Item1^.StrLen<>Item2^.StrLen)
1149                    or ((Item1^.StrStart<>nil)
1150                        and (not CompareMem(Item1^.StrStart,Item2^.StrStart,Item1^.StrLen)))
1151                  then exit;
1152     ctcsvNumber: if Item1^.Number<>Item2^.Number then exit;
1153     end;
1154     Node1:=FItems.FindSuccessor(Node1);
1155     Node2:=Vars.FItems.FindSuccessor(Node2);
1156   end;
1157   Result:=true;
1158 end;
1159 
1160 procedure TCTCfgScriptVariables.Assign(Source: TCTCfgScriptVariables);
1161 var
1162   Node: TAVLTreeNode;
1163   Item: PCTCfgScriptVariable;
1164   NewItem: PCTCfgScriptVariable;
1165 begin
1166   if Self=Source then exit;
1167   Clear;
1168   Node:=Source.FItems.FindLowest;
1169   while Node<>nil do begin
1170     Item:=PCTCfgScriptVariable(Node.Data);
1171     NewItem:=CloneCTCSVariable(Item);
1172     FItems.Add(NewItem);
1173     Node:=Source.FItems.FindSuccessor(Node);
1174   end;
1175 end;
1176 
1177 procedure TCTCfgScriptVariables.Assign(Source: TStrings);
1178 var
1179   Name: string;
1180   Value: string;
1181   i: Integer;
1182 begin
1183   Clear;
1184   for i:=0 to Source.Count-1 do begin
1185     Name:=Source.Names[i];
1186     if not IsValidIdent(Name) then continue;
1187     Value:=Source.ValueFromIndex[i];
1188     Define(PChar(Name),Value);
1189   end;
1190 end;
1191 
1192 procedure TCTCfgScriptVariables.AddOverrides(Source: TCTCfgScriptVariables);
1193 var
1194   Item: PCTCfgScriptVariable;
1195   Node: TAVLTreeNode;
1196 begin
1197   Node:=Source.FItems.FindLowest;
1198   while Node<>nil do begin
1199     Item:=PCTCfgScriptVariable(Node.Data);
1200     AddOverride(Item);
1201     Node:=Source.FItems.FindSuccessor(Node);
1202   end;
1203 end;
1204 
1205 procedure TCTCfgScriptVariables.AddOverride(Source: PCTCfgScriptVariable);
1206 var
1207   Node: TAVLTreeNode;
1208   Item: PCTCfgScriptVariable;
1209 begin
1210   Node:=FItems.Find(Source);
1211   if Node<>nil then begin
1212     Item:=PCTCfgScriptVariable(Node.Data);
1213     SetCTCSVariableValue(Source,Item);
1214   end else begin
1215     Item:=CloneCTCSVariable(Source);
1216     FItems.Add(Item);
1217   end;
1218 end;
1219 
TCTCfgScriptVariables.GetVariablenull1220 function TCTCfgScriptVariables.GetVariable(const Name: PChar;
1221   CreateIfNotExists: Boolean): PCTCfgScriptVariable;
1222 var
1223   Node: TAVLTreeNode;
1224 begin
1225   Node:=FItems.FindKey(Name,@ComparePCharWithCTCSVariableName);
1226   if Node<>nil then
1227     Result:=PCTCfgScriptVariable(Node.Data)
1228   else if CreateIfNotExists then begin
1229     Result:=NewCTCSVariable(Name);
1230     FItems.Add(Result);
1231   end else
1232     Result:=nil;
1233 end;
1234 
1235 procedure TCTCfgScriptVariables.Undefine(Name: PChar);
1236 var
1237   Node: TAVLTreeNode;
1238   Item: PCTCfgScriptVariable;
1239 begin
1240   Node:=FItems.FindKey(Name,@ComparePCharWithCTCSVariableName);
1241   if Node=nil then exit;
1242   Item:=PCTCfgScriptVariable(Node.Data);
1243   FreeCTCSVariable(Item);
1244   FItems.Delete(Node);
1245 end;
1246 
1247 procedure TCTCfgScriptVariables.Define(Name: PChar; const Value: string);
1248 
IsNumbernull1249   function IsNumber: boolean;
1250   var
1251     p: PChar;
1252   begin
1253     if Value='' then exit(false);
1254     p:=PChar(Value);
1255     if p^='-' then inc(p);
1256     while (p^ in ['0'..'9']) do inc(p);
1257     Result:=(p^=#0) and (p-PChar(Value)=length(Value));
1258   end;
1259 
1260 var
1261   V: PCTCfgScriptVariable;
1262   i: Int64;
1263 begin
1264   V:=GetVariable(Name,true);
1265   if Value='' then
1266     ClearCTCSVariable(V)
1267   else if IsNumber and TryStrToInt64(Value,i) then
1268     SetCTCSVariableAsNumber(V,i)
1269   else
1270     SetCTCSVariableAsString(V,Value);
1271 end;
1272 
TCTCfgScriptVariables.IsDefinednull1273 function TCTCfgScriptVariables.IsDefined(Name: PChar): boolean;
1274 begin
1275   Result:=GetVariable(Name)<>nil;
1276 end;
1277 
1278 procedure TCTCfgScriptVariables.WriteDebugReport(const Title: string;
1279   const Prefix: string);
1280 var
1281   Node: TAVLTreeNode;
1282   V: PCTCfgScriptVariable;
1283 begin
1284   debugln([Prefix,'TCTCfgScriptVariables.WriteDebugReport Count=',Tree.Count,': ',Title]);
1285   Node:=FItems.FindLowest;
1286   while Node<>nil do begin
1287     V:=PCTCfgScriptVariable(Node.Data);
1288     debugln([Prefix,'  ',dbgs(V)]);
1289     Node:=FItems.FindSuccessor(Node);
1290   end;
1291 end;
1292 
1293 { TCTConfigScriptEngine }
1294 
TCTConfigScriptEngine.GetErrorsnull1295 function TCTConfigScriptEngine.GetErrors(Index: integer): TCTCfgScriptError;
1296 begin
1297   Result:=TCTCfgScriptError(FErrors[Index]);
1298 end;
1299 
1300 procedure TCTConfigScriptEngine.AddError(const aMsg: string; ErrorPos: PChar);
1301 var
1302   Err: TCTCfgScriptError;
1303   Position: Integer;
1304   Line: Integer;
1305   Column: Integer;
1306 begin
1307   {$IFDEF VerboseCTCfgScript}
1308   WriteDebugReportStack('ERROR: '+aMsg);
1309   {$ENDIF}
1310   Position:=-1;
1311   Line:=0;
1312   Column:=0;
1313   if (ErrorPos<>nil) then begin
1314     Position:=ErrorPos-Src;
1315     PosToLineCol(ErrorPos,Line,Column);
1316   end;
1317   Err:=TCTCfgScriptError.Create(aMsg,Position,Line,Column);
1318   FErrors.Add(Err);
1319   if ErrorCount>=MaxErrorCount then
1320     raise ECodeToolCfgScript.Create(GetErrorStr(ErrorCount-1));
1321 end;
1322 
1323 procedure TCTConfigScriptEngine.AddError(const aMsg: string);
1324 begin
1325   AddError(aMsg,AtomStart);
1326 end;
1327 
1328 procedure TCTConfigScriptEngine.RunStatement(Skip: boolean);
1329 { Examples:
1330     begin..
1331     if...
1332     variable:=
1333 }
1334 
1335   procedure ErrorUnexpectedAtom;
1336   begin
1337     AddError(Format(ctsExpectedSemicolonOfStatementButFound, [GetAtomOrNothing]))
1338   end;
1339 
1340 var
1341   Handled: Boolean;
1342   StartTop: LongInt;
1343 begin
1344   {$IFDEF VerboseCTCfgScript}
1345   debugln(['TCTConfigScriptEngine.RunStatement Atom=',GetAtom]);
1346   {$ENDIF}
1347   StartTop:=FStack.Top;
1348   case AtomStart^ of
1349   #0: ;
1350   ';': ; // empty statement
1351   'a'..'z','A'..'Z':
1352     begin
1353       // identifier or keyword
1354       Handled:=false;
1355       case UpChars[AtomStart^] of
1356       'B':
1357         if CompareIdentifiers('BEGIN',AtomStart)=0 then begin
1358           Handled:=true;
1359           RunBegin(Skip);
1360         end;
1361       'I':
1362         if CompareIdentifiers('IF',AtomStart)=0 then begin
1363           Handled:=true;
1364           RunIf(Skip);
1365         end;
1366       'U':
1367         if CompareIdentifiers('Undefine',AtomStart)=0 then begin
1368           Handled:=true;
1369           RunUndefine(Skip);
1370         end;
1371       end;
1372       if (not Handled) then begin
1373         if IsKeyWord(AtomStart) then begin
1374           AddError(Format(ctsUnexpectedKeyword2, [GetAtom]));
tomStartnull1375         end else if IsFunction(AtomStart) then begin
1376           if not RunFunction then exit;
1377         end else begin
1378           // parse assignment
1379           RunAssignment(Skip);
1380         end;
1381       end;
1382     end;
1383   else
1384     ErrorUnexpectedAtom;
1385   end;
1386   // clean up stack
1387   while FStack.Top>StartTop do FStack.Pop;
1388 end;
1389 
1390 procedure TCTConfigScriptEngine.RunBegin(Skip: boolean);
1391 { Examples:
1392     begin
1393     end
1394     begin
1395       statement statement
1396     end
1397 }
1398 var
1399   BeginStart: PChar;
1400   StartTop: LongInt;
1401 
1402   procedure ErrorMissingEnd;
1403   begin
1404     //debugln(['ErrorMissingEnd BeginStart=',BeginStart]);
1405     AddError(Format(ctsBeginAtWithoutEnd, [PosToStr(BeginStart)]));
1406   end;
1407 
1408 begin
1409   BeginStart:=AtomStart;
1410   StartTop:=FStack.Top;
1411   FStack.Push(ctcssBegin,AtomStart);
1412   ReadRawNextPascalAtom(Src,AtomStart,nil,false,true);
1413   repeat
1414     if (AtomStart^=#0) then begin
1415       ErrorMissingEnd;
1416       break;
1417     end else if CompareIdentifiers('END',AtomStart)=0 then begin
1418       FStack.Pop;
1419       ReadRawNextPascalAtom(Src,AtomStart,nil,false,true);
1420       break;
1421     end else if AtomStart^=';' then begin
1422       // skip
1423       ReadRawNextPascalAtom(Src,AtomStart,nil,false,true);
1424     end else begin
1425       RunStatement(Skip);
1426     end;
1427   until false;
1428   // clean up stack (recover from errors)
1429   while FStack.Top>StartTop do FStack.Pop;
1430 end;
1431 
1432 procedure TCTConfigScriptEngine.RunIf(Skip: boolean);
1433 { Examples:
1434     if expression then statement else statement
1435 }
1436 var
1437   IfStart: PChar;
1438   ExprIsTrue: Boolean;
1439   StartTop: LongInt;
1440 begin
1441   IfStart:=AtomStart;
1442   StartTop:=FStack.Top;
1443   FStack.Push(ctcssIf,IfStart);
1444   ReadRawNextPascalAtom(Src,AtomStart,nil,false,true);
1445   ExprIsTrue:=false;
1446   if RunExpression then begin
1447     ExprIsTrue:=CTCSVariableIsTrue(FStack.TopItemOperand);
1448     FStack.Pop;
1449   end;
1450   {$IFDEF VerboseCTCfgScript}
1451   debugln(['TCTConfigScriptEngine.RunIf expression=',ExprIsTrue]);
1452   {$ENDIF}
1453 
1454   // read then
1455   if CompareIdentifiers(AtomStart,'then')<>0 then
1456     AddError(Format(ctsThenExpectedButFound, [GetAtomOrNothing]));
1457   // then statement
1458   ReadRawNextPascalAtom(Src,AtomStart,nil,false,true);
1459   RunStatement(Skip or not ExprIsTrue);
1460   if CompareIdentifiers(AtomStart,'else')=0 then begin
1461     // else statement
1462     ReadRawNextPascalAtom(Src,AtomStart,nil,false,true);
1463     RunStatement(Skip or ExprIsTrue);
1464   end;
1465   // clean up stack
1466   while FStack.Top>StartTop do FStack.Pop;
1467 end;
1468 
1469 procedure TCTConfigScriptEngine.RunUndefine(Skip: boolean);
1470 var
1471   VarStart: PChar;
1472 begin
1473   ReadRawNextPascalAtom(Src,AtomStart,nil,false,true);
1474   if AtomStart^<>'(' then begin
1475     AddError(Format(ctsExpectedButFound, [GetAtomOrNothing]));
1476     exit;
1477   end;
1478   ReadRawNextPascalAtom(Src,AtomStart,nil,false,true);
1479   if (not IsIdentStartChar[AtomStart^]) or IsKeyWord(AtomStart) then begin
1480     AddError(Format(ctsExpectedIdentifierButFound, [GetAtomOrNothing]));
1481     exit;
1482   end;
1483   VarStart:=AtomStart;
1484   ReadRawNextPascalAtom(Src,AtomStart,nil,false,true);
1485   if AtomStart^<>')' then begin
1486     AddError(Format(ctsExpectedButFound2, [GetAtomOrNothing]));
1487     exit;
1488   end;
1489   if not Skip then
1490     Variables.Undefine(VarStart);
1491   ReadRawNextPascalAtom(Src,AtomStart,nil,false,true);
1492 end;
1493 
1494 procedure TCTConfigScriptEngine.RunAssignment(Skip: boolean);
1495 { Examples:
1496     a:=3;
1497 }
1498 var
1499   VarStart: PChar;
1500   Variable: PCTCfgScriptVariable;
1501   OperatorStart: PChar;
1502   StartTop: LongInt;
1503 begin
1504   VarStart:=AtomStart;
1505   {$IFDEF VerboseCTCfgScript}
1506   debugln(['TCTConfigScriptEngine.RunAssignment ',GetIdentifier(VarStart)]);
1507   {$ENDIF}
1508   StartTop:=FStack.Top;
1509   FStack.Push(ctcssAssignment,VarStart);
1510   ReadRawNextPascalAtom(Src,AtomStart,nil,false,true);
1511   {$IFDEF VerboseCTCfgScript}
1512   debugln(['TCTConfigScriptEngine.RunAssignment Operator=',GetAtom]);
1513   {$ENDIF}
1514   // read := or +=
1515   if AtomStart^=#0 then begin
1516     AddError(ctsMissing);
1517     exit;
1518   end;
1519   OperatorStart:=AtomStart;
1520   if (not (AtomStart^ in [':','+'])) or (AtomStart[1]<>'=') then begin
1521     AddError(Format(ctsExpectedButFound3, [GetAtom]));
1522     exit;
1523   end;
1524   // read expression
1525   ReadRawNextPascalAtom(Src,AtomStart,nil,false,true);
1526   if RunExpression and (not Skip) then begin
1527     Variable:=Variables.GetVariable(VarStart,true);
1528     {$IFDEF VerboseCTCfgScript}
1529     debugln(['TCTConfigScriptEngine.RunAssignment BEFORE ',GetIdentifier(VarStart),'=(Old=',dbgs(Variable),') ',GetAtom(OperatorStart),' ',dbgs(FStack.TopItemOperand)]);
1530     {$ENDIF}
1531     case OperatorStart^ of
1532     ':': // :=
1533       SetCTCSVariableValue(FStack.TopItemOperand,Variable);
1534     '+': // +=
1535       AddCTCSVariables(FStack.TopItemOperand,Variable);
1536     end;
1537 
1538     {$IFDEF VerboseCTCfgScript}
1539     debugln(['TCTConfigScriptEngine.RunAssignment AFTER ',GetIdentifier(VarStart),' = ',dbgs(Variable),' Atom=',GetAtom]);
1540     {$ENDIF}
1541   end;
1542   // clean up stack
1543   while FStack.Top>StartTop do FStack.Pop;
1544 end;
1545 
1546 procedure TCTConfigScriptEngine.PushNumberValue(const Number: int64);
1547 var
1548   Operand: PCTCfgScriptVariable;
1549 begin
1550   FStack.Push(ctcssOperand,AtomStart);
1551   Operand:=FStack.TopItemOperand;
1552   Operand^.ValueType:=ctcsvNumber;
1553   Operand^.Number:=Number;
1554   ExecuteStack(1);
1555 end;
1556 
RunDefinednull1557 function TCTConfigScriptEngine.RunDefined(Negate: boolean): boolean;
1558 var
1559   VarStart: PChar;
1560   b: Boolean;
1561 begin
1562   Result:=false;
1563   ReadRawNextPascalAtom(Src,AtomStart,nil,false,true);
1564   if AtomStart^<>'(' then begin
1565     AddError(Format(ctsExpectedButFound, [GetAtomOrNothing]));
1566     exit;
1567   end;
1568   ReadRawNextPascalAtom(Src,AtomStart,nil,false,true);
1569   if (not IsIdentStartChar[AtomStart^]) or IsKeyWord(AtomStart) then begin
1570     AddError(Format(ctsExpectedIdentifierButFound, [GetAtomOrNothing]));
1571     exit;
1572   end;
1573   VarStart:=AtomStart;
1574   ReadRawNextPascalAtom(Src,AtomStart,nil,false,true);
1575   if AtomStart^<>')' then begin
1576     AddError(Format(ctsExpectedButFound2, [GetAtomOrNothing]));
1577     exit;
1578   end;
1579   b:=Variables.GetVariable(VarStart)<>nil;
1580   if Negate then b:=not b;
1581   PushBooleanValue(b);
1582   Result:=true;
1583 end;
1584 
RunFunctionnull1585 function TCTConfigScriptEngine.RunFunction: boolean;
1586 var
1587   StartTop: LongInt;
1588   Value: TCTCfgScriptVariable;
1589   FunctionName: PChar;
1590 begin
1591   Result:=false;
1592   FunctionName:=AtomStart;
1593   StartTop:=FStack.Top;
1594   ReadRawNextPascalAtom(Src,AtomStart,nil,false,true);
1595   if AtomStart^<>'(' then begin
1596     AddError(Format(ctsExpectedButFound, [GetAtomOrNothing]));
1597     exit;
1598   end;
1599   ReadRawNextPascalAtom(Src,AtomStart,nil,false,true);
1600 
1601   FStack.Push(ctcssRoundBracketOpen,AtomStart);
1602   FillByte(Value{%H-},SizeOf(Value),0);
1603   if RunExpression then
1604     SetCTCSVariableValue(FStack.TopItemOperand,@Value);
1605   if AtomStart^<>')' then begin
1606     AddError(Format(ctsExpectedButFound2, [GetAtomOrNothing]));
1607     exit;
1608   end;
1609 
1610   // clean up stack
1611   while FStack.Top>StartTop do FStack.Pop;
1612 
1613   // execute function
1614   {$IFDEF VerboseCTCfgScript}
1615   debugln(['TCTConfigScriptEngine.RunFunction FunctionName="',GetAtom(FunctionName),'" Parameter=',dbgs(PCTCfgScriptVariable(@Value))]);
1616   {$ENDIF}
1617   case UpChars[FunctionName^] of
1618   'I':
1619     if CompareIdentifiers(FunctionName,'int64')=0 then
1620       MakeCTCSVariableInt64(@Value)
1621     else if CompareIdentifiers(FunctionName,'integer')=0 then
1622       MakeCTCSVariableInteger(@Value);
1623   'S':
1624     if CompareIdentifiers(FunctionName,'string')=0 then
1625       MakeCTCSVariableString(@Value);
1626   else
unctionNamenull1627     RunCustomSimpleFunction(FunctionName,@Value);
1628   end;
1629 
1630   // put result on stack as operand
1631   {$IFDEF VerboseCTCfgScript}
1632   debugln(['TCTConfigScriptEngine.RunFunction FunctionName="',GetAtom(FunctionName),'" Result=',dbgs(PCTCfgScriptVariable(@Value))]);
1633   {$ENDIF}
1634   FStack.Push(ctcssOperand,FunctionName);
1635   SetCTCSVariableValue(@Value,FStack.TopItemOperand);
1636 
1637   ClearCTCSVariable(@Value);
1638 
1639   Result:=true;
1640 end;
1641 
1642 procedure TCTConfigScriptEngine.PushStringConstant;
1643 var
1644   Operand: PCTCfgScriptVariable;
1645 
1646   procedure Add(p: PChar; Count: integer);
1647   var
1648     OldLen: LongInt;
1649     NewLen: Integer;
1650   begin
1651     if Count=0 then exit;
1652     OldLen:=Operand^.StrLen;
1653     NewLen:=OldLen+Count;
1654     ReAllocMem(Operand^.StrStart,NewLen+1);
1655     System.Move(p^,Operand^.StrStart[OldLen],Count);
1656     Operand^.StrLen:=NewLen;
1657     Operand^.StrStart[NewLen]:=#0;
1658   end;
1659 
1660 var
1661   p: PChar;
1662   StartPos: PChar;
1663   i: Integer;
1664   c: char;
1665 begin
1666   FStack.Push(ctcssOperand,AtomStart);
1667   Operand:=FStack.TopItemOperand;
1668   Operand^.ValueType:=ctcsvString;
1669   Operand^.StrLen:=0;
1670   Operand^.StrStart:=nil;
1671   p:=AtomStart;
1672   while true do begin
1673     case p^ of
1674     #0:
1675       break;
1676     '#':
1677       begin
1678         inc(p);
1679         StartPos:=p;
1680         i:=0;
1681         while (p^ in ['0'..'9']) do begin
1682           i:=i*10+ord(p^)-ord('0');
1683           if (i>255) then begin
1684             AddError(ctsCharacterConstantOutOfRange);
1685             while (p^ in ['0'..'9']) do inc(p);
1686             break;
1687           end;
1688           inc(p);
1689         end;
1690         c:=chr(i);
1691         Add(@c,1);
1692       end;
1693     '''':
1694       begin
1695         inc(p);
1696         StartPos:=p;
1697         while not (p^ in ['''',#10,#13,#0]) do
1698           inc(p);
1699         if p^<>'''' then
1700           AddError('missing end apostrophe of string constant');
1701         Add(StartPos,p-StartPos);
1702         if p^='''' then
1703           inc(p);
1704       end;
1705     else
1706       break;
1707     end;
1708   end;
1709   ExecuteStack(1);
1710 end;
1711 
1712 procedure TCTConfigScriptEngine.PushNumberConstant;
1713 var
1714   Item: PCTCfgScriptStackItem;
1715   p: PChar;
1716   Number: int64;
1717   l: integer;
1718   c: Char;
1719 begin
1720   FStack.Push(ctcssOperand,AtomStart);
1721   Item:=FStack.TopItem;
1722   p:=AtomStart;
1723   c:=p^;
1724   if not (c in ['0'..'9']) then inc(p);
1725   Number:=0;
1726   try
1727     while true do begin
1728       case c of
1729       '%':
1730         case p^ of
1731         '0': Number:=Number*2;
1732         '1': Number:=Number*2+1;
1733         else break;
1734         end;
1735       '&':
1736         case p^ of
1737         '0'..'7': Number:=Number*8+ord(p^)-ord('0');
1738         else break;
1739         end;
1740       '$':
1741         case p^ of
1742         '0'..'9': Number:=Number*16+ord(p^)-ord('0');
1743         'a'..'f': Number:=Number*16+ord(p^)-ord('a')+10;
1744         'A'..'F': Number:=Number*16+ord(p^)-ord('A')+10;
1745         else break;
1746         end;
1747       else
1748         // decimal or float
1749         case p^ of
1750         '0'..'9': Number:=Number*10+ord(p^)-ord('0');
1751         else break;
1752         end;
1753       end;
1754       inc(p);
1755     end;
1756   except
1757     p:=AtomStart;
1758   end;
1759   if p=Src then begin
1760     // a number
1761     Item^.Operand.ValueType:=ctcsvNumber;
1762     Item^.Operand.Number:=Number;
1763   end else begin
1764     // string constant
1765     Item^.Operand.ValueType:=ctcsvString;
1766     l:=Src-AtomStart;
1767     Item^.Operand.StrLen:=l;
1768     Item^.Operand.StrStart:=GetMem(l+1);
1769     System.Move(AtomStart^,Item^.Operand.StrStart^,l);
1770     Item^.Operand.StrStart[l]:=#0;
1771   end;
1772   ExecuteStack(1);
1773 end;
1774 
1775 procedure TCTConfigScriptEngine.PushBooleanValue(b: boolean);
1776 var
1777   Operand: PCTCfgScriptVariable;
1778 begin
1779   FStack.Push(ctcssOperand,AtomStart);
1780   Operand:=FStack.TopItemOperand;
1781   Operand^.ValueType:=ctcsvNumber;
1782   if b then
1783     Operand^.Number:=1
1784   else
1785     Operand^.Number:=0;
1786   ExecuteStack(1);
1787 end;
1788 
TCTConfigScriptEngine.RunExpressionnull1789 function TCTConfigScriptEngine.RunExpression: boolean;
1790 { Examples:
1791     A   is false if A=0 or A='0'
1792     defined(A)
1793     (A)
1794     unary operators:
1795 
1796     binary operators:
1797 
1798 }
OperandAllowednull1799   function OperandAllowed: boolean;
1800   begin
1801     case FStack.TopTyp of
1802     ctcssExpression,ctcssOperator,ctcssRoundBracketOpen:
1803       Result:=true;
1804     else
1805       {$IFDEF VerboseCTCfgScript}
1806       debugln(['TCTConfigScriptEngine.RunExpression.OperandAllowed no']);
1807       {$ENDIF}
1808       AddError(Format(ctsOperatorExpectedButFound, [GetAtom]));
1809       Result:=false;
1810     end;
1811   end;
1812 
BinaryOperatorAllowednull1813   function BinaryOperatorAllowed: boolean;
1814   begin
1815     case FStack.TopTyp of
1816     ctcssOperand:
1817       Result:=true;
1818     else
1819       {$IFDEF VerboseCTCfgScript}
1820       debugln(['TCTConfigScriptEngine.RunExpression.BinaryOperatorAllowed no']);
1821       {$ENDIF}
1822       AddError(Format(ctsOperandExpectedButFound, [GetAtom]));
1823       Result:=false;
1824     end;
1825   end;
1826 
PushBinaryOperatornull1827   function PushBinaryOperator: boolean;
1828   begin
1829     Result:=BinaryOperatorAllowed;
1830     if not Result then begin
1831       RunExpression:=false;
1832       exit;
1833     end;
1834     ExecuteStack(GetOperatorLevel(AtomStart));
1835     FStack.Push(ctcssOperator,AtomStart);
1836   end;
1837 
1838 var
1839   ExprStart: PChar;
1840   Handled: Boolean;
1841   Item: PCTCfgScriptStackItem;
1842   StartTop: LongInt;
1843   v: PCTCfgScriptVariable;
1844 begin
1845   Result:=true;
1846   ExprStart:=AtomStart;
1847   StartTop:=FStack.Top;
1848   FStack.Push(ctcssExpression,ExprStart);
1849   while true do begin
1850     {$IFDEF VerboseCTCfgScript}
1851     debugln(['TCTConfigScriptEngine.RunExpression Atom=',GetAtom]);
1852     {$ENDIF}
1853     case AtomStart^ of
1854     #0:
1855       break;
1856     '(':
1857       begin
1858         if not OperandAllowed then break;
1859         FStack.Push(ctcssRoundBracketOpen,AtomStart);
1860       end;
1861     ')':
1862       begin
1863         ExecuteStack(5);
1864         if FStack.TopTyp=ctcssRoundBracketOpen then begin
1865           // empty ()
1866           AddError(Format(ctsOperandExpectedButFound2, [GetAtom]));
1867           Result:=false;
1868           break;
1869         end else if (FStack.TopTyp=ctcssOperand)
1870         and (FStack.Top>0) and (FStack.Items[FStack.Top-1].Typ=ctcssRoundBracketOpen)
1871         then begin
1872           FStack.Delete(FStack.Top-1);
1873         end else
1874           break;
1875       end;
1876     '=':
1877       if not PushBinaryOperator then break;
1878     '<':
1879       if (Src-AtomStart=1) or (AtomStart[1] in ['=','>']) then begin
1880         if not PushBinaryOperator then break;
1881       end else begin
1882         AddError(Format(ctsInvalidOperator, [GetAtom]));
1883         Result:=false;
1884         break;
1885       end;
1886     '>':
1887       if (Src-AtomStart=1) or (AtomStart[1] in ['=']) then begin
1888         if not PushBinaryOperator then break;
1889       end else begin
1890         AddError(Format(ctsInvalidOperator, [GetAtom]));
1891         Result:=false;
1892         break;
1893       end;
1894     '+':
1895       if (Src-AtomStart=1) then begin
1896         if not PushBinaryOperator then break;
1897       end else begin
1898         AddError(Format(ctsInvalidOperator, [GetAtom]));
1899         Result:=false;
1900         break;
1901       end;
1902     'a'..'z','A'..'Z':
1903       begin
1904         // a keyword or an identifier
1905 
1906         {$IFDEF VerboseCTCfgScript}
1907         debugln(['TCTConfigScriptEngine.RunExpression StackTop=',dbgs(FStack.TopTyp),' Atom=',GetAtom]);
1908         {$ENDIF}
1909         // execute
1910         Handled:=false;
1911         case UpChars[AtomStart^] of
1912         'A':
1913           if CompareIdentifiers('and',AtomStart)=0 then begin
1914             Handled:=true;
1915             if not PushBinaryOperator then break;
1916           end;
1917         'D':
1918           case UpChars[AtomStart[1]] of
1919           'E':
1920             if CompareIdentifiers('defined',AtomStart)=0 then begin
1921               Handled:=true;
1922               if not OperandAllowed then break;
1923               if not RunDefined(false) then break;
1924             end;
1925           'I':
1926             if CompareIdentifiers('div',AtomStart)=0 then begin
1927               Handled:=true;
1928               if not PushBinaryOperator then break;
1929             end;
1930           end;
1931         'E':
1932           case UpChars[AtomStart[1]] of
1933           'L':
1934             if CompareIdentifiers('else',AtomStart)=0 then
1935               break;
1936           'N':
1937             if CompareIdentifiers('end',AtomStart)=0 then
1938               break;
1939           end;
1940         'F':
1941           if CompareIdentifiers('false',AtomStart)=0 then begin
1942             Handled:=true;
1943             if not OperandAllowed then break;
1944             PushBooleanValue(false);
1945           end;
1946         'M':
1947           if CompareIdentifiers('mod',AtomStart)=0 then begin
1948             Handled:=true;
1949             if not PushBinaryOperator then break;
1950           end;
1951         'N':
1952           if CompareIdentifiers('not',AtomStart)=0 then begin
1953             Handled:=true;
1954             if not OperandAllowed then break;
1955             // Note: no execute, "not" is unary operator for the next operand
1956             FStack.Push(ctcssOperator,AtomStart);
1957           end;
1958         'O':
1959           if CompareIdentifiers('or',AtomStart)=0 then begin
1960             Handled:=true;
1961             if not PushBinaryOperator then break;
1962           end;
1963         'T':
1964           case UpChars[AtomStart[1]] of
1965           'H':
1966             if CompareIdentifiers('then',AtomStart)=0 then begin
1967               break;
1968             end;
1969           'R':
1970             if CompareIdentifiers('true',AtomStart)=0 then begin
1971               Handled:=true;
1972               if not OperandAllowed then break;
1973               PushBooleanValue(true);
1974             end;
1975           end;
1976         'U':
1977           if CompareIdentifiers('undefined',AtomStart)=0 then begin
1978             Handled:=true;
1979             if not OperandAllowed then break;
1980             if not RunDefined(true) then break;
1981           end;
1982         'X':
1983           if CompareIdentifiers('xor',AtomStart)=0 then begin
1984             Handled:=true;
1985             if not PushBinaryOperator then break;
1986           end;
1987         end;
1988         if (not Handled) and IsKeyWord(AtomStart) then begin
1989           AddError(Format(ctsUnexpectedKeyword2, [GetAtom]));
1990           Result:=false;
1991           break;
1992         end;
1993         if (not Handled) then begin
1994           if not OperandAllowed then break;
1995           {$IFDEF VerboseCTCfgScript}
tomStartnull1996           debugln(['TCTConfigScriptEngine.RunExpression ',GetAtom(AtomStart),' ',IsFunction(AtomStart)]);
1997           {$ENDIF}
tomStartnull1998           if IsFunction(AtomStart) then begin
1999             // a function
2000             if not RunFunction then begin
2001               Result:=false;
2002               break;
2003             end;
2004           end else begin
2005             // a variable
2006             FStack.Push(ctcssOperand,AtomStart);
2007             Item:=FStack.TopItem;
2008             v:=Variables.GetVariable(AtomStart);
2009             if v<>nil then begin
2010               SetCTCSVariableValue(v,@Item^.Operand);
2011             end;
2012           end;
2013           ExecuteStack(1);
2014         end;
2015       end;
2016     '#','''':
2017       begin
2018         if not OperandAllowed then break;
2019         PushStringConstant;
2020       end;
2021     '0'..'9','$','%','&':
2022       begin
2023         // float, decimal, hex, octal, binary constant
2024         if not OperandAllowed then break;
2025         PushNumberConstant;
2026       end;
2027     else
2028       if FStack.TopTyp in [ctcssOperator,ctcssRoundBracketOpen]
2029       then begin
2030         AddError(Format(ctsOperandExpectedButFound2, [GetAtom]));
2031         Result:=false;
2032       end;
2033       break;
2034     end;
2035     ReadRawNextPascalAtom(Src,AtomStart,nil,false,true);
2036   end;
2037 
2038   if Result then begin
2039     if not ExecuteStack(10) then
2040       Result:=false;
2041     if FStack.Top=StartTop+1 then begin
2042       // empty expression
2043       AddError(Format(ctsOperandExpectedButFound2, [GetAtom]));
2044     end else if (FStack.TopTyp<>ctcssOperand) or (FStack.Top<>StartTop+2) then begin
2045       // unfinished expression
2046       if FStack.TopTyp in [ctcssOperator,ctcssRoundBracketOpen]
2047       then
2048         AddError(Format(ctsOperandExpectedButFound2, [GetAtom]))
2049       else
2050         AddError(Format(ctsOperatorExpectedButFound2, [GetAtom]));
2051       Result:=false;
2052     end
2053     else if Result then begin
2054       // success
2055       // delete ctcssExpression and keep the operand
2056       FStack.Delete(FStack.Top-1);
2057       Item:=FStack.TopItem;
2058       inc(StartTop);
2059       {$IFDEF VerboseCTCfgScript}
2060       debugln(['TCTConfigScriptEngine.RunExpression Result="',dbgs(PCTCfgScriptVariable(@Item^.Operand)),'" ']);
2061       {$ENDIF}
2062     end;
2063   end;
2064 
2065   // clean up stack
2066   while (FStack.Top>StartTop) do FStack.Pop;
2067 end;
2068 
IsKeyWordnull2069 function TCTConfigScriptEngine.IsKeyWord(P: PChar): boolean;
2070 begin
2071   Result:=false;
2072   if p=nil then exit;
2073   case UpChars[p^] of
2074   'A':
2075     if CompareIdentifiers('and',p)=0 then exit(true);
2076   'B':
2077     if CompareIdentifiers('begin',p)=0 then exit(true);
2078   'C':
2079     if CompareIdentifiers('case',p)=0 then exit(true);
2080   'D':
2081     case UpChars[p[1]] of
2082     'E':
2083       if CompareIdentifiers('defined',p)=0 then exit(true);
2084     'I':
2085       if CompareIdentifiers('div',p)=0 then exit(true);
2086     end;
2087   'E':
2088     case UpChars[p[1]] of
2089     'L':
2090       if CompareIdentifiers('else',p)=0 then exit(true);
2091     'N':
2092       if CompareIdentifiers('end',p)=0 then exit(true);
2093     end;
2094   'F':
2095     case UpChars[p[1]] of
2096     'A':
2097       if CompareIdentifiers('false',p)=0 then exit(true);
2098     'U':
2099       if CompareIdentifiers('function',p)=0 then exit(true);
2100     end;
2101   'I':
2102     case UpChars[p[1]] of
2103     'F':
2104       if CompareIdentifiers('if',p)=0 then exit(true);
2105     'N':
2106       if (CompareIdentifiers('in',p)=0) then exit(true)
2107     end;
2108   'M':
2109     if CompareIdentifiers('mod',p)=0 then exit(true);
2110   'N':
2111     if CompareIdentifiers('not',p)=0 then exit(true);
2112   'O':
2113     case UpChars[p[1]] of
2114     'F':
2115       if CompareIdentifiers('of',p)=0 then exit(true);
2116     'R':
2117       if CompareIdentifiers('or',p)=0 then exit(true);
2118     end;
2119   'P':
2120     if CompareIdentifiers('procedure',p)=0 then exit(true);
2121   'S':
2122     case UpChars[p[1]] of
2123     'H':
2124       case UpChars[p[2]] of
2125       'L':
2126         if CompareIdentifiers('shl',p)=0 then exit(true);
2127       'R':
2128         if CompareIdentifiers('shr',p)=0 then exit(true);
2129       end;
2130     end;
2131   'T':
2132     case UpChars[p[1]] of
2133     'H':
2134       if CompareIdentifiers('then',p)=0 then exit(true);
2135     'R':
2136       if CompareIdentifiers('true',p)=0 then exit(true);
2137     end;
2138   'X':
2139     if CompareIdentifiers('xor',p)=0 then exit(true);
2140   'U':
2141     if CompareIdentifiers('undefined',p)=0 then exit(true);
2142   end;
2143 end;
2144 
ExecuteStacknull2145 function TCTConfigScriptEngine.ExecuteStack(MaxLevel: integer): boolean;
2146 { execute all operators on stack with level <= maxlevel
2147 }
2148 var
2149   OperatorItem: PCTCfgScriptStackItem;
2150   Typ: TCTCfgScriptOperator;
2151   OperandItem: PCTCfgScriptStackItem;
2152   b: Boolean;
2153   LeftOperandItem: PCTCfgScriptStackItem;
2154   OperandsEqual: boolean;
2155   LeftIsLowerThanRight: boolean;
2156 
2157   procedure ErrorInvalidOperator;
2158   begin
2159     raise ECodeToolCfgScript.Create('TCTConfigScriptEngine.ExecuteStack invalid operator: '+GetAtom(OperatorItem^.StartPos));
2160   end;
2161 
2162 begin
2163   Result:=true;
2164   repeat
2165     {$IFDEF VerboseCTCfgScript}
2166     WriteDebugReportStack('ExecuteStack MaxLevel='+dbgs(MaxLevel));
2167     {$ENDIF}
2168     if (FStack.TopTyp<>ctcssOperand) or (FStack.Top<=0) then
2169       exit;
2170     OperatorItem:=@FStack.Items[FStack.Top-1];
2171     if (OperatorItem^.Typ<>ctcssOperator)
2172     or (GetOperatorLevel(OperatorItem^.StartPos)>MaxLevel) then
2173       exit;
2174     OperandItem:=FStack.TopItem;
2175 
2176     // execute operator
2177     Typ:=AtomToCTCfgOperator(OperatorItem^.StartPos);
2178     {$IFDEF VerboseCTCfgScript}
2179     debugln(['TCTConfigScriptEngine.ExecuteStack execute operator "',GetAtom(OperatorItem^.StartPos),'" Typ=',dbgs(Typ)]);
2180     {$ENDIF}
2181     case Typ of
2182 
2183     ctcsoNot:
2184       begin
2185         b:=CTCSVariableIsTrue(@OperandItem^.Operand);
2186         FStack.Pop(2);
2187         PushBooleanValue(not b);
2188       end;
2189 
2190     ctcsoAnd,ctcsoOr,ctcsoXOr:
2191       begin
2192         b:=CTCSVariableIsTrue(@OperandItem^.Operand);
2193         FStack.Pop(2);
2194         if (FStack.Top>=0) then begin
2195           OperandItem:=FStack.TopItem;
2196           case Typ of
2197           ctcsoAnd: b:=b and CTCSVariableIsTrue(@OperandItem^.Operand);
2198           ctcsoOr:  b:=b or CTCSVariableIsTrue(@OperandItem^.Operand);
2199           ctcsoXOr: b:=b xor CTCSVariableIsTrue(@OperandItem^.Operand);
2200           end;
2201           FStack.Pop;
2202         end;
2203         PushBooleanValue(b);
2204       end;
2205 
2206     ctcsoEqual, ctcsoNotEqual, ctcsoLowerThan, ctcsoLowerOrEqualThan,
2207     ctcsoGreaterThan, ctcsoGreaterOrEqualThan:
2208       begin
2209         b:=false;
2210         if (FStack.Top>=2) then begin
2211           LeftOperandItem:=@FStack.Items[FStack.Top-2];
2212           if not CompareCTCSVariables(@LeftOperandItem^.Operand,@OperandItem^.Operand,
2213                                OperandsEqual,LeftIsLowerThanRight)
2214           then begin
2215             b:=false;
2216           end else begin
2217             case Typ of
2218             ctcsoEqual:
2219               b:=OperandsEqual;
2220             ctcsoNotEqual:
2221               b:=not OperandsEqual;
2222             ctcsoLowerThan:
2223               b:=(not OperandsEqual) and LeftIsLowerThanRight;
2224             ctcsoLowerOrEqualThan:
2225               b:=OperandsEqual or LeftIsLowerThanRight;
2226             ctcsoGreaterThan:
2227               b:=(not OperandsEqual) and not LeftIsLowerThanRight;
2228             ctcsoGreaterOrEqualThan:
2229               b:=OperandsEqual or not LeftIsLowerThanRight;
2230             end;
2231           end;
2232           {$IFDEF VerboseCTCfgScript}
2233           debugln(['TCTConfigScriptEngine.ExecuteStack ',GetCTCSVariableAsString(@LeftOperandItem^.Operand),' ',GetCTCSVariableAsString(@OperandItem^.Operand),' Equal=',OperandsEqual,' LT=',LeftIsLowerThanRight,' Result=',Result]);
2234           {$ENDIF}
2235           FStack.Pop(3);
2236         end else begin
2237           FStack.Pop(2);
2238         end;
2239         PushBooleanValue(b);
2240       end;
2241 
2242     ctcsoPlus:
2243       begin
2244         if (FStack.Top>=2) then begin
2245           LeftOperandItem:=@FStack.Items[FStack.Top-2];
2246           // add right operand to left operand on stack
2247           AddCTCSVariables(@OperandItem^.Operand,@LeftOperandItem^.Operand);
2248           // remove right operand and +
2249           FStack.Pop(2);
2250         end else begin
2251           // unary operator
2252           // just remove the +
2253           FStack.Delete(FStack.Top-1);
2254         end;
2255       end;
2256 
2257     else
2258       ErrorInvalidOperator;
2259     end;
2260   until false;
2261 end;
2262 
GetOperatorLevelnull2263 function TCTConfigScriptEngine.GetOperatorLevel(P: PChar): integer;
2264 begin
2265   Result:=CTCfgScriptOperatorLvl[AtomToCTCfgOperator(P)];
2266 end;
2267 
TCTConfigScriptEngine.IsFunctionnull2268 function TCTConfigScriptEngine.IsFunction(p: PChar): boolean;
2269 begin
2270   Result:=false;
2271   if (p=nil) or (not IsIdentStartChar[p^]) then exit;
2272   case UpChars[p^] of
2273   'I':
2274     if (CompareIdentifiers(p,'integer')=0)
2275     or (CompareIdentifiers(p,'int64')=0)
2276     then exit(true);
2277   'S':
2278     if CompareIdentifiers(p,'string')=0 then exit(true);
2279   end;
2280   Result:=IsCustomFunction(p);
2281 end;
2282 
TCTConfigScriptEngine.IsCustomFunctionnull2283 function TCTConfigScriptEngine.IsCustomFunction(FunctionName: PChar): boolean;
2284 begin
2285   Result:=false;
2286 end;
2287 
2288 procedure TCTConfigScriptEngine.RunCustomSimpleFunction(FunctionName: PChar;
2289   Value: PCTCfgScriptVariable);
2290 begin
2291 
2292 end;
2293 
2294 constructor TCTConfigScriptEngine.Create;
2295 begin
2296   FVariables:=TCTCfgScriptVariables.Create;
2297   FStack:=TCTCfgScriptStack.Create;
2298   FErrors:=TFPList.Create;
2299 end;
2300 
2301 destructor TCTConfigScriptEngine.Destroy;
2302 begin
2303   ClearErrors;
2304   FreeAndNil(FErrors);
2305   FreeAndNil(FVariables);
2306   FreeAndNil(FStack);
2307   inherited Destroy;
2308 end;
2309 
2310 procedure TCTConfigScriptEngine.ClearErrors;
2311 var
2312   i: Integer;
2313 begin
2314   for i:=0 to FErrors.Count-1 do
2315     TObject(FErrors[i]).Free;
2316   FErrors.Clear;
2317 end;
2318 
Executenull2319 function TCTConfigScriptEngine.Execute(const Source: string;
2320   StopAfterErrors: integer): boolean;
2321 
2322   procedure ExpectedSemicolon;
2323   begin
2324     AddError(Format(ctsExpectedSemicolonOfStatementButFound, [GetAtomOrNothing]))
2325   end;
2326 
2327 var
2328   Err: TCTCfgScriptError;
2329 begin
2330   FStack.Clear;
2331   ClearErrors;
2332   MaxErrorCount:=StopAfterErrors;
2333   SrcStart:=#0;
2334   SrcEnd:=SrcStart;
2335   Src:=SrcStart;
2336   AtomStart:=SrcStart;
2337 
2338   if Source='' then exit(true);
2339 
2340   SrcStart:=PChar(Source);
2341   SrcEnd:=SrcStart+length(Source);
2342   Src:=SrcStart;
2343   AtomStart:=Src;
2344 
2345   try
2346     // execute all statements
2347     ReadRawNextPascalAtom(Src,AtomStart,nil,false,true);
2348     while Src^<>#0 do begin
2349       RunStatement(false);
2350       if not (AtomStart^ in [#0,';']) then
2351         ExpectedSemicolon;
2352       ReadRawNextPascalAtom(Src,AtomStart,nil,false,true);
2353     end;
2354   except
2355     on E: Exception do begin
2356       // too many errors
2357       if ErrorCount=0 then begin
2358         Err:=TCTCfgScriptError.Create(E.Message);
2359         FErrors.Add(Err);
2360       end;
2361     end;
2362   end;
2363   Result:=ErrorCount=0;
2364 end;
2365 
ErrorCountnull2366 function TCTConfigScriptEngine.ErrorCount: integer;
2367 begin
2368   Result:=FErrors.Count;
2369 end;
2370 
GetAtomnull2371 function TCTConfigScriptEngine.GetAtom: string;
2372 begin
2373   if (AtomStart=nil) or (AtomStart>Src) then
2374     exit('');
2375   SetLength(Result,Src-AtomStart);
2376   if Result<>'' then
2377     System.Move(AtomStart^,Result[1],length(Result));
2378 end;
2379 
TCTConfigScriptEngine.GetAtomOrNothingnull2380 function TCTConfigScriptEngine.GetAtomOrNothing: string;
2381 begin
2382   if (AtomStart=nil) or (AtomStart>Src) then
2383     Result:='nothing'
2384   else begin
2385     SetLength(Result,Src-AtomStart);
2386     if Result<>'' then
2387       System.Move(AtomStart^,Result[1],length(Result));
2388   end;
2389 end;
2390 
GetAtomnull2391 function TCTConfigScriptEngine.GetAtom(P: PChar): string;
2392 var
2393   StartPos: PChar;
2394 begin
2395   if P=nil then
2396     exit('');
2397   ReadRawNextPascalAtom(P,StartPos,nil,false,true);
2398   SetLength(Result,p-StartPos);
2399   if Result<>'' then
2400     System.Move(StartPos^,Result[1],length(Result));
2401 end;
2402 
TCTConfigScriptEngine.PosToLineColnull2403 function TCTConfigScriptEngine.PosToLineCol(p: PChar; out Line, Column: integer
2404   ): boolean;
2405 var
2406   run: PChar;
2407 begin
2408   Line:=1;
2409   Column:=1;
2410   if (p<SrcStart) or (p>SrcEnd) then exit(false);
2411   run:=SrcStart;
2412   while run<p do begin
2413     if Run^ in [#10,#13] then begin
2414       inc(Line);
2415       Column:=1;
2416       if (Run[1] in [#10,#13]) and (Run^<>Run[1]) then
2417         inc(Run,2)
2418       else
2419         inc(Run);
2420     end else begin
2421       inc(Run);
2422       inc(Column);
2423     end;
2424   end;
2425   Result:=true;
2426 end;
2427 
PosToStrnull2428 function TCTConfigScriptEngine.PosToStr(p: PChar): string;
2429 var
2430   Line: integer;
2431   Column: integer;
2432 begin
2433   if PosToLineCol(p,Line,Column) then
2434     Result:='('+IntToStr(Line)+','+IntToStr(Column)+')'
2435   else
2436     Result:='';
2437 end;
2438 
GetErrorStrnull2439 function TCTConfigScriptEngine.GetErrorStr(Index: integer): string;
2440 var
2441   Err: TCTCfgScriptError;
2442 begin
2443   Err:=Errors[Index];
2444   Result:='Error: ';
2445   if Err.Line>0 then
2446     Result:=Result+'('+IntToStr(Err.Line)+','+IntToStr(Err.Column)+') ';
2447   Result:=Result+Err.Msg;
2448 end;
2449 
2450 procedure TCTConfigScriptEngine.WriteDebugReportStack(Title: string);
2451 var
2452   i: Integer;
2453   Item: PCTCfgScriptStackItem;
2454 begin
2455   debugln(['TCTConfigScriptEngine.WriteDebugReportStack FStack.Top=',FStack.Top,' ',Title]);
2456   for i:=0 to FStack.Top do begin
2457     dbgout(GetIndentStr(i*2+2));
2458     Item:=@FStack.Items[i];
2459     dbgout(dbgs(Item^.Typ),' StartPos=',GetAtom(Item^.StartPos));
2460     if Item^.Typ=ctcssOperator then
2461       dbgout(' level='+dbgs(GetOperatorLevel(Item^.StartPos)));
2462     if Item^.Typ=ctcssOperand then
2463       dbgout(' ',dbgs(PCTCfgScriptVariable(@Item^.Operand)));
2464     debugln;
2465   end;
2466 end;
2467 
2468 { TCTCfgScriptStack }
2469 
2470 constructor TCTCfgScriptStack.Create;
2471 begin
2472   Top:=-1;
2473 end;
2474 
2475 destructor TCTCfgScriptStack.Destroy;
2476 begin
2477   Clear;
2478   inherited Destroy;
2479 end;
2480 
2481 procedure TCTCfgScriptStack.Clear;
2482 var
2483   i: Integer;
2484   Item: PCTCfgScriptStackItem;
2485 begin
2486   for i:=0 to Top do begin
2487     Item:=@Items[i];
2488     ClearCTCSVariable(@Item^.Operand);
2489     if Item^.Operand.Name<>nil then
2490       ReAllocMem(Item^.Operand.Name,0);
2491   end;
2492   Top:=-1;
2493   TopTyp:=ctcssNone;
2494   Capacity:=0;
2495   ReAllocMem(Items,0);
2496 end;
2497 
2498 procedure TCTCfgScriptStack.Push(Typ: TCTCfgScriptStackItemType;
2499   const StartPos: PChar);
2500 var
2501   OldCapacity: LongInt;
2502   Item: PCTCfgScriptStackItem;
2503 begin
2504   inc(Top);
2505   if Top>=Capacity then begin
2506     OldCapacity:=Capacity;
2507     if Capacity<10 then
2508       Capacity:=10
2509     else
2510       Capacity:=Capacity*2;
2511     ReAllocMem(Items,Capacity*SizeOf(TCTCfgScriptStackItem));
2512     FillByte(Items[OldCapacity],(Capacity-OldCapacity)*SizeOf(TCTCfgScriptStackItem),0);
2513   end;
2514   Item:=@Items[Top];
2515   Item^.Typ:=Typ;
2516   Item^.StartPos:=StartPos;
2517   TopTyp:=Typ;
2518   {$IFDEF CheckCTCfgVars}
2519   CheckOperands;
2520   {$ENDIF}
2521 end;
2522 
2523 procedure TCTCfgScriptStack.Pop(Count: integer);
2524 
2525   procedure RaiseTooManyPop;
2526   begin
2527     raise ECodeToolCfgScript.Create('TCTCfgScriptStack.Pop too many pop');
2528   end;
2529 
2530 var
2531   Item: PCTCfgScriptStackItem;
2532 begin
2533   if Top<Count-1 then
2534     RaiseTooManyPop;
2535   while Count>0 do begin
2536     Item:=@Items[Top];
2537     ClearCTCSVariable(@Item^.Operand);
2538     if Item^.Operand.Name<>nil then
2539       ReAllocMem(Item^.Operand.Name,0);
2540     dec(Top);
2541     if Top>=0 then
2542       TopTyp:=Items[Top].Typ
2543     else
2544       TopTyp:=ctcssNone;
2545     dec(Count);
2546   end;
2547   {$IFDEF CheckCTCfgVars}
2548   CheckOperands;
2549   {$ENDIF}
2550 end;
2551 
2552 procedure TCTCfgScriptStack.Delete(Index: integer);
2553 var
2554   Item: PCTCfgScriptStackItem;
2555 begin
2556   if (Index<0) or (Index>Top) then exit;
2557   Item:=@Items[Index];
2558   ClearCTCSVariable(@Item^.Operand);
2559   if Item^.Operand.Name<>nil then
2560     ReAllocMem(Item^.Operand.Name,0);
2561   if Index<Top then begin
2562     System.Move(Items[Index+1],Items[Index],SizeOf(TCTCfgScriptStackItem)*(Top-Index));
2563     Item:=@Items[Top];
2564     Item^.Typ:=ctcssNone;
2565     FillByte(Item^.Operand,SizeOf(Item^.Operand),0);
2566   end;
2567   dec(Top);
2568   {$IFDEF CheckCTCfgVars}
2569   CheckOperands;
2570   {$ENDIF}
2571 end;
2572 
TCTCfgScriptStack.TopItemnull2573 function TCTCfgScriptStack.TopItem: PCTCfgScriptStackItem;
2574 begin
2575   if Top<0 then
2576     Result:=nil
2577   else
2578     Result:=@Items[Top];
2579 end;
2580 
TopItemOperandnull2581 function TCTCfgScriptStack.TopItemOperand: PCTCfgScriptVariable;
2582 begin
2583   if Top<0 then
2584     Result:=nil
2585   else
2586     Result:=@Items[Top].Operand;
2587 end;
2588 
2589 {$IFDEF CheckCTCfgVars}
2590 procedure TCTCfgScriptStack.CheckOperands;
2591 var
2592   i: Integer;
2593 begin
2594   for i:=0 to Top do
2595     CheckCTCSVariable(@Items[Top].Operand);
2596 end;
2597 {$ENDIF}
2598 
2599 { TCTCfgScriptError }
2600 
2601 constructor TCTCfgScriptError.Create(const aMsg: string; aPos, aLine,
2602   aCol: integer);
2603 begin
2604   Msg:=aMsg;
2605   Position:=aPos;
2606   Line:=aLine;
2607   Column:=aCol;
2608 end;
2609 
2610 constructor TCTCfgScriptError.Create(const aMsg: string);
2611 begin
2612   Msg:=aMsg;
2613   Position:=-1;
2614   Line:=0;
2615   Column:=0;
2616 end;
2617 
2618 end.
2619 
2620