Chip 2001 December/Chip_2001-12_cd1.bin/zkuste/delphi/kompon/d23456/CAJSCRTP.ZIP/demo_del/demo1.pas

Pascal/Delphi Source File | 2001-10-03 | 16.5 KB | 559 lines

unit demo1;

interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ifspas, ifs_var, ifs_utl, ifs_obj, Menus, StdCtrls, ExtCtrls;

type
  TMain = class(TForm)
    MainMenu1: TMainMenu;
    Memo1: 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;
    Memo2: TMemo;
    Stop1: TMenuItem;
    N3: TMenuItem;
    Runproceduretest1: TMenuItem;
    RunwithTestObject1: TMenuItem;
    RunwithaddedVariables1: TMenuItem;
    N4: TMenuItem;
    RunWithTimer1: TMenuItem;
    StepOver1: 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 Memo1Change(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 RunWithTimer1Click(Sender: TObject);
    procedure StepOver1Click(Sender: TObject);
  Private
    { Private declarations }
  Public
    ps: TIFPasScript;
    fn: string;
    changed: Boolean;
    function SaveTest: Boolean;
    procedure AddLine(s: string);
    { Public declarations }
  end;

type
  TIStatus = (iStopped, iRunning, iStepOver, iStepOverWaiting);

var
  Main: TMain;
  iStatus: TIStatus;
  LastLine: Longint;

implementation
uses
  demo2, ifpsdll, ifpsdelphi, ifpsdll2, ifsctrlstd, ifpslib, ifsdfrm, ifpscom, ifpstrans, ifpsdate;
{$R *.dfm}

procedure TMain.New1Click(Sender: TObject);
begin
  if not SaveTest then exit;
  Memo1.Lines.Text := 'Program IFSTest;'#13#10'Begin'#13#10'End.';
  Memo2.Lines.Clear;
  fn := '';
end;

procedure TMain.AddLine(s: string);
begin
  Memo2.Lines.Add(s);
end;

function TMain.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 TMain.Open1Click(Sender: TObject);
begin
  if not SaveTest then exit;
  if OpenDialog1.Execute then begin
    Memo1.Lines.LoadFromFile(OpenDialog1.FileName);
    changed := False;
    Memo2.Lines.Clear;
    fn := OpenDialog1.FileName;
  end;
end;

procedure TMain.Save1Click(Sender: TObject);
begin
  if fn = '' then begin
    Saveas1Click(nil);
  end else begin
    Memo1.Lines.SaveToFile(fn);
    changed := False;
  end;
end;

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

procedure TMain.Saveas1Click(Sender: TObject);
begin
  SaveDialog1.FileName := '';
  if SaveDialog1.Execute then begin
    fn := SaveDialog1.FileName;
    Memo1.Lines.SaveToFile(fn);
    changed := False;
  end;
end;

procedure TMain.Run1Click(Sender: TObject);
begin
  if (istatus = iStepOverWaiting) then
  begin
    istatus := IRunning;
  end;
  if (istatus <> iStopped) then Exit;
  istatus := iRunning;
  try
    Memo2.Clear;
    ps.SetText(Memo1.Text);
    if ps.ErrorCode = ENoError then begin
      AddLine('Script is running.');
      ps.RunScript;
    end;
    if ps.ErrorCode = ENoError then begin
      AddLine('Script finished, no errors.');
    end else begin
      AddLine('Error in '+ps.ErrorModule+'('+IntToStr(ps.ErrorPos)+') '+ErrorToString(ps.ErrorCode, ps.ErrorString));
      Memo1.SelStart := ps.ErrorPos;
    end;
  finally
    istatus := iStopped;
  end;
  ps.Cleanup;
end;

function RegProc(Sender: TIfPasScript; ScriptID: Pointer; proc: PProcedure; Params: PVariableManager; res: PIfVariant): TIfPasScriptError;
begin
  if proc^.Name = 'WRITELN' then begin
    Main.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);
    RegisterExceptionLib(Sender);
    RegisterDll2library(Sender);
    RegisterDateTimeLib(Sender);

    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+'.IFS', 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;

function GetLine(const text: string; pos: Longint): Longint;
var
  i: Integer;
begin
  Result := 1;
  for i := 1 to pos do
    if text[i] = #10 then inc(result); // should work under linux too
end;
function OnRunLine(id: Pointer; Sender: TIfPasScript; Position: Longint): TCs2Error;
var
  i: Longint;
begin
  Application.ProcessMessages;
  Result := ENoError;

  case iStatus of
    istopped: Result := EExitCommand;
    iStepOver:
    begin
      i := GetLine(Main.Memo1.Text, Position);
      if i <> LastLine then begin
        istatus := istepoverwaiting;
        lastline := i;
        Main.Memo1.SelStart := Position;
        Main.Memo1.SelLength := 1;
        while istatus = istepoverwaiting do
           Application.ProcessMessages;
      end;
    end;
  end;
end;

procedure TMain.FormCreate(Sender: TObject);
begin
  ps := TIfPasScript.Create(nil);
  ps.OnRunLine := OnRunLine;
  ps.OnUses := OnUses;
  ps.MaxBeginNesting := 1000;
  ps.OnExternal := DllExternalProc;
  fn := '';
  changed := False;
  Randomize;
end;

procedure TMain.FormDestroy(Sender: TObject);
begin
  try
    ps.Free;
  except
    ShowMessage('Error ???');
  end;
end;

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

procedure TMain.Memo1Change(Sender: TObject);
begin
  changed := True;
  Memo1.Tag := 1;
end;

procedure TMain.Stop1Click(Sender: TObject);
begin
  if istatus <> istopped then istatus := istopped;
end;

