{******************************************************************************}
{ FileName............: PicoExecute                                            }
{ Project.............:                                                        }
{ Author(s)...........: MM                                                     }
{ Version.............: 1.02                                                   }
{------------------------------------------------------------------------------}
{  Maintains Pico scripts                                                      }
{                                                                              }
{  Copyright (C) 2003-2006  M.Majoor                                           }
{                                                                              }
{  This program is free software; you can redistribute it and/or               }
{  modify it under the terms of the GNU General Public License                 }
{  as published by the Free Software Foundation; either version 2              }
{  of the License, or (at your option) any later version.                      }
{                                                                              }
{  This program is distributed in the hope that it will be useful,             }
{  but WITHOUT ANY WARRANTY; without even the implied warranty of              }
{  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the               }
{  GNU General Public License for more details.                                }
{                                                                              }
{  You should have received a copy of the GNU General Public License           }
{  along with this program; if not, write to the Free Software                 }
{  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. }
{                                                                              }
{------------------------------------------------------------------------------}
{                                                                              }
{ Version   Date   Comment                                                     }
{  1.00   20050629 - Initial release                                           }
{  1.01   20051030 - 'Data' in Execute is released when assigned               }
{  1.02   20060120 - Data left on stack for real number corrected (%f removed) }
{******************************************************************************}
unit PicoExecute;

interface

function  ScriptLoad   (Script: string): Integer;
procedure ScriptUnload (Identifier: Integer);
function  ScriptExecute(Identifier: Integer; FunctionCall: PChar; InputParameters: OleVariant; var OutputParameters: OleVariant): Boolean;
function  ScriptMessage: string;

implementation

uses
  Classes,
  Dialogs,
  JanPico,
  SysUtils,
  Windows;

type
  TPicoScript = class(TObject)
    FPath  : string;
    FScript: TJanPico;
  private
    procedure PicoUses(Sender: TjanPico; const Include: string; var Text: string; var Handled: Boolean);
    procedure PicoExternal(Sender: TjanPico; Symbol: string);
  public
  end;

var
  PicoScripts: array of TPicoScript;
  AMessage   : string;

{------------------------------------------------------------------------------
  Params  : <Sender>   Sender
            <Include>  Pico script to include
  Returns : <Text>     The complete script as one text
            <Handled>  True if valid script

  Descript: Handles includes from Pico scripts
  Notes   : Without an extension a '.pico' extension is assumed
 ------------------------------------------------------------------------------}
procedure TPicoScript.PicoUses(Sender: TjanPico; const Include: string; var Text: string; var Handled: Boolean);
var
  Strings: TStrings;
  AddExt : string;
begin
  if ExtractFileExt(Include) = '' then
    AddExt := '.pico'
  else
    AddExt := '';
  if FileExists(FPath + Include + AddExt) then
  begin
    Strings := TStringList.Create;
    try
      Strings.LoadFromFile(FPath + Include + AddExt);
      Text := Strings.Text;
      Handled := True;
    finally
      Strings.Free;
    end
  end
  else
    Handled := False;
end;


{------------------------------------------------------------------------------
  Params  : <Sender>   Sender
            <Symbol>   External function to call
  Returns : -

  Descript: Handles external functions from Pico scripts
  Notes   : For future expansion
 ------------------------------------------------------------------------------}
procedure TPicoScript.PicoExternal(Sender: TjanPico; Symbol: string);
begin
// Example:  if Symbol='system.path' then
//             Sender.pushText(appldir);
end;


{------------------------------------------------------------------------------
  Params  : -
  Returns : <Result>   Error message

  Descript: Return error message
  Notes   :
 ------------------------------------------------------------------------------}
function ScriptMessage: string;
begin
  Result := AMessage;
end;


{------------------------------------------------------------------------------
  Params  : <Script>   Script name
  Returns : <Result>   Identifier of loaded script
                       Negative number if an error was detected
                       (use ScriptMessage to obtain the textual error)

  Descript: Load a Pico script
  Notes   :
 ------------------------------------------------------------------------------}
function ScriptLoad(Script: string): Integer;
var
  Strings: TStrings;
