File Coverage

blib/lib/Net/LDAP/Class/MethodMaker.pm
Criterion Covered Total %
statement 65 75 86.6
branch 32 44 72.7
condition 7 19 36.8
subroutine 11 12 91.6
pod 3 3 100.0
total 118 153 77.1


line stmt bran cond sub pod time code
1             package Net::LDAP::Class::MethodMaker;
2 10     10   30 use strict;
  10         12  
  10         212  
3 10     10   24 use warnings;
  10         12  
  10         187  
4 10     10   32 use base qw( Rose::Object::MakeMethods::Generic );
  10         60  
  10         4775  
5 10     10   57957 use Carp;
  10         12  
  10         411  
6 10     10   37 use Data::Dump;
  10         14  
  10         6471  
7              
8             our $VERSION = '0.27';
9              
10             =head1 NAME
11              
12             Net::LDAP::Class::MethodMaker - create methods for Net::LDAP::Class classes
13              
14             =head1 SYNOPSIS
15              
16             package MyUser;
17             use base qw( Net::LDAP::Class::User );
18             use Net::LDAP::Class::MethodMaker (
19             'scalar --get_set_init' => [qw( foo )],
20             'related_objects' => [qw( bars )],
21             );
22            
23             __PACKAGE__->metadata->setup(
24             base_dn => 'dc=local',
25             attributes => [qw( foo )],
26             unique_attributes => [qw( foo )],
27             );
28            
29             # must define a fetch_bars method
30             sub fetch_bars {
31             my $user = shift;
32            
33             # do something to get bar objects.
34            
35             }
36              
37             1;
38            
39             # elsewhere
40            
41             my $user = MyUser->new( foo => '1234' )->read or die;
42             $user->foo; # == $user->ldap_entry->get_value('foo');
43             $user->foo(5678); # == $user->ldap_entry->replace( foo => 5678 );
44             $user->foo; # returns '5678'
45            
46             my $bars = $user->bars; # == $user->fetch_bars;
47             push(@$bars, 'new bar');
48             $user->bars($bars);
49             my $newbars = $user->bars; # != $user->fetch_bars;
50             $user->clear_bars;
51             $newbars = $user->bars; # == $user->fetch_bars;
52            
53            
54             =head1 DESCRIPTION
55              
56             Net::LDAP::Class::MethodMaker is a subclass of Rose::Object::MakeMethods::Generic.
57             It extends the base class with two new method types: related_objects and ldap_entry.
58              
59             =head1 METHODS
60              
61             =head2 related_objects( I, I )
62              
63             The related_objects method type creates three methods for each
64             I when using the 'get_set' (default) interface:
65             C, C, and C.
66              
67             The I method must be defined by your class. It should return
68             values from the LDAP server.
69              
70             The I method is a get/set method. If nothing is set, it calls
71             through to I. Otherwise, if you have set something, it returns
72             what you have set.
73              
74             The I method will delete any set value from the object and return it.
75              
76             =cut
77              
78             sub related_objects {
79 32     32 1 2350 my ( $class, $name, $args ) = @_;
80              
81 32         30 my %methods;
82              
83 32   33     114 my $key = $args->{'hash_key'} || $name;
84 32   50     84 my $interface = $args->{'interface'} || 'get_set';
85              
86 32 50       72 if ( $interface eq 'get_set_init' ) {
    50          
87 0         0 croak
88             "get_set_init interface not supported for related_objects: $name";
89             }
90             elsif ( $interface eq 'get_set' ) {
91 32   33     80 my $fetcher_method = $args->{'fetch_method'} || "fetch_$name";
92             $methods{$name} = sub {
93 257 100   257   1054 if ( @_ > 1 ) {
94 97 50       311 if ( !$_[0]->validate( $key, $_[1] ) ) {
95 0         0 croak "validate failed for attribute $key: "
96             . $_[0]->error;
97             }
98 97         275 return $_[0]->{$key} = $_[1];
99             }
100             return exists $_[0]->{$key}
101 160 100       882 ? $_[0]->{$key}
102             : $_[0]->$fetcher_method;
103 32         108 };
104              
105 32     0   84 $methods{"clear_$name"} = sub { return delete $_[0]->{$key} };
  0         0  
106             }
107             else {
108 0         0 croak "Unknown interface: $interface";
109             }
110              
111 32         58 return \%methods;
112             }
113              
114             =head2 ldap_entry
115              
116             The ldap_entry method type supports the 'get_set' interface only.
117              
118             This method type negotiates the getting and setting of values
119             in the delegate ldap_entry() object.
120              
121             =cut
122              
123             # get/set attributes on the delegate ldap_entry
124             sub ldap_entry {
125 132     132 1 2657 my ( $class, $name, $args ) = @_;
126              
127 132 50       783 if ( $class->can($name) ) {
128 0         0 carp "class $class already has method for $name";
129 0         0 return;
130             }
131              
132 132         87 my %methods;
133              
134 132   33     345 my $attribute = $args->{'hash_key'} || $name;
135 132   50     296 my $interface = $args->{'interface'} || 'get_set';
136              
137 132 50       169 if ( $interface eq 'get_set' ) {
138              
139             $methods{$name} = sub {
140 2628     2628   3575 my $self = shift;
141 2628         2719 my @args = @_;
142              
143             # we do not support values of more than one arg
144 2628 50       4319 if ( scalar @args > 1 ) {
145 0         0 croak "cannot set more than one value at a time";
146             }
147              
148             # if we haven't yet loaded a Net::LDAP::Entry via read()
149             # cache the values and set them when/if we read().
150 2628 100       4467 if ( !defined $self->ldap_entry ) {
151              
152 1392 100       1993 if ( scalar @args ) {
153 210         420 $self->{_not_yet_set}->{$attribute} = $args[0];
154             }
155             return
156             exists $self->{_not_yet_set}->{$attribute}
157 1392 100       5560 ? $self->{_not_yet_set}->{$attribute}
158             : undef;
159              
160             }
161              
162             # otherwise, delegate to the ldap_entry
163             #unless ( grep { $_ eq $attribute } @{ $self->attributes } ) {
164             # croak
165             # qq[no such attribute or method "$attribute" defined for package "]
166             # . ref($self)
167             # . qq[ -- do you need to add '$attribute' to your setup() call?"];
168             # }
169              
170 1236 100       6389 if ( scalar @args ) {
171              
172 8 50       39 if ( !$self->validate( $attribute, $args[0] ) ) {
173 0         0 croak "validate failed for attribute $attribute: "
174             . $self->error;
175             }
176              
177             #warn "AUTOLOAD set $attribute -> $args[0]";
178 8         23 my @old = $self->ldap_entry->get_value($attribute);
179 8         98 $self->ldap_entry->replace( $attribute, $args[0] );
180 8         275 $self->{_was_set}->{$attribute}->{new} = $args[0];
181              
182             # do not overwrite an existing 'old' value, since we might need to know
183             # what was originally in the ldap_entry in order to replace it.
184 8 50       25 unless ( exists $self->{_was_set}->{$attribute}->{old} ) {
185             $self->{_was_set}->{$attribute}->{old}
186 8 100       25 = @old > 1 ? \@old : $old[0];
187             }
188             }
189              
190 1236         2337 my (@ret) = ( $self->ldap_entry->get_value($attribute) );
191 1236 100       22158 if (wantarray) {
192 88         419 return @ret;
193             }
194             else {
195 1148 100       4702 return @ret > 1 ? \@ret : $ret[0];
196             }
197 132         546 };
198              
199             }
200             else {
201 0         0 croak "Unknown interface: $interface";
202             }
203              
204 132         228 return \%methods;
205             }
206              
207             =head2 object_or_class_meta
208              
209             Similar to the 'scalar --get-set-init' method type but may be called as a class method,
210             in which case it will call through to the class metadata() object.
211              
212             =cut
213              
214             sub object_or_class_meta {
215 30     30 1 4637 my ( $class, $name, $args ) = @_;
216              
217 30         31 my %methods;
218 30   33     112 my $key = $args->{'hash_key'} || $name;
219 30   33     70 my $init_method = $args->{'init_method'} || "init_$name";
220              
221             $methods{$name} = sub {
222 2040 100   2040   4547 if ( ref( $_[0] ) ) {
223 1999 50       3634 return $_[0]->{$key} = $_[1] if ( @_ > 1 );
224              
225 1999 50       5403 if ( $_[0]->can($init_method) ) {
226             return defined $_[0]->{$key}
227             ? $_[0]->{$key}
228 0 0       0 : ( $_[0]->{$key} = $_[0]->$init_method() );
229             }
230             else {
231             return defined $_[0]->{$key}
232             ? $_[0]->{$key}
233 1999 100       7270 : ( $_[0]->{$key} = $_[0]->metadata->$key );
234             }
235             }
236             else {
237 41         161 return $_[0]->metadata->$key;
238             }
239 30         80 };
240              
241 30         51 return \%methods;
242             }
243              
244             1;
245              
246             __END__