{******************************************}
{                                          }
{             FastScript v1.9              }
{            Common functions              }
{                                          }
{  (c) 2003-2007 by Alexander Tzyganenko,  }
{             Fast Reports Inc             }
{                                          }
{******************************************}
//VCL uses section
{$IFNDEF FMX}
unit fs_itools;

interface

{$i fs.inc}

uses
  SysUtils, Classes, TypInfo, fs_iinterpreter, fs_xml
{$IFDEF Delphi6}
, Variants
{$ENDIF}
{$IFDEF CROSS_COMPILE}
, Types
{$ELSE}
, Windows
{$ENDIF};
// FMX USES section
{$ELSE}
interface

{$i fs.inc}

uses
  System.SysUtils, System.Classes, System.TypInfo, FMX.fs_iinterpreter, FMX.fs_xml
{$IFDEF Delphi6}
, System.Variants
{$ENDIF}
, System.Types, FMX.Types;
{$ENDIF}

type
  TVarRecArray = array of TVarRec;


procedure fsRegisterLanguage(const Name, Grammar: String);
function fsGetLanguage(const Name: String): String;
procedure fsGetLanguageList(List: TStrings);

procedure GenerateXMLContents(Prog: TfsScript; Item: TfsXMLItem;
  FunctionsOnly: Boolean = False);
procedure GenerateMembers(Prog: TfsScript; cl: TClass; Item: TfsXMLItem);
function StrToVarType(const TypeName: String; Script: TfsScript): TfsVarType;
function TypesCompatible(Typ1, Typ2: TfsTypeRec; Script: TfsScript): Boolean;
function AssignCompatible(Var1, Var2: TfsCustomVariable; Script: TfsScript): Boolean;
function VarRecToVariant(v: TVarRec): Variant;
procedure VariantToVarRec(v: Variant; var ar: TVarRecArray; var sPtrList: Tlist);
procedure ClearVarRec(var ar: TVarRecArray; var sPtrList: TList);
function ParserStringToVariant(s: String): Variant;
function ParseMethodSyntax(const Syntax: String; Script: TfsScript): TfsCustomVariable;
function fsPosToPoint(const ErrorPos: String): TPoint;
{$IFNDEF Delphi4}
function fsSetToString(PropInfo: PPropInfo; const Value: Variant): string;
{$ENDIF}

implementation
//VCL uses section
{$IFNDEF FMX}
uses
  fs_iparser,
  fs_iconst;
//FMX uses section
{$ELSE}
uses
  FMX.fs_iparser,
  FMX.fs_iconst;
{$ENDIF}

var
  Languages: TStringList;

procedure fsRegisterLanguage(const Name, Grammar: String);
var
  i: Integer;
begin
  i := Languages.IndexOfName(Name);
  if i = -1 then
    Languages.Add(Name + '=' + Grammar)
  else
    Languages[i] := Name + '=' + Grammar;
end;

function fsGetLanguage(const Name: String): String;
begin
  if Languages.IndexOfName(Name) = -1 then
    raise Exception.CreateFmt(SLangNotFound, [Name]) else
    Result := Languages.Values[Name];
end;

procedure fsGetLanguageList(List: TStrings);
var
  i: Integer;
begin
  List.Clear;
  for i := 0 to Languages.Count - 1 do
    if Languages.Names[i][1] <> '@' then
      List.Add(Languages.Names[i]);
end;


function StrToVarType(const TypeName: String; Script: TfsScript): TfsVarType;
var
  v: TfsCustomVariable;
begin
  v := Script.Find(TypeName);
  if v = nil then
    Result := fvtClass else
    Result := v.Typ;
end;

function ClassesCompatible(const Class1, Class2: String; Script: TfsScript): Boolean;
var
  cl1, cl2: TfsClassVariable;
begin
  Result := False;
  cl1 := Script.FindClass(Class1);
  cl2 := Script.FindClass(Class2);
  if (cl1 <> nil) and (cl2 <> nil) then
    Result := cl2.ClassRef.InheritsFrom(cl1.ClassRef);
end;

