File Coverage

blib/lib/Data/Toolkit/Connector/LDAP.pm
Criterion Covered Total %
statement 50 205 24.3
branch 8 132 6.0
condition 0 9 0.0
subroutine 12 20 60.0
pod 11 11 100.0
total 81 377 21.4


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -w
2             #
3             # Data::Toolkit::Connector::LDAP
4             #
5             # Andrew Findlay
6             # Nov 2006
7             # andrew.findlay@skills-1st.co.uk
8             #
9             # $Id: LDAP.pm 388 2013-08-30 15:19:23Z remotesvn $
10              
11             package Data::Toolkit::Connector::LDAP;
12              
13 1     1   828 use strict;
  1         1  
  1         40  
14 1     1   6 use Carp;
  1         1  
  1         68  
15 1     1   5 use Clone qw(clone);
  1         1  
  1         39  
16 1     1   909 use Net::LDAP::Entry;
  1         160026  
  1         34  
17 1     1   802 use Data::Toolkit::Entry;
  1         5  
  1         34  
18 1     1   8 use Data::Toolkit::Connector;
  1         1  
  1         22  
19 1     1   5 use Data::Dumper;
  1         2  
  1         94  
20              
21             our @ISA = ("Data::Toolkit::Connector");
22              
23             =head1 NAME
24              
25             Data::Toolkit::Connector::LDAP
26              
27             =head1 DESCRIPTION
28              
29             Connector for LDAP directories.
30              
31             =head1 SYNOPSIS
32              
33             $ldapConn = Data::Toolkit::Connector::LDAP->new();
34              
35             $ldap = Net::LDAP->new( 'ldap.example.org' ) or die "$@";
36             $mesg = $ldap->bind;
37              
38             $ldapConn->server( $ldap );
39              
40             $ldapConn->add( $entry );
41              
42             $hashref = $ldapConn->searchparams( { base => "dc=example,dc=org", scope => "sub" } );
43             $hashref = $ldapConn->filterspec( '(sn=Beeblebrox)' );
44              
45             $msg = $ldapConn->search();
46             $msg = $ldapConn->search( $entry );
47              
48             $msg = $ldapConn->delete( $entry );
49              
50              
51              
52             =head1 DEPENDENCIES
53              
54             Carp
55             Clone
56             Net::LDAP
57              
58             =cut
59              
60             ########################################################################
61             # Package globals
62             ########################################################################
63              
64 1     1   6 use vars qw($VERSION);
  1         5  
  1         2722  
