Pascal Script，pascalscript

Pascal Script，pascalscript

這兩天研究了一下腳本語言，用的RO帶的Pascal Script

程序的功能是 在form1中執行腳本 創建form2窗體，並讓form2能和form1 能進行交互

備注：uPSI_Unit2文件 是用PSUnitImporter.exe導出來的

        PSUnitImporter.exe 在D:\Program Files\RemObjects Software\Pascal Script for Delphi\Bin（本機安裝目錄）。

下面是程序源碼

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Unit2, uPSComponent;

type
  TForm1 = class(TForm)
    mmo1: TMemo;
    btn1: TButton;
    btn2: TButton;
    procedure btn1Click(Sender: TObject);
    procedure btn2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private

    { Private declarations }
  public
    { Public declarations }
    filepath: string;
    procedure ShowNewMessage(const Message: string);
    procedure setFilepath(str: string);
  end;

var
  Form1: TForm1;
  Str: string;

implementation

{$R *.dfm}

uses
  uPSCompiler,uPSRuntime,uPSC_std,uPSC_controls, uPSC_stdctrls,uPSC_forms,
  uPSR_std,uPSR_controls,uPSR_stdctrls,uPSR_forms,uPSC_graphics,uPSI_Unit2;

function ScriptOnUses(Sender: TPSPascalCompiler; const Name: string): Boolean;
{ the OnUses callback function is called for each "uses" in the script.
  It's always called with the parameter 'SYSTEM' at the top of the script.
  For example: uses ii1, ii2;
  This will call this function 3 times. First with 'SYSTEM' then 'II1' and then 'II2'.
}
begin
  if Name = 'SYSTEM' then begin
    SIRegister_Std(Sender);
    { This will register the declarations of these classes:
      TObject, TPersisent.
      This procedure can be found in the uPSC_std.pas unit. }
    SIRegister_Controls(Sender);
    { This will register the declarations of these classes:
      TControl, TWinControl, TFont, TStrings, TStringList, TGraphicControl.
      This procedure can be found in the uPSC_controls.pas unit. }

    SIRegister_Graphics(Sender, True);
    {  注冊圖像顏色}

    SIRegister_Forms(Sender);
    { This will register: TScrollingWinControl, TCustomForm, TForm and TApplication.
      This procedure can be found in the uPSC_forms.pas unit. }

    SIRegister_stdctrls(Sender);
     { This will register: TButtonContol, TButton, TCustomCheckbox, TCheckBox, TCustomEdit,
       TEdit, TCustomMemo, TMemo, TCustomLabel and TLabel.
       This procedure can be found in the uPSC_stdctrls.pas unit. }

    AddImportedClassVariable(Sender, 'Application', 'TApplication');
    // Registers the application variable to the script engine.

    SIRegister_TForm2(Sender);
    SIRegister_Unit2(Sender);
    {自定義類要在最後注冊，在運行的時候 還要在runtime中注冊，在btn1Click中可以看到}

    Result := True;
  end else
    Result := False;
end;

