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