Difference between revisions of "Pascal Script Examples"

From Lazarus wiki
Jump to navigationJump to search
m (Fixed syntax highlighting; removed categories included in template)
 
(20 intermediate revisions by 9 users not shown)
Line 1: Line 1:
<code>
+
{{Pascal Script Examples}}
 +
 
 +
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.
 +
 
 +
<syntaxhighlight lang=pascal>
 +
var
 +
  filename,emsg:string;
 +
begin
 +
    filename = '';
 +
    try
 +
      if filename = '' then
 +
          RaiseException(erCustomError, 'File name cannot be blank');
 +
 
 +
    except
 +
          emsg:=ExceptionToString(ExceptionType, ExceptionParam);
 +
          //do somethign with the exception message i.e. email it or
 +
          //save to a log etc
 +
    end;
 +
 
 +
end.
 +
 
 +
</syntaxhighlight>
 +
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.
 +
 
 +
Place a button on your form and create a new Onclick event for it and add this to it:
 +
<syntaxhighlight lang=pascal>
 +
ps_script.Script.LoadFromFile('yourscript.txt');
 +
if ps_script.compile then
 +
  ps_script.execute
 +
else
 +
  //show any compile errors
 +
  showmessage(ps_script.CompilerErrorToStr(0));
 +
 
 +
 
 +
</syntaxhighlight>
 +
 
 +
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.
 +
 
 +
<syntaxhighlight lang=pascal>
 +
 
 +
procedure TForm1.ps_ScriptCompile(Sender: TPSScript);
 +
begin
 +
    sender.AddFunction(@ExtractFileExt,'function ExtractFileExt(const FileName: string): string;');
 +
    sender.AddFunction(@ExtractFileName,'function ExtractFileName(const FileName: string): string;');
 +
end;
 +
</syntaxhighlight>
 +
 
 +
Your script will now have access to these functions.
 +
 
 +
 
 +
 
 +
 
 +
 
 +
The following examples are FPC code and do not show a script.
 +
 
 +
<syntaxhighlight lang=pascal>
 
program psce;
 
program psce;
 +
//enhanced with compiler messages to the shell and output to shell
 +
//bytecode and dissasembly output
 +
//jan 2011 www.softwareschule.ch/maxbox.htm, loc's =218
 
{$APPTYPE CONSOLE}
 
{$APPTYPE CONSOLE}
  
Line 8: Line 72:
  
 
uses
 
uses
   SysUtils,interfaces,Classes,Forms,uPSCompiler, uPSR_std, uPSC_std, uPSR_classes, uPSC_classes, uPSRuntime, uPSComponent,uPSDisassembly,
+
   SysUtils,
   uPSR_dateutils,uPSC_dateutils,uPSC_forms,uPSR_forms,uPSC_controls,uPSR_controls,uPSR_dll,uPSC_dll;
+
  Classes,
 +
  Forms,
 +
  uPSCompiler,
 +
  uPSR_std,
 +
  uPSC_std,
 +
  uPSR_classes,
 +
  uPSC_classes,
 +
  uPSC_controls,
 +
  uPSR_controls,
 +
  uPSC_forms,
 +
  uPSR_forms,
 +
  uPSRuntime,
 +
  uPSComponent,
 +
  uPSDisassembly,
 +
   uPSR_dateutils,
 +
  uPSC_dateutils,
 +
  uPSR_dll,
 +
  uPSC_dll;
  
 
type
 
type
Line 15: Line 96:
 
   protected
 
   protected
 
     FScr: TPSScript;
 
     FScr: TPSScript;
     procedure SaveCompiled(var Data : String);
+
     procedure SaveCompiled(var Data: String);
     procedure SaveDissasembly(var Data : String);
+
     procedure SaveDissasembly(var Data: String);
 
     procedure OnCompile(Sender: TPSScript);
 
     procedure OnCompile(Sender: TPSScript);
     procedure OnExecImport(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter);
+
     procedure OnExecImport(Sender: TObject; se: TPSExec;
 +
                                  x: TPSRuntimeClassImporter);
 
   public
 
   public
 
     constructor Create;
 
     constructor Create;
Line 29: Line 111:
 
var
 
var
 
   aPSCE: TPSCE;
 
   aPSCE: TPSCE;
   SFile,Data : String;
+
   SFile, sData: String;
  
  
 
procedure MWritedt(d : TDateTime);
 
procedure MWritedt(d : TDateTime);
 
var
 
var
  s : String;
+
  s: String;
 
begin
 
begin
   s := DateToStr(d) + ' ' + TimeToStr(d);
+
   s:= DateToStr(d) + ' ' + TimeToStr(d);
 
   Write(s);
 
   Write(s);
 
end;
 
end;
Line 45: Line 127:
 
   Write(s);
 
   Write(s);
 
end;
 
end;
 
 
  
 
procedure MWritei(const i: Integer);
 
procedure MWritei(const i: Integer);
Line 63: Line 143:
 
end;
 
end;
  
procedure MVal(const s: string; var n, z: Integer);
+
procedure MyVal(const s: string; var n, z: Integer);
 
begin
 
begin
 
   Val(s, n, z);
 
   Val(s, n, z);
Line 70: Line 150:
 
constructor TPSCE.Create;
 
constructor TPSCE.Create;
 
begin
 
begin
   FScr:=TPSScript.Create(nil);
+
   FScr:= TPSScript.Create(nil);
 
   FScr.OnCompile:= OnCompile;
 
   FScr.OnCompile:= OnCompile;
   FScr.OnExecImport := OnExecImport;
+
   FScr.OnExecImport:= OnExecImport;
 
end;
 
end;
  
Line 83: Line 163:
 
var
 
var
 
   OutFile: string;
 
   OutFile: string;
   Fx : Longint ;
