Resolving circular references in VBA via ObjectStore class and CleanUp cascade

Question

Resolving circular references in VBA via ObjectStore class and CleanUp cascade

I have been working on a VBA database library and realized I had a few circular reference loops in my class hierarchy, as illustrated in the figure (left panel). I recalled reading an RDVBA blog post about the circular reference issue and the weak reference technique, as well as a CRQ question about an optimized WeakReference class. However, I wanted to try two native approaches to managing circular references in VBA: one employing a termination clean-up cascade and another using a helper object preventing the formation of the loops. To keep this question focused, I prepared a stripped-down version of the classes shown in the figure: I have removed all business logic and only kept the code relevant to this question.

Simplified class diagram of a database library (left) and a diagram with ObjectStore (right).

---

ObjectStore class

ObjectStore essentially maintains an ObjPtr → Obj map in a wrapped dictionary. With ObjectStore employed, the child object (DbStatement) constructor saves the address of its parent object (DbConnection), saving the latter to ObjectStore. To avoid replacing one loop with another, the Child cannot keep an ObjectStore reference necessitating a public variable. While the predeclared instance could do the job, a similarly behaving public auto-assigned variable named after the class is preferable because it resets if set to Nothing.

The DbManager class is not involved in circular references, is terminated automatically by VBA, and can destroy ObjectStore. However, because the ObjectStore variable is global and more than one DbManager instance may exist, ObjectStore should not be destroyed from the Class_Terminate() method. Instead, the default DbManager instance counts existing regular instances. Whenever this count goes to zero, the default instance of DbManager sets ObjectStore to Nothing, destroying the wrapped dictionary object alone with all saved object references and freeing the stored objects.

ObjectStoreGlobals

'@Folder "Object Store"
Option Explicit

Public ObjectStore As New ObjectStore

ObjectStore

'@Folder "Object Store"
'@ModuleDescription "Manages object references using scalar handles."
'@IgnoreModule IndexedDefaultMemberAccess
Option Explicit

Private Type TObjectStore
    Store As Scripting.Dictionary
End Type
Private this As TObjectStore


Private Sub Class_Initialize()
    Set this.Store = New Scripting.Dictionary
    this.Store.CompareMode = TextCompare
End Sub

Private Sub Class_Terminate()
    this.Store.RemoveAll
    Set this.Store = Nothing
End Sub

#If VBA7 Then
Public Sub DelRef(ByVal Handle As LongPtr)
#Else
Public Sub DelRef(ByVal Handle As Long)
#End If
    If this.Store.Exists(Handle) Then this.Store.Remove Handle
End Sub

#If VBA7 Then
Public Function SetRef(ByVal ObjRef As Object) As LongPtr
    Dim Handle As LongPtr
#Else
Public Function SetRef(ByVal ObjRef As Object) As Long
    Dim Handle As Long
#End If
    Handle = ObjPtr(ObjRef)
    If Not this.Store.Exists(Handle) Then
        Set this.Store(Handle) = ObjRef
    End If
    SetRef = Handle
End Function

#If VBA7 Then
Public Function GetRef(ByVal Handle As LongPtr) As Object
#Else
Public Function GetRef(ByVal Handle As Long) As Object
#End If
    If this.Store.Exists(Handle) Then
        Set GetRef = this.Store(Handle)
    Else
        Set GetRef = Nothing
    End If
End Function

---

CleanUp cascade

A CleanUp cascade is an alternative approach to resolving circular references. It relies on a network of routines relaying clean-up flow control between affected objects and clearing attributes forming reference loops. This process can be initiated from the Class_Terminate() method of a top-level unaffected object. With loops due to Parent ↔ Children relationships, clearing parent references should suffice. The code below, however, resets both parent and children attributes. But once it has reset a given instance, it severs all links to other objects, making further traversal impossible. For this reason, the clean-up code traverses the object hierarchy in depth-first fashion via the CleanUp routines, nesting the calls and paving its way back via the call stack. After reaching the lowest affected node, the clean-up process resets the node and passes control back to its parent via a return from a nested CleanUp call.

