File Coverage

blib/lib/Net/LDAP/Class/Group/POSIX.pm
Criterion Covered Total %
statement 54 110 49.0
branch 15 52 28.8
condition 7 30 23.3
subroutine 14 16 87.5
pod 11 11 100.0
total 101 219 46.1


line stmt bran cond sub pod time code
1             package Net::LDAP::Class::Group::POSIX;
2 4     4   1706 use strict;
  4         4  
  4         94  
3 4     4   12 use warnings;
  4         4  
  4         72  
4 4     4   12 use Carp;
  4         4  
  4         192  
5 4     4   14 use base qw( Net::LDAP::Class::Group );
  4         10  
  4         1478  
6              
7             our $VERSION = '0.27';
8              
9             my $RESERVED_GID = 999999; # used when renaming groups
10              
11             # see http://www.ietf.org/rfc/rfc2307.txt
12              
13             =head1 NAME
14              
15             Net::LDAP::Class::Group::POSIX - group class for POSIX LDAP schema
16              
17             =head1 SYNOPSIS
18              
19             # create a subclass for your local LDAP
20             package MyLDAPGroup;
21             use base qw( Net::LDAP::Class::Group::POSIX );
22            
23             __PACKAGE__->metadata->setup(
24             base_dn => 'dc=mycompany,dc=com',
25             attributes => __PACKAGE__->POSIX_attributes,
26             unique_attributes => __PACKAGE__->POSIX_unique_attributes,
27             );
28            
29             1;
30            
31             # then use your class
32             my $ldap = get_and_bind_LDAP_object(); # you write this
33            
34             use MyLDAPGroup;
35             my $group = MyLDAPGroup->new( ldap => $ldap, cn => 'foobar' );
36             $group->read_or_create;
37             for my $user ($group->users) {
38             printf("user %s in group %s\n", $user, $group);
39             }
40              
41             =head1 DESCRIPTION
42              
43             Net::LDAP::Class::Group::POSIX isa Net::LDAP::Class::Group implementing
44             the POSIX LDAP schema.
45              
46             =head1 CLASS METHODS
47              
48             =head2 POSIX_attributes
49              
50             Returns array ref of 'cn', 'gidNumber' and 'memberUid'.
51              
52             =cut
53              
54             sub POSIX_attributes {
55              
56             # these attributes refer to the posixGroup object
57             # which SUPER::read() will refer to.
58             return [
59 2     2 1 70 qw(
60             cn gidNumber memberUid
61             )
62             ];
63              
64             }
65              
66             =head2 POSIX_unique_attributes
67              
68             Returns array ref of 'cn' and 'gidNumber'.
69              
70             =cut
71              
72             sub POSIX_unique_attributes {
73 2     2 1 15 return [qw( cn gidNumber )];
74             }
75              
76             =head1 OBJECT METHODS
77              
78             =head2 read
79              
80             Overrides (and calls) base method to perform additional sanity check
81             that the matching organizational unit exists for the primary posixGroup.
82              
83             =cut
84              
85             sub read {
86 45     45 1 146 my $self = shift;
87 45 50       144 $self->SUPER::read( base_dn => 'ou=Group,' . $self->base_dn, @_ )
88             or return;
89              
90 45         331 my $name = $self->cn;
91              
92             # double check that organizational unit exists too
93 45 50       202 if (!$self->find(
94             base_dn => 'ou=People,' . $self->base_dn,
95             scope => 'sub',
96             filter => "(ou=$name)"
97             )
98             )
99             {
100 0         0 croak
101             "fatal LDAP error: posixGroup $name found but no matching organizational unit";
102             }
103              
104 45         579 return $self;
105             }
106              
107             =head2 action_for_create([ cn => I, gidNumber => I ])
108              
109             Add a group to the database.
110              
111             May be called as a class method with explicit B and B
112             key/value pairs.
113              
114             =cut
115              
116             sub action_for_create {
117 3     3 1 5 my $self = shift;
118 3         5 my %opts = @_;
119 3 50 33     28 my $name = delete $opts{cn} || $self->cn
120             or croak "cn required to create()";
121 3 50 33     16 my $gid = delete $opts{gidNumber} || $self->gidNumber
122             or croak "gidNumber required to create()";
123 3         14 my @actions = (
124              
125             add => [
126              
127             # first the posixGroup
128             { dn => "cn=$name,ou=Group," . $self->base_dn,
129             attr => [
130             objectClass => [ 'top', 'posixGroup' ],
131             cn => $name,
132             gidNumber => $gid,
133             ],
134             },
135              
136             # second the organizational unit
137             { dn => "ou=$name,ou=People," . $self->base_dn,
138             attr => [
139             objectClass => [ 'top', 'organizationalUnit' ],
140             ou => $name
141             ],
142             },
143             ]
144             );
145              
146             # special case of passing in '0' (zero) means do not
147             # create actions for memberUid.
148 3         6 my $memberUid = delete $opts{memberUid};
149 3 50       8 if ( !defined $memberUid ) {
150 3         8 $memberUid = $self->memberUid;
151             }
152 3 50 33     20 if ( defined $memberUid and ref $memberUid and @$memberUid ) {
    50 33        
      33        
      33        
153 0         0 push(
154             @actions,
155             update => {
156             search => [
157             base => "ou=Group," . $self->base_dn,
158             scope => "sub",
159             filter => "(cn=$name)"
160             ],
161             replace => { memberUid => $memberUid },
162             }
163             );
164             }
165             elsif ( defined $memberUid and !ref $memberUid and $memberUid ne '0' ) {
166 0         0 push(
167             @actions,
168             update => {
169             search => [
170             base => "ou=Group," . $self->base_dn,
171             scope => "sub",
172             filter => "(cn=$name)"
173             ],
174             replace => { memberUid => [$memberUid] },
175             }
176             );
177             }
178              
179 3         13 return @actions;
180              
181             }
182              
183             =head2 action_for_update
184              
185             Save new gidNumber (gid) or cn (name) for an existing group.
186              
187             B Because of the POSIX schema layout,
188             renaming a group means creating a new group, moving
189             existing users into it, and deleting the old group. This is handled
190             transparently in action_for_update().
191              
192             =cut
193              
194             sub action_for_update {
195 0     0 1 0 my $self = shift;
196 0         0 my %opts = @_;
197              
198 0 0       0 if ( !grep { exists $self->{_was_set}->{$_} } @{ $self->attributes } ) {
  0         0  
  0         0  
199 0         0 warn "no attributes have changed for group $self. Skipping update().";
200 0         0 return 1;
201             }
202              
203 0         0 my @actions;
204              
205             # change gid alone is easy.
206 0 0 0     0 if ( exists $self->{_was_set}->{gidNumber}
207             and !exists $self->{_was_set}->{cn} )
208             {
209              
210 0         0 push(
211             @actions,
212             update => {
213             search => [
214             base => "ou=Group," . $self->base_dn,
215             scope => "sub",
216             filter => "(cn=" . $self->cn . ")"
217             ],
218             replace => { gidNumber => $self->gidNumber },
219             }
220             );
221              
222             }
223              
224             # changing name, not as easy.
225 0 0       0 if ( exists $self->{_was_set}->{cn} ) {
226              
227 0   0     0 my $class = ref($self) || $self;
228              
229 0         0 my $old_name = $self->{_was_set}->{cn}->{old};
230 0         0 my $new_name = $self->{_was_set}->{cn}->{new};
231 0 0       0 if ( $self->debug ) {
232 0         0 warn "renaming group $old_name to $new_name\n";
233             }
234              
235 0 0       0 my $oldgroup
236             = $class->new( ldap => $self->ldap, cn => $old_name )->read
237             or croak "can't find $old_name in LDAP";
238              
239             my $new_gid
240             = exists $self->{_was_set}->{gidNumber}
241             ? $self->{_was_set}->{gidNumber}->{new}
242 0 0       0 : $self->gidNumber;
243              
244             # LDAP schema requires we rename existing group
245             # because we can't delete a non-leaf entry.
246              
247             # first, change gid of existing group so we don't get conflicts.
248 0         0 push(
249             @actions,
250             update => {
251             search => [
252             base => "ou=Group," . $self->base_dn,
253             scope => "sub",
254             filter => "(cn=$old_name)"
255             ],
256             replace => { gidNumber => $RESERVED_GID },
257             }
258             );
259              
260             # second, create the new group
261 0         0 my $primary_users = $oldgroup->fetch_primary_users;
262 0         0 my $secondary_users = $oldgroup->fetch_secondary_users;
263              
264 0 0       0 if ( $self->debug ) {
265 0         0 warn "rename group for $self primary users: "
266             . join( ", ", @$primary_users );
267 0         0 warn "rename group for $self secondary users: "
268             . join( ", ", @$secondary_users );
269             }
270              
271             my $newgroup = $class->new(
272             ldap => $self->ldap,
273             cn => $new_name,
274             gidNumber => $self->gidNumber,
275 0         0 memberUid => [ map {"$_"} @$secondary_users ],
  0         0  
276             );
277 0         0 push( @actions, $newgroup->action_for_create );
278              
279             # third, update the gid for any users for whom
280             # $old_group is the primary group.
281             # primary users need their gid and dn set in 2 steps
282 0         0 for my $user (@$primary_users) {
283              
284 0         0 my $uid = $user->uid;
285              
286 0         0 push(
287             @actions,
288             update => [
289             { search => [
290             base => "ou=People," . $user->base_dn,
291             scope => "sub",
292             filter => "(uid=$uid)",
293             attrs => $user->attributes,
294             ],
295             replace => { gidNumber => $new_gid }
296             },
297             { dn => {
298             'newrdn' => "uid=$uid",
299             'deleteoldrdn' => 1,
300             'newsuperior' => "ou=$newgroup,ou=People,"
301             . $self->base_dn,
302             },
303             search => [
304             base => "ou=People," . $self->base_dn,
305             scope => "sub",
306             filter => "(uid=$uid)",
307             attrs => $self->attributes,
308             ],
309             }
310             ],
311             );
312              
313             }
314              
315             # fourth and finally, delete the original group
316             push(
317 0         0 @actions,
318             $self->action_for_delete(
319             gidNumber => $RESERVED_GID,
320             cn => $old_name,
321             skip_check => 1,
322             )
323             );
324              
325             }
326              
327 0         0 return @actions;
328             }
329              
330             =head2 action_for_delete( [cn => I] )
331              
332             Returns array ref of actions for removing the organizational unit
333             and the posixGroup.
334              
335             You may call this as a class method with an explicit B key/value
336             pair.
337              
338             =cut
339              
340             sub action_for_delete {
341 0     0 1 0 my $self = shift;
342 0         0 my %opts = @_;
343 0   0     0 my $name = delete $opts{cn} || $self->cn;
344              
345 0 0       0 if ( !$name ) {
346 0         0 croak "cn required to delete a Group";
347             }
348              
349             # even if called a class method, we need an object
350             # in order to find users, etc.
351 0 0       0 my $group = ref($self) ? $self : $self->new( cn => $name )->read;
352 0 0       0 if ( !$group ) {
353 0         0 croak "no such Group to delete: $name";
354             }
355              
356 0 0       0 unless ( $opts{skip_check} ) {
357              
358             # set since users() will require it
359 0         0 $group->cn($name);
360              
361             # clear first so we re-read from the db
362 0         0 $group->clear_primary_users;
363 0         0 $group->clear_secondary_users;
364              
365 0 0       0 if ( scalar @{ $group->users } ) {
  0         0  
366             croak
367             "cannot delete Group $group -- it still has members: [primary] "
368 0         0 . join( ", ", map {"$_"} @{ $group->primary_users } )
  0         0  
369             . " [secondary] "
370 0         0 . join( ", ", map {"$_"} @{ $group->secondary_users } );
  0         0  
  0         0  
371             }
372              
373             }
374              
375 0         0 my @actions = (
376             { search => [
377             base => 'ou=People,' . $group->base_dn,
378             scope => 'sub',
379             filter => "(ou=$name)",
380             attrs => $group->attributes,
381             ],
382             },
383             { search => [
384             base => "ou=Group," . $group->base_dn,
385             scope => "sub",
386             filter => "(cn=$name)",
387             attrs => $group->attributes,
388             ],
389             },
390              
391             );
392              
393 0         0 return ( delete => \@actions );
394             }
395              
396             =head2 fetch_primary_users
397              
398             Required MethodMaker method for retrieving primary_users from LDAP.
399              
400             Returns array or array ref based on context, of related User objects
401             who have this group assigned as their primary group.
402              
403             =cut
404              
405             sub fetch_primary_users {
406 1     1 1 2 my $self = shift;
407 1 50       3 my $user_class = $self->user_class or croak "user_class() required";
408 1         8 my $name = $self->cn;
409 1         6 my @u = $user_class->find(
410             base_dn => "ou=$name,ou=People," . $self->base_dn,
411             scope => "sub",
412             filter => "(objectClass=posixAccount)",
413             ldap => $self->ldap,
414             );
415 1 50       13 return wantarray ? @u : \@u;
416             }
417              
418             =head2 primary_users_iterator
419              
420             Returns Net::LDAP::Class::Iterator for the same query as fetch_primary_users().
421              
422             See the advice in L about iterators
423             versus arrays.
424              
425             =cut
426              
427             sub primary_users_iterator {
428 3     3 1 6 my $self = shift;
429 3 50       9 my $user_class = $self->user_class or croak "user_class required";
430 3   33     28 my $name = $self->cn || $self->read->cn;
431 3         17 return Net::LDAP::Class::Iterator->new(
432             class => $user_class,
433             base_dn => "ou=$name,ou=People," . $self->base_dn,
434             filter => "(objectClass=posixAccount)",
435             ldap => $self->ldap,
436             @_
437             );
438             }
439              
440             =head2 fetch_secondary_users
441              
442             Required MethodMaker method for retrieving secondary_users from LDAP.
443              
444             Returns array or array ref based on context, of related User objects
445             who have this group assigned as a secondary group.
446              
447             Consider using secondary_users_iterator() instead, especially if you
448             have large groups. See L for an explanation.
449             This method is just a wrapper around secondary_users_iterator().
450              
451             =cut
452              
453             # changed to using iterator to avoid surprises for large groups.
454             sub fetch_secondary_users {
455 3     3 1 6 my $self = shift;
456 3         6 my @users;
457 3         36 my $iter = $self->secondary_users_iterator;
458 3         19 while ( my $u = $iter->next ) {
459 1         6 push @users, $u;
460             }
461 3 50       15 return wantarray ? @users : \@users;
462             }
463              
464             =head2 secondary_users_iterator([I])
465              
466             Returns Net::LDAP::Class::SimpleIterator for the same query as
467             fetch_secondary_users().
468              
469             See the advice in L about iterators
470             versus arrays.
471              
472             =cut
473              
474             sub secondary_users_iterator {
475 6     6 1 32 my $self = shift;
476 6 50       21 my $user_class = $self->user_class or croak "user_class required";
477 6 50       55 my $ldap = $self->ldap or croak "ldap required";
478 6         45 $self->read; # make sure we have latest memberUid list
479 6         34 my @uids = $self->memberUid;
480              
481             return Net::LDAP::Class::SimpleIterator->new(
482             code => sub {
483 27 100   27   86 my $uid = shift @uids or return undef;
484 22         110 return $user_class->new( ldap => $ldap, uid => $uid )->read;
485             }
486 6         146 );
487             }
488              
489             =head2 gid
490              
491             Alias for gidNumber() attribute.
492              
493             =cut
494              
495             sub gid {
496 8     8 1 3043 my $self = shift;
497 8         40 $self->gidNumber(@_);
498             }
499              
500             1;
501              
502             __END__