+
   Fx: Longint ;
 
begin
 
begin
   OutFile := ExtractFilePath(ParamStr(0)) + ChangeFileExt(SFile,'.out');
+
   OutFile:= ExtractFilePath(ParamStr(0)) + ChangeFileExt(SFile,'.out');
 
   Fx:= FileCreate(OutFile) ;
 
   Fx:= FileCreate(OutFile) ;
 
   FileWrite(Fx,Data[1],Length(Data));
 
   FileWrite(Fx,Data[1],Length(Data));
   FileClose (Fx) ;
+
   FileClose(Fx) ;
 
end;
 
end;
  
procedure TPSCE.SaveDissasembly(var Data : String);
+
procedure TPSCE.SaveDissasembly(var Data: String);
 
var
 
var
 
   OutFile: string;
 
   OutFile: string;
   Fx : Longint ;
+
   Fx: Longint ;
 
begin
 
begin
   OutFile := ExtractFilePath(ParamStr(0)) + ChangeFileExt(SFile,'.dis');
+
   OutFile:= ExtractFilePath(ParamStr(0)) + ChangeFileExt(SFile,'.dis');
 
   Fx:= FileCreate(OutFile) ;
 
   Fx:= FileCreate(OutFile) ;
   FileWrite(Fx,Data[1],Length(Data));
+
   FileWrite(Fx, Data[1], Length(Data));
   FileClose (Fx) ;
+
   FileClose(Fx) ;
 
end;
 
end;
 
  
  
 
procedure TPSCE.OnExecImport(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter);
 
procedure TPSCE.OnExecImport(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter);
 
begin
 
begin
RIRegister_Std(x);
+
  RIRegister_Std(x);
RIRegister_Classes(x,true);
+
  RIRegister_Classes(x,true);
RIRegister_Forms(x);
+
  RIRegister_Controls(x);
RIRegister_Controls(x);
+
  RIRegister_Forms(x);
RegisterDateTimeLibrary_R(se);
+
  RegisterDateTimeLibrary_R(se);
RegisterDLLRuntime(se);
+
  RegisterDLLRuntime(se);
 
end;
 
end;
  
Line 122: Line 201:
 
   Sender.AddFunction(@MWrited, 'procedure Writed(const f: Double)');
 
   Sender.AddFunction(@MWrited, 'procedure Writed(const f: Double)');
 
   Sender.AddFunction(@MWriteln, 'procedure Writeln');
 
   Sender.AddFunction(@MWriteln, 'procedure Writeln');
   Sender.AddFunction(@MVal, 'procedure Val(const s: string; var n, z: Integer)');
+
   Sender.AddFunction(@MyVal, 'procedure Val(const s: string; var n, z: Integer)');
 +
  Sender.AddFunction(@FileCreate, 'Function FileCreate(const FileName: string): integer)');
 +
  Sender.AddFunction(@FileWrite, 'function FileWrite(Handle: Integer; const Buffer: pChar; Count: LongWord): Integer)');
 +
  Sender.AddFunction(@FileClose, 'Procedure FileClose(handle: integer)');
 +
  //Sender.AddRegisteredVariable('Application', 'TApplication');
 
   SIRegister_Std(Sender.Comp);
 
   SIRegister_Std(Sender.Comp);
 
   SIRegister_Classes(Sender.Comp,true);
 
   SIRegister_Classes(Sender.Comp,true);
 +
  SIRegister_Controls(Sender.Comp);
 
   SIRegister_Forms(Sender.Comp);
 
   SIRegister_Forms(Sender.Comp);
  SIRegister_Controls(Sender.Comp);
 
 
end;
 
end;
 +
  
 
function TPSCE.Compile(const FileName: string): Boolean;
 
function TPSCE.Compile(const FileName: string): Boolean;
Line 134: Line 218:
 
   i: Integer;
 
   i: Integer;
 
begin
 
begin
   Result:=False;
+
   Result:= False;
 
   if FileExists(FileName) then begin
 
   if FileExists(FileName) then begin
     S:=TStringList.Create;
+
     S:= TStringList.Create;
 
     S.LoadFromFile(FileName);
 
     S.LoadFromFile(FileName);
     FScr.Script:=S;
+
     FScr.Script:= S;
     Result:=FScr.Compile;
+
     Result:= FScr.Compile;
 +
    for i:= 0 to aPSCE.FScr.CompilerMessageCount - 1 do
 +
      writeln(aPSCE.FScr.CompilerMessages[i].MessageToString);
 
     S.Free;
 
     S.Free;
 
     if not Result then
 
     if not Result then
       if FScr.CompilerMessageCount &gt; 0 then
+
       if FScr.CompilerMessageCount > 0 then
         for i:=0 to FScr.CompilerMessageCount-1 do
+
         for i:= 0 to FScr.CompilerMessageCount-1 do
 
           Writeln(FScr.CompilerErrorToStr(i));
 
           Writeln(FScr.CompilerErrorToStr(i));
  end else Writeln('File not found: ', FileName);
+
      end else Writeln('Script File not found: ', FileName);
 
end;
 
end;
  
 
function TPSCE.Execute: Boolean;
 
function TPSCE.Execute: Boolean;
 
begin
 
begin
   Result:=FScr.Execute;
+
  //FScr.SetVarToInstance('APPLICATION', Application);
 +
  //FScr.SetVarToInstance('SELF', Self);
 +
   Result:= FScr.Execute;
 +
  //writeln(FScr.About);
 
   if not Result then
 
   if not Result then
 
     Writeln('Run-time error:' + FScr.ExecErrorToString);
 
     Writeln('Run-time error:' + FScr.ExecErrorToString);
Line 156: Line 245:
  
  
 
+
begin //main
 
 
begin
 
 
   Application.Initialize;
 
   Application.Initialize;
   aPSCE:=TPSCE.Create;
