unit U_Script;

interface

uses
  Classes,
  U_LogEmitter;

type
  {$METHODINFO ON}
  TScriptPublic = class;
  {$METHODINFO OFF}


  { ------------------------------------------------------------------------ }
  TScript = class(TLogEmitter)
  private
    FPath: string;
    FName: string;
    FSource: string;
    FEngine: OleVariant;
    FPublic: TScriptPublic;
    FCommands: TStringList;
    FKeys: TStringList;
    FProcedures: TStringList;

    FCommandObject: OleVariant;
    FKeypressObject: OleVariant;
    FUpdateObject: OleVariant;

    procedure LoadFromFile(Path: string);

    procedure SetName(Value: string);
    procedure SetSource(Code: string);
    function  GetIsLibrary(): boolean;
  public
    Enabled: boolean;

    constructor Create(Parent: TLogEmitter; Path: string); overload;
    constructor Create(Path: string); overload;
    destructor  Destroy; override;

    function  HandlesCommand(Command: string): boolean;
    function  HandlesKeyPress(KeyCode: integer; Alt: boolean): boolean;
    function  HandlesUpdate(): boolean;

    function  DoCommand(Command: string): OleVariant;
    procedure DoKeyPress(KeyCode: integer; Alt: boolean);
    procedure DoUpdate(ZBar: OleVariant);

    property Path: string             read FPath;
    property Name: string             read FName    write SetName;
    property Source: string           read FSource  write SetSource;
    property Engine: OleVariant       read FEngine;
    property Public: TScriptPublic    read FPublic;
    property IsLibrary: boolean       read GetIsLibrary;

    property HandledCommands: TStringList read FCommands;
    property HandledKeys: TStringList     read FKeys;
    property Procedures: TStringList      read FProcedures;
  end;


  { ------------------------------------------------------------------------ }
  {$METHODINFO ON}
  TScriptPublic = class
  private
    FParent: TScript;
    FOutput: string;

    function  GetPath: string;
    procedure SetName(Value: string);
    function  GetName: string;
  public
    constructor Create(Parent: TScript);
    destructor  Destroy; override;

    procedure Import(Filename: string);

    function  RegisterCommand(Command: string): boolean;
    function  RegisterKey(KeyCode: integer; Alt: boolean): boolean;

  published
    { The full path and filename of the current script. }
	property Filename: string read GetPath;
	{ The display name of the script. Defaults to the file name. }
    property Name: string     read GetName  write SetName;
	{ The output generated by this script using @link(TScriptEnvironment.Write Write) and @link(TScriptEnvironment.WriteLine WriteLine). }
    property Output: string   read FOutput  write FOutput;
  end;
  {$METHODINFO OFF}

  { ------------------------------------------------------------------------ }
  {$METHODINFO ON}
  TScriptEnvironment = class
  private
    FScript: TScript;

    function  GetFSO: OleVariant;
    function  GetFile: OleVariant;
    function  GetOtherFile: OleVariant;
  public
    constructor Create(Script: TScript);
  published
    { Displays a dialog box containing the given message and an 'OK' button.
	  @param(Text is the message to display.) }
	procedure Alert(Text: string);
	{ Displays a dialog box containing the given message, and the buttons 'OK' and 'Cancel'.
	  @param(Text is the message to display.)
	  @returns(@true if the user clicked OK, @false otherwise.) }
    function  Confirm(Text: string): boolean;
	{ Creates and returns a reference to an Automation object.
	  @br Example:  @code(CreateObject@("ADODB.Stream"@)) returns a newly created Stream object. }
    function  CreateObject(ProgID: string): OleVariant;

    { Outputs the given text to the debug console. @seealso(TScriptPublic.Output) }
	procedure Write(Text: string);
    { Outputs the given text to the debug console, followed by a line break. @seealso(TScriptPublic.Output) }
    procedure WriteLine(Text: string);