function TypesCompatible(Typ1, Typ2: TfsTypeRec; Script: TfsScript): Boolean;
begin
  Result := False;
  case Typ1.Typ of
    fvtInt:
      Result := Typ2.Typ in [fvtInt, fvtFloat, fvtVariant, fvtEnum, fvtInt64];
{$IFDEF FS_INT64}
    fvtInt64:
      Result := Typ2.Typ in [fvtInt64, fvtInt, fvtFloat, fvtVariant, fvtEnum];
{$ENDIF}
    fvtFloat:
      Result := Typ2.Typ in [fvtInt, fvtFloat, fvtVariant];
    fvtBool:
      Result := Typ2.Typ in [fvtBool, fvtVariant];
    fvtChar, fvtString:
      Result := Typ2.Typ in [fvtChar, fvtString, fvtVariant];
    fvtClass:
      Result := (Typ2.Typ = fvtVariant) or ((Typ2.Typ = fvtClass) and
         ClassesCompatible(Typ1.TypeName, Typ2.TypeName, Script));
    fvtArray:
      Result := Typ2.Typ in [fvtArray, fvtVariant];
    fvtVariant:
      Result := True;
    fvtEnum:
      begin
        Result := Typ2.Typ in [fvtInt, fvtInt64, fvtVariant, fvtEnum];
        if Typ2.Typ = fvtEnum then
  Result := AnsiCompareText(Typ1.TypeName, Typ2.TypeName) = 0;
      end;
  end;
end;

function AssignCompatible(Var1, Var2: TfsCustomVariable; Script: TfsScript): Boolean;
var
  t1, t2: TfsTypeRec;
begin
  t1.Typ := Var1.Typ;
  t1.TypeName := Var1.TypeName;
  t2.Typ := Var2.Typ;
  t2.TypeName := Var2.TypeName;

  Result := TypesCompatible(t1, t2, Script);
  if Result and (Var1.Typ = fvtInt) and (Var2.Typ = fvtFloat) then
    Result := False;
end;

function VarRecToVariant(v: TVarRec): Variant;
begin
  with v do
    case VType of
{$IFDEF FS_INT64}
      vtInt64:
        Result := VInt64^;
{$ENDIF}
{$IFDEF CPUX64}
      vtInteger:
        Result := VInteger;
      vtObject:
        Result := frxInteger(VObject);
{$ELSE}
      vtInteger, vtObject:
        Result := VInteger;
{$ENDIF}
      vtBoolean:
        Result := VBoolean;
      vtExtended, vtCurrency:
        Result := VExtended^;
      vtChar:
        Result := VChar;
      vtString:
        Result := VString^;
      vtAnsiString:
        Result := AnsiString(VAnsiString);
{$IFDEF Delphi12}
      vtUnicodeString:
        Result := String(VUnicodeString);
      vtWideString:
        Result := WideString(VWideString);
      vtWideChar:
        Result := VWideChar;
{$ENDIF}
      vtVariant:
        Result := VVariant^;
      else
        Result := Null;
    end;
end;

procedure VariantToVarRec(v: Variant; var ar: TVarRecArray; var sPtrList: TList);
var
  i: Integer;
{$IFDEF Delphi12}
  pWStr: PWideString;
{$ELSE}
{$IFDEF FPC}
  pWStr: PWideString;
{$ELSE}
  pAStr: PAnsiString;
{$ENDIF}
{$ENDIF}
begin
  SetLength(ar, VarArrayHighBound(v, 1) + 1);

  sPtrList := TList.Create;
  for i := 0 to VarArrayHighBound(v, 1) do
    case TVarData(v[i]).VType of
      varSmallint, varInteger, varByte{$IFDEF Delphi6}, varShortInt, varWord, varLongWord{$ENDIF}:
        begin
          ar[i].VType := vtInteger;
          ar[i].VInteger := v[i];
        end;
{$IFDEF DELPHI6}
      varInt64:
        begin
          ar[i].VType := vtInt64;
          New(ar[i].VInt64);
          ar[i].VInt64^ := v[i];
        end;
{$ENDIF}
      varSingle, varDouble, varCurrency, varDate:
        begin
          ar[i].VType := vtExtended;
          New(ar[i].VExtended);
          ar[i].VExtended^ := v[i];
        end;
      varBoolean:
        begin
          ar[i].VType := vtBoolean;
          ar[i].VBoolean := v[i];
        end;
        varString:
        begin
          ar[i].VType := vtString;
          New(ar[i].VString);
{$IFDEF Delphi12}
          ar[i].VString^ := AnsiString(v[i]);
{$ELSE}
          ar[i].VString^ := v[i];
{$ENDIF}
        end;
      varOleStr:
        begin
{$IFDEF Delphi12}
          ar[i].VType := vtWideString;
          New(pWStr);
          sPtrList.Add(pWStr);
          pWStr^ := WideString(v[i]);
          ar[i].VWideString := PWideString(pWStr^);
{$ELSE}
{$IFDEF FPC}
          ar[i].VType := vtWideString;
          New(pWStr);
          sPtrList.Add(pWStr);
          pWStr^ := WideString(v[i]);
          ar[i].VWideString := PWideString(pWStr^);
{$ELSE}
          ar[i].VType := vtAnsiString;
          //New(ar[i].VAnsiString);
          New(pAStr);
          sPtrList.Add(pAStr);
          pAStr^ := AnsiString(v[i]);
          ar[i].VAnsiString := PAnsiString(pAStr^);
{$ENDIF}
{$ENDIF}
        end;
{$IFDEF Delphi12}
      varUString:
        begin
          ar[i].VType := vtUnicodeString;
          New(ar[i].VUnicodeString);
          PUnicodeString(ar[i].VUnicodeString)^ := v[i];
        end;
{$ENDIF}
      varVariant:
        begin
          ar[i].VType := vtVariant;
          New(ar[i].VVariant);
          ar[i].VVariant^ := v[i];
        end;
    end;