+
   aPSCE:= TPSCE.Create;
   if ParamCount = 0 then  
+
   if ParamCount = 0 then begin
  begin
+
     Writeln('Usage: ', ExtractFileName(ParamStr(0)), ' [--compile|--dissasembly] <script.pss>');
     Writeln('Usage: ', ExtractFileName(ParamStr(0)), ' [--compile|--dissasembly] &lt;script.pss&gt;');
 
 
     Writeln('');
 
     Writeln('');
 
     Writeln('--compile : Save compiled script bytecode');
 
     Writeln('--compile : Save compiled script bytecode');
Line 169: Line 255:
 
     Exit;
 
     Exit;
 
   end;
 
   end;
 
+
  SFile:= ParamStr(1);
  SFile := ParamStr(1);
+
  if (ParamStr(1)='--compile') or (ParamStr(1)='--dissasembly') then begin
  if (ParamStr(1)='--compile') or (ParamStr(1)='--dissasembly') then
+
   SFile:= ParamStr(2);
begin
 
   SFile := ParamStr(2);
 
 
   aPSCE.Compile(SFile);
 
   aPSCE.Compile(SFile);
   aPSCE.FScr.GetCompiled(Data);
+
  aPSCE.Execute;  //output on shell
   if Paramstr(1)='--compile' then aPSCE.SaveCompiled(Data);
+
   aPSCE.FScr.GetCompiled(sData);
   if Paramstr(1)='--dissasembly' then
+
   if Paramstr(1)='--compile' then begin
  begin
+
    aPSCE.FScr.Comp.GetOutput(sData);
     if not IFPS3DataToText(Data,Data) then Writeln('Cannot create dissasembly!')
+
    aPSCE.SaveCompiled(sData);
     else
+
  end;
     aPSCE.SaveDissasembly(Data);
+
   if Paramstr(1)='--dissasembly' then begin
 +
    aPSCE.FScr.GetCompiled(sData);
 +
     if not IFPS3DataToText(sData, sData)
 +
      then begin
 +
        Writeln('Create or create not dissasembly!');
 +
        aPSCE.SaveDissasembly(sData);  //do it anyway
 +
     end else
 +
     aPSCE.SaveDissasembly(sData);
 
   end;
 
   end;
Exit;
+
  Exit;
 
  end;
 
  end;
 
 
 
  aPSCE.Compile(SFile);
 
  aPSCE.Compile(SFile);
 
  aPSCE.Execute;
 
  aPSCE.Execute;
Line 192: Line 281:
 
end.
 
end.
  
</code>
+
</syntaxhighlight>
 +
 
 +
 
 +
2. Example of Lazarus with GUI Components
 +
 
 +
<syntaxhighlight lang=pascal>
 +
 
 +
unit unit1pscript2;
 +
//compiled by max
 +
////oct 2014: www.softwareschule.ch/maxbox.htm
 +
 
 +
{$mode objfpc}{$H+}
 +
 
 +
interface
 +
 
 +
uses
 +
  Classes, SysUtils, FileUtil, SynMemo, SynHighlighterPas, uPSComponent,
 +
  uPSComponent_Default, uPSComponent_StdCtrls, uPSComponent_Forms, Forms,
 +
  Controls, Graphics, Dialogs, StdCtrls, Buttons, ExtCtrls, uPSRuntime,
 +
  uPSComponent_DB, uPSCompiler;
 +
 
 +
type
 +
 
 +
  { TpsForm1 }
 +
  TpsForm1 = class(TForm)
 +
    btnImport: TBitBtn;
 +
    btnCompile: TBitBtn;
 +
    btnSaveScript: TBitBtn;
 +
    btnSaveComp: TBitBtn;
 +
    btnLoadScript: TBitBtn;
 +
    btngetCompiled: TBitBtn;
 +
    btnExecute: TButton;
 +
    btnRunbytecode: TButton;
 +
    Image1: TImage;
 +
    Image2: TImage;
 +
    Memo1: TMemo;
 +
    PSImport_Classes1: TPSImport_Classes;
 +
    PSImport_DateUtils1: TPSImport_DateUtils;
 +
    PSImport_DB1: TPSImport_DB;
 +
    PSImport_Forms1: TPSImport_Forms;
 +
    PSImport_StdCtrls1: TPSImport_StdCtrls;
 +
    PSScript1: TPSScript;
 +
    SynMemo1: TSynMemo;
 +
    SynPasSyn1: TSynPasSyn;
 +
    procedure btnImportClick(Sender: TObject);
 +
    procedure btnLoadScriptClick(Sender: TObject);
 +
    procedure btnRunbytecodeClick(Sender: TObject);
 +
    procedure Compile1Click(Sender: TObject);
 +
    procedure btnSaveScriptClick(Sender: TObject);
 +
    procedure btnSaveCompClick(Sender: TObject);
 +
    procedure btngetCompiledClick(Sender: TObject);
 +
    procedure btnExecuteClick(Sender: TObject);
 +
    procedure FormActivate(Sender: TObject);
 +
    procedure PSScript1AfterExecute(Sender: TPSScript);
 +
    procedure PSScript1Compile(Sender: TPSScript);
 +
    procedure PSScript1CompImport(Sender: TObject; x: TPSPascalCompiler);
 +
    procedure PSScript1ExecImport(Sender: TObject; se: TPSExec;
 +
      x: TPSRuntimeClassImporter);
 +
    procedure SynMemo1Change(Sender: TObject);
 +
  private
 +
    function RunCompiledScript2(Bytecode: AnsiString; out
 +
      RuntimeErrors: AnsiString): Boolean;
 +
    { private declarations }
 +
  public
 +
    { public declarations }
 +
  end;
 +
 
 +
