dxjs_main.pas

Well known and usefull component for delphi 7

////////////////////////////////////////////////////////////////////////////
//    Component: TJScript
//       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: JavaScript interpreter maanger.
// ========================================================================
////////////////////////////////////////////////////////////////////////////

unit DXJS_MAIN;
interface

{$I DXJavaScript.def}

uses
{$IFDEF VARIANTS}
  Variants,
{$ENDIF}
  SysUtils,
  Classes,
  TypInfo,
  DXJS_SHARE,
  DXJS_SCANNER,
  DXJS_SYMBOL,
  DXJS_PARSER,
  DXJS_POSTFIX,
  DXJS_LIST,
  DXJS_EXTERN,
  DXJS_OBJECT,
  DXJS_CONV;

type
  TModule = class(TStringList)
  public
    Name: String;
    FileName: String;
  end;

  TModules = class
  private
    List: TList;
    function GetModule(Index: Integer): TModule;
    function GetCount: Integer;
    function GetSourceCode: String;
  public
    constructor Create;
    procedure Clear;
    function IndexOf(const Name: String): Integer;
    function Add(const Name: String): Integer;
    procedure Delete(Index: Integer);
    destructor Destroy; override;
    property Items[Index: Integer]: TModule read GetModule; default;
    property Count: Integer read GetCount;
    property SourceCode: String read GetSourceCode;
  end;

  TScriptEvent = procedure(const ScriptObject: Variant) of object;

  TGetExtraPropertyEvent = function (Sender: TObject; Instance: TObject;
                                 const PropertyName: String): Variant of object;

  TPutExtraPropertyEvent = procedure (Sender: TObject; Instance: TObject; const PropertyName: String;
                                 const Value: Variant) of object;

  TVariableEvent = procedure (Sender: TObject; const Name: String; var Value: Variant) of object;

  TJScript = class
  public
    Modules: TModules;
    SymbolTable: TSymbolTable;
    Scanner: TScanner;
    Parser: TParser;
    Postfix: TPostfix;
    LineCount: Integer;
    StdDefinitionList: TDefinitionList;
    HostDefinitionList: TDefinitionList;
    PropDefList: TPropDefList;
    RemovePropList: TRemovePropList;
    HostVariableList: THostVariableList;
    ConstantList: TConstantList;
    HostObjectList: THostObjectList;
    HostConstructorList: THostConstructorList;
    EventHandlerList: TEventHandlerList;
    fOnShowError: TScriptEvent;
    Error: TVariant;
    ZeroBasedStringIndex: boolean;
    Garbage: TGarbage;
    GlobalObject: TGlobalObject;
    ScriptState: TScriptState;
    OpenWindows: TList;

    fOnGetExtraProperty: TGetExtraPropertyEvent;
    fOnPutExtraProperty: TPutExtraPropertyEvent;
    fOnUndefinedVariable: TVariableEvent;
    fOnChangedVariable: TVariableEvent;

    Owner: TComponent;

    constructor Create(Owner: TComponent); 
    destructor Destroy; override;
    function AddModule(const ModuleName: String): Integer;
    procedure AddCode(const ModuleName, Code: String);
    procedure AddCodeFromFile(const ModuleName, FileName: String);
    procedure AddObject(const Name: String; Instance: TObject);
    procedure AddRoutine(const Name: String; Address: Pointer);
    procedure AddMethod(AClass: TClass; const Name: String; Address: Pointer);
    procedure AddConstructor(AClass: TClass; Address: Pointer);
    procedure AddProperty(AClass: TClass; const Name: String;
                          ReadAddr, WriteAddr: Pointer);
    procedure RemoveProperty(AClass: TClass; const Name: String);
    procedure AddHostVariable(const Name: String; Address: Pointer);
    procedure AddConstant(const Name: String; const Value: Variant);
    procedure SaveToStream(S: TStream);
    procedure LoadFromStream(S: TStream);
    procedure Print;
    function ParseModule(const I:Integer): boolean;
    function Parse: boolean;
    function Run(RunMode: Integer = rmRun): boolean;
    procedure Reset;
    procedure ClearModule(const Modulename:String);
    procedure CreateErrorObject(E: Exception);
    procedure ShowError(const Error: TVariant); virtual;
    function Eval(const Code: String): Variant;
    function GetID(const Name: String): Integer;
    function GetValue(ID: Integer): Variant;
    procedure PutValue(ID: Integer; const Value: Variant);
    function CallFunction(SubID: Integer; const Parameters: array of Variant): Variant;
    function SourceLineToPCodeLine(const ModuleName: String; LineNumber: Integer): Integer;
    function AddBreakpoint(const ModuleName: String; LineNumber: Integer): boolean;
    function RemoveBreakpoint(const ModuleName: String; LineNumber: Integer): boolean;
    procedure RemoveAllBreakpoints;
    procedure ExtractCallStack(CallStack: TStringList);
    function CurrentLineNumber: Integer;
    function CurrentModule: String;
    function CurrentLine: String;
    function CurrentFunction: String;
    procedure ResetRun;
    procedure Terminate;
  end;

