hwexprext.pas

用于Delphi程序中嵌入公式解析

            procedure Clear; override;
            { 返回实际可操作的IValue }
            function GetIValue(Obj: IValue; const aName: string;
                               aParams: TParameterList): IValue;
            { 下面属性用于取得注册的成员信息，主要用于显示给用户 }
            property Items[Index: Cardinal]: PMemberInfo read GetItem;
            property ItemsName;
            property Member[const AName: string]: PMemberInfo read GetMember;
            property OwnerClassName: string read GetClassName;
            property OwnerClass: TClass Read FOwnerClassType;
            property Syntax[const AMemberName: string]: string read GetMemberSyntax;
        Published
            property Count;
        end;

        { ---------------------------------------------------------------------
          Class : TClassContext
          注册类Context。在本表中存储有需要在表达式中访问的类及其相关属性
          -------------------------------------------------------------------- }
        TClassContext = class(TExprContext)
        Private
            function GetItem(Index: Cardinal): TClassMemberContext;
            function GetMemberContext(const AClassName: string): TClassMemberContext;
        Public
            constructor Create(AOwner: TAbstractContextSet);
            destructor Destroy; override;
            function Add(const AClassType: TClass): TClassMemberContext;
            { DONE -oCharmer -c表达式解析与运算 : 用什么方式使用类型信息比较好 ？ }
            function ValidMember(const AClassName, AMemberName: String): Boolean;
            procedure Clear; override;
            procedure Delete(Index: Cardinal); overload; override;
            procedure Delete(const AName: string); overload; override;
            function IDF(obj: IValue; const Identifier: string;
                     ParameterList: TParameterList): IValue;
            property Items[Index: Cardinal]: TClassMemberContext read GetItem;
            property ItemsName;
            property MemberContext[const AClassName: string]: TClassMemberContext
                     read GetMemberContext;
        Published
            property Count;
        end;
        { ---------------------------------------------------------------------
          Class : TObjectContext
          对象Context。用于表达式通过对象名称标识符访问对象
          -------------------------------------------------------------------- }
        TObjectContext = class(TExprContext)
        Private
            function GetItem(Index: Cardinal): TObject;
        Public
            constructor Create(AOwner: TExprContextSet);
            destructor Destroy; override;
            procedure Add(const AName: String; Obj: TObject);
            procedure Delete(Index: Cardinal); overload; override;
            procedure Delete(const AName: string); overload; override;
            function GetObject(const AName: string): IValue;
            property Items[Index: Cardinal]: TObject read GetItem;
            property ItemsName;
        Published
            property Count;
        end;
        { ---------------------------------------------------------------------
          Class :
          扩展公式上下文表
          -------------------------------------------------------------------- }
        TExtFuncContext = class(TExprContext)
        Private
            { 由于IValue的TestParameters方法仅返回True/False，因此在请求函数
              时先检查一下参数，以便于提供更多的出错信息 }
            function CheckParams(ADeclare: TExtFunctionDeclare;
                                 APassParams: TParameterList): Boolean;
        Protected
            //procedure SaveToStream(AStream: TrptStream);
            //procedure LoadFromStream(AStream: TrptStream);
            procedure Delete(Index: Cardinal); overload; override;
            procedure Delete(const AName: string); overload; override;
        Public
            constructor Create(AOwner: TAbstractContextSet);
            destructor  Destroy; override;
            procedure AddFunc(const AFuncName: string;
                              const AResultType: TExprType;
                              ParamList: Array of TExprType;
                              ExtFunc: TExtFuncImplementation;
                              const ADescription: string);overload;
            procedure AddFunc(const AFuncName: string;
                              const ParamNames: array of string;
                              const ParamTypes: array of TExprType;
                              const AResultType: TExprType;
                              ExtFunc: TExtFuncImplementation;
                              const ADescription: String); overload;
            procedure Clear; override;
            function GetFunc(const AName: string; APassParams: TParameterList): TFunction;
            function GetFuncDeclare(const AName: string): TExtFunctionDeclare; overload;
            function GetFuncDeclare(Index: integer): TExtFunctionDeclare; overload;
        Published
            property Count;
        end;

        { ---------------------------------------------------------------------
          Class : TUserFuncTemplateContext
          用户定义公式模板Context
          -------------------------------------------------------------------- }
        TUserFuncTemplateContext = class(TExprContext)
        Protected
            procedure SaveToStream(AStream: TExprStream);
            procedure LoadFromStream(AStream: TExprStream);
        Public
            constructor Create(AOwner: TAbstractContextSet);
            destructor  Destroy; override;
            function Add(const AFuncName: string;
                         const AResultType: TExprType): TExprTemplate; overload;
            procedure Add(ATemplate: TExprTemplate); overload;
            procedure Delete(const AName: string); overload; override;
            procedure Delete(Index: Cardinal); overload; override;
            procedure Clear; override;
            function GetTemplate(const AName: string): TExprTemplate; overload;
            function GetTemplate(const Index: Cardinal): TExprTemplate; overload;
            property ItemsName;
        Published
            property Count;
        end;

        { 注：最好在UserEvalFunction和UserCompileFunction两者间只选择一个用 }
        { 编译型用户定义公式Context }

        TUserCompileFuncContext = class(TExprContext)
        Public
            constructor Create(AOwner: TAbstractContextSet);
            destructor Destroy; override;
            procedure Add(AFuncTemplate: TExprTemplate);
            procedure Delete(const AName: string); overload; override;
            procedure Delete(Index: Cardinal); Overload; override;
            procedure Clear; override;
            function GetFunc(const AName: string; APassParams: TParameterList): TFunction;
            function GetUCFI(Index: Cardinal): TAbstractExtFunction; overload;
            function GetUCFI(AName: string): TAbstractExtFunction; overload;
        Published
            property Count;
        end;

        { 抽象类，用于用户扩展ContextSet。 }
        TAbstractContextSet = class
        Public
            function Has(const Identifier: string): Boolean; virtual; abstract;
            function ExtIdent(Obj: IValue; const Identifier: String;
                     ParameterList: TParameterList): IValue; virtual; abstract;
        end;

        { 上下文表集合 }
        TExprContextSet = class(TAbstractContextSet)
        private
            FConstants        : TConstantContext;
            FExtFunctions     : TExtFuncContext;
            FExprTemplates    : TUserFuncTemplateContext;
            FCompileFunctions : TUserCompileFuncContext;
            FRegistedClasses  : TClassContext;
            FObjects          : TObjectContext;
            FEnumerations     : TEnumerationContext;
            { 用户定义的ContextSet，用户可以通过指定自定义的上下文表集合扩展
              应用。或者情况反过来，由用户ContextSet包含GlobalContextSet，并
              由用户决定先查询哪些表 }
            FUserContextSet   : TAbstractContextSet;
        Public
            constructor Create;
            destructor Destroy; override;
            function Has(const Identifier: string): Boolean; override;
            { IDF }
            function ExtIdent(Obj: IValue; const Identifier: string;
                     ParameterList: TParameterList): IValue; override;
            procedure SaveToStream(AStream: TExprStream);
            procedure LoadFromStream(AStream: TExprStream);
        Published
            property Constants       : TConstantContext read FConstants;
            property ExtFunctions    : TExtFuncContext read FExtFunctions;
            property ExprTemplates   : TUserFuncTemplateContext read FExprTemplates;
            property CompileFunctions: TUserCompileFuncContext read FCompileFunctions;
            property RegistedClasses : TClassContext read FRegistedClasses;
            property Objects         : TObjectContext read FObjects;
            property Enumerations    : TEnumerationContext read FEnumerations;
            property UserContextSet  : TAbstractContextSet read FUserContextSet write FUserContextSet;
        end;

        { 这个函数没有IdentifierFunciton参数，以GlobalContextset.ExtIdent替代 }
        function CreateExpression2(const S : string): IValue;

        procedure AddExtFunc(const AFuncName: string;
                             const AResultType: TExprType;
                             ParamList: Array of TExprType;
                             ExtFunc: TExtFuncImplementation;
                             const ADescription: string); overload;
        procedure AddExtFunc(const AFuncName: string;
                             const ParamNames: array of string;
                             const ParamTypes: array of TExprType;
                             const AResultType: TExprType;
                             ExtFunc: TExtFuncImplementation;
                             const ADescription: String); overload;
        { 扩展函数示例 }
        function Extfunc_ShowMessage(ParameterList: TParameterList): IValue;