Const SCRIPTFILE = 'paswiki2.txt';
 +
 
 +
var
 +
  psForm1: TpsForm1;
 +
 
 +
implementation
 +
 
 +
{$R *.lfm}
 +
 
 +
uses  uPSDisassembly;
 +
 
 +
{ TpsForm1 }
 +
 
 +
procedure TpsForm1.btnExecuteClick(Sender: TObject);
 +
var res: boolean;
 +
begin
 +
  //showmessage('run max box');
 +
  Res:= PSScript1.Execute;
 +
  if not Res then
 +
    memo1.lines.add('Run-time error:'+ PSScript1.ExecErrorToString) else
 +
      image1.Show;
 +
end;
 +
 
 +
procedure MWritedt(d : TDateTime);
 +
var
 +
s: String;
 +
begin
 +
  s:= DateToStr(d) + ' ' + TimeToStr(d);
 +
  psForm1.memo1.lines.add(s);
 +
end;
 +
 
 +
procedure MWrites(const s: string);
 +
begin
 +
  psForm1.memo1.lines.add(s);
 +
end;
 +
 
 +
procedure MWritei(const i: Integer);
 +
begin
 +
  psForm1.memo1.lines.add(inttostr(i));
 +
end;
 +
 
 +
procedure MVal(const s: string; var n, z: Integer);
 +
begin
 +
  Val(s, n, z);
 +
end;
 +
 
 +
 
 +
procedure TpsForm1.FormActivate(Sender: TObject);
 +
begin
 +
  synmemo1.Text:= '';
 +
  synmemo1.Lines.LoadFromFile(SCRIPTFILE);
 +
  self.caption:= SCRIPTFILE +' loaded '+caption;
 +
  btnsaveComp.enabled:= false;
 +
  btnExecute.enabled:= false;
 +
  image1.hide;
 +
end;
 +
 
 +
procedure TpsForm1.PSScript1AfterExecute(Sender: TPSScript);
 +
begin
 +
  //
 +
end;
 +
 
 +
procedure TpsForm1.PSScript1Compile(Sender: TPSScript);
 +
begin
 +
  //your own executables
 +
  Sender.AddFunction(@MWrites, 'procedure Writes(const s: string)');
 +
  Sender.AddFunction(@MWritedt,'procedure WriteDT(d : TDateTime)');
 +
  Sender.AddFunction(@MWritei, 'procedure Writei(const i: Integer)');
 +
  Sender.AddFunction(@MWrites, 'procedure Writeln(const s: string)');  //alias
 +
  Sender.AddFunction(@MVal, 'procedure Val(const s: string; var n, z: Integer)');
 +
end;
 +
 
 +
procedure TpsForm1.PSScript1CompImport(Sender: TObject; x: TPSPascalCompiler);
 +
begin
 +
  {uPSC_std.SIRegister_Std(X);
 +
  uPSC_classes.SIRegister_Classes(X,true);
 +
  SIRegister_Forms(x);
 +
  SIRegister_Controls(x);}
 +
end;
 +
 
 +
procedure TpsForm1.PSScript1ExecImport(Sender: TObject; se: TPSExec;
 +
  x: TPSRuntimeClassImporter);
 +
begin
 +
  //add lib at run- or designtime
 +
  {  RIRegister_Std(x);
 +
  RIRegister_Classes(x,true);
 +
  RIRegister_Forms(x);
 +
  RIRegister_Controls(x);
 +
  RegisterDateTimeLibrary_R(se);
 +
  RegisterDLLRuntime(se); }
 +
  {Se.RegisterDelphiFunction(@MWrites, 'procedure Writes(const s: string)', cdRegister);
 +
  Se.RegisterDelphiFunction(@MWritedt,'procedure WriteDT(d : TDateTime)', cdRegister);
 +
  Se.RegisterDelphiFunction(@MWritei, 'procedure Writei(const i: Integer)', cdRegister);
 +
  Se.RegisterDelphiFunction(@MWrites, 'procedure Writeln(const s: string)', cdRegister);  //alias
 +
  Se.RegisterDelphiFunction(@MVal, 'procedure Val(const s: string; var n, z: Integer)', cdRegister);
 +
  }
 +
  // showmessage('import PORT ')
 +
  //x.RegisterMethod(@MWrites, 'procedure Writes(const s: string)');
 +
end;
 +
 
 +
procedure TpsForm1.SynMemo1Change(Sender: TObject);
 +
begin
 +
  //showmessage('to debug gutter');
 +
end;
 +
 
 +
procedure TpsForm1.Compile1Click(Sender: TObject);
 +
var
 +
//S: TStringList;
 +
i: Integer;
 +
result: boolean;
 +
  //showmessage('compile file');
 +
begin
 +
  Result:= False;
 +
  //if FileExists(FileName) then begin
 +
    //S:=TStringList.Create;
 +
    //S.LoadFromFile(FileName);
 +
    PSScript1.Script.Text:= Synmemo1.Text;
 +
    result:= Psscript1.Compile;
 +
    for i:= 0 to Psscript1.CompilerMessageCount - 1 do
 +
      memo1.lines.add(Psscript1.CompilerMessages[i].MessageToString);
 +
    //S.Free;
 +
    if not Result then
 +
      if Psscript1.CompilerMessageCount > 0 then
 +
        for i:= 0 to Psscript1.CompilerMessageCount-1 do
 +
          memo1.lines.add(Psscript1.CompilerErrorToStr(i));
 +
    //else memo1.lines.add('Script File not found: ', FileName); }
 +
    if Result then begin
 +
      btnExecute.Enabled:= true;
 +
      btnsaveComp.enabled:= true;
 +
    end;
 +
end;
 +
 
 +
procedure TpsForm1.btnLoadScriptClick(Sender: TObject);
 +
begin
 +
