fs_iinterpreter.pas

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

end;

function TfsCustomVariable.GetValue: Variant;
begin
  Result := FValue;
end;

procedure TfsCustomVariable.SetValue(const Value: Variant);
begin
  if not FIsReadOnly then
    FValue := Value;
end;

function TfsCustomVariable.GetParam(Index: Integer): TfsParamItem;
begin
  Result := FItems[Index];
end;

function TfsCustomVariable.GetPValue: PVariant;
begin
  Result := @FValue;
end;

function TfsCustomVariable.GetFullTypeName: String;
begin
  case FTyp of
    fvtInt: Result := 'Integer';
    fvtBool: Result := 'Boolean';
    fvtFloat: Result := 'Extended';
    fvtChar: Result := 'Char';
    fvtString: Result := 'String';
    fvtClass: Result := FTypeName;
    fvtArray: Result := 'Array';
    fvtEnum: Result := FTypeName;
  else
    Result := 'Variant';
  end;
end;

function TfsCustomVariable.GetNumberOfRequiredParams: Integer;
var
  i: Integer;
begin
  Result := 0;
  for i := 0 to Count - 1 do
    if not Params[i].IsOptional then
      Inc(Result);
end;


{ TfsStringVariable }

function TfsStringVariable.GetValue: Variant;
begin
  Result := FStr;
  if Assigned(FOnGetVarValue) then
  begin
    Result := FOnGetVarValue(FName, FTyp, FStr);
    if Result = null then Result := FStr;
  end;
end;

procedure TfsStringVariable.SetValue(const Value: Variant);
begin
  FStr := Value;
end;


{ TfsParamItem }

constructor TfsParamItem.Create(const AName: String; ATyp: TfsVarType;
  const ATypeName: String; AIsOptional, AIsVarParam: Boolean);
begin
  inherited Create(AName, ATyp, ATypeName);
  FIsOptional := AIsOptional;
  FIsVarParam := AIsVarParam;
  FDefValue := Null;
end;


{ TfsProcVariable }

constructor TfsProcVariable.Create(const AName: String; ATyp: TfsVarType;
  const ATypeName: String; AParent: TfsScript; AIsFunc: Boolean = True);
begin
  inherited Create(AName, ATyp, ATypeName);
  FIsReadOnly := True;
  FIsFunc := AIsFunc;
  FProgram := TfsScript.Create(nil);
  FProgram.Parent := AParent;
  if FIsFunc then
  begin
    FRefItem := TfsVariable.Create('Result', ATyp, ATypeName);
    FProgram.Add('Result', FRefItem);
  end;
end;



destructor TfsProcVariable.Destroy;
var
  i: Integer;
begin
  { avoid destroying the param objects twice }
  for i := 0 to Count - 1 do
    FProgram.FItems.Delete(FProgram.FItems.IndexOfObject(Params[i]));

  FProgram.Free;
  inherited;
end;

function TfsProcVariable.GetValue: Variant;
var
  Temp: Boolean;
  ParentProg, SaveProg: TfsScript;
begin
  Temp := FExecuting;
  FExecuting := True;
  if FIsFunc then
    FRefItem.Value := Unassigned;

  ParentProg := FProgram;
  SaveProg := nil;
  while ParentProg <> nil do
    if ParentProg.FMainProg then
    begin
      SaveProg := ParentProg.FProgRunning;
      ParentProg.FProgRunning := FProgram;
      break;
    end
    else
      ParentProg := ParentProg.FParent;

  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{$IFDEF Delphi12}, tkUString{$ENDIF}:
