ShowModal por formulario en VCL

Antes de continuar, en muchos en los que se realiza un desarrollo multi-área, como MDI, nos surge la necesidad de hacer diálogos modales por área o formulario. Aunque a partir de la versión de XE5 (si no recuerdo mal) hay una solución para FireMonkey, para VCL no existe esta posibilidad y hay que implementarla.
Seguramente muchos ya lo habréis solucionado de una manera u otra, la forma que lo he visto en muchos casaos es crear el dialogo sobre el formulario y en vez de mostrarlo con en modo modal mostrarlo sin modo modal y esperar en un bucle con Application.ProcessMessages la finalización de diálogo, algo como:

...
    FrmDialogo.Create(Self);
    FrmDialogo.Parent := Self;
    FrmDialogo.Show;
    while FrmDialogo.ModalResult <> mrNone do
      Application.ProcessMessages;
    case FrmDialogo.ModalResult of
      mrOK: begin
        ...
      end;
      mrCancel: begin
        ...
      end;
    end;
... 

Con esto (...bueno sí faltan cosas...) se permite poder cambiar de área y dejar el diálogo en el formulario desde el que se lanzo, pero creerme que a la larga el funcionamiento no es el esperado y a veces puede llevar a errores difíciles de encontrar.
El problema es que sólo tenemos un hilo de ejecución y con la VCL sólo se nos permite uno para la parte visual y no podemos mostrar más de una ventana modal. Para poder hacerlo tenemos que simularlo, para ello vamos a usar las primeras versiones que he usado en mi framework. Lo mejor es no usar el Application.ProcessMessages, y dejar el funcionamiento al sistema de eventos y mensajes. En una primera aproximación los diálogos modales paran el proceso del formulario emisor y al finalizarse se continúa. Además no vamos a entrar en el multiproceso, eso es otro tema.
Vamos a ver las bases del formulario usados en el framework y los diálogos (no por completo).

unit uJwd.VCL.Form;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Forms, Vcl.Controls; 

type
  TjwdForm = class(TForm)
    ...
    procedure OnDeactivateForModalDlg; virtual; abstract;
    procedure OnActivateForModalDlg; virtual; abstract;
    ...
    constructor Create(AOwner: TComponent); override;
  end;

implementation

{$R *.dfm}

{ TjwdForm }

constructor TjwdForm.Create(AOwner: TComponent);
begin
  if AOwner = nil then
    AOwner := Application.MainForm;
  inherited Create(AOwner);
  if AOwner is TjwdForm then
    Parent := TjwdForm(AOwner);
end;
...
end.

Lo que nos interesa de aquí es los métodos abstractos se utilizarán para habilitar y deshabilitar el formulario cuando se muestre el diálogo, ya que lo que haremos, como veremos, es deshabiltar sus controles para que n se pueda hacer hada sobre él y que el control lo tenga el nuevo diálogo. Otra cosa a tener en cuenta es que el Create ya poner como Parent propio Owner lo que nos evita hacerlo posteriormente. Esto es práctico en los diálogos, que heredan de éste.

unit uJwd.VCL.Dialog;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, uJwd.VCL.Form;

type
  EjwdFormModalException = class(Exception);

  TjwdDialog = class(TjwdForm)
    ...
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  strict private
    function ShowModal: Integer; overload; override;
  public type
    TjwdDialogPosition = (jwdpCenter, jwdpTopCenter, jwdpBottomCenter, jwdpCenterLeft, jwdpCenterRigth, jwdpNone);
  private type
    TjwdModalProc = procedure (const AModalResult: TModalResult) of object;
  private
    ...
    procedure SetModalResult(Value: TModalResult);
    ...
  protected
    ...
    procedure SetJwdDialogPosition(var ATop, ALeft: Integer); virtual;
    procedure ShowModal(const AParent: TjwdForm;
      const ResultProc: TjwdModalProc;
      const UseRootFormHiddingDialog: boolean = True); reintroduce; overload;
    procedure ShowModal(const AParent: TjwdForm;
      const ResultProc: TProc;
      const UseRootFormHiddingDialog: boolean = True); reintroduce; overload;
  public
    procedure ShowModal(const ResultProc: TjwdModalProc;
      const UseRootFormHiddingDialog: boolean = True); reintroduce; overload;
    procedure ShowModal(const ResultProc: TProc;
      const UseRootFormHiddingDialog: boolean = True); reintroduce; overload;

    property ModalResult: TModalResult
      read FModalResult
      write SetModalResult;

    constructor Create(AOwner: TjwdForm; APosition: TjwdDialogPosition = jwdpTopCenter);
  published
    property DialogPosition: TjwdDialogPosition
      read FDialogPosition
      write FDialogPosition
      stored jwdpTopCenter;
  end;

implementation

{$R *.dfm}

constructor TjwdDialog.Create(AOwner: TjwdForm; APosition: TjwdDialogPosition);
begin
  inherited Create(AOwner);

  FDialogPosition := APosition;