---

The DbManager, DbConnection, and DbStatement classes incorporate both approaches for illustrative purposes, with one or the other (or neither) being conditionally selected by setting a public variable flag.

DbManager

'@Folder "Demo"
'@ModuleDescription "Top database API class. Abstract factory for DbConnection."
'@PredeclaredId
Option Explicit

Private Type TDbManager
    Connections As Scripting.Dictionary '''' Children collection
    InstanceCount As Long               '''' Number of DbManager objects
    TimeStamp As Double
    DefaultInstance As Boolean
End Type
Private this As TDbManager


Public Function Create() As DbManager
    Dim Instance As DbManager
    Set Instance = New DbManager
    Instance.Init
    Set Create = Instance
End Function

Friend Sub Init()
    Set this.Connections = New Scripting.Dictionary
    this.Connections.CompareMode = TextCompare
    this.DefaultInstance = False
    this.TimeStamp = GetEpoch()
End Sub

Private Sub Class_Initialize()
    If Me Is DbManager Then
        this.InstanceCount = 0
    Else
        DbManager.InstanceAdd
    End If
    this.DefaultInstance = True
    Dim InstanceType As String
    InstanceType = IIf(Me Is DbManager, "Default", "Regular")
    Debug.Print EpochToString(this.TimeStamp) & ": DbManager   /" & _
                InstanceType & " - Class_Initialize"
End Sub

Private Sub Class_Terminate()
    If ObjectStoreGlobals.ReferenceLoopManagementMode = REF_LOOP_CLEANUP_CASCADE Then
        CleanUp
    End If
    DbManager.InstanceDel
    Dim InstanceType As String
    InstanceType = IIf(this.DefaultInstance, "Default", "Regular")
    Debug.Print GetTimeStampMs & ": DbManager   /" & _
                InstanceType & " - Class_Terminate"
End Sub

Friend Sub CleanUp()
    Dim DbConn As DbConnection
    Dim DbConnHandle As Variant
    For Each DbConnHandle In this.Connections.Keys
        Set DbConn = this.Connections(DbConnHandle)
        DbConn.CleanUp
    Next DbConnHandle
    Set DbConn = Nothing
    this.Connections.RemoveAll
    Set this.Connections = Nothing
End Sub

Public Function CreateConnection(ByVal DbConnStr As String) As DbConnection
    Dim DbConn As DbConnection
    Set DbConn = DbConnection.Create(DbConnStr)
    Set this.Connections(DbConnStr) = DbConn
    Set CreateConnection = DbConn
End Function

Public Property Get InstanceCount() As Long
    If Me Is DbManager Then
        InstanceCount = this.InstanceCount
    Else
        InstanceCount = DbManager.InstanceCount
    End If
End Property

Public Property Let InstanceCount(ByVal Value As Long)
    If Me Is DbManager Then
        this.InstanceCount = Value
    Else
        DbManager.InstanceCount = Value
    End If
End Property

Public Sub InstanceAdd()
    If Me Is DbManager Then
        this.InstanceCount = this.InstanceCount + 1
    Else
        DbManager.InstanceCount = DbManager.InstanceCount + 1
    End If
End Sub

Public Sub InstanceDel()
    If Me Is DbManager Then
        this.InstanceCount = this.InstanceCount - 1
        If this.InstanceCount = 0 Then
            If ObjectStoreGlobals.ReferenceLoopManagementMode = _
               REF_LOOP_OBJECT_STORE Then
                Set ObjectStore = Nothing
            End If
        End If
    Else
        DbManager.InstanceCount = DbManager.InstanceCount - 1
    End If
End Sub
''

DbConnection

'@Folder "Demo"
'@ModuleDescription "Handles database connections. Abstract factory for DbStatement."
'@PredeclaredId
Option Explicit