65             $VERSION = '1.0';
66              
67             # Set this non-zero for debug logging
68             #
69             my $debug = 0;
70              
71             # BODGE / algorithm choice for updating LDAP
72             my $useLDAPReplace = 1;
73              
74             ########################################################################
75             # Constructors and destructors
76             ########################################################################
77              
78             =head1 Constructor
79              
80             =head2 new
81              
82             my $ldapConn = Data::Toolkit::Connector::LDAP->new();
83              
84             Creates an object of type Data::Toolkit::Connector::LDAP
85              
86             =cut
87              
88             sub new {
89 1     1 1 3 my $class = shift;
90              
91 1         15 my $self = $class->SUPER::new(@_);
92 1         4 bless ($self, $class);
93              
94 1 50       5 carp "Data::Toolkit::Connector::LDAP->new $self" if $debug;
95 1         3 return $self;
96             }
97              
98             sub DESTROY {
99 1     1   531 my $self = shift;
100 1 50       18 carp "Data::Toolkit::Connector::LDAP Destroying $self" if $debug;
101             }
102              
103             ########################################################################
104             # Methods
105             ########################################################################
106              
107             =head1 Methods
108              
109             =cut
110              
111             ########################################
112              
113             =head2 server
114              
115             Define the LDAP server for the connector to use.
116             This should be an object of type Net::LDAP
117              
118             my $res = $csvConn->server( Net::LDAP->new('ldap.example.org') );
119              
120             Returns the object that it is passed.
121              
122             =cut
123              
124             sub server {
125 0     0 1 0 my $self = shift;
126 0         0 my $server = shift;
127              
128 0 0       0 croak "Data::Toolkit::Connector::LDAP->server expects a parameter" if !$server;
129 0 0       0 carp "Data::Toolkit::Connector::LDAP->server $self" if $debug;
130              
131 0         0 return $self->{server} = $server;
132             }
133              
134              
135              
136             ########################################
137              
138             =head2 add
139              
140             Add an entry to the LDAP directory
141              
142             $msg = $ldapConn->add( $entry );
143              
144             Retruns the Net::LDAP::Message object from the add operation.
145              
146             The entry I contain attributes as follows:
147              
148             =over
149              
150             =item _dn
151              
152             The DN of the entry to be created (single value)
153              
154             =item objectClass
155              
156             A list of objectClasses describing the entry
157              
158             =back
159              
160             In addition, the entry must contain all the mandatory attributes for the
161             selected objectClasses.
162             The attribute-value pair used as the RDN must be included.
163              
164             All attributes in the entry whose names do not start with an underscore
165             will be placed in the LDAP entry.
166              
167             =cut
168              
169             sub add {
170 0     0 1 0 my $self = shift;
171 0         0 my $entry = shift;
172              
173 0 0       0 croak "add requires an entry" if !$entry;
174              
175 0         0 my $dn = $entry->get('_dn');
176             # We only want one value here, not an array of them!
177 0 0       0 $dn = $dn->[0] if $dn;
178 0 0       0 croak "add requires a _dn attribute in the entry" if !$dn;
179              
180 0         0 my $oc = $entry->get('objectClass');
181 0 0       0 croak "add requires an objectClass attribute in the entry" if !$oc;
182              
183 0 0       0 carp "Data::Toolkit::Connector::LDAP->add $dn" if $debug;
184              
185 0         0 my $dirEntry = Net::LDAP::Entry->new;
186 0 0       0 confess "Failed to create Net::LDAP::Entry" if !$dirEntry;
187              
188             # Set the DN
189 0         0 $dirEntry->dn($dn);
190              
191             # Work through the attributes in the entry, copying to the dirEntry
192             # where appropriate
193 0         0 my @attributes = $entry->attributes();
194 0         0 while (my $attr = shift @attributes) {
195             # Ignore attributes starting with an underscore
196 0 0       0 next if $attr =~ /^_/;
197             # Add everything else to the LDAP entry if it has a defined value
198 0         0 my @values = $entry->get($attr);
199 0 0       0 print "## Attribute $attr: ", (join ':',@values), "\n" if $debug;
200 0 0       0 $dirEntry->add( $attr => \@values) if defined($values[0]);
201             }
202              
203             # Do the update and return the result
204 0         0 return $dirEntry->update( $self->{server} );
205             }
206              
207              
208             ########################################
209              
210             =head2 delete
211              
212             Delete an entry from the LDAP directory
213              
214             $msg = $ldapConn->delete( $entry );
215              
216             Retruns the Net::LDAP::Message object from the add operation.
217              
218             The entry I contain an attribute called _dn containing a single value:
219             the DN of the LDAP entry that you want to delete.
220              
221             =cut
222              
223             sub delete {
224 0     0 1 0 my $self = shift;
225 0         0 my $entry = shift;
226              
227 0 0       0 croak "delete requires an entry" if !$entry;
228              
229 0         0 my $dn = $entry->get('_dn');
230             # We only want one value here, not an array of them!
231 0 0       0 $dn = $dn->[0] if $dn;
232 0 0       0 croak "delete requires a _dn attribute in the entry" if !$dn;
233              
234 0 0       0 carp "Data::Toolkit::Connector::LDAP->delete $dn" if $debug;
235              
236             # Do the deletion and return the result
237 0         0 return $self->{server}->delete( $dn );
238             }
239              
240              
241              
242             ########################################
243              
244             =head2 searchparams
245              
246             Supply or fetch search parameters
247              
248             $hashref = $ldapConn->searchparams();
249             $hashref = $ldapConn->searchparams( { base => "dc=example,dc=org", scope => "sub" } );
250              
251             =cut
252              
253             sub searchparams {
254 0     0 1 0 my $self = shift;
255 0         0 my $paramhash = shift;
256              
257 0 0       0 carp "Data::Toolkit::Connector::LDAP->searchparams $self $paramhash " if $debug;
258              
259             # No arg supplied - just return existing setting
260 0 0       0 return $self->{searchparams} if (!$paramhash);
261              
262 0 0       0 if ((ref $paramhash) ne 'HASH') {
263 0         0 croak "Data::Toolkit::Connector::LDAP->searchparams expects a hashref argument";
264             }
265              
266             # Store the parameters and return a pointer to them
267 0         0 return $self->{searchparams} = clone( $paramhash );
268             }
269              
270              
271             ########################################
272              
273             =head2 filterspec
274              
275             Supply or fetch filterspec
276              
277             $hashref = $ldapConn->filterspec();
278             $hashref = $ldapConn->filterspec( '(sn=Beeblebrox)' );
279              
280             =cut
281              
282             sub filterspec {
283 0     0 1 0 my $self = shift;
284 0         0 my $filter = shift;
285              
286 0 0       0 carp "Data::Toolkit::Connector::LDAP->filterspec $self $filter " if $debug;
287              
288             # No arg supplied - just return existing setting
289 0 0       0 return $self->{filterspec} if (!$filter);
290              
291             # Store the filter and return it
292 0         0 return $self->{filterspec} = $filter;
293             }
294              
295             ########################################
296              
297             =head2 search
298              
299             Search the LDAP directory.
300             If an entry is supplied, attributes from it may be used in the search.
301              
302             $msg = $ldapConn->search();
303             $msg = $ldapConn->search( $entry );
304              
305             Returns the Net::LDAP::Message object from the search operation.
306              
307             =cut
308              
309             sub search {
310 0     0 1 0 my $self = shift;
311 0         0 my $entry = shift;
312              
313 0 0       0 carp "Data::Toolkit::Connector::LDAP->search $self" if $debug;
314              
315             # Invalidate the current entry
316 0         0 $self->{current} = undef;
317 0         0 $self->{currentLDAP} = undef;
318              
319             # Take copy of search params as we need to modify it
320 0         0 my %searchparams;
321 0 0       0 if ($self->{searchparams}) {
322 0         0 %searchparams = %{ clone( $self->{searchparams} ) };
  0         0  
323             }
324              
325             # Do we need to generate a search string?
326 0 0       0 if ($self->{filterspec}) {
327 0         0 my $filterspec = $self->{filterspec};
328 0         0 my $filter = '';
329 0 0       0 croak "Data::Toolkit::Connector::LDAP->search needs a filterspec" if !$filterspec;
330              
331             # Parameter names are between pairs of % characters
332             # so if the search string has at least two left then there is work to be done
333 0         0 while ($filterspec =~ /%.+%/) {
334 0 0       0 croak "Data::Toolkit::Connector::LDAP->search needs an entry to build the filter from" if !$entry;
335              
336 0         0 my ($left,$name,$right) = ($filterspec =~ /^([^%]*)%([a-zA-Z0-9_]+)%(.*)$/);
337             # Everything before the first % gets added to the filter
338 0         0 $filter .= $left;
339             # Look for the attribute in the entry
340 0         0 my $value = $entry->get($name);
341 0 0       0 $value = $value->[0] if $value;
342 0 0       0 croak "Data::Toolkit::Connector::LDAP->search cannot find value for '$name' to put in search filter" if !$value;
343             # Apply escape convention for LDAP search data
344 0         0 $value =~ s/\\/\\5c/g; # Escape backslashes
345 0         0 $value =~ s/\(/\\28/g; # Escape (
346 0         0 $value =~ s/\)/\\29/g; # Escape )
347 0         0 $value =~ s/\*/\\2a/g; # Escape *
348              
349             # Place the value in the filter
350 0         0 $filter .= $value;
351             # The remainder of the filterspec goes round again
352 0         0 $filterspec = $right;
353             }
354             # Anything left in the filterspec gets appended to the filter
355 0         0 $filter .= $filterspec;
356              
357             # Drop the filter into the local copy of the search params
358 0         0 $searchparams{filter} = $filter;
359             }
360              
361             # Do the search and return the result having stashed a copy internally
362 0         0 return $self->{searchresult} = $self->{server}->search( %searchparams );
363             }
364              
365              
366              
367             ########################################
368              
369             =head2 next
370              
371             Return the next entry from the LDAP search as a Data::Toolkit::Entry object.
372             Optionally apply a map to the LDAP data.
373              
374             Updates the "current" entry (see "current" method description below).
375              
376             my $entry = $ldapConn->next();
377             my $entry = $ldapConn->next( $map );
378              
379             The result is a Data::Toolkit::Entry object if there is data left to be read,
380             otherwise it is undef.
381              
382             =cut
383              
384             sub next {
385 0     0 1 0 my $self = shift;
386 0         0 my $map = shift;
387              
388 0 0       0 carp "Data::Toolkit::Connector::LDAP->next $self" if $debug;
389              
390             # Invalidate the old 'current entry' in case we have to return early
391 0         0 $self->{current} = undef;
392              
393             # Do we have any search results to return?
394 0 0       0 return undef if !$self->{searchresult}; # No search results at all!
395 0 0       0 return undef if !$self->{searchresult}->count(); # No data left to return
396              
397             # Pull out the next LDAP entry
398 0         0 my $ldapEntry = $self->{searchresult}->shift_entry();
399 0 0       0 confess "Expecting to find an entry in LDAP search results!" if !$ldapEntry;
400              
401             # Build an entry
402 0         0 my $entry = Data::Toolkit::Entry->new();
403              
404             # Set the DN
405 0         0 $entry->set( '_dn', [ $ldapEntry->dn() ] );
406              
407             # Now step through the LDAP attributes and assign data to attributes in the entry
408 0         0 my $attrib;
409 0         0 my @attributes = $ldapEntry->attributes();
410              
411 0         0 foreach $attrib (@attributes) {
412 0         0 $entry->set( $attrib, $ldapEntry->get_value( $attrib, asref => 1 ) );
413             }
414              
415             # Save this as the current entry
416 0         0 $self->{current} = $entry;
417 0         0 $self->{currentLDAP} = $ldapEntry;
418              
419             # Do we have a map to apply?
420 0 0       0 if ($map) {
421 0         0 return $entry->map($map);
422             }
423              
424 0         0 return $entry;
425             }
426              
427              
428             ########################################
429              
430             =head2 current
431              
432             Return the current entry in the list of search results as a Data::Toolkit::Entry.
433             The current entry is not defined until the "next" method has been called after a search.
434             Alternatively the current entry can be set by passing a Net::LDAP::Entry
435             object to this method.
436              
437             $entry = $ldapConn->current();
438             $entry = $ldapConn->current( $newEntry );
439              
440             NOTE: if you intend to modify the returned entry you should clone it first,
441             as it is a reference to the connector's copy.
442              
443             =cut
444              
445             sub current {
446 1     1 1 1272 my $self = shift;
447 1         3 my $newCurrent = shift;
448              
449 1 50       6 if ($newCurrent) {
450 1 50       6 croak "Data::Toolkit::Connector::LDAP->current expects a Net::LDAP::Entry"
451             unless $newCurrent->isa("Net::LDAP::Entry");
452 1 50       4 carp "Data::Toolkit::Connector::LDAP->current converting Net::LDAP::Entry" if $debug;
453              
454             # Build an entry
455 1         11 my $entry = Data::Toolkit::Entry->new();
456              
457             # Set the DN
458 1         6 $entry->set( '_dn', [ $newCurrent->dn() ] );
459              
460             # Now step through the LDAP attributes and assign data to attributes in the entry
461 1         14 my $attrib;
462 1         7 my @attributes = $newCurrent->attributes();
463              
464 1         13 foreach $attrib (@attributes) {
465 1         7 $entry->set( $attrib, $newCurrent->get_value( $attrib, asref => 1 ) );
466             }
467              
468 1         13 $self->{current} = $entry;
469 1         4 $self->{currentLDAP} = $newCurrent;
470             }
471              
472 1 50       5 if ($debug) {
473 0         0 my $dn;
474 0         0 my $setting = '';
475 0 0       0 $setting = "setting " if $newCurrent;
476 0 0       0 $dn = $self->{current}->get('_dn') if $self->{current};
477 0         0 carp "Data::Toolkit::Connector::LDAP->current $setting$self DN: $dn";
478             }
479              
480 1         4 return $self->{current};
481             }
482              
483              
484             ########################################
485              
486             =head2 update
487              
488             Update the current LDAP entry using data from a source entry and an optional map.
489             If no map is supplied, all attributes in the source entry are updated in the LDAP entry.
490              
491             If a map I supplied then any attribute listed in the map but not in the
492             source entry will be deleted from the current entry in LDAP.
493              
494             Returns the Net::LDAP::Message result of the LDAP update operation.
495              
496             $msg = $ldapConn->update($sourceEntry);
497             $msg = $ldapConn->update($sourceEntry, $updateMap);
498              
499             =cut
500              
501             sub update {
502 0     0 1 0 my $self = shift;
503 0         0 my $source = shift;
504 0         0 my $map = shift;
505              
506 0 0       0 croak "Data::Toolkit::Connector::LDAP->update called without a source entry" if !$source;
507 0 0       0 croak "Data::Toolkit::Connector::LDAP->update expects a Data::Toolkit::Entry parameter"
508             if !$source->isa('Data::Toolkit::Entry');
509 0 0 0     0 croak "Data::Toolkit::Connector::LDAP->update second parameter should be a Data::Toolkit::Map"
510             if ($map and !$map->isa('Data::Toolkit::Map'));
511              
512 0 0       0 croak "Data::Toolkit::Connector::LDAP->update called without a valid current entry" if !$self->{current};
513              
514 0         0 my $dn = $self->{current}->get('_dn');
515 0 0       0 $dn = $dn->[0] if $dn;
516 0 0       0 carp "Data::Toolkit::Connector::LDAP->update $self DN: $dn" if $debug;
517              
518             # Save a copy of the current entry in case the update fails and we need to reset it
519 0         0 my $currentSave = clone($self->{currentLDAP});
520              
521             # Apply the map if we have one
522 0 0       0 $source = $source->map($map) if $map;
523              
524             # Work out which attributes we are going to deal with
525 0         0 my @attrlist;
526 0 0       0 if ($map) {
527             # We have a map so take the list of attributes from that
528             # This allows us to delete attributes that are not present in the source entry
529 0         0 @attrlist = $map->outputs();
530             }
531             else {
532             # No map supplied so we will only update attributes present in the source entry
533             # i.e. we will not delete any attributes
534 0         0 @attrlist = $source->attributes();
535             }
536              
537             # Step through the list of attributes and compare source with current LDAP entry
538             # Keep track of whether we do any actual changes, and avoid passing null change to LDAP
539             # (need to synthesise an LDAP result message in that case)
540 0         0 my $needUpdate = 0;
541 0         0 foreach my $attr (@attrlist) {
542 0 0       0 print "ATTR: $attr\n" if $debug;
543              
544             # We know that entry objects store attr lists in sorted order so we can use this
545             # to compare them.
546 0         0 my @sourcelist = $source->get($attr);
547 0         0 my @currentlist = $self->{current}->get($attr);
548              
549 0 0       0 if ($useLDAPReplace) {
550             # Delete or replace the whole set of values
551             # Often inefficient, but works even if no equality match is defined in the schema
552              
553             # Delete attribute if no values are wanted
554 0 0 0     0 if (!defined($sourcelist[0]) and defined($currentlist[0])) {
555 0 0       0 print "DELETING $attr\n" if $debug;
556 0         0 $self->{currentLDAP}->delete( $attr );
557 0         0 $needUpdate = 1;
558             }
559              
560             # Replace all values if we have any
561 0 0       0 if (defined($sourcelist[0])) {
562             # Only replace if different attribute count or list
563             # FIXME: this does not honour the attribute comparison rules
564 0         0 my $joinsource = '';
565 0         0 my $joincurrent = '';
566 0 0       0 $joinsource = (join ',',@sourcelist) if defined($sourcelist[0]);
567 0 0       0 $joincurrent = (join ',',@currentlist) if defined($currentlist[0]);
568 0 0       0 if ($joinsource ne $joincurrent) {
569 0 0       0 print "REPLACING $attr: ", (join ',', @sourcelist), "\n" if $debug;
570 0         0 $self->{currentLDAP}->replace( $attr => \@sourcelist );
571 0         0 $needUpdate = 1;
572             }
573             }
574             }
575             else {
576             # FIXME: if the attribute does not have an equality match defined in the schema
577             # then this per-value update scheme will not work.
578             # The 'replace' update will work in those cases but it is inefficient when dealing
579             # with large numbers of values.
580             # Maybe choose based on the size of the 'current' list?
581             # Step through the lists comparing values
582 0         0 my $sourceVal = shift @sourcelist;
583 0         0 my $currentVal = shift @currentlist;
584 0   0     0 while ($sourceVal or $currentVal) {
585             # print "CMP $sourceVal $currentVal\n";
586             # Simple case
587 0 0       0 next if ($source->attrCmp($attr, $sourceVal, $currentVal) == 0);
588              
589             # Values differ or one is empty so we need to modify LDAP
590 0         0 $needUpdate = 1;
591              
592 0 0       0 if ($sourceVal) {
593             # The source value needs adding
594 0 0       0 print "ADD value $sourceVal\n" if $debug;
595 0         0 $self->{currentLDAP}->add( $attr => $sourceVal );
596             }
597              
598 0 0       0 if ($currentVal) {
599             # The current value needs deleting
600 0 0       0 print "DEL value $currentVal\n" if $debug;
601 0         0 $self->{currentLDAP}->delete( $attr => [ $currentVal ] );
602             }
603             }
604             continue {
605             # Get next pair of values
606 0         0 $sourceVal = shift @sourcelist;
607 0         0 $currentVal = shift @currentlist;
608             }
609             }
610             }
611              
612 0 0       0 if ($needUpdate) {
613             # Do the update
614 0         0 my $msg = $self->{currentLDAP}->update( $self->{server} );
615              
616             # Reset currentLDAP if the update failed
617 0 0       0 $self->{currentLDAP} = $currentSave if $msg->is_error();
618              
619             # Return the update message
620 0         0 return $msg;
621             }
622              
623             # Nasty bodge to construct a success message for an operation that we did not
624             # actually do.
625             # FIXME: find a better way to do this.
626             # FIXME: it must support the $msg->is_error() and $msg->code() methods...
627 0         0 my $bodge = clone($self->{searchresult});
628 0         0 $bodge->{parent} = undef;
629 0         0 $bodge->{resultCode} = 0;
630 0         0 $bodge->{errorMessage} = 'Success';
631 0         0 return $bodge;
632             }
633              
634             ########################################################################
635             # Debugging methods
636             ########################################################################
637              
638             =head1 Debugging methods
639              
640             =head2 debug
641              
642             Set and/or get the debug level for Data::Toolkit::Connector
643              
644             my $currentDebugLevel = Data::Toolkit::Connector::LDAP->debug();
645             my $newDebugLevel = Data::Toolkit::Connector::LDAP->debug(1);
646              
647             Any non-zero debug level causes the module to print copious debugging information.
648              
649             Note that this is a package method, not an object method. It should always be
650             called exactly as shown above.
651              
652             All debug information is reported using "carp" from the Carp module, so if
653             you want a full stack backtrace included you can run your program like this:
654              
655             perl -MCarp=verbose myProg
656              
657             =cut
658              
659             # Class method to set and/or get debug level
660             #
661             sub debug {
662 1     1 1 72 my $class = shift;
663 1 50       5 if (ref $class) { croak "Class method 'debug' called as object method" }
  0         0  
664             # print "DEBUG: ", (join '/', @_), "\n";
665 1 50       6 $debug = shift if (@_ == 1);
666 1         10 return $debug
667             }
668              
669              
670             ########################################################################
671             ########################################################################
672              
673             =head1 Author
674              
675             Andrew Findlay
676              
677             Skills 1st Ltd
678              
679             andrew.findlay@skills-1st.co.uk
680              
681             http://www.skills-1st.co.uk/
682              
683             =cut
684              
685             ########################################################################
686             ########################################################################
687             1;