Difference between revisions of "Pascal Script Examples"
From Lazarus wiki
Jump to navigationJump to searchm (formatting) |
|||
Line 1: | Line 1: | ||
− | < | + | <pre> |
program psce; | program psce; | ||
{$APPTYPE CONSOLE} | {$APPTYPE CONSOLE} | ||
Line 192: | Line 192: | ||
end. | end. | ||
− | </ | + | </pre> |
--[[User:Forest|Forest]] 23:00, 22 Oct 2005 (CEST) | --[[User:Forest|Forest]] 23:00, 22 Oct 2005 (CEST) |
Revision as of 09:44, 23 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)