unit ULScriptFrm;{derived from ifps demo program}
{
  (C) 2000 - 2001 Jindrich Jindrich, Pavel Pisa, PiKRON Ltd.

  Originators of the CHROMuLAN project:

  Jindrich Jindrich - http://www.jindrich.com
                      http://orgchem.natur.cuni.cz/Chromulan
                      software developer, project coordinator
  Pavel Pisa        - http://cmp.felk.cvut.cz/~pisa
                      embeded software developer
  PiKRON Ltd.       - http://www.pikron.com
                      project initiator, sponsor, instrument developer

  The CHROMuLAN project is distributed under the GNU General Public Licence.
  See file COPYING for details.

  Originators reserve the right to use and publish sources
  under different conditions too. If third party contributors
  do not accept this condition, they can delete this statement
  and only GNU license will apply.
}


interface
{$I define.pas}
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Menus, StdCtrls, ExtCtrls, {$IFDEF DELPHI4}FileCtrl,{$ENDIF}
  ifspas, ifs_var, ifs_utl, ifs_obj,
  {v0.47}ULObjUsru,{/v0.47}
  {$IFDEF IFPS3}
  ULScript3u,
  {$ELSE}
  ULScriptu,
  {$ENDIF}

  UlanType{/v0.50};

type
  TULScriptForm = class(TForm)
    MainMenu1: TMainMenu;
    ScriptMemo: TMemo;
    Splitter1: TSplitter;
    File1: TMenuItem;
    New1: TMenuItem;
    Open1: TMenuItem;
    Save1: TMenuItem;
    Saveas1: TMenuItem;
    N1: TMenuItem;
    Exit1: TMenuItem;
    N2: TMenuItem;
    Script1: TMenuItem;
    Run1: TMenuItem;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    LogMemo: TMemo;
    Stop1: TMenuItem;
    N3: TMenuItem;
    Runproceduretest1: TMenuItem;
    RunwithTestObject1: TMenuItem;
    RunwithaddedVariables1: TMenuItem;
    PopupMenu1: TPopupMenu;
    File_Item: TMenuItem;
    Script_Item: TMenuItem;
    Open_Item: TMenuItem;
    New_Item: TMenuItem;
    N4: TMenuItem;
    Save_Item: TMenuItem;
    SaveAs_Item: TMenuItem;
    N5: TMenuItem;
    Exit_Item: TMenuItem;
    Run_Item: TMenuItem;
    Stop_Item: TMenuItem;
    N6: TMenuItem;
    RunWithProc_Item: TMenuItem;
    RunWithVar_Item: TMenuItem;
    RunWithClass_Item: TMenuItem;
    CmdPanel: TPanel;
    CmdEdit: TComboBox;
    Cleanup_Item: TMenuItem;
    procedure New1Click(Sender: TObject);
    procedure Open1Click(Sender: TObject);
    procedure Save1Click(Sender: TObject);
    procedure Exit1Click(Sender: TObject);
    procedure Saveas1Click(Sender: TObject);
    procedure Run1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure ScriptMemoChange(Sender: TObject);
    procedure Stop1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Runproceduretest1Click(Sender: TObject);
    procedure RunwithaddedVariables1Click(Sender: TObject);
    procedure RunwithTestObject1Click(Sender: TObject);
    procedure CmdEditKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure Cleanup_ItemClick(Sender: TObject);
  Private
    { Private declarations }
    {v0.47}
    FFileName: string;
    procedure SetUsr(AUsr: TObject);
    function GetUsr: TObject;
    function GetCmdLine: string;
    procedure SetCmdLine(const AValue: string);
    { Called only with valid filename. Loads the text of the script from the
      specified file to the Memo text. }
    procedure ScriptLoad(const AFileName: string);
    { Parses CmdLine and take the first word as a base name of a script
      file. Tries to find the file and load its content to the script's text
      using ScriptLoad method. Returns false if the file found. }
    function ScriptLoadFromCommandLine: boolean;
    procedure RunCommandLine;
    { Runs the code contained currently in the Memo lines and uses the current
      command line. }
    procedure RunActiveScript;
    {/v0.47}
  Public
    Script: TULScript;{TCs2PascalScript;}
    changed: Boolean;
    function SaveTest: Boolean;
    procedure AddLine(const s: string);
    { Public declarations }
    {v0.77}
    { Load the script from the file with base name ACmd and run it. }
    procedure ScriptLoadAndRun(ACmd: string);
    {/v0.77}
    {v0.47}
    { Holds name of the last loaded script file. }
    property FileName: string read FFileName write FFileName;
    property CmdLine: string read GetCmdLine write SetCmdLine;
    property Usr: TObject read GetUsr write SetUsr;
    {/v0.47}
  end;