synMemo1.lines.loadFromFile(SCRIPTFILE)
 +
end;
 +
 
 +
procedure TpsForm1.btnImportClick(Sender: TObject);
 +
begin
 +
  //psForm1.Close;
 +
{if synmemo1.Focused then} synMemo1.PasteFromClipboard;
 +
end;
 +
 
 +
 
 +
function TpsForm1.RunCompiledScript2(Bytecode: AnsiString; out RuntimeErrors: AnsiString): Boolean;
 +
var Runtime: TPSExec;  //to debug
 +
begin
 +
  Runtime:= TPSExec.Create;
 +
  try
 +
    //IFPS3ClassesPlugin1ExecImport(Self, runtime, classImporter);
 +
    //PSScript1.RuntimeImporter.CreateAndRegister(runtime, false);
 +
    result:= PSScript1.Exec.LoadData(bytecode)
 +
            and PSScript1.Exec.RunScript and (PSScript1.Exec.ExceptionCode = erNoError);
 +
    if not result then
 +
      RunTimeErrors:= PSErrorToString(PSScript1.Exec.ExceptionCode,'');
 +
 
 +
    //PSScript1.SetCompiled(Bytecode);
 +
    //IFPS3DataToText(Bytecode,Bytecode);
 +
    //memo1.lines.add(bytecode);
 +
  finally
 +
    Runtime.Free;
 +
  end;
 +
end;
 +
 
 +
 
 +
function LoadFile(const FileName: TFileName): string;
 +
  begin
 +
    with TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite) do begin
 +
      try
 +
        SetLength(Result, Size);
 +
        Read(Pointer(Result)^, Size);
 +
      except
 +
        Result := '';  // Deallocates memory
 +
        Free;
 +
        raise;
 +
      end;
 +
      Free;
 +
    end;
 +
  end;
 +
 
 +
 
 +
procedure TpsForm1.btnRunbytecodeClick(Sender: TObject);
 +
var sdata, filename, bcerrorcode: string;
 +
  fhandle: THandle;
 +
begin
 +
  //sdata:= synmemo1.Text;
 +
  //Compile1Click(self);
 +
  //PSScript1.GetCompiled(sData);
 +
    filename:= ExtractFilePath(ParamStr(0)) + ChangeFileExt(SCRIPTFILE,'.out');
 +
    //fhandle:= fileopen(filename, 2);
 +
    //fileread(fhandle, sdata, 100);
 +
  sdata:= loadFile(filename);
 +
  if RunCompiledScript2(sdata, bcerrorcode) then begin
 +
      sysutils.beep;
 +
      showmessage('Byte Code run success')
 +
  end else
 +
      Memo1.lines.add('ByteCode Error Message: '+bcerrorcode);
 +
    // fileclose(fhandle)
 +
  //PSScript1.SetCompiled(sData);
 +
  //synmemo1.Text:= sData;
 +
  //btnExecuteClick(self)
 +
end;
 +
 
 +
procedure TpsForm1.btnSaveScriptClick(Sender: TObject);
 +
begin
 +
  synMemo1.lines.saveToFile(SCRIPTFILE)
 +
end;
 +
 
 +
procedure TpsForm1.btnSaveCompClick(Sender: TObject);
 +
var
 +
  OutFile, sdata: string;
 +
  Fx: Longint ;
 +
begin
 +
  PSScript1.GetCompiled(sData);
 +
  OutFile:= ExtractFilePath(ParamStr(0)) + ChangeFileExt(SCRIPTFILE,'.out');
 +
  Fx:= FileCreate(OutFile) ;
 +
  FileWrite(Fx,sData[1],Length(sData));
 +
  FileClose(Fx) ;
 +
end;
 +
 
 +
procedure TpsForm1.btngetCompiledClick(Sender: TObject);
 +
var sdata: string;
 +
begin
 +
  PSScript1.GetCompiled(sData);
 +
  // {if not} PSScript1.SetCompiled(sData);
 +
  if not IFPS3DataToText(sData,sData)
 +
    then memo1.lines.add('¡No puedo crear el desensamblado!')
 +
  else
 +
    synmemo1.Text:= sData;
 +
  //aPSCE.SaveDissasembly(sData);
 +
end;
 +
 
 +
end.
 +
 
 +
</syntaxhighlight>
  
--[[User:Forest|Forest]] 23:00, 22 Oct 2005 (CEST)
+
[[File:maXbox_mini_LAZARUS.png]]
 +
[[File:maXbox_mini_LAZARUS2.png]]

Latest revision as of 06:30, 23 February 2020

English (en) español (es)

This is a simple example of a actual script that shows how to do try except with raising a exception and doing something with the exception message.

var
   filename,emsg:string;
begin
    filename = '';
    try
       if filename = '' then
          RaiseException(erCustomError, 'File name cannot be blank');

    except
          emsg:=ExceptionToString(ExceptionType, ExceptionParam);
          //do somethign with the exception message i.e. email it or
          //save to a log etc
    end;

end.

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.

Place a button on your form and create a new Onclick event for it and add this to it:

ps_script.Script.LoadFromFile('yourscript.txt');
if ps_script.compile then
   ps_script.execute
else
   //show any compile errors
   showmessage(ps_script.CompilerErrorToStr(0));

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.

procedure TForm1.ps_ScriptCompile(Sender: TPSScript);
begin
     sender.AddFunction(@ExtractFileExt,'function ExtractFileExt(const FileName: string): string;');
     sender.AddFunction(@ExtractFileName,'function ExtractFileName(const FileName: string): string;');
 end;

Your script will now have access to these functions.



The following examples are FPC code and do not show a script.

program psce;
//enhanced with compiler messages to the shell and output to shell
//bytecode and dissasembly output
//jan 2011 www.softwareschule.ch/maxbox.htm, loc's =218
{$APPTYPE CONSOLE}

