Chamando Formulários com PascalScript + RTTI + Factory Methods

Um desenvolvedor que leu meu artigo sobre metaprogramação no Delphi me perguntou hoje como criar e abrir formulários a partir de scripts com o Pascal Script.
Não há uma maneira muito fácil de se fazer isso, e pode haver outras maneiras de se fazer.

Você não pode simplesmente registrar a form1 simplesmente porque o tipo TForm1 não existe. Ele não é nativo do Delphi, mas foi escrito por você.

O Pascal Script não conhece o tipo TForm1 e não tem como, dentro do script, você criar uma variável desse tipo.

Uma das maneiras seria você registrar a unit1, fazendo com que o pascal script a use, ou declarar a TForm1 todinha dentro do pascal script. Essas duas opções são complicadas, pois um dos meios é passar o fonte .pas junto com a aplicação e deixar  o cliente ver / manipular livremente. E se por acaso a unit1 usa ou depende de outras units você teria um enorme problema em cascata.

Além disso o pascal script é limitado. Ele se limita apenas às operações básicas do pascal.

Uma maneira elegante de resolver esse impasse seria usar uma mistura de FactoryMethod com RTTI e pascal script.

Use a função registerclass para "registrar" a classe da form que você quer que seja aberta no script. Faça isso na seção initilization como segue:

unit uFrmChamada;

interface

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

type
  TfrmChamada = class(TForm)
    Label1: TLabel;
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmChamada: TfrmChamada;

implementation

{$R *.dfm}


initialization
  RegisterClass(TfrmChamada);

end.

RegisterClass exige um parâmetro do tipo TPersistentClass, que é um tipo que define um tipo (?!?!?) Sim, é um metatipo, ou metaclasse se você preferir.

Como forms são descendentes de TPersistent, qualquer tipo de classe de form é do mesmo tipo do metatipo TPersistentClass (?!?!?). Estou falando de classes, não de objetos, repare bem nisso. Você pode ter variáveis que são do TIPO CLASSE e não DO TIPO DE UMA CLASSE.

E não podemos esquecer que na unit forms existe a declaração:

  TFormClass = class of TForm;

Para facilitar nossa vida, porque TFormClass também é um TPersistentClass, mas é específico da classe TForm, ou seja, TFormClass é um descendente indireto (bastardo) de TPersistentClass.

São os truques da RTTI para se trabalhar dinamicamente com tipos sobre tipos. (variáveis de tipos).

Partindo do pressuposto que você já tem uma form com um memo para digitar o código e o componente do pascal script colado nela, crie nessa form (ou numa unit separada para não gerar acoplamentos desnecessários) uma function estática global assim:

function ConstrutorDeForms(NomeClasse: string): TForm;
var
  ClasseDaForm: TFormClass;
begin
  ClasseDaForm := TFormClass(FindClass(NomeClasse));
  Result := ClasseDaForm.Create(Application);
end;

Usei Application como owner aqui porque não estamos dentro de um objeto ou classe (form) estamos direto na unit. Poderia ser nil, mas assegure-se de que o objeto seja destruído para não criar leaks.

E registre a função assim, no evento OnCompile do pascal script:

 psExecutar.AddFunction(@ConstrutorDeForms, 'function ConstrutorDeForms(NomeClasse: string):TForm;');

Não esqueça de registrar outras funções e variáveis que vá utilizar, como foi explicado no artigo.

unit uFrmEditor;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Buttons, dateutils, DB, ADODB, uPSComponent, uPSCompiler,
  uPSRuntime, uPSComponent_DB, uPSComponent_Default;

type
  TfrmEditor = class(TForm)
    btExecutar: TBitBtn;
    psExecutar: TPSScript;
    mMensagens: TMemo;
    mSaida: TMemo;
    mFonte: TMemo;
    PSImport_DB1: TPSImport_DB;
    PSImport_Classes1: TPSImport_Classes;
    procedure btExecutarClick(Sender: TObject);
    procedure psExecutarCompile(Sender: TPSScript);
    procedure psExecutarExecute(Sender: TPSScript);
    procedure psExecutarCompImport(Sender: TObject; x: TPSPascalCompiler);
    procedure psExecutarExecImport(Sender: TObject; se: TPSExec;
      x: TPSRuntimeClassImporter);
  private
    { Private declarations }
  public
    { Public declarations }
  end;


procedure NossoWriteLn(const s: string);
procedure NossoReadLn(var s: string);
//function para simular factory method com as classes de forms registradas
//ela cria a form e devolve a quem a chamar
function ConstrutorDeForms(NomeClasse: string): TForm;


var
  frmEditor: TfrmEditor;

