Home > Object Pascal > Autoregister attribute for Delphi

Autoregister attribute for Delphi

December 13, 2016 Leave a comment Go to comments

imageWouldnt it be nice if Delphi had an attribute that would automatically register your classes? So instead of having to manually call Registerclass() you just decorate the class with an attribute and it’s automatically registered. No messing about with rouge procedure calls in the initialize section, just pretty and neat class declarations as far as the eye can see.

Well, I think that would be a good idea. And after searching for such a class without finding it (which is a bit odd since it’s such an obvious candidate for automation) – I decided to make one.

Now if you are expecting a huge unit with super-duper advanced code, I’m afraid I must disappoint you. This class is about elegance, grace and usefulness. It may be a humble class in the great scheme of things, but as is often the case in life, the simplest things can be of greatest value.

I find it very useful and I hope you find it equally helpful in your projects.

unit AutoRegister;

interface

uses
System.Rtti, System.TypInfo, System.Sysutils, System.Classes;

type

// Our fancy shmancy attribute
TAutoRegister = class(TCustomAttribute)
end;

implementation

// This procedure walks through all classtypes and isolates
// those with our TAutoRegister attribute.
// It then locates the actual classtype and registeres it
// with Delphi's persistance layer
procedure ProcessAutoRegisterAttributes;
var
  ctx : TRttiContext;
  typ : TRttiType;
  attr : TCustomAttribute;
  LRealType: TClass;
  LAccess: PTypeData;
begin
  ctx := TRttiContext.Create();
  try
    for typ in ctx.GetTypes() do
    begin
      if typ.TypeKind = tkClass then
      begin
        for attr in typ.GetAttributes() do
        begin
          if attr is TAutoRegister then
          begin
            LAccess := GetTypeData(typ.Handle);
            if LAccess <> nil then
            begin
              LRealType := LAccess^.ClassType;
              if LRealType <> nil then
              begin
                if LRealType.InheritsFrom(TPersistent)
                or LRealType.InheritsFrom(TInterfacedPersistent) then
                begin
                  RegisterClass( TPersistentClass(LRealType) );
                end;
              end;
              break;
            end;
          end;
        end;
      end;
    end;
  finally
    ctx.Free();
  end;
end;

// We want to register all the classes decorated with our little
// attribute when this unit is loaded into memory
Initialization
begin
  ProcessAutoRegisterAttributes;
end;

end.

That’s basically it. Now to use the attribute just save out the unit and include it as you would any other (just add it to the uses-clause where you need it). Then decorate the classes you want registered automatically.

Remember that only classes that inherit from TPersistent (which includes TInterfacedPersistent) can be registered.

uses AutoRegister;

type
  [TAutoRegister]
  TMyClass = class(TPeristent)
  end;

  [TAutoRegister]
  TMyCoolClass = class(TInterfacedPersistent)
  end;

And voila, no more Registerclass() calls at the bottom of your units. Just neat, clean object oriented code -and as a bonus: I find it easier to read as well.

Cheers!

