Difference between revisions of "Pascal Script Examples"

From Lazarus wiki
Jump to navigationJump to search
 
Line 196: Line 196:
  
 
</code>
 
</code>
 +
 +
--[[User:Forest|Forest]] 23:00, 22 Oct 2005 (CEST)

Revision as of 22:00, 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)