scriptrunner.pas

源代码

unit ScriptRunner;

{
  Inno Setup
  Copyright (C) 1998-2003 Jordan Russell
  Portions by Martijn Laan
  For conditions of distribution and use, see LICENSE.TXT.

  Script runner

  $jrsoftware: issrc/Projects/ScriptRunner.pas,v 1.20 2004/12/23 00:49:56 jr Exp $
}

interface

uses
  uPSRuntime, uPSDebugger, uPSUtils;

type
  TScriptRunnerOnDllImport = procedure(var DllName: String; var ForceDelayLoad: Boolean);
  TScriptRunnerOnDebug = procedure(const Position: LongInt; var ContinueStepOver: Boolean);
  TScriptRunnerOnDebugIntermediate = procedure(const Position: LongInt);
  TScriptRunnerOnException = procedure(const Exception: String; const Position: LongInt);

  TScriptRunner = class
    private
      FPSExec: TPSDebugExec;
      FOnDllImport: TScriptRunnerOnDllImport;
      FOnDebug: TScriptRunnerOnDebug;
      FOnDebugIntermediate: TScriptRunnerOnDebugIntermediate;
      FOnException: TScriptRunnerOnException;
      procedure RaisePSExecException;
      procedure SetPSExecParameters(const Parameters: array of Const; Params: TPSList);
      procedure SetPSExecReturnValue(Params: TPSList; BaseType: TPSBaseType; var Res: PPSVariant);
      procedure ShowPSExecError(const Error: TPSError);
    public
      constructor Create;
      destructor Destroy; override;
      procedure LoadScript(const CompiledScriptText, CompiledScriptDebugInfo: String);
      function FunctionExists(const Name: String): Boolean;
      procedure RunProcedure(const Name: String; const Parameters: array of Const; const MustExist: Boolean);
      function RunBooleanFunction(const Name: String; const Parameters: array of Const; const MustExist, Default: Boolean): Boolean;
      function RunIntegerFunction(const Name: String; const Parameters: array of Const; const MustExist: Boolean; const Default: Integer): Integer;
      function RunStringFunction(const Name: String; const Parameters: array of Const; const MustExist: Boolean; const Default: String): String;
      function EvaluateUsedVariable(const Param1, Param2, Param3: LongInt; const Param4: String): String;
      property OnDllImport: TScriptRunnerOnDllImport read FOnDllImport write FOnDllImport;
      property OnDebug: TScriptRunnerOnDebug read FOnDebug write FOnDebug;
      property OnDebugIntermediate: TScriptRunnerOnDebugIntermediate read FOnDebugIntermediate write FOnDebugIntermediate;
      property OnException: TScriptRunnerOnException read FOnException write FOnException;
    end;

implementation

uses
  Windows,
  Forms, SysUtils,
  uPSR_dll,
  ScriptClasses_R, ScriptFunc_R;

{---}

procedure TScriptRunner.ShowPSExecError(const Error: TPSError);
begin
  raise Exception.Create('Script error: ' + PSErrorToString(Error, ''));
end;

procedure TScriptRunner.RaisePSExecException;
begin
  try
    FPSExec.RaiseCurrentException;
  except
    on E: Exception do begin
      E.Message := Format('Runtime Error (at %d:%d):'#13#10#13#10,
        [FPSExec.ExceptionProcNo, FPSExec.ExceptionPos]) + E.Message;
      raise;
    end;
  end;
end;

procedure TScriptRunner.SetPSExecParameters(const Parameters: array of Const; Params: TPSList);
var
  Param: PPSVariant;
  I: Integer;
begin
  for I := High(Parameters) downto Low(Parameters) do begin
    case Parameters[I].vType of
      vtAnsiString:
        begin
          Param := CreateHeapVariant(FPSExec.FindType2(btString));
          PPSVariantAString(Param).Data := String(Parameters[I].vAnsiString);
        end;
      vtInteger:
        begin
          Param := CreateHeapVariant(FPSExec.FindType2(btS32));
          PPSVariantS32(Param).Data := Parameters[I].vInteger;
        end;
      vtBoolean:
        begin
          Param := CreateHeapVariant(FPSExec.FindType2(btU8));
          PPSVariantU8(Param).Data := Byte(Parameters[I].vBoolean);
        end;
      vtPointer:
        begin
          { Pointers are assumed to be pointers to Booleans }
          Param := CreateHeapVariant(FPSExec.FindType2(btU8));
          PPSVariantU8(Param).Data := Byte(Boolean(Parameters[I].VPointer^));
        end;
    else
      raise Exception.Create('TScriptRunner.SetPSExecParameters: Invalid type');
    end;
    Params.Add(Param);
  end;
end;

