File: sample4.dpr

package info (click to toggle)
lazarus 1.2.4%2Bdfsg2-1
  • links: PTS, VCS
  • area: main
  • in suites: jessie, jessie-kfreebsd
  • size: 170,220 kB
  • ctags: 115,165
  • sloc: pascal: 1,386,898; xml: 257,878; sh: 2,935; java: 603; makefile: 549; perl: 297; sql: 174; ansic: 137
file content (115 lines) | stat: -rw-r--r-- 3,712 bytes parent folder | download | duplicates (4)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
program sample4;
{$APPTYPE CONSOLE}
uses
  uPSCompiler,
  uPSRuntime,
  uPSC_std,
  uPSC_controls,
  uPSC_stdctrls,
  uPSC_forms,
  uPSR_std,
  uPSR_controls,
  uPSR_stdctrls,
  uPSR_forms,
  forms

  ;

{$IFDEF UNICODE}
function ScriptOnUses(Sender: TPSPascalCompiler; const Name: AnsiString): Boolean;
{$ELSE}
function ScriptOnUses(Sender: TPSPascalCompiler; const Name: string): Boolean;
{$ENDIF}
{ the OnUses callback function is called for each "uses" in the script. 
  It's always called with the parameter 'SYSTEM' at the top of the script. 
  For example: uses ii1, ii2;   
  This will call this function 3 times. First with 'SYSTEM' then 'II1' and then 'II2'.
}
begin
  if Name = 'SYSTEM' then
  begin
    SIRegister_Std(Sender);
    { This will register the declarations of these classes:
      TObject, TPersistent, TComponent. This can be found
      in the uPSC_std.pas unit. }

    SIRegister_Controls(Sender);
    { This will register the declarations of these classes:
      TControl, TWinControl, TFont, TStrings, TStringList, TCanvas, TGraphicControl. This can be found
      in the uPSC_controls.pas unit. }

    SIRegister_Forms(Sender);
    { This will register: TScrollingWinControl, TCustomForm, TForm and TApplication. uPSC_forms.pas unit. }

    SIRegister_stdctrls(Sender);
     { This will register: TButtonContol, TButton, TCustomCheckbox, TCheckBox, TCustomEdit, TEdit, TCustomMemo, TMemo,
      TCustomLabel and TLabel. Can be found in the uPSC_stdctrls.pas unit. }

    Result := True;
  end else
    Result := False;
end;

procedure ExecuteScript(const Script: string);
var
  Compiler: TPSPascalCompiler;
  { TPSPascalCompiler is the compiler part of the scriptengine. This will 
    translate a Pascal script into a compiled form the executer understands. } 
  Exec: TPSExec;
   { TPSExec is the executer part of the scriptengine. It uses the output of
    the compiler to run a script. }
  {$IFDEF UNICODE}Data: AnsiString;{$ELSE}Data: string;{$ENDIF}
  i: Integer;
  CI: TPSRuntimeClassImporter;
begin
  Compiler := TPSPascalCompiler.Create; // create an instance of the compiler.
  Compiler.OnUses := ScriptOnUses; // assign the OnUses event.
  if not Compiler.Compile(Script) then  // Compile the Pascal script into bytecode.
  begin

    for i := 0 to Compiler.MsgCount -1 do
      Writeln(Compiler.Msg[i].MessageToString);
    Compiler.Free;
     // You could raise an exception here.
    Exit;
  end;

  Compiler.GetOutput(Data); // Save the output of the compiler in the string Data.
  Compiler.Free; // After compiling the script, there is no need for the compiler anymore.

  CI := TPSRuntimeClassImporter.Create;
  { Create an instance of the runtime class importer.}

  RIRegister_Std(CI);  // uPSR_std.pas unit.
  RIRegister_stdctrls(CI);  // uPSR_stdctrls.pas unit.
  RIRegister_Controls(CI); // uPSR_controls.pas unit.
  RIRegister_Forms(CI);  // uPSR_forms.pas unit.

  Exec := TPSExec.Create;  // Create an instance of the executer.

  RegisterClassLibraryRuntime(Exec, CI);
  // Assign the runtime class importer to the executer.

  if not  Exec.LoadData(Data) then // Load the data from the Data string.
  begin
    { For some reason the script could not be loaded. This is usually the case when a
      library that has been used at compile time isn't registered at runtime. }
    Exec.Free;
     // You could raise an exception here.
    Exit;
  end;

  Exec.RunScript; // Run the script.
  Exec.Free; // Free the executer.
  CI.Free;  // Free the runtime class importer.
end;



const
  Script =
    'var f: TForm; i: Longint; begin f := TForm.CreateNew(nil,0); f.Show; for i := 0 to 1000000 do; f.Hide; f.free;  end.';

begin
  ExecuteScript(Script);
end.