// Routines Found in DXJS_CONV, brought Forward:
function ToBoolean(const Value: TVariant): Boolean;
function ToNumber(const Value: TVariant): Double;
function ToInteger(const Value: TVariant): Integer;
function ToString(const Value: TVariant): String;
function ToDelphiObject(Value: TVariant): TObject;
function DelphiObjectToVariant(Instance: TObject): Variant;
function GetProperty(const ScriptObject: Variant; PropertyName: String): Variant;
function IsPrimitive(const Value: Variant): boolean;

var
  RTTITypeList: TStringList;

implementation

Uses
{$IFDEF LINUX}
  QForms,
{$ELSE}
  Forms, // uses TForm
{$ENDIF}
  DXString; // from DXFreeware

constructor TModules.Create;
begin
  inherited;
  List := TList.Create;
end;

destructor TModules.Destroy;
var
  I: Integer;
  Module: TModule;
begin
  for I:=List.Count - 1 downto 0 do begin // 803 downto
    Module := TModule(List[I]);
    Module.Free;
  end;
  List.Free;
  inherited;
end;

function TModules.GetModule(Index: Integer): TModule;
begin
  if (Index < 0) or (Index >= Count) then Result:=Nil
  Else result := TModule(List[Index]);
end;

procedure TModules.Delete(Index: Integer);
begin
  if (Index < 0) or (Index >= Count) then Exit;
  TModule(List[Index]).Free;
  List.Delete(Index);
end;

procedure TModules.Clear;
var
  I: Integer;
begin
  for I:=Count-1 downto 0 do Delete(I); //803 downto!
end;

function TModules.GetSourceCode: String;
var
  I: Integer;
begin
  result := '';
  for I:=0 to Count-1 do result:=result+GetModule(I).Text;
end;

function TModules.GetCount: Integer;
begin
  result := List.Count;
end;

function TModules.IndexOf(const Name: String): Integer;
var
  Module: TModule;
  I: Integer;
begin
  result := -1;
  for I:=0 to List.Count - 1 do begin
    Module := TModule(List[I]);
    if StrEql(Name, Module.Name) then begin
      result := I;
      Exit;
    end;
  end;
end;

function TModules.Add(const Name: String): Integer;
var
  Module: TModule;
begin
  result := IndexOf(Name);
  if result <0 then Begin
     Module := TModule.Create;
     Module.Name := Name;
     Module.FileName := '';
     List.Add(Pointer(Module));
  End;
end;

constructor TJScript.Create(Owner: TComponent);
begin
  inherited create; // OZZ
  Self.Owner := Owner;
  Garbage := TGarbage.Create;
  StdDefinitionList := TDefinitionList.Create;
  StdDefinitionList.AddStandardRoutines;
  HostDefinitionList := TDefinitionList.Create;
  PropDefList := TPropDefList.Create;
  RemovePropList := TRemovePropList.Create;
  HostVariableList := THostVariableList.Create;
  ConstantList := TConstantList.Create;
  HostObjectList := THostObjectList.Create;
  HostConstructorList := THostConstructorList.Create;
  EventHandlerList := TEventHandlerList.Create;
  Modules := TModules.Create;
  Scanner := nil;
  Parser := TParser.Create(Self);
  Postfix := TPostfix.Create(Self);
  GlobalObject := TGlobalObject.Create(Self);
  GlobalObject.CreatePrototypes;
  SymbolTable := TSymbolTable.Create(Self);
  LineCount := 0;
  ZeroBasedStringIndex := true;
  ScriptState := ss_Initialization;
  OpenWindows := TList.Create;
end;

destructor TJScript.Destroy;
begin
  if Assigned(Garbage) then Garbage.Free;
  if Assigned(StdDefinitionList) then StdDefinitionList.Free;
  if Assigned(HostDefinitionList) then HostDefinitionList.Free;
  if Assigned(PropDefList) then PropDefList.Free;
  if Assigned(RemovePropList) then RemovePropList.Free;
  if Assigned(HostVariableList) then HostVariableList.Free;
  if Assigned(ConstantList) then ConstantList.Free;
  if Assigned(HostObjectList) then HostObjectList.Free;
  if Assigned(HostConstructorList) then HostConstructorList.Free;
  if Assigned(EventHandlerList) then EventHandlerList.Free;
  if Assigned(Modules) then Modules.Free;
  if Assigned(Parser) then Parser.Free;
  if Assigned(Postfix) then Postfix.Free;
//  if Assigned(GlobalObject) then GlobalObject.Free;
  if Assigned(SymbolTable) then SymbolTable.Free;
  if Assigned(Scanner) then Scanner.Free;
  if Assigned(OpenWindows) then OpenWindows.Free;
  inherited destroy; // OZZ
end;

procedure TJScript.Reset;
begin
  Garbage.Free;
  Garbage := TGarbage.Create;
//  if Assigned(GlobalObject) then GlobalObject.Free;
  GlobalObject := TGlobalObject.Create(Self);
  GlobalObject.CreatePrototypes;
  Modules.Free;
  Modules := TModules.Create;
  SymbolTable.Free;
  SymbolTable := TSymbolTable.Create(Self);
  Parser.Free;
  Parser := TParser.Create(Self);
  Postfix.Free;
  Postfix := TPostfix.Create(Self);
  LineCount := 0;
  ScriptState := ss_Initialization;
