Sign in Join
Wiki copytemporary

Pascal Script Examples: what changed

Revision 0 to 1. Removed lines have a minus sign; added lines have a plus sign.

Title: Pascal Script Examples

OldNewLine
1+This is a simple example of a actual [[Pascal Script|script]] that shows how to do try except with raising a exception and doing something with the exception message.
2+
3+``` pascal
4+var
5+ filename,emsg:string;
6+begin
7+ filename = '';
8+ try
9+ if filename = '' then
10+ RaiseException(erCustomError, 'File name cannot be blank');
11+
12+ except
13+ emsg:=ExceptionToString(ExceptionType, ExceptionParam);
14+ //do somethign with the exception message i.e. email it or
15+ //save to a log etc
16+ end;
17+
18+end.
19+```
20+
21+To run the above script drop a TPSScript component on your form and either copy the above script to the script property or use the script properties LoadFromFile. We will call the TPSScript component "ps_script" for this example.
22+
23+Place a button on your form and create a new Onclick event for it and add this to it:
24+
25+``` pascal
26+ps_script.Script.LoadFromFile('yourscript.txt');
27+if ps_script.compile then
28+ ps_script.execute
29+else
30+ //show any compile errors
31+ showmessage(ps_script.CompilerErrorToStr(0));
32+```
33+
34+Ok, what if some standard functions are not available in the base scripting engine? No problem, just create the OnCompile event for the TPSScript component. Here we extend the script engine by adding two functions from the standard sysutils that don't seem to be included with the base engine.
35+
36+``` pascal
37+
38+procedure TForm1.ps_ScriptCompile(Sender: TPSScript);
39+begin
40+ sender.AddFunction(@ExtractFileExt,'function ExtractFileExt(const FileName: string): string;');
41+ sender.AddFunction(@ExtractFileName,'function ExtractFileName(const FileName: string): string;');
42+ end;
43+```
44+
45+Your script will now have access to these functions.
46+
47+The following examples are FPC code and do not show a script.
48+
49+``` pascal
50+program psce;
51+//enhanced with compiler messages to the shell and output to shell
52+//bytecode and dissasembly output
53+//jan 2011 www.softwareschule.ch/maxbox.htm, loc's =218
54+{$APPTYPE CONSOLE}
55+
56+{$IFDEF FPC}
57+{$mode delphi}{$H+}
58+{$ENDIF}
59+
60+uses
61+ SysUtils,
62+ Classes,
63+ Forms,
64+ uPSCompiler,
65+ uPSR_std,
66+ uPSC_std,
67+ uPSR_classes,
68+ uPSC_classes,
69+ uPSC_controls,
70+ uPSR_controls,
71+ uPSC_forms,
72+ uPSR_forms,
73+ uPSRuntime,
74+ uPSComponent,
75+ uPSDisassembly,
76+ uPSR_dateutils,
77+ uPSC_dateutils,
78+ uPSR_dll,
79+ uPSC_dll;
80+
81+type
82+ TPSCE = class
83+ protected
84+ FScr: TPSScript;
85+ procedure SaveCompiled(var Data: String);
86+ procedure SaveDissasembly(var Data: String);
87+ procedure OnCompile(Sender: TPSScript);
88+ procedure OnExecImport(Sender: TObject; se: TPSExec;
89+ x: TPSRuntimeClassImporter);
90+ public
91+ constructor Create;
92+ destructor Destroy; override;
93+ function Compile(const FileName: string): Boolean;
94+ function Execute: Boolean;
95+ end;
96+
97+var
98+ aPSCE: TPSCE;
99+ SFile, sData: String;
100+
101+procedure MWritedt(d : TDateTime);
102+var
103+ s: String;
104+begin
105+ s:= DateToStr(d) + ' ' + TimeToStr(d);
106+ Write(s);
107+end;
108+
109+procedure MWrites(const s: string);
110+begin
111+ Write(s);
112+end;
113+
114+procedure MWritei(const i: Integer);
115+begin
116+ Write(i);
117+end;
118+
119+procedure MWrited(const d: Double);
120+begin
121+ Write(d:0:1);
122+end;
123+
124+procedure MWriteln;
125+begin
126+ Writeln;
127+end;
128+
129+procedure MyVal(const s: string; var n, z: Integer);
130+begin
131+ Val(s, n, z);
132+end;
133+
134+constructor TPSCE.Create;
135+begin
136+ FScr:= TPSScript.Create(nil);
137+ FScr.OnCompile:= OnCompile;
138+ FScr.OnExecImport:= OnExecImport;
139+end;
140+
141+destructor TPSCE.Destroy;
142+begin
143+ FScr.Free;
144+end;
145+
146+procedure TPSCE.SaveCompiled(var Data : String);
147+var
148+ OutFile: string;
149+ Fx: Longint ;
150+begin
151+ OutFile:= ExtractFilePath(ParamStr(0)) + ChangeFileExt(SFile,'.out');
152+ Fx:= FileCreate(OutFile) ;
153+ FileWrite(Fx,Data[1],Length(Data));
154+ FileClose(Fx) ;
155+end;
156+
157+procedure TPSCE.SaveDissasembly(var Data: String);
158+var
159+ OutFile: string;
160+ Fx: Longint ;
161+begin
162+ OutFile:= ExtractFilePath(ParamStr(0)) + ChangeFileExt(SFile,'.dis');
163+ Fx:= FileCreate(OutFile) ;
164+ FileWrite(Fx, Data[1], Length(Data));
165+ FileClose(Fx) ;
166+end;
167+
168+procedure TPSCE.OnExecImport(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter);
169+begin
170+ RIRegister_Std(x);
171+ RIRegister_Classes(x,true);
172+ RIRegister_Controls(x);
173+ RIRegister_Forms(x);
174+ RegisterDateTimeLibrary_R(se);
175+ RegisterDLLRuntime(se);
176+end;
177+
178+procedure TPSCE.OnCompile(Sender: TPSScript);
179+begin
180+ RegisterDateTimeLibrary_C(Sender.Comp);
181+ Sender.AddFunction(@MWrites, 'procedure Writes(const s: string)');
182+ Sender.AddFunction(@MWritedt,'procedure WriteDT(d : TDateTime)');
183+ Sender.AddFunction(@MWritei, 'procedure Writei(const i: Integer)');
184+ Sender.AddFunction(@MWrited, 'procedure Writed(const f: Double)');
185+ Sender.AddFunction(@MWriteln, 'procedure Writeln');
186+ Sender.AddFunction(@MyVal, 'procedure Val(const s: string; var n, z: Integer)');
187+ Sender.AddFunction(@FileCreate, 'Function FileCreate(const FileName: string): integer)');
188+ Sender.AddFunction(@FileWrite, 'function FileWrite(Handle: Integer; const Buffer: pChar; Count: LongWord): Integer)');
189+ Sender.AddFunction(@FileClose, 'Procedure FileClose(handle: integer)');
190+ //Sender.AddRegisteredVariable('Application', 'TApplication');
191+ SIRegister_Std(Sender.Comp);
192+ SIRegister_Classes(Sender.Comp,true);
193+ SIRegister_Controls(Sender.Comp);
194+ SIRegister_Forms(Sender.Comp);
195+end;
196+
197+function TPSCE.Compile(const FileName: string): Boolean;
198+var
199+ S: TStringList;
200+ i: Integer;
201+begin
202+ Result:= False;
203+ if FileExists(FileName) then begin
204+ S:= TStringList.Create;
205+ S.LoadFromFile(FileName);
206+ FScr.Script:= S;
207+ Result:= FScr.Compile;
208+ for i:= 0 to aPSCE.FScr.CompilerMessageCount - 1 do
209+ writeln(aPSCE.FScr.CompilerMessages[i].MessageToString);
210+ S.Free;
211+ if not Result then
212+ if FScr.CompilerMessageCount > 0 then
213+ for i:= 0 to FScr.CompilerMessageCount-1 do
214+ Writeln(FScr.CompilerErrorToStr(i));
215+ end else Writeln('Script File not found: ', FileName);
216+end;
217+
218+function TPSCE.Execute: Boolean;
219+begin
220+ //FScr.SetVarToInstance('APPLICATION', Application);
221+ //FScr.SetVarToInstance('SELF', Self);
222+ Result:= FScr.Execute;
223+ //writeln(FScr.About);
224+ if not Result then
225+ Writeln('Run-time error:' + FScr.ExecErrorToString);
226+end;
227+
228+begin //main
229+ Application.Initialize;
230+ aPSCE:= TPSCE.Create;
231+ if ParamCount = 0 then begin
232+ Writeln('Usage: ', ExtractFileName(ParamStr(0)), ' [--compile|--dissasembly] <script.pss>');
233+ Writeln('');
234+ Writeln('--compile : Save compiled script bytecode');
235+ Writeln('--dissasembly: Save dissasembly of script');
236+ Exit;
237+ end;
238+ SFile:= ParamStr(1);
239+ if (ParamStr(1)='--compile') or (ParamStr(1)='--dissasembly') then begin
240+ SFile:= ParamStr(2);
241+ aPSCE.Compile(SFile);
242+ aPSCE.Execute; //output on shell
243+ aPSCE.FScr.GetCompiled(sData);
244+ if Paramstr(1)='--compile' then begin
245+ aPSCE.FScr.Comp.GetOutput(sData);
246+ aPSCE.SaveCompiled(sData);
247+ end;
248+ if Paramstr(1)='--dissasembly' then begin
249+ aPSCE.FScr.GetCompiled(sData);
250+ if not IFPS3DataToText(sData, sData)
251+ then begin
252+ Writeln('Create or create not dissasembly!');
253+ aPSCE.SaveDissasembly(sData); //do it anyway
254+ end else
255+ aPSCE.SaveDissasembly(sData);
256+ end;
257+ Exit;
258+ end;
259+ aPSCE.Compile(SFile);
260+ aPSCE.Execute;
261+ aPSCE.Free;
262+end.
263+```
264+
265+2\. Example of Lazarus with GUI Components
266+
267+``` pascal
268+
269+unit unit1pscript2;
270+//compiled by max
271+////oct 2014: www.softwareschule.ch/maxbox.htm
272+
273+{$mode objfpc}{$H+}
274+
275+interface
276+
277+uses
278+ Classes, SysUtils, FileUtil, SynMemo, SynHighlighterPas, uPSComponent,
279+ uPSComponent_Default, uPSComponent_StdCtrls, uPSComponent_Forms, Forms,
280+ Controls, Graphics, Dialogs, StdCtrls, Buttons, ExtCtrls, uPSRuntime,
281+ uPSComponent_DB, uPSCompiler;
282+
283+type
284+
285+ { TpsForm1 }
286+ TpsForm1 = class(TForm)
287+ btnImport: TBitBtn;
288+ btnCompile: TBitBtn;
289+ btnSaveScript: TBitBtn;
290+ btnSaveComp: TBitBtn;
291+ btnLoadScript: TBitBtn;
292+ btngetCompiled: TBitBtn;
293+ btnExecute: TButton;
294+ btnRunbytecode: TButton;
295+ Image1: TImage;
296+ Image2: TImage;
297+ Memo1: TMemo;
298+ PSImport_Classes1: TPSImport_Classes;
299+ PSImport_DateUtils1: TPSImport_DateUtils;
300+ PSImport_DB1: TPSImport_DB;
301+ PSImport_Forms1: TPSImport_Forms;
302+ PSImport_StdCtrls1: TPSImport_StdCtrls;
303+ PSScript1: TPSScript;
304+ SynMemo1: TSynMemo;
305+ SynPasSyn1: TSynPasSyn;
306+ procedure btnImportClick(Sender: TObject);
307+ procedure btnLoadScriptClick(Sender: TObject);
308+ procedure btnRunbytecodeClick(Sender: TObject);
309+ procedure Compile1Click(Sender: TObject);
310+ procedure btnSaveScriptClick(Sender: TObject);
311+ procedure btnSaveCompClick(Sender: TObject);
312+ procedure btngetCompiledClick(Sender: TObject);
313+ procedure btnExecuteClick(Sender: TObject);
314+ procedure FormActivate(Sender: TObject);
315+ procedure PSScript1AfterExecute(Sender: TPSScript);
316+ procedure PSScript1Compile(Sender: TPSScript);
317+ procedure PSScript1CompImport(Sender: TObject; x: TPSPascalCompiler);
318+ procedure PSScript1ExecImport(Sender: TObject; se: TPSExec;
319+ x: TPSRuntimeClassImporter);
320+ procedure SynMemo1Change(Sender: TObject);
321+ private
322+ function RunCompiledScript2(Bytecode: AnsiString; out
323+ RuntimeErrors: AnsiString): Boolean;
324+ { private declarations }
325+ public
326+ { public declarations }
327+ end;
328+
329+Const SCRIPTFILE = 'paswiki2.txt';
330+
331+var
332+ psForm1: TpsForm1;
333+
334+implementation
335+
336+{$R *.lfm}
337+
338+ uses uPSDisassembly;
339+
340+{ TpsForm1 }
341+
342+procedure TpsForm1.btnExecuteClick(Sender: TObject);
343+var res: boolean;
344+begin
345+ //showmessage('run max box');
346+ Res:= PSScript1.Execute;
347+ if not Res then
348+ memo1.lines.add('Run-time error:'+ PSScript1.ExecErrorToString) else
349+ image1.Show;
350+end;
351+
352+procedure MWritedt(d : TDateTime);
353+var
354+ s: String;
355+begin
356+ s:= DateToStr(d) + ' ' + TimeToStr(d);
357+ psForm1.memo1.lines.add(s);
358+end;
359+
360+procedure MWrites(const s: string);
361+begin
362+ psForm1.memo1.lines.add(s);
363+end;
364+
365+procedure MWritei(const i: Integer);
366+begin
367+ psForm1.memo1.lines.add(inttostr(i));
368+end;
369+
370+procedure MVal(const s: string; var n, z: Integer);
371+begin
372+ Val(s, n, z);
373+end;
374+
375+procedure TpsForm1.FormActivate(Sender: TObject);
376+begin
377+ synmemo1.Text:= '';
378+ synmemo1.Lines.LoadFromFile(SCRIPTFILE);
379+ self.caption:= SCRIPTFILE +' loaded '+caption;
380+ btnsaveComp.enabled:= false;
381+ btnExecute.enabled:= false;
382+ image1.hide;
383+end;
384+
385+procedure TpsForm1.PSScript1AfterExecute(Sender: TPSScript);
386+begin
387+ //
388+end;
389+
390+procedure TpsForm1.PSScript1Compile(Sender: TPSScript);
391+begin
392+ //your own executables
393+ Sender.AddFunction(@MWrites, 'procedure Writes(const s: string)');
394+ Sender.AddFunction(@MWritedt,'procedure WriteDT(d : TDateTime)');
395+ Sender.AddFunction(@MWritei, 'procedure Writei(const i: Integer)');
396+ Sender.AddFunction(@MWrites, 'procedure Writeln(const s: string)'); //alias
397+ Sender.AddFunction(@MVal, 'procedure Val(const s: string; var n, z: Integer)');
398+end;
399+
400+procedure TpsForm1.PSScript1CompImport(Sender: TObject; x: TPSPascalCompiler);
401+begin
402+ {uPSC_std.SIRegister_Std(X);
403+ uPSC_classes.SIRegister_Classes(X,true);
404+ SIRegister_Forms(x);
405+ SIRegister_Controls(x);}
406+end;
407+
408+procedure TpsForm1.PSScript1ExecImport(Sender: TObject; se: TPSExec;
409+ x: TPSRuntimeClassImporter);
410+begin
411+ //add lib at run- or designtime
412+ { RIRegister_Std(x);
413+ RIRegister_Classes(x,true);
414+ RIRegister_Forms(x);
415+ RIRegister_Controls(x);
416+ RegisterDateTimeLibrary_R(se);
417+ RegisterDLLRuntime(se); }
418+ {Se.RegisterDelphiFunction(@MWrites, 'procedure Writes(const s: string)', cdRegister);
419+ Se.RegisterDelphiFunction(@MWritedt,'procedure WriteDT(d : TDateTime)', cdRegister);
420+ Se.RegisterDelphiFunction(@MWritei, 'procedure Writei(const i: Integer)', cdRegister);
421+ Se.RegisterDelphiFunction(@MWrites, 'procedure Writeln(const s: string)', cdRegister); //alias
422+ Se.RegisterDelphiFunction(@MVal, 'procedure Val(const s: string; var n, z: Integer)', cdRegister);
423+ }
424+ // showmessage('import PORT ')
425+ //x.RegisterMethod(@MWrites, 'procedure Writes(const s: string)');
426+end;
427+
428+procedure TpsForm1.SynMemo1Change(Sender: TObject);
429+begin
430+ //showmessage('to debug gutter');
431+end;
432+
433+procedure TpsForm1.Compile1Click(Sender: TObject);
434+var
435+//S: TStringList;
436+i: Integer;
437+result: boolean;
438+ //showmessage('compile file');
439+begin
440+ Result:= False;
441+ //if FileExists(FileName) then begin
442+ //S:=TStringList.Create;
443+ //S.LoadFromFile(FileName);
444+ PSScript1.Script.Text:= Synmemo1.Text;
445+ result:= Psscript1.Compile;
446+ for i:= 0 to Psscript1.CompilerMessageCount - 1 do
447+ memo1.lines.add(Psscript1.CompilerMessages[i].MessageToString);
448+ //S.Free;
449+ if not Result then
450+ if Psscript1.CompilerMessageCount > 0 then
451+ for i:= 0 to Psscript1.CompilerMessageCount-1 do
452+ memo1.lines.add(Psscript1.CompilerErrorToStr(i));
453+ //else memo1.lines.add('Script File not found: ', FileName); }
454+ if Result then begin
455+ btnExecute.Enabled:= true;
456+ btnsaveComp.enabled:= true;
457+ end;
458+end;
459+
460+procedure TpsForm1.btnLoadScriptClick(Sender: TObject);
461+begin
462+ synMemo1.lines.loadFromFile(SCRIPTFILE)
463+end;
464+
465+procedure TpsForm1.btnImportClick(Sender: TObject);
466+begin
467+ //psForm1.Close;
468+ {if synmemo1.Focused then} synMemo1.PasteFromClipboard;
469+end;
470+
471+function TpsForm1.RunCompiledScript2(Bytecode: AnsiString; out RuntimeErrors: AnsiString): Boolean;
472+var Runtime: TPSExec; //to debug
473+begin
474+ Runtime:= TPSExec.Create;
475+ try
476+ //IFPS3ClassesPlugin1ExecImport(Self, runtime, classImporter);
477+ //PSScript1.RuntimeImporter.CreateAndRegister(runtime, false);
478+ result:= PSScript1.Exec.LoadData(bytecode)
479+ and PSScript1.Exec.RunScript and (PSScript1.Exec.ExceptionCode = erNoError);
480+ if not result then
481+ RunTimeErrors:= PSErrorToString(PSScript1.Exec.ExceptionCode,'');
482+
483+ //PSScript1.SetCompiled(Bytecode);
484+ //IFPS3DataToText(Bytecode,Bytecode);
485+ //memo1.lines.add(bytecode);
486+ finally
487+ Runtime.Free;
488+ end;
489+end;
490+
491+function LoadFile(const FileName: TFileName): string;
492+ begin
493+ with TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite) do begin
494+ try
495+ SetLength(Result, Size);
496+ Read(Pointer(Result)^, Size);
497+ except
498+ Result := ''; // Deallocates memory
499+ Free;
500+ raise;
501+ end;
502+ Free;
503+ end;
504+ end;
505+
506+procedure TpsForm1.btnRunbytecodeClick(Sender: TObject);
507+var sdata, filename, bcerrorcode: string;
508+ fhandle: THandle;
509+begin
510+ //sdata:= synmemo1.Text;
511+ //Compile1Click(self);
512+ //PSScript1.GetCompiled(sData);
513+ filename:= ExtractFilePath(ParamStr(0)) + ChangeFileExt(SCRIPTFILE,'.out');
514+ //fhandle:= fileopen(filename, 2);
515+ //fileread(fhandle, sdata, 100);
516+ sdata:= loadFile(filename);
517+ if RunCompiledScript2(sdata, bcerrorcode) then begin
518+ sysutils.beep;
519+ showmessage('Byte Code run success')
520+ end else
521+ Memo1.lines.add('ByteCode Error Message: '+bcerrorcode);
522+ // fileclose(fhandle)
523+ //PSScript1.SetCompiled(sData);
524+ //synmemo1.Text:= sData;
525+ //btnExecuteClick(self)
526+end;
527+
528+procedure TpsForm1.btnSaveScriptClick(Sender: TObject);
529+begin
530+ synMemo1.lines.saveToFile(SCRIPTFILE)
531+end;
532+
533+procedure TpsForm1.btnSaveCompClick(Sender: TObject);
534+var
535+ OutFile, sdata: string;
536+ Fx: Longint ;
537+begin
538+ PSScript1.GetCompiled(sData);
539+ OutFile:= ExtractFilePath(ParamStr(0)) + ChangeFileExt(SCRIPTFILE,'.out');
540+ Fx:= FileCreate(OutFile) ;
541+ FileWrite(Fx,sData[1],Length(sData));
542+ FileClose(Fx) ;
543+end;
544+
545+procedure TpsForm1.btngetCompiledClick(Sender: TObject);
546+var sdata: string;
547+begin
548+ PSScript1.GetCompiled(sData);
549+ // {if not} PSScript1.SetCompiled(sData);
550+ if not IFPS3DataToText(sData,sData)
551+ then memo1.lines.add('¡No puedo crear el desensamblado!')
552+ else
553+ synmemo1.Text:= sData;
554+ //aPSCE.SaveDissasembly(sData);
555+end;
556+
557+end.
558+```
559+
560+![](/wiki-images/6/67/MaXbox_mini_LAZARUS.png) ![](/wiki-images/9/9b/MaXbox_mini_LAZARUS2.png)
561+
562+---
563+*From the Free Pascal wiki, page "Pascal Script Examples", as it stood on 2020-02-23 after a change by Trev, out of the wiki's dump of 2024-05-26. Copyright stays with the author who wrote it, according to the old wiki's [[Licensing]] page. If you have concerns about this material, [message the admin](/wiki-contact).*

Back to history