end;
...
procedure TjwdDialog.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caFree;
end;
...
procedure TjwdDialog.SetJwdDialogPosition(var ATop, ALeft: Integer);
begin
  // You can change dialog position in this moment
  //   ATop and ALeft has been already calculated from DialogPosition
end;

procedure TjwdDialog.SetModalResult(Value: TModalResult);
begin
  FModalResult := Value;
  try
    Hide;
    if Assigned(FParentDialog) then
      FParentDialog.Show
    else
      TjwdForm(Parent).OnActivateForModalDlg;
    DoResultProc(FModalResult);
  finally
    FResultProc := nil;
    FResultProc2 := nil;
    Close;
  end;
end;

function TjwdDialog.ShowModal: Integer;
var
  ATop, ALeft: Integer;
begin
  Result := 0;
  try
    Position := poDesigned;
    if Assigned(FParentDialog) then
      FParentDialog.Hide
    else
      TjwdForm(Parent).OnDeactivateForModalDlg;
    case DialogPosition of
      jwdpCenter: begin
        ATop := (Parent.Height - Height) div 2;
        ALeft := (Parent.Width - Width) div 2;
      end;
      jwdpTopCenter: begin
        ATop := 0;
        ALeft := (Parent.Width - Width) div 2;
      end;
      jwdpBottomCenter: begin
        ATop := (Parent.Height - Height);
        ALeft := (Parent.Width - Width) div 2;
      end;
      jwdpCenterLeft: begin
        ATop := (Parent.Height - Height) div 2;
        ALeft := 0;
      end;
      jwdpCenterRigth: begin
        ATop := (Parent.Height - Height) div 2;
        ALeft := (Parent.Width - Width);
      end;
      else
        ATop := 0;
        ALeft := 0;
    end;
    SetJwdDialogPosition(ATop, ALeft);
    Top := ATop;
    Left := ALeft;
  finally
    Show;
  end;
end;

procedure TjwdDialog.ShowModal(const AParent: TjwdForm;
  const ResultProc: TjwdModalProc;
  const UseRootFormHiddingDialog: boolean);
begin
  if UseRootFormHiddingDialog and (Parent is TjwdDialog) then
    FParentDialog := TjwdDialog(Parent)
  else
    FParentDialog := nil;
  Parent := AParent;
  FResultProc := nil;
  FResultProc2 := ResultProc;
  ShowModal;
end;
...
procedure TjwdDialog.ShowModal(const ResultProc: TjwdModalProc;
  const UseRootFormHiddingDialog: boolean);
var
  frm: TjwdForm;
  AError: string;
begin
  frm := GetParentJwdForm(UseRootFormHiddingDialog, AError);
  if Assigned(frm) then
    ShowModal(frm, ResultProc, UseRootFormHiddingDialog)
  else
    raise EjwdFormModalException.Create(AError);
end;

end.

Se ha omitido código por brevedad y sí tenéis razón, se utiliza la misma forma que se hace en FireMonkey, pero se ha añadido para ampliar la que ya existía con el método de objeto.

• DialogPosition; posición dónde situar el diálogo sobre el padre
• SetJwdDialogPosition: sobrescribiendo este método se puede modificar la posición del diálogo
• El Close pone el ActionClose a caFree para que, por defecto, automáticamente se libere el diálogo, sobreescribiendo este método se puede cambiar esta opción
• El Create incluye la posición APosition
• El ShowModal tiene dós parámetros:
• ResultProc:  el método de respuesta , tanto en método de objeto como en en método anónimo - al igual que FireMonkey
• UseRootFormHiddingDialog, si se llama un diálogo desde otro diálogo se puede ocultar el diálogo padre y mostrar el nuevo diálogo sobre el formualrio original, nos permite anidar dialogos y no perder la traza

A grandes rasgos el ShowModal hace lo siguiente: Comprueba si el padre es correctamente un TjwdForm, si es así en función del parámetro UseRootFormHiddingDialog, pondremos como padre al mismo diálogo o al formulario raiz (ocultado el diálogo padre si es necesario); una vez gestionado, bloquea el padre usando su método OnDeactivateForModalDlg , posiciona el nuevo diálogo y después lo muestra. Una vez finalizado el diálogo (se ha asignado ModalResult)  se devuelve el control al padre, no si antes llamar a su método OnActivarForModalDlg.

unit SampleDialog;
...
type
  TSampleDLG = class(TjwdDialog)
    ...
  end;
...
procedure TSampleDLG.Button1Click(Sender: TObject);
begin
  ModalResult := mrOK;
end;

procedure TSampleDLG.Button2Click(Sender: TObject);
begin
  ModalResult := mrCancel;
end;
...

Como ejemplo, para llamar a un diálogo de ejemplo desde un formulario de ejemplo