end;

procedure ClearVarRec(var ar: TVarRecArray; var sPtrList: TList);
var
  i: Integer;
begin
  for i := 0 to Length(ar) - 1 do
    if ar[i].VType in [vtExtended, vtString, vtVariant {$IFDEF Delphi6}, vtInt64 {$ENDIF}] then
      Dispose(ar[i].VExtended)
{$IFDEF Delphi12}
    else if ar[i].VType in [vtWideString] then
      WideString(ar[i].VWideString) := ''
{$ENDIF}
    else if ar[i].VType in [vtAnsiString] then
      AnsiString(ar[i].VAnsiString) := '';
  for i := 0 to sPtrList.Count - 1 do
    Dispose(sPtrList[i]);
  sPtrList.Free;
  Finalize(ar);
end;

function ParserStringToVariant(s: String): Variant;
var
  i: Int64;
  k: Integer;
  iPos: Integer;
begin
  Result := Null;
  if s <> '' then
    if s[1] = '''' then
      Result := Copy(s, 2, Length(s) - 2)
    else
    begin
      Val(s, i, k);
      if k = 0 then
{$IFDEF Delphi6}
        if i > MaxInt then
          Result := i
        else
          Result := Integer(i)
{$ELSE}
        Result := Integer(i)
{$ENDIF}
      else
      begin
{$IFDEF FMX}
        if FormatSettings.DecimalSeparator <> '.' then
{$ELSE}
{$IFDEF DELPHI16}
        if FormatSettings.DecimalSeparator <> '.' then
{$ELSE}
        if DecimalSeparator <> '.' then
{$ENDIF}
{$ENDIF}
        begin
          iPos := Pos('.', s);
          if iPos > 0 then
            s[iPos] := {$IFDEF DELPHI16}FormatSettings.{$ENDIF}DecimalSeparator;
        end;
        Result := StrToFloat(s);
      end;
    end;
end;

function ParseMethodSyntax(const Syntax: String; Script: TfsScript): TfsCustomVariable;
var
  Parser: TfsParser;
  i, j: Integer;
  Name, Params, TypeName, s: String;
  isFunc, isMacro, varParam: Boolean;
  InitValue: Variant;
  IsParamWithDef: Boolean;
  v: TfsCustomVariable;

  procedure AddParams;
  var
    i: Integer;
    p: TfsParamItem;
    sl: TStringList;
  begin
    sl := TStringList.Create;
    try
      Delete(Params, Length(Params), 1);
      sl.CommaText := Params;
      for i := 0 to sl.Count - 2 do
      begin
        p := TfsParamItem.Create(sl[i], StrToVarType(TypeName, Script), TypeName,
          False, varParam);
        Result.Add(p);
      end;
      p := TfsParamItem.Create(sl[sl.Count - 1], StrToVarType(TypeName, Script), TypeName,
        IsParamWithDef, varParam);
      p.DefValue := InitValue;
      Result.Add(p);

    finally
      sl.Free;
    end;
  end;

begin
  Parser := TfsParser.Create;
  if Script.ExtendedCharset then
    for i := 128 to 255 do
      Parser.IdentifierCharset := Parser.IdentifierCharset + [Chr(i)];
  Parser.Text := Syntax;

  s := Parser.GetIdent;
  isMacro := Pos('macro', AnsiLowercase(s)) = 1;
  if isMacro then
    s := Copy(s, 6, 255);
  isFunc := CompareText(s, 'function') = 0;
  Name := Parser.GetIdent;

  if isFunc then
  begin
    j := Length(Syntax);
    while (Syntax[j] <> ':') and (j <> 0) do
      Dec(j);

    i := Parser.Position;
    Parser.Position := j + 1;
    TypeName := Parser.GetIdent;
    Parser.Position := i;
  end
  else
    TypeName := '';

  Result := TfsCustomVariable.Create(Name, StrToVarType(TypeName, Script), TypeName);
  Result.IsMacro := IsMacro;

  Parser.SkipSpaces;
  s := Parser.GetChar;
  if s = '(' then
  begin
    repeat
      varParam := False;
      Params := '';

      repeat
        s := Parser.GetIdent;
        if CompareText(s, 'var') = 0 then
          varParam := True
        else if CompareText(s, 'const') = 0 then // do nothing
        else
          Params := Params + s + ',';
        Parser.SkipSpaces;
        s := Parser.GetChar;
        if s = ':' then
        begin
          TypeName := Parser.GetIdent;
          Parser.SkipSpaces;
          i := Parser.Position;
          IsParamWithDef:=False;
          if Parser.GetChar = '=' then
          begin
            IsParamWithDef:=True;
            s := Parser.GetNumber;
            if s = '' then
              s := Parser.GetString;
            if s = '' then
            begin
              i := Parser.Position;
              s := Parser.GetChar;
              if s = '-' then
                s := '-' + Parser.GetNumber else
                Parser.Position := i;
            end;

            if s <> '' then
              InitValue := ParserStringToVariant(s)
            else
            begin
              s := Parser.GetIdent;  { it's constant }
              v := Script.Find(s);
              if v <> nil then
                InitValue := v.Value else
                InitValue := Null;
            end
          end
          else
          begin
            InitValue := Null;
            Parser.Position := i;
          end;
          AddParams;
          s := ';';
        end
        else if s = ')' then
        begin
          Parser.Position := Parser.Position - 1;
          break;
        end;
      until s = ';';

      Parser.SkipSpaces;
    until Parser.GetChar = ')';
  end;

  Parser.Free;
end;

function fsPosToPoint(const ErrorPos: String): TPoint;
begin
  Result.X := 0;
  Result.Y := 0;
  if ErrorPos <> '' then
  begin
    Result.Y := StrToInt(Copy(ErrorPos, 1, Pos(':', ErrorPos) - 1));
    Result.X := StrToInt(Copy(ErrorPos, Pos(':', ErrorPos) + 1, 255));
  end;
end;

procedure GenerateXMLContents(Prog: TfsScript; Item: TfsXMLItem;
  FunctionsOnly: Boolean = False);
var
  i, j: Integer;
  v: TfsCustomVariable;
  c: TfsClassVariable;
  xi: TfsXMLItem;
  clItem: TfsCustomHelper;
  s: String;
begin
  Item.FindItem('Functions');
  Item.FindItem('Classes');
  Item.FindItem('Types');
  Item.FindItem('Variables');
  Item.FindItem('Constants');

  for i := 0 to Prog.Count - 1 do
  begin
    v := Prog.Items[i];
    if not (v is TfsMethodHelper) and FunctionsOnly then
      continue;
    if v is TfsMethodHelper then
    begin
      xi := Item.FindItem('Functions');
      xi := xi.FindItem(TfsMethodHelper(v).Category);
      xi.Text := 'text="' + xi.Name + '"';
      with xi.Add do
      begin
        Name := 'item';
        s := TfsMethodHelper(v).Syntax;
        Text := 'text="' + s + '" description="' +
          TfsMethodHelper(v).Description + '"';
      end;
    end
    else if v is TfsClassVariable then
    begin
      c := TfsClassVariable(v);
      xi := Item.FindItem('Classes');
      xi := xi.Add;
      with xi do
      begin
        Name := 'item';
        Text := 'text="' + c.Name + ' = class(' + c.Ancestor + ')"';
      end;

      for j := 0 to c.MembersCount - 1 do
      begin
        clItem := c.Members[j];
        with xi.Add do
        begin
          Name := 'item';
          Text := 'text="';
          if clItem is TfsPropertyHelper then
            Text := Text + 'property ' + clItem.Name + ': ' + clItem.GetFullTypeName + '"'
          else if clItem is TfsMethodHelper then
          begin
            s := TfsMethodHelper(clItem).Syntax;
            if TfsMethodHelper(clItem).IndexMethod then
      s := 'index property' + Copy(s, Pos(' ', s), 255);
            Text := Text + s + '"';
          end
          else
            Text := Text + 'event ' + clItem.Name + '"';
        end;
      end;
    end
    else if v is TfsVariable then
    begin
      if v.Typ = fvtEnum then
      begin
        xi := Item.FindItem('Types');
        with xi.FindItem(v.TypeName) do
        begin
          if v.Name <> v.TypeName then
            if Text = '' then
              Text := v.Name else
              Text := Text + ',' + v.Name;
        end;
      end
      else
      begin
        if v.IsReadOnly then
          xi := Item.FindItem('Constants') else
          xi := Item.FindItem('Variables');
        with xi.Add do
        begin
          Name := 'item';
          Text := 'text="' + v.Name + ': ' + v.GetFullTypeName;
          if v.IsReadOnly then
            Text := Text + ' = ' + VarToStr(v.Value);
          Text := Text + '"';
        end;
      end;
    end;
  end;

  xi := Item.FindItem('types');
  for i := 0 to xi.Count - 1 do
    if xi[i].Name <> 'item' then
    begin
      xi[i].Text := 'text="' + xi[i].Name + ': (' + xi[i].Text + ')"';
      xi[i].Name := 'item';
    end;
end;

procedure GenerateMembers(Prog: TfsScript; cl: TClass; Item: TfsXMLItem);
var
  i, j: Integer;
  v: TfsCustomVariable;
  c: TfsClassVariable;
  xi: TfsXMLItem;
  clItem: TfsCustomHelper;
  s: String;
begin
  for i := 0 to Prog.Count - 1 do
  begin
    v := Prog.Items[i];
    if v is TfsClassVariable then
    begin
      c := TfsClassVariable(v);
      if cl.InheritsFrom(c.ClassRef) then
      begin
        xi := Item;
        for j := 0 to c.MembersCount - 1 do
        begin
          clItem := c.Members[j];
          with xi.Add do
          begin
            Name := 'item';
            Text := 'text="';
            if clItem is TfsPropertyHelper then
              Text := Text + 'property ' + clItem.Name + ': ' + clItem.GetFullTypeName + '"'
            else if clItem is TfsMethodHelper then
            begin
              s := TfsMethodHelper(clItem).Syntax;
              if TfsMethodHelper(clItem).IndexMethod then
                s := 'index property' + Copy(s, Pos(' ', s), 255);
              Text := Text + s + '"';
            end
            else
              Text := Text + 'event ' + clItem.Name + '"';
          end;
        end;
      end;
    end;
  end;
end;

{$IFNDEF Delphi4}
function fsSetToString(PropInfo: PPropInfo; const Value: Variant): string;
var
  S: TIntegerSet;
  TypeInfo: PTypeInfo;
  I: Integer;
begin
  Result := '';
{$IFNDEF FPC}
  TypeInfo := GetTypeData(PropInfo^.PropType^)^.CompType^;
{$ELSE}
  TypeInfo := GetTypeData(PropInfo^.PropType)^.CompType;
{$ENDIF}

  Integer(S) := 0;
  if VarIsArray(Value) then
    for I := 0 to VarArrayHighBound(Value, 1) do
      begin
        Integer(S) := Integer(S) or Value[I];
      end;

  for I := 0 to SizeOf(Integer) * 8 - 1 do
    if I in S then
    begin
      if Result <> '' then
        Result := Result + ',';
      Result := Result + GetEnumName(TypeInfo, I);
    end;
  Result := '[' + Result + ']';
end;
{$ENDIF}

initialization
  Languages := TStringList.Create;

finalization
  Languages.Free;

end.