var
        { 全局常量集合 }
        GlobalContextSet: TExprContextSet;
implementation

{ ============================================================================
  >>>>   Class Implementation Begin                                       <<<<
  >>>>   Class Name  : TAbstractExtFunction
  >>>>   Description :
  >>>>   Create Date :
  ---------------------------------------------------------------------------- }
procedure TAbstractExtFunction.SetFuncName(const AName: string);
begin
        FFuncName := AName;
end;

procedure TAbstractExtFunction.SetResultType(const AType: TExprType);
begin
        FResultType := AType;
end;

procedure TAbstractExtFunction.SetAdditionType(const ATypeName: string);
begin
        FAdditionType := TypeName;
end;

function TAbstractExtFunction.GetTypeName: string;
var     pti: PTypeInfo;
begin
        pti := System.TypeInfo(TExprType);
        if not (FResultType in [ttObject, ttEnumerated]) then
        begin
            Result := GetEnumName(pti, Integer(FResultType));
        end
        else
        begin
            if FAdditionType <> '' then
                Result := FAdditionType
            else Result := GetEnumName(pti, Integer(FResultType));
        end;
end;

function TAbstractExtFunction.GetSyntax: String;
var     i : Integer;
        S : string;
begin
        S := FunctionName + '(';
        if Self.ParamsCount > 0 then
        begin
            for i := 0 to ParamsCount -1 do
            begin
                S := S + Self.ParamsName[i]
                   + ': ' + ExprTypeName[Self.ParamsType[i]] + '; ';
            end;
            S := Copy(S, 1, Length(S) -2);
        end;
        S := S + '): ' + ExprTypeName[ResultType];
        Result := S;
