fs_itools.pas

这个是功能强大的报表软件

        InitValue <> Null, varParam);
      p.DefValue := InitValue;
      Result.Add(p);

    finally
      sl.Free;
    end;
  end;

begin
  Parser := TfsParser.Create;
  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] <> ':' 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;
          if Parser.GetChar = '=' then
          begin
            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.