Metaprogramação

program Main;

uses AppCore, AppLate;

var
  U: TUsed;
begin
  U := TUsed.Create;
  WriteLn('1: ', U.Double(21));
  // o late module se registrou na initialization dele, que roda por último
  WriteLn('2: ', CallRegistered);
end.

module AppCore;

// O núcleo: declara um tipo que o programa USA (TUsed), um que ninguém usa
// (TUnused, que a eliminação de código morto descarta) e o ponto de registro
// que o late module preenche.

public type
  TRegistrar = procedure;

public type
  TUsed = class(TObject)
  public
    function Double(A: Int32): Int32;
  end class;

public type
  TUnused = class(TObject)
  public
    function Never: Int32;
  end class;

public var
  GRegister: TRegistrar;

public var
  GStatus: UString;

public function CallRegistered: UString;
begin
  if GRegister <> nil then
  begin
    GRegister();
    Exit(GStatus);
  end if;
  Exit('ninguém registrou');
end function;

function TUsed.Double(A: Int32): Int32;
begin
  Exit(A * 2);
end function;

function TUnused.Never: Int32;
begin
  Exit(0);
end function;

end.

late module AppLate;

// Um late module é lido DEPOIS de o programa inteiro existir e de a eliminação
// de código não usado marcar o que sobreviveu. Declared(X) responde se X
// sobreviveu; citar um símbolo morto seria erro.

uses AppCore;

private procedure ReportSurvivors;
begin
  {$if Declared(TUsed)}
  GStatus := 'TUsed sobreviveu';
  {$else}
  GStatus := 'TUsed sumiu?!';
  {$endif}
  {$if Declared(TUnused)}
  GStatus := GStatus + ', TUnused também';
  {$else}
  GStatus := GStatus + ', TUnused foi descartada';
  {$endif}
end procedure;

initialization
  GRegister := @ReportSurvivors;
end.

program Main;

uses Entities, TableLabel;

var
  C: TCustomer;
begin
  C := TCustomer.Create;
  C.Name := 'maria';
  WriteLn('nome:     ', C.Name);
  // Describe não existe em fonte nenhum: o meta module o criou em compilação
  WriteLn('descrição: ', C.Describe);
end.

module Entities;

// Uma classe decorada com um atributo. O método Describe NÃO existe aqui:
// quem o cria é o meta module, rodando em compilação sobre o retrato do programa.

public attribute DbTable(const TableName: LString);

public type
  [DbTable('CUSTOMERS')]
  TCustomer = class(TObject)
  public
    Name: UString;
  end class;

end.

meta module TableLabel;

// Roda em COMPILAÇÃO: varre o retrato do programa e, em toda classe viva com o
// atributo DbTable, acrescenta um método Describe que devolve o nome da tabela.
// O módulo Meta da RTL (a árvore TMetaRtti* e o TMetaMethodBuilder) entra implícito.

private procedure Execute;
var
  Ctx: TMetaRttiContext;
  Pack: TMetaRttiPackage;
  Modl: TMetaRttiModule;
  TypeInfo: TMetaRttiType;
  Attr: TMetaRttiAttribute;
  Table: UString;
  Builder: TMetaMethodBuilder;
begin
  for Pack in Ctx.GetPackages() do
    for Modl in Pack.GetModules() do
      if (not Modl.IsMeta()) and (not Modl.IsLate()) then
        for TypeInfo in Modl.GetTypes() do
          if (not TypeInfo.IsDead()) and TypeInfo.IsClass() then
          begin
            Table := '';
            for Attr in TypeInfo.GetAttributes() do
              if Attr.TypeNameIs('DbTable') then
                Table := Attr.ValueDef('TableName');
            if Length(Table) > 0 then
            begin
              Builder := TMetaMethodBuilder.Create(TypeInfo, 'Describe');
              if not Builder.Exist() then
              begin
                Builder.Start();
                Builder.SetResult('UString');
                Builder.SetSourceText('  Exit(''tabela ' + Table + ''');');
              end if;
            end if;
          end if;
end procedure;

initialization
  Execute;
end.