end;

function TJScript.AddModule(const ModuleName: String): Integer;
begin
  result := Modules.Add(ModuleName);
end;

procedure TJScript.AddCode(const ModuleName, Code: String);
var
  I: Integer;
  Module: TModule;
begin
  I := Modules.IndexOf(ModuleName);
  if I = -1 then begin
    Modules.Add(ModuleName);
    I := Modules.IndexOf(ModuleName);
  end;
  Module := TModule(Modules.List[I]);
  Module.Text := Module.Text + Code;
end;

procedure TJScript.AddCodeFromFile(const ModuleName, FileName: String);
var
  L: TStringList;
  I: Integer;
  Module: TModule;
begin
  if FileExists(FileName) then Begin
    L := TStringList.Create;
    try
      L.LoadFromFile(FileName);
      AddCode(ModuleName, L.Text);
      I := Modules.IndexOf(ModuleName);
      Module := TModule(Modules.List[I]);
      Module.FileName := FileName;
    finally
      L.Free;
    end;
  end;
end;

function TJScript.Eval(const Code: String): Variant;
var
  StartPos, LastOP, LastN: Integer;
  I, SymbolTableCard, SymbolTableMemBoundVar, {PostfixCard,}
  PostfixCurrBoundTable, PostfixCurrBoundStack,
  PostfixStackCard: Integer;
  ExtraCode: boolean;
  LastState: TScriptState;

begin
  StartPos := Postfix.Card;
  LastOP := PostFix.OP;
  LastN := PostFix.N;
  PostfixCurrBoundTable := Postfix.CurrBoundTable;
  PostfixCurrBoundStack := Postfix.CurrBoundStack;
  PostFixStackCard := Postfix.Stack.Card;
  SymbolTableCard := SymbolTable.Card;
  SymbolTableMemBoundVar := SymbolTable.MemBoundVar;
  SymbolTable.Card := SymbolTable.EvalCard;
  SymbolTable.MemBoundVar := SymbolTable.EvalMemBoundVar;
  if Postfix.CallStack.TopObject <> nil then
    Parser.CurrLevel := Postfix.CallStack.TopObject.SubID;
  Scanner := TScanner.Create(Self);
  Scanner.Buff := Code + ';' + #255;
  Parser.Call_SCANNER;
  result := Parser.Parse_Program;
  Scanner.Free;
  Scanner := nil;
  ExtraCode := false;
  for I:= SymbolTable.EvalCard + 1 to SymbolTable.Card do
    if SymbolTable.GetKind(I) = kind_is_SUB then ExtraCode := true;
  Parser.App_POSTFIX(OP_HALT);
  SymbolTable.EvalCard := SymbolTable.Card;
  SymbolTable.EvalMemBoundVar := SymbolTable.MemBoundVar;
  LastState := ScriptState;
  ScriptState := ss_Running;
  Inc(Postfix.EvalCount);
  Postfix.N := StartPos;
  PostFix.Run;
  Dec(Postfix.EvalCount);
  result := Postfix.EvalRes;
  if PostFix.Stack.Card > PostfixStackCard then result := Postfix.PopVariant;
  if VarType(result) = varScriptObject then begin
    result := VariantToScriptObject(result).DefaultValue;
  end;
  SymbolTable.EraseTail(SymbolTableCard);
  SymbolTable.MemBoundVar := SymbolTableMemBoundVar;
  Postfix.CurrBoundTable := PostfixCurrBoundTable;
  Postfix.CurrBoundStack := PostfixCurrBoundStack;
  PostFix.Stack.Card := PostfixStackCard;
  if not ExtraCode then Postfix.Card := StartPos;
  PostFix.OP := LastOP;
  PostFix.N := LastN;
  ScriptState := LastState;
end;

function TJScript.ParseModule(const I:Integer): boolean;
var
  Module: TModule;
begin
  Module := Modules[I];
  Parser.App_POSTFIX(BOUND_FILES - I);
  Parser.App_POSTFIX(BOUND_LINES - 0);
  Scanner := TScanner.Create(Self);
  Scanner.Buff := Module.Text + #255;
  Parser.Call_SCANNER;
  result := Parser.Parse_Program;
  Scanner.Free;
  Scanner := nil;
end;

function TJScript.Parse: boolean;
var
  I: Integer;
begin
  result := true;
  Postfix.BreakpointList.Clear;
  Postfix.Card := 0;
  Postfix.N := 0;
  SymbolTable.SetupHostDefinitions;
  Parser.App_POSTFIX(OP_START);
  ScriptState := ss_Compiling;
  for I:=0 to Modules.Count - 1 do begin
    result := result and ParseModule(I); //720 Modules[I].Name);
    if not result then begin
      if Assigned(fOnShowError) then fOnShowError(Error)
       else ShowError(Error);
       ScriptState := ss_Initialization;
       Exit;
    end;
  end;
  Parser.App_POSTFIX(OP_HALT);
  with SymbolTable do begin
    ParseCard := Card;