const
  ULScriptForm: TULScriptForm = nil;

procedure ULScriptFormShow{v0.47}(AUsr:TObject){/v0.47};

implementation
{v0.50}
Uses Channelsu;
{/v0.50}
{v0.47}{/v0.47
uses
  ULScriptPaintFrm, ifpslib, ifsdfrm, ifsctrlstd, ifpscom, ifpstrans,
  ifpsdll, ifpsdelphi;}

{$R *.dfm}

procedure ULScriptFormShow{v0.47}(AUsr: TObject){/v0.47};
begin
  if ULScriptForm = nil then
    ULScriptForm := TULScriptForm.Create(Application);
  {v0.47}
  ULScriptForm.Usr := AUsr;
  {/v0.47}
  ULScriptForm.Show;
end;

{v0.47}
procedure ScriptFormLog(s: string);
begin
  ULScriptForm.AddLine(s);
end;
{/v0.47
function RegProc(Sender: TIfPasScript; ScriptID: Pointer; proc: PProcedure; Params: PVariableManager; res: PIfVariant): TIfPasScriptError;
begin
  if proc^.Name = 'WRITELN' then begin
    ULScriptForm.AddLine(GetString(Vm_Get(Params, 0)));
  end else if proc^.Name = 'READLN' then begin
    GetVarLink(Vm_Get(Params, 0))^.Cv_Str := InputBox('Demo', 'Readln:', '');
  end else if proc^.Name = 'RANDOM' then begin
    SetInteger(res, random(GetInteger(Vm_Get(Params, 0))));
  end;
  Result := ENoError;
end;

function PaintRegProc(Sender: TIfPasScript; ScriptID: Pointer; proc: PProcedure; Params: PVariableManager; res: PIfVariant): TIfPasScriptError;
var
  I: Integer;
  r: TRect;
begin
  if proc^.Name = 'SHOWPAINTWINDOW' then begin
    PaintForm.ClientWidth := GetInteger(GetVarLink(Vm_Get(Params, 0)));
    PaintForm.ClientHeight := GetInteger(GetVarLink(Vm_Get(Params, 1)));
    PaintForm.Bitmap.Width := PaintForm.ClientWidth;
    PaintForm.Bitmap.Height := PaintForm.ClientHeight;
    PaintForm.Show;
    PaintForm.DoUpdate;
  end else if proc^.Name = 'HIDEPAINTWINDOW' then
    PaintForm.Hide
  else if proc^.Name = 'UPDATE' then begin
    PaintForm.DoUpdate;
    Application.ProcessMessages;
  end else if proc^.Name = 'CLEAR' then begin
    PaintForm.Bitmap.Canvas.Brush.Style := bsSolid;
    PaintForm.Bitmap.Canvas.Brush.Color := GetInteger(GetVarLink(Vm_Get(Params, 0)));
    PaintForm.Bitmap.Canvas.FillRect(Rect(0, 0, PaintForm.ClientWidth, PaintForm.ClientHeight));
  end else if proc^.Name = 'LINE' then begin
    PaintForm.Bitmap.Canvas.Pen.Color := GetInteger(GetVarLink(Vm_Get(Params, 4)));
    PaintForm.Bitmap.Canvas.MoveTo(GetInteger(GetVarLink(Vm_Get(Params, 0))), GetInteger(GetVarLink(Vm_Get(Params, 1))));
    PaintForm.Bitmap.Canvas.LineTo(GetInteger(GetVarLink(Vm_Get(Params, 2))), GetInteger(GetVarLink(Vm_Get(Params, 3))));
  end else if proc^.Name = 'CIRCLE' then begin
    PaintForm.Bitmap.Canvas.Pen.Color := GetInteger(GetVarLink(Vm_Get(Params, 3)));
    PaintForm.Bitmap.Canvas.Brush.Style := bsClear;
    I := GetInteger(GetVarLink(Vm_Get(Params, 2)));
    PaintForm.Bitmap.Canvas.Ellipse(GetInteger(GetVarLink(Vm_Get(Params, 0))) - I, GetInteger(GetVarLink(Vm_Get(Params, 1))) - I, GetInteger(GetVarLink(Vm_Get(Params, 0))) + I, GetInteger(GetVarLink(Vm_Get(Params, 1))) + I);
    ;
  end else if proc^.Name = 'RECTANGLE' then begin
    PaintForm.Bitmap.Canvas.Pen.Color := GetInteger(GetVarLink(Vm_Get(Params, 4)));
    PaintForm.Bitmap.Canvas.Rectangle(GetInteger(GetVarLink(Vm_Get(Params, 0))), GetInteger(GetVarLink(Vm_Get(Params, 1))), GetInteger(GetVarLink(Vm_Get(Params, 2))), GetInteger(GetVarLink(Vm_Get(Params, 3))));
  end else if proc^.Name = 'FILLEDRECTANGLE' then begin
    PaintForm.Bitmap.Canvas.Brush.Style := bsSolid;
    PaintForm.Bitmap.Canvas.Brush.Color := GetInteger(GetVarLink(Vm_Get(Params, 4)));
    r := Rect(GetInteger(GetVarLink(Vm_Get(Params, 0))), GetInteger(GetVarLink(Vm_Get(Params, 1))), GetInteger(GetVarLink(Vm_Get(Params, 2))), GetInteger(GetVarLink(Vm_Get(Params, 3))));
    PaintForm.Bitmap.Canvas.FillRect(r);
  end;
  Result := ENoError;
end;

function ImportTest(S1: string; s2: Longint; s3: Byte; s4: word; var s5: string): string;
begin
  Result := s1 + ' ' + IntToStr(s2) + ' ' + IntToStr(s3) + ' ' + IntToStr(s4) + ' - OK!';
  S5 := result + ' - OK2!';
end;

function OnUses(id: Pointer; Sender: TIfPasScript; Name: string): TCs2Error;
var
  f: TIFPasScript;
  n: TFileStream;
  s: string;
begin
  if Name = 'SYSTEM' then begin
    RegisterStdLib(Sender, False);
    RegisterTIfStringList(Sender);
    RegisterComLibrary(Sender);
    RegisterTransLibrary(Sender);
    RegisterFormsLibrary(Sender);
    RegisterStdControlsLibrary(Sender);
    RegisterDllCallLibrary(Sender);
    RegisterDelphiFunction(Sender, 'function ImportTest(S1:string;s2:Longint;s3:Byte;s4:Word;var s5:string):string;', @importTest);
    Sender.AddFunction(@RegProc, 'procedure Writeln(s: string)', nil);
    Sender.AddFunction(@RegProc, 'procedure Readln(var s: string)', nil);
    Sender.AddFunction(@RegProc, 'function Random(I: Longint): Longint', nil);
    Result := ENoError;
  end else if Name = 'GRAPH' then begin
    Sender.AddFunction(@PaintRegProc, 'procedure ShowPaintWindow(x,y : integer)', nil);
    Sender.AddFunction(@PaintRegProc, 'procedure Clear(Color: Integer);', nil);
    Sender.AddFunction(@PaintRegProc, 'procedure Update;', nil);
    Sender.AddFunction(@PaintRegProc, 'procedure Line(x1,y1,x2,y2,color: Integer);', nil);
    Sender.AddFunction(@PaintRegProc, 'procedure Circle(x,y,r,color: Integer);', nil);
    Sender.AddFunction(@PaintRegProc, 'procedure Rectangle(x1,y1,x2,y2,color: Integer);', nil);
    Sender.AddFunction(@PaintRegProc, 'procedure FilledRectangle(x1,y1,x2,y2,color: Integer);', nil);
    Sender.AddFunction(@PaintRegProc, 'procedure HidePaintWindow;', nil);
    Result := ENoError;
  end else
  begin
    F := TIFPasScript.Create(nil);
    try
      n := TFileStream.Create(Name+ IFSExt, FMOpenRead or FMShareDenyWrite);
      setLength(s, n.Size);
      n.Read(s[1], Length(S));
      n.Free;
    except
      Result := EUnitNotFound;
      exit;
    end;
    f.OnUses := OnUses;
    f.SetText(s);
    if f.ErrorCode <> ENoError then
    begin
      Sender.RunError2(f, f.ErrorCode, f.ErrorString);
      f.Free;
      Result := EUnitNotFound;
    end else
    begin
      if not Sender.Attach(F) then
      begin
        f.Free;
        Result := ECustomError;
      end else
        Result := ENoError;
    end;
  end;
end;
}
procedure TULScriptForm.New1Click(Sender: TObject);
begin
  if not SaveTest then exit;
  ScriptMemo.Lines.Text := 'Program IFSTest;'#13#10'Begin'#13#10'End.';
  LogMemo.Lines.Clear;
  FileName := '';
