Difference between revisions of "Pascal Script Examples"

From Lazarus wiki
Jump to navigationJump to search
m (formatting)
Line 1: Line 1:
 +
{{Pascal Script Examples}}
 +
 
<pre>
 
<pre>
 
program psce;
 
program psce;

Revision as of 18:42, 20 June 2007

English (en) español (es)

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)