unit ULScript3u;
{v0.78 Derived from ifps3\ide-demo\ide_editor.pas but instead of form
  using datamodule. }

interface

uses
  Windows, SysUtils, Classes, Forms,
  ifps3, ifps3disasm, ifps3debug, 
  IFPS3CompExec, ifps3CEImp_StdCtrls, ifps3CEImp_Forms,
  ifps3CEImp_Default, ifps3CEImp_Controls, Dialogs;

type
  TOnWriteln = procedure(const s: string);

  TULScript = class(TDataModule)
    IFPS3DllPlugin1: TIFPS3DllPlugin;
    IFPS3CE_Controls1: TIFPS3CE_Controls;
    IFPS3CE_DateUtils1: TIFPS3CE_DateUtils;
    IFPS3CE_Std1: TIFPS3CE_Std;
    IFPS3CE_Forms1: TIFPS3CE_Forms;
    IFPS3CE_StdCtrls1: TIFPS3CE_StdCtrls;
    CompExec: TIFPS3DebugCompExec;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    procedure CompExecAfterExecute(Sender: TIFPS3CompExec);
    procedure CompExecCompile(Sender: TIFPS3CompExec);
    procedure CompExecExecute(Sender: TIFPS3CompExec);
    procedure CompExecIdle(Sender: TObject);
    procedure CompExecLineInfo(Sender: TObject; Position, Row,
      Col: Cardinal);
    procedure DataModuleDestroy(Sender: TObject);
  private
    { Private declarations }
    FResume: Boolean;
    FActiveLine: integer;
    FMessages: TStrings;
    FScriptLines: TStrings;
    FFileScriptLines: TStrings;
    FFileName: string;

    FAfterExecute: TIFPS3CompExecEvent;
    FOnCompile: TIFPS3CompExecEvent;
    FOnExecute: TIFPS3CompExecEvent;
    FOnIdle: TNotifyEvent;
    FOnOpen: TNotifyEvent;

    FOnWriteln: TOnWriteln;
    FOnMessageAdd: TOnWriteln;
    FOnNew: TNotifyEvent;
    FOnLoadFromFile: TNotifyEvent;
    FOnSaveToFile: TNotifyEvent;

    function GetMessages: TStrings;
    function GetScriptLines: TStrings;

    procedure Readln(var s: string);
    procedure Writeln(const s: string);
    procedure MessageAdd(const s: string);
    { Check if ScriptLines were modified by direct assignment since
      last load from/save to file. }
    function SaveCheck: Boolean;
    function GetModified: boolean;
    function GetFileScriptLines: TStrings;
    property FileScriptLines: TStrings read GetFileScriptLines;
  public
    { Public declarations }
    {variables}
    Usr:  pointer;
    {/variables}
    {methods}
    { Run the script with source stored in ScriptLines. The ScriptLines
      should be filled by calling Open or LoadFromFile or by assigning
      to the CommandLine property. }
    procedure Run;
    { Clear ScriptLines, fills it with create test program lines.
      Expecting assignment of new script by on of the following:
        - calling Open
        - calling LoadFromFile
        - assigning to CommandLine }
    procedure New;
    { Calls open file dialog to choose a script file to be loaded. }
    procedure Open;
    { Loads script to ScriptLines from the specified file. Called by
      Open. }
    procedure LoadFromFile(const AFileName: string);
    { Method called by Save and SaveAs methods to actually store
      the ScriptLines to the AFileName. }
    procedure SaveToFile(const AFileName: string);
    { Save ScriptLines to the file specified during the last LoadFromFile.
      If no previous filename assigned SaveAs method is called. }
    procedure Save;
    { Invokes SaveFile dialog, saves to the selecte filename. }
    procedure SaveAs;

    { Set/Reset breakpoint at given source Line number }
    procedure ToggleBreakPoint(Line: integer);
    { Debug - step into }
    procedure StepInto;
    { Debug - step over }
    procedure StepOver;
    { Compile the script stored in ScriptLines. Called from Run. }
    function Compile: boolean;
    { Execute the compiled script. Called from Run if Compile succeeded. }
    function Execute: Boolean;
    { Stop the script. }
    procedure Reset;
    procedure Decompile(var ALines: TStrings);
    {/methods}


    {properties}
    { Were ScriptLines modified since last New, SaveToFile or LoadFromFile? }
    property Modified: boolean read GetModified;
    { Messages collected during the last script run }
    property Messages: TStrings read GetMessages;
    { Source lines of the script to be run }
    property ScriptLines: TStrings read GetScriptLines;
    property FileName: string read FFileName;
    {/properties}

    {events}
    property AfterExecute: TIFPS3CompExecEvent read FAfterExecute write FAfterExecute;
    property OnCompile: TIFPS3CompExecEvent read FOnCompile write FOnCompile;
    property OnExecute: TIFPS3CompExecEvent read FOnExecute write FOnExecute;
    property OnIdle: TNotifyEvent read FOnIdle write FOnIdle;

    { When script calles writeln pascal procedure. }
    property OnWriteln: TOnWriteln read FOnWriteln write FOnWriteln;
    { When compiler/executor message added }
    property OnMessageAdd: TOnWriteln read FOnMessageAdd write FOnMessageAdd;
    { When New method called. }
    property OnNew: TNotifyEvent read FOnNew write FOnNew;
    { When new script loaded from file. }
    property OnLoadFromFile: TNotifyEvent read FOnLoadFromFile write FOnLoadFromFile;
    property OnSaveToFile: TNotifyEvent read FOnSaveToFile write FOnSaveToFile;
    {/events}
  end;