end;

procedure TULScriptForm.AddLine(const s: string);
begin
  LogMemo.Lines.Add(s);
end;

function TULScriptForm.SaveTest: Boolean;
begin
  if changed then begin
    case MessageDlg('File is not saved, save now?', mtWarning, mbYesNoCancel, 0) of
      mrYes: begin
          Save1Click(nil);
          Result := not changed;
        end;
      mrNo: Result := True;
    else
      Result := False;
    end;
  end else
    Result := True;
end;

procedure TULScriptForm.Open1Click(Sender: TObject);
begin
  if not SaveTest then
    exit;
  if not DirectoryExists(ScriptsDir) then
    CreateDir(ScriptsDir);
  OpenDialog1.InitialDir := ScriptsDir;
  if OpenDialog1.Execute then begin
    {v0.47}
    ScriptLoad(OpenDialog1.FileName);
    CmdLine := ChangeFileExt(ExtractFileName(OpenDialog1.FileName),'');
    {/v0.47
    ScriptMemo.Lines.LoadFromFile(OpenDialog1.FileName);
    changed := False;
    LogMemo.Lines.Clear;
    FileName := OpenDialog1.FileName;
    }
  end;
end;

procedure TULScriptForm.Save1Click(Sender: TObject);
begin
  if FileName = '' then begin
    Saveas1Click(nil);
  end else begin
    ScriptMemo.Lines.SaveToFile(FileName);
    changed := False;
  end;
