← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 11:58:52 2013
Reported on Tue Oct 15 12:01:37 2013

Filename/usr/share/perl5/Net/LDAP.pm
StatementsExecuted 43 statements in 6.85ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1117.86ms19.8msNet::LDAP::::BEGIN@8Net::LDAP::BEGIN@8
1113.03ms17.7msNet::LDAP::::BEGIN@12Net::LDAP::BEGIN@12
1112.12ms2.49msNet::LDAP::::BEGIN@9Net::LDAP::BEGIN@9
1111.87ms115msNet::LDAP::::BEGIN@13Net::LDAP::BEGIN@13
11134µs45µsNet::LDAP::::BEGIN@7Net::LDAP::BEGIN@7
11130µs35µsNet::LDAP::::importNet::LDAP::import
11123µs23µsNet::LDAP::::BEGIN@10Net::LDAP::BEGIN@10
11120µs138µsNet::LDAP::::BEGIN@11Net::LDAP::BEGIN@11
11113µs146µsNet::LDAP::::BEGIN@15Net::LDAP::BEGIN@15
11110µs36µsNet::LDAP::::BEGIN@14Net::LDAP::BEGIN@14
0000s0sNet::LDAP::::DESTROYNet::LDAP::DESTROY
0000s0sNet::LDAP::::TIEHASHNet::LDAP::TIEHASH
0000s0sNet::LDAP::::_SSL_context_init_argsNet::LDAP::_SSL_context_init_args
0000s0sNet::LDAP::::__ANON__[:84]Net::LDAP::__ANON__[:84]
0000s0sNet::LDAP::::__ANON__[:85]Net::LDAP::__ANON__[:85]
0000s0sNet::LDAP::::__ANON__[:86]Net::LDAP::__ANON__[:86]
0000s0sNet::LDAP::::_dn_optionsNet::LDAP::_dn_options
0000s0sNet::LDAP::::_drop_connNet::LDAP::_drop_conn
0000s0sNet::LDAP::::_err_msgNet::LDAP::_err_msg
0000s0sNet::LDAP::::_errorNet::LDAP::_error
0000s0sNet::LDAP::::_forgetmesgNet::LDAP::_forgetmesg
0000s0sNet::LDAP::::_optionsNet::LDAP::_options
0000s0sNet::LDAP::::_sendmesgNet::LDAP::_sendmesg
0000s0sNet::LDAP::::abandonNet::LDAP::abandon
0000s0sNet::LDAP::::addNet::LDAP::add
0000s0sNet::LDAP::::asyncNet::LDAP::async
0000s0sNet::LDAP::::bindNet::LDAP::bind
0000s0sNet::LDAP::::certificateNet::LDAP::certificate
0000s0sNet::LDAP::::cipherNet::LDAP::cipher
0000s0sNet::LDAP::::compareNet::LDAP::compare
0000s0sNet::LDAP::::connect_ldapNet::LDAP::connect_ldap
0000s0sNet::LDAP::::connect_ldapiNet::LDAP::connect_ldapi
0000s0sNet::LDAP::::connect_ldapsNet::LDAP::connect_ldaps
0000s0sNet::LDAP::::debugNet::LDAP::debug
0000s0sNet::LDAP::::deleteNet::LDAP::delete
0000s0sNet::LDAP::::disconnectNet::LDAP::disconnect
0000s0sNet::LDAP::::extensionNet::LDAP::extension
0000s0sNet::LDAP::::hostNet::LDAP::host
0000s0sNet::LDAP::::innerNet::LDAP::inner
0000s0sNet::LDAP::::ldapbindNet::LDAP::ldapbind
0000s0sNet::LDAP::::messageNet::LDAP::message
0000s0sNet::LDAP::::moddnNet::LDAP::moddn
0000s0sNet::LDAP::::modifyNet::LDAP::modify
0000s0sNet::LDAP::::modrdnNet::LDAP::modrdn
0000s0sNet::LDAP::::newNet::LDAP::new
0000s0sNet::LDAP::::outerNet::LDAP::outer
0000s0sNet::LDAP::::portNet::LDAP::port
0000s0sNet::LDAP::::processNet::LDAP::process
0000s0sNet::LDAP::::root_dseNet::LDAP::root_dse
0000s0sNet::LDAP::::schemaNet::LDAP::schema
0000s0sNet::LDAP::::schemeNet::LDAP::scheme
0000s0sNet::LDAP::::searchNet::LDAP::search
0000s0sNet::LDAP::::socketNet::LDAP::socket
0000s0sNet::LDAP::::start_tlsNet::LDAP::start_tls
0000s0sNet::LDAP::::syncNet::LDAP::sync
0000s0sNet::LDAP::::unbindNet::LDAP::unbind
0000s0sNet::LDAP::::uriNet::LDAP::uri
0000s0sNet::LDAP::::versionNet::LDAP::version
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1# Copyright (c) 1997-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
2# This program is free software; you can redistribute it and/or
3# modify it under the same terms as Perl itself.
4
5package Net::LDAP;
6
7357µs256µs
# spent 45µs (34+11) within Net::LDAP::BEGIN@7 which was called: # once (34µs+11µs) by C4::Auth_with_ldap::BEGIN@31 at line 7
use strict;
# spent 45µs making 1 call to Net::LDAP::BEGIN@7 # spent 11µs making 1 call to strict::import
83328µs221.5ms
# spent 19.8ms (7.86+11.9) within Net::LDAP::BEGIN@8 which was called: # once (7.86ms+11.9ms) by C4::Auth_with_ldap::BEGIN@31 at line 8
use IO::Socket;
# spent 19.8ms making 1 call to Net::LDAP::BEGIN@8 # spent 1.65ms making 1 call to IO::Socket::import
93286µs22.57ms
# spent 2.49ms (2.12+372µs) within Net::LDAP::BEGIN@9 which was called: # once (2.12ms+372µs) by C4::Auth_with_ldap::BEGIN@31 at line 9
use IO::Select;
# spent 2.49ms making 1 call to Net::LDAP::BEGIN@9 # spent 76µs making 1 call to Exporter::import
10374µs123µs
# spent 23µs within Net::LDAP::BEGIN@10 which was called: # once (23µs+0s) by C4::Auth_with_ldap::BEGIN@31 at line 10
use Tie::Hash;
# spent 23µs making 1 call to Net::LDAP::BEGIN@10
11362µs2257µs
# spent 138µs (20+119) within Net::LDAP::BEGIN@11 which was called: # once (20µs+119µs) by C4::Auth_with_ldap::BEGIN@31 at line 11
use vars qw($VERSION $LDAP_VERSION @ISA);
# spent 138µs making 1 call to Net::LDAP::BEGIN@11 # spent 119µs making 1 call to vars::import
123242µs217.8ms
# spent 17.7ms (3.03+14.7) within Net::LDAP::BEGIN@12 which was called: # once (3.03ms+14.7ms) by C4::Auth_with_ldap::BEGIN@31 at line 12
use Convert::ASN1 qw(asn_read);
# spent 17.7ms making 1 call to Net::LDAP::BEGIN@12 # spent 58µs making 1 call to Exporter::import
133177µs1115ms
# spent 115ms (1.87+113) within Net::LDAP::BEGIN@13 which was called: # once (1.87ms+113ms) by C4::Auth_with_ldap::BEGIN@31 at line 13
use Net::LDAP::Message;
# spent 115ms making 1 call to Net::LDAP::BEGIN@13
14346µs261µs
# spent 36µs (10+26) within Net::LDAP::BEGIN@14 which was called: # once (10µs+26µs) by C4::Auth_with_ldap::BEGIN@31 at line 14
use Net::LDAP::ASN qw(LDAPResponse);
# spent 36µs making 1 call to Net::LDAP::BEGIN@14 # spent 26µs making 1 call to Net::LDAP::ASN::import
151134µs
# spent 146µs (13+134) within Net::LDAP::BEGIN@15 which was called: # once (13µs+134µs) by C4::Auth_with_ldap::BEGIN@31 at line 29
use Net::LDAP::Constant qw(LDAP_SUCCESS
# spent 134µs making 1 call to Exporter::import
16 LDAP_OPERATIONS_ERROR
17 LDAP_SASL_BIND_IN_PROGRESS
18 LDAP_DECODING_ERROR
19 LDAP_PROTOCOL_ERROR
20 LDAP_ENCODING_ERROR
21 LDAP_FILTER_ERROR
22 LDAP_LOCAL_ERROR
23 LDAP_PARAM_ERROR
24 LDAP_INAPPROPRIATE_AUTH
25 LDAP_SERVER_DOWN
26 LDAP_USER_CANCELED
27 LDAP_EXTENSION_START_TLS
28 LDAP_UNAVAILABLE
2935.42ms1146µs );
# spent 146µs making 1 call to Net::LDAP::BEGIN@15
30
3111µs$VERSION = "0.4001";
32163µs@ISA = qw(Tie::StdHash Net::LDAP::Extra);
331500ns$LDAP_VERSION = 3; # default LDAP protocol version
34
35# Net::LDAP::Extra will only exist is someone use's the module. But we need
36# to ensure the package stash exists or perl will complain that we inherit
37# from a non-existant package. I could just use the module, but I did not
38# want to.
39
401200ns$Net::LDAP::Extra::create = $Net::LDAP::Extra::create = 0;
41
42
# spent 35µs (30+4) within Net::LDAP::import which was called: # once (30µs+4µs) by C4::Auth_with_ldap::BEGIN@31 at line 31 of /usr/share/koha/lib/C4/Auth_with_ldap.pm
sub import {
43439µs shift;
44 unshift @_, 'Net::LDAP::Constant';
45 require Net::LDAP::Constant;
46277µs goto &{Net::LDAP::Constant->can('import')};
# spent 73µs making 1 call to Exporter::import # spent 4µs making 1 call to UNIVERSAL::can
47}
48
49sub _options {
50 my %ret = @_;
51 my $once = 0;
52 for my $v (grep { /^-/ } keys %ret) {
53 require Carp;
54 $once++ or Carp::carp("deprecated use of leading - for options");
55 $ret{substr($v,1)} = $ret{$v};
56 }
57
58 $ret{control} = [ map { (ref($_) =~ /[^A-Z]/) ? $_->to_asn : $_ }
59 ref($ret{control}) eq 'ARRAY'
60 ? @{$ret{control}}
61 : $ret{control}
62 ]
63 if exists $ret{control};
64
65 \%ret;
66}
67
68sub _dn_options {
69 unshift @_, 'dn' if @_ & 1;
70 &_options;
71}
72
73sub _err_msg {
74 my $mesg = shift;
75 my $errstr = $mesg->dn || '';
76 $errstr .= ": " if $errstr;
77 $errstr . $mesg->error;
78}
79
80my %onerror = (
81 'die' => sub {
82 require Carp;
83 Carp::croak(_err_msg(@_))
84 },
85 'warn' => sub { require Carp; Carp::carp(_err_msg(@_)); $_[0] },
86 'undef' => sub { require Carp; Carp::carp(_err_msg(@_)) if $^W; undef },
87115µs);
88
89sub _error {
90 my ($ldap, $mesg) = splice(@_,0,2);
91
92 $mesg->set_error(@_);
93 $ldap->{net_ldap_onerror} && !$ldap->{net_ldap_async}
94 ? scalar &{$ldap->{net_ldap_onerror}}($mesg)
95 : $mesg;
96}
97
98sub new {
99 my $self = shift;
100 my $type = ref($self) || $self;
101 my $host = shift if @_ % 2;
102 my $arg = &_options;
103 my $obj = bless {}, $type;
104
105 foreach my $uri (ref($host) ? @$host : ($host)) {
106 my $scheme = $arg->{scheme} || 'ldap';
107 (my $h = $uri) =~ s,^(\w+)://,, and $scheme = $1;
108 my $meth = $obj->can("connect_$scheme") or next;
109 $h =~ s,/.*,,; # remove path part
110 $h =~ s/%([A-Fa-f0-9]{2})/chr(hex($1))/eg; # unescape
111 if (&$meth($obj, $h, $arg)) {
112 $obj->{net_ldap_uri} = $uri;
113 $obj->{net_ldap_scheme} = $scheme;
114 last;
115 }
116 }
117
118 return undef unless $obj->{net_ldap_socket};
119
120 $obj->{net_ldap_resp} = {};
121 $obj->{net_ldap_version} = $arg->{version} || $LDAP_VERSION;
122 $obj->{net_ldap_async} = $arg->{async} ? 1 : 0;
123 $obj->{raw} = $arg->{raw} if ($arg->{raw});
124
125 if (defined(my $onerr = $arg->{onerror})) {
126 $onerr = $onerror{$onerr} if exists $onerror{$onerr};
127 $obj->{net_ldap_onerror} = $onerr;
128 }
129
130 $obj->debug($arg->{debug} || 0 );
131
132 $obj->outer;
133}
134
135sub connect_ldap {
136 my ($ldap, $host, $arg) = @_;
137 my $port = $arg->{port} || 389;
138 my $class = 'IO::Socket::INET';
139
140 # separate port from host overwriting given/default port
141 $host =~ s/^([^:]+|\[.*\]):(\d+)$/$1/ and $port = $2;
142
143 if ($arg->{inet6}) {
144 require IO::Socket::INET6;
145 $class = 'IO::Socket::INET6';
146 }
147
148 $ldap->{net_ldap_socket} = $class->new(
149 PeerAddr => $host,
150 PeerPort => $port,
151 LocalAddr => $arg->{localaddr} || undef,
152 Proto => 'tcp',
153 MultiHomed => $arg->{multihomed},
154 Timeout => defined $arg->{timeout}
155 ? $arg->{timeout}
156 : 120
157 ) or return undef;
158
159 $ldap->{net_ldap_host} = $host;
160 $ldap->{net_ldap_port} = $port;
161}
162
163
164# Different OpenSSL verify modes.
16513µsmy %ssl_verify = qw(none 0 optional 1 require 3);
166
167sub connect_ldaps {
168 my ($ldap, $host, $arg) = @_;
169 my $port = $arg->{port} || 636;
170
171 require IO::Socket::INET6 if ($arg->{inet6});
172 require IO::Socket::SSL;
173 IO::Socket::SSL->import(qw/inet6/) if ($arg->{inet6});
174
175 # separate port from host overwriting given/default port
176 $host =~ s/^([^:]+|\[.*\]):(\d+)$/$1/ and $port = $2;
177
178 $ldap->{'net_ldap_socket'} = IO::Socket::SSL->new(
179 PeerAddr => $host,
180 PeerPort => $port,
181 LocalAddr => $arg->{localaddr} || undef,
182 Proto => 'tcp',
183 Timeout => defined $arg->{'timeout'} ? $arg->{'timeout'} : 120,
184 _SSL_context_init_args($arg)
185 ) or return undef;
186
187 $ldap->{net_ldap_host} = $host;
188 $ldap->{net_ldap_port} = $port;
189}
190
191sub _SSL_context_init_args {
192 my $arg = shift;
193
194 my $verify = 0;
195 my ($clientcert,$clientkey,$passwdcb);
196
197 if (exists $arg->{'verify'}) {
198 my $v = lc $arg->{'verify'};
199 $verify = 0 + (exists $ssl_verify{$v} ? $ssl_verify{$v} : $verify);
200 }
201
202 if (exists $arg->{'clientcert'}) {
203 $clientcert = $arg->{'clientcert'};
204 if (exists $arg->{'clientkey'}) {
205 $clientkey = $arg->{'clientkey'};
206 } else {
207 require Carp;
208 Carp::croak("Setting client public key but not client private key");
209 }
210 }
211
212 if ($arg->{'checkcrl'} && !$arg->{'capath'}) {
213 require Carp;
214 Carp::croak("Cannot check CRL without having CA certificates");
215 }
216
217 if (exists $arg->{'keydecrypt'}) {
218 $passwdcb = $arg->{'keydecrypt'};
219 }
220
221 (
222 SSL_cipher_list => defined $arg->{'ciphers'} ? $arg->{'ciphers'} : 'ALL',
223 SSL_ca_file => exists $arg->{'cafile'} ? $arg->{'cafile'} : '',
224 SSL_ca_path => exists $arg->{'capath'} ? $arg->{'capath'} : '',
225 SSL_key_file => $clientcert ? $clientkey : undef,
226 SSL_passwd_cb => $passwdcb,
227 SSL_check_crl => $arg->{'checkcrl'} ? 1 : 0,
228 SSL_use_cert => $clientcert ? 1 : 0,
229 SSL_cert_file => $clientcert,
230 SSL_verify_mode => $verify,
231 SSL_version => defined $arg->{'sslversion'} ? $arg->{'sslversion'} :
232 'sslv2/3',
233 );
234}
235
236sub connect_ldapi {
237 my ($ldap, $peer, $arg) = @_;
238
239 $peer = $ENV{LDAPI_SOCK} || "/var/run/ldapi"
240 unless length $peer;
241
242 require IO::Socket::UNIX;
243
244 $ldap->{net_ldap_socket} = IO::Socket::UNIX->new(
245 Peer => $peer,
246 Timeout => defined $arg->{timeout}
247 ? $arg->{timeout}
248 : 120
249 ) or return undef;
250
251 $ldap->{net_ldap_host} = 'localhost';
252 $ldap->{net_ldap_peer} = $peer;
253}
254
255sub message {
256 my $ldap = shift;
257 shift->new($ldap, @_);
258}
259
260sub async {
261 my $ldap = shift;
262
263 @_
264 ? ($ldap->{'net_ldap_async'},$ldap->{'net_ldap_async'} = shift)[0]
265 : $ldap->{'net_ldap_async'};
266}
267
268sub debug {
269 my $ldap = shift;
270
271 require Convert::ASN1::Debug if $_[0];
272
273 @_
274 ? ($ldap->{net_ldap_debug},$ldap->{net_ldap_debug} = shift)[0]
275 : $ldap->{net_ldap_debug};
276}
277
278sub socket {
279 $_[0]->{net_ldap_socket};
280}
281
282sub host {
283 my $ldap = shift;
284 ($ldap->{net_ldap_scheme} ne 'ldapi')
285 ? $ldap->{net_ldap_host}
286 : $ldap->{net_ldap_peer};
287}
288
289sub port {
290 $_[0]->{net_ldap_port} || undef;
291}
292
293sub scheme {
294 $_[0]->{net_ldap_scheme};
295}
296
297sub uri {
298 $_[0]->{net_ldap_uri};
299}
300
301
302sub unbind {
303 my $ldap = shift;
304 my $arg = &_options;
305
306 my $mesg = $ldap->message('Net::LDAP::Unbind' => $arg);
307
308 my $control = $arg->{control}
309 and $ldap->{net_ldap_version} < 3
310 and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
311
312 $mesg->encode(
313 unbindRequest => 1,
314 controls => $control,
315 ) or return _error($ldap, $mesg,LDAP_ENCODING_ERROR,"$@");
316
317 $ldap->_sendmesg($mesg);
318}
319
320
321sub ldapbind {
322 require Carp;
323 Carp::carp("->ldapbind deprecated, use ->bind") if $^W;
324 goto &bind;
325}
326
327
32816µsmy %ptype = qw(
329 password simple
330 krb41password krbv41
331 krb42password krbv42
332 kerberos41 krbv41
333 kerberos42 krbv42
334 sasl sasl
335 noauth anon
336 anonymous anon
337);
338
339sub bind {
340 my $ldap = shift;
341 my $arg = &_dn_options;
342
343 require Net::LDAP::Bind;
344 my $mesg = $ldap->message('Net::LDAP::Bind' => $arg);
345
346 $ldap->version(delete $arg->{version})
347 if exists $arg->{version};
348
349 my $dn = delete $arg->{dn} || '';
350 my $control = delete $arg->{control}
351 and $ldap->{net_ldap_version} < 3
352 and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
353
354 my %stash = (
355 name => ref($dn) ? $dn->dn : $dn,
356 version => $ldap->version,
357 );
358
359 my($auth_type,$passwd) = scalar(keys %$arg) ? () : (simple => '');
360
361 keys %ptype; # Reset iterator
362 while(my($param,$type) = each %ptype) {
363 if (exists $arg->{$param}) {
364 ($auth_type,$passwd) = $type eq 'anon' ? (simple => '') : ($type,$arg->{$param});
365 return _error($ldap, $mesg, LDAP_INAPPROPRIATE_AUTH, "No password, did you mean noauth or anonymous ?")
366 if $type eq 'simple' and $passwd eq '';
367 last;
368 }
369 }
370
371 return _error($ldap, $mesg, LDAP_INAPPROPRIATE_AUTH, "No AUTH supplied")
372 unless $auth_type;
373
374 if ($auth_type eq 'sasl') {
375
376 return _error($ldap, $mesg, LDAP_PARAM_ERROR, "SASL requires LDAPv3")
377 if $ldap->{net_ldap_version} < 3;
378
379 my $sasl = $passwd;
380 my $sasl_conn;
381
382 if (ref($sasl) and $sasl->isa('Authen::SASL')) {
383
384 # If we're talking to a round-robin, the canonical name of
385 # the host we are talking to might not match the name we
386 # requested
387 my $connected_name = $ldap->{net_ldap_socket}->peerhost;
388 $connected_name ||= $ldap->{net_ldap_host};
389
390 $sasl_conn = eval {
391 local ($SIG{__DIE__});
392 $sasl->client_new("ldap", $connected_name);
393 };
394 }
395 else {
396 $sasl_conn = $sasl;
397 }
398
399 return _error($ldap, $mesg, LDAP_LOCAL_ERROR, "$@")
400 unless defined($sasl_conn);
401
402 # Tell SASL the local and server IP addresses
403 $sasl_conn->property(
404 sockname => $ldap->{net_ldap_socket}->sockname,
405 peername => $ldap->{net_ldap_socket}->peername,
406 );
407
408 my $initial = $sasl_conn->client_start;
409
410 return _error($ldap, $mesg, LDAP_LOCAL_ERROR, $sasl_conn->error)
411 unless defined($initial);
412
413 $passwd = {
414 mechanism => $sasl_conn->mechanism,
415 credentials => $initial,
416 };
417
418 # Save data, we will need it later
419 $mesg->_sasl_info($stash{name},$control,$sasl_conn);
420 }
421
422 $stash{authentication} = { $auth_type => $passwd };
423
424 $mesg->encode(
425 bindRequest => \%stash,
426 controls => $control
427 ) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
428
429 $ldap->_sendmesg($mesg);
430}
431
432
43315µsmy %scope = qw(base 0 one 1 single 1 sub 2 subtree 2);
43413µsmy %deref = qw(never 0 search 1 find 2 always 3);
435
436sub search {
437 my $ldap = shift;
438 my $arg = &_options;
439
440 require Net::LDAP::Search;
441
442 $arg->{raw} = $ldap->{raw}
443 if ($ldap->{raw} && !defined($arg->{raw}));
444
445 my $mesg = $ldap->message('Net::LDAP::Search' => $arg);
446
447 my $control = $arg->{control}
448 and $ldap->{net_ldap_version} < 3
449 and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
450
451 my $base = $arg->{base} || '';
452 my $filter;
453
454 unless (ref ($filter = $arg->{filter})) {
455 require Net::LDAP::Filter;
456 my $f = Net::LDAP::Filter->new;
457 $f->parse($filter)
458 or return _error($ldap, $mesg, LDAP_PARAM_ERROR,"Bad filter");
459 $filter = $f;
460 }
461
462 my %stash = (
463 baseObject => ref($base) ? $base->dn : $base,
464 scope => 2,
465 derefAliases => 2,
466 sizeLimit => $arg->{sizelimit} || 0,
467 timeLimit => $arg->{timelimit} || 0,
468 typesOnly => $arg->{typesonly} || $arg->{attrsonly} || 0,
469 filter => $filter,
470 attributes => $arg->{attrs} || []
471 );
472
473 if (exists $arg->{scope}) {
474 my $sc = lc $arg->{scope};
475 $stash{scope} = 0 + (exists $scope{$sc} ? $scope{$sc} : $sc);
476 }
477
478 if (exists $arg->{deref}) {
479 my $dr = lc $arg->{deref};
480 $stash{derefAliases} = 0 + (exists $deref{$dr} ? $deref{$dr} : $dr);
481 }
482
483 $mesg->encode(
484 searchRequest => \%stash,
485 controls => $control
486 ) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
487
488 $ldap->_sendmesg($mesg);
489}
490
491
492sub add {
493 my $ldap = shift;
494 my $arg = &_dn_options;
495
496 my $mesg = $ldap->message('Net::LDAP::Add' => $arg);
497
498 my $control = $arg->{control}
499 and $ldap->{net_ldap_version} < 3
500 and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
501
502 my $entry = $arg->{dn}
503 or return _error($ldap, $mesg, LDAP_PARAM_ERROR,"No DN specified");
504
505 unless (ref $entry) {
506 require Net::LDAP::Entry;
507 $entry = Net::LDAP::Entry->new;
508 $entry->dn($arg->{dn});
509 $entry->add(@{$arg->{attrs} || $arg->{attr} || []});
510 }
511
512 $mesg->encode(
513 addRequest => $entry->asn,
514 controls => $control
515 ) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
516
517 $ldap->_sendmesg($mesg);
518}
519
520
52113µsmy %opcode = ( 'add' => 0, 'delete' => 1, 'replace' => 2, 'increment' => 3);
522
523sub modify {
524 my $ldap = shift;
525 my $arg = &_dn_options;
526
527 my $mesg = $ldap->message('Net::LDAP::Modify' => $arg);
528
529 my $control = $arg->{control}
530 and $ldap->{net_ldap_version} < 3
531 and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
532
533 my $dn = $arg->{dn}
534 or return _error($ldap, $mesg, LDAP_PARAM_ERROR,"No DN specified");
535
536 my @ops;
537 my $opcode;
538 my $op;
539
540 if (exists $arg->{changes}) {
541 my $chg;
542 my $opcode;
543 my $j = 0;
544 while($j < @{$arg->{changes}}) {
545 return _error($ldap, $mesg, LDAP_PARAM_ERROR,"Bad change type '" . $arg->{changes}[--$j] . "'")
546 unless defined($opcode = $opcode{$arg->{changes}[$j++]});
547
548 $chg = $arg->{changes}[$j++];
549 if (ref($chg)) {
550 my $i = 0;
551 while ($i < @$chg) {
552 push @ops, {
553 operation => $opcode,
554 modification => {
555 type => $chg->[$i],
556 vals => ref($chg->[$i+1]) ? $chg->[$i+1] : [$chg->[$i+1]]
557 }
558 };
559 $i += 2;
560 }
561 }
562 }
563 }
564 else {
565 foreach $op (qw(add delete replace increment)) {
566 next unless exists $arg->{$op};
567 my $opt = $arg->{$op};
568 my $opcode = $opcode{$op};
569 my($k,$v);
570
571 if (ref($opt) eq 'HASH') {
572 while (($k,$v) = each %$opt) {
573 push @ops, {
574 operation => $opcode,
575 modification => {
576 type => $k,
577 vals => ref($v) ? $v : [$v]
578 }
579 };
580 }
581 }
582 elsif (ref($opt) eq 'ARRAY') {
583 $k = 0;
584 while ($k < @{$opt}) {
585 my $attr = ${$opt}[$k++];
586 my $val = $opcode == 1 ? [] : ${$opt}[$k++];
587 push @ops, {
588 operation => $opcode,
589 modification => {
590 type => $attr,
591 vals => ref($val) ? $val : [$val]
592 }
593 };
594 }
595 }
596 else {
597 push @ops, {
598 operation => $opcode,
599 modification => {
600 type => $opt,
601 vals => []
602 }
603 };
604 }
605 }
606 }
607
608 $mesg->encode(
609 modifyRequest => {
610 object => ref($dn) ? $dn->dn : $dn,
611 modification => \@ops
612 },
613 controls => $control
614 )
615 or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
616
617 $ldap->_sendmesg($mesg);
618}
619
620sub delete {
621 my $ldap = shift;
622 my $arg = &_dn_options;
623
624 my $mesg = $ldap->message('Net::LDAP::Delete' => $arg);
625
626 my $control = $arg->{control}
627 and $ldap->{net_ldap_version} < 3
628 and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
629
630 my $dn = $arg->{dn}
631 or return _error($ldap, $mesg, LDAP_PARAM_ERROR,"No DN specified");
632
633 $mesg->encode(
634 delRequest => ref($dn) ? $dn->dn : $dn,
635 controls => $control
636 ) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
637
638 $ldap->_sendmesg($mesg);
639}
640
641sub moddn {
642 my $ldap = shift;
643 my $arg = &_dn_options;
644 my $del = $arg->{deleteoldrdn} || $arg->{'delete'} || 0;
645 my $newsup = $arg->{newsuperior};
646
647 my $mesg = $ldap->message('Net::LDAP::ModDN' => $arg);
648
649 my $control = $arg->{control}
650 and $ldap->{net_ldap_version} < 3
651 and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
652
653 my $dn = $arg->{dn}
654 or return _error($ldap, $mesg, LDAP_PARAM_ERROR,"No DN specified");
655
656 my $new = $arg->{newrdn} || $arg->{'new'}
657 or return _error($ldap, $mesg, LDAP_PARAM_ERROR,"No NewRDN specified");
658
659 $mesg->encode(
660 modDNRequest => {
661 entry => ref($dn) ? $dn->dn : $dn,
662 newrdn => ref($new) ? $new->dn : $new,
663 deleteoldrdn => $del,
664 newSuperior => ref($newsup) ? $newsup->dn : $newsup,
665 },
666 controls => $control
667 ) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
668
669 $ldap->_sendmesg($mesg);
670}
671
672# now maps to the V3/X.500(93) modifydn map
673sub modrdn { goto &moddn }
674
675sub compare {
676 my $ldap = shift;
677 my $arg = &_dn_options;
678
679 my $mesg = $ldap->message('Net::LDAP::Compare' => $arg);
680
681 my $control = $arg->{control}
682 and $ldap->{net_ldap_version} < 3
683 and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
684
685 my $dn = $arg->{dn}
686 or return _error($ldap, $mesg, LDAP_PARAM_ERROR,"No DN specified");
687
688 my $attr = exists $arg->{attr}
689 ? $arg->{attr}
690 : exists $arg->{attrs} #compat
691 ? $arg->{attrs}[0]
692 : "";
693
694 my $value = exists $arg->{value}
695 ? $arg->{value}
696 : exists $arg->{attrs} #compat
697 ? $arg->{attrs}[1]
698 : "";
699
700
701 $mesg->encode(
702 compareRequest => {
703 entry => ref($dn) ? $dn->dn : $dn,
704 ava => {
705 attributeDesc => $attr,
706 assertionValue => $value
707 }
708 },
709 controls => $control
710 ) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
711
712 $ldap->_sendmesg($mesg);
713}
714
715sub abandon {
716 my $ldap = shift;
717 unshift @_,'id' if @_ & 1;
718 my $arg = &_options;
719
720 my $id = $arg->{id};
721
722 my $mesg = $ldap->message('Net::LDAP::Abandon' => $arg);
723
724 my $control = $arg->{control}
725 and $ldap->{net_ldap_version} < 3
726 and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
727
728 $mesg->encode(
729 abandonRequest => ref($id) ? $id->mesg_id : $id,
730 controls => $control
731 ) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
732
733 $ldap->_sendmesg($mesg);
734}
735
736sub extension {
737 my $ldap = shift;
738 my $arg = &_options;
739
740 require Net::LDAP::Extension;
741 my $mesg = $ldap->message('Net::LDAP::Extension' => $arg);
742
743 return _error($ldap, $mesg, LDAP_LOCAL_ERROR, "ExtendedRequest requires LDAPv3")
744 if $ldap->{net_ldap_version} < 3;
745
746 $mesg->encode(
747 extendedReq => {
748 requestName => $arg->{name},
749 requestValue => $arg->{value}
750 },
751 controls => $arg->{control}
752 ) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
753
754 $ldap->_sendmesg($mesg);
755}
756
757sub sync {
758 my $ldap = shift;
759 my $mid = shift;
760 my $table = $ldap->{net_ldap_mesg};
761 my $err = LDAP_SUCCESS;
762
763 return $err unless defined $table;
764
765 $mid = $mid->mesg_id if ref($mid);
766 while (defined($mid) ? exists $table->{$mid} : %$table) {
767 last if $err = $ldap->process($mid);
768 }
769
770 $err;
771}
772
773sub disconnect {
774 my $self = shift;
775 _drop_conn($self, LDAP_USER_CANCELED, "Explicit disconnect");
776}
777
778sub _sendmesg {
779 my $ldap = shift;
780 my $mesg = shift;
781
782 my $debug;
783 if ($debug = $ldap->debug) {
784 require Convert::ASN1::Debug;
785 print STDERR "$ldap sending:\n";
786
787 Convert::ASN1::asn_hexdump(*STDERR, $mesg->pdu)
788 if $debug & 1;
789
790 Convert::ASN1::asn_dump(*STDERR, $mesg->pdu)
791 if $debug & 4;
792 }
793
794 my $socket = $ldap->socket
795 or return _error($ldap, $mesg, LDAP_SERVER_DOWN, "$!");
796
797 # send packets in sizes that IO::Socket::SSL can chew
798 # originally it was:
799 #syswrite($socket, $mesg->pdu, length($mesg->pdu))
800 # or return _error($ldap, $mesg, LDAP_LOCAL_ERROR,"$!")
801 my $to_send = \( $mesg->pdu );
802 my $offset = 0;
803 while($offset < length($$to_send)) {
804 my $n = syswrite($socket, substr($$to_send, $offset, 15000), 15000)
805 or return _error($ldap, $mesg, LDAP_LOCAL_ERROR,"$!");
806 $offset += $n;
807 }
808
809 # for CLDAP, here we need to recode when we were sent
810 # so that we can perform timeouts and resends
811
812 my $mid = $mesg->mesg_id;
813 my $sync = not $ldap->async;
814
815 unless ($mesg->done) { # may not have a responce
816
817 $ldap->{net_ldap_mesg}->{$mid} = $mesg;
818
819 if ($sync) {
820 my $err = $ldap->sync($mid);
821 return _error($ldap, $mesg, $err,$@) if $err;
822 }
823 }
824
825 $sync && $ldap->{net_ldap_onerror} && $mesg->is_error
826 ? scalar &{$ldap->{net_ldap_onerror}}($mesg)
827 : $mesg;
828}
829
830sub process {
831 my $ldap = shift;
832 my $what = shift;
833 my $sock = $ldap->socket or return LDAP_SERVER_DOWN;
834 my $sel = IO::Select->new($sock);
835 my $ready;
836
837 for( $ready = 1 ; $ready ; $ready = $sel->can_read(0)) {
838 my $pdu;
839 asn_read($sock, $pdu)
840 or return _drop_conn($ldap, LDAP_OPERATIONS_ERROR, "Communications Error");
841
842 my $debug;
843 if ($debug = $ldap->debug) {
844 require Convert::ASN1::Debug;
845 print STDERR "$ldap received:\n";
846
847 Convert::ASN1::asn_hexdump(\*STDERR,$pdu)
848 if $debug & 2;
849
850 Convert::ASN1::asn_dump(\*STDERR,$pdu)
851 if $debug & 8;
852 }
853
854 my $result = $LDAPResponse->decode($pdu)
855 or return LDAP_DECODING_ERROR;
856
857 my $mid = $result->{messageID};
858 my $mesg = $ldap->{net_ldap_mesg}->{$mid};
859
860 unless ($mesg) {
861 if (my $ext = $result->{protocolOp}{extendedResp}) {
862 if (($ext->{responseName} || '') eq '1.3.6.1.4.1.1466.20036') {
863 # notice of disconnection
864 return _drop_conn($ldap, LDAP_SERVER_DOWN, "Notice of Disconnection");
865 }
866 }
867
868 print STDERR "Unexpected PDU, ignored\n" if $debug & 10;
869 next;
870 }
871
872 $mesg->decode($result) or
873 return $mesg->code;
874
875 last if defined $what && $what == $mid;
876 }
877
878 # FIXME: in CLDAP here we need to check if any message has timed out
879 # and if so do we resend it or what
880
881 return LDAP_SUCCESS;
882}
883
88412µs*_recvresp = \&process; # compat
885
886sub _drop_conn {
887 my ($self, $err, $etxt) = @_;
888
889 my $sock = delete $self->{net_ldap_socket};
890 close($sock) if $sock;
891
892 if (my $msgs = delete $self->{net_ldap_mesg}) {
893 foreach my $mesg (values %$msgs) {
894 $mesg->set_error($err, $etxt);
895 }
896 }
897
898 $err;
899}
900
901
902sub _forgetmesg {
903 my $ldap = shift;
904 my $mesg = shift;
905
906 my $mid = $mesg->mesg_id;
907
908 delete $ldap->{net_ldap_mesg}->{$mid};
909}
910
911#Mark Wilcox 3-20-2000
912#now accepts named parameters
913#dn => "dn of subschema entry"
914#
915#
916# Clif Harden 2-4-2001.
917# corrected filter for subschema search.
918# added attributes to retrieve on subschema search.
919# added attributes to retrieve on rootDSE search.
920# changed several double qoute character to single quote
921# character, just to be consistent throughout the schema
922# and root_dse functions.
923#
924
925sub schema {
926 require Net::LDAP::Schema;
927 my $self = shift;
928 my %arg = @_;
929 my $base;
930 my $mesg;
931
932 if (exists $arg{'dn'}) {
933 $base = $arg{'dn'};
934 }
935 else {
936 my $root = $self->root_dse( attrs => ['subschemaSubentry'] )
937 or return undef;
938
939 $base = $root->get_value('subschemaSubentry') || 'cn=schema';
940 }
941
942 $mesg = $self->search(
943 base => $base,
944 scope => 'base',
945 filter => '(objectClass=subschema)',
946 attrs => [qw(
947 objectClasses
948 attributeTypes
949 matchingRules
950 matchingRuleUse
951 dITStructureRules
952 dITContentRules
953 nameForms
954 ldapSyntaxes
955 extendedAttributeInfo
956 )],
957 );
958
959 $mesg->code
960 ? undef
961 : Net::LDAP::Schema->new($mesg->entry);
962}
963
964
965sub root_dse {
966 my $ldap = shift;
967 my %arg = @_;
968 my $attrs = $arg{attrs} || [qw(
969 subschemaSubentry
970 namingContexts
971 altServer
972 supportedExtension
973 supportedControl
974 supportedFeatures
975 supportedSASLMechanisms
976 supportedLDAPVersion
977 vendorName
978 vendorVersion
979 )];
980 my $root = $arg{attrs} && $ldap->{net_ldap_root_dse};
981
982 return $root if $root;
983
984 my $mesg = $ldap->search(
985 base => '',
986 scope => 'base',
987 filter => '(objectClass=*)',
988 attrs => $attrs,
989 );
990
991 require Net::LDAP::RootDSE;
992 $root = $mesg->entry;
993 bless $root, 'Net::LDAP::RootDSE' if $root; # Naughty, but there you go :-)
994
995 $ldap->{net_ldap_root_dse} = $root unless $arg{attrs};
996
997 return $root;
998}
999
1000sub start_tls {
1001 my $ldap = shift;
1002 my $arg = &_options;
1003 my $sock = $ldap->socket;
1004
1005 require IO::Socket::SSL;
1006 require Net::LDAP::Extension;
1007 my $mesg = $ldap->message('Net::LDAP::Extension' => $arg);
1008
1009 return _error($ldap, $mesg, LDAP_OPERATIONS_ERROR, "TLS already started")
1010 if $sock->isa('IO::Socket::SSL');
1011
1012 return _error($ldap, $mesg, LDAP_PARAM_ERROR, "StartTLS requires LDAPv3")
1013 if $ldap->version < 3;
1014
1015 $mesg->encode(
1016 extendedReq => {
1017 requestName => LDAP_EXTENSION_START_TLS,
1018 }
1019 );
1020
1021 $ldap->_sendmesg($mesg);
1022 $mesg->sync();
1023
1024 return $mesg
1025 if $mesg->code;
1026
1027 delete $ldap->{net_ldap_root_dse};
1028
1029 $arg->{sslversion} = 'tlsv1' unless defined $arg->{sslversion};
1030 IO::Socket::SSL::context_init( { _SSL_context_init_args($arg) } );
1031 my $sock_class = ref($sock);
1032
1033 return $mesg
1034 if IO::Socket::SSL->start_SSL($sock, {_SSL_context_init_args($arg)});
1035
1036 my $err = $@ || $IO::Socket::SSL::SSL_ERROR || $IO::Socket::SSL::SSL_ERROR || ''; # avoid use on once warning
1037
1038 if ($sock_class ne ref($sock)) {
1039 $err = $sock->errstr;
1040 bless $sock, $sock_class;
1041 }
1042
1043 _error($ldap, $mesg, LDAP_OPERATIONS_ERROR, $err);
1044}
1045
1046sub cipher {
1047 my $ldap = shift;
1048 $ldap->socket->isa('IO::Socket::SSL')
1049 ? $ldap->socket->get_cipher
1050 : undef;
1051}
1052
1053sub certificate {
1054 my $ldap = shift;
1055 $ldap->socket->isa('IO::Socket::SSL')
1056 ? $ldap->socket->get_peer_certificate
1057 : undef;
1058}
1059
1060# what version are we talking?
1061sub version {
1062 my $ldap = shift;
1063
1064 @_
1065 ? ($ldap->{net_ldap_version},$ldap->{net_ldap_version} = shift)[0]
1066 : $ldap->{net_ldap_version};
1067}
1068
1069sub outer {
1070 my $self = shift;
1071 return $self if tied(%$self);
1072 my %outer;
1073 tie %outer, ref($self), $self;
1074 ++$self->{net_ldap_refcnt};
1075 bless \%outer, ref($self);
1076}
1077
1078sub inner {
1079 tied(%{$_[0]}) || $_[0];
1080}
1081
1082sub TIEHASH {
1083 $_[1];
1084}
1085
1086sub DESTROY {
1087 my $ldap = shift;
1088 my $inner = tied(%$ldap) or return;
1089 _drop_conn($inner, LDAP_UNAVAILABLE, "Implicit disconnect")
1090 unless --$inner->{net_ldap_refcnt};
1091}
1092
1093116µs1;
1094
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.