File Coverage

blib/lib/Catalyst/Model/LDAP/Connection.pm
Criterion Covered Total %
statement 36 82 43.9
branch 0 34 0.0
condition 0 7 0.0
subroutine 12 15 80.0
pod 3 3 100.0
total 51 141 36.1


line stmt bran cond sub pod time code
1             package Catalyst::Model::LDAP::Connection;
2             # ABSTRACT: Convenience methods for Net::LDAP
3              
4 5     5   2860 use strict;
  5         15  
  5         121  
5 5     5   25 use warnings;
  5         11  
  5         119  
6 5     5   25 use base qw/Net::LDAP Class::Accessor::Fast/;
  5         8  
  5         2416  
7 5     5   734622 use Carp qw/croak/;
  5         15  
  5         254  
8 5     5   2143 use Catalyst::Model::LDAP::Search;
  5         23  
  5         167  
9 5     5   3000 use Data::Dumper;
  5         37235  
  5         375  
10 5     5   2624 use Data::Page;
  5         14206  
  5         38  
11 5     5   1669 use MRO::Compat;
  5         9228  
  5         152  
12 5     5   36 use Net::LDAP::Constant qw/LDAP_CONTROL_VLVRESPONSE/;
  5         12  
  5         333  
13 5     5   2467 use Net::LDAP::Control::Sort;
  5         10342  
  5         144  
14 5     5   3058 use Net::LDAP::Control::VLV;
  5         5854  
  5         157  
15 5     5   2689 use Net::LDAP::Control::ProxyAuth;
  5         2983  
  5         2953  
