File Coverage

blib/lib/Net/LDAP/Class/Loader.pm
Criterion Covered Total %
statement 18 53 33.9
branch 0 14 0.0
condition 0 3 0.0
subroutine 6 8 75.0
pod 2 2 100.0
total 26 80 32.5


line stmt bran cond sub pod time code
1             package Net::LDAP::Class::Loader;
2 10     10   65 use strict;
  10         22  
  10         1112  
3 10     10   66 use warnings;
  10         26  
  10         348  
4 10     10   63 use Carp;
  10         16  
  10         919  
5 10     10   62 use Data::Dump qw( dump );
  10         24  
  10         584  
6 10     10   67 use base qw( Rose::Object );
  10         19  
  10         1087  
7             use Net::LDAP::Class::MethodMaker (
8 10     10   7632 scalar => [qw( base_dn ldap object_classes )], );
  10         39  
  10         209  
9              
10             our $VERSION = '0.26';
11              
12             =head1 NAME
13              
14             Net::LDAP::Class::Loader - interrogate an LDAP schema
15              
16             =head1 SYNOPSIS
17              
18             package MyLDAPClass;
19             use strict;
20             use base qw( Net::LDAP::Class );
21            
22             __PACKAGE__->metadata->setup(
23             use_loader => 1,
24             ldap => $ldap,
25             object_classes => [qw( posixAccount )], # optional
26             );
27            
28             1;
29              
30             =head1 DESCRIPTION
31              
32             Net::LDAP::Class:Loader inspects a Net::LDAP::Schema
33             object and determines which attributes are available and which
34             are unique.
35              
36             =head1 METHODS
37              
38             =head2 init
39              
40             Checks that ldap() and object_classes() are defined.
41              
42             =cut
43              
44             sub init {
45 0     0 1   my $self = shift;
46 0           $self->SUPER::init(@_);
47              
48 0 0         if ( !$self->ldap ) {
49 0           croak "must set a Net::LDAP object";
50             }
51              
52 0 0 0       if ( !$self->object_classes or ref( $self->object_classes ) ne 'ARRAY' ) {
53 0           croak "must set an ARRAY ref of object_classes";
54             }
55              
56 0           return $self;
57             }
58              
59             =head2 interrogate
60              
61             Inspects the Net::LDAP::Schema object and returns hashref of C
62             and C.
63              
64             =cut
65              
66             sub interrogate {
67 0     0 1   my $self = shift;
68              
69 0 0         if ( $self->ldap->version < 3 ) {
70 0           croak "LDAP v3 required in order to interrogate the LDAP server";
71             }
72              
73             #dump $self;
74              
75 0           my %OC;
76 0           my $schema = $self->ldap->schema;
77 0           for my $oc ( @{ $self->object_classes } ) {
  0            
78              
79             #warn "interrogating $oc";
80              
81 0           my ( @attributes, @unique );
82              
83 0           for my $may ( $schema->may($oc) ) {
84              
85             #warn "may: " . dump($may);
86 0           push( @attributes, $may->{name} );
87              
88             }
89 0           MUST: for my $must ( $schema->must($oc) ) {
90              
91             #warn "must: " . dump($must);
92 0           my $name = $must->{name};
93 0 0         next MUST if $name eq 'objectClass';
94              
95 0           push( @attributes, $name );
96              
97             # TODO how to speed up fetching only one search result?
98             # or better, how to determine which attributes must be unique.
99 0 0         if ( !@unique ) {
100 0           my $filter = "(&($name=*) (objectClass=$oc))";
101 0           my $res = $self->ldap->search(
102             base => $self->base_dn,
103             scope => 'sub',
104             filter => $filter,
105             sizelimit => 1,
106             );
107              
108 0 0         if ( !$res->count ) {
109             #warn "no match for $filter";
110 0           next MUST;
111             }
112              
113 0           my $entry = $res->pop_entry;
114 0 0         if ($entry) {
115              
116 0           my $dn = $entry->dn;
117 0           my @rdn = split( m/,/, $dn );
118 0           my ( $attr, $val ) = split( m/=/, $rdn[0] );
119 0           push( @unique, $attr );
120              
121             }
122 0           $res->abandon;
123              
124             }
125              
126             }
127              
128 0           $OC{$oc}
129             = { attributes => \@attributes, unique_attributes => \@unique };
130             }
131              
132 0           return \%OC;
133              
134             }
135              
136             =head2 base_dn
137              
138             Get/set the base DN used by interrogate().
139              
140             =head2 ldap
141              
142             Get/set the Net::LDAP object.
143              
144             =head2 object_classes
145              
146             Get/set the array ref of object classes to be used by interrogate().
147              
148             =cut
149              
150             1;
151              
152             __END__