{$IFDEF FPC}
{$mode delphi}{$H+}
{$ENDIF}

uses
  SysUtils,
  Classes,
  Forms,
  uPSCompiler,
  uPSR_std,
  uPSC_std,
  uPSR_classes,
  uPSC_classes,
  uPSC_controls,
  uPSR_controls,
  uPSC_forms,
  uPSR_forms,
  uPSRuntime,
  uPSComponent,
  uPSDisassembly,
  uPSR_dateutils,
  uPSC_dateutils,
  uPSR_dll,
  uPSC_dll;

type
  TPSCE = class
   protected
    FScr: TPSScript;
    procedure SaveCompiled(var Data: String);
    procedure SaveDissasembly(var Data: String);
    procedure OnCompile(Sender: TPSScript);
    procedure OnExecImport(Sender: TObject; se: TPSExec;
                                   x: TPSRuntimeClassImporter);
   public
    constructor Create;
    destructor Destroy; override;
    function Compile(const FileName: string): Boolean;
    function Execute: Boolean;
  end;


var
  aPSCE: TPSCE;
  SFile, sData: String;


procedure MWritedt(d : TDateTime);
var
 s: String;
begin
  s:= DateToStr(d) + ' ' + TimeToStr(d);
  Write(s);
end;


procedure MWrites(const s: string);
begin
  Write(s);
end;

procedure MWritei(const i: Integer);
begin
  Write(i);
end;

procedure MWrited(const d: Double);
begin
  Write(d:0:1);
end;

procedure MWriteln;
begin
  Writeln;
end;

procedure MyVal(const s: string; var n, z: Integer);
begin
  Val(s, n, z);
end;

constructor TPSCE.Create;
begin
  FScr:= TPSScript.Create(nil);
  FScr.OnCompile:= OnCompile;
  FScr.OnExecImport:= OnExecImport;
end;

destructor TPSCE.Destroy;
begin
  FScr.Free;
end;

procedure TPSCE.SaveCompiled(var Data : String);
var
  OutFile: string;
  Fx: Longint ;
begin
  OutFile:= ExtractFilePath(ParamStr(0)) + ChangeFileExt(SFile,'.out');
  Fx:= FileCreate(OutFile) ;
  FileWrite(Fx,Data[1],Length(Data));
  FileClose(Fx) ;
end;

procedure TPSCE.SaveDissasembly(var Data: String);
var
  OutFile: string;
  Fx: Longint ;
begin
  OutFile:= ExtractFilePath(ParamStr(0)) + ChangeFileExt(SFile,'.dis');
  Fx:= FileCreate(OutFile) ;
  FileWrite(Fx, Data[1], Length(Data));
  FileClose(Fx) ;
end;


procedure TPSCE.OnExecImport(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter);
begin
  RIRegister_Std(x);
  RIRegister_Classes(x,true);
  RIRegister_Controls(x);
  RIRegister_Forms(x);
  RegisterDateTimeLibrary_R(se);
  RegisterDLLRuntime(se);
end;

procedure TPSCE.OnCompile(Sender: TPSScript);
begin
  RegisterDateTimeLibrary_C(Sender.Comp);
  Sender.AddFunction(@MWrites, 'procedure Writes(const s: string)');
  Sender.AddFunction(@MWritedt,'procedure WriteDT(d : TDateTime)');
  Sender.AddFunction(@MWritei, 'procedure Writei(const i: Integer)');
  Sender.AddFunction(@MWrited, 'procedure Writed(const f: Double)');
  Sender.AddFunction(@MWriteln, 'procedure Writeln');
  Sender.AddFunction(@MyVal, 'procedure Val(const s: string; var n, z: Integer)');
  Sender.AddFunction(@FileCreate, 'Function FileCreate(const FileName: string): integer)');
  Sender.AddFunction(@FileWrite, 'function FileWrite(Handle: Integer; const Buffer: pChar; Count: LongWord): Integer)');
  Sender.AddFunction(@FileClose, 'Procedure FileClose(handle: integer)');
  //Sender.AddRegisteredVariable('Application', 'TApplication');
  SIRegister_Std(Sender.Comp);
  SIRegister_Classes(Sender.Comp,true);
  SIRegister_Controls(Sender.Comp);
  SIRegister_Forms(Sender.Comp);
end;


function TPSCE.Compile(const FileName: string): Boolean;
var
  S: TStringList;
  i: Integer;
begin
  Result:= False;
  if FileExists(FileName) then begin
    S:= TStringList.Create;
    S.LoadFromFile(FileName);
    FScr.Script:= S;
    Result:= FScr.Compile;
    for i:= 0 to aPSCE.FScr.CompilerMessageCount - 1 do
      writeln(aPSCE.FScr.CompilerMessages[i].MessageToString);
    S.Free;
    if not Result then
      if FScr.CompilerMessageCount > 0 then
        for i:= 0 to FScr.CompilerMessageCount-1 do
          Writeln(FScr.CompilerErrorToStr(i));
      end else Writeln('Script File not found: ', FileName);
end;

function TPSCE.Execute: Boolean;
begin
  //FScr.SetVarToInstance('APPLICATION', Application);
  //FScr.SetVarToInstance('SELF', Self);
  Result:= FScr.Execute;
  //writeln(FScr.About);
  if not Result then
    Writeln('Run-time error:' + FScr.ExecErrorToString);
end;