unit SampleForm;
...
type
  TSampleFrm = class(TjwdForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    procedre ResultProc(const AModalResult: TModalResult);
  public
    procedure OnDeactivateForModalDlg; override;
    procedure OnActivateForModalDlg; override;
  end;
...
procedure TSampleFrm.Button1Click(Sender: TObject);
begin
  TjwdSampleDLG.Create(Self, jwdpTopCenter).ShowModal(ResultProc, True);
end;

procedre TSampleFrm.ResultProc(const AModalResult: TModalResult);
begin
  if AModalResult = mrOK then
    ShowMessage('Correcto')
  else
    ShowMessage('Cancelado');  
end;

procedure TSampleFrm.OnDeactivateForModalDlg; 
begin
  Button1.Enabled := False;
end;

procedure TSampleFrm.OnActivateForModalDlg; 
begin
  Button1.Enabled := True;
end;

...

Retorno

Este último año he estado ocupado y no he podido atender el blog, ahora volveré a empezar a ver si esta vez hay más continuidad. Este ultimo año han pasado varias cosas, entre otras la aparición de varias versiones más de Delphi, estando ahora el la versión Delphi 10.1 Berlín, que es la nueva nomenclatura que le han dado ya que habían llegado al XE10. Algunas novedades han habido (alguna cosilla de atributos), pero para lo que lo vamos a utilizar por ahora no hay grandes cambios.

Desde de ahora ahora utilizaré la versión Delphi 10.1 Berlín (esta hasta hace poco era, en versión educativa, gratuita). Este año he llegado a realizar un framework casi completo, ahora aplicaremos esa experiencia para realizar uno que intentaremos que sea lo más genérico posible y poder dejarlo totalmente abierto. Ya vimos el uso de los atributos y del uso de JSON, ahora vamos a aplicarlo.

Primero vamos a fijar unos conceptos para la implementación de framework .

• Cada clase será una entidad .
• Podremos usar una una base de datos relacional (BD o BDR) y asociar cada clase con una tabla.
• Cada clase/objeto deberá tener una clave que identifique unívocamente el objeto dentro de la clase, realmente la clave única sera el terna <clase, clave>. En la BD la tabla será la clase y la clave primaria la clave.
• Relacionaremos las propiedades de la clase con los campos de la tabla de la BD.
• Automatizaremos la operaciones (carga, inserción, actualización,...) de los objetos de la clase en función de su clave.
• Usaremos como clase base el tipo TPersistent 
• ...Ya Iremos ampliando esta lista...
• ...

Por último especificar que el framework  tendrá en nombre de JWD Object Framework y que por tanto las clases empezarán por Tjwd<nombre_clase> y las unidades por jwd.<nombre unidad>, ahora mismo les daremos un nombre, pero seguramente en un futuro refactoricemos y les cambiaremos la nomenclatura..

Empecemos por algo

Iremos creando unidades y las iremos ampliando y  creando más. Inicialmente vamos ha crear una unidad  jwd.Ground dónde tendremos las clase base que utilizaremos

unit jwd.Ground;

interface

uses
  System.Classes;

type
  TjwdClass = class of TjwdGroundObject;

  TjwdGroundObject = class(TInterfacedPersistent)
  public
    class function GetJwdClass: TjwdClass; virtual; abstract;
  end;

implementation

end.

Ahora una unidad para los interfaces base jwd.Types.Interfaces por ahora crearemos un par interfaces, pero lo iremos ampliando.

unit jwd.Interfaces;

interface

uses
  System.Classes, jwd.Ground;

type
  IjwdClass = interface
    ['{2227D866-9D83-48CE-8F4F-D7FBB2E8A3FF}']
    function GetJwdIdClass: string;
    function GetJwdObject: TjwdGroundObject;
    function GetJwdClass: TjwdClass;
    property JwdIdClass: string read GetJwdIdClass;
  end;

  IjwdPersistent = interface
    ['{0D7C4784-619E-49C7-8B07-5195EEE8217D}']
    procedure Assign(Source: TPersistent);
    function GetPersistentObject: TPersistent;
  end;

implementation

end.

Otra unidad para la clase base jwd.Custom, que seguro que también la ampliamos

unit jwd.Custom;

interface

uses
  System.Classes, jwd.Interfaces, jwd.Ground;

type
  TjwdCustom = class(TjwdGroundObject, IjwdClass, IjwdPersistent)
  protected
    // IjwdClass
    function GetJwdIdClass: string; virtual;
    function GetJwdObject: TjwdGroundObject;
    // iherited class function GetJwdClass: TjwdClass;
    // IjwdPersistent
    function GetPersistentObject: TPersistent;

  // Create/Destroy events
  protected
    procedure BeforeCreate; virtual;
    procedure AfterCreate; virtual;
    procedure BeforeCreateFrom; virtual;
    procedure AfterCreateFrom; virtual;
    procedure BeforeDestroy; virtual;
    procedure AfterDestroy; virtual;

  public
    // Clear object
    procedure Clear; virtual;

    // Object constructors
    constructor Create; virtual;
    constructor CreateFrom(const AObject: TjwdCustom);

    // Object destructor
    destructor Destroy; override;
  end;


implementation

{ TjwdCustom }

procedure TjwdCustom.AfterCreate;
begin
  // for inheritance
end;

procedure TjwdCustom.AfterCreateFrom;
begin
  // for inheritance
end;

procedure TjwdCustom.AfterDestroy;
begin
  // for inheritance
end;

procedure TjwdCustom.BeforeCreate;
begin
  // for inheritance
end;

procedure TjwdCustom.BeforeCreateFrom;
begin
  // for inheritance
end;

procedure TjwdCustom.BeforeDestroy;
begin
  // for inheritance
end;

procedure TjwdCustom.Clear;
begin
  // for inheritance
end;

constructor TjwdCustom.Create;
begin
  BeforeCreate;
  inherited Create;
  Clear;
  AfterCreate;
end;

constructor TjwdCustom.CreateFrom(const AObject: TjwdCustom);
begin
  BeforeCreateFrom;
  Create;
  Assign(AObject);
  AfterCreateFrom;
end;

destructor TjwdCustom.Destroy;
begin
  BeforeDestroy;
  inherited;
  AfterDestroy;
end;

function TjwdCustom.GetJwdIdClass: string;
begin
  Result := GetJwdClass.ClassName;
end;

function TjwdCustom.GetJwdObject: TjwdGroundObject;
begin
  Result := Self;
end;

function TjwdCustom.GetPersistentObject: TPersistent;
begin
  Result := Self;
end;

end.

También crearemos la unidad para los atributos de clase jwd.Attributes, que cotendra los atributos básicos para enlazar las clases con la BD, más adelante veremos los atributos para las relaciones entre las mismas (1 a 1, 1 a muchos, muchos a muchos)

unit jwd.Attributes;

interface

uses
  Data.DB;

type
  TjwdAttributes = class(TCustomAttribute);

  TjwdDBTableAttr = class(TjwdAttributes)
  private
    FSchemaName: string;
    FTableName: string;
    FReadOnly: Boolean;
  public
    property ReadOnly: Boolean read FReadOnly;
    property TableName: string read FTableName;
    property SchemaName: string read FSchemaName;

    constructor Create(const ATableName: string;
      const ASchemaName: string = ''; const AReadOnly: Boolean);

    function GetTable(const ATableName, ASchemaName: string): string; overload;
    function GetTable: string; overload;
  end;

  TjwdDBFieldAttr = class(TjwdAttributes)
  private
    FIsKey: Boolean;
    FType: Data.DB.TFieldType;
    FSize: Integer;
    FFieldName: string;
    FVisible: Boolean;
    FEditable: Boolean;
  public
    property FieldName: string read FFieldName;
    property DataType: Data.DB.TFieldType read FType;
    property Size: integer read FSize;
    property IsKey: Boolean read FIsKey;
    property Visible: Boolean read FVisible;
    property Editable: Boolean read FEditable;

    function GetFieldName(const APropertyName: string): string;

    constructor Create; overload; virtual;
    constructor Create(
      const AFieldName: string;
      const AFieldType: Data.DB.TFieldType;
      const ASize: integer;
      const AIsKey: Boolean;
      const AVisible: Boolean = True;
      const AEditable: Boolean = True
      ); overload;
    constructor Create(
      const AFieldType: Data.DB.TFieldType;
      const ASize: integer = 0;
      const AIsKey: Boolean = False;
      const AVisible: Boolean = True;
      const AEditable: Boolean = True
      ); overload;
  end;

  TjwdDBKeyAttr = class(TjwdDBFieldAttr)
  public
    constructor Create; overload; override;
    constructor Create(
      const AFieldName: string;
      const AFieldType: Data.DB.TFieldType;
      const ASize: integer;
      const AVisible: Boolean = True;
      const AEditable: Boolean = True); overload;
    constructor Create(
      const AFieldType: Data.DB.TFieldType;
      const ASize: integer = 0;
      const AVisible: Boolean = True;
      const AEditable: Boolean = True); overload;
  end;

implementation

{ TjwdDBTableAttr }

constructor TjwdDBTableAttr.Create(const ATableName, ASchemaName: string;
  const AReadOnly: Boolean);
begin
  FTableName := ATableName;
  FSchemaName := ASchemaName;
  FReadOnly := AReadOnly;
end;

function TjwdDBTableAttr.GetTable: string;
begin
  Result := GetTable(FTableName, FSchemaName);
end;

function TjwdDBTableAttr.GetTable(const ATableName,
  ASchemaName: string): string;
begin
  if SchemaName='' then
    Result := ASchemaName
  else
    Result := SchemaName;
  if Result<>'' then
    Result := Result + '.';
  if TableName='' then
    Result := Result + TableName
  else
    Result := Result + ATableName;
end;

{ TjwdDBFieldAttr }

constructor TjwdDBFieldAttr.Create;
begin
  Create('', ftUnknown, 0, True, True, False);
end;

constructor TjwdDBFieldAttr.Create(const AFieldName: string;
  const AFieldType: Data.DB.TFieldType; const ASize: integer;
  const AIsKey, AVisible, AEditable: Boolean);
begin
  FFieldName := AFieldName;
  FType := AFieldType;
  FSize := ASize;
  FIsKey := AIsKey;
  FVisible := AVisible;
  FEditable := AEditable;
end;

constructor TjwdDBFieldAttr.Create(const AFieldType: Data.DB.TFieldType;
  const ASize: integer; const AIsKey, AVisible, AEditable: Boolean);
begin
  Create('', AFieldType, ASize, AIsKey, AVisible, AEditable);
end;

function TjwdDBFieldAttr.GetFieldName(const APropertyName: string): string;
begin
  if FFieldName='' then
    Result := APropertyName
  else
    Result := FFieldName;
end;

{ TjwdDBKeyAttr }

constructor TjwdDBKeyAttr.Create;
begin
  inherited Create('', ftUnknown, 0, True, True, True);
end;

constructor TjwdDBKeyAttr.Create(const AFieldName: string;
  const AFieldType: Data.DB.TFieldType; const ASize: integer; const AVisible,
  AEditable: Boolean);
begin
  inherited Create(AFieldName, AFieldType, ASize, AVisible, AEditable, True);
end;

constructor TjwdDBKeyAttr.Create(const AFieldType: Data.DB.TFieldType;
  const ASize: integer; const AVisible, AEditable: Boolean);
begin
  inherited Create('', AFieldType, ASize, AVisible, AEditable, True);
end;

end.

Attributos de la Rtti

Desde la versión 2010 de Delphi, se agregó a la Rtti los attributos, que corresponden con las anotaciones de otros lenguajes como Java o .Net.
Con esta nueva característica de la Rtti podemos añadir a clases, méodos o propiedades, atributos en tiempo de diseño y desarrollo que después podremos recuperar en tiempo de ejecución a través de la Rtti.
Para nosotros será útil para el desarrollo del framework que tenemos en marcha, ya que las utilizaremos para automatizar muchas cosas.
Como sabemos la Rtti lleva mucho tiempo con nosotros y como característica más importante (por lo menos para nuestro framework) es la de poder recuperar las propiedades de una clase, que se hace de forma sencilla

function GoGetProperties(const AClass: TClass): TStrings;
var
  cxt: TRttiContext;
  t : TRttiType;
  p : TRttiProperty;
begin
  Result := TStringList.Create;
  cxt := TRttiContext.Create;
  try
    t := cxt.GetType(AClass);
    for p in t.GetProperties do
    begin
      Result.Add(p.Name);
    end;
  finally
    cxt.Free;
  end;
end;

Si lanzamos la función sobre la clase TMyClass del articulo Serialización sencilla JSON (II) el resultado sería:

IntegerValue
DoubleValue
StringValue

Respecto a los atributos, descienden de la clase TCustomAttribute alojada en System.Rtti y para asociar el atributo a un tipo, método, campo o propiedad simplemente hay que ponerlo entre [] antes de su definición.

type
  TMyAttribute = class(TCustomAttribute)
  end;
  TMyAttribute2 = class(TCustomAttribute)
  end;
  TMyAttribute3 = class(TCustomAttribute)
  end;

  [TMyAttribute]
  TMyClass = class
    ...
    [TMyAttribute2]
    property IntegerValue: Integer read FIntegerValue write FIntegerValue;
    property DoubleValue: Double read FDoubleValue write FDoubleValue;
    [TMyAttribute3]
    property StringValue: string read FStringValue write FStringValue;
    ...
  end;
  ...

Para acceder en tiempo de ejecución a estos atributos, accederemos a la lista de atributos adjunta al tipo, método, campo o propiedad reflejados en la Rtti.

function GoGetProperties2(const AClass: TClass): TStrings;
var
  cxt: TRttiContext;
  t : TRttiType;
  p  : TRttiProperty;
  Attr: TCustomAttribute;
  s: string;
begin
  Result := TStringList.Create;
  cxt := TRttiContext.Create;
  try
    t := cxt.GetType(AClass);
    s := '';
    for Attr in t.GetAttributes do
    begin
      s := ',' + Attr.ClassName;
      if Attr is TMyAttribute then
      begin
        // Este clase tiene asociado el atributo TMyAttribute
      end;
    end;
    if s'' then
      s := '('+s.Substring(2)+')';
    Result.Add('Type: '+t.Name+' '+s);
    for p in t.GetProperties do
    begin
      s := '';
      for Attr in p.GetAttributes do
      begin
        s := ',' + Attr.ClassName;
        if Attr is TMyAttribute2 then
        begin
          // Este propiedad tiene asociado el atributo TMyAttribute2
        end;
      end;
      if s'' then
        s := '('+s.Substring(2)+')';
      Result.Add('  Property: '+ p.Name+' '+s);
    end;
  finally
    cxt.Free;
  end;
end;

Si pasamos esta función sobre la calse TMyClass

Type: TMyclass (MyAttribute)
  Property: IntegerValue (MyAttribute2)
  Property: DoubleValue
  Property: StringValue (MyAttribute3)

Además podemos crear propiedades a los atributos que después podremos recuperar, para ello los crearemos en la clase del atributo:

   ...
  TMyAttribute2 = class(TCustomAttribute)
  private
    FValue: string;
  public
    property Value: string read FValue write FValue;
    constructor Create(const AValue: string = '');
  end;
  ...
constructor TMyAttribute2.Create(const AValue: string);
begin
  FValue := AValue;
end;
  ...

Si ponemos una pequeña modificación cuando recuperamos los atributos de las propiedades podemos recuperar estos valores

        ...
        if Attr is TMyAttribute2 then
        begin
          // Este propiedad tiene asociado el atributo TMyAttribute2
          s := s + '{' + TMyAttribute2(Attr).Value + '}'; 
        end;
       ...

Si añadimos un valor a este atributo en la propiedad del ejemplo

    ...
    [TMyAttribute2('Esto es SPARTA')]
    property IntegerValue: Integer read FIntegerValue write FIntegerValue;
    ...

Ahora el resultado de pasar la función sobre la clase

Type: TMyclass (MyAttribute)
  Property: IntegerValue (MyAttribute2{Esto es SPARTA})
  Property: DoubleValue
  Property: StringValue (MyAttribute3)

Hemos visto como usar los atributos de la Rtti así de como recuperarlos de un tipo, método, campo o propiedad. Esta utilización de la Rtti será muy útil para nuestros propósitos.

Serialización sencilla JSON (II)

Vamos a ver de manera sencilla como crear la el objeto JSON personalizado de nuestra clase,
para eso veamos la clase creada:

unit Unit1;

interface

uses
  Data.DBXJSON;

type
  TMyclass = class(TObject)
  private
    FIntegerValue: Integer;
    FDoubleValue: Double;
    FStringValue: string;
  public
    class function FromJsonObject(const AJsonObject: TJSONObject): TMyClass;
    class function FromJsonString(const AJsonString: string): TMyClass;
    function ToJsonObject: TJSONObject;
    function ToJsonString: string;
  published
    property IntegerValue: Integer read FIntegerValue write FIntegerValue;
    property DoubleValue: Double read FDoubleValue write FDoubleValue;
    property StringValue: string read FStringValue write FStringValue;
  end;

implementation

uses
  System.SysUtils;

{ TMyclass }

class function TMyclass.FromJsonObject(
  const AJsonObject: TJSONObject): TMyClass;
begin
  Result := TMyclass.Create;
  if Assigned(AJsonObject) then
  begin
    Result.FIntegerValue := TJSONNumber(AJsonObject.Get('I').JsonValue).AsInt;
    Result.FDoubleValue := TJSONNumber(AJsonObject.Get('D').JsonValue).AsDouble;
    Result.FStringValue := TJSONString(AJsonObject.Get('S').JsonValue).Value;
  end;
end;

class function TMyclass.FromJsonString(const AJsonString: string): TMyClass;
var
  AJson: TJSONValue;
begin
  AJson := TJSONObject.ParseJSONValue(AJsonString);
  try
    Result := FromJsonObject(TJSONObject(AJson));
  finally
    if Assigned(AJson) then
      AJson.Free;
  end;
end;

function TMyclass.ToJsonObject: TJSONObject;
begin
  Result := TJSONObject.Create;
  Result.AddPair('I',TJSONNumber.Create(FIntegerValue));
  Result.AddPair('D',TJSONNumber.Create(FDoubleValue));
  Result.AddPair('S',TJSONString.Create(FStringValue));
end;

function TMyclass.ToJsonString: string;
begin
  with ToJsonObject do
  try
    Result := ToString;
  finally
    Free;
  end;
end;

end.

TMyClass es una ampliación de lo que vimos en el post anterior (Serialización sencilla en JSON), aquí el cotarro está en ToJsonObject y FormJsonObject, donde usamos el método AddPair de TJSONObject para ir añadiendo los campos que queremos serializar. que posteriormente recuperaremos con la función Get.

Como ejemplo:

function Test: string;
begin
  with TMyclass.Create do
    try
      IntegerValue := MaxInt;
      DoubleValue := 100728.897;
      StringValue := 'Hola Mundo';
      Result := ToJsonString;
    finally
      Free;
    end;
end;

Result = {"I":2147483647,"D":100728.897,"S":"Hola Mundo"}

Ahora vamos a ver como funcionan los arrays, para verlo podemos crear una lista de objetos, como

...
type
  TMyClassList = class(TObjectList<TMyclass>)
  public
    class function FromJsonObject(const AJsonObject: TJSONObject): TMyClassList;
    class function FromJsonString(const AJsonString: string): TMyClassList;
    function ToJsonObject: TJSONObject;
    function ToJsonString: string;
  end;
...
class function TMyClassList.FromJsonObject(const AJsonObject: TJSONObject): TMyClassList;
var
  AJsonArray: TJSONArray;
  i: Integer;
begin
  Result := TMyClassList.Create;
  if Assigned(AJsonObject) then
  begin
    AJsonArray := TJSONArray(AJsonObject);
    for i := 0 to AJsonArray.Size - 1 do
      Result.Add(TMyclass.FromJsonObject(TJSONObject(AJsonArray.Get(i))));
  end;
end;

class function TMyClassList.FromJsonString(const AJsonString: string): TMyClassList;
var
  AJson: TJSONValue;
begin
  AJson := TJSONObject.ParseJSONValue(AJsonString);
  try
    Result := FromJsonObject(TJSONObject(AJson));
  finally
    if Assigned(AJson) then
      AJson.Free;
  end;
end;

function TMyClassList.ToJsonObject: TJSONObject;
var
  AJsonArray: TJSONArray;
  i: Integer;
begin
  AJsonArray := TJSONArray.Create;
  for i := 0 to Count - 1 do
    AJsonArray.AddElement(Items[i].ToJsonObject);
  Result := TJSONObject(AJsonArray);
end;

function TMyClassList.ToJsonString: string;
begin
  with TJSONArray(ToJsonObject) do
    try
      Result := ToString;
    finally
      Free;
    end;
end;
...

He usado las mismas pautas que en TMyClass para ver de forma sencilla podemos generarlo. Usamos TJSONArray.AddElement para crear los elementos y Get para recuperarlos.

Como ejemplo

function TForm2.Test: string;
var
  a: TMyclass;
  b: TMyClassList;
begin
  b := TMyClassList.Create;
  try
    a := TMyclass.Create;
    with a do
    begin
      IntegerValue := MaxInt;
      DoubleValue := 100728.897;
      StringValue := 'Antonio';
    end;
    b.Add(a);
    a := TMyclass.Create;
    with a do
    begin
      IntegerValue := 0;
      DoubleValue := 827.09;
      StringValue := 'Pedro';
    end;
    b.Add(a);
    a := TMyclass.Create;
    with a do
    begin
      IntegerValue := -MaxInt;
      DoubleValue := -3.141596;
      StringValue := 'Jose';
    end;
    b.Add(a);
    Result := b.ToJsonString;
  finally
    b.Free;
  end;
end;

Result = [{"I":2147483647,"D":100728.897,"S":"Antonio"},{"I":0,"D":827.09,"S":"Pedro"},{"I":-2147483647,"D":-3.141596,"S":"Jose"}]

De una forma sencilla podemos crear nuestra propia serialización.

Serialización sencilla en JSON

El desarrollo de DataSnap Rest en Delphi (desde XE si no me equivoco)implica que disponemos de unas librerías que nos permiten la serialización de los objetos en JSON. Además se nos ofrecen varios tipos de clases y utilidades que nos permitirá tener estructuras complejas en JSON y poder serializar manualmente cualquier objeto (dentro de la capacidad de la Rtti).

 TJson = class(TObject)
  public
    class function ObjectToJsonObject(AObject: TObject; AOptions: TJsonOptions = []): TJSOnObject;
    class function ObjectToJsonString(AObject: TObject; AOptions: TJsonOptions = []): string;
    class function JsonToObject<T: class, constructor>(AJsonObject: TJSOnObject): T; overload;
    class function JsonToObject<T: class, constructor>(AJson: string): T; overload;
    class function Format(AJsonValue: TJsonValue): string;
  end;

Si no queremos complicarnos la vida, existen funciones que directamente nos hacen el trabajo, se encuentran en la unidad REST.Json, a través de su clase TJson:

Estas funciones nos permiten convertir cualquier objeto en un objeto o cadena JSON y viceversa, su uso es muy sencillo, sólo debemos indicar el objeto, clase y/o cadena a convertir.

Como ejemplo de su simplicidad:

...
type
  TMyClass = class(TObject)
  ...
  public
    function ToJsonString: string;
    class function CreateFromJsonString(const AJsonString: string): TMyClass;
  end;
...
function TMayClass.ToJsonString: string
begin
  Result := REST.Json.TJson.ObjectToJsonString(Self);
end;

class function TMyClass.CreateFromJsonString(const AJsonString: string): TMyClass;
begin
  Result := REST.Json.TJson.JsonToObject<TMyClass>(AJsonString);
end;
...

En muchas ocasiones, estas funciones nos serán de utilidad, en otras ya tendremos que adentrarnos más en el funcionamiento de los objetos json de Delphi y generar nosotros mismos la conversión .

Desarrollo de Framework

Para aprender un poco más sobre Delphi, voy ha realizar una serie de posts a través de los cuales se desarrollará un Framework de trabajo.

El objetivo que me planteo es aprender, en la medida de lo posible, sobre:

• Rtti (Run-Time Type Information)
• Interfaces
• Json
• Persistencia 
• Integración en el IDE de Delphi
• Ingeniería inversa
• Bases de Datos

Intentaremos implementar un framework para el desarrollo de soluciones de negocio orientadas a objetos. Ya sé que existen soluciones buenas, pero la función es la del aprendizaje.

Se desarrollará sobre Delphi XE5, aunque se intentará dejar la puerta abierta para implementaciones en versiones más antiguas de Delphi.

Usando clases e interfaces crearemos unas estructuras básicas que nos permitan automatizar los procesos como la creación de clases y objetos, la serialización en Json, el almacenamiento en bases de datos, etc. Todos estos procesos automáticos serán parte fundamental de este framework que basaremos en la utilización de las funcionalidades que nos aporta la Rtti.

Según avancemos en el desarrollo generaremos herramientas de desarrollo que integraremos en el IDE de Delphi, como la generación del código de nuevas clases usando este framework.

También tengo en mente centralizar el uso del framework utilizando DataSnap o un servicio web.

Además intentaremos flexibilizar al máximo el framework (lo que nos implicará más complejidad y por tanto aprenderemos más) para poder utilizarlo de manera inversa usando las estructuras de Bases de Datos de las que ya dispongamos. Ya que en el desarrollo de aplicaciones, se usa mucho crear primero la estructura en la base de datos y después la integración en la aplicación software.

Como he dicho, la primordial misión es la de aprender y no la de obtener un rendimiento óptimo ni de abarcar una casuística muy amplia.

Antes de empezar, e incluso, durante el desarrollo del framework, iré publicando posts que nos sirvan para el desarrollo del framework.

Object Pascal Style Guide

Antes de empezar a con los posts de programación vamos a establecer unos estilos de trabajo.

Aunque cada uno puede usar los estilos que quiera para programar, yo voy a intentar seguir los estilos indicados en Object Pascal Style Guide, con alguna adición o modificación, a continuación presento un esbozo.

Atención: Aunque en este documento los nombres los pongo en castellano (MiVariable, MiCampo,...), en los desarrollo generalmente usaré el inglés (MyVariable, MyField,...), se ha dejado este documento en castellano para su mejor comprensión. 

Convenciones de nomenclatura

A excepción de las palabras reservadas y directivas, que están en minúsculas, todos los identificadores Pascal deben usar UpperCamelCase, lo que significa que la primera letra debe ser mayúscula, y las palabras incrustadas en un identificador debe ser en mayúsculas, así como cualquier sigla que está incrustada. Además no se debe usar el carácter de subrayado o guión bajo  "_" para unir palabras.

// Mal formadas

patata

miVariable

Lanzar_Actualizacion

MiClaseFtp

// Bien formadas

Patata

MiVariable

LanzarActualizacion

MiClaseFTP

Tipos

Cualquier definición de tipo (excepto Interfaces) siempre comenzará con la letra T y a continuación el nombre.

type

  TMiTipo = class(TObject)...

Interfaces

Los interfaces comenzarán con la letra I y a continuación el nombre.

  IMiBuenPastor = interface 

  ...

En algunos casos he comenzando con la palabra Interface aunque ya no lo estoy utilizando mucho

  InterfaceMiBuenPastor = interface 

  ...

Tipos enumerados

En este caso, los componentes del tipo utilizarán la notación húngara (más o menos)

type

  TFormatoCuadrado = (fcNormal, fcRedondeado, fcEstrellado);

Dónde fc significa formato de cuadrado.

Clases

Los nombres de las clases siguen la nomenclatura de los tipos (TMiClase)

Campos

Los campos de las clases comenzarán por la F y el nombre del campo y generalmente irá en la sección privada. En general deben ser sustantivos. Para hacer uso publico de estos campos usaremos las propiedades o  setters y getters

  FMyCampo: string;

Métodos

Los nombres de los métodos deben ser verbos o frases imperativas.

  LanzarRestauracion

  Cargar

  Salvar

  AgregaBoton

Propiedades

Generalmente las propiedades accederán directamente a los campos o a través de getters y setters

  property MiCampo: string read FMiCampo write FMiCampo;

  property MiCampo: string read GetMiCampo write SetMiCampo;

  property MiCampo: string read FMiCampo write SetMiCampo;

Variables locales

Las variables locales nunca deben empezar por la letra F para diferenciarlas de los campos. Deben ser en general sustantivos o nombres que no definan ninguna acción, para no confundirlas con los métodos o procedimientos.

Se permite el uso de variables de una sólo letra en minúscula para variables temporales y de bucle:

  for i := 0 to 9 do

    HacerAlgo;

Procedimientos y funciones

Igual que los métodos.

  procedure HacerAlgo;
  function CalculaAlgo: double;

Formateo de código

Mención especial tiene el formateo de código ya que como actualmente el mismo Delphi ya tiene un herramienta de formateo integrada, por lo que es recomendable usarla. Para versiones más antiguas se puede usar el DelForExp (podeis verlo en Delphi al Límite) o el JEDI Code Format