var
  ULScript: TULScript;

implementation

{$R *.dfm}

{private methods}
function TULScript.GetMessages: TStrings;
begin
  if FMessages = nil then
    FMessages := TStringList.Create;
  Result := FMessages;
end;

function TULScript.GetScriptLines: TStrings;
begin
  if FScriptLines = nil then
    FScriptLines := TStringList.Create;
  Result := FScriptLines;
end;

function TULScript.GetFileScriptLines: TStrings;
begin
  if FFileScriptLines = nil then
    FFileScriptLines := TStringList.Create;
  Result := FFileScriptLines;
end;

procedure TULScript.Writeln(const s: string);
begin
  if Assigned(FOnWriteln) then
    FOnWriteln(s);
{
  debugoutput.output.Lines.Add(S);
  debugoutput.Visible := True;
}
end;

procedure TULScript.Readln(var s: string);
begin
  s := InputBox('Script', '', '');
end;

procedure TULScript.MessageAdd(const s: string);
begin
  if Assigned(FOnMessageAdd) then
    FOnMessageAdd(s);
  Messages.Add(s);
end;

function TULScript.SaveCheck: Boolean;
begin
  if Modified then begin
    case MessageDlg('Script has not been saved, save now?', mtConfirmation, mbYesNoCancel, 0) of
      idYes: begin
        Save;
        Result := FFileName <> '';
      end;
      IDNO: begin
        Result := True;
      end;
    else
      Result := False;
    end;
  end else begin
    Result := True;
  end;
end;

function TULScript.GetModified: boolean;
begin
  Result := ScriptLines.Text <> FileScriptLines.Text;
end;
{/private methods TULScript3.}

{public methods}
procedure TULScript.Run;
begin
  if CompExec.Running then begin
    FResume := true;
  end else begin
    if Compile then
      Execute;
  end;
end;

procedure TULScript.ToggleBreakPoint(Line: integer);
begin
  if CompExec.HasBreakPoint(Line) then
    CompExec.ClearBreakPoint(Line)
  else
    CompExec.SetBreakPoint(Line);
end;

procedure TULScript.StepOver;
begin
  if CompExec.Exec.Status = isRunning then begin
    CompExec.StepOver
  end else begin
    if Compile then begin
      CompExec.StepInto;
      Execute;
    end;
  end;
end;

procedure TULScript.StepInto;
begin
  if CompExec.Exec.Status = isRunning then begin
    CompExec.StepInto
  end else begin
    if Compile then begin
      CompExec.StepInto;
      Execute;
    end;
  end;
end;

function TULScript.Compile: Boolean;
var
  i: Longint;
begin
  CompExec.Script.Assign(ScriptLines);
  Result := CompExec.Compile;
  Messages.Clear;
  for i := 0 to CompExec.CompilerMessageCount -1 do
  begin
    MessageAdd(CompExec.CompilerMessages[i].MessageToString);
  end;
  if Result then
    MessageAdd('Succesfully compiled');
end;

procedure TULScript.Reset;
begin
  if CompExec.Exec.Status = isRunning then
    CompExec.Stop;
end;

