Class ACLRoleResolver
Private ndbNAB As NotesDatabase
Private acl As NotesACL
Private blnIsOnServer As Boolean
Private strStackTrc As String
Private strNameArray() As String

Public Property Get CLASSNAME As String
CLASSNAME = {"ACLRoleResolver" class}
End Property

Public Property Get NAB_REPLICA_ID As String
NAB_REPLICA_ID = "852563DB00636E94"
End Property

Public Property Get CRLF As String
CRLF = {
}
End Property

Public Property Get LOAD_FACTOR As Integer
LOAD_FACTOR = 16
End Property

Public Property Get StackTrace As String
StackTrace$ = Me.strStackTrc$
End Property

Sub New(paclTarget As NotesACL)
Const ERR_NAB_AXS_FAILURE = 7042

Set Me.acl = paclTarget
Set Me.ndbNAB = New NotesDatabase("", "")
If Not(ndbNAB.OpenByReplicaID(Me.acl.Parent.Server, Me.NAB_REPLICA_ID)) Then
Error ERR_NAB_AXS_FAILURE, {Failed to access the Public Name & Address Book by replica id}
End If

Me.blnIsOnServer = Me.ndbNAB.Parent.IsOnServer
End Sub

Sub Delete()
On Error Resume Next
'// explicitly release all instance variables
Set Me.ndbNAB = Nothing
Set Me.acl = Nothing
Me.strStackTrc$ = ""
Erase Me.strNameArray
End Sub

Public Function ResolveRoleHolders(Byval pstrRole As String, pvarNamesOut As Variant) As Boolean
On Error Goto errorThrower

Const DEFAULT_ENTRY = "-DEFAULT-"
Dim aclEntry As NotesACLEntry
Dim viewGroups As NotesView
Dim intCount As Integer
Dim strEntryName As String
Dim varNames As Variant

ResolveRoleHolders = False

'// Get the role into the expected format of "[Role name]"
If Not(pstrRole$ Like "[[]*[]]") Then
pstrRole$ = "[" & pstrRole$ & "]"
End If

'// Role doesn't exist in the ACL of the target database
If Isnull(Arraygetindex(Me.acl.Roles, pstrRole$, 5)) Then
Goto thisExit
End If

If Not(Me.blnIsOnServer) Then
Set viewGroups = Me.ndbNAB.GetView("($VIMGroups)")
End If

'// Size an array to the default size
Redim Me.strNameArray(0 To Me.LOAD_FACTOR - 1) As String

intCount% = -1
Set aclEntry = Me.acl.GetFirstEntry()
Do
If aclEntry.IsRoleEnabled(pstrRole$) Then
strEntryName$ = aclEntry.Name
Select Case True
Case aclEntry.IsGroup '// group entry
If Me.blnIsOnServer Then
Call Me.expandGroupNames(strEntryName$, varNames)
Else
varNames = Me.getGroupMembers(viewGroups, strEntryName$)
End If

Forall uName In varNames
If Me.addName(intCount%, Cstr(uName)) Then
intCount% = intCount% + 1
End If
End Forall
Case Left(strEntryName$, 1) = "*" '// wildcard entry
If Me.expandWildcard(strEntryName$, varNames) Then
Forall uName In varNames
If Me.addName(intCount%, Cstr(uName)) Then
intCount% = intCount% + 1
End If
End Forall
End If
Case Strcompare(strEntryName$, DEFAULT_ENTRY, 5) = 0 '// default
Me.strNameArray(0) = DEFAULT_ENTRY '// if role is enabled for default access, don't record names
intCount% = 0
Exit Do
Case Else
If Me.addName(intCount%, strEntryName$) Then
intCount% = intCount% + 1
End If
End Select
End If
Set aclEntry = Me.acl.GetNextEntry(aclEntry)
Loop Until aclEntry Is Nothing

If intCount% > -1 Then
Redim Preserve Me.strNameArray(0 To intCount%) As String '// resize the array to eliminate empties
pvarNamesOut = Me.strNameArray '// write results
Call Me.shellSort(pvarNamesOut) '// sort results
ResolveRoleHolders = True
End If

thisExit:
Exit Function

errorThrower:
Call Me.buildStackTrace(Erl, Getthreadinfo(1))
Error Err, Error$
End Function

Private Function addName(Byval pintIndex As Integer, pstrName As String) As Boolean
On Error Goto errorThrower

Dim intSize As Integer

addName = False
pintIndex% = pintIndex% + 1
intSize% = Ubound(Me.strNameArray)
If pintIndex% > intSize% Then
intSize% = intSize% + Me.LOAD_FACTOR
Redim Preserve Me.strNameArray(0 To intSize%) As String
End If

If Isnull(Arraygetindex(Me.strNameArray, pstrName$, 5)) Then
Me.strNameArray(pintIndex%) = pstrName$
addName = True
End If

thisExit:
Exit Function

errorThrower:
Call Me.buildStackTrace(Erl, Getthreadinfo(1))
Error Err, Error$
End Function

Private Function expandGroupNames(pstrGroupName As String, pvarMemberNamesOut As Variant) As Boolean
On Error Goto errorThrower