begin  //main
  Application.Initialize;
  aPSCE:= TPSCE.Create;
  if ParamCount = 0 then begin
    Writeln('Usage: ', ExtractFileName(ParamStr(0)), ' [--compile|--dissasembly] <script.pss>');
    Writeln('');
    Writeln('--compile : Save compiled script bytecode');
    Writeln('--dissasembly: Save dissasembly of script');
    Exit;
  end;
 SFile:= ParamStr(1);
 if (ParamStr(1)='--compile') or (ParamStr(1)='--dissasembly') then begin
  SFile:= ParamStr(2);
  aPSCE.Compile(SFile);
  aPSCE.Execute;   //output on shell
  aPSCE.FScr.GetCompiled(sData);
  if Paramstr(1)='--compile' then begin
    aPSCE.FScr.Comp.GetOutput(sData);
    aPSCE.SaveCompiled(sData);
  end;
  if Paramstr(1)='--dissasembly' then begin
    aPSCE.FScr.GetCompiled(sData);
    if not IFPS3DataToText(sData, sData)
      then begin
        Writeln('Create or create not dissasembly!');
        aPSCE.SaveDissasembly(sData);  //do it anyway
    end else
    aPSCE.SaveDissasembly(sData);
  end;
  Exit;
 end;
 aPSCE.Compile(SFile);
 aPSCE.Execute;
 aPSCE.Free;
end.


2. Example of Lazarus with GUI Components

unit unit1pscript2;
//compiled by max
////oct 2014: www.softwareschule.ch/maxbox.htm

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, SynMemo, SynHighlighterPas, uPSComponent,
  uPSComponent_Default, uPSComponent_StdCtrls, uPSComponent_Forms, Forms,
  Controls, Graphics, Dialogs, StdCtrls, Buttons, ExtCtrls, uPSRuntime,
  uPSComponent_DB, uPSCompiler;

type

  { TpsForm1 }
   TpsForm1 = class(TForm)
    btnImport: TBitBtn;
    btnCompile: TBitBtn;
    btnSaveScript: TBitBtn;
    btnSaveComp: TBitBtn;
    btnLoadScript: TBitBtn;
    btngetCompiled: TBitBtn;
    btnExecute: TButton;
    btnRunbytecode: TButton;
    Image1: TImage;
    Image2: TImage;
    Memo1: TMemo;
    PSImport_Classes1: TPSImport_Classes;
    PSImport_DateUtils1: TPSImport_DateUtils;
    PSImport_DB1: TPSImport_DB;
    PSImport_Forms1: TPSImport_Forms;
    PSImport_StdCtrls1: TPSImport_StdCtrls;
    PSScript1: TPSScript;
    SynMemo1: TSynMemo;
    SynPasSyn1: TSynPasSyn;
    procedure btnImportClick(Sender: TObject);
    procedure btnLoadScriptClick(Sender: TObject);
    procedure btnRunbytecodeClick(Sender: TObject);
    procedure Compile1Click(Sender: TObject);
    procedure btnSaveScriptClick(Sender: TObject);
    procedure btnSaveCompClick(Sender: TObject);
    procedure btngetCompiledClick(Sender: TObject);
    procedure btnExecuteClick(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure PSScript1AfterExecute(Sender: TPSScript);
    procedure PSScript1Compile(Sender: TPSScript);
    procedure PSScript1CompImport(Sender: TObject; x: TPSPascalCompiler);
    procedure PSScript1ExecImport(Sender: TObject; se: TPSExec;
      x: TPSRuntimeClassImporter);
    procedure SynMemo1Change(Sender: TObject);
  private
    function RunCompiledScript2(Bytecode: AnsiString; out
      RuntimeErrors: AnsiString): Boolean;
    { private declarations }
  public
    { public declarations }
  end;

Const SCRIPTFILE = 'paswiki2.txt';

var
  psForm1: TpsForm1;

implementation

{$R *.lfm}

 uses  uPSDisassembly;

{ TpsForm1 }

procedure TpsForm1.btnExecuteClick(Sender: TObject);
var res: boolean;
begin
  //showmessage('run max box');
   Res:= PSScript1.Execute;
   if not Res then
     memo1.lines.add('Run-time error:'+ PSScript1.ExecErrorToString) else
       image1.Show;
end;

procedure MWritedt(d : TDateTime);
var
 s: String;
begin
  s:= DateToStr(d) + ' ' + TimeToStr(d);
  psForm1.memo1.lines.add(s);
end;

procedure MWrites(const s: string);
begin
  psForm1.memo1.lines.add(s);
end;

procedure MWritei(const i: Integer);
begin
  psForm1.memo1.lines.add(inttostr(i));
end;

procedure MVal(const s: string; var n, z: Integer);
begin
  Val(s, n, z);
end;


procedure TpsForm1.FormActivate(Sender: TObject);
begin
  synmemo1.Text:= '';
  synmemo1.Lines.LoadFromFile(SCRIPTFILE);
  self.caption:= SCRIPTFILE +' loaded '+caption;
  btnsaveComp.enabled:= false;
  btnExecute.enabled:= false;
  image1.hide;
end;

procedure TpsForm1.PSScript1AfterExecute(Sender: TPSScript);
begin
  //
end;

procedure TpsForm1.PSScript1Compile(Sender: TPSScript);
begin
  //your own executables
  Sender.AddFunction(@MWrites, 'procedure Writes(const s: string)');
  Sender.AddFunction(@MWritedt,'procedure WriteDT(d : TDateTime)');
  Sender.AddFunction(@MWritei, 'procedure Writei(const i: Integer)');
  Sender.AddFunction(@MWrites, 'procedure Writeln(const s: string)');  //alias
  Sender.AddFunction(@MVal, 'procedure Val(const s: string; var n, z: Integer)');
end;

procedure TpsForm1.PSScript1CompImport(Sender: TObject; x: TPSPascalCompiler);
begin
  {uPSC_std.SIRegister_Std(X);
  uPSC_classes.SIRegister_Classes(X,true);
  SIRegister_Forms(x);
  SIRegister_Controls(x);}
end;

procedure TpsForm1.PSScript1ExecImport(Sender: TObject; se: TPSExec;
  x: TPSRuntimeClassImporter);
begin
  //add lib at run- or designtime
  {  RIRegister_Std(x);
  RIRegister_Classes(x,true);
  RIRegister_Forms(x);
  RIRegister_Controls(x);
  RegisterDateTimeLibrary_R(se);
  RegisterDLLRuntime(se); }
  {Se.RegisterDelphiFunction(@MWrites, 'procedure Writes(const s: string)', cdRegister);
  Se.RegisterDelphiFunction(@MWritedt,'procedure WriteDT(d : TDateTime)', cdRegister);
  Se.RegisterDelphiFunction(@MWritei, 'procedure Writei(const i: Integer)', cdRegister);
  Se.RegisterDelphiFunction(@MWrites, 'procedure Writeln(const s: string)', cdRegister);  //alias
  Se.RegisterDelphiFunction(@MVal, 'procedure Val(const s: string; var n, z: Integer)', cdRegister);
  }
  // showmessage('import PORT ')
  //x.RegisterMethod(@MWrites, 'procedure Writes(const s: string)');
end;

procedure TpsForm1.SynMemo1Change(Sender: TObject);
begin
  //showmessage('to debug gutter');
end;

procedure TpsForm1.Compile1Click(Sender: TObject);
var
//S: TStringList;
i: Integer;
result: boolean;
  //showmessage('compile file');
begin
  Result:= False;
  //if FileExists(FileName) then begin
    //S:=TStringList.Create;
    //S.LoadFromFile(FileName);
    PSScript1.Script.Text:= Synmemo1.Text;
    result:= Psscript1.Compile;
    for i:= 0 to Psscript1.CompilerMessageCount - 1 do
      memo1.lines.add(Psscript1.CompilerMessages[i].MessageToString);
    //S.Free;
    if not Result then
      if Psscript1.CompilerMessageCount > 0 then
        for i:= 0 to Psscript1.CompilerMessageCount-1 do
          memo1.lines.add(Psscript1.CompilerErrorToStr(i));
    //else memo1.lines.add('Script File not found: ', FileName); }
    if Result then begin
      btnExecute.Enabled:= true;
      btnsaveComp.enabled:= true;
    end;
end;

procedure TpsForm1.btnLoadScriptClick(Sender: TObject);
begin
 synMemo1.lines.loadFromFile(SCRIPTFILE)
end;

procedure TpsForm1.btnImportClick(Sender: TObject);
begin
  //psForm1.Close;
 {if synmemo1.Focused then} synMemo1.PasteFromClipboard;
end;


function TpsForm1.RunCompiledScript2(Bytecode: AnsiString; out RuntimeErrors: AnsiString): Boolean;
var Runtime: TPSExec;  //to debug
begin
  Runtime:= TPSExec.Create;
  try
    //IFPS3ClassesPlugin1ExecImport(Self, runtime, classImporter);
    //PSScript1.RuntimeImporter.CreateAndRegister(runtime, false);
     result:= PSScript1.Exec.LoadData(bytecode)
             and PSScript1.Exec.RunScript and (PSScript1.Exec.ExceptionCode = erNoError);
     if not result then
       RunTimeErrors:= PSErrorToString(PSScript1.Exec.ExceptionCode,'');

    //PSScript1.SetCompiled(Bytecode);
    //IFPS3DataToText(Bytecode,Bytecode);
    //memo1.lines.add(bytecode);
  finally
    Runtime.Free;
  end;
end;


function LoadFile(const FileName: TFileName): string;
   begin
     with TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite) do begin
       try
         SetLength(Result, Size);
         Read(Pointer(Result)^, Size);
       except
         Result := '';  // Deallocates memory
         Free;
         raise;
       end;
       Free;
     end;
   end;


