rm_jvinterpreter.pas.~2~

这是一个功能强大

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: rm_JvInterpreter.PAS, released on 2002-07-04.

The Initial Developers of the Original Code are: Andrei Prygounkov <a dott prygounkov att gmx dott de>
Copyright (c) 1999, 2002 Andrei Prygounkov
All Rights Reserved.

Contributor(s): Dmitry Osinovsky, Peter Thornqvist, Olga Kobzar
                Peter Schraut (http://www.console-de.de)
                Ivan Ravin (ivan_ra)

Portions created by Dmitry Osinovsky and Olga Kobzar are
Copyright (C) 2003 ProgramBank Ltd.
All Rights Reserved.

You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net

component   : JvInterpreterProgram and more..
description : JVCL Interpreter version 2

Known Issues:
   String fields in records binded from Delphi don't work
-----------------------------------------------------------------------------}
// $Id: rm_JvInterpreter.pas 10546 2006-04-21 09:23:48Z obones $

{ history (JVCL Library versions):
  1.10:
   - first release;
  1.12:
   - method HandleException removed as bugged;
   - method UpdateExceptionPos now fill error message
     with error Unit name and Line pos;
   - fixed bug in TJvInterpreterUnit.Assignment method;
   - new public property BaseErrLine used in UpdateExceptionPos;
  1.17.7:
   - local "const" statement for functions;
   - global variables and constants - scope on all units - not normal !;
   - OnGetValue and OnSetValue now called before call to Adapter;
   - fixed bug with "Break" statement inside "for" loop;
  1.17.10:
   - fixed(?) bug with "begin/end" statement in "else" part of "if" statement;
   - fixed few bugs in ole automation support;
  1.21.2 (RALib 1.21 Update 2):
   - fixed bug with multiple external functions defintions
     (greetings to Peter Fischer-Haaser)
   - fixed AV-bug in TJvInterpreterFunction.InFunction if errors in source occured
     (greetings to Andre N Belokon)
  1.21.4 (RALib 1.21 Update 4):
   - fixed bugs in "if" and "while" with "begin" statements;
   - "div" and "mod" now working;
  1.21.6 (RALib 1.21 Update 6):
   - fixed bug with incorrect error line and unit name if erorr
     occured in used unit
     (greetings to Dmitry Mokrushin)
   - add parameters check (not fully functional - only count checked)
     in source fucntion calls;
  1.31.2 (RALib 1.31 Update 2):
   - fixed bug: sometimes compare-operators ('=', '>', ...)
     in expressions do not working.
  1.31.4 (RALib 1.31 Update 4):
   - fixed bug: plus and minus operators after symbol ']' not working.
  1.31.5 (RALib 1.31 Update 5):
   - function Statement1 is changed; this remove many bugs and add new ones.
   - fixed many bug in exception handling statements and in nested
     "begin/end" statements;
   - fixed error with source function with TObject (and descendants)
     returning values;
  1.41.1:
   - another fix for bug with incorrect error line and unit name
     if erorr occurred in used unit;
   - fixed bug with "Break" statement;
   - "exit" statement;
   - "repeat" loop;
  1.50:
   - behavior of "UseGlobalAdapter" property was changed; in previous versions
     each TJvInterpreterExpression component creates its own copy of GlobalAdapter and
     then manage it own copy, but now TJvInterpreterExpression manages two adapters:
     own and global, so GlobalJvInterpreterAdapter now is used by all TJvInterpreterExpressions;
     performance of "Compile" function increased (there is no necessity
     more to Assign adapters) (20 msec on my machine with JvInterpreter_all unit)
     and memory requirement decreased;
   - sorting in TJvInterpreterAdapter dramatically increase its performance speed;
   - fixed bug in "except/on" statement;
  1.51:
   - arrays as local and global variables. supports simple types (Integer,
     double, string, tdatetime, object).
     Added by Andrej Olejnik (olej att asset dott sk);
   - type conversion with Integer, string, TObject,... keywords;
  1.51.2:
   - array support was rewritten;
     enhanced indexes support: default indexed properties,
     access to chars in strings. Many changes are made to make this possible:
     new methods: GetElement, SetElement;
   - record support is simplified;
   - new property TJvInterpreterExpression.Error provide extended error information
     about non-interpreter errors.
   - "case" statement; not fully implemented - only one expression for one block.
  1.52:
   - TJvInterpreterExpression.JvInterpreterAdapter property renamed to Adapter;
   - new public property TJvInterpreterExpression.SharedAdapter, setting to
     GlobalJvInterpreterAdapter by default. This allows to create set of global adapters,
     shared between TJvInterpreterExpression components;
   - property TJvInterpreterExpression.GlobalAdapter removed; setting SharedAdapter
     to nil has same effect as GlobalAdapter := False;
   - fixed memory bug in event handling;
   - new: unit name in uses list can be placed in quotes and contains any symbols;
   - fixed bug: selector in case-statement not working with variables (only constants)
  1.53:
   - fixed bug: "Type mistmatch error" in expressions with OleAutomation objects;
   - fixed bug: error while assign function's result to object's published property;
   - call to external functions (placed in dll) in previous versions always
     return Integer, now it can return Boolean, if declared so;
  1.54:
   - new: in call to external function var-parameters are supported for
     Integer type;
   - new: after call to external function (placed in dll) last win32 error
     is restored correctly; in previous versions it was overriden by call to
     FreeLibrary;
   - fixed bug: memory leak: global variables and constants not allways be freed;
  1.60:
   - bug fixed in case-statement;
   - new: global variables and constants in different units now can have
     identical names;
   - new: constants, variables and functions can have prefix with unit name
     and point to determine appropriate unit;
   - new: class declaration for forms (needed for TJvInterpreterFm component);
   - bug fixed: record variables do not work;
  1.61:
   - bug fixed: variable types are not always kept the same when
     assigning values to them;
     thanks to Ritchie Annand (RitchieA att malibugroup dott com);
   - bug fixed: exceptions, raised in dll calls produce AV.
     fix: exception of class Exception is raised.
   - new internal: LocalVars property in TJvInterpreterFunction (it is used in TJvInterpreterFm).
  2.00:
   - Delphi 6 compatibility;
   - Kylix 1 compatibility;
   - exception handling was rewriten in more portable way,
     ChangeTopException function is not used anymore;
   - fixed bug: intefrace section was not processed correct
     (Thanks to Ivan Ravin);
Upcoming JVCL 3.00
   - major code cleanups
   - introduced data type system for variables and record fields initializations
   - interface (IInterface, IUnknown) method call support, see AddIntfGet
   - record declaration support
   - arrays of records, arrays of arrays
   - dynamic arrays
   - variant array support
   - arrays as parameters to Delphi procedures (sorry, no support for arrays
     as procedure parameters)
   - fixed record bugs with Delphi 6
   - fixed OLE bugs
   - (rom) added fix for default properties from ivan_ra  26 Dec 2003

   - (wap) fixed bug: memory leak in local-function LeaveFunction, part of
      TJvInterpreterFunction.InFunction.  See code marker VARLEAKFIX.
      (Fix suggested by ivan_ra att mail dott ru)

   - bug fixed: exceptions, raised in Assign nil to Method property  - dejoy-2004-3-13
   - fixed  Character '"' error in SkipToEnd from dejoy 2004-5-25;

   - peter schraut added shl, shr and xor support
}

