Sordie.co.uk

libsassy/libSassy.RTTI.pas

Raw

{(
 )) libSassy.RTTI
((    RTTI field access
 ))
((  Copyright  Sordie Aranka Solomon-Smith 2015
 ))
((  This work is made available under the terms of the Creative Commons
 )) Attribution-NonCommercial-ShareAlike 3.0 Unported license
((  http://creativecommons.org/licenses/by-nc-sa/3.0/
 )}

{
  Warning - This library uses Delphi's Rtti and TypInfo library which will in
  turn include massive RTL components such as SysUtils and Variants.
}

unit libSassy.RTTI;

interface

uses
  System.Rtti,
  System.TypInfo,

  libSassy.Errors;

type
{$REGION 'TRttiContextHelper'}
  TRttiContextHelper = record helper for TRttiContext
  public
    function FindPublishedType(const Name: String): TRttiType;
  end;
{$ENDREGION}

{$REGION 'TObjectHelper'}
  TObjectHelper = class helper for TObject
  private
    function GetThis: TObject; inline;
  public
    class procedure Use;

    function  ReadProperty (const Name: String): TValue;
    procedure WriteProperty(const Name: String; Value: TValue);

    function InvokeMethod(const Name: String; Args: array of TValue): TValue;

    function IsReadable (const Name: String): Boolean;
    function IsWriteable(const Name: String): Boolean;

    property This: TObject read GetThis;
  end;

  TRttiError = class(TException);
{$ENDREGION}

{$REGION 'TExpandableObject'}
  TExpandableObject = class
  public
    function  ReadExpandedProperty (const Name: String): TValue;        virtual;
    procedure WriteExpandedProperty(const Name: String; Value: TValue); virtual;

    function InvokeExpandedMethod(const Name: String; Args: array of TValue): TValue; virtual;

    function IsExpandedReadable (const Name: String): Boolean; virtual;
    function IsExpandedWriteable(const Name: String): Boolean; virtual;
  end;
{$ENDREGION}

var
  RttiContext: TRttiContext;

implementation

uses
  libSassy.Strings;

{$REGION 'TRttiContextHelper'}
function TRttiContextHelper.FindPublishedType;
var
  i:    Integer;
  f, n: String;
begin
  f := Name.Lowercase;

  for Result in RttiContext.GetTypes do
  begin
    n := Result.QualifiedName.Lowercase;

    for i := n.Length downto 1 do
      if n[i] = '.' then break;

    n := n.Copy(i + 1);

    if n = f then exit;
  end;

  Result := nil;
end;
{$ENDREGION}

{$REGION 'TObjectHelper'}
function TObjectHelper.GetThis;
begin
  Result := Self;
end;

class procedure TObjectHelper.Use;
asm
  nop
end;

function TObjectHelper.ReadProperty;
var
  RttiProperty: TRttiProperty;
begin
  TMonitor.Enter(Self);

  try
    if Self is TExpandableObject then
      with Self as TExpandableObject do
      begin
        if IsExpandedReadable(Name) then
          try
            Result := ReadExpandedProperty(Name);
            exit;
          except end;
      end;

    RttiProperty := RttiContext.GetType(Self.ClassType).GetProperty(Name);

    if (RttiProperty = nil) or (RttiProperty.Visibility in [mvPrivate, mvProtected]) then
      TRttiError.RaiseException('Unknown property "' + Name + '"');

    Result := RttiProperty.GetValue(Self);
  finally
    TMonitor.Exit(Self);
  end;
end;

procedure TObjectHelper.WriteProperty;
var
  RttiProperty: TRttiProperty;
begin
  TMonitor.Enter(Self);

  try
    if Self is TExpandableObject then
      with Self as TExpandableObject do
      begin
        if IsExpandedWriteable(Name) then
          try
            WriteExpandedProperty(Name, Value);
            exit;
          except end;
      end;

    RttiProperty := RttiContext.GetType(Self.ClassType).GetProperty(Name);

    if (RttiProperty = nil) or (RttiProperty.Visibility in [mvPrivate, mvProtected]) then
      TRttiError.RaiseException('Unknown property "' + Name + '"');

    RttiProperty.SetValue(Self, Value);
  finally
    TMonitor.Exit(Self);
  end;
end;

function TObjectHelper.InvokeMethod;
var
  RttiMethod: TRttiMethod;
begin
  TMonitor.Enter(Self);

  try
    if Self is TExpandableObject then
      with Self as TExpandableObject do
      begin
        if IsExpandedReadable(Name) then
          try
            Result := InvokeExpandedMethod(Name, Args);
            exit;
          except end;
      end;

    RttiMethod := RttiContext.GetType(Self.ClassType).GetMethod(Name);

    if (RttiMethod = nil) or (RttiMethod.Visibility in [mvPrivate, mvProtected]) then
      TRttiError.RaiseException('Unknown method "' + Name + '"');

    Result := RttiMethod.Invoke(Self, Args);
  finally
    TMonitor.Exit(Self);
  end;
end;

function TObjectHelper.IsReadable;
var
  RttiProperty: TRttiProperty;
  RttiMethod:   TRttiMethod;
begin
  if Self is TExpandableObject then
  begin
    Result := TExpandableObject(Self).IsExpandedReadable(Name);
    if Result then exit;
  end;

  RttiProperty := RttiContext.GetType(Self.ClassType).GetProperty(Name);

  if RttiProperty <> nil then
    Result := (RttiProperty.Visibility in [mvPublic, mvPublished]) and RttiProperty.IsReadable
  else
  begin
    RttiMethod := RttiContext.GetType(Self.ClassType).GetMethod(Name);
    Result := (RttiMethod <> nil) and (RttiMethod.Visibility in [mvPublic, mvPublished]);
  end;
end;

function TObjectHelper.IsWriteable;
var
  RttiProperty: TRttiProperty;
begin
  if Self is TExpandableObject then
  begin
    Result := TExpandableObject(Self).IsExpandedWriteable(Name);
    if Result then exit;
  end;{if Self}

  RttiProperty := RttiContext.GetType(Self.ClassType).GetProperty(Name);

  Result := (RttiProperty <> nil) and (RttiProperty.Visibility in [mvPublic, mvPublished]) and RttiProperty.IsWritable;
end;
{$ENDREGION}

{$REGION 'TExpandableObject'}
function TExpandableObject.ReadExpandedProperty;
begin
  TRttiError.RaiseException('Unknown property "' + Name + '"');
end;

procedure TExpandableObject.WriteExpandedProperty;
begin
  TRttiError.RaiseException('Unknown property "' + Name + '"');
end;

function TExpandableObject.InvokeExpandedMethod;
begin
  TRttiError.RaiseException('Unknown method "' + Name + '"');
end;

function TExpandableObject.IsExpandedReadable;
begin
  Result := False;
end;

function TExpandableObject.IsExpandedWriteable;
begin
  Result := False;
end;
{$ENDREGION}

initialization
  RttiContext := TRttiContext.Create;

finalization
  RttiContext.Free;

end.