/Source/FR_PARS.PAS

  1
  2{*****************************************}
  3{                                         }
  4{             FastReport v2.3             }
  5{            Expression parser            }
  6{                                         }
  7{  Copyright (c) 1998-99 by Tzyganenko A. }
  8{                                         }
  9{*****************************************}
 10
 11unit FR_Pars;
 12
 13interface
 14
 15{$I FR.inc}
 16
 17type
 18  TGetPValueEvent = procedure(const s: String; var v: Variant) of object;
 19  TFunctionEvent = procedure(const Name: String; p1, p2, p3: Variant;
 20                             var Val: String) of object;
 21
 22  TfrParser = class
 23  private
 24    FOnGetValue: TGetPValueEvent;
 25    FOnFunction: TFunctionEvent;
 26    function GetIdentify(const s: String; var i: Integer): String;
 27    function GetString(const s: String; var i: Integer):String;
 28    procedure Get3Parameters(const s: String; var i: Integer;
 29      var s1, s2, s3: String);
 30  public
 31    function Str2OPZ(s: String): String;
 32    function CalcOPZ(const s: String): Variant;
 33    function Calc(const s: String): Variant;
 34    property OnGetValue: TGetPValueEvent read FOnGetValue write FOnGetValue;
 35    property OnFunction: TFunctionEvent read FOnFunction write FOnFunction;
 36  end;
 37
 38function GetBrackedVariable(s: String; var i, j: Integer): String;
 39
 40implementation
 41
 42uses SysUtils;
 43
 44const
 45  ttGe = #1; ttLe = #2;
 46  ttNe = #3; ttOr = #4; ttAnd = #5;
 47  ttInt = #6;  ttFrac = #7;
 48  ttUnMinus = #9; ttUnPlus = #10; ttStr = #11;
 49  ttNot = #12; ttMod = #13; ttRound = #14;
 50
 51
 52function GetBrackedVariable(s: String; var i, j: Integer): String;
 53var
 54  c: Integer;
 55  fl1, fl2: Boolean;
 56begin
 57  j := i; fl1 := True; fl2 := True; c := 0;
 58  Result := '';
 59  if s = '' then Exit;
 60  Dec(j);
 61  repeat
 62    Inc(j);
 63    if fl1 and fl2 then
 64      if s[j] = '[' then
 65      begin
 66        if c = 0 then i := j;
 67        Inc(c);
 68      end
 69      else if s[j] = ']' then Dec(c);
 70    if fl1 then
 71      if s[j] = '"' then fl2 := not fl2;
 72    if fl2 then
 73      if s[j] = '''' then fl1 := not fl1;
 74  until (c = 0) or (j >= Length(s));
 75  Result := Copy(s, i + 1, j - i - 1);
 76end;
 77
 78function TfrParser.CalcOPZ(const s: String): Variant;
 79var
 80  i, j, k, i1, st: Integer;
 81  s1: String;
 82  nm: Array[1..8] of Variant;
 83  Format: (fNone, fDate, fTime);
 84begin
 85  st := 1;
 86  i := 1;
 87  Format := fNone;
 88  while i <= Length(s) do
 89  begin
 90    j := i;
 91    case s[i] of
 92      '+', ttOr:
 93        nm[st - 2] := nm[st - 2] + nm[st - 1];
 94      '-':
 95        nm[st - 2] := nm[st - 2] - nm[st - 1];
 96      '*', ttAnd:
 97        nm[st - 2] := nm[st - 2] * nm[st - 1];
 98      '/':
 99        if nm[st - 1] <> 0 then
100          nm[st - 2] := nm[st - 2] / nm[st - 1] else
101          nm[st - 2] := 0;
102      '>':
103        if nm[st - 2] > nm[st - 1] then nm[st - 2] := 1
104        else nm[st - 2] := 0;
105      '<':
106        if nm[st - 2] < nm[st - 1] then nm[st - 2] := 1
107        else nm[st - 2] := 0;
108      '=':
109        if nm[st - 2] = nm[st - 1] then nm[st - 2] := 1
110        else nm[st - 2] := 0;
111      ttNe:
112        if nm[st - 2] <> nm[st - 1] then nm[st - 2] := 1
113        else nm[st - 2] := 0;
114      ttGe:
115        if nm[st - 2] >= nm[st - 1] then nm[st - 2] := 1
116        else nm[st - 2] := 0;
117      ttLe:
118        if nm[st - 2] <= nm[st - 1] then nm[st - 2] := 1
119        else nm[st - 2] := 0;
120      ttInt:
121        nm[st - 1] := Int(nm[st - 1]);
122      ttFrac:
123        nm[st - 1] := Frac(nm[st - 1]);
124      ttRound:
125        nm[st - 1] := Integer(Round(nm[st - 1]));
126      ttUnMinus:
127        nm[st - 1] := -nm[st - 1];
128      ttUnPlus:;
129      ttStr:
130        begin
131          s1 := nm[st - 1];
132          nm[st - 1] := s1;
133        end;
134      ttNot:
135        if nm[st - 1] = 0 then nm[st - 1] := 1 else nm[st - 1] := 0;
136      ttMod:
137        nm[st - 2] := nm[st - 2] mod nm[st - 1];
138      '%':
139        begin
140          if s[i + 1] in ['d', 'D'] then Format := fDate;
141          if s[i + 1] in ['t', 'T'] then Format := fTime;
142          Inc(i);
143        end;
144      ' ': ;
145      '[':
146        begin
147          k := i;
148          s1 := GetBrackedVariable(s, k, i);
149          if Assigned(FOnGetValue) then
150            FOnGetValue(s1, nm[st]);
151          Inc(st);
152        end
153      else
154        begin
155          if s[i] = '''' then
156          begin
157            s1 := GetString(s, i);
158            while Pos('''' + '''', s1) <> 0 do
159              Delete(s1,Pos('''' + '''', s1), 1);
160            s1 := Copy(s1, 2, Length(s1) - 2);
161            if Format = fNone then
162              nm[st] := s1
163            else if Format = fDate then
164              nm[st] := StrToDate(s1)
165            else if Format = fTime then
166              nm[st] := StrToTime(s1);
167            Format := fNone;
168            k := i;
169          end
170          else
171          begin
172            k := i;
173            s1 := GetIdentify(s, k);
174            if s1[1] in ['0'..'9', '.', ','] then
175            begin
176              for i1 := 1 to Length(s1) do
177                if s1[i1] in ['.', ','] then s1[i1] := DecimalSeparator;
178              nm[st] := StrToFloat(s1);
179            end
180            else
181              if Assigned(FOnGetValue) then
182                FOnGetValue(AnsiUpperCase(s1), nm[st]);
183          end;
184          i := k;
185          Inc(st);
186        end;
187    end;
188    if s[j] in ['+', '-', '*', '/', '>', '<', '=', ttGe, ttLe, ttNe,
189      ttOr, ttAnd, ttMod] then
190      Dec(st);
191    Inc(i);
192  end;
193  Result := nm[1];
194end;
195
196function TfrParser.GetIdentify(const s: String; var i: Integer): String;
197var
198  k, n: Integer;
199begin
200  n := 0;
201  while (i <= Length(s)) and (s[i] = ' ') do
202    Inc(i);
203  k := i; Dec(i);
204  repeat
205    Inc(i);
206    while (i <= Length(s)) and
207      not (s[i] in [' ', '+', '-', '*', '/', '>', '<', '=', '(', ')']) do
208    begin
209      if s[i] = '"' then Inc(n);
210      Inc(i);
211    end;
212  until n mod 2 = 0;
213  Result := Copy(s, k, i - k);
214end;
215
216function TfrParser.GetString(const s: String; var i: Integer): String;
217var
218  k: Integer;
219  f: Boolean;
220begin
221  k := i; Inc(i);
222  repeat
223    while (i <= Length(s)) and (s[i] <> '''') do
224      Inc(i);
225    f := True;
226    if (i < Length(s)) and (s[i + 1] = '''') then
227    begin
228      f := False;
229      Inc(i, 2);
230    end;
231  until f;
232  Result := Copy(s, k, i - k + 1);
233  Inc(i);
234end;
235
236procedure TfrParser.Get3Parameters(const s: String; var i: Integer;
237  var s1, s2, s3: String);
238var
239  c, d, oi, ci: Integer;
240begin
241  s1 := ''; s2 := ''; s3 := '';
242  c := 1; d := 1; oi := i + 1; ci := 1;
243  repeat
244    Inc(i);
245    if s[i] = '(' then Inc(c)
246    else if s[i] = ')' then Dec(c);
247    if s[i] = '''' then
248      if d = 1 then Inc(d) else d := 1;
249    if (s[i] = ',') and (c = 1) and (d = 1) then
250    begin
251      if ci = 1 then
252        s1 := Copy(s, oi, i - oi) else
253        s2 := Copy(s, oi, i - oi);
254      oi := i + 1; Inc(ci);
255    end;
256  until (c = 0) or (i >= Length(s));
257  case ci of
258    1: s1 := Copy(s, oi, i - oi);
259    2: s2 := Copy(s, oi, i - oi);
260    3: s3 := Copy(s, oi, i - oi);
261  end;
262  Inc(i);
263end;
264
265function TfrParser.Str2OPZ(s: String): String;
266label 1;
267var
268  i, i1, j, p, ci, cn: Integer;
269  stack: String;
270  res, s1, s2, s3, s4, sr: String;
271  vr: Boolean;
272  c: Char;
273  function Priority(c: Char): Integer;
274  begin
275    case c of
276      '(': Priority := 5;
277      ')': Priority := 4;
278      '=', '>', '<', ttGe, ttLe, ttNe: Priority := 3;
279      '+', '-', ttUnMinus, ttUnPlus: Priority := 2;
280      '*', '/', ttOr, ttAnd, ttNot, ttMod: Priority := 1;
281      ttInt, ttFrac, ttRound, ttStr: Priority := 0;
282      else Priority := 0;
283    end;
284  end;
285  procedure ProcessQuotes(var s: String);
286  var
287    i: Integer;
288  begin
289    if (Length(s) = 0) or (s[1] <> '''') then Exit;
290    i := 2;
291    if Length(s) > 2 then
292      while i <= Length(s) do
293      begin
294        if (s[i] = '''') and (i < Length(s)) then
295        begin
296          Insert('''', s, i);
297          Inc(i);
298        end;
299        Inc(i);
300      end;
301  end;
302begin
303  res := '';
304  stack := '';
305  i := 1; vr := False;
306  while i <= Length(s) do
307  begin
308    case s[i] of
309      '(':
310        begin
311          stack := '(' + stack;
312          vr := False;
313        end;
314      ')':
315        begin
316          p := Pos('(', stack);
317          res := res + Copy(stack, 1, p - 1);
318          stack := Copy(stack, p + 1, Length(stack) - p);
319        end;
320      '+', '-', '*', '/', '>', '<', '=':
321        begin
322          if (s[i] = '<') and (s[i + 1] = '>') then
323          begin
324            Inc(i);
325            s[i] := ttNe;
326          end else
327          if (s[i] = '>') and (s[i + 1] = '=') then
328          begin
329            Inc(i);
330            s[i] := ttGe;
331          end else
332          if (s[i] = '<') and (s[i + 1] = '=') then
333          begin
334            Inc(i);
335            s[i] := ttLe;
336          end;
337
3381:        if not vr then
339          begin
340            if s[i] = '-' then s[i] := ttUnMinus;
341            if s[i] = '+' then s[i] := ttUnPlus;
342          end;
343          vr := False;
344          if stack = '' then stack := s[i] + stack
345          else
346            if Priority(s[i]) < Priority(stack[1]) then
347              stack := s[i] + stack
348            else
349            begin
350              repeat
351                res := res + stack[1];
352                stack := Copy(stack, 2, Length(stack) - 1);
353              until (stack = '') or (Priority(stack[1]) > Priority(s[i]));
354              stack := s[i] + stack;
355            end;
356        end;
357      ';': break;
358      ' ': ;
359      else
360      begin
361        vr := True;
362        s2 := '';
363        i1 := i;
364        if s[i] = '%' then
365        begin
366          s2 := '%' + s[i + 1];
367          Inc(i, 2);
368        end;
369        if s[i] = '''' then
370          s2 := s2 + GetString(s, i)
371        else if s[i] = '[' then
372        begin
373          s2 := s2 + '[' + GetBrackedVariable(s, i, j) + ']';
374          i := j + 1;
375        end
376        else
377          s2 := s2 + GetIdentify(s, i);
378        c := s[i];
379        if (Length(s2) > 0) and (s2[1] in ['0'..'9', '.', ',']) then
380          res := res + s2 + ' '
381        else
382        begin
383          s1 := AnsiUpperCase(s2);
384          if s1 = 'INT' then
385          begin
386            s[i - 1] := ttInt;
387            Dec(i);
388            goto 1;
389          end
390          else if s1 = 'FRAC' then
391          begin
392            s[i - 1] := ttFrac;
393            Dec(i);
394            goto 1;
395          end
396          else if s1 = 'ROUND' then
397          begin
398            s[i - 1] := ttRound;
399            Dec(i);
400            goto 1;
401          end
402          else if s1 = 'OR' then
403          begin
404            s[i - 1] := ttOr;
405            Dec(i);
406            goto 1;
407          end
408          else if s1 = 'AND' then
409          begin
410            s[i - 1] := ttAnd;
411            Dec(i);
412            goto 1;
413          end
414          else if s1 = 'NOT' then
415          begin
416            s[i - 1] := ttNot;
417            Dec(i);
418            goto 1;
419          end
420          else if s1 = 'STR' then
421          begin
422            s[i - 1] := ttStr;
423            Dec(i);
424            goto 1;
425          end
426          else if s1 = 'MOD' then
427          begin
428            s[i - 1] := ttMod;
429            Dec(i);
430            goto 1;
431          end
432          else if s1 = 'COPY' then
433          begin
434            Get3Parameters(s, i, s2, s3, s4);
435            ci := StrToInt(CalcOPZ(Str2OPZ(s3)));
436            cn := StrToInt(CalcOPZ(Str2OPZ(s4)));
437            s1 := '''' + Copy(CalcOPZ(Str2OPZ(s2)), ci, cn) + '''';
438            ProcessQuotes(s1);
439            Delete(s, i1, i - i1);
440            Insert('(' + s1 + ')', s, i1);
441            i := i1;
442          end
443          else if s1 = 'IF' then
444          begin
445            Get3Parameters(s, i, s2, s3, s4);
446            if Int(StrToFloat(CalcOPZ(Str2OPZ(s2)))) > 0 then
447              s1 := s3 else
448              s1 := s4;
449            ProcessQuotes(s1);
450            Delete(s, i1, i - i1);
451            Insert('(' + s1 + ')', s, i1);
452            i := i1;
453          end
454          else if c = '(' then // other function
455          begin
456            Get3Parameters(s, i, s2, s3, s4);
457            sr := '';
458            if Assigned(FOnFunction) then
459              FOnFunction(s1, s2, s3, s4, sr);
460            ProcessQuotes(sr);
461            Delete(s, i1, i - i1);
462            Insert('(' + sr + ')', s, i1);
463            i := i1;
464          end
465          else res := res + s2 + ' ';
466        end;
467        Dec(i);
468      end;
469    end;
470    Inc(i);
471  end;
472  if stack <> '' then res := res + stack;
473  Result := res;
474end;
475
476function TfrParser.Calc(const s: String): Variant;
477begin
478  Result := CalcOPZ(Str2OPZ(s));
479end;
480
481end.
482