Difference between revisions of "Pascal Script Examples"
From Lazarus wiki
Jump to navigationJump to search| Line 1: | Line 1: | ||
<code> | <code> | ||
| − | + | program psce; | |
| − | + | {$APPTYPE CONSOLE} | |
| − | + | ||
| − | + | {$IFDEF FPC} | |
| − | + | {$mode delphi}{$H+} | |
| − | + | {$ENDIF} | |
| − | + | ||
| − | + | uses | |
| − | + | SysUtils,interfaces,Classes,Forms,uPSCompiler, uPSR_std, uPSC_std, uPSR_classes, uPSC_classes, uPSRuntime, uPSComponent,uPSDisassembly, | |
| − | + | uPSR_dateutils,uPSC_dateutils,uPSC_forms,uPSR_forms,uPSC_controls,uPSR_controls,uPSR_dll,uPSC_dll; | |
| − | + | ||
| − | + | type | |
| − | + | TPSCE = class | |
| − | + | protected | |
| − | |||
FScr: TPSScript; | FScr: TPSScript; | ||
procedure SaveCompiled(var Data : String); | procedure SaveCompiled(var Data : String); | ||
| Line 27: | Line 26: | ||
end; | end; | ||
| − | + | ||
| + | var | ||
aPSCE: TPSCE; | aPSCE: TPSCE; | ||
SFile,Data : String; | SFile,Data : 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); | Write(d:0:1); | ||
| − | + | end; | |
| − | + | procedure MWriteln; | |
| − | + | begin | |
| − | + | Writeln; | |
| − | + | end; | |
| − | |||
| − | |||
| − | |||
| − | |||
| − | |||
| + | procedure MVal(const s: string; var n, z: Integer); | ||
| + | begin | ||
| + | Val(s, n, z); | ||
| + | end; | ||
constructor TPSCE.Create; | constructor TPSCE.Create; | ||
| Line 142: | Line 142: | ||
S.Free; | S.Free; | ||
if not Result then | if not Result then | ||
| − | if FScr.CompilerMessageCount | + | 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)); | ||
| Line 163: | Line 163: | ||
if ParamCount = 0 then | if ParamCount = 0 then | ||
begin | begin | ||
| − | Writeln('Usage: ', ExtractFileName(ParamStr(0)), ' [--compile|--dissasembly] | + | Writeln('Usage: ', ExtractFileName(ParamStr(0)), ' [--compile|--dissasembly] <script.pss>'); |
Writeln(''); | Writeln(''); | ||
Writeln('--compile : Save compiled script bytecode'); | Writeln('--compile : Save compiled script bytecode'); | ||
| Line 191: | Line 191: | ||
aPSCE.Free; | aPSCE.Free; | ||
end. | end. | ||
| − | |||
| − | |||
</code> | </code> | ||
--[[User:Forest|Forest]] 23:00, 22 Oct 2005 (CEST) | --[[User:Forest|Forest]] 23:00, 22 Oct 2005 (CEST) | ||
Revision as of 23:05, 22 October 2005
program psce;
{$APPTYPE CONSOLE}
{$IFDEF FPC}
{$mode delphi}{$H+}
{$ENDIF}
uses
SysUtils,interfaces,Classes,Forms,uPSCompiler, uPSR_std, uPSC_std, uPSR_classes, uPSC_classes, uPSRuntime, uPSComponent,uPSDisassembly,
uPSR_dateutils,uPSC_dateutils,uPSC_forms,uPSR_forms,uPSC_controls,uPSR_controls,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,Data : 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 MVal(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_Forms(x);
RIRegister_Controls(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(@MVal, 'procedure Val(const s: string; var n, z: Integer)');
SIRegister_Std(Sender.Comp);
SIRegister_Classes(Sender.Comp,true);
SIRegister_Forms(Sender.Comp);
SIRegister_Controls(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;
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('File not found: ', FileName);
end;
function TPSCE.Execute: Boolean;
begin
Result:=FScr.Execute;
if not Result then
Writeln('Run-time error:' + FScr.ExecErrorToString);
end;
begin
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.FScr.GetCompiled(Data);
if Paramstr(1)='--compile' then aPSCE.SaveCompiled(Data);
if Paramstr(1)='--dissasembly' then
begin
if not IFPS3DataToText(Data,Data) then Writeln('Cannot create dissasembly!')
else
aPSCE.SaveDissasembly(Data);
end;
Exit;
end;
aPSCE.Compile(SFile);
aPSCE.Execute;
aPSCE.Free;
end.
--Forest 23:00, 22 Oct 2005 (CEST)