Advertisements
  1. December 13, 2016 at 12:45 pm

    Hi jon, i read this article, and i just wonder what am i missing with my method to get a list of registered class, i can manage to get list of class available in my runtime application using this method:

    class procedure TFuncAttributes.GetClasses(
      out AClassList: TStringList;
      AIncludedClassType : string);
    var
      atrCustom: TCustomAttribute;
      slClassesInfo : TStringList;
      arrTypes : TArray<Rtti.TRttiType>;
      typType: TRttiType;
      i: Integer;
      ctx : TRttiContext;
      arrIncludedClass : array of TClass;
      j: Integer;
      sIncludedClass : string;
      bIncludedClass : Boolean;
    begin
      if AClassList <> nil then
      begin
        ctx := TRttiContext.Create;
        try
          AClassList.Sorted := True;
          AClassList.CaseSensitive := False;
          AClassList.Duplicates := dupIgnore;
          arrTypes := ctx.GetTypes;
    
          //Get the class reference for Included Class Type first
          if AIncludedClassType = '' then
          begin
            sIncludedClass := 'TCustomForm';
          end
          else
            sIncludedClass := AIncludedClassType;
          SetLength(arrIncludedClass,0);
          for i := 0 to Length(arrTypes) - 1 do
          begin
            if TCSFDelimeter.FindText(sIncludedClass,arrTypes[i].Name,';') > -1 then
            begin
              SetLength(arrIncludedClass,Length(arrIncludedClass) + 1);
              typType := arrTypes[i];
              if typType is TRttiInstanceType then
              begin
                arrIncludedClass[Length(arrIncludedClass) - 1] :=
                  (arrTypes[i] as TRttiInstanceType).MetaclassType;
              end;
            end;
          end;
    
          for i := 0 to Length(arrTypes) - 1 do
          begin
            typType := arrTypes[i];
            if typType is TRttiInstanceType then
            begin
              bIncludedClass := False;
              //If the inluded class is define, then store only included class,
              //else store everything
              if Length(arrIncludedClass) > 0 then
              begin
                for j := 0 to Length(arrIncludedClass) - 1 do
                begin
                  if ((arrTypes[i] as TRttiInstanceType).MetaclassType.InheritsFrom(
                    arrIncludedClass[j])
                  ) then
                  begin
                    bIncludedClass := True;
                    Break;
                  end;
                end;
              end
              else
                bIncludedClass := True;
    
              if bIncludedClass then
              begin
                slClassesInfo := TStringList.Create;
                slClassesInfo.Add('ClassName=' + arrTypes[i].QualifiedName);
                for atrCustom in typType.GetAttributes do
                begin
                  if atrCustom is ClassAttribute then
                  begin
                    slClassesInfo.Add(
                      'ClassType=' +
                      GetEnumName(
                        TypeInfo(EnCSClassType),
                        Ord(ClassAttribute(atrCustom).PropertyType)
                      )
                    );
                    slClassesInfo.Add('Title=' + ClassAttribute(atrCustom).Title);
                    slClassesInfo.Add('Description=' + ClassAttribute(atrCustom).Description);
                  end;
                end;
                AClassList.AddObject(typType.Name,slClassesInfo);
              end;
            end;
          end;
        finally
          ctx.Free;
        end;
      end;
    end;
    

    This method will return list of class available in the application with the specified included class parameter. This code is working and i’m using it within my project, with this code, i can also create and load a form by it’s name. so is this method is the one you wrote about?or there is other thing that cause my method is different with your method.

    Sorry before, but i really need your advice, i concern that i might do something wrong with my method.

    Thanks

    Iwan

    • December 13, 2016 at 12:47 pm

      I’m sorry but I cant really jump into that code. I get a ton of these questions all the time and I cant spend all day cleaning up other people’s code.
      But if you post it on Delphi Developer (https://www.facebook.com/groups/137012246341854/1292918857417848/) on facebook there are many people that will no doubt help you. We are about 5500 active members there now, so you are welcome to join us!

      Object persistence can be a bit of a pain, especially when it’s recursive so you are not the first to hit a snag.
      As for RTTI, I really dont know more than the average coder. I google, read examples and try things out.
      There is always someone who has experienced the same as you – and solved it on Delphi-Developer, Stack Overflow or git.

      But you may want to be sure that you include the units: System.Rtti and System.TypInfo. Also, why on earth are you returning TStringlists..
      Also check the “include RTTI” option for the compiler — and try examples! There are a ton of examples about doing this.
      If they work and your code does not, then use theirs; then compare and you will find the solution sooner or later.

  2. sglienke
    December 14, 2016 at 10:36 am

    Nice idea in theory – useless in practice if you have loosely coupled code and you might not have a reference to that class somewhere else (so that one RegisterClass call was the only one before) the linker will remove that class. Yes, there are directives to prevent this but it’s an all or nothing. What we would need is compiler/linker support to mark classes for the linker not to remove them regardless being referenced anywhere.

    • December 15, 2016 at 8:08 am

      You would have to define “loosely coupled”. Even dependency injection results in the compiler including what is needed, even though the actual dependency is hidden from public. I have yet to see a piece of code where an instance is created without there being any reference anywhere to the class. The exception is in non assembly languages like C# where bytecodes can be loaded at runtime. Perhaps something similar could be done with packages, if you compile with packages – but still, for an instance to become available to an object factory – a line refering to that class must be present.

      The only thing good about the code i present here, is that it is “inheritance proof”. Let us say you inherit from TQTXASTPersistent, called TAClass, then from that again, called TBClass — both of them will not have their published property data mangled by their ancestors. Since we use the qualified classname as an entrypoint in the JSON data, they will not overwrite each other.

      And if you dont override ReadObjectJSon or WriteObjectJSon to write any “special” data, it will result in only one JSON document being produced.

      If you are thinking about properties or “loosely attached references” like an interface or pointer-object — well, the same is true for all storage methods, including commercial solutions. I have seen a lot of solutions, and even the most clever of them pretty much end up with the same result as this post.

      Either way, its a blog. I dont expect everyone to agree with my code or ideas all the time. But I do expect people to at least try them and present solutions rather than just hacking away at things that would equally be true to the default storage mechanism in delphi.

  3. sglienke
    December 15, 2016 at 11:15 am

    Look at this code (http://pastebin.com/CVw17Pv3) – it will just fail because I did not directly use the class i put the attribute on. But I might want to deserialize it from JSON somewhere where it only had the classname specified. This will fail because the compiler did remove it from the binary.
    P.S. If you have a TRttiType for a class its always of type TRttiInstanceType which has the MetaclassType property to give you the class – no need to look around in the type data yourself. Oh, and TInterfacedPersistent inherits from TPersistent 😉

    • December 16, 2016 at 1:00 am

      >> “Oh, and TInterfacedPersistent inherits from TPersistent”

      Yeah I know, what is your point?

      • sglienke
        December 16, 2016 at 9:37 am

        That you don’t need to explicitly check this class since with the InheritsFrom(TPersistent) it already got handled.

  1. No trackbacks yet.

Leave a Reply

Please log in using one of these methods to post your comment:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

%d bloggers like this: