Difference between revisions of "Pascal Script Examples"
From Lazarus wiki
Jump to navigationJump to searchMaxkleiner (talk | contribs) |
Maxkleiner (talk | contribs) |
||
Line 231: | Line 231: | ||
unit unit1pscript2; | unit unit1pscript2; | ||
//compiled by max | //compiled by max | ||
+ | ////oct 2014: www.softwareschule.ch/maxbox.htm | ||
{$mode objfpc}{$H+} | {$mode objfpc}{$H+} | ||
Line 536: | Line 537: | ||
</syntaxhighlight> | </syntaxhighlight> | ||
+ | |||
+ | http://wiki.freepascal.org/File:maXbox_mini_LAZARUS.png |
Revision as of 12:22, 7 October 2014
│
English (en) │
español (es) │
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.