(*    { Returns a @html(<a href="http://www.ztwiki.com/tiki-index.php?page=u_ZbarCOM">ZBarCOM.Zaap</a>) 
	 object. }
	property  zbar: OleVariant;
*)	
	{ Returns a @html(<a href="http://msdn.microsoft.com/en-us/library/z9ty6h50.aspx">Scripting.FileSystemObject</a>) object. }
	property  FSO: OleVariant         read GetFSO;
    { Returns a @html(<a href="http://msdn.microsoft.com/en-us/library/1ft05taf.aspx">Scripting.File</a>) 
	  or a @html(<a href="http://msdn.microsoft.com/en-us/library/1c87day3.aspx">Scripting.Folder</a>) 
	  object representing the item that is currently selected in ZTreeWin. }
    property  &File: OleVariant    read GetFile;
    { Returns a @html(<a href="http://msdn.microsoft.com/en-us/library/1ft05taf.aspx">Scripting.File</a>) 
	  or a @html(<a href="http://msdn.microsoft.com/en-us/library/1c87day3.aspx">Scripting.Folder</a>) 
      object representing the item that is currently selected in the opposite pane of ZTreeWin, 
	  if in F8 split view mode.  When not in split view mode, this property returns Null 
	  (@bold(Nothing) in VBScript). }
    property  OtherFile: OleVariant   read GetOtherFile;
  end;
  {$METHODINFO OFF}


implementation

uses
  SysUtils, ComObj, ObjComAuto, Variants, Windows,
  L_ScriptingUtils, L_StringUtils,
  U_Globals, U_ScriptHost;

{ ============================================================================ }
{ TScript }

{ ---------------------------------------------------------------------------- }
constructor TScript.Create(Path: string);
begin
  Create(nil, Path);
end;
{ ---------------------------------------------------------------------------- }
constructor TScript.Create(Parent: TLogEmitter; Path: string);
begin
  if Assigned(Parent) and Assigned(Parent.OnLog) then begin
    FOnLog := Parent.OnLog;
  end;

  FCommands := TStringList.Create;
  FCommands.CaseSensitive := False;
  FKeys := TStringList.Create;
  FProcedures := TStringList.Create;

  Enabled := True;

  FPath := Path;
  FPublic := TScriptPublic.Create(Self);
  LoadFromFile(Path);
end;
{ ---------------------------------------------------------------------------- }
destructor TScript.Destroy;
begin
  VarClear(FEngine);
  FreeAndNil(FPublic);

  FreeAndNil(FCommands);
  FreeAndNil(FKeys);
  FreeAndNil(FProcedures);

  inherited;
end;

{ ---------------------------------------------------------------------------- }
procedure TScript.LoadFromFile(Path: string);
var
  FS: TFileStream;
  Buffer: TBytes;
  Encoding: TEncoding;
  Offset: integer;
  ModuleIndex, ProcIndex: integer;
  Module, Proc: OleVariant;
begin
  VarClear(FCommandObject);
  VarClear(FKeypressObject);
  VarClear(FUpdateObject);
  VarClear(FEngine);

  FPath := Path;
  if FName = '' then begin
    FName := ExtractFileName(FPath);
  end;

  // Load the file (taking any BOM into account)
  FS := TFileStream.Create(FPath, fmOpenRead);
  try
    SetLength(Buffer, FS.Size);
    FS.ReadBuffer(pointer(Buffer)^, Length(Buffer));
    Offset := TEncoding.GetBufferEncoding(Buffer, Encoding);
    FSource := Encoding.GetString(Buffer, Offset, Length(Buffer) - Offset);
    SetLength(Buffer, 0);
  finally
    FS.Free;
  end;

  // Request a scripting engine instance from the ScriptManager
  FEngine := ScriptHost.ScriptManager.GetEngine(ScriptLanguageFromExtension(FPath), True);

  FEngine.AddObject('ScriptEnvironment', TObjectDispatch.Create(TScriptEnvironment.Create(Self)) as IDispatch, True);
  FEngine.AddObject('Script', TObjectDispatch.Create(FPublic, False) as IDispatch, False);
  FEngine.AddObject('zbar', U_Globals.ZBar, False);
  try
    FEngine.AddCode(FSource);
  except
    on E: EOleError do begin
      if FEngine.Error.Number <> 0 then begin
        WriteToLog(Format('%s %s on line %s, col %s:'#13#10'"%s" (%s)',
                          [E.ClassName, FEngine.Error.Number,
                          FEngine.Error.Line, FEngine.Error.Column,
                          FEngine.Error.Description, FEngine.Error.Source]),
                    llError, 0);
      end;
    end;
    on E: Exception do begin
      raise;
    end;
  end;

  // Go through the modules and procedures, and store the module of each
  // first 'onAssist', 'onKeyPress', and 'onUpdate' procedure
  for ModuleIndex := 1 to FEngine.Modules.Count do begin
    Module := FEngine.Modules.Item[ModuleIndex];
    for ProcIndex := 1 to Module.Procedures.Count do begin
      Proc := Module.Procedures.Item[ProcIndex];
      if SameText(Module.Name, 'Global') then begin
        FProcedures.Add(Proc.Name);
      end else begin
        FProcedures.Add(Module.Name + '.' + Proc.Name);
      end;
      case IndexOfString(Proc.Name, ['onAssist', 'onKeyPress', 'onUpdate']) of
        0: begin // onCommand
          if VarIsClear(FCommandObject) then begin
            FCommandObject := Module.CodeObject;
          end;
        end;
        1: begin // onKeyPress
          if VarIsClear(FKeypressObject) then begin
            FKeypressObject := Module.CodeObject;
          end;
        end;
        2: begin // onUpdate
          if VarIsClear(FUpdateObject) then begin
            FUpdateObject := Module.CodeObject;
          end;
        end;
      end;
    end;
  end;
end;

{ ---------------------------------------------------------------------------- }
procedure TScript.SetName(Value: string);
begin
  FName := Value;
  // TODO: raise event?
end;

{ ---------------------------------------------------------------------------- }
procedure TScript.SetSource(Code: string);
begin
  FSource := Code;
  // TODO: reinitialize the engine
end;

{ ---------------------------------------------------------------------------- }
function TScript.HandlesCommand(Command: string): boolean;
begin
  Result := (not VarIsClear(FCommandObject)) and (FCommands.IndexOf(Command) > -1);
end;

{ ---------------------------------------------------------------------------- }
function TScript.HandlesKeyPress(KeyCode: integer; Alt: boolean): boolean;
var
  Code: Cardinal;
begin
  Code := KeyCode;
  if Alt then
    Code := Code or $80000000;
  Result := (not VarIsClear(FKeypressObject))
            and ((FKeys.Count = 0) or (FKeys.IndexOfObject(TObject(Code)) > -1));
end;

{ ---------------------------------------------------------------------------- }
function TScript.HandlesUpdate(): boolean;
begin
  Result := not VarIsClear(FUpdateObject);
end;

{ ---------------------------------------------------------------------------- }
function TScript.DoCommand(Command: string): OleVariant;
begin
  if not VarIsClear(FCommandObject) then begin
    Result := FCommandObject.onAssist(Command);
  end;
end;

{ ---------------------------------------------------------------------------- }
procedure TScript.DoKeyPress(KeyCode: integer; Alt: boolean);
begin
  if not VarIsClear(FKeypressObject) then begin
    FKeypressObject.onKeyPress(KeyCode, Alt);
  end;
end;

{ ---------------------------------------------------------------------------- }
procedure TScript.DoUpdate(ZBar: OleVariant);
begin
  if not VarIsClear(FUpdateObject) then begin
    FUpdateObject.onUpdate(ZBar);
  end;
end;

{ ---------------------------------------------------------------------------- }
function TScript.GetIsLibrary: boolean;
begin
  Result := VarIsClear(FCommandObject) and VarIsClear(FKeypressObject) and VarIsClear(FUpdateObject);
end;


{ ============================================================================ }
{ TScriptPublic }

{ ---------------------------------------------------------------------------- }
constructor TScriptPublic.Create(Parent: TScript);
begin
  FParent := Parent;
end;

{ ---------------------------------------------------------------------------- }
destructor TScriptPublic.Destroy;
begin

  inherited;
end;

{ ---------------------------------------------------------------------------- }
procedure TScriptPublic.Import(Filename: string);
begin
  // TODO
end;

{ ---------------------------------------------------------------------------- }
function TScriptPublic.RegisterCommand(Command: string): boolean;
begin
  // Get permission from the script manager to register this command
  Result := not Assigned(ScriptHost.ScriptManager.GetScriptForCommand(Command));
  if Result then begin
    FParent.FCommands.Add(Command);
  end;
end;

{ ---------------------------------------------------------------------------- }
function TScriptPublic.RegisterKey(KeyCode: integer; Alt: boolean): boolean;
var
  Code: Cardinal;
  Key: string;
begin
  if not FParent.HandlesKeyPress(KeyCode, Alt) then begin
    Code := KeyCode;
    Key := Chr(KeyCode);
    if Alt then begin
      Code := Code or $80000000;
      Key := 'Alt-' + Key;
    end;
    FParent.FKeys.AddObject(Key, TObject(Code));
  end;
  Result := True; // TODO: get permission from the script manager to register this key?
end;

{ ---------------------------------------------------------------------------- }
function TScriptPublic.GetPath: string;
begin
  Result := FParent.FPath;
end;

{ ---------------------------------------------------------------------------- }
function TScriptPublic.GetName: string;
begin
  Result := FParent.Name;
end;

{ ---------------------------------------------------------------------------- }
procedure TScriptPublic.SetName(Value: string);
begin
  FParent.Name := Value;
end;


{ ============================================================================ }
{ TScriptGlobal }

{ ---------------------------------------------------------------------------- }
constructor TScriptEnvironment.Create(Script: TScript);
begin
  FScript := Script;
end;

{ ---------------------------------------------------------------------------- }
function TScriptEnvironment.GetFile: OleVariant;
begin
  Result := U_Globals.ThisFile;
end;

{ ---------------------------------------------------------------------------- }
function TScriptEnvironment.GetFSO: OleVariant;
begin
  Result := U_Globals.FSO;
end;

{ ---------------------------------------------------------------------------- }
function TScriptEnvironment.GetOtherFile: OleVariant;
begin
  Result := U_Globals.OtherFile;
end;

{ ---------------------------------------------------------------------------- }
procedure TScriptEnvironment.Alert(Text: string);
var
  hWnd: THandle;
  Title: string;
begin
  hWnd := ZBar.ZTreeHWnd;
  if not IsWindow(hWnd) then begin
    hWnd := GetDesktopWindow;
  end;
  if Assigned(FScript) then begin
    Title := FScript.Name;
  end else begin
    Title := ExtractFileName(ParamStr(0));
  end;
  MessageBox(hWnd,
             PChar(Text),
             PChar(Title),
             MB_ICONEXCLAMATION);
end;

{ ---------------------------------------------------------------------------- }
function TScriptEnvironment.Confirm(Text: string): boolean;
var
  hWnd: THandle;
  Title: string;
begin
  hWnd := ZBar.ZTreeHWnd;
  if not IsWindow(hWnd) then begin
    hWnd := GetDesktopWindow;
  end;
  if Assigned(FScript) then begin
    Title := FScript.Name;
  end else begin
    Title := ExtractFileName(ParamStr(0));
  end;
  Result := (IDOK = MessageBox(hWnd,
                               PChar(Text),
                               PChar(Title),
                               MB_OKCANCEL or MB_ICONQUESTION));
end;

{ ---------------------------------------------------------------------------- }
function TScriptEnvironment.CreateObject(ProgID: string): OleVariant;
begin
  Result := CreateOleObject(ProgID);
end;

{ ---------------------------------------------------------------------------- }
procedure TScriptEnvironment.Write(Text: string);
begin
  if Assigned(FScript) then begin
    FScript.&Public.Output := FScript.&Public.Output + Text;
  end else begin
    ScriptHost.WriteToLog(Text, llInfo, 2);
  end;
end;

{ ---------------------------------------------------------------------------- }
procedure TScriptEnvironment.WriteLine(Text: string);
begin
  Write(Text + #13#10);
end;

end.
