BatSoft.Classes.pas

TInterfacedObjectNoRefCount

For a simple TInterfacedObject without reference counting, there is System.Generics.Defaults.TSingletonImplementation. But that is oddly named and hard to find, hence BatSoft.Classes.TInterfacedObjectNoRefCount.

TMinRefCountObject

Sometimes I want interfaced objects to free when the RefCount is something other than 0, such as when writing factories that keep track of multitons.
This is simply a TInterfacedObject where the reference count has been offset. It may be a hack, but the logic is tight.

TRefCountMyOwner

Enables adding interfaces to a class that is not a TInterfacedObject.

Did you ever have a class that you wanted to add an interface to, but couldn’t change the root class to TInterfacedObject, and didn’t want to explicitly implement the IInterface methods? Well, here is your solution.

(Have you looked at TinterfacedObject? It’s not a simple matter of simply copy/pasting three methods.)

Say you have:

TMyClass = class(TUneditableParentClass, IMyInterface)

Add the following to your class declaration:

  private
    fRefCounter: IInterface;
  public
    //  IInterface interface
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;

Add the following to the constructor:

  fRefCounter   := TRefCountMyOwner.Create(Self);

Implement the IInterface methods as follows:

function TMyClass.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
    Result := 0
  else
    Result := E_NOINTERFACE;
end;

function TMyClass._AddRef: Integer;
begin
  Result  := fRefCounter._AddRef
end;

function TMyClass._Release: Integer;
begin
  Result  := fRefCounter._Release
end;

TInterfaceRegistry

The intention is for modules to register their singleton interface implementations centrally. Then the rest of the application can obtain the singletons knowing only the interface type. The only coupling will be the instance of this object and the interface declarations, but not their implementations.

RegisteredLists

Generic types are great. But they’re not runtime types, so you can’t query a TList<XYZ> object to find out what type XYZ is.

RegisteredLists enables the registration of container classes and their related element types. Later, when you have a collection object, you can ask RegisteredLists to find out what element type it holds. This is used in other BatSoft units.

TBinaryList<T>

Think of this as a binary sorted TList<>. This is useful for indexing.

It’s actually a wrapper for TList<> and many methods simply pass through to the internal TList<> object. But this class adds binary sorting and associated limitations.

For example; you can’t insert elements, only add them. TBinaryList<> will put the new items into their proper places.

TAttributeArrayHelper

This is a place to put generic and useful routines for attribute arrays. It saves re-writing the same old loops to search for specific attributes.

Note: The parameter FoundAttribute is actually an output parameter that returns the attribute when it’s found.

procedure ChangeClass()

Change the class of an object.

Note: This procedure contains safeguards to reduce the risk of bugs, but please make certain you know what you’re doing.

This comes in handy when you want to extend, for example, controls in forms. Consider this:

You want to add functionality to a control that is only used in one form. (I do this when testing a control’s functionality.) So, you make a descendant class where you override a method (ex. Paint). Normally, to see your control on the form in design time, you would register the new component in a package and install that package.

With this procedure you simply change the component’s class to your descendant class at runtime. One line! Try this:

type
  TForm2 = class(TForm)
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
  end;

  TTestLabel = class(TLabel)
  protected
    procedure Paint; override;
  end;

uses
  BatSoft.Classes;

{ TForm2 }

procedure TForm2.FormCreate(Sender: TObject);
begin
  ChangeClass(Label1, TTestLabel); // <-  Change Label1 from TLabel to TTestLabel
end;

{ TTestLabel }

procedure TTestLabel.Paint;
var
  Brush: TStrokeBrush;
begin
  inherited;
  Brush := TStrokeBrush.Create(TBrushKind.Solid, TAlphaColorRec.Red);
  try
    Brush.Thickness := 5;
    Canvas.DrawLine(PointF(0, 0), PointF(Width, Height), 1, Brush);
    Canvas.DrawLine(PointF(Width, 0), PointF(0, Height), 1, Brush);
  finally
    Brush.Free;
  end;
end;