function TULScript.Execute: Boolean;
begin
//  debugoutput.Output.Clear;
  if CompExec.Execute then begin
    MessageAdd('Succesfully Executed');
    Result := True;
  end else begin
    MessageAdd('Runtime Error: '+ CompExec.ExecErrorToString +
      ' at ['+IntToStr(CompExec.ExecErrorRow)+':'+
        IntToStr(CompExec.ExecErrorCol)+'] bytecode pos:'+
        inttostr(CompExec.ExecErrorProcNo)+':'+
        inttostr(CompExec.ExecErrorByteCodePosition));
    Result := False;
  end;
end;

procedure TULScript.New;
begin
  if SaveCheck then
  begin
    FFileName := '';
    ScriptLines.Text := 'Program test;'#13#10'begin'#13#10'end.';
    FileScriptLines.Text := ScriptLines.Text;
    //ed.ClearAll;
    //ed.Modified := False;
    if Assigned(FOnNew) then
      FOnNew(Self);
  end;
end;

procedure TULScript.Open;
begin
  if SaveCheck then begin
    if OpenDialog1.Execute then
    begin
      LoadFromFile(OpenDialog1.FileName);
    end;
  end;
end;

procedure TULScript.LoadFromFile(const AFileName: string);
begin
  ScriptLines.Clear;
  ScriptLines.LoadFromFile(AFileName);
  FileScriptLines.Text := ScriptLines.Text;
  FFileName := AFileName;
  if Assigned(FOnLoadFromFile) then
    FOnLoadFromFile(Self);
  //ed.Modified := False;
end;

{ Save ScriptLines to the file specified during the last LoadFromFile.
  If no previous filename assigned, ask user using SaveAs method. }
procedure TULScript.Save;
begin
  if FFileName <> '' then begin
    SaveToFile(FFileName);
    //ed.Modified := False;
  end else begin
    SaveAs
  end;
end;

procedure TULScript.SaveToFile(const AFileName: string);
begin
  ScriptLines.SaveToFile(FFileName);
  FileScriptLines.Text := ScriptLines.Text;
  if FFileName <> AFileName then
    FFileName := AFileName;
  if Assigned(FOnSaveToFile) then
    FOnSaveToFile(Self);
  //ed.Modified := False;
end;

procedure TULScript.SaveAs;
begin
  if SaveDialog1.Execute then
    SaveToFile(SaveDialog1.FileName);
end;

procedure TULScript.Decompile(var ALines: TStrings);
var
  s: string;
begin
  if Compile then begin
    CompExec.GetCompiled(s);
    IFPS3DataToText(s, s);
    ALines.Text := s;
  end;
end;
{/public methods TULScript3.}

{CompExec Events}
procedure TULScript.CompExecAfterExecute(Sender: TIFPS3CompExec);
begin
  if Assigned(FAfterExecute) then
    FAfterExecute(Sender);
end;

procedure TULScript.CompExecCompile(Sender: TIFPS3CompExec);
begin
  if Assigned(FOnCompile) then
    FOnCompile(Sender);
  {adjusted from ide_demo: }
  Sender.AddMethod(Self, @TULScript.Writeln, 'procedure Writeln(s: string)');
  Sender.AddMethod(Self, @TULScript.Readln, 'procedure readln(var s: string)');

  Sender.AddRegisteredVariable('Self', 'TDataModule');
  Sender.AddRegisteredVariable('Application', 'TApplication');
  {/}
end;

procedure TULScript.CompExecExecute(Sender: TIFPS3CompExec);
begin
  if Assigned(FOnExecute) then
    FOnExecute(Sender);
  CompExec.SetVarToInstance('SELF', Self);
  CompExec.SetVarToInstance('APPLICATION', Application);
//  Caption := 'Editor - Running';
end;

procedure TULScript.CompExecIdle(Sender: TObject);
begin
  if Assigned(FOnIdle) then
    FOnIdle(Sender);
  Application.HandleMessage;
  if FResume then
  begin
    FResume := False;
    CompExec.Resume;
    FActiveLine := 0;
    //ed.Refresh;
  end;
end;


procedure TULScript.CompExecLineInfo(Sender: TObject; Position, Row,
  Col: Cardinal);
begin
  if CompExec.Exec.DebugMode = dmRun then begin
    FActiveLine := -1
  end else begin
    FActiveLine := Row;
    //ed.Refresh;
  end;
end;
{/CompExec Events}

procedure TULScript.DataModuleDestroy(Sender: TObject);
begin
  FMessages.Free;
  FScriptLines.Free;
  FFileScriptLines.Free;
end;

end.
