dxjs_share.pas

Well known and usefull component for delphi 7

////////////////////////////////////////////////////////////////////////////
//    Component: DXJS_SHARE
//       Author: Alexander Baranovsky ([e-mail])
//               G.E. Ozz Nixon Jr. ([e-mail])
// ========================================================================
// Source Owner: DX, Inc. 2002, 2004
//    Copyright: All code is the property of DX, Inc. Licensed for
//               resell by Brain Patchwork DX (tm) and part of the
//               DX (r) product lines, which are (c) 1999-2002
//               DX, Inc. Source may not be distributed without
//               written permission from both Brain Patchwork DX,
//               and DX, Inc.
//      License: (Reminder), None of this code can be added to other
//               developer products without permission. This includes
//               but not limited to DCU's, DCP's, DLL's, OCX's, or
//               any other form of merging our technologies. All of
//               your products released to a public consumer be it
//               shareware, freeware, commercial, etc. must contain a
//               license notification somewhere visible in the
//               application.
// Code Version: (3rd Generation)
// ========================================================================
//  Description: Common/Global Variables and Routines
// ========================================================================
////////////////////////////////////////////////////////////////////////////

unit DXJS_SHARE;
interface
{$I DXJavaScript.def}

uses
   Classes,
   SysUtils,// for exceptions
{$IFDEF WIN32}
   Windows,
{$ENDIF}
{$IFDEF LINUX}
//  QForms,
{$ENDIF}
{$IFDEF VARIANTS}
   Variants,
{$ENDIF}
   DXJS_RESSTR;

var
   Undefined:Variant;
   String_ID,
   Boolean_ID,
   Number_ID,
   Array_ID,
   Date_ID,
   Math_ID,
   RegExp_ID,
   Function_ID,
   Error_ID,
   DelphiObject_ID,
   ActiveXObject_ID,
   EnumeratorObject_ID:Integer;

const
   rmRun=0;
   rmStepOver=1;
   rmTraceInto=2;
   rmNextSourceLine=3;
   MaxHash=97;
   BR=#13#10;
   MAX_VALUE:double=1.7E307;
   MIN_VALUE:double=4.0E-324;
   NEGATIVE_INFINITY:double=-1.7E308;
   POSITIVE_INFINITY:double=1.7E308;
   NaN:double=1.71E308;
   INFINITY:double=1.7E308;
   varUndefined=varEmpty;
//   varScriptObject=varByte;
{$IFDEF LINUX}
   varScriptObject = varError;
{$ELSE}
   varScriptObject = $0E;
{$ENDIF}
   varDelphiObject=varSmallInt; // June 2004 - Need to make this different!!
   MaxSymbolCard=32000;
   MaxConst=2000;
   MaxPostfix=40000;
   StartMemBoundConst=100;
   StartMemBoundVar=40000;
{$IFDEF SMALL}
   MaxMem=64000;// 64KB per instance of DXJavaScript - DXJS_SYMBOL.CREATE
{$ENDIF}
{$IFDEF MEDIUM}
   MaxMem=100000;// 100KB per instance of DXJavaScript - DXJS_SYMBOL.CREATE
{$ENDIF}
{$IFDEF LARGE}
   MaxMem=200000;// 200KB per instance of DXJavaScript - DXJS_SYMBOL.CREATE
{$ENDIF}
   MaxTryStack=100;
   MaxEval=100;
   FirstStackSize=256;
   GrowStackSize=256;
   BOUND_KEYWORD=-800;
   BOUND_OPER=-100;
   BOUND_LINES=-30000;
   BOUND_FILES=-50000;
   SP_ROUND_BRACKET_L=-901;
   SP_ROUND_BRACKET_R=-902;
   SP_BRACKET_L=-903;
   SP_BRACKET_R=-904;
   SP_BRACE_L=-905;
   SP_BRACE_R=-906;
   SP_SEMICOLON=-907;
   SP_POINT=-908;
   SP_COLON=-909;
   SP_COMMA=-910;

