← Back to branch summary

~ubuntu-branches/ubuntu/vivid/lazarus/vivid

« back to all changes in this revision

Viewing changes to components/PascalScript/Samples/Console/sample6.dpr

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Paul Gevers
  • Date: 2014-02-22 10:25:57 UTC
  • mfrom: (1.1.11)
  • Revision ID: package-import@ubuntu.com-20140222102557-ors9d31r84nz31jq
Tags: 1.2~rc2+dfsg-1
http://bugs.debian.org/724776
[ Abou Al Montacir ]
* New upstream pre-release.
  + Moved ideintf to components directory.
  + Added new package cairocanvas.
* Remove usage of depreciated parameters form of find. (Closes: Bug#724776)
* Bumped standard version to 3.9.5.
* Clean the way handling make files generation and removal.

[ Paul Gevers ]
* Remove nearly obsolete bzip compression for binary packages
  (See https://lists.debian.org/debian-devel/2014/01/msg00542.html)
* Update d/copyright for newly added dir in examples and components
* Update Vcs-* fields with new packaging location
* Update d/watch file to properly (Debian way) change upstreams versions
* Prevent 46MB of package size by sym linking duplicate files
* Patches
  - refresh to remove fuzz
  - add more Lintian found spelling errors
  - new patch to add shbang to two scripts in lazarus-src
* Drop lcl-# from Provides list of lcl-units-#
* Make lazarus-ide-qt4-# an arch all until it really contains stuff
* Make all metapackages arch all as the usecase for arch any doesn't
  seem to warrant the addition archive hit
* Fix permissions of non-scripts in lazarus-src-#

Show diffs side-by-side

added added

removed removed

Lines of Context:
components/PascalScript/Samples/Console/sample6.dpr
 
1
program sample6;
 
2
 
 
3
uses
 
4
  uPSCompiler,
 
5
  uPSUtils,
 
6
  uPSRuntime,
 
7
 
 
8
  Dialogs
 
9
 
 
10
  ;
 
11
 
 
12
procedure MyOwnFunction(const Data: string);
 
13
begin
 
14
  // Do something with Data
 
15
  ShowMessage(Data);
 
16
end;
 
17
{$IFDEF UNICODE}
 
18
function ScriptOnExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; const ProcDecl: AnsiString): Boolean;
 
19
{$ELSE}
 
20
function ScriptOnExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; const ProcDecl: string): Boolean;
 
21
{$ENDIF}
 
22
{
 
23
  The OnExportCheck callback function is called for each function in the script
 
24
  (Also for the main proc, with '!MAIN' as a Proc^.Name). ProcDecl contains the
 
25
  result type and parameter types of a function using this format:
 
26
  ProcDecl: ResultType + ' ' + Parameter1 + ' ' + Parameter2 + ' '+Parameter3 + .....
 
27
  Parameter: ParameterType+TypeName
 
28
  ParameterType is @ for a normal parameter and ! for a var parameter.
 
29
  A result type of 0 means no result.
 
30
}
 
31
begin
 
32
  if Proc.Name = 'TEST' then // Check if the proc is the Test proc we want.
 
33
  begin
 
34
    if not ExportCheck(Sender, Proc, [0, {$IFDEF UNICODE}btUnicodeString{$ELSE}btString{$ENDIF}], [pmIn]) then // Check if the proc has the correct params.
 
35
    begin
 
36
      { Something is wrong, so cause an error at the declaration position of the proc. }
 
37
      Sender.MakeError('', ecTypeMismatch, '');
 
38
      Result := False;
 
39
      Exit;
 
40
    end;
 
41
    Result := True;
 
42
  end else Result := True;
 
43
end;
 
44
 
 
45
{$IFDEF UNICODE}
 
46
function ScriptOnUses(Sender: TPSPascalCompiler; const Name: AnsiString): Boolean;
 
47
{$ELSE}
 
48
function ScriptOnUses(Sender: TPSPascalCompiler; const Name: string): Boolean;
 
49
{$ENDIF}
 