procedure TForm1.ShowNewMessage(const Message: string);
begin
  ShowMessage('ShowNewMessage invoked:'#13#10 + Message);
end;

procedure TForm1.btn1Click(Sender: TObject);
var
  Compiler: TPSPascalCompiler;
  {腳本編譯器 TPSPascalCompiler is the compiler part of the script engine. This will
    translate a Pascal script into compiled data for the executer. }
  Exec: TPSExec;
   {腳本執行 TPSExec is the executer part of the script engine. It uses the output of
    the compiler to run a script. }
  Data, Script: string;
  CI: TPSRuntimeClassImporter;
  i: Integer;
begin
  Str := 'abc';
  Compiler := TPSPascalCompiler.Create; // create an instance of the compiler.
  Compiler.OnUses := ScriptOnUses; // assign the OnUses event.

  Script := mmo1.Text;
  if not Compiler.Compile(Script) then
  begin // Compile the Pascal script into bytecode.

    for i := 0 to Compiler.MsgCount - 1 do
    begin
      ShowMessage(Compiler.Msg[i].MessageToString);
      //如果有錯誤在這裡可以提示出來
    end;
    Compiler.Free;
     // You could raise an exception here.
    Exit;
  end;

  Compiler.GetOutput(Data); // Save the output of the compiler in the string Data.
  Compiler.Free; // After compiling the script, there is no need for the compiler anymore.

  CI := TPSRuntimeClassImporter.Create;
  { Create an instance of the runtime class importer.}

  RIRegister_Std(CI); // uPSR_std.pas unit.
  RIRegister_Controls(CI); // uPSR_controls.pas unti.
  RIRegister_stdctrls(CI); // uPSR_stdctrls.pas unit.
  RIRegister_Forms(CI); // uPSR_forms.pas unit.
  RIRegister_TForm2(CI);
  RIRegister_Unit2(CI);

  Exec := TPSExec.Create; // Create an instance of the executer.

  RegisterClassLibraryRuntime(Exec, CI);
  // Assign the runtime class importer to the executer.

  if not Exec.LoadData(Data) then begin // Load the data from the Data string.
    { For some reason the script could not be loaded. This is usually the case when a
      library that has been used at compile time isn't registered at runtime. }
    Exec.Free;
     // You could raise an exception here.
    Exit;
  end;

  SetVariantToClass(Exec.GetVarNo(Exec.GetVar('APPLICATION')), Application);
   // This will set the script's Application variable to the real Application variable.

  Exec.RunScript; // Run the script.
  Exec.Free; // Free the executer.
  CI.Free; // Free the runtime class importer.
end;

procedure TForm1.btn2Click(Sender: TObject);
begin
     //測試用   驗證Form2設置了該值沒有
  ShowMessage(filepath);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
   //測試用
  filepath := ExtractFilePath(Application.ExeName);
end;

procedure TForm1.setFilepath(str: string);
begin
   //供form2 測試用
  filepath := str;
end;

end.

---unit1 窗體文件

object Form1: TForm1
  Left = 210
  Top = 175
  Width = 514
  Height = 644
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object mmo1: TMemo
    Left = 16
    Top = 16
    Width = 385
    Height = 537
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -24
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    Lines.Strings = (
      'var f: TForm2; i: Longint; '
      'begin'
      ' f := TForm2.Create(nil); '
      'f.Show; '
      'f.caption:=''hello--script'';'
      'f.color:=clOlive;'
      'while f.Visible do '
      'Application.ProcessMessages;'
      ' F.free;  '
      'end.')
    ParentFont = False
    TabOrder = 0
  end
  object btn1: TButton
    Left = 408
    Top = 24
    Width = 75
    Height = 25
    Caption = '執行腳本'
    TabOrder = 1
    OnClick = btn1Click
  end
  object btn2: TButton
    Left = 408
    Top = 56
    Width = 75
    Height = 25
    Caption = '驗證'
    TabOrder = 2
    OnClick = btn2Click
  end
end

--unit2源碼

unit Unit2;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm2 = class(TForm)
    edt1: TEdit;
    btn1: TButton;
    btn2: TButton;
    procedure btn1Click(Sender: TObject);
    procedure btn2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form2: TForm2;

implementation

{$R *.dfm}
uses Unit1;

procedure TForm2.btn1Click(Sender: TObject);
begin
  edt1.Text:=Form1.filepath;
  ShowMessage(edt1.Text);
end;

procedure TForm2.btn2Click(Sender: TObject);
begin
  Form1.setFilepath('hello 測試哦！');
end;

end.

--unit2窗體文件

object Form2: TForm2
  Left = 411
  Top = 297
  Width = 395
  Height = 236
  Caption = 'Form2'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object edt1: TEdit
    Left = 8
    Top = 24
    Width = 257
    Height = 21
    TabOrder = 0
    Text = 'edt1'
  end
  object btn1: TButton
    Left = 32
    Top = 80
    Width = 75
    Height = 25
    Caption = 'btn1'
    TabOrder = 1
    OnClick = btn1Click
  end
  object btn2: TButton
    Left = 128
    Top = 80
    Width = 75
    Height = 25
    Caption = 'btn2'
    TabOrder = 2
    OnClick = btn2Click
  end
end

--uPSI_Unit2文件

unit uPSI_Unit2;
{
This file has been generated by UnitParser v0.7, written by M. Knight
and updated by NP. v/d Spek and George Birbilis.
Source Code from Carlo Kok has been used to implement various sections of
UnitParser. Components of ROPS are used in the construction of UnitParser,
code implementing the class wrapper is taken from Carlo Kok's conv utility

}
interface
 
uses
   SysUtils
  ,Classes
  ,uPSComponent
  ,uPSRuntime
  ,uPSCompiler
  ;
 
type
(*----------------------------------------------------------------------------*)
  TPSImport_Unit2 = class(TPSPlugin)
  protected
    procedure CompileImport1(CompExec: TPSScript); override;
    procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
  end;
 
 
{ compile-time registration functions }
procedure SIRegister_TForm2(CL: TPSPascalCompiler);
procedure SIRegister_Unit2(CL: TPSPascalCompiler);

{ run-time registration functions }
procedure RIRegister_TForm2(CL: TPSRuntimeClassImporter);
procedure RIRegister_Unit2(CL: TPSRuntimeClassImporter);

procedure Register;

implementation

uses
   Windows
  ,Messages
  ,Variants
  ,Graphics
  ,Controls
  ,Forms
  ,Dialogs
  ,StdCtrls
  ,Unit2
  ;
 
 
procedure Register;
begin
  RegisterComponents('Pascal Script', [TPSImport_Unit2]);
end;

(* === compile-time registration functions === *)
(*----------------------------------------------------------------------------*)
procedure SIRegister_TForm2(CL: TPSPascalCompiler);
begin
  //with RegClassS(CL,'TForm', 'TForm2') do
  with CL.AddClassN(CL.FindClass('TForm'),'TForm2') do
  begin
    RegisterProperty('edt1', 'TEdit', iptrw);
    RegisterProperty('btn1', 'TButton', iptrw);
  end;
end;

(*----------------------------------------------------------------------------*)
procedure SIRegister_Unit2(CL: TPSPascalCompiler);
begin
  SIRegister_TForm2(CL);
end;

(* === run-time registration functions === *)
(*----------------------------------------------------------------------------*)
procedure TForm2btn1_W(Self: TForm2; const T: TButton);
Begin Self.btn1 := T; end;

(*----------------------------------------------------------------------------*)
procedure TForm2btn1_R(Self: TForm2; var T: TButton);
Begin T := Self.btn1; end;

(*----------------------------------------------------------------------------*)
procedure TForm2edt1_W(Self: TForm2; const T: TEdit);
Begin Self.edt1 := T; end;

(*----------------------------------------------------------------------------*)
procedure TForm2edt1_R(Self: TForm2; var T: TEdit);
Begin T := Self.edt1; end;

(*----------------------------------------------------------------------------*)
procedure RIRegister_TForm2(CL: TPSRuntimeClassImporter);
begin
  with CL.Add(TForm2) do
  begin
    RegisterPropertyHelper(@TForm2edt1_R,@TForm2edt1_W,'edt1');
    RegisterPropertyHelper(@TForm2btn1_R,@TForm2btn1_W,'btn1');
  end;
end;

(*----------------------------------------------------------------------------*)
procedure RIRegister_Unit2(CL: TPSRuntimeClassImporter);
begin
  RIRegister_TForm2(CL);
end;

 
 
{ TPSImport_Unit2 }
(*----------------------------------------------------------------------------*)
procedure TPSImport_Unit2.CompileImport1(CompExec: TPSScript);
begin
  SIRegister_Unit2(CompExec.Comp);
end;
(*----------------------------------------------------------------------------*)
procedure TPSImport_Unit2.ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
begin
  RIRegister_Unit2(ri);
end;
(*----------------------------------------------------------------------------*)
 
 
end.