end;

procedure TULScriptForm.Exit1Click(Sender: TObject);
begin
  Close;
end;

procedure TULScriptForm.Saveas1Click(Sender: TObject);
begin
  SaveDialog1.FileName := '';
  SaveDialog1.InitialDir := ScriptsDir;
  if SaveDialog1.Execute then begin
    FileName := SaveDialog1.FileName;
    ScriptMemo.Lines.SaveToFile(FileName);
    changed := False;
  end;
end;

procedure TULScriptForm.RunActiveScript;
begin
  if Tag <> 0 then
    exit;
  Tag := 1;
  try
    LogMemo.Clear;
    {v0.50}
    {Script.Usr := Channels.FindChannel(pvUlanDefaultChannel);}
    {/v0.50}
    Script.SetText(ScriptMemo.Text);
    Script.CommandLine := CmdLine;
    if Script.ErrorCode = ENoError then begin
      AddLine('Script is running.');
      Script.RunScript;
    end;
    if Script.ErrorCode = ENoError then begin
      AddLine('Script finished, no errors.');
    end else begin
      AddLine(Script.ErrorMsg);
      //AddLine('Error in '+Script.ErrorModule+'('+IntToStr(Script.ErrorPos)+') '+ErrorToString(Script.ErrorCode, Script.ErrorString));
      ScriptMemo.SelStart := Script.ErrorPos;
    end;
  finally
    Tag := 0;
  end;
  {Script.Cleanup;}