50
{ the OnUses callback function is called for each "uses" in the script.
 
51
  It's always called with the parameter 'SYSTEM' at the top of the script. 
 
52
  For example: uses ii1, ii2;   
 
53
  This will call this function 3 times. First with 'SYSTEM' then 'II1' and then 'II2'.
 
54
}
 
55
begin
 
56
  if Name = 'SYSTEM' then
 
57
  begin
 
58
    Sender.AddDelphiFunction('procedure MyOwnFunction(Data: string)');
 
59
    { This will register the function to the script engine. Now it can be used from within the script. }
 
60
 
 
61
    Result := True;
 
62
  end else
 
63
    Result := False;
 
64
end;
 
65
 
 
66
procedure ExecuteScript(const Script: string);
 
67
var
 
68
  Compiler: TPSPascalCompiler;
 
69
  { TPSPascalCompiler is the compiler part of the scriptengine. This will 
 
70
    translate a Pascal script into a compiled form the executer understands. } 
 
71
  Exec: TPSExec;
 
72
   { TPSExec is the executer part of the scriptengine. It uses the output of
 
73
    the compiler to run a script. }
 
74
  {$IFDEF UNICODE}Data: AnsiString;{$ELSE}Data: string;{$ENDIF}
 
75
 
 
76
  N: PIfVariant;
 
77
  { The variant in which we are going to store the parameter }
 
78
  ParamList: TIfList;
 
79
  { The parameter list}
 
80
begin
 
81
  Compiler := TPSPascalCompiler.Create; // create an instance of the compiler.
 
82
  Compiler.OnUses := ScriptOnUses; // assign the OnUses event.
 
83
 
 
84
  Compiler.OnExportCheck := ScriptOnExportCheck; // Assign the onExportCheck event.
 
85
 
 
86
  if not Compiler.Compile(Script) then  // Compile the Pascal script into bytecode.
 
87
  begin
 
88
    Compiler.Free;
 
89
     // You could raise an exception here.
 
90
    Exit;
 
91
  end;
 
92
 
 
93
  Compiler.GetOutput(Data); // Save the output of the compiler in the string Data.
 
94
  Compiler.Free; // After compiling the script, there is no need for the compiler anymore.
 
95
 
 
96
  Exec := TPSExec.Create;  // Create an instance of the executer.
 
97
 
 
98
  Exec.RegisterDelphiFunction(@MyOwnFunction, 'MYOWNFUNCTION', cdRegister);
 
99
  { This will register the function to the executer. The first parameter is the executer. The second parameter is a 
 
100
    pointer to the function. The third parameter is the name of the function (in uppercase). And the last parameter is the
 
101
    calling convention (usually Register). }
 
102
 
 
103
  if not Exec.LoadData(Data) then // Load the data from the Data string.
 
104
  begin
 
105
    { For some reason the script could not be loaded. This is usually the case when a 
 
106
      library that has been used at compile time isn't registered at runtime. }
 
107
    Exec.Free;
 
108
     // You could raise an exception here.
 
109
    Exit;
 
110
  end;
 
111
 
 
112
  ParamList := TIfList.Create; // Create the parameter list
 
113
 
 
114
  N := CreateHeapVariant(Exec.FindType2(btString));
 
115
  { Create a variant for the string parameter }
 
116
  if n = nil then
 
117
  begin
 
118
    { Something is wrong. Exit here }
 
119
    ParamList.Free;
 
120
    Exec.Free;
 
121
    Exit;
 
122
  end;
 
123
  VSetString(n, 'Test Parameter!');
 
124
  // Put something in the string parameter.
 
125
 
 
126
  ParamList.Add(n); // Add it to the parameter list.
 
127
 
 
128
  Exec.RunProc(ParamList, Exec.GetProc('TEST'));
 
129
  { This will call the test proc that was exported before }
 
130
 
 
131
  FreePIFVariantList(ParamList); // Cleanup the parameters (This will also free N)
 
132
 
 
133
  Exec.Free; // Free the executer.
 
134
end;
 
135
 
 
136
 
 
137
 
 
138
const
 
139
  Script = 'procedure test(s: string); begin MyOwnFunction(''Test is called: ''+s);end; begin end.';
 
140
 
 
141
begin
 
142
  ExecuteScript(Script);
 
143
end.