fs_iinterpreter.pas

报表源码 FastReport 3 is new generation of the report generators components. It consists of report engin

  try
// avoid trial message
// same as FProgram.Execute
    with FProgram do
    begin
      FExitCalled := False;
      FTerminated := False;
      FIsRunning := True;
      try
        FStatement.Execute;
      finally
        FExitCalled := False;
        FTerminated := False;
        FIsRunning := False;
      end;
    end;
//

    if FIsFunc then
      Result := FRefItem.Value else
      Result := Null;
  finally
    if ParentProg <> nil then
      ParentProg.FProgRunning := SaveProg;
    FExecuting := Temp;
  end;
end;


{ TfsPropertyHelper }

function TfsPropertyHelper.GetValue: Variant;
var
  p: PPropInfo;
  Instance: TObject;
begin
  Result := Null;
  Instance := TObject(Integer(ParentValue));

  if FIsPublished and Assigned(Instance) then
  begin
    p := GetPropInfo(Instance.ClassInfo, Name);
    if p <> nil then
      case p.PropType^.Kind of
        tkInteger, tkSet, tkEnumeration, tkClass:
          Result := GetOrdProp(Instance, p);

        tkFloat:
          Result := GetFloatProp(Instance, p);

        tkString, tkLString, tkWString:
          Result := GetStrProp(Instance, p);

        tkChar, tkWChar:
          Result := Chr(GetOrdProp(Instance, p));

        tkVariant:
          Result := GetVariantProp(Instance, p);
      end;
  end
  else if Assigned(FOnGetValue) then
    Result := FOnGetValue(Instance, FClassRef, AnsiUpperCase(Name));

  if Typ = fvtBool then
    if Result = 0 then
      Result := False else
      Result := True;
end;

procedure TfsPropertyHelper.SetValue(const Value: Variant);
var
  p: PPropInfo;
  Instance: TObject;
  IntVal: Integer;
begin
  if IsReadOnly then Exit;
  Instance := TObject(Integer(ParentValue));

  if FIsPublished then
  begin
    p := GetPropInfo(Instance.ClassInfo, Name);
    if p <> nil then
      case p.PropType^.Kind of
        tkInteger, tkSet, tkEnumeration, tkClass:
        begin
          if Typ = fvtBool then
            if Value = True then
              IntVal := 1 else
              IntVal := 0
          else
            IntVal := Integer(Value);
          SetOrdProp(Instance, p, IntVal);
        end;

        tkFloat:
          SetFloatProp(Instance, p, Extended(Value));

        tkString, tkLString, tkWString:
          SetStrProp(Instance, p, String(Value));

        tkChar, tkWChar:
          SetOrdProp(Instance, p, Ord(String(Value)[1]));

        tkVariant:
          SetVariantProp(Instance, p, Value);
      end;
  end
  else if Assigned(FOnSetValue) then
    FOnSetValue(Instance, FClassRef, AnsiUpperCase(Name), Value);
end;


{ TfsMethodHelper }

constructor TfsMethodHelper.Create(const Syntax: String;
  CallEvent: TfsCallMethodEvent; Script: TfsScript);
var
  i: Integer;
  v: TfsCustomVariable;
begin
  v := ParseMethodSyntax(Syntax, Script);
  inherited Create(v.Name, v.Typ, v.TypeName);
  FOnCall := CallEvent;
  FIsReadOnly := True;
  FSyntax := Syntax;
  IsMacro := v.IsMacro;

  { copying params }
  for i := 0 to v.Count - 1 do
    Add(v.Params[i]);
  while v.Count > 0 do
    v.FItems.Delete(0);
  v.Free;
end;

function TfsMethodHelper.GetValue: Variant;
var
  v: Variant;
  i: Integer;
  s: String;
  Instance: TObject;
begin
  if Assigned(FOnCall) then
  begin
    v := VarArrayCreate([0, Count - 1], varVariant);
    for i := 0 to Count - 1 do
      v[i] := Params[i].Value;

    s := Name;
    if FIndexMethod then
      s := s + '.Get';

    Instance := nil;
    if not VarIsNull(ParentValue) then
      Instance := TObject(Integer(ParentValue));

    Result := FOnCall(Instance, FClassRef, AnsiUpperCase(s), v);
    for i := 0 to Count - 1 do
      if Params[i].IsVarParam then
        Params[i].Value := v[i];
    v := Null;
  end
  else
    Result := 0;
end;

procedure TfsMethodHelper.SetValue(const Value: Variant);
var
  v: Variant;
  i: Integer;
begin
  if Assigned(FOnCall) and FIndexMethod then
  begin
    v := VarArrayCreate([0, Count], varVariant);
    for i := 0 to Count - 1 do
      v[i] := Params[i].Value;
    v[Count] := Value;

    FOnCall(TObject(Integer(ParentValue)), FClassRef, AnsiUpperCase(Name + '.Set'), v);
    v := Null;
  end;
end;


{ TfsComponentHelper }

constructor TfsComponentHelper.Create(Component: TComponent);
begin
  inherited Create(Component.Name, fvtClass, Component.ClassName);
  FComponent := Component;
end;

function TfsComponentHelper.GetValue: Variant;
begin
  Result := Integer(FComponent);
end;


{ TfsEventHelper }

constructor TfsEventHelper.Create(const Name: String; AEvent: TfsEventClass);
begin
  inherited Create(Name, fvtString, '');
  FEvent := AEvent;
end;

function TfsEventHelper.GetValue: Variant;
begin
  Result := '';
end;

procedure TfsEventHelper.SetValue(const Value: Variant);
var
  Instance: TPersistent;
  v: TfsCustomVariable;
  e: TfsCustomEvent;
  p: PPropInfo;
  m: TMethod;
begin
  Instance := TPersistent(Integer(ParentValue));
  if VarToStr(Value) = '0' then
  begin
    m.Code := nil;
    m.Data := nil;
  end
  else
  begin
    v := FProgram.Find(Value);
    if (v = nil) or not (v is TfsProcVariable) then
      raise Exception.Create(SEventError);

    e := TfsCustomEvent(FEvent.NewInstance);
    e.Create(Instance, TfsProcVariable(v));
    fsEventList.Add(e);
    m.Code := e.GetMethod;
    m.Data := e;
  end;

  p := GetPropInfo(Instance.ClassInfo, Name);
  SetMethodProp(Instance, p, m);
end;


{ TfsClassVariable }

constructor TfsClassVariable.Create(AClass: TClass; const Ancestor: String);
begin
  inherited Create(AClass.ClassName, fvtClass, AClass.ClassName);
  FMembers := TfsItemList.Create;
  FAncestor := Ancestor;
  FClassRef := AClass;

  AddPublishedProperties(AClass);
  Add(TfsParamItem.Create('', fvtVariant, '', True, False));
end;

destructor TfsClassVariable.Destroy;
begin
  FMembers.Free;
  inherited;
end;

function TfsClassVariable.GetMembers(Index: Integer): TfsCustomHelper;
begin
  Result := FMembers.FItems[Index];
end;

function TfsClassVariable.GetMembersCount: Integer;
begin
  Result := FMembers.Count;
end;

procedure TfsClassVariable.AddConstructor(Syntax: String; CallEvent: TfsCallMethodEvent);
var
  i: Integer;
begin
  i := Pos(' ', Syntax);
  Delete(Syntax, 1, i - 1);
  Syntax := 'function' + Syntax + ': ' + 'Constructor';
  AddMethod(Syntax, CallEvent);
end;

procedure TfsClassVariable.AddMethod(const Syntax: String; CallEvent: TfsCallMethodEvent);
var
  m: TfsMethodHelper;
begin
  m := TfsMethodHelper.Create(Syntax, CallEvent, FProgram);
  m.FClassRef := FClassRef;
  FMembers.Add(m);
end;

procedure TfsClassVariable.AddEvent(const Name: String; AEvent: TfsEventClass);
var
  e: TfsEventHelper;
begin
  e := TfsEventHelper.Create(Name, AEvent);
  e.FClassRef := FClassRef;
  FMembers.Add(e);
end;

procedure TfsClassVariable.AddProperty(const Name, Typ: String;
  GetEvent: TfsGetValueEvent; SetEvent: TfsSetValueEvent);
var
  p: TfsPropertyHelper;
begin
  p := TfsPropertyHelper.Create(Name, StrToVarType(Typ, FProgram), Typ);
  p.FClassRef := FClassRef;
  p.FOnGetValue := GetEvent;
  p.FOnSetValue := SetEvent;
  p.IsReadOnly := not Assigned(SetEvent);
  FMembers.Add(p);
end;

procedure TfsClassVariable.AddDefaultProperty(const Name, Params, Typ: String;
  CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False);
begin
  AddIndexProperty(Name, Params, Typ, CallEvent, AReadOnly);
  FDefProperty := Members[FMembers.Count - 1];
end;

