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