Private Type TDbConnection
    DbConnStr As String
    Statements As Scripting.Dictionary  '''' Children collection
    TimeStamp As Double
    DefaultInstance As Boolean
End Type
Private this As TDbConnection


'@DefaultMember
Public Function Create(ByVal DbConnStr As String) As DbConnection
    Dim Instance As DbConnection
    Set Instance = New DbConnection
    Instance.Init DbConnStr
    Set Create = Instance
End Function

Friend Sub Init(ByVal DbConnStr As String)
    this.DbConnStr = DbConnStr
    Set this.Statements = New Scripting.Dictionary
    this.Statements.CompareMode = TextCompare
    this.DefaultInstance = False
    this.TimeStamp = GetEpoch()
End Sub

Private Sub Class_Initialize()
    this.DefaultInstance = True
    Dim InstanceType As String
    InstanceType = IIf(Me Is DbConnection, "Default", "Regular")
    Debug.Print EpochToString(this.TimeStamp) & ": DbConnection/" & _
                InstanceType & " - Class_Initialize"
End Sub

Private Sub Class_Terminate()
    Dim InstanceType As String
    InstanceType = IIf(this.DefaultInstance, "Default", "Regular")
    Debug.Print GetTimeStampMs & ": DbConnection/" & _
                InstanceType & " - Class_Terminate"
End Sub

Friend Sub CleanUp()
    Dim DbStmt As DbStatement
    Dim DbStmtHandle As Variant
    For Each DbStmtHandle In this.Statements.Keys
        Set DbStmt = this.Statements(DbStmtHandle)
        DbStmt.CleanUp
    Next DbStmtHandle
    Set DbStmt = Nothing
    this.Statements.RemoveAll
    Set this.Statements = Nothing
End Sub

Public Property Get DbConnStr() As String
    DbConnStr = this.DbConnStr
End Property

Public Function CreateStatement(ByVal DbStmtID As String) As DbStatement
    Dim DbStmt As DbStatement
    Set DbStmt = DbStatement.Create(Me, DbStmtID)
    Set this.Statements(DbStmtID) = DbStmt
    Set CreateStatement = DbStmt
End Function

DbStatement

'@Folder "Demo"
'@ModuleDescription "Prepares database queries."
'@PredeclaredId
Option Explicit

Private Type TDbStatement
    DbConn As Variant
    DbStmtID As String
    TimeStamp As Double
    DefaultInstance As Boolean
End Type
Private this As TDbStatement


Public Function Create(ByVal DbConn As DbConnection, ByVal DbStmtID As String) As DbStatement
    Dim Instance As DbStatement
    Set Instance = New DbStatement
    Instance.Init DbConn, DbStmtID
    Set Create = Instance
End Function

Friend Sub Init(ByVal DbConn As DbConnection, ByVal DbStmtID As String)
    this.DbStmtID = DbStmtID
    If ObjectStoreGlobals.ReferenceLoopManagementMode = REF_LOOP_OBJECT_STORE Then
        this.DbConn = ObjectStore.SetRef(DbConn)
    Else
        Set this.DbConn = DbConn
    End If
    this.DefaultInstance = False
    this.TimeStamp = GetEpoch()
End Sub

Private Sub Class_Initialize()
    this.DefaultInstance = True
    Dim InstanceType As String
    InstanceType = IIf(Me Is DbStatement, "Default", "Regular")
    Debug.Print EpochToString(this.TimeStamp) & ": DbStatement /" & _
                InstanceType & " - Class_Initialize"
End Sub

Private Sub Class_Terminate()
    Dim InstanceType As String
    InstanceType = IIf(this.DefaultInstance, "Default", "Regular")
    Debug.Print GetTimeStampMs & ": DbStatement /" & _
                InstanceType & " - Class_Terminate"
End Sub

Friend Sub CleanUp()
    this.DbConn = Empty
End Sub

Public Property Get DbConn() As DbConnection
    If ObjectStoreGlobals.ReferenceLoopManagementMode = REF_LOOP_OBJECT_STORE Then
        Set DbConn = ObjectStore.GetRef(this.DbConn)
    Else
        Set DbConn = this.DbConn
    End If
End Property

The code is available from a GitHub repository and further documentation - from GitHub pages.