procedure TpsForm1.btnRunbytecodeClick(Sender: TObject);
var sdata, filename, bcerrorcode: string;
  fhandle: THandle;
begin
   //sdata:= synmemo1.Text;
   //Compile1Click(self);
   //PSScript1.GetCompiled(sData);
    filename:= ExtractFilePath(ParamStr(0)) + ChangeFileExt(SCRIPTFILE,'.out');
    //fhandle:= fileopen(filename, 2);
    //fileread(fhandle, sdata, 100);
   sdata:= loadFile(filename);
   if RunCompiledScript2(sdata, bcerrorcode) then begin
       sysutils.beep;
       showmessage('Byte Code run success')
   end else
      Memo1.lines.add('ByteCode Error Message: '+bcerrorcode);
    // fileclose(fhandle)
   //PSScript1.SetCompiled(sData);
   //synmemo1.Text:= sData;
   //btnExecuteClick(self)
end;

procedure TpsForm1.btnSaveScriptClick(Sender: TObject);
begin
  synMemo1.lines.saveToFile(SCRIPTFILE)
end;

procedure TpsForm1.btnSaveCompClick(Sender: TObject);
var
  OutFile, sdata: string;
  Fx: Longint ;
begin
  PSScript1.GetCompiled(sData);
  OutFile:= ExtractFilePath(ParamStr(0)) + ChangeFileExt(SCRIPTFILE,'.out');
  Fx:= FileCreate(OutFile) ;
  FileWrite(Fx,sData[1],Length(sData));
  FileClose(Fx) ;
end;

procedure TpsForm1.btngetCompiledClick(Sender: TObject);
var sdata: string;
begin
   PSScript1.GetCompiled(sData);
   // {if not} PSScript1.SetCompiled(sData);
   if not IFPS3DataToText(sData,sData)
     then memo1.lines.add('¡No puedo crear el desensamblado!')
   else
     synmemo1.Text:= sData;
  //aPSCE.SaveDissasembly(sData);
end;

end.

maXbox mini LAZARUS.png maXbox mini LAZARUS2.png