procedure TfsClassVariable.AddIndexProperty(const Name, Params,
  Typ: String; CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False);
var
  i: Integer;
  sl: TStringList;
  s: String;
begin
  sl := TStringList.Create;
  sl.CommaText := Params;

  s := '';
  for i := 0 to sl.Count - 1 do
    s := s + 'p' + IntToStr(i) + ': ' + sl[i] + '; ';

  SetLength(s, Length(s) - 2);
  try
    AddMethod('function ' + Name + '(' + s + '): ' + Typ, CallEvent);
    with TfsMethodHelper(Members[FMembers.Count - 1]) do
    begin
      IsReadOnly := AReadOnly;
      FIndexMethod := True;
    end;
  finally
    sl.Free;
  end;
end;

procedure TfsClassVariable.AddComponent(c: TComponent);
begin
  FMembers.Add(TfsComponentHelper.Create(c));
end;

procedure TfsClassVariable.AddPublishedProperties(AClass: TClass);
var
  TypeInfo: PTypeInfo;
  PropCount: Integer;
  PropList: PPropList;
  i: Integer;
  cl: String;
  t: TfsVarType;
  FClass: TClass;
  p: TfsPropertyHelper;
begin
  TypeInfo := AClass.ClassInfo;
  if TypeInfo = nil then Exit;

  PropCount := GetPropList(TypeInfo, tkProperties, nil);
  GetMem(PropList, PropCount * SizeOf(PPropInfo));
  GetPropList(TypeInfo, tkProperties, PropList);

  try
    for i := 0 to PropCount - 1 do
    begin
      t := fvtInt;
      cl := '';

      case PropList[i].PropType^.Kind of
        tkInteger:
          t := fvtInt;
        tkSet:
          begin
            t := fvtEnum;
            cl := PropList[i].PropType^.Name;
          end;
        tkEnumeration:
          begin
            t := fvtEnum;
            cl := PropList[i].PropType^.Name;
            if CompareText(cl, 'Boolean') = 0 then
              t := fvtBool;
          end;
        tkFloat:
          t := fvtFloat;
        tkChar, tkWChar:
          t := fvtChar;
        tkString, tkLString, tkWString:
          t := fvtString;
        tkVariant:
          t := fvtVariant;
        tkClass:
          begin
            t := fvtClass;
            FClass := GetTypeData(PropList[i].PropType^).ClassType;
            cl := FClass.ClassName;
          end;
      end;

      p := TfsPropertyHelper.Create(PropList[i].Name, t, cl);
      p.FClassRef := FClassRef;
      p.FIsPublished := True;
      FMembers.Add(p);
    end;

  finally
    FreeMem(PropList, PropCount * SizeOf(PPropInfo));
  end;
end;

function TfsClassVariable.Find(const Name: String): TfsCustomHelper;
var
  cl: TfsClassVariable;

  function DoFind(const Name: String): TfsCustomHelper;
  var
    i: Integer;
  begin
    Result := nil;
    for i := 0 to FMembers.Count - 1 do
      if CompareText(Name, Members[i].Name) = 0 then
      begin
        Result := Members[i];
        Exit;
      end;
  end;

begin
  Result := DoFind(Name);
  if Result = nil then
  begin
    cl := FProgram.FindClass(FAncestor);
    if cl <> nil then
      Result := cl.Find(Name);
  end;
end;

function TfsClassVariable.GetValue: Variant;
begin
  if Params[0].Value = Null then
    Result := Integer(FClassRef.NewInstance) else        { constructor call }
    Result := Params[0].Value;                           { typecast }
  Params[0].Value := Null;
end;


{ TfsDesignatorItem }

function TfsDesignatorItem.GetItem(Index: Integer): TfsCustomExpression;
begin
  Result := FItems[Index];
end;


{ TfsDesignator }

constructor TfsDesignator.Create(AProgram: TfsScript);
var
  ParentProg: TfsScript;
begin
  inherited Create('', fvtInt, '');
  FProgram := AProgram;
  FMainProg := FProgram;
  ParentProg := FProgram;
  while ParentProg <> nil do
    if ParentProg.FMainProg then
    begin
      FMainProg := ParentProg;
      break;
    end
    else
      ParentProg := ParentProg.FParent;
end;

procedure TfsDesignator.Borrow(ADesignator: TfsDesignator);
var
  SaveItems: TList;
begin
  SaveItems := FItems;
  FItems := ADesignator.FItems;
  ADesignator.FItems := SaveItems;
  FKind := ADesignator.FKind;