end;

procedure TAbstractExtFunction.SaveToStream(AStream: TExprStream);
begin
        AStream.SaveString(FunctionName);
        AStream.SaveInteger(Integer(Self.ResultType));
        AStream.SaveString(Description);
end;

procedure TAbstractExtFunction.LoadFromStream(AStream: TExprStream);
begin
        SetFuncName(AStream.LoadString);
        SetResultType(TExprType(AStream.LoadInteger));
        FDescription := AStream.LoadString;
end;
{ Charmer Ext }
{ ============================================================================ }
{ 用户自定义函数部分：由表达式构成的函数。
  这部分内容包含如下类：
        TExprTemplate          ----> 自定义函数模板
        TUserEvalFunction      ----> 解释型函数，即时编译
        TUserCompileFunction   ----> 预编译型函数算子
        TUCFImplementation     ----> 预编译函数执行体
  ============================================================================ }
type
        TParamRec = record
            ParamName: string;
            ParamType: TExprType;
        end;

        PParamRec = ^TParamRec;
        { ******************************************************* }
        { User evaluate function }
        { 用户定义的公式算子。本对象只有在请求时才被Context根据相关模
          板创建，类似于解释型运行方式。参见另一类用户定义函数
          User compile function }
        TUserEvalFunction = class(TExpression)
        Private
            FPrivateParams: TParameterList; //本公式私有参数
            FTemplate: TExprTemplate; //公式模板
            FValue: IValue;
            function IDF(Obj: IValue; const Identifier: string;
                ParameterList: TParameterList): IValue;
        Public
            constructor Create(const ATemplate: TExprTemplate; ParameterList: TParameterList);
            destructor Destroy; override;
            function AsBoolean : boolean; override;
            function AsFloat   : double; override;
            function AsInteger : integer; override;
            function AsObject  : TObject; override;
            function AsString  : string; override;
            function ExprType  : TExprType; override;
            //function CanReadAs(aType : TExprType): boolean;
            function TestParameters: Boolean; override;
        end;

        { 预编译用户函数执行体 }
        TUCFImplementation = class(TAbstractExtFunction)
        Private
            FSyntax: string;
            FPrivateParams: TList;
            FExprValue: IValue;
            FIdentifierContextSet: TAbstractContextSet;
            function GetParamsCount: Integer; override;
            function GetParamsName(Index: integer): String; override;
            function GetParamsType(Index: integer): TExprType; override;
            function GetSyntax: string; override;
            function IDF(Obj: IValue; const Identifier: string;
                ParameterList: TParameterList): IValue;
        Public
            constructor Create(const ATemplate: TExprTemplate);
            destructor Destroy; override;
            function Param(Index: Integer): TVarLiteral;
            function AsBoolean: Boolean;
            function AsInteger: Integer;
            function AsFloat: double;
            function AsString: string;
            function AsObject: TObject;
            procedure SetParam(Index: integer; Value: IValue);
            property ParamsName;
            property ParamsType;
        Published
            property ParamsCount;