Here’s how the promise framework is implemented. This is kind of extreme VBA and Excel is very unforgiving. If you are playing around with this, I advise saving often.
cDeferred versus cPromise
sub asyncdata
asyncdata.done(process,"store").fail(process,"error")
end sub
function asyncdata
set defer = new cDeferred
getsomedata(defer)
end function
sub getsomedata(defer)
data = getthedata
if (somerror) then
defer.reject(someerror)
else
defer.resolve(data)
endif
end sub
cDeferred class
- .resolve ( array(data) )
- .reject( array(errorData) )
Option Explicit
' this is vba hack of a jquery $.Deferred()
Private pPromise As cPromise
Private pStatus As Long
' this will be raised when resolved/rejected to coerce promise execution
Public Event completed(data As Variant)
Public Property Get isResolved() As Boolean
isResolved = (pStatus = 1)
End Property
Public Property Get isRejected() As Boolean
isRejected = (pStatus = 2)
End Property
Public Property Get isCompleted() As Boolean
isCompleted = isRejected Or isResolved
End Property
Public Property Get promise() As cPromise
Set promise = pPromise
End Property
Private Function complete(data As Variant) As cDeferred
' the data can be a series of arguments
promise.setData (data)
Set complete = Me
' alert promise we've been completed
RaiseEvent completed(data)
End Function
Public Function resolve(data As Variant) As cDeferred
' all is good - will execite promise.done()
pStatus = 1
Set resolve = complete(data)
End Function
Public Function reject(data As Variant) As cDeferred
' all is bad - will execute promise.fail()
pStatus = 2
Set reject = complete(data)
End Function
Public Sub tearDown(Optional a As Variant)
promise.tearDown
Set pPromise = Nothing
End Sub
Private Sub class_initialize()
Set pPromise = New cPromise
promise.init Me
pStatus = 0
End Sub
cPromise class
- .done (callback As Object, method As String, Optional defer As cDeferred = Nothing, Optional args As Variant)
- .fail (callback As Object, method As String, Optional defer As cDeferred = Nothing, Optional args As Variant)
Option Explicit
' we are going to be alerted by events going on in the parent object
Private WithEvents pDeferred As cDeferred
' these are things to do when completed
Private pSucceeds As Collection
Private pFails As Collection
Private pWhens As Collection
' this is the data that arrives when resolved/rejected
Private pData As Variant
Public Function init(parent As cDeferred) As cPromise
Set pDeferred = parent
Set init = Me
End Function
' data arguments are unknown in quantity/type
Public Function setData(arr As Variant) As cPromise
pData = arr
Set setData = Me
End Function
Public Property Get deferred() As cDeferred
Set deferred = pDeferred
End Property
' retrieve the arguments
Public Function getData() As Variant
getData = pData
End Function
' we are being asked to record an action to take on either success or failure
Private Function queueUp(coll As Collection, _
callback As Object, method As String, _
Optional defer As cDeferred = Nothing, _
Optional args As Variant) As cPromise
Dim cb As cCallback
Set cb = New cCallback
' add to the list of things that need to be done when resolved
coll.add cb.init(callback, method, defer, args)
' do them all in case already resolved
execute
Set queueUp = Me
End Function
' queueUp a failure action
Public Function fail(callback As Object, method As String, _
Optional defer As cDeferred = Nothing, _
Optional args As Variant) As cPromise
Set fail = queueUp(pFails, callback, method, defer, args)
End Function
' queueUp a success action
Public Function done(callback As Object, method As String, _
Optional defer As cDeferred = Nothing, _
Optional args As Variant) As cPromise
Set done = queueUp(pSucceeds, callback, method, defer, args)
End Function
' do anything in the queue
Private Sub execute()
' do the successes
If pDeferred.isResolved Then flush pSucceeds
' and the failures
If pDeferred.isRejected Then flush pFails
' resolve any completed whens
dealWithWhens
End Sub
Private Sub flush(coll As Collection)
Dim cb As cCallback, n As Long, i As Long
' destroy the callback after execution so it only happens once
'
n = coll.Count
For i = 1 To n
Set cb = coll(1)
CallByName cb.callback, cb.method, VbMethod, getData, cb.defer, cb.args
coll.remove (1)
cb.tearDown
Next i
End Sub
Public Property Get whens() As Collection
Set whens = pWhens
End Property
Private Sub class_initialize()
Set pSucceeds = New Collection
Set pFails = New Collection
Set pWhens = New Collection
End Sub
Public Sub tearDown(Optional a As Variant)
Dim act As cCallback
For Each act In pSucceeds
act.tearDown
Next act
Set pSucceeds = Nothing
For Each act In pFails
act.tearDown
Next act
Set pFails = Nothing
Set pDeferred = Nothing
End Sub
Private Sub pDeferred_completed(a As Variant)
' do anything queued
' this event is called when deferred is resolved/rejected
execute
'
End Sub
Private Sub dealWithWhens()
' may be part of some whens
Dim w As cWhen
For Each w In pWhens
w.completed
Next w
End Sub
cWhen class
- when( array(promises,…) ,array(promises,..),…)
All promises is in all arrays need to be resolved or rejected for the promise that is returned by when to get either resolved or rejected. If any promise fails, the promise returned will be rejected. All promises need to be resolved successfully for the when.promise to be resolved. As a convenience, the data associated with the last promise in all arrays is passed to the .done() or .fail() method of when.promise
when returns a cPromise, which means that you can chain .done() or .fail() to a when() function.
Public Function when(ParamArray arr() As Variant) As cPromise
' kind of like jquery $.when()
Dim i As Long, n As Long, combinedPromises As Variant, j As Long
n = 0
' the paramarray is an array of arrays of promises. combining then into one list
For i = LBound(arr) To UBound(arr)
n = n - LBound(arr(i)) + UBound(arr(i)) + 1
Next i
ReDim combinedPromises(0 To n - 1)
n = LBound(combinedPromises)
For i = LBound(arr) To UBound(arr)
For j = LBound(arr(i)) To UBound(arr(i))
Set combinedPromises(n) = arr(i)(j)
n = n + 1
Next j
Next i
' now process a long list of whens
Dim w As cWhen
Set w = New cWhen
Set when = w.when(combinedPromises)
End Function
Option Explicit
Private pDeferred As cDeferred
Private pPromises As Collection
Public Function when(arrayOfPromises As Variant) As cPromise
' we need to listen to each of the promises mention in array
' when all are done we can resolve
Dim i As Long, p As cPromise, d As cDeferred
Set pDeferred = New cDeferred
For i = LBound(arrayOfPromises) To UBound(arrayOfPromises)
' each promise can belong to a collection of whens
Set p = arrayOfPromises(i)
p.whens.add Me
pPromises.add p
Next i
Set when = pDeferred.promise()
End Function
Public Sub completed()
' this will be called as a promise is executed.
' when all in the collection are done. we can resolve this
Dim p As cPromise, f As Long, lp As cPromise
f = 0
For Each p In pPromises
' they all have to be completed
Set lp = p
If (Not p.deferred.isCompleted) Then Exit Sub
If (p.deferred.isRejected) Then f = f + 1
Next p
' all have been done, so resolve or reject it
' what gets passed is the data belongnig to the last promise
If f = 0 Then
pDeferred.resolve (lp.getData)
Else
pDeferred.reject (Array("when rejected with " & f & " failures"))
End If
End Sub
Private Sub class_initialize()
Set pDeferred = New cDeferred
Set pPromises = New Collection
End Sub
Public Function tearDown()
Dim i As Long, p As cPromise, n As Long
pDeferred.tearDown
Set pDeferred = Nothing
n = pPromises.Count
For i = 1 To n
Set p = pPromises(i)
Set p = Nothing
pPromises.remove (1)
Next i
Set pPromises = Nothing
End Function
cDeferredRegister class
- keepInRegister(o As Object, Optional oName As String = vbNullString, Optional oType As String = vbNullString) As Object
This adds an object reference with the given name and type. The name and type are only used for later listing and debugging. Self reference is returned for chaining.
- clearRegister()
Removes all register items and attempts to execute a tearDown class if they have one. Should be called when all aync activity is ended, and as very first call in a fresh session.
- register.list
Can be useful for debugging. It will produce a list like this.
register.list
these items are being kept in memory
248811352 cProcessData
266750400 cEventTimer
266749920 cBackoff
264238376 cHttpDeferredHelper
358537424 cHttpDeferred
schema cJobject
266750592 cEventTimer
266750496 cBackoff
264239816 cHttpDeferredHelper
269075400 cHttpDeferred
One of the trickiest things is to get the arguments right for reject,resolve,done and fail. If you get that wrong, the error will show here in the cPromise() class
Option Explicit
Public register As cDeferredRegister
Public Function keepInRegister(o As Object, Optional oName As String = vbNullString, _
Optional oType As String = vbNullString) As Object
Set keepInRegister = keepSafe(register, o, oName, oType)
End Function
Public Function keepSafe(reg As cDeferredRegister, _
o As Variant, Optional oName As String = vbNullString, _
Optional oType As String = vbNullString) As Object
If register Is Nothing Then Set register = New cDeferredRegister
Set keepSafe = reg.register(o, oName, oType)
End Function
Public Function clearRegister() As cDeferredRegister
If register Is Nothing Then Set register = New cDeferredRegister
register.tearDown
End Function
cDeferredRegister
Option Explicit
' when doing asynchronous things, local variables can go out of scope and be garbage collected
' the purpose of this class is to register an interest in local variables so they dont
' and instance of this class should be declared at module level so it stays in scope when your proc exits
' doing it this way avoids lots of global variables
Private pInterests As Collection
Public Sub list(Optional data As Variant, _
Optional defer As cDeferred, Optional args As Variant)
Dim x As cRegisterItem, i As Long
Debug.Print "these items are being kept in memory"
For i = 1 To pInterests.Count
Set x = pInterests(i)
Debug.Print x.oName, x.oType
Next i
End Sub
Public Sub tearDown(Optional data As Variant, _
Optional defer As cDeferred, Optional args As Variant)
Dim c As Variant, n As Long, i As Long, x As cRegisterItem
n = pInterests.Count
For i = 1 To n
Set x = pInterests(1)
Set c = x.ob
tryToTearDown c
Set c = Nothing
pInterests.remove (1)
Set x = Nothing
Next i
End Sub
Public Function register(o As Variant, Optional oName As String = vbNullString, _
Optional oType As String = "unknown type") As Variant
Dim x As cRegisterItem
Set x = New cRegisterItem
If oName = vbNullString Then
If IsObject(o) Then
oName = CStr(ObjPtr(o))
Else
oName = CStr(ObjPtr(x))
End If
End If
x.init o, oName, oType
pInterests.add x, oName
Set register = x
End Function
Private Function tryToTearDown(c As Variant) As Boolean
' this will try to execute a teardown if it has one
On Error GoTo failed
c.tearDown
tryToTearDown = True
Exit Function
failed:
tryToTearDown = False
End Function
Private Sub class_initialize()
Set pInterests = New Collection
End Sub