procedure TScriptRunner.SetPSExecReturnValue(Params: TPSList; BaseType: TPSBaseType; var Res: PPSVariant);
begin
  Res := CreateHeapVariant(FPSExec.FindType2(BaseType));
  Params.Add(Res);
end;

{---}

function PSExecOnSpecialProcImport(Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean;
var
  ScriptRunner: TScriptRunner;
  DllName: String;
  I: Integer;
  ForceDelayLoad: Boolean;
begin
  ScriptRunner := Sender.ID;
  ForceDelayLoad := False;

  if Assigned(ScriptRunner.FOnDllImport) then begin
    DllName := p.Decl;

    I := Pos('dll:', DllName);
    if I <> 1 then begin
      Result := False;
      Exit;
    end;
    Delete(DllName, 1, Length('dll:'));

    I := Pos(#0, DllName);
    if I = 0 then begin
      Result := False;
      Exit;
    end;
    Delete(DllName, I, MaxInt);

    ScriptRunner.FOnDllImport(DllName, ForceDelayLoad);

    p.Decl := 'dll:' + DllName + Copy(p.Decl, Pos(#0, p.Decl), MaxInt);
  end;

  Result := ProcessDllImportEx(Sender, p, ForceDelayLoad);
end;

procedure PSExecOnSourceLine(Sender: TPSDebugExec; const Name: String; Position, Row, Col: Cardinal);
var
  ScriptRunner: TScriptRunner;
  ContinueStepOver: Boolean;
begin
  ScriptRunner := Sender.ID;

  if Sender.DebugMode = dmPaused then begin
    ContinueStepOver := False;
    if Assigned(ScriptRunner.FOnDebug) then
      ScriptRunner.FOnDebug(Position, ContinueStepOver);
    if ContinueStepOver then
      Sender.StepOver()
    else
      Sender.StepInto();
  end else begin
    if Assigned(ScriptRunner.FOnDebugIntermediate) then
      ScriptRunner.FOnDebugIntermediate(Position);
  end;
end;

procedure PSExecOnException(Sender: TPSExec; ExError: TPSError; const ExParam: string; ExObject: TObject; ProcNo, Position: Cardinal);
var
  ScriptRunner: TScriptRunner;
begin
  ScriptRunner := Sender.ID;

  if Assigned(ScriptRunner.FOnException) then
    ScriptRunner.FOnException(PSErrorToString(ExError, ExParam), ScriptRunner.FPSExec.TranslatePosition(ProcNo, Position));
end;

{---}

constructor TScriptRunner.Create();
begin
  FPSExec := TPSDebugExec.Create();
  FPSExec.ID := Self;

  FPSExec.AddSpecialProcImport('dll', @PSExecOnSpecialProcImport, nil);
  FPSExec.OnSourceLine := PSExecOnSourceLine;
  FPSExec.OnException := PSExecOnException;

  { Have to register UnloadDLL manually since we don't call RegisterDLLRuntime }
  FPSExec.RegisterFunctionName('UNLOADDLL', UnloadProc, nil, nil);
  ScriptClassesLibraryInit();
  ScriptClassesLibraryRegister_R(FPSExec);
  ScriptFuncLibraryInit();
  ScriptFuncLibraryRegister_R(FPSExec);
end;

destructor TScriptRunner.Destroy;
begin
  ScriptFuncLibraryDeInit();
  ScriptClassesLibraryDeInit();

  FPSExec.Free();
end;

procedure TScriptRunner.LoadScript(const CompiledScriptText, CompiledScriptDebugInfo: String);
begin
  if FPSExec.LoadData(CompiledScriptText) then begin
    FPSExec.DebugEnabled := CompiledScriptDebugInfo <> '';
    if FPSExec.DebugEnabled then
      FPSExec.LoadDebugData(CompiledScriptDebugInfo);
  end else begin
    RaisePSExecException;
    { In the case the above for some reason doesn't raise an exception, raise
      our own: }
    raise Exception.Create('TScriptRunner.LoadScript failed');
  end;
end;

function TScriptRunner.FunctionExists(const Name: String): Boolean;
begin
  Result := FPSExec.GetProc(Name) <> Cardinal(-1);
end;

procedure TScriptRunner.RunProcedure(const Name: String; const Parameters: array of Const; const MustExist: Boolean);
var
  ProcNo: Cardinal;
  Params: TPSList;
  I: Integer;
begin
  ProcNo := FPSExec.GetProc(Name);
  if ProcNo <> Cardinal(-1) then begin
    Params := TPSList.Create();
    try
      SetPSExecParameters(Parameters, Params);
      FPSExec.StepInto();

      ScriptClassesLibraryUpdateVars(FPSExec);
      ScriptFuncLibraryUpdateVars(FPSExec);
      FPSExec.RunProc(Params, ProcNo);

      { Write back new Boolean values to vtPointer-type parameters } 
      for I := 0 to High(Parameters) do
        if Parameters[I].vType = vtPointer then
          Boolean(Parameters[I].VPointer^) := (PPSVariantU8(Params[High(Parameters)-I]).Data = 1);
    finally
      FreePSVariantList(Params);
    end;

    RaisePSExecException;
  end else begin
    if MustExist then
      ShowPSExecError(erCouldNotCallProc);
  end;
end;

function TScriptRunner.RunBooleanFunction(const Name: String; const Parameters: array of Const; const MustExist, Default: Boolean): Boolean;
var
  ProcNo: Cardinal;
  Params: TPSList;
  Res: PPSVariant;
begin
  Result := Default;

  ProcNo := FPSExec.GetProc(Name);
  if ProcNo <> Cardinal(-1) then begin
    Params := TPSList.Create();
    try
      SetPSExecParameters(Parameters, Params);
      SetPSExecReturnValue(Params, btU8, Res);
      FPSExec.StepInto();

      ScriptClassesLibraryUpdateVars(FPSExec);
      ScriptFuncLibraryUpdateVars(FPSExec);
      FPSExec.RunProc(Params, ProcNo);

      RaisePSExecException;
      Result := PPSVariantU8(Res).Data = 1;
    finally
      FreePSVariantList(Params);
    end;
  end else begin
    if MustExist then
      ShowPSExecError(erCouldNotCallProc);
  end;
end;

function TScriptRunner.RunIntegerFunction(const Name: String; const Parameters: array of Const; const MustExist: Boolean; const Default: Integer): Integer;
var
  ProcNo: Cardinal;
  Params: TPSList;
  Res: PPSVariant;
begin
  Result := Default;

  ProcNo := FPSExec.GetProc(Name);
  if ProcNo <> Cardinal(-1) then begin
    Params := TPSList.Create();
    try
      SetPSExecParameters(Parameters, Params);
      SetPSExecReturnValue(Params, btS32, Res);
      FPSExec.StepInto();

      ScriptClassesLibraryUpdateVars(FPSExec);
      ScriptFuncLibraryUpdateVars(FPSExec);
      FPSExec.RunProc(Params, ProcNo);

      RaisePSExecException;
      Result := PPSVariantS32(Res).Data;
    finally
      FreePSVariantList(Params);
    end;
  end else begin
    if MustExist then
      ShowPSExecError(erCouldNotCallProc);
  end;
end;

function TScriptRunner.RunStringFunction(const Name: String; const Parameters: array of Const; const MustExist: Boolean; const Default: String): String;
var
  ProcNo: Cardinal;
  Params: TPSList;
  Res: PPSVariant;
begin
  Result := Default;

  ProcNo := FPSExec.GetProc(Name);
  if ProcNo <> Cardinal(-1) then begin
    Params := TPSList.Create();
    try
      SetPSExecParameters(Parameters, Params);
      SetPSExecReturnValue(Params, btString, Res);
      FPSExec.StepInto();

      ScriptClassesLibraryUpdateVars(FPSExec);
      ScriptFuncLibraryUpdateVars(FPSExec);
      FPSExec.RunProc(Params, ProcNo);

      RaisePSExecException;
      Result := PPSVariantAString(Res).Data;
    finally
      FreePSVariantList(Params);
    end;
  end else begin
    if MustExist then
      ShowPSExecError(erCouldNotCallProc);
  end;
end;

function TScriptRunner.EvaluateUsedVariable(const Param1, Param2, Param3: LongInt; const Param4: String): String;
begin
  case TPSVariableType(Param1) of
    ivtGlobal:
      begin
        Result := FPSExec.GlobalVarNames[Param3];
        if Param4 <> '' then
          Result := Result + '.' + Param4;
        Result := Result + ' = ' + PSVariantToString(NewTPSVariantIFC(FPSExec.GetGlobalVar(Param3), False), Param4);
      end;
    ivtParam:
      begin
        if Param2 = LongInt(FPSExec.GetCurrentProcNo) then begin
          Result := FPSExec.CurrentProcParams[Param3];
          if Param4 <> '' then
            Result := Result + '.' + Param4;
          Result := Result + ' = ' + PSVariantToString(NewTPSVariantIFC(FPSExec.GetProcParam(Param3), False), Param4);
        end else
          Result := '';
      end;
    ivtVariable:
      begin
        if Param2 = LongInt(FPSExec.GetCurrentProcNo) then begin
          Result := FPSExec.CurrentProcVars[Param3];
          if Param4 <> '' then
            Result := Result + '.' + Param4;
          Result := Result + ' = ' + PSVariantToString(NewTPSVariantIFC(FPSExec.GetProcVar(Param3), False), Param4);
        end else
          Result := '';
      end;
  end;
end;

end.