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