type
   TVariant=Variant;
   TInteger=Integer;
   TDouble=Double;
   TBoolean=Boolean;

   TKindProc= (KindJavaScript,
      KindDelphiRoutine,
      KindDelphiMethod,
      KindDelphiConstructor) ;

   TScriptState= (ss_Initialization,
      ss_Compiling,
      ss_Compiled,
      ss_Running,
      ss_Suspended) ;

   TScriptProc=function (var This:Variant;const Parameters:array of Variant) :Variant;
   TDelphiRoutine=function (const Parameters:array of Variant) :Variant;
   TDelphiMethod=function (Instance:TObject;const Parameters:array of Variant) :Variant;
   TDelphiConstructor=function (const Parameters:array of Variant) :TObject;

   TStandardClasses=TStringList;
   TAssignmentOperators=TList;
   TRunErrors=TStringList;

   TCallConvention= (ccRegister,
      ccPascal,
      ccCDecl,
      ccStdCall,
      ccSafeCall) ;

   TTokenClass= (classOPER,
      classSPECIAL,
      classKEYWORD,
      classID,
      classCONST,
      classSEPARATOR) ;

const
   StrTokenClass:array[0..5] of string=
      ('OPER','SPECIAL','KEYWORD','ID','CONST','SEPARATOR') ;

type
   PToken=^TToken;
   TToken=record
      Text:string;
      ID:Integer;
      AClass:TTokenClass;
      Pos:Integer;
   end;

   TScriptFailure=class (Exception)
      Code:Integer;
      constructor Create (InitCode:Cardinal) ;
   end;

   TParseError=class
      Msg:string;
      Match:Integer;
   end;

   TParseErrors=class (TList)
   private
      function App (const Msg:string;Match:Integer) :Integer;
      function GetMessage (Code:Integer) :string;
   public
      function GetCode (Match:Integer) :Integer;
      property Messages[Code:Integer]:string read GetMessage;default;
   end;

   TBaseTypeRec=record
      Name:string;
      Size:Integer;
   end;

   TBaseTypes=class
      A:array[1..50] of TBaseTypeRec;
      Card:Integer;
      constructor Create;
      function App (const Name:string;Size:Integer) :Integer;
      function GetSize (AType:Integer) :Integer;
   end;

   TKinds=TStringList;

Var
   peSyntaxError,
      peIdentifierExpected,
      peIdentifierRedeclared,
      peInvalidCompilerDirective,
      peOutsideOfLoop,
      peLabelNotFound,
      peCannotAssign,
      peMissingENDIFdirective:Integer;
   reIncompatibleTypes,
      reVarNotArray,
      reVarArrayBounds,
      reReferenceError,
      reRecompileRequested,
      reFunctionNotFound:Integer;
   type_is_VARIANT:Integer;

const
   Kind_is_VAR=1;
   Kind_is_TYPE=2;
   Kind_is_CONST=3;
   Kind_is_SUB=4;
   Kind_is_REF=5;
   Kind_is_LABEL=6;
   Kind_is_OPER=7;
   MaxKinds=Kind_is_OPER;
   kind_String:array[0..MaxKinds] of record
      Code:Integer;
      Msg:string
   end=
   ((Code:0;Msg:'VOID') ,
      (Code:Kind_is_VAR;Msg:'VAR') ,
      (Code:Kind_is_TYPE;Msg:'TYPE') ,
      (Code:Kind_is_CONST;Msg:'CONST') ,
      (Code:Kind_is_SUB;Msg:'SUB') ,
      (Code:Kind_is_REF;Msg:'REF') ,
      (Code:Kind_is_LABEL;Msg:'LABEL') ,
      (Code:Kind_is_OPER;Msg:'OPER')
      ) ;