begin
  AMessage := '';
  SetLength(PicoScripts, Length(PicoScripts)+1);
  Result := Length(PicoScripts)-1;
  PicoScripts[Result] := TPicoScript.Create;
  PicoScripts[Result].FScript := TJanPico.Create;
  PicoScripts[Result].FScript.OnUses     := PicoScripts[Result].PicoUses;
  PicoScripts[Result].FScript.OnExternal := PicoScripts[Result].PicoExternal;
  // Read file and pass it on to Pico (which also tokenizes it)
  Strings := TStringList.Create;
  try
    PicoScripts[Result].FPath := ExtractFilePath(Script);
    Strings.LoadFromFile(Script);
    try
      PicoScripts[Result].FScript.Script := Strings.Text;
    except
      on E: Exception do
      begin
        AMessage := E.Message;
        FreeAndNil(PicoScripts[Result].FScript);
        FreeAndNil(PicoScripts[Result]);
        SetLength(PicoScripts, Length(PicoScripts)-1);
        Result := -1;
        Exit;
      end;
    end;
  finally
    Strings.Free;
  end;
  // At this point the Pico file has been tokenized and we must execute it
  // before individual functions can be called.
  // If an error occurs display it and remove the script.
  try
    PicoScripts[Result].FScript.Execute;
  except
    on E: Exception do
    begin
      AMessage := E.Message;
      FreeAndNil(PicoScripts[Result].FScript);
      FreeAndNil(PicoScripts[Result]);
      SetLength(PicoScripts, Length(PicoScripts)-1);
      Result := -1;
      Exit;
    end;
  end;
end;


{------------------------------------------------------------------------------
  Params  : <Identifier>        Identifier of loaded script
            <Call>              Function to exectute
           <InputParameters>    Input parameters (note: not all types are allowed)
  Returns : <Result>            True if no error
            <OutputParameters>  Output parameters

  Descript: Execute a Pico function
  Notes   :
 ------------------------------------------------------------------------------}
function ScriptExecute(Identifier: Integer; FunctionCall: PChar; InputParameters: OleVariant; var OutputParameters: OleVariant): Boolean;
var
  Loop      : Integer;
  StackEmpty: Boolean;
  StackNo   : Integer;
  StackStr  : AnsiString;
  Data      : TjanPicoObject;
  CurrentVar: OleVariant;