unit rm_JvInterpreter;

{$I rm_jvcl.inc}

{.$DEFINE JvInterpreter_DEBUG}

interface

uses
  {$IFDEF UNITVERSIONING}
  rm_JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  SysUtils, Classes,
  {$IFDEF MSWINDOWS}
  Windows,
  {$ENDIF MSWINDOWS}
  {$IFDEF HAS_UNIT_VARIANTS}
  Variants,
  {$ENDIF HAS_UNIT_VARIANTS}
  rm_JvInterpreterParser, rm_JvComponentBase, rm_JvVCL5Utils;

const
  // (rom) renamed to longer names
  { max arguments to functions - small values increase performance }
  cJvInterpreterMaxArgs = 32;

  { max fields allowed in records }
  cJvInterpreterMaxRecFields = 32;

  // (rom) added
  cJvInterpreterStackMax = 199;

  { Max available dimensions for arrays }
  JvInterpreter_MAX_ARRAY_DIMENSION = 10;

type
  { argument definition }
  PValueArray = ^TValueArray;
  TValueArray = array [0..cJvInterpreterMaxArgs] of Variant;
  PTypeArray = ^TTypeArray;
  TTypeArray = array [0..cJvInterpreterMaxArgs] of Word;
  PNameArray = ^TNameArray;
  TNameArray = array [0..cJvInterpreterMaxArgs] of string;

  TJvInterpreterArgs = class;
  IJvInterpreterDataType = interface;

  TJvInterpreterGetValue = procedure(Sender: TObject; Identifier: string; var Value: Variant;
    Args: TJvInterpreterArgs; var Done: Boolean) of object;
  TJvInterpreterSetValue = procedure(Sender: TObject; Identifier: string;
    const Value: Variant; Args: TJvInterpreterArgs; var Done: Boolean) of object;
  TJvInterpreterGetUnitSource = procedure(UnitName: string; var Source: string;
    var Done: Boolean) of object;

  TJvInterpreterAdapterGetValue = procedure(var Value: Variant; Args: TJvInterpreterArgs);
  TJvInterpreterAdapterSetValue = procedure(const Value: Variant; Args: TJvInterpreterArgs);
  TJvInterpreterAdapterNewRecord = procedure(var Value: Pointer);
  TJvInterpreterAdapterDisposeRecord = procedure(const Value: Pointer);
  TJvInterpreterAdapterCopyRecord = procedure(var Dest: Pointer; const Source: Pointer);

  POpenArray = ^TOpenArray;
  TOpenArray = array [0..cJvInterpreterMaxArgs] of TVarRec;

  TJvInterpreterRecField = record
    Identifier: string;
    Offset: Integer;
    Typ: Word;
    DataType: IJvInterpreterDataType;
  end;

  TJvInterpreterArgs = class(TObject)
  private
    FVarNames: TNameArray;
    FHasVars: Boolean;
    { open array parameter support }
    { allocates memory only if necessary }
    FOAV: PValueArray; { open array values }
  public
    Identifier: string;
    Count: Integer;
    Types: TTypeArray;
    Values: TValueArray;
    Names: TNameArray;
    HasResult: Boolean; { = False, if result not needed - used by calls
                          to OLE automation servers }
    Assignment: Boolean; { internal }
    Obj: TObject;
    ObjTyp: Word; { varObject, varClass, varUnknown }
    ObjRefHolder: Variant; { if ObjType is varDispatch or varUnknown,
                              then we need to hold a reference to it }

    Indexed: Boolean; // if True then Args contain Indexes to Identifier
    ReturnIndexed: Boolean; // established by GetValue function, indicating
                            // what Args used as indexed (matters only if Indexed = True)
  public
    { open array parameter support }
    OA: POpenArray; { open array }
    OAS: Integer; { open array size }
    destructor Destroy; override;
    procedure Clear;
    procedure OpenArray(const Index: Integer);
    procedure Delete(const Index: Integer);
  end;

  { function descriptor }
  TJvInterpreterFunctionDesc = class(TObject)
  private
    FUnitName: string;
    FIdentifier: string;
    FClassIdentifier: string; { class name, if function declared as
                                TClassIdentifier.Identifier}
    FParamCount: Integer; { - 1..cJvInterpreterMaxArgs }
    FParamTypes: TTypeArray;
    FParamTypeNames: TNameArray; 
    FParamNames: TNameArray;
    FResTyp: Word;
    FResTypName: string;
    FResDataType: IJvInterpreterDataType;
    FPosBeg: Integer; { position in source }
    FPosEnd: Integer;
    function GetParamName(Index: Integer): string;
    function GetParamType(Index: Integer): Word;
    function GetParamTypeNames(Index: Integer): string;
    function GetDefine: string;
  public
    property UnitName: string read FUnitName;
    property Identifier: string read FIdentifier;
    property ClassIdentifier: string read FClassIdentifier;
    property Define: string read GetDefine;
    property ParamCount: Integer read FParamCount;
    property ParamTypes[Index: Integer]: Word read GetParamType;
    property ParamNames[Index: Integer]: string read GetParamName;
    property ParamTypeNames[Index: Integer]: string read GetParamTypeNames; 
    property ResTyp: Word read FResTyp;
    property ResTypName: string read FResTypName;
    property ResDataType: IJvInterpreterDataType read FResDataType;
    property PosBeg: Integer read FPosBeg;
    property PosEnd: Integer read FPosEnd;
  end;

  TSimpleEvent = procedure of object;
  TJvInterpreterExpression = class;
  EJvInterpreterError = class;

  TJvInterpreterEvent = class(TObject)
  private
    FOwner: TJvInterpreterExpression;
    FInstance: TObject;
    FUnitName: string;
    FFunctionName: string;
    FPropName: string;
    FArgs: TJvInterpreterArgs;
    function GetArgs: TJvInterpreterArgs;
  protected
    constructor Create(AOwner: TJvInterpreterExpression; AInstance: TObject;
      const AUnitName, AFunctionName, APropName: string); virtual;
    function CallFunction(Args: TJvInterpreterArgs; Params: array of Variant): Variant;
    property Args: TJvInterpreterArgs read GetArgs;
    property Owner: TJvInterpreterExpression read FOwner;
    property Instance: TObject read FInstance;
    property UnitName: string read FUnitName;
    property FunctionName: string read FFunctionName;
    property PropName: string read FPropName;
  public