Const
   OP_PRINT=BOUND_OPER-0;
   OP_PAUSE=BOUND_OPER-1;
   OP_CREATE_OBJECT=BOUND_OPER-2;
   OP_CREATE_REFERENCE=BOUND_OPER-3;
   OP_GET_NEXT_PROP=BOUND_OPER-4;
   OP_SWAP=BOUND_OPER-5;
   OP_GO=BOUND_OPER-6;
   OP_GO_FALSE=BOUND_OPER-7;
   OP_NOP=BOUND_OPER-8;
   OP_EOF=BOUND_OPER-9;
   OP_EOS=BOUND_OPER-10;
   OP_HALT=BOUND_OPER-11;
   OP_START=BOUND_OPER-12;
   OP_SAVE_CALL=BOUND_OPER-13;
   OP_CALL=BOUND_OPER-14;
   OP_PASS_BY_VAL=BOUND_OPER-15;
   OP_RET=BOUND_OPER-16;
   OP_EXIT=BOUND_OPER-17;
   OP_COND_EXIT=BOUND_OPER-18;
   OP_FINALLY=BOUND_OPER-19;
   OP_CATCH=BOUND_OPER-20;
   OP_TRY_ON=BOUND_OPER-21;
   OP_TRY_OFF=BOUND_OPER-22;
   OP_RAISE=BOUND_OPER-23;
   OP_CLEAR_ERROR=BOUND_OPER-24;
   OP_THROW=BOUND_OPER-25;
   OP_BEGIN_WITH=BOUND_OPER-26;
   OP_END_WITH=BOUND_OPER-27;
   OP_EVAL_IDENTIFIER=BOUND_OPER-28;
   OP_POP_RET=BOUND_OPER-29;
   OP_PLUS=BOUND_OPER-30;
   OP_MINUS=BOUND_OPER-31;
   OP_MULT=BOUND_OPER-32;
   OP_DIV=BOUND_OPER-33;
   OP_MOD=BOUND_OPER-34;
   OP_LOGICAL_AND=BOUND_OPER-35;
   OP_LOGICAL_OR=BOUND_OPER-36;
   OP_BITWISE_AND=BOUND_OPER-37;
   OP_BITWISE_OR=BOUND_OPER-38;
   OP_BITWISE_LEFT_SHIFT=BOUND_OPER-39;
   OP_BITWISE_RIGHT_SHIFT=BOUND_OPER-40;
   OP_BITWISE_UNSIGNED_RIGHT_SHIFT=BOUND_OPER-41;
   OP_BITWISE_XOR=BOUND_OPER-42;
   OP_BITWISE_NOT=BOUND_OPER-43;
   OP_INC=BOUND_OPER-44;
   OP_DEC=BOUND_OPER-45;
   OP_PLUS1=BOUND_OPER-46;
   OP_MINUS1=BOUND_OPER-47;
   OP_DELETE=BOUND_OPER-48;
   OP_VOID=BOUND_OPER-49;
   OP_TYPEOF=BOUND_OPER-50;
   OP_LT=BOUND_OPER-51;
   OP_GT=BOUND_OPER-52;
   OP_LE=BOUND_OPER-53;
   OP_GE=BOUND_OPER-54;
   OP_EQ=BOUND_OPER-55;
   OP_NE=BOUND_OPER-56;
   OP_INSTANCEOF=BOUND_OPER-57;
   OP_IN=BOUND_OPER-58;
   OP_ID=BOUND_OPER-59;
   OP_NI=BOUND_OPER-60;
   OP_LOGICAL_NOT=BOUND_OPER-61;
   OP_COND=BOUND_OPER-62;
   OP_ASSIGN=BOUND_OPER-63;
   OP_ASSIGN_PLUS=BOUND_OPER-64;
   OP_ASSIGN_MINUS=BOUND_OPER-65;
   OP_ASSIGN_MULT=BOUND_OPER-66;
   OP_ASSIGN_DIV=BOUND_OPER-67;
   OP_ASSIGN_MOD=BOUND_OPER-68;
   OP_ASSIGN_BITWISE_AND=BOUND_OPER-69;
   OP_ASSIGN_BITWISE_OR=BOUND_OPER-70;
   OP_ASSIGN_BITWISE_LEFT_SHIFT=BOUND_OPER-71;
   OP_ASSIGN_BITWISE_RIGHT_SHIFT=BOUND_OPER-72;
   OP_ASSIGN_BITWISE_UNSIGNED_RIGHT_SHIFT=BOUND_OPER-73;
   OP_ASSIGN_BITWISE_XOR=BOUND_OPER-74;

   MaxOperations=BOUND_OPER-74;
   strOperations:array[0..74] of string=
      ('OP_PRINT','OP_PAUSE','OP_CREATE_OBJECT','OP_CREATE_REFERENCE',
       'OP_GET_NEXT_PROP','OP_SWAP','OP_GO','OP_GO_FALSE','OP_NOP',
       'OP_EOF','OP_EOS','OP_HALT','OP_START','OP_SAVE_CALL','OP_CALL',
       'OP_PASS_BY_VAL','OP_RET','OP_EXIT','OP_COND_EXIT','OP_FINALLY',
       'OP_CATCH','OP_TRY_ON','OP_TRY_OFF','OP_RAISE','OP_CLEAR_ERROR',
       'OP_THROW','OP_BEGIN_WITH','OP_END_WITH','OP_EVAL_IDENTIFIER',
       'OP_POP_RET','OP_PLUS','OP_MINUS','OP_MULT','OP_DIV','OP_MOD',
       'OP_LOGICAL_AND','OP_LOGICAL_OR','OP_BITWISE_AND','OP_BITWISE_OR',
       'OP_BITWISE_LEFT_SHIFT','OP_BITWISE_RIGHT_SHIFT',
       'OP_BITWISE_UNSIGNED_RIGHT_SHIFT','OP_BITWISE_XOR','OP_BITWISE_NOT',
       'OP_INC','OP_DEC','OP_PLUS1','OP_MINUS1','OP_DELETE','OP_VOID',
       'OP_TYPEOF','OP_LT','OP_GT','OP_LE','OP_GE','OP_EQ','OP_NE',
       'OP_INSTANCEOF','OP_IN','OP_ID','OP_NI','OP_LOGICAL_NOT',
       'OP_COND','OP_ASSIGN','OP_ASSIGN_PLUS','OP_ASSIGN_MINUS',
       'OP_ASSIGN_MULT','OP_ASSIGN_DIV','OP_ASSIGN_MOD',
       'OP_ASSIGN_BITWISE_AND','OP_ASSIGN_BITWISE_OR',
       'OP_ASSIGN_BITWISE_LEFT_SHIFT','OP_ASSIGN_BITWISE_RIGHT_SHIFT',
       'OP_ASSIGN_BITWISE_UNSIGNED_RIGHT_SHIFT','OP_ASSIGN_BITWISE_XOR');

   MaxKeywords=26;
   strKeywords:array[0..MaxKeywords] of string=
{7}   ('break','case','catch','continue','debugger','default','delete',
{15}   'do','else','finally','for','function','if','in','instanceof',
{23}   'new','print','pause','return','switch','throw','try','typeof',
{27}   'var','void','while','with');

   WD_BREAK=BOUND_KEYWORD-0;
   WD_CASE=BOUND_KEYWORD-1;
   WD_CATCH=BOUND_KEYWORD-2;
   WD_CONTINUE=BOUND_KEYWORD-3;
   WD_DEBUGGER=BOUND_KEYWORD-4;
   WD_DEFAULT=BOUND_KEYWORD-5;
   WD_DELETE=BOUND_KEYWORD-6;
   WD_DO=BOUND_KEYWORD-7;
   WD_ELSE=BOUND_KEYWORD-8;
   WD_FINALLY=BOUND_KEYWORD-9;
   WD_FOR=BOUND_KEYWORD-10;
   WD_FUNCTION=BOUND_KEYWORD-11;
   WD_IF=BOUND_KEYWORD-12;
   WD_IN=BOUND_KEYWORD-13;
   WD_INSTANCEOF=BOUND_KEYWORD-14;
   WD_NEW=BOUND_KEYWORD-15;
   WD_PRINT=BOUND_KEYWORD-16;
   WD_PAUSE=BOUND_KEYWORD-17;
   WD_RETURN=BOUND_KEYWORD-18;
   WD_SWITCH=BOUND_KEYWORD-19;
   WD_THROW=BOUND_KEYWORD-20;
   WD_TRY=BOUND_KEYWORD-21;
   WD_TYPEOF=BOUND_KEYWORD-22;
   WD_VAR=BOUND_KEYWORD-23;
   WD_VOID=BOUND_KEYWORD-24;
   WD_WHILE=BOUND_KEYWORD-25;
   WD_WITH=BOUND_KEYWORD-26;