implementation
uses
  uPSR_std,
  uPSC_std,
  uPSR_stdctrls,
  uPSC_stdctrls,
  uPSR_forms,
  uPSC_forms,
  uPSC_graphics,
  uPSC_controls,
  uPSC_classes,
  uPSR_graphics,
  uPSR_controls,
  uPSR_classes, uFrmChamada;

{$R *.dfm}


procedure NossoWriteLn(const s: string);
begin
  frmEditor.mSaida.Lines.Add(s);
end;

procedure NossoReadLn(var s: string);
begin
  s := InputBox('Digite um valor:', 'Digite um valor:', '');
end;

function ConstrutorDeForms(NomeClasse: string): TForm;
var
  ClasseDaForm: TFormClass;
begin
  ClasseDaForm := TFormClass(FindClass(NomeClasse));
  Result := ClasseDaForm.Create(Application);
end;



procedure TfrmEditor.btExecutarClick(Sender: TObject);
var
  Compilou, Executou: boolean;
  i: integer;
begin
  mMensagens.Clear;
  mSaida.Clear;


  psExecutar.Script.Text := mFonte.Text;
  Compilou := psExecutar.Compile;

  if Compilou then
  begin
    mMensagens.Lines.Add('Programa compilado com sucesso!');
    Executou := psExecutar.Execute;

    if Executou then
    begin
      mMensagens.Lines.Add('Programa executado com sucesso!');
    end
    else
    begin
      mMensagens.Lines.Add('Ocorreu o erro de execução: ' +
        psExecutar.ExecErrorToString +' onde? '+
        Inttostr(psExecutar.ExecErrorProcNo)+'.'+
        Inttostr(psExecutar.ExecErrorByteCodePosition));
    end;

  end
  else
     mMensagens.Lines.Add('Erro de compilação:');

  for i := 0 to psExecutar.CompilerMessageCount - 1 do
  begin
    mMensagens.Lines.Add('Compilador: '+ psExecutar.CompilerErrorToStr(i));
  end;

end;

procedure TfrmEditor.psExecutarCompile(Sender: TPSScript);
begin
  psExecutar.AddFunction(@NossoWriteLn, 'procedure Writeln(s: string);');
  psExecutar.AddFunction(@NossoReadLn, 'procedure ReadLn(var s: string);');
  psExecutar.AddFunction(@ShowMessage, 'procedure ShowMessage(s: string);');

  psExecutar.AddFunction(@ConstrutorDeForms, 'function ConstrutorDeForms(NomeClasse: string):TForm;');

  //adicionamos isso para existir a variável
  psExecutar.AddRegisteredVariable('Application', 'TApplication');
  psExecutar.AddRegisteredVariable('Self', 'TForm');
end;



procedure TfrmEditor.psExecutarCompImport(Sender: TObject;
  x: TPSPascalCompiler);
begin
  SIRegister_Std(x);
  SIRegister_Classes(x, true);
  SIRegister_Graphics(x, true);
  SIRegister_Controls(x);
  SIRegister_stdctrls(x);
  SIRegister_Forms(x);
end;

procedure TfrmEditor.psExecutarExecImport(Sender: TObject; se: TPSExec;
  x: TPSRuntimeClassImporter);
begin
  RIRegister_Std(x);
  RIRegister_Classes(x, True);
  RIRegister_Graphics(x, True);
  RIRegister_Controls(x);
  RIRegister_stdctrls(x);
  RIRegister_Forms(x);
end;

procedure TfrmEditor.psExecutarExecute(Sender: TPSScript);
begin
  psExecutar.SetVarToInstance('Application', Application);
  psExecutar.SetVarToInstance('Self', Self);
end;

end.

E para chamar a dita cuja segunda form faça assim:

program DoUsuario;

var frmChamada: Tform;


begin

frmChamada := ConstrutorDeForms('TFrmChamada');
frmChamada.ShowModal;
frmChamada.free;

end.

O legal é que a função ConstrutorDeForms pode ser usada também fora do pascal script para chamar qualquer form que esteja registrada com RegisterClass.

Para acessar componentes internos da form criada use os métodos FindComponent, exemplo:

program DoUsuario;

var frmChamada: Tform;
lbl1: TLabel;


begin

frmChamada := ConstrutorDeForms('TFrmChamada');
lbl1:= TLabel(frmChamada.FindComponent('Label1'));
lbl1.Caption := 'Uia, dá pra mudar propiedades dos componentes!';

frmChamada.ShowModal;
frmChamada.free;

end.

O pascal script, pelo menos nesta versão e do modo como eu o uso, não tem os operadores de RTTI is e as, por isso usamos a conversão de tipo "forçada" e "não segura" TLabel(frmChamada.FindComponent('Label1')); que não é verificada pelo compilador.

Baixe o fonte desse exemplo, juntamente com o componente.

Espero ter ajudado ^^