Difference between revisions of "Pascal Script Examples"

From Lazarus wiki
Jump to navigationJump to search
Line 23: Line 23:
  
 
</syntaxhighlight>
 
</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>
 +
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>
 +
 +
 +
 +
The following examples are FPC code and do not show a script.
  
 
<syntaxhighlight>
 
<syntaxhighlight>

Revision as of 16:50, 9 October 2014

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));


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;
  ClassImporter: TPSRuntimeClassImporter;
begin
  Runtime := TPSExec.Create;
  //ClassImporter:= TPSRuntimeClassImporter.CreateAndRegister(runtime, false);
  try
    //ExtendRuntime(Runtime, ClassImporter);
    //IFPS3ClassesPlugin1ExecImport(Self, runtime, classImporter);
    PSScript1Compile(PSScript1);
    PSScript1ExecImport(PSScript1, runtime, PSScript1.RuntimeImporter);
    // runtime.AddResource();
    //runtime.AddSpecialProcImport('procedure Writes(const i: Integer)',NIL,@MWrites);

    PSScript1.RuntimeImporter.CreateAndRegister(runtime, false);

      // PSScript1.RuntimeImporter.CreateAndRegister(runtime, false);
      //TPSClassesPlugin1ExecImport(Self, runtime, classImporter);
    Result:= Runtime.LoadData(Bytecode)
          and Runtime.RunScript
          and (Runtime.ExceptionCode = erNoError);
    memo1.lines.add(bytecode);
    //PSScript1.SetCompiled(Bytecode);
    IFPS3DataToText(Bytecode,Bytecode);
    memo1.lines.add(bytecode);
    if not Result then
      RuntimeErrors:=  PSErrorToString(Runtime.LastEx, '');
  finally
    //ClassImporter.Free;
    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.

http://wiki.freepascal.org/File:maXbox_mini_LAZARUS.png http://wiki.freepascal.org/File:maXbox_mini_LAZARUS2.png