File Coverage

blib/lib/Net/LDAP/Class/Group/AD.pm
Criterion Covered Total %
statement 95 122 77.8
branch 27 56 48.2
condition 13 39 33.3
subroutine 16 17 94.1
pod 12 12 100.0
total 163 246 66.2


line stmt bran cond sub pod time code
1             package Net::LDAP::Class::Group::AD;
2 4     4   1688 use strict;
  4         6  
  4         90  
3 4     4   12 use warnings;
  4         4  
  4         80  
4 4     4   12 use base qw( Net::LDAP::Class::Group );
  4         2  
  4         1402  
5 4     4   16 use Carp;
  4         6  
  4         150  
6 4     4   14 use Data::Dump ();
  4         4  
  4         4016  
7              
8             our $VERSION = '0.27';
9              
10             =head1 NAME
11              
12             Net::LDAP::Class::Group::AD - Active Directory group class
13              
14             =head1 SYNOPSIS
15              
16             # create a subclass for your local Active Directory
17             package MyLDAPGroup;
18             use base qw( Net::LDAP::Class::Group::AD );
19            
20             __PACKAGE__->metadata->setup(
21             base_dn => 'dc=mycompany,dc=com',
22             attributes => __PACKAGE__->AD_attributes,
23             unique_attributes => __PACKAGE__->AD_unique_attributes,
24             );
25            
26             1;
27            
28             # then use your class
29             my $ldap = get_and_bind_LDAP_object(); # you write this
30            
31             use MyLDAPGroup;
32             my $group = MyLDAPGroup->new( ldap => $ldap, cn => 'foobar' );
33             $group->read_or_create;
34             my $users = $group->users_iterator( page_size => 50 );
35             while ( my $user = $users->next ) {
36             printf("user %s in group %s\n", $user, $group);
37             }
38              
39             =head1 DESCRIPTION
40              
41             Net::LDAP::Class::Group::AD isa Net::LDAP::Class::Group implementing
42             the Active Directory LDAP schema.
43              
44             =head1 CLASS METHODS
45              
46             =head2 AD_attributes
47              
48             Returns array ref of a subset of the default Active Directory
49             attributes. Only a subset is used since the default schema contains
50             literally 100s of attributes. The subset was chosen based on its
51             similarity to the POSIX schema.
52              
53             =cut
54              
55             sub AD_attributes {
56 2     2 1 73 [ qw(
57             canonicalName
58             cn
59             description
60             distinguishedName
61             info
62             member
63             primaryGroupToken
64             whenChanged
65             whenCreated
66             objectClass
67             objectSID
68             )
69             ];
70             }
71              
72             =head2 AD_unique_attributes
73              
74             Returns array ref of unique Active Directory attributes.
75              
76             =cut
77              
78             sub AD_unique_attributes {
79 2     2 1 15 [qw( cn objectSID distinguishedName )];
80             }
81              
82             =head1 OBJECT METHODS
83              
84             =head2 fetch_primary_users
85              
86             Required MethodMaker method for retrieving primary_users from LDAP.
87              
88             Returns array or array ref based on context, of related User objects
89             who have this group assigned as their primary group.
90              
91             =cut
92              
93             sub fetch_primary_users {
94 36     36 1 44 my $self = shift;
95 36         120 my $user_class = $self->user_class;
96 36         261 my $pgt = $self->primaryGroupToken;
97 36         183 my @users = $user_class->find(
98             scope => 'sub',
99             filter => "(primaryGroupID=$pgt)",
100             ldap => $self->ldap,
101             base_dn => $self->base_dn,
102             );
103              
104 36 50       182 return wantarray ? @users : \@users;
105             }
106              
107             =head2 primary_users_iterator([I])
108              
109             Returns a Net::LDAP::Class::Iterator object for all the related
110             primary users for the group.
111              
112             This is the same data as primary_users() returns, but is more
113             efficient since it pages the results and only fetches
114             one at a time.
115              
116             =cut
117              
118             sub primary_users_iterator {
119 3     3 1 5 my $self = shift;
120 3 50       11 my $user_class = $self->user_class or croak "user_class required";
121 3   33     30 my $pgt = $self->primaryGroupToken || $self->read->primaryGroupToken;
122 3         11 return Net::LDAP::Class::Iterator->new(
123             class => $user_class,
124             ldap => $self->ldap,
125             base_dn => $self->base_dn,
126             filter => "(primaryGroupID=$pgt)",
127             @_
128             );
129             }
130              
131             =head2 fetch_secondary_users
132              
133             Required MethodMaker method for retrieving secondary_users from LDAP.
134              
135             Returns array or array ref based on context, of related User objects
136             who have this group assigned as a secondary group (memberOf).
137              
138             Consider using secondary_users_iterator() instead, especially if you
139             have large groups. See L for an explanation.
140             This method is just a wrapper around secondary_users_iterator().
141              
142             =cut
143              
144             # changed to using iterator to avoid surprises for large groups.
145             sub fetch_secondary_users {
146 46     46 1 78 my $self = shift;
147 46         61 my @users;
148 46         131 my $iter = $self->secondary_users_iterator;
149 46         352 while ( my $u = $iter->next ) {
150 221         539 push @users, $u;
151             }
152 46 100       208 return wantarray ? @users : \@users;
153             }
154              
155             =head2 secondary_users_iterator([I])
156              
157             Like primary_users_iterator, only for secondary_users.
158              
159             This is the same data as secondary_users() returns, but is more
160             efficient since it pages the results and only fetches
161             one at a time.
162              
163             =cut
164              
165             sub secondary_users_iterator {
166 49     49 1 91 my $self = shift;
167 49   33     146 my $dn = $self->distinguishedName || $self->cn;
168              
169             # escape any parens
170 49         137 $dn =~ s/\(/\\(/g;
171 49         69 $dn =~ s/\)/\\)/g;
172              
173             # there's a subtle bug possible here.
174             # unlike secondary_users, which will croak if there's
175             # a mismatch in the list of members the group claims
176             # and what LDAP actually returns for the $dn value,
177             # this query will silenty miss any users who don't have
178             # memberOf set correctly. I don't *think* it's an issue
179             # since we're looking for memberOf specifically,
180             # rather than parsing the $dn for the user's distinguishedName
181             # but you never know.
182             # The behaviour in secondary_users() is actually more brittle,
183             # as it will point out the problems in parsing the $dn.
184 49         138 return Net::LDAP::Class::Iterator->new(
185             class => $self->user_class,
186             ldap => $self->ldap,
187             base_dn => $self->base_dn,
188             filter => qq{(memberOf=$dn)},
189             @_
190             );
191             }
192              
193             =head2 gid
194              
195             Alias for calling primaryGroupToken() method.
196             Note that primaryGroupToken is dynamically generated
197             by the server and cannot be assigned (set).
198              
199             =cut
200              
201 31     31 1 117 sub gid { shift->primaryGroupToken }
202              
203             =head2 action_for_create([ cn => I ])
204              
205             Add a group to the database.
206              
207             May be called as a class method with explicit B key/value pair.
208              
209             =cut
210              
211             sub action_for_create {
212 5     5 1 5 my $self = shift;
213 5         8 my %opts = @_;
214 5 50 33     34 my $name = delete $opts{cn} || $self->cn
215             or croak "cn required to create()";
216              
217 5         29 my @actions = (
218             add => [
219             { dn => "CN=$name," . $self->base_dn,
220             attr => [
221             objectClass => [ 'top', 'group' ],
222             cn => $name,
223             ],
224             },
225             ]
226             );
227              
228 5         22 return @actions;
229              
230             }
231              
232             =head2 action_for_update
233              
234             Save new cn (name) for an existing group.
235              
236             =cut
237              
238             sub action_for_update {
239 5     5 1 8 my $self = shift;
240 5         10 my %opts = @_;
241              
242 5   33     26 my $base_dn = delete $opts{base_dn} || $self->base_dn;
243              
244 5         7 my @actions;
245              
246             # users get translated to 'member' attribute
247 5 50       16 if ( exists $self->{users} ) {
248              
249 5         10 my @names;
250 5         6 for my $user ( @{ delete $self->{users} } ) {
  5         21  
251 4         10 my $dn = $user->ldap_entry->dn;
252 4         33 push @names, $dn;
253             }
254 5         54 $self->member( \@names ); # should trigger _was_set below
255              
256             }
257              
258             # which fields have changed.
259 5         10 my %replace;
260 5         7 for my $attr ( keys %{ $self->{_was_set} } ) {
  5         16  
261              
262 5 50       17 next if $attr eq 'cn'; # part of DN
263 5 50       13 next if $attr eq 'objectSID'; # set by server
264 5 50       11 next if $attr eq 'primaryGroupToken'; # set by server
265              
266 5         20 my $old = $self->{_was_set}->{$attr}->{old};
267 5         7 my $new = $self->{_was_set}->{$attr}->{new};
268              
269 5 50 66     60 if ( defined($old) and !defined($new) ) {
    100 66        
    50 33        
    50          
270 0         0 $replace{$attr} = undef;
271             }
272             elsif ( !defined($old) and defined($new) ) {
273 2         6 $replace{$attr} = $new;
274             }
275             elsif ( !defined($old) and !defined($new) ) {
276              
277             #$replace{$attr} = undef;
278             }
279             elsif ( $old ne $new ) {
280 3         8 $replace{$attr} = $new;
281             }
282              
283             }
284              
285 5 50       12 if (%replace) {
286 5         18 my $cn = $self->name;
287 5         23 push(
288             @actions,
289             update => {
290             search => [
291             base => $base_dn,
292             scope => "sub",
293             filter => "(cn=$cn)",
294             attrs => $self->attributes,
295             ],
296             replace => \%replace
297             }
298             );
299             }
300              
301 5 50       17 if ( exists $self->{_was_set}->{cn} ) {
302              
303 0   0     0 my $class = ref($self) || $self;
304              
305 0         0 my $old_name = $self->{_was_set}->{cn}->{old};
306 0         0 my $new_name = $self->{_was_set}->{cn}->{new};
307 0 0       0 if ( $self->debug ) {
308 0         0 warn "renaming group $old_name to $new_name\n";
309             }
310              
311 0 0       0 my $oldgroup
312             = $class->new( ldap => $self->ldap, cn => $old_name )->read
313             or croak "can't find $old_name in LDAP";
314              
315             # two steps since cn is part of the dn.
316             # first, create a new group with the new name
317 0         0 push( @actions, $self->action_for_create( cn => $new_name ) );
318              
319             # second, delete the old group.
320 0         0 push( @actions, $self->action_for_delete( cn => $old_name ) );
321              
322             }
323              
324 5 50       11 if ( !@actions ) {
325 0         0 warn "no attributes have changed for group $self. Skipping update().";
326 0         0 return @actions;
327             }
328              
329 5         20 return @actions;
330             }
331              
332             =head2 action_for_delete( [cn => I] )
333              
334             Removes array ref of actions for removing the Group.
335              
336             You may call this as a class method with an explicit B key/value
337             pair.
338              
339             =cut
340              
341             sub action_for_delete {
342 0     0 1 0 my $self = shift;
343 0         0 my %opts = @_;
344 0   0     0 my $name = delete $opts{cn} || $self->cn;
345              
346 0 0       0 if ( !$name ) {
347 0         0 croak "cn required to delete a Group";
348             }
349              
350             # even if called a class method, we need an object
351             # in order to find users, etc.
352 0 0       0 my $group
353             = ref($self)
354             ? $self
355             : $self->new( cn => $name, ldap => $self->ldap )->read;
356 0 0       0 if ( !$group ) {
357 0         0 croak "no such Group to delete: $name";
358             }
359              
360             # TODO update all related Users 'memberOf' ?
361              
362 0         0 my @actions = (
363             { search => [
364             base => $group->base_dn,
365             scope => 'sub',
366             filter => "(cn=$name)",
367             attrs => $group->attributes,
368             ],
369             }
370             );
371              
372 0         0 return ( delete => \@actions );
373             }
374              
375             =head2 add_user( I )
376              
377             Push I onto the list of member() DNs, checking
378             that I is not already on the list.
379              
380             =cut
381              
382             sub add_user {
383 4     4 1 8 my $self = shift;
384 4         5 my $user = shift;
385 4 50 33     16 if ( !$user or !ref($user) or !$user->isa('Net::LDAP::Class::User::AD') )
      33        
386             {
387 0         0 croak "Net::LDAP::Class::User::AD object required";
388             }
389 4 50       16 unless ( $user->username ) {
390 0         0 croak
391             "User object must have at least a username before adding to group $self";
392             }
393 4 100       23 if ( !defined $self->{users} ) {
394 2         10 $self->{users} = $self->secondary_users;
395             }
396 4         8 my @users = @{ $self->{users} };
  4         9  
397 4         22 for my $u (@users) {
398 3 50       7 if ( "$u" eq "$user" ) {
399 0         0 croak "User $user is already a member of group $self";
400             }
401             }
402 4         8 push( @users, $user );
403 4         15 $self->{users} = \@users;
404             }
405              
406             =head2 remove_user( I )
407              
408             Drop I from the list of member() DNs, checking
409             that I is already on the list.
410              
411             =cut
412              
413             sub remove_user {
414 5     5 1 24 my $self = shift;
415 5         6 my $user = shift;
416 5 50 33     13 if ( !$user or !ref($user) or !$user->isa('Net::LDAP::Class::User::AD') )
      33        
417             {
418 0         0 croak "Net::LDAP::Class::User::AD object required";
419             }
420 5 50       14 unless ( $user->username ) {
421 0         0 croak
422             "User object must have at least a username before removing from group $self";
423             }
424 5 100       17 if ( !defined $self->{users} ) {
425 3         12 $self->{users} = $self->secondary_users;
426             }
427 5         9 my %users = map { $_->username => $_ } @{ $self->{users} };
  8         18  
  5         11  
428 5 50       13 if ( !exists $users{ $user->username } ) {
429 0         0 croak "User $user is not a member of group $self";
430             }
431 5         11 delete $users{ $user->username };
432 5         25 $self->{users} = [ values %users ];
433             }
434              
435             1;
436              
437             __END__