expandGroupNames = False
If Len(Trim$(pstrGroupName$)) = 0 Then
Goto thisExit '// if no name is passed, don't even try to resolve the group name
End If

pvarMemberNamesOut = Evaluate({@ExpandNameList(@DbName; "} & pstrGroupName$ & {")})
pvarMemberNamesOut = Arrayunique(pvarMemberNamesOut, 5)
If Ubound(pvarMemberNamesOut) = 0 Then '// if there's only one group member, check to see if it's valid
If Strcompare(pvarMemberNamesOut(0), pstrGroupName$, 5) = 0 Then
Goto thisExit '// if the only group member found is the group name itself, the group name passed couldn't be resolved
End If
End If
expandGroupNames = True

thisExit:
Exit Function

errorThrower:
Call Me.buildStackTrace(Erl, Getthreadinfo(1))
Error Err, Error$
End Function

Private Function getGroupMembers(pviewGroups As NotesView, pstrGroupName As String) As Variant
On Error Goto errorThrower
Dim docGroup As NotesDocument
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim intChildUBound As Integer
Dim varParentMembers As Variant
Dim varChildMembers As Variant
Dim varMemberArray() As Variant

Set docGroup = pviewGroups.GetDocumentByKey(pstrGroupName$, True)
j = 0

If Not(docGroup Is Nothing) Then
Redim varMemberArray(0 To 1) As Variant
varParentMembers = docGroup.GetItemValue("Members")
For i = Lbound(varParentMembers) To Ubound(varParentMembers)
varChildMembers = Me.getGroupMembers(pviewGroups, varParentMembers(i))
intChildUBound% = Ubound(varChildMembers)
Redim Preserve varMemberArray(0 To (intChildUBound% + j)) As Variant
For k = Lbound(varChildMembers) To intChildUBound%
varMemberArray(j) = varChildMembers(k)
j = j + 1
Next k
Next i
Else
Redim varMemberArray(0) As Variant
varMemberArray(0) = pstrGroupName$
End If

getGroupMembers = varMemberArray

thisExit:
Exit Function

errorThrower:
Call Me.buildStackTrace(Erl, Getthreadinfo(1))
Error Err, Error$
End Function


Private Function expandWildcard(Byval pstrEntryName As String, pvarNamesOut As Variant) As Boolean
On Error Goto errorThrower

Dim dclxn As NotesDocumentCollection
Dim doc As NotesDocument
Dim i As Integer
Dim intRezCount As Integer
Dim strSrchVal As String
Dim strNameArray() As String

expandWildcard = False
pstrEntryName$ = Strright(pstrEntryName$, "*/")
strSrchVal$ = {(Type = "Person") & (@Contains(@Name([HIERARCHYONLY]; FullName[1]); "} & pstrEntryName$ & {"))}

Set dclxn = Me.ndbNAB.Search(strSrchVal$, Nothing, 0)
intRezCount% = dclxn.Count
If intRezCount% > 0 Then
Redim strNameArray(0 To intRezCount%) As String
Set doc = dclxn.GetFirstDocument()
For i = 1 To dclxn.Count
strNameArray(i) = doc.GetItemValue("FullName")(0)
Set doc = dclxn.GetNextDocument(doc)
Next i

pvarNamesOut = strNameArray
expandWildcard = True
End If

thisExit:
Exit Function

errorThrower:
Call Me.buildStackTrace(Erl, Getthreadinfo(1))
Error Err, Error$
End Function

Private Sub shellSort(pvarArray As Variant)
Dim intStep As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim n As Integer
Dim varSave As Variant

n = Ubound(pvarArray) + 1
While (intStep% < (n / 9))
intStep% = 3 * intStep% + 1
Wend

Do
k = 0
Do While k <= intStep% - 1
i = k + intStep%
Do While i <= n - 1
varSave = pvarArray(i)
j = i - intStep%
If j < 0 Then
j = 0
End If

Do While j >= k And pvarArray(j) > varSave
pvarArray(j + intStep%) = pvarArray(j)
j = j - intStep%
If j < 0 Then
Exit Do
End If
Loop
pvarArray(j + intStep%) = varSave
i = i + intStep%
Loop
k = k + 1
Loop
intStep% = intStep% / 3
Loop While Not(intStep% = 0)
End Sub

Private Sub buildStackTrace(pintLineNo As Integer, pstrCodeElement As String)
Me.strStackTrc$ = Me.strStackTrc$ & Me.CRLF & pstrCodeElement$ & ": " & pintLineNo%
End Sub
End Class

CLASS_NAME
Return value: String constant, name of this class (mostly for use in error handling).

NAB_REPLICA_ID
Return value: String constant, the replica id of the public name and addressbook to be used for resolving group membership.

CRLF
Return value: String constant, carriage return and line feed characters.

LOAD_FACTOR
Return value: Integer constant, the factor by which internal arrays will grow.

StackTrace
Return value: String, a record of calls on the stack in the event of an internal error.

