home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 December / Chip_2001-12_cd1.bin / zkuste / delphi / kompon / d23456 / CAJSCRTP.ZIP / demo_del / demo1.pas < prev    next >
Pascal/Delphi Source File  |  2001-10-03  |  17KB  |  559 lines
  1. unit demo1;
  2.  
  3. interface
  4. uses
  5.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  6.   ifspas, ifs_var, ifs_utl, ifs_obj, Menus, StdCtrls, ExtCtrls;
  7.                                                                    
  8. type
  9.   TMain = class(TForm)
  10.     MainMenu1: TMainMenu;
  11.     Memo1: TMemo;
  12.     Splitter1: TSplitter;
  13.     File1: TMenuItem;
  14.     New1: TMenuItem;
  15.     Open1: TMenuItem;
  16.     Save1: TMenuItem;
  17.     Saveas1: TMenuItem;
  18.     N1: TMenuItem;
  19.     Exit1: TMenuItem;
  20.     N2: TMenuItem;
  21.     Script1: TMenuItem;
  22.     Run1: TMenuItem;
  23.     OpenDialog1: TOpenDialog;
  24.     SaveDialog1: TSaveDialog;
  25.     Memo2: TMemo;
  26.     Stop1: TMenuItem;
  27.     N3: TMenuItem;
  28.     Runproceduretest1: TMenuItem;
  29.     RunwithTestObject1: TMenuItem;
  30.     RunwithaddedVariables1: TMenuItem;
  31.     N4: TMenuItem;
  32.     RunWithTimer1: TMenuItem;
  33.     StepOver1: TMenuItem;
  34.     procedure New1Click(Sender: TObject);
  35.     procedure Open1Click(Sender: TObject);
  36.     procedure Save1Click(Sender: TObject);
  37.     procedure Exit1Click(Sender: TObject);
  38.     procedure Saveas1Click(Sender: TObject);
  39.     procedure Run1Click(Sender: TObject);
  40.     procedure FormCreate(Sender: TObject);
  41.     procedure FormDestroy(Sender: TObject);
  42.     procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  43.     procedure Memo1Change(Sender: TObject);
  44.     procedure Stop1Click(Sender: TObject);
  45.     procedure FormClose(Sender: TObject; var Action: TCloseAction);
  46.     procedure Runproceduretest1Click(Sender: TObject);
  47.     procedure RunwithaddedVariables1Click(Sender: TObject);
  48.     procedure RunwithTestObject1Click(Sender: TObject);
  49.     procedure RunWithTimer1Click(Sender: TObject);
  50.     procedure StepOver1Click(Sender: TObject);
  51.   Private
  52.     { Private declarations }
  53.   Public
  54.     ps: TIFPasScript;
  55.     fn: string;
  56.     changed: Boolean;
  57.     function SaveTest: Boolean;
  58.     procedure AddLine(s: string);
  59.     { Public declarations }
  60.   end;
  61.  
  62. type
  63.   TIStatus = (iStopped, iRunning, iStepOver, iStepOverWaiting);
  64.  
  65. var
  66.   Main: TMain;
  67.   iStatus: TIStatus;
  68.   LastLine: Longint;
  69.  
  70. implementation
  71. uses
  72.   demo2, ifpsdll, ifpsdelphi, ifpsdll2, ifsctrlstd, ifpslib, ifsdfrm, ifpscom, ifpstrans, ifpsdate;
  73. {$R *.dfm}
  74.  
  75. procedure TMain.New1Click(Sender: TObject);
  76. begin
  77.   if not SaveTest then exit;
  78.   Memo1.Lines.Text := 'Program IFSTest;'#13#10'Begin'#13#10'End.';
  79.   Memo2.Lines.Clear;
  80.   fn := '';
  81. end;
  82.  
  83. procedure TMain.AddLine(s: string);
  84. begin
  85.   Memo2.Lines.Add(s);
  86. end;
  87.  
  88. function TMain.SaveTest: Boolean;
  89. begin
  90.   if changed then begin
  91.     case MessageDlg('File is not saved, save now?', mtWarning, mbYesNoCancel, 0) of
  92.       mrYes: begin
  93.           Save1Click(nil);
  94.           Result := not changed;
  95.         end;
  96.       mrNo: Result := True;
  97.     else
  98.       Result := False;
  99.     end;
  100.   end else
  101.     Result := True;
  102. end;
  103.  
  104. procedure TMain.Open1Click(Sender: TObject);
  105. begin
  106.   if not SaveTest then exit;
  107.   if OpenDialog1.Execute then begin
  108.     Memo1.Lines.LoadFromFile(OpenDialog1.FileName);
  109.     changed := False;
  110.     Memo2.Lines.Clear;
  111.     fn := OpenDialog1.FileName;
  112.   end;
  113. end;
  114.  
  115. procedure TMain.Save1Click(Sender: TObject);
  116. begin
  117.   if fn = '' then begin
  118.     Saveas1Click(nil);
  119.   end else begin
  120.     Memo1.Lines.SaveToFile(fn);
  121.     changed := False;
  122.   end;
  123. end;
  124.  
  125. procedure TMain.Exit1Click(Sender: TObject);
  126. begin
  127.   Close;
  128. end;
  129.  
  130. procedure TMain.Saveas1Click(Sender: TObject);
  131. begin
  132.   SaveDialog1.FileName := '';
  133.   if SaveDialog1.Execute then begin
  134.     fn := SaveDialog1.FileName;
  135.     Memo1.Lines.SaveToFile(fn);
  136.     changed := False;
  137.   end;
  138. end;
  139.  
  140. procedure TMain.Run1Click(Sender: TObject);
  141. begin
  142.   if (istatus = iStepOverWaiting) then
  143.   begin
  144.     istatus := IRunning;
  145.   end;
  146.   if (istatus <> iStopped) then Exit;
  147.   istatus := iRunning;
  148.   try
  149.     Memo2.Clear;
  150.     ps.SetText(Memo1.Text);
  151.     if ps.ErrorCode = ENoError then begin
  152.       AddLine('Script is running.');
  153.       ps.RunScript;
  154.     end;
  155.     if ps.ErrorCode = ENoError then begin
  156.       AddLine('Script finished, no errors.');
  157.     end else begin
  158.       AddLine('Error in '+ps.ErrorModule+'('+IntToStr(ps.ErrorPos)+') '+ErrorToString(ps.ErrorCode, ps.ErrorString));
  159.       Memo1.SelStart := ps.ErrorPos;
  160.     end;
  161.   finally
  162.     istatus := iStopped;
  163.   end;
  164.   ps.Cleanup;
  165. end;
  166.  
  167. function RegProc(Sender: TIfPasScript; ScriptID: Pointer; proc: PProcedure; Params: PVariableManager; res: PIfVariant): TIfPasScriptError;
  168. begin
  169.   if proc^.Name = 'WRITELN' then begin
  170.     Main.AddLine(GetString(Vm_Get(Params, 0)));
  171.   end else if proc^.Name = 'READLN' then begin
  172.     GetVarLink(Vm_Get(Params, 0))^.Cv_Str := InputBox('Demo', 'Readln:', '');
  173.   end else if proc^.Name = 'RANDOM' then begin
  174.     SetInteger(res, random(GetInteger(Vm_Get(Params, 0))));
  175.   end;
  176.   Result := ENoError;
  177. end;
  178.  
  179. function PaintRegProc(Sender: TIfPasScript; ScriptID: Pointer; proc: PProcedure; Params: PVariableManager; res: PIfVariant): TIfPasScriptError;
  180. var
  181.   I: Integer;
  182.   r: TRect;
  183. begin
  184.   if proc^.Name = 'SHOWPAINTWINDOW' then begin
  185.     PaintForm.ClientWidth := GetInteger(GetVarLink(Vm_Get(Params, 0)));
  186.     PaintForm.ClientHeight := GetInteger(GetVarLink(Vm_Get(Params, 1)));
  187.     PaintForm.Bitmap.Width := PaintForm.ClientWidth;
  188.     PaintForm.Bitmap.Height := PaintForm.ClientHeight;
  189.     PaintForm.Show;
  190.     PaintForm.DoUpdate;
  191.   end else if proc^.Name = 'HIDEPAINTWINDOW' then
  192.     PaintForm.Hide
  193.   else if proc^.Name = 'UPDATE' then begin
  194.     PaintForm.DoUpdate;
  195.     Application.ProcessMessages;
  196.   end else if proc^.Name = 'CLEAR' then begin
  197.     PaintForm.Bitmap.Canvas.Brush.Style := bsSolid;
  198.     PaintForm.Bitmap.Canvas.Brush.Color := GetInteger(GetVarLink(Vm_Get(Params, 0)));
  199.     PaintForm.Bitmap.Canvas.FillRect(Rect(0, 0, PaintForm.ClientWidth, PaintForm.ClientHeight));
  200.   end else if proc^.Name = 'LINE' then begin
  201.     PaintForm.Bitmap.Canvas.Pen.Color := GetInteger(GetVarLink(Vm_Get(Params, 4)));
  202.     PaintForm.Bitmap.Canvas.MoveTo(GetInteger(GetVarLink(Vm_Get(Params, 0))), GetInteger(GetVarLink(Vm_Get(Params, 1))));
  203.     PaintForm.Bitmap.Canvas.LineTo(GetInteger(GetVarLink(Vm_Get(Params, 2))), GetInteger(GetVarLink(Vm_Get(Params, 3))));
  204.   end else if proc^.Name = 'CIRCLE' then begin
  205.     PaintForm.Bitmap.Canvas.Pen.Color := GetInteger(GetVarLink(Vm_Get(Params, 3)));
  206.     PaintForm.Bitmap.Canvas.Brush.Style := bsClear;
  207.     I := GetInteger(GetVarLink(Vm_Get(Params, 2)));
  208.     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);
  209.     ;
  210.   end else if proc^.Name = 'RECTANGLE' then begin
  211.     PaintForm.Bitmap.Canvas.Pen.Color := GetInteger(GetVarLink(Vm_Get(Params, 4)));
  212.     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))));
  213.   end else if proc^.Name = 'FILLEDRECTANGLE' then begin
  214.     PaintForm.Bitmap.Canvas.Brush.Style := bsSolid;
  215.     PaintForm.Bitmap.Canvas.Brush.Color := GetInteger(GetVarLink(Vm_Get(Params, 4)));
  216.     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))));
  217.     PaintForm.Bitmap.Canvas.FillRect(r);
  218.   end;
  219.   Result := ENoError;
  220. end;
  221.  
  222. function ImportTest(S1: string; s2: Longint; s3: Byte; s4: word; var s5: string): string;
  223. begin
  224.   Result := s1 + ' ' + IntToStr(s2) + ' ' + IntToStr(s3) + ' ' + IntToStr(s4) + ' - OK!';
  225.   S5 := result + ' - OK2!';
  226. end;
  227.  
  228.  
  229. function OnUses(id: Pointer; Sender: TIfPasScript; Name: string): TCs2Error;
  230. var
  231.   f: TIFPasScript;
  232.   n: TFileStream;
  233.   s: string;
  234. begin
  235.   if Name = 'SYSTEM' then begin
  236.     RegisterStdLib(Sender, False);
  237.     RegisterTIfStringList(Sender);
  238.     RegisterComLibrary(Sender);
  239.     RegisterTransLibrary(Sender);
  240.     RegisterFormsLibrary(Sender);
  241.     RegisterStdControlsLibrary(Sender);
  242.     RegisterDllCallLibrary(Sender);
  243.     RegisterDelphiFunction(Sender, 'function ImportTest(S1:string;s2:Longint;s3:Byte;s4:Word;var s5:string):string;', @importTest);
  244.     RegisterExceptionLib(Sender);
  245.     RegisterDll2library(Sender);
  246.     RegisterDateTimeLib(Sender);
  247.  
  248.     Sender.AddFunction(@RegProc, 'procedure Writeln(s: string)', nil);
  249.     Sender.AddFunction(@RegProc, 'procedure Readln(var s: string)', nil);
  250.     Sender.AddFunction(@RegProc, 'function Random(I: Longint): Longint', nil);
  251.     Result := ENoError;
  252.   end else if Name = 'GRAPH' then begin
  253.     Sender.AddFunction(@PaintRegProc, 'procedure ShowPaintWindow(x,y : integer)', nil);
  254.     Sender.AddFunction(@PaintRegProc, 'procedure Clear(Color: Integer);', nil);
  255.     Sender.AddFunction(@PaintRegProc, 'procedure Update;', nil);
  256.     Sender.AddFunction(@PaintRegProc, 'procedure Line(x1,y1,x2,y2,color: Integer);', nil);
  257.     Sender.AddFunction(@PaintRegProc, 'procedure Circle(x,y,r,color: Integer);', nil);
  258.     Sender.AddFunction(@PaintRegProc, 'procedure Rectangle(x1,y1,x2,y2,color: Integer);', nil);
  259.     Sender.AddFunction(@PaintRegProc, 'procedure FilledRectangle(x1,y1,x2,y2,color: Integer);', nil);
  260.     Sender.AddFunction(@PaintRegProc, 'procedure HidePaintWindow;', nil);
  261.     Result := ENoError;
  262.   end else
  263.   begin
  264.     F := TIFPasScript.Create(nil);
  265.     try
  266.       n := TFileStream.Create(Name+'.IFS', FMOpenRead or FMShareDenyWrite);
  267.       setLength(s, n.Size);
  268.       n.Read(s[1], Length(S));
  269.       n.Free;
  270.     except
  271.       Result := EUnitNotFound;
  272.       exit;
  273.     end;
  274.     f.OnUses := OnUses;
  275.     f.SetText(s);
  276.     if f.ErrorCode <> ENoError then
  277.     begin
  278.       Sender.RunError2(f, f.ErrorCode, f.ErrorString);
  279.       f.Free;
  280.       Result := EUnitNotFound;
  281.     end else
  282.     begin
  283.       if not Sender.Attach(F) then
  284.       begin
  285.         f.Free;
  286.         Result := ECustomError;
  287.       end else
  288.         Result := ENoError;
  289.     end;
  290.   end;
  291. end;
  292.  
  293. function GetLine(const text: string; pos: Longint): Longint;
  294. var
  295.   i: Integer;
  296. begin
  297.   Result := 1;
  298.   for i := 1 to pos do
  299.     if text[i] = #10 then inc(result); // should work under linux too 
  300. end;
  301. function OnRunLine(id: Pointer; Sender: TIfPasScript; Position: Longint): TCs2Error;
  302. var
  303.   i: Longint;
  304. begin
  305.   Application.ProcessMessages;
  306.   Result := ENoError;
  307.  
  308.   case iStatus of
  309.     istopped: Result := EExitCommand;
  310.     iStepOver:
  311.     begin
  312.       i := GetLine(Main.Memo1.Text, Position);
  313.       if i <> LastLine then begin
  314.         istatus := istepoverwaiting;
  315.         lastline := i;
  316.         Main.Memo1.SelStart := Position;
  317.         Main.Memo1.SelLength := 1;
  318.         while istatus = istepoverwaiting do
  319.            Application.ProcessMessages;
  320.       end;
  321.     end;
  322.   end;
  323. end;
  324.  
  325. procedure TMain.FormCreate(Sender: TObject);
  326. begin
  327.   ps := TIfPasScript.Create(nil);
  328.   ps.OnRunLine := OnRunLine;
  329.   ps.OnUses := OnUses;
  330.   ps.MaxBeginNesting := 1000;
  331.   ps.OnExternal := DllExternalProc;
  332.   fn := '';                                            
  333.   changed := False;
  334.   Randomize;
  335. end;
  336.  
  337. procedure TMain.FormDestroy(Sender: TObject);
  338. begin
  339.   try
  340.     ps.Free;
  341.   except
  342.     ShowMessage('Error ???');
  343.   end;
  344. end;
  345.  
  346. procedure TMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  347. begin
  348.   CanClose := SaveTest;
  349. end;
  350.  
  351. procedure TMain.Memo1Change(Sender: TObject);
  352. begin
  353.   changed := True;
  354.   Memo1.Tag := 1;
  355. end;
  356.  
  357. procedure TMain.Stop1Click(Sender: TObject);
  358. begin
  359.   if istatus <> istopped then istatus := istopped;
  360. end;
  361.  
  362. procedure TMain.FormClose(Sender: TObject; var Action: TCloseAction);
  363. begin
  364.   if istatus <> istopped then istatus := istopped;
  365. end;
  366.  
  367. procedure TMain.Runproceduretest1Click(Sender: TObject);
  368.  
  369.   procedure RunScriptProc;
  370.   var
  371.     p: PProcedure;
  372.     v: PVariableManager;
  373.   begin
  374.     p := ps.GetFunction('TEST');
  375.     if p = nil then begin
  376.       AddLine('procedure test; not found!');
  377.     end else begin
  378.       v := VM_Create;
  379.       DestroyCajVariant(ps.RunScriptProc(p, v));
  380.       VM_Destroy(v);
  381.     end;
  382.   end;
  383. begin
  384.   if (istatus = iStepOverWaiting) then
  385.   begin
  386.     istatus := IStepOver;
  387.   end;
  388.   if (istatus <> iStopped) then Exit;
  389.   istatus := iRunning;
  390.   try
  391.     Memo2.Clear;
  392.     ps.SetText(Memo1.Text);
  393.     if ps.ErrorCode = ENoError then begin
  394.       AddLine('Script is running.');
  395.       RunScriptProc;
  396.     end;
  397.     if ps.ErrorCode = ENoError then begin
  398.       AddLine('Script finished, no errors.');
  399.     end else begin
  400.       AddLine(ErrorToString(ps.ErrorCode, ps.ErrorString));
  401.       Memo1.SelStart := ps.ErrorPos;
  402.     end;
  403.   finally
  404.     istatus := istopped;
  405.   end;
  406.   ps.Cleanup;
  407. end;
  408.  
  409. procedure TMain.RunwithaddedVariables1Click(Sender: TObject);
  410. begin
  411.   if (istatus = iStepOverWaiting) then
  412.   begin
  413.     istatus := IStepOver;
  414.   end;
  415.   if (istatus <> iStopped) then Exit;
  416.   istatus := iRunning;
  417.   try
  418.     Memo2.Clear;
  419.     ps.SetText(Memo1.Text);
  420.     if ps.ErrorCode = ENoError then begin
  421.       AddLine('Script is running.');
  422.       ps.AddVariable('Demo', 'String', False)^.Cv_Str := 'Demo 1.0';
  423.       ps.RunScript;
  424.     end;
  425.     if ps.ErrorCode = ENoError then begin
  426.       AddLine('Script finished, no errors.');
  427.     end else begin
  428.       AddLine(ErrorToString(ps.ErrorCode, ps.ErrorString));
  429.       Memo1.SelStart := ps.ErrorPos;
  430.     end;
  431.   finally
  432.     istatus := istopped;
  433.   end;
  434.   ps.Cleanup;
  435. end;
  436.  
  437. procedure TMain.RunwithTestObject1Click(Sender: TObject);
  438.   procedure RunScriptClass;
  439.   var
  440.     p: PTypeRec;
  441.     n: PIfVariant;
  442.     v: PVariableManager;
  443.     Func: PProcedure;
  444.   begin
  445.     p := ps.GetType('TIFStringList');
  446.     if p = nil then begin
  447.       AddLine('Strange. The TIFStringList type is not found!');
  448.     end else begin
  449.       if not GetClassProcedure(nil, p^.Ext, 'CREATE', Func, False) then begin
  450.         AddLine('Can not find TIFStringList.Create (weird error) !');
  451.       end else begin
  452.         v := VM_Create;
  453.         Vm_Add(v, nil, '');
  454.         n := ps.RunScriptConstructor(p, Func, v);
  455.         VM_Destroy(v);
  456.         if n <> nil then begin
  457.           ps.AddVariable('MyStringList', 'TIFStringList', False)^.CV_Class := n^.CV_Class;
  458.           DestroyCajVariant(n);
  459.         end;
  460.       end;
  461.     end;
  462.   end;
  463. begin
  464.   if (istatus = iStepOverWaiting) then
  465.   begin
  466.     istatus := IStepOver;
  467.   end;
  468.   if (istatus <> iStopped) then Exit;
  469.   istatus := iRunning;
  470.   try
  471.     Memo2.Clear;
  472.     ps.SetText(Memo1.Text);
  473.     if ps.ErrorCode = ENoError then begin
  474.       AddLine('Script is running.');
  475.       RunScriptClass;
  476.       if ps.ErrorCode = ENoError then
  477.         ps.RunScript;
  478.     end;
  479.     if ps.ErrorCode = ENoError then begin
  480.       AddLine('Script finished, no errors.');
  481.     end else begin
  482.       AddLine(ErrorToString(ps.ErrorCode, ps.ErrorString));
  483.       Memo1.SelStart := ps.ErrorPos;
  484.     end;
  485.   finally
  486.     istatus := istopped;
  487.   end;
  488.   ps.Cleanup;
  489. end;
  490.  
  491. procedure TMain.RunWithTimer1Click(Sender: TObject);
  492. var
  493.   Freq, Time1, Time2: Int64;
  494. begin
  495.   if not QueryPerformanceFrequency(Freq) then begin
  496.     ShowMessage('Your computer does not support Performance Timers!');
  497.     exit;
  498.   end;
  499.   if (istatus = iStepOverWaiting) then
  500.   begin
  501.     istatus := IStepOver;
  502.   end;
  503.   if (istatus <> iStopped) then Exit;
  504.   istatus := iRunning;
  505.   try
  506.     Memo2.Clear;
  507.     ps.OnRunLine := nil;
  508.     QueryPerformanceCounter(Time1);
  509.     ps.SetText(Memo1.Text);
  510.     ps.RunScript;
  511.     QueryPerformanceCounter(Time2);
  512.     ps.OnRunLine := OnRunLine;
  513.     if ps.ErrorCode = ENoError then begin
  514.       AddLine('Script finished, no errors.');
  515.     end else begin
  516.       AddLine('Error in '+ps.ErrorModule+'('+IntToStr(ps.ErrorPos)+') '+ErrorToString(ps.ErrorCode, ps.ErrorString));
  517.       Memo1.SelStart := ps.ErrorPos;
  518.     end;
  519.     AddLine('Time: '+Sysutils.FloatToStr((Time2-Time1)/Freq)+' sec');
  520.   finally
  521.     istatus := istopped;
  522.   end;
  523.   ps.Cleanup;
  524. end;
  525.  
  526. procedure TMain.StepOver1Click(Sender: TObject);
  527. begin
  528.   if (istatus = iStepOverWaiting) then
  529.   begin
  530.     istatus := IStepOver;
  531.   end;
  532.   if (istatus <> iStopped) then Exit;
  533.   istatus := iStepOver;
  534.   try
  535.     Memo2.Clear;
  536.     ps.SetText(Memo1.Text);
  537.     if ps.ErrorCode = ENoError then begin
  538.       AddLine('Script is running.');
  539.       ps.RunScript;
  540.     end;
  541.     if ps.ErrorCode = ENoError then begin
  542.       AddLine('Script finished, no errors.');
  543.     end else begin
  544.       AddLine('Error in '+ps.ErrorModule+'('+IntToStr(ps.ErrorPos)+') '+ErrorToString(ps.ErrorCode, ps.ErrorString));
  545.       Memo1.SelStart := ps.ErrorPos;
  546.     end;
  547.   finally
  548.     istatus := iStopped;
  549.   end;
  550.   ps.Cleanup;
  551. end;
  552.  
  553. initialization
  554.   iStatus := iStopped;
  555.   LastLine := 0;
  556.  
  557. end.
  558.  
  559.