Every now and then I am doing something that I think would be benefited by virtual class vars. FPC already has class vars but every subclass accesses the same var. They are not virtual. In a way there are some hard coded virtual class vars such as TObject.ClassName
This shows how current class vars operate:
program test; TA = class class var MyVariable: Integer; end; TB = class(TA); var A: TA; B: TB; begin A.MyVariable := 1234; B.MyVariable := 4321; WriteLn(A.MyVariable); end.
The output is
4321
.With a virtual class var the output would be 1234
. Unfortunately FPC does not have virtual class vars so I have devised a terrible hack.In short I declare a virtual procedure that will never be used, this is a placeholder. Then create a class constructor which finds the index of that procedure in the VMT which is saved to a regular class var. Then I set the VMT entry to nil as if it's an unset variable. And the first part is done. For every virtual class var you will need a regular class var to hold the index of the placeholder VMT entry.
type TA = class protected class var cMyVarIndex: Integer; private class constructor create; strict private procedure MyVarHolder; virtual; //cannot be abstract end; implementation class constructor TA.create; var i: Integer; c: PPointer; begin c := PPointer(ClassType); for i := 0 to MaxInt-1 do begin if c[i] = Pointer(@TA.VarHolder1) then begin cMyVarIndex:=i; c[i] := nil; break; end; end; end;
Now we need a way to set and unset our variable. We will have to access it using a virtual class function and procedure.In my case I used a string type.
protected class function GetName: string; virtual; class procedure SetName(AValue: string); virtual; public property Name: String read GetName write SetName; ... class function TA.GetName: string; var c: PPointer; P: PString; begin c := PPointer(ClassType); P := PString((c[cMyVarIndex])); if p = nil then Result := '' else result := p^; end; class procedure TA.SetName(AValue: string); var c: PPointer; P: PString; begin c := PPointer(ClassType); P := PString((c[cMyVarIndex])); if P <> nil then DisposeStr(P); c[cMyVarIndex] := NewStr(AValue) end;
Class properties cannot use virtual methods so I used a property that can only be accessed by an instance.
Here's the complete source for my example.
program test; {$mode objfpc}{$H+} uses Classes, sysutils; type TA = class(TObject) protected class var cMyVarIndex: Integer; private class constructor create; strict private procedure MyVarHolder; virtual; //cannot be abstract public class function GetName: string; virtual; class procedure SetName(AValue: string); virtual; property Name: String read GetName write SetName; end; TB = class (TA) class constructor create; end; class constructor TA.create; var i: Integer; c: PPointer; begin c := PPointer(ClassType); for i := 0 to MaxInt-1 do begin if c[i] = Pointer(@TA.MyVarHolder) then begin cMyVarIndex:=i; c[i] := nil; break; end; end; end; class function TA.GetName: string; var c: PPointer; P: PString; begin c := PPointer(ClassType); P := PString((c[cMyVarIndex])); if p = nil then Result := '' else Result := p^; end; class procedure TA.SetName(AValue: string); var c: PPointer; P: PString; begin c := PPointer(ClassType); P := PString((c[cMyVarIndex])); if P <> nil then DisposeStr(P); c[cMyVarIndex] := NewStr(AValue) end; procedure TA.MyVarHolder; begin // never called! end; class constructor TB.create; var c: PPointer; begin c := Pointer(ClassType); c[cMyVarIndex] := nil; end; var A: TA; B: TB; C: TA; begin A := TA.Create; B := TB.Create; C := TA.Create; // of type TA A.Name := 'Hello'; B.Name := 'World'; WriteLn('A Name = ', A.Name); WriteLn('B Name = ', B.Name); WriteLn('C Name = ', C.Name); FreeAndNil(A); FreeAndNil(B); FreeAndNil(C); end.
You may have noticed that I had to create a class constructor for TB. This is because the VMT for TB is already initialized with the address of TA.MyVarHolder.
To get around this I made the following changes.
program test; {$mode objfpc}{$H+} uses Classes, sysutils; type TVirtualClassVarObject = class strict private procedure vVarsAreSetHolder; virtual; // placeholder. never called protected class var cVarsAreSetIndex: Integer; class procedure SetClassVarIndex(var AIndex: Integer; APlaceHolderAddress: Pointer; AShouldNil: Boolean = True); virtual; private function InitializeVirtualClassVars: Boolean; virtual; class constructor Create; public constructor Create; end; TA = class(TVirtualClassVarObject) strict private procedure vNameHolder; virtual; //cannot be abstract. placeholder protected class var cVarNameIndex: Integer; class function GetName: string; virtual; class procedure SetName(AValue: string); virtual; function InitializeVirtualClassVars: Boolean; override; public property Name: String read GetName write SetName; end; TB = class (TA) end; { TVirtualClassVarObject } class procedure TVirtualClassVarObject.SetClassVarIndex(var AIndex: Integer; APlaceHolderAddress: Pointer; AShouldNil: Boolean); var i: Integer; c: PPointer; begin c := PPointer(ClassType); if AIndex <> 0 then begin // we are in a descendant class and index is known if AShouldNil then c[AIndex] := nil; Exit; end; // find the index for i := 0 to MaxInt-1 do begin if c[i] = APlaceHolderAddress then begin AIndex:=i; if AShouldNil then c[i] := nil; break; end; end; end; function TVirtualClassVarObject.InitializeVirtualClassVars: Boolean; begin Result := False; if PPointer(ClassType)[cVarsAreSetIndex] = nil then Exit; PPointer(ClassType)[cVarsAreSetIndex] := nil; Result := True; end; class constructor TVirtualClassVarObject.Create; begin SetClassVarIndex(cVarsAreSetIndex, @TA.vVarsAreSetHolder, False); end; procedure TVirtualClassVarObject.vVarsAreSetHolder; begin // do nothing; end; constructor TVirtualClassVarObject.Create; begin InitializeVirtualClassVars; end; function TA.InitializeVirtualClassVars: Boolean; begin Result := inherited InitializeVirtualClassVars; if Result then begin SetClassVarIndex(cVarNameIndex, @TA.vNameHolder); end; end; class function TA.GetName: string; var c: PPointer; P: PString; begin c := Pointer(ClassType); P := PString((c[cVarNameIndex])); if p = nil then Result := '' else Result := p^; end; class procedure TA.SetName(AValue: string); var c: PPointer; P: PString; begin c := Pointer(ClassType); P := PString((c[cVarNameIndex])); if P <> nil then DisposeStr(P); c[cVarNameIndex] := NewStr(AValue) end; procedure TA.vNameHolder; begin // never called! end; var A: TA; B: TB; C: TA; begin A := TA.Create; B := TB.Create; C := TA.Create; // of type TA A.Name := 'Hello'; B.Name := 'World'; WriteLn('A Name = ', A.Name); WriteLn('B Name = ', B.Name); WriteLn('C Name = ', C.Name); FreeAndNil(A); FreeAndNil(B); FreeAndNil(C); end.
A Name = Hello
B Name = World
C Name = Hello
I added a base object TVirtualClassVarObject; It has a small framework to ease adding virtual class vars to descendant classes. It takes care of initializing class vars to nil in child classes in InitializeVirtualClassVars. You could also set a default value to something else. Each child class would get that default value.
For each variable you want to add you must declare an index variable, virtual procedure and the getter and setter methods. Then in InitializeVirtualClassVars call SetClassVarIndex with the index variable to set and the address of the virtual procedure.
Limitations. There are a couple of limitations I see. Variable types are limited in size to SizeOf(Pointer). If you need a more complex type stored you will have to store a pointer to the data and access it that way, like I have done with the string property. I haven't taken care of disposing of variables that are allocated. This wouldn't be too hard to add. However if you limit your variable types to basic types or pointers to existing data it shouldn't matter. When the class is destructing the program is about to end and it's memory will be freed anyway.
That's it. Now if you really want to you can add virtual class vars to your objects.