begin
  Result := False;
  if (Identifier < 0) or (Identifier >= Length(PicoScripts)) then
    Exit;
  if not Assigned(PicoScripts[Identifier]) then
    Exit;
  if not VarIsEmpty(InputParameters) then
  begin
    try
      // Push all parameters
      Loop := 0;
      if VarIsArray(InputParameters) then
        Loop := VarArrayLowBound(InputParameters, 1);
      repeat
        VarClear(CurrentVar);
        if VarIsArray(InputParameters) then
          CurrentVar := InputParameters[Loop]
        else
          CurrentVar := InputParameters;
        case VarType(CurrentVar) of
          varInteger:    PicoScripts[Identifier].FScript.PushNumber(CurrentVar);
          varBoolean:    if CurrentVar then
                          PicoScripts[Identifier].FScript.PushNumber(-1)
                        else
                          PicoScripts[Identifier].FScript.PushNumber(0);
          varByte:      PicoScripts[Identifier].FScript.PushText(CurrentVar);
          varDouble:    PicoScripts[Identifier].FScript.PushNumber(CurrentVar);
          varOleStr:    PicoScripts[Identifier].FScript.PushText(CurrentVar);
          else          begin
                          AMessage := format('Unsupported type: $%x', [VarType(CurrentVar)]);
                          Exit;
                        end;
        end;
        Inc(Loop);
      until (not VarIsArray(InputParameters)) or (Loop > VarArrayHighBound(InputParameters, 1));
    except
      on E: Exception do
      begin
        AMessage := E.Message;
        Exit;
      end;
    end;
  end;
  // Execute
  try
    PicoScripts[Identifier].FScript.ExecuteFunction(FunctionCall);
  except
    on E: Exception do
    begin
      AMessage := E.Message;
      Exit;
    end;
  end;
  if not VarIsEmpty(OutputParameters) then
  begin
    // Pop parameters
    try
      Loop := 0;
      if VarIsArray(OutputParameters) then
        Loop := VarArrayLowBound(OutputParameters, 1);
      repeat
        VarClear(CurrentVar);
        if VarIsArray(OutputParameters) then
          CurrentVar := OutputParameters[Loop]
        else
          CurrentVar := OutputParameters;
        case VarType(CurrentVar) of
          varInteger:  CurrentVar := Integer(Round(PicoScripts[Identifier].FScript.PopNumber));
          varBoolean:  CurrentVar := (PicoScripts[Identifier].FScript.PopNumber <> 0);
          varByte:     CurrentVar := PicoScripts[Identifier].FScript.PopText[1];
          varDouble:   CurrentVar := PicoScripts[Identifier].FScript.PopNumber;
          varOleStr:   CurrentVar := PicoScripts[Identifier].FScript.PopText;
          else         begin
                         AMessage := format('Unsupported type: $%x', [VarType(CurrentVar)]);
                         Exit;
                       end;
        end;
        if VarIsArray(OutputParameters) then
          OutputParameters[Loop] := CurrentVar
        else
          OutputParameters := CurrentVar;
        Inc(Loop);
      until (not VarIsArray(OutputParameters)) or (Loop > VarArrayHighBound(OutputParameters, 1));
    except
      on E: Exception do
      begin
        AMessage := E.Message;
        Exit;
      end;
    end;
  end
  else
  begin
    // If nothing is to be returned, but there is data on the stack, then display
    // it. We have to 'reverse' it because we like the top of stack displayed last
    // as the 'saystack' would.
    StackEmpty := False;
    StackStr   := '';
    StackNo    := 0;
    repeat
      try
        Data := PicoScripts[Identifier].FScript.Pop;
        try
          case Data.Kind of
            jpoNumber : if Data.Number = Round(Data.Number) then
                        begin
                          if Round(Data.Number) < 0 then
                            StackStr := format('%d %s', [Round(Data.Number), StackStr])
                          else
                            StackStr := format('$%x %s', [Round(Data.Number), StackStr]);
                        end
                        else
                          StackStr := format('%f %s', [Data.Number, StackStr]);
            jpoText   : StackStr := format('"%s" %s', [Data.Text, StackStr]);
          end;
          Inc(StackNo);
        finally
          Data.Free;
        end;
      except
        StackEmpty := True;
      end;
    until StackEmpty;
    if StackNo <> 0 then
      if StackNo > 1 then
        ShowMessage(format('ScriptExecute stack [%d]'#13 +
                           'bottom ---> top of stack'#13#13'%s', [StackNo, StackStr]))
      else
        ShowMessage(format('ScriptExecute stack [1]'#13#13'%s', [StackStr]))
  end;
  Result := True;
end;


{------------------------------------------------------------------------------
  Params  : <Identifier>   Identifier of loaded script
  Returns : -

  Descript: Unload a Pico script
  Notes   :
 ------------------------------------------------------------------------------}
procedure ScriptUnload(Identifier: Integer);
begin
  if (Identifier < 0) or (Identifier >= Length(PicoScripts)) then
    Exit;
  if Assigned(PicoScripts[Identifier].FScript) then
    FreeAndNil(PicoScripts[Identifier].FScript);
  FreeAndNil(PicoScripts[Identifier]);
end;


procedure Initialize;
begin
  PicoScripts := nil;
  AMessage := '';
end;


procedure Finalize;
var
  Loop: Integer;
begin
  if Length(PicoScripts) > 0 then
    for Loop := 0 to Length(PicoScripts)-1 do
    begin
      if Assigned(PicoScripts[Loop]) then
      begin
        if Assigned(PicoScripts[Loop].FScript) then
          PicoScripts[Loop].FScript.Free;
        PicoScripts[Loop].Free;
      end;
    end;
  PicoScripts := nil;  
end;


initialization
  Initialize;

finalization
  Finalize;
end.