procedure TMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  if istatus <> istopped then istatus := istopped;
end;

procedure TMain.Runproceduretest1Click(Sender: TObject);

  procedure RunScriptProc;
  var
    p: PProcedure;
    v: PVariableManager;
  begin
    p := ps.GetFunction('TEST');
    if p = nil then begin
      AddLine('procedure test; not found!');
    end else begin
      v := VM_Create;
      DestroyCajVariant(ps.RunScriptProc(p, v));
      VM_Destroy(v);
    end;
  end;
begin
  if (istatus = iStepOverWaiting) then
  begin
    istatus := IStepOver;
  end;
  if (istatus <> iStopped) then Exit;
  istatus := iRunning;
  try
    Memo2.Clear;
    ps.SetText(Memo1.Text);
    if ps.ErrorCode = ENoError then begin
      AddLine('Script is running.');
      RunScriptProc;
    end;
    if ps.ErrorCode = ENoError then begin
      AddLine('Script finished, no errors.');
    end else begin
      AddLine(ErrorToString(ps.ErrorCode, ps.ErrorString));
      Memo1.SelStart := ps.ErrorPos;
    end;
  finally
    istatus := istopped;
  end;
  ps.Cleanup;
end;

procedure TMain.RunwithaddedVariables1Click(Sender: TObject);
begin
  if (istatus = iStepOverWaiting) then
  begin
    istatus := IStepOver;
  end;
  if (istatus <> iStopped) then Exit;
  istatus := iRunning;
  try
    Memo2.Clear;
    ps.SetText(Memo1.Text);
    if ps.ErrorCode = ENoError then begin
      AddLine('Script is running.');
      ps.AddVariable('Demo', 'String', False)^.Cv_Str := 'Demo 1.0';
      ps.RunScript;
    end;
    if ps.ErrorCode = ENoError then begin
      AddLine('Script finished, no errors.');
    end else begin
      AddLine(ErrorToString(ps.ErrorCode, ps.ErrorString));
      Memo1.SelStart := ps.ErrorPos;
    end;
  finally
    istatus := istopped;
  end;
  ps.Cleanup;
end;

procedure TMain.RunwithTestObject1Click(Sender: TObject);
  procedure RunScriptClass;
  var
    p: PTypeRec;
    n: PIfVariant;
    v: PVariableManager;
    Func: PProcedure;
  begin
    p := ps.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;
        Vm_Add(v, nil, '');
        n := ps.RunScriptConstructor(p, Func, v);
        VM_Destroy(v);
        if n <> nil then begin
          ps.AddVariable('MyStringList', 'TIFStringList', False)^.CV_Class := n^.CV_Class;
          DestroyCajVariant(n);
        end;
      end;
    end;
  end;
begin
  if (istatus = iStepOverWaiting) then
  begin
    istatus := IStepOver;
  end;
  if (istatus <> iStopped) then Exit;
  istatus := iRunning;
  try
    Memo2.Clear;
    ps.SetText(Memo1.Text);
    if ps.ErrorCode = ENoError then begin
      AddLine('Script is running.');
      RunScriptClass;
      if ps.ErrorCode = ENoError then
        ps.RunScript;
    end;
    if ps.ErrorCode = ENoError then begin
      AddLine('Script finished, no errors.');
    end else begin
      AddLine(ErrorToString(ps.ErrorCode, ps.ErrorString));
      Memo1.SelStart := ps.ErrorPos;
    end;
  finally
    istatus := istopped;
  end;
  ps.Cleanup;
end;

procedure TMain.RunWithTimer1Click(Sender: TObject);
var
  Freq, Time1, Time2: Int64;
begin
  if not QueryPerformanceFrequency(Freq) then begin
    ShowMessage('Your computer does not support Performance Timers!');
    exit;
  end;
  if (istatus = iStepOverWaiting) then
  begin
    istatus := IStepOver;
  end;
  if (istatus <> iStopped) then Exit;
  istatus := iRunning;
  try
    Memo2.Clear;
    ps.OnRunLine := nil;
    QueryPerformanceCounter(Time1);
    ps.SetText(Memo1.Text);
    ps.RunScript;
    QueryPerformanceCounter(Time2);
    ps.OnRunLine := OnRunLine;
    if ps.ErrorCode = ENoError then begin
      AddLine('Script finished, no errors.');
    end else begin
      AddLine('Error in '+ps.ErrorModule+'('+IntToStr(ps.ErrorPos)+') '+ErrorToString(ps.ErrorCode, ps.ErrorString));
      Memo1.SelStart := ps.ErrorPos;
    end;
    AddLine('Time: '+Sysutils.FloatToStr((Time2-Time1)/Freq)+' sec');
  finally
    istatus := istopped;
  end;
  ps.Cleanup;
end;

procedure TMain.StepOver1Click(Sender: TObject);
begin
  if (istatus = iStepOverWaiting) then
  begin
    istatus := IStepOver;
  end;
  if (istatus <> iStopped) then Exit;
  istatus := iStepOver;
  try
    Memo2.Clear;
    ps.SetText(Memo1.Text);
    if ps.ErrorCode = ENoError then begin
      AddLine('Script is running.');
      ps.RunScript;
    end;
    if ps.ErrorCode = ENoError then begin
      AddLine('Script finished, no errors.');
    end else begin
      AddLine('Error in '+ps.ErrorModule+'('+IntToStr(ps.ErrorPos)+') '+ErrorToString(ps.ErrorCode, ps.ErrorString));
      Memo1.SelStart := ps.ErrorPos;
    end;
  finally
    istatus := iStopped;
  end;
  ps.Cleanup;
end;

initialization
  iStatus := iStopped;
  LastLine := 0;

end.