//          Result := GetStrProp(Instance, p);

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

        tkVariant:
          Result := GetVariantProp(Instance, p);
{$IFDEF Delphi12}
        tkString, tkLString:
          Result := GetAnsiStrProp(Instance, p);
        tkWString, tkUString:
          Result := GetUnicodeStrProp(Instance, p);
{$ELSE}
        tkString, tkLString, tkWString:
          Result := GetStrProp(Instance, p);
{$ENDIF}
      end;
  end
  else if Assigned(FOnGetValue) then
    Result := FOnGetValue(Instance, FClassRef, FUppercaseName)
  else if Assigned(FOnGetValueNew) then
    Result := FOnGetValueNew(Instance, FClassRef, FUppercaseName, Self);

  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
{$IFNDEF Delphi4}
          if VarType(Value) <> varInteger then
          begin
            SetSetProp(Instance, p, fsSetToString(p, Value));
          end
          else
{$ENDIF}
          begin
            if Typ = fvtBool then
              if Value = True then
                IntVal := 1 else
                IntVal := 0
            else
              IntVal := Integer(Value);
            SetOrdProp(Instance, p, IntVal);
          end;
        end;

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

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

//        tkWString{$IFDEF Delphi12}, tkUString{$ENDIF}:
//          SetStrProp(Instance, p, WideString(Value));

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

        tkVariant:
          SetVariantProp(Instance, p, Value);

{$IFDEF Delphi12}
        tkString, tkLString:
          SetAnsiStrProp(Instance, p, AnsiString(Value));
        tkWString, tkUString:
          SetUnicodeStrProp(Instance, p, WideString(Value));
{$ELSE}
        tkString, tkLString, tkWString:
          SetStrProp(Instance, p, String(Value));
{$ENDIF}
      end;
  end
  else if Assigned(FOnSetValue) then
    FOnSetValue(Instance, FClassRef, FUppercaseName, Value)
  else if Assigned(FOnSetValueNew) then
    FOnSetValueNew(Instance, FClassRef, FUppercaseName, Value, Self);

end;


{ TfsMethodHelper }

constructor TfsMethodHelper.Create(const Syntax: String; Script: TfsScript);
var
  i: Integer;
  v: TfsCustomVariable;
begin
  v := ParseMethodSyntax(Syntax, Script);
  inherited Create(v.Name, v.Typ, v.TypeName);
  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;

  // FPC and Delphi do this different way. FPC implementation more honest, so
  // if Count = 0 then we get exception about bad bounds
  if Count > 0 then
    FVarArray := VarArrayCreate([0, Count - 1], varVariant);
end;

destructor TfsMethodHelper.Destroy;
begin
  FVarArray := Null;
  inherited;
end;

function TfsMethodHelper.GetVParam(Index: Integer): Variant;
begin
  if Index = Count then
    Result := FSetValue
  else
    Result := TfsParamItem(FItems[Index]).Value;
end;

procedure TfsMethodHelper.SetVParam(Index: Integer; const Value: Variant);
begin
  TfsParamItem(FItems[Index]).Value := Value;
end;

function TfsMethodHelper.GetValue: Variant;
var
  i: Integer;
  Instance: TObject;
begin
  if Assigned(FOnCall) then
  begin
    for i := 0 to Count - 1 do
      FVarArray[i] := inherited Params[i].Value;

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

    if FIndexMethod then
      Result := FOnCall(Instance, FClassRef, FUppercaseName + '.GET', FVarArray)
    else
      Result := FOnCall(Instance, FClassRef, FUppercaseName, FVarArray);
    for i := 0 to Count - 1 do
      if inherited Params[i].IsVarParam then
        inherited Params[i].Value := FVarArray[i];
  end
  else if Assigned(FOnCallNew) then
  begin
    Instance := nil;
    if not VarIsNull(ParentValue) then
      Instance := TObject(Integer(ParentValue));

    if FIndexMethod then
      Result := FOnCallNew(Instance, FClassRef, FUppercaseName + '.GET', Self)
    else
      Result := FOnCallNew(Instance, FClassRef, FUppercaseName, Self);
  end
  else
    Result := 0;
end;

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

      FOnCall(TObject(Integer(ParentValue)), FClassRef, FUppercaseName + '.SET', v);
      v := Null;
    end
    else if Assigned(FOnCallNew) then
    begin
      FSetValue := Value;
      FOnCallNew(TObject(Integer(ParentValue)), FClassRef, FUppercaseName + '.SET', Self);
      FSetValue := 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));
    FProgram.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));