end;

procedure TULScriptForm.Run1Click(Sender: TObject);
begin
  RunActiveScript;
end;

{v0.47}{/v0.47
function OnRunLine(id: Pointer; Sender: TIfPasScript; Position: Longint): TCs2Error;
begin
  Application.ProcessMessages;
  if ULScriptForm.Tag = 2 then
    Result := EExitCommand
  else
    Result := Sender.ErrorCode;
end;
}
procedure TULScriptForm.FormCreate(Sender: TObject);
begin
  {$IFDEF IFPS3}
  Script := TULScript.Create(nil);
  Script.OnWriteln := ScriptFormLog;
  Script.OnMessageAdd := ScriptFormLog;
  {$ELSE}
  Script := TULScript{TCs2PascalScript}.Create(nil, nil);
  {$ENDIF}
  {v0.47}
  Script.LogProc := ScriptFormLog{AddLine};
  {/v0.47
  Script.OnRunLine := OnRunLine;
  Script.OnUses := OnUses;
  Script.MaxBeginNesting := 1000;}
  FileName := '';
  changed := False;
  Randomize;
end;

procedure TULScriptForm.FormDestroy(Sender: TObject);
begin
  ULScriptForm := nil;
  try
    Script.Free;
  except
    ShowMessage('Error ???');
  end;
end;

procedure TULScriptForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  CanClose := SaveTest;
end;

procedure TULScriptForm.ScriptMemoChange(Sender: TObject);
begin
  changed := True;
  ScriptMemo.Tag := 1;
end;

procedure TULScriptForm.Stop1Click(Sender: TObject);
begin
  if Tag = 1 then begin
    {v0.47}
    Script.Abort;
    {/v0.47
    Tag := 2;}
  end;
end;

procedure TULScriptForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  if Tag = 1 then begin
    {v0.47}
    Script.Abort;
    {/v0.47
    Tag := 2;}
  end;
  {}Action := caFree;{/}
end;

procedure TULScriptForm.RunProcedureTest1Click(Sender: TObject);
  {$IFNDEF IFPS3}
  procedure RunScriptProc;
  var
    p: PProcedure;
    v: PVariableManager;
  begin
    p := Script.GetFunction('TEST');
    if p = nil then begin
      AddLine('procedure test; not found!');
    end else begin
      v := VM_Create(nil);
      DestroyCajVariant(Script.RunScriptProc(p, v));
      VM_Destroy(v);
    end;
  end;
  {$ENDIF}

begin
  {$IFNDEF IFPS3}
  if Tag <> 0 then
    exit;
  Tag := 1;
  try
    LogMemo.Clear;
    Script.SetText(ScriptMemo.Text);
    if Script.ErrorCode = ENoError then begin
      AddLine('Script is running.');
      RunScriptProc;
    end;
    if Script.ErrorCode = ENoError then begin
      AddLine('Script finished, no errors.');
    end else begin
      AddLine(ErrorToString(Script.ErrorCode, Script.ErrorString));
      ScriptMemo.SelStart := Script.ErrorPos;
    end;
  finally
    Tag := 0;
  end;
{  Script.Cleanup;}
  {$ENDIF}
end;

procedure TULScriptForm.RunWithAddedVariables1Click(Sender: TObject);
begin
  {$IFNDEF IFPS3}
  if Tag <> 0 then
    exit;
  Tag := 1;
  try
    LogMemo.Clear;
    Script.SetText(ScriptMemo.Text);
    if Script.ErrorCode = ENoError then begin
      AddLine('Script is running.');
      Script.AddVariable('Demo', 'String', False)^.Cv_Str := 'Demo 1.0';
      Script.RunScript;
    end;
    if Script.ErrorCode = ENoError then begin
      AddLine('Script finished, no errors.');
    end else begin
      AddLine(ErrorToString(Script.ErrorCode, Script.ErrorString));
      ScriptMemo.SelStart := Script.ErrorPos;
    end;
  finally
    Tag := 0;
  end;
{  Script.Cleanup;}
  {$ENDIF}
end;