New(paclTarget As NotesACL)
Description: class constructor
Parameters:
paclTarget - NotesACL, source access control list from which to obtain roles and names for the current instance

Sub Delete()
Description: class destructor, executes by default when a given instance of the class is dereferenced
Parameters:
none

Function ResolveRoleHolders(Byval pstrRole As String, pvarNamesOut As Variant) As String
Description: attempts to resolve individual names that possess the role specified via the public name and addressbook
Parameters:
pstrRole - String, (Byval) the role for which names are to be resolved (brackets are not required).
pvarNamesOut - Variant, receives the individual names of those found to possess the role specified

Return:
Boolean, true if the role specified can be resolved successfully, otherwise, false.

Function addName(Byval pintIndex As Integer, pstrName As String) As Boolean
Description: logically determines whether or not the name specified should be added to the current array of names.
Parameters:
pintIndex - Integer, (Byval) the delimiter to be used for concatenation
pstrName - String, the name to be added

Return:
Boolean, true if name is added to the current array of names, otherwise, false.

Function expandGroupNames(pstrGroupName As String, pvarMemberNamesOut As Variant) As Boolean
Description: attempts to expand the group name specified by evaluating the currently undocumented @Function, @ExpandNameList. This is only used for server-based operations.
Parameters:
pstrGroupName - String, the group name to be expanded into its complete list of individual members
pvarMemberNamesOut - Variant, receives the individual member names for the group specified

Return:
Boolean, true if the group name can be successfully expanded, otherwise, false.

Function getGroupMembers(pviewGroups As NotesView, pstrGroupName As String) As Variant
Description: attempts to expand the group name specified by way of the view passed. This is only used for client-based operations.
Parameters:
pviewGroups - NotesView, view in the public name and addressbook from which group membership is to be resolved
pstrGroupName - String, the group name for which to resolve group membership

Return:
Variant, a String array containing the name(s) of the individual members of the group specified

Function expandWildcard(Byval pstrEntryName As String, pvarNamesOut As Variant) As Boolean
Description: attempts to expand the individual names of the wildcard entry name specified (e.g., "*/finance/acme") into individual names represented by the wildcard entry.
Parameters:
pstrEntryName - String, (Byval) the wildcard entry from which to obtain individual names
pvarNamesOut - Variant, receives a String array containing the individual names represented by the wildcard entry specified

Return:
Boolean, true if the wildcard entry can be successfully expanded, otherwise, false.

Sub shellSort(pvarArray As Variant)
Description: sorts the variant array passed using a Shell sorting algorithm.
Parameters:
pvarArray - Variant, array of values to be sorted

Sub buildStackTrace(pintLineNo As Integer, pstrCodeElement As String)
Description: builds a stacktrace so that details of errors encountered in the class are accessible outside of the class.
Parameters:
pintLineNo - Integer, the line in the calling method at which the error was encountered
pstrCodeElement - String, the name of the calling method in which an error was encountered

On Error Goto errorHandler

Const DB_REPLICAID = "A VALID REPLICA ID"
Dim nsess As NotesSession
Dim ndbTarget As NotesDatabase
Dim roleResolver As ACLRoleResolver
Dim dblStartTime As Double
Dim strRole As String
Dim varNames As Variant

dblStartTime# = Timer()
Set nsess = New NotesSession()
Set ndbTarget = New NotesDatabase("", "")
If Not(ndbTarget.OpenByReplicaID(nsess.CurrentDatabase.Server, DB_REPLICAID)) Then
Msgbox "Oops - couldn't open the database by replica id.", , "Could open database . . ."
Goto subExit
End If

Set roleResolver = New ACLRoleResolver(ndbTarget.ACL)
strRole$ = "SomeRoleName"
If roleResolver.ResolveRoleHolders(strRole$, varNames) Then
Print "Operation completed in " & Format(Timer() - dblStartTime#, "0.000") & " seconds . . ."
Msgbox {The following } & (Ubound(varNames) + 1) & { users have the "} & strRole$ & {" role in the "} & ndbTarget.Title & {" database:} & Chr(13) & Join(varNames, Chr(13)), , "Results . . ."
Else
Msgbox {Failed to resolve users having the "} & strRole$ & {" role in the "} & ndbTarget.Title & {" database.}, , "Results . . ."
End If

Set roleResolver = Nothing
Exit Sub

Select Case True
Case roleResolver Is Nothing, Len(roleResolver.StackTrace) = 0
Msgbox "Error " & Err & ": " & Error$ & " at line " & Erl & " of " & Getthreadinfo(1) & ".", , "Error encountered . . ."
Print "Error " & Err & ": " & Error$ & " encountered at line " & Erl & " of " & Getthreadinfo(1) & " . . ."
Case Else
Msgbox "Error " & Err & ": " & Error$ & " at line " & Erl & " of " & Getthreadinfo(1) & String(2, 13) & "Stack trace:" & Chr(13) & roleResolver.StackTrace, , "Error encountered . . ."
Print "Error " & Err & ": " & Error$ & " encountered at line " & Erl & " of " & Getthreadinfo(1) & " . . ."
End Select
Resume subExit