16              
17             __PACKAGE__->mk_accessors(qw/base options entry_class/);
18              
19              
20             sub new {
21 0     0 1   my ( $class, %args ) = @_;
22              
23 0           my $base = delete $args{base};
24             my %options =
25 0 0         %{ ref $args{options} eq 'HASH' ? delete $args{options} : {} };
  0            
26             my $entry_class = delete $args{entry_class}
27 0   0       || 'Catalyst::Model::LDAP::Entry';
28              
29 0           my $host = delete $args{host};
30 0           my $self = $class->next::method( $host, %args );
31 0 0         croak "Error connecting to $host: $@" unless $self;
32              
33 0           $self->base($base);
34 0           $self->options( \%options );
35 0           $self->entry_class($entry_class);
36              
37 0           return $self;
38             }
39              
40              
41             sub bind {
42 0     0 1   my ( $self, %args ) = @_;
43              
44 0           delete $args{$_} for qw/host base options connection_class entry_class/;
45              
46             # Bind using TLS if configured
47 0 0         if ( delete $args{start_tls} ) {
48             my $mesg =
49 0 0         $self->start_tls( %{ delete $args{start_tls_options} || {} }, );
  0            
50 0 0         croak 'LDAP TLS error: ' . $mesg->error if $mesg->is_error;
51             }
52              
53             # Bind via DN if configured
54 0           my $dn = delete $args{dn};
55              
56 0 0         $self->next::method( $dn ? ( $dn, %args ) : %args );
57             }
58              
59              
60             sub search {
61 0     0 1   my $self = shift;
62 0 0         my %args = scalar @_ == 1 ? ( filter => shift ) : @_;
63              
64             croak "Cannot use 'page' without 'order_by'"
65 0 0 0       if $args{page} and not $args{order_by};
66              
67             # Use default base
68             %args = (
69             base => $self->base,
70 0 0         %{ $self->options || {} },
  0            
71             %args,
72             );
73              
74             # Allow ProxyAuth by itself
75 0 0         if ( my $authz = delete $args{authz} ) {
76 0           my $authz =
77             Net::LDAP::Control::ProxyAuth->new( authzID => q{dn:} . $authz );
78 0 0         $args{control} = [ @{ $args{control} || [] }, $authz ];
  0            
79             }
80              
81             # Handle server-side sorting
82 0 0         if ( my $order_by = delete $args{order_by} ) {
83 0           my $sort = Net::LDAP::Control::Sort->new( order => $order_by );
84              
85 0 0         $args{control} = [ @{ $args{control} || [] }, $sort ];
  0            
86             }
87              
88 0           my ( $mesg, $pager );
89 0 0         if ( my $page = delete $args{page} ) {
90 0   0       my $rows = delete $args{rows} || 25;
91              
92 0           my $vlv = Net::LDAP::Control::VLV->new(
93             before => 0,
94             after => $rows - 1,
95             content => 0,
96             offset => ( $rows * $page ) - $rows + 1,
97             );
98              
99 0 0         $args{control} = [ @{ $args{control} || [] }, $vlv ];
  0            
100              
101 0           $mesg = $self->next::method(%args);
102 0 0         my @resp = $mesg->control(LDAP_CONTROL_VLVRESPONSE)
103             or croak 'Could not get pager from LDAP response: '
104             . $mesg->server_error;
105 0           $pager = Data::Page->new( $resp[0]->content, $rows, $page );
106             }
107             else {
108 0           $mesg = $self->next::method(%args);
109             }
110              
111 0           bless $mesg, 'Catalyst::Model::LDAP::Search';
112 0           $mesg->init( $self->entry_class );
113              
114 0 0         return ( $pager ? ( $mesg, $pager ) : $mesg );
115             }
116              
117              
118             1;
119              
120             __END__
121              
122             =pod
123              
124             =encoding UTF-8
125              
126             =head1 NAME
127              
128             Catalyst::Model::LDAP::Connection - Convenience methods for Net::LDAP
129              
130             =head1 VERSION
131              
132             version 0.19
133              
134             =head1 DESCRIPTION
135              
136             Subclass of L<Net::LDAP>, which adds paging support and an additional
137             method to rebless the entries. See L<Catalyst::Model::LDAP::Entry>
138             for more information.
139              
140             =head1 OVERRIDING METHODS
141              
142             If you want to override methods provided by L<Net::LDAP>, you can use
143             the C<connection_class> configuration variable. For example:
144              
145             # In lib/MyApp/Model/LDAP.pm
146             package MyApp::Model::LDAP;
147             use base qw/Catalyst::Model::LDAP/;
148              
149             __PACKAGE__->config(
150             # ...
151             connection_class => 'MyApp::LDAP::Connection',
152             );
153              
154             1;
155              
156             # In lib/MyApp/LDAP/Connection.pm
157             package MyApp::LDAP::Connection;
158             use base qw/Catalyst::Model::LDAP::Connection/;
159             use Authen::SASL;
160              
161             sub bind {
162             my ($self, @args) = @_;
163              
164             my $sasl = Authen::SASL->new(...);
165             push @args, sasl => $sasl;
166              
167             $self->SUPER::bind(@args);
168             }
169              
170             1;
171              
172             =head1 METHODS
173              
174             =head2 new
175              
176             Create a new connection to the specific LDAP server.
177              
178             my $conn = Catalyst::Model::LDAP::Connection->new(
179             host => 'ldap.ufl.edu',
180             base => 'ou=People,dc=ufl,dc=edu',
181             );
182              
183             On connection failure, an error is thrown using L<Carp/croak>.
184              
185             =head2 bind
186              
187             Bind to the configured LDAP server using the specified credentials.
188              
189             $conn->bind(
190             dn => 'uid=dwc,ou=People,dc=ufl,dc=edu',
191             password => 'secret',
192             );
193              
194             This method behaves similarly to L<Net::LDAP/bind>, except that it
195             gives an explicit name to the C<dn> parameter. For example, if you
196             need to use SASL to bind to the server, you can specify that in your
197             call:
198              
199             $conn->bind(
200             dn => 'uid=dwc,ou=People,dc=ufl,dc=edu',
201             sasl => Authen::SASL->new(mechanism => 'GSSAPI'),
202             );
203              
204             Additionally, if the C<start_tls> configuration option is present, the
205             client will use L<Net::LDAP/start_tls> to make your connection secure.
206              
207             For more information on customizing the bind process, see
208             L</OVERRIDING METHODS>.
209              
210             =head2 search
211              
212             Search the configured directory using a given filter. For example:
213              
214             my $mesg = $c->model('Person')->search('(cn=Lou Rhodes)');
215             my $entry = $mesg->shift_entry;
216             print $entry->title;
217              
218             This method overrides the C<search> method in L<Net::LDAP> to add
219             paging support. The following additional options are supported:
220              
221             =over 4
222              
223             =item C<raw>
224              
225             Use REGEX to denote the names of attributes that are to be considered binary
226             in search results.
227              
228             When this option is given, Net::LDAP converts all values of attributes B<not>
229             matching this REGEX into Perl UTF-8 strings so that the regular Perl operators
230             (pattern matching, ...) can operate as one expects even on strings with
231             international characters.
232              
233             If this option is not given, attribute values are treated as byte strings.
234              
235             Generally, you'll only ever need to do this if using RFC'd LDAP attributes
236             and not a custom LDAP schema:
237              
238             raw => qr/(?i:^jpegPhoto|;binary)/,
239              
240             =item C<authz>
241              
242             This allows you to use LDAPv3 Proxy Authorization control object, i.e.
243             (L<Net::LDAP::Control::ProxyAuth>):
244              
245             authz => 'uid=gavinhenry,ou=users,dc=surevoip,dc=co,dc=uk',
246              
247             =item C<page>
248              
249             Which page to return.
250              
251             =item C<rows>
252              
253             Rows to return per page. Defaults to 25.
254              
255             =item C<order_by>
256              
257             Sort the records (on the server) by the specified attribute. Required
258             if you use C<page>.
259              
260             =back
261              
262             When paging is active, this method returns the server response and a
263             L<Data::Page> object. Otherwise, it returns the server response only.
264              
265             =head1 SEE ALSO
266              
267             =over 4
268              
269             =item * L<Catalyst::Model::LDAP>
270              
271             =back
272              
273             =head1 AUTHORS
274              
275             =over 4
276              
277             =item * Daniel Westermann-Clark
278              
279             =item * Marcus Ramberg (paging support)
280              
281             =item * Gavin Henry <ghenry@surevoip.co.uk> (authz and raw support, plus bug fixes)
282              
283             =back
284              
285             =head1 LICENSE
286              
287             This library is free software; you can redistribute it and/or modify
288             it under the same terms as Perl itself.
289              
290             =head1 AUTHOR
291              
292             Gavin Henry <ghenry@surevoip.co.uk>
293              
294             =head1 COPYRIGHT AND LICENSE
295              
296             This software is copyright (c) 2017 by Gavin Henry.
297              
298             This is free software; you can redistribute it and/or modify it under
299             the same terms as the Perl 5 programming language system itself.
300              
301             =cut