procedure TULScriptForm.RunWithTestObject1Click(Sender: TObject);
  {$IFNDEF IFPS3}

  procedure RunScriptClass;
  var
    p: PTypeRec;
    n: PIfVariant;
    v: PVariableManager;
    Func: PProcedure;
  begin
    p := Script.GetType('TIFStringList');
    if p = nil then begin
      AddLine('Strange. The TIFStringList type is not found!');
    end else begin
      if not GetClassProcedure(nil, p^.Ext, 'CREATE', Func, False) then begin
        AddLine('Can not find TIFStringList.Create (weird error) !');
      end else begin
        v := VM_Create(nil);
        Vm_Add(v, nil, '');
        n := Script.RunScriptConstructor(p, Func, v);
        VM_Destroy(v);
        if n <> nil then begin
          Script.AddVariable('MyStringList', 'TIFStringList', False)^.CV_Class := n^.CV_Class;
          DestroyCajVariant(n);
        end;
      end;
    end;
  end;
  {$ENDIF}
begin
  {$IFNDEF IFPS3}
  if Tag <> 0 then
    exit;
  Tag := 1;
  try
    LogMemo.Clear;
    Script.SetText(ScriptMemo.Text);
    if Script.ErrorCode = ENoError then begin
      AddLine('Script is running.');
      RunScriptClass;
      if Script.ErrorCode = ENoError then
        Script.RunScript;
    end;
    if Script.ErrorCode = ENoError then begin
      AddLine('Script finished, no errors.');
    end else begin
      AddLine(ErrorToString(Script.ErrorCode, Script.ErrorString));
      ScriptMemo.SelStart := Script.ErrorPos;
    end;
  finally
    Tag := 0;
  end;
{  Script.Cleanup;}
  {$ENDIF}
end;

{v0.47}
function TULScriptForm.GetCmdLine: string;
begin
  Result := CmdEdit.Text;
end;

procedure TULScriptForm.SetCmdLine(const AValue: string);
begin
  CmdEdit.Text := AValue;
end;

procedure TULScriptForm.ScriptLoad(const AFileName: string);
begin
  ScriptMemo.Lines.LoadFromFile(AFileName);
  changed := False;
  LogMemo.Lines.Clear;
  FileName := AFileName;
end;

function TULScriptForm.ScriptLoadFromCommandLine: boolean;
var
  n: string;
  i: integer;
  fn: string;
begin
  Result := false;
  n := CmdLine;
  if (n <> '') then begin
    i := pos(' ', n);
    if i > 0 then
      n := copy(n, 1, i - 1);
    if ExtractFilePath(n) = '' then begin
      fn := FileSearch(n + IFSExt, Script.ScriptsDirList);
      {fn := ScriptsDir + n}
    end else
      fn := n;
    fn := ChangeFileExt(fn, IFSExt);
    if FileExists(fn) then begin
      ScriptLoad(fn);
      Result := true;
    end;
  end;
end;

procedure TULScriptForm.RunCommandLine;
var s: string;
begin
  if ScriptLoadFromCommandLine then begin
    RunActiveScript;
    s := trim(CmdLine);
    if CmdEdit.Items.IndexOf(s) < 0 then
      CmdEdit.Items.Add(s);
  end else begin
    ShowMessage('Unrecognized command: ' + CmdLine);
  end;
end;

procedure TULScriptForm.CmdEditKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  case Key of
    vk_Return: begin
      RunCommandLine;
      Key := 0;
    end;
    vk_Space: begin {windows}
      ScriptLoadFromCommandLine;
    end;
  end;
  inherited;
end;

procedure TULScriptForm.SetUsr(AUsr: TObject);
begin
  Script.Usr := AUsr;
end;

function TULScriptForm.GetUsr: TObject;
begin
  Result := Script.Usr;
end;

{/v0.47}

procedure TULScriptForm.Cleanup_ItemClick(Sender: TObject);
begin
  Script.Cleanup;
end;

{v0.77}
procedure TULScriptForm.ScriptLoadAndRun(ACmd: string);
begin
  CmdLine := ACmd;
  RunCommandLine;
end;
{/v0.77}

end.

