File Coverage

blib/lib/Net/LDAP/Class/User.pm
Criterion Covered Total %
statement 63 72 87.5
branch 11 20 55.0
condition 18 26 69.2
subroutine 11 12 91.6
pod 7 7 100.0
total 110 137 80.2


line stmt bran cond sub pod time code
1             package Net::LDAP::Class::User;
2 8     8   34 use strict;
  8         8  
  8         172  
3 8     8   24 use warnings;
  8         16  
  8         138  
4 8     8   56 use Carp;
  8         6  
  8         338  
5 8     8   36 use base qw( Net::LDAP::Class );
  8         8  
  8         3008  
6             use Net::LDAP::Class::MethodMaker (
7 8         30 'scalar --get_set_init' => [qw( group_class )],
8             'related_objects' => [qw( group groups )],
9 8     8   106 );
  8         10  
10              
11             our $VERSION = '0.27';
12              
13             =head1 NAME
14              
15             Net::LDAP::Class::User - base class for LDAP user objects
16              
17             =head1 SYNOPSIS
18              
19             package MyUser;
20             use strict;
21             use base qw( Net::LDAP::Class::User );
22            
23             # define action_for_* methods for your LDAP schema
24            
25             1;
26              
27             =head1 DESCRIPTION
28              
29             Net::LDAP::Class::User is a simple base class intended to be
30             subclassed by schema-specific Net::LDAP::Class::User::* classes.
31              
32             =head1 METHODS
33              
34             =head2 init
35              
36             Overrides base method to check that group_class() is defined.
37              
38             =cut
39              
40             sub init {
41 392     392 1 31136 my $self = shift;
42 392         1132 $self->SUPER::init(@_);
43 392 50       717 unless ( defined $self->group_class ) {
44 0         0 croak "must define group_class()";
45             }
46 392         2855 return $self;
47             }
48              
49             =head2 add_to_group( I )
50              
51             Adds I via the groups() method. A convenience method.
52              
53             Must call update() to actually write the changes to the LDAP database.
54              
55             =cut
56              
57             sub add_to_group {
58 2     2 1 5 my $self = shift;
59 2 50       8 my $group = shift or croak "Group required";
60 2 50 33     31 if ( !ref($group) or !$group->isa('Net::LDAP::Class::Group') ) {
61 0         0 croak "Group should be a Net::LDAP::Class::Group-derived object";
62             }
63 2 50       8 if ( !$group->ldap_entry ) {
64 0         0 croak "Group should be read() prior to adding User $self as a member";
65             }
66 2         15 my @groups = @{ $self->groups };
  2         9  
67 2         2 my $uniq_method;
68 2         10 for my $g (@groups) {
69 2   33     18 $uniq_method ||= $g->unique_attributes->[0];
70 2 50       6 if ( $g->$uniq_method eq $group->$uniq_method ) {
71 0         0 croak "User $self is already a member of Group $group";
72             }
73             }
74 2         4 push( @groups, $group );
75 2         6 $self->groups( \@groups );
76 2         8 return $self;
77             }
78              
79             =head2 remove_from_group( I )
80              
81             Removes I using the groups() method. A convenience method.
82              
83             Must call update() to actually write the changes to the LDAP database.
84              
85             =cut
86              
87             sub remove_from_group {
88 4     4 1 7 my $self = shift;
89 4 50       13 my $group = shift or croak "Group required";
90 4 50 33     44 if ( !ref($group) or !$group->isa('Net::LDAP::Class::Group') ) {
91 0         0 croak "Group should be a Net::LDAP::Class::Group-derived object";
92             }
93 4 50       12 if ( !$group->ldap_entry ) {
94 0         0 croak
95             "Group should be read() prior to removing User $self as a member";
96             }
97 4         21 my @groups = @{ $self->groups };
  4         11  
98 4         7 my @new;
99             my $uniq_method;
100 4         45 for my $g (@groups) {
101 6   66     31 $uniq_method ||= $g->unique_attributes->[0];
102 6 100       14 if ( $g->$uniq_method eq $group->$uniq_method ) {
103 4         9 next;
104             }
105 2         4 push( @new, $g );
106             }
107 4 50       8 if ( scalar(@new) == scalar(@groups) ) {
108             croak "User $self is not a member of $group and cannot be removed.\n"
109             . "$self is in these groups: "
110 0         0 . join( ", ", map {"$_"} @groups );
  0         0  
111             }
112 4         13 $self->groups( \@new );
113 4         44 return $self;
114             }
115              
116             =head2 init_group_class
117              
118             Default is to croak indicating you must override this method in your subclass.
119              
120             =cut
121              
122             sub init_group_class {
123 0     0 1 0 croak "Must override init_group_class() or set group_class in metadata. "
124             . "Have you created a group subclass yet?";
125             }
126              
127             =head2 stringify
128              
129             Aliased to username().
130              
131             =cut
132              
133 582     582 1 1801 sub stringify { shift->username }
134              
135             =head2 username
136              
137             Get/set the value of the first unique attribute.
138              
139             =cut
140              
141             sub username {
142 797     797 1 1254 my $self = shift;
143 797         1560 my $attr = $self->unique_attributes->[0];
144 797         1816 return $self->$attr(@_);
145             }
146              
147             =head2 random_string([I])
148              
149             Returns a random alphanumeric string of length I (default: 10).
150              
151             =cut
152              
153             # possible characters (omits common mistaken letters Oh and el)
154             my @charset = (
155             'a' .. 'k', 'm' .. 'z', 'A' .. 'N', 'P' .. 'Z', '2' .. '9', '.',
156             ',', '$', '?', '@', '!'
157             );
158              
159             # sanity check for collisions in tight loops
160             my %rand_string_cache;
161              
162             sub random_string {
163 78     78 1 98 my $self = shift;
164 78   100     211 my $len = shift || 10;
165              
166             # set random seed
167 78         319 my ( $usert, $system, $cuser, $csystem ) = times;
168 78         353 srand( ( $$ ^ $usert ^ $system ^ time ) );
169              
170             # select characters
171             # retry until we get at least:
172             # * one UPPER
173             # * one lower
174             # * one \d
175             # * one \W
176              
177 78         76 my @chars;
178 78         104 my $str = '';
179 78   66     201 until ( $str =~ /\d/
      100        
      100        
      100        
180             && $str =~ /[A-Z]/
181             && $str =~ /[a-z]/
182             && $str =~ /\W/
183             && !$rand_string_cache{$str}++ )
184             {
185 981         1259 @chars = ();
186 981         1446 for ( my $i = 0; $i <= ( $len - 1 ); $i++ ) {
187 9810         17500 $chars[$i] = $charset[ int( rand($#charset) + 1 ) ];
188             }
189 981         7367 $str = join( '', @chars );
190             }
191              
192 78         328 return $str;
193             }
194              
195             1;
196              
197             __END__