var
   StandardClasses:TStandardClasses;
   AssignmentOperators:TAssignmentOperators;
   ParseErrors:TParseErrors;
   RunErrors:TRunErrors;
   BaseTypes:TBaseTypes;
   Kinds:TKinds;

   DummyInt:Integer;

function IsStandardClass (ClassID:Integer) :Boolean;

function EqualityComparison (const V1,V2:TVariant) :TBoolean;
function StrictEqualityComparison (const V1,V2:TVariant) :TBoolean;
function RelationalComparison (const V1,V2:TVariant) :TVariant;
function StrEql (const S1,S2:string) :Boolean;
function GetOperName (OP:Integer) :string;
function VariantToString (const Value:Variant) :string;
function ShiftPointer (P:Pointer;D:Integer) :Pointer;
function GetStrTokenClass (Token:TToken) :string;
function Norm (const S:string;L:Integer) :string;
procedure ErrMessageBox (const S:string) ;
function IsNumber (const V:Variant) :boolean;
function IsArray (const V:Variant) :boolean;
function IsString (const V:Variant) :boolean;
function IsBoolean (const V:Variant) :boolean;
function IsObject (const V:Variant) :boolean;
function IsUndefined (const V:Variant) :boolean;
function IsNull (const V:Variant) :boolean;