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 IO::Socket;
9use IO::Select;
10use Tie::Hash;
11use vars qw($VERSION $LDAP_VERSION @ISA);
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$VERSION 	= "0.35";
32@ISA     	= qw(Tie::StdHash Net::LDAP::Extra);
33$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
40$Net::LDAP::Extra::create = $Net::LDAP::Extra::create = 0;
41
42sub import {
43    shift;
44    unshift @_, 'Net::LDAP::Constant';
45    require Net::LDAP::Constant;
46    goto &{Net::LDAP::Constant->can('import')};
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 },
87);
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.
165my %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
328my %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 = eval {
381      local($SIG{__DIE__});
382      $sasl->client_new("ldap",$ldap->{net_ldap_host});
383    };
384
385    return _error($ldap, $mesg, LDAP_LOCAL_ERROR, "$@")
386      unless defined($sasl_conn);
387
388    # Tell SASL the local and server IP addresses
389    $sasl_conn->property(
390      sockname => $ldap->{net_ldap_socket}->sockname,
391      peername => $ldap->{net_ldap_socket}->peername,
392    );
393
394    my $initial = $sasl_conn->client_start;
395
396    return _error($ldap, $mesg, LDAP_LOCAL_ERROR, "$@")
397      unless defined($initial);
398
399    $passwd = {
400      mechanism   => $sasl_conn->mechanism,
401      credentials => (length($initial) ? $initial : undef)
402    };
403
404    # Save data, we will need it later
405    $mesg->_sasl_info($stash{name},$control,$sasl_conn);
406  }
407
408  $stash{authentication} = { $auth_type => $passwd };
409
410  $mesg->encode(
411    bindRequest => \%stash,
412    controls    => $control
413  ) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
414
415  $ldap->_sendmesg($mesg);
416}
417
418
419my %scope = qw(base  0 one    1 single 1 sub    2 subtree 2);
420my %deref = qw(never 0 search 1 find   2 always 3);
421
422sub search {
423  my $ldap = shift;
424  my $arg  = &_options;
425
426  require Net::LDAP::Search;
427
428  $arg->{raw} = $ldap->{raw}
429    if ($ldap->{raw} && !defined($arg->{raw}));
430
431  my $mesg = $ldap->message('Net::LDAP::Search' => $arg);
432
433  my $control = $arg->{control}
434    and $ldap->{net_ldap_version} < 3
435    and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
436
437  my $base = $arg->{base} || '';
438  my $filter;
439
440  unless (ref ($filter = $arg->{filter})) {
441    require Net::LDAP::Filter;
442    my $f = Net::LDAP::Filter->new;
443    $f->parse($filter)
444      or return _error($ldap, $mesg, LDAP_PARAM_ERROR,"Bad filter");
445    $filter = $f;
446  }
447
448  my %stash = (
449    baseObject   => ref($base) ? $base->dn : $base,
450    scope        => 2,
451    derefAliases => 2,
452    sizeLimit    => $arg->{sizelimit} || 0,
453    timeLimit    => $arg->{timelimit} || 0,
454    typesOnly    => $arg->{typesonly} || $arg->{attrsonly} || 0,
455    filter       => $filter,
456    attributes   => $arg->{attrs} || []
457  );
458
459  if (exists $arg->{scope}) {
460    my $sc = lc $arg->{scope};
461    $stash{scope} = 0 + (exists $scope{$sc} ? $scope{$sc} : $sc);
462  }
463
464  if (exists $arg->{deref}) {
465    my $dr = lc $arg->{deref};
466    $stash{derefAliases} = 0 + (exists $deref{$dr} ? $deref{$dr} : $dr);
467  }
468
469  $mesg->encode(
470    searchRequest => \%stash,
471    controls      => $control
472  ) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
473
474  $ldap->_sendmesg($mesg);
475}
476
477
478sub add {
479  my $ldap = shift;
480  my $arg  = &_dn_options;
481
482  my $mesg = $ldap->message('Net::LDAP::Add' => $arg);
483
484  my $control = $arg->{control}
485    and $ldap->{net_ldap_version} < 3
486    and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
487
488  my $entry = $arg->{dn}
489    or return _error($ldap, $mesg, LDAP_PARAM_ERROR,"No DN specified");
490
491  unless (ref $entry) {
492    require Net::LDAP::Entry;
493    $entry = Net::LDAP::Entry->new;
494    $entry->dn($arg->{dn});
495    $entry->add(@{$arg->{attrs} || $arg->{attr} || []});
496  }
497
498  $mesg->encode(
499    addRequest => $entry->asn,
500    controls   => $control
501  ) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
502
503  $ldap->_sendmesg($mesg);
504}
505
506
507my %opcode = ( 'add' => 0, 'delete' => 1, 'replace' => 2);
508
509sub modify {
510  my $ldap = shift;
511  my $arg  = &_dn_options;
512
513  my $mesg = $ldap->message('Net::LDAP::Modify' => $arg);
514
515  my $control = $arg->{control}
516    and $ldap->{net_ldap_version} < 3
517    and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
518
519  my $dn = $arg->{dn}
520    or return _error($ldap, $mesg, LDAP_PARAM_ERROR,"No DN specified");
521
522  my @ops;
523  my $opcode;
524  my $op;
525
526  if (exists $arg->{changes}) {
527    my $chg;
528    my $opcode;
529    my $j = 0;
530    while($j < @{$arg->{changes}}) {
531      return _error($ldap, $mesg, LDAP_PARAM_ERROR,"Bad change type '" . $arg->{changes}[--$j] . "'")
532       unless defined($opcode = $opcode{$arg->{changes}[$j++]});
533
534      $chg = $arg->{changes}[$j++];
535      if (ref($chg)) {
536	my $i = 0;
537	while ($i < @$chg) {
538          push @ops, {
539	    operation => $opcode,
540	    modification => {
541	      type => $chg->[$i],
542	      vals => ref($chg->[$i+1]) ? $chg->[$i+1] : [$chg->[$i+1]]
543	    }
544	  };
545	  $i += 2;
546	}
547      }
548    }
549  }
550  else {
551    foreach $op (qw(add delete replace)) {
552      next unless exists $arg->{$op};
553      my $opt = $arg->{$op};
554      my $opcode = $opcode{$op};
555      my($k,$v);
556
557      if (ref($opt) eq 'HASH') {
558	while (($k,$v) = each %$opt) {
559          push @ops, {
560	    operation => $opcode,
561	    modification => {
562	      type => $k,
563	      vals => ref($v) ? $v : [$v]
564	    }
565	  };
566	}
567      }
568      elsif (ref($opt) eq 'ARRAY') {
569	$k = 0;
570	while ($k < @{$opt}) {
571          my $attr = ${$opt}[$k++];
572          my $val = $opcode == 1 ? [] : ${$opt}[$k++];
573          push @ops, {
574	    operation => $opcode,
575	    modification => {
576	      type => $attr,
577	      vals => ref($val) ? $val : [$val]
578	    }
579	  };
580	}
581      }
582      else {
583	push @ops, {
584	  operation => $opcode,
585	  modification => {
586	    type => $opt,
587	    vals => []
588	  }
589	};
590      }
591    }
592  }
593
594  $mesg->encode(
595    modifyRequest => {
596      object       => ref($dn) ? $dn->dn : $dn,
597      modification => \@ops
598    },
599    controls => $control
600  )
601    or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
602
603  $ldap->_sendmesg($mesg);
604}
605
606sub delete {
607  my $ldap = shift;
608  my $arg  = &_dn_options;
609
610  my $mesg = $ldap->message('Net::LDAP::Delete' => $arg);
611
612  my $control = $arg->{control}
613    and $ldap->{net_ldap_version} < 3
614    and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
615
616  my $dn = $arg->{dn}
617    or return _error($ldap, $mesg, LDAP_PARAM_ERROR,"No DN specified");
618
619  $mesg->encode(
620    delRequest => ref($dn) ? $dn->dn : $dn,
621    controls   => $control
622  ) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
623
624  $ldap->_sendmesg($mesg);
625}
626
627sub moddn {
628  my $ldap = shift;
629  my $arg  = &_dn_options;
630  my $del  = $arg->{deleteoldrdn} || $arg->{'delete'} || 0;
631  my $newsup = $arg->{newsuperior};
632
633  my $mesg = $ldap->message('Net::LDAP::ModDN' => $arg);
634
635  my $control = $arg->{control}
636    and $ldap->{net_ldap_version} < 3
637    and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
638
639  my $dn = $arg->{dn}
640    or return _error($ldap, $mesg, LDAP_PARAM_ERROR,"No DN specified");
641
642  my $new  = $arg->{newrdn} || $arg->{'new'}
643    or return _error($ldap, $mesg, LDAP_PARAM_ERROR,"No NewRDN specified");
644
645  $mesg->encode(
646    modDNRequest => {
647      entry        => ref($dn) ? $dn->dn : $dn,
648      newrdn       => ref($new) ? $new->dn : $new,
649      deleteoldrdn => $del,
650      newSuperior  => ref($newsup) ? $newsup->dn : $newsup,
651    },
652    controls => $control
653  ) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
654
655  $ldap->_sendmesg($mesg);
656}
657
658# now maps to the V3/X.500(93) modifydn map
659sub modrdn { goto &moddn }
660
661sub compare {
662  my $ldap  = shift;
663  my $arg   = &_dn_options;
664
665  my $mesg = $ldap->message('Net::LDAP::Compare' => $arg);
666
667  my $control = $arg->{control}
668    and $ldap->{net_ldap_version} < 3
669    and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
670
671  my $dn = $arg->{dn}
672    or return _error($ldap, $mesg, LDAP_PARAM_ERROR,"No DN specified");
673
674  my $attr = exists $arg->{attr}
675		? $arg->{attr}
676		: exists $arg->{attrs} #compat
677		   ? $arg->{attrs}[0]
678		   : "";
679
680  my $value = exists $arg->{value}
681		? $arg->{value}
682		: exists $arg->{attrs} #compat
683		   ? $arg->{attrs}[1]
684		   : "";
685
686
687  $mesg->encode(
688    compareRequest => {
689      entry => ref($dn) ? $dn->dn : $dn,
690      ava   => {
691	attributeDesc  => $attr,
692	assertionValue => $value
693      }
694    },
695    controls => $control
696  ) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
697
698  $ldap->_sendmesg($mesg);
699}
700
701sub abandon {
702  my $ldap = shift;
703  unshift @_,'id' if @_ & 1;
704  my $arg = &_options;
705
706  my $id = $arg->{id};
707
708  my $mesg = $ldap->message('Net::LDAP::Abandon' => $arg);
709
710  my $control = $arg->{control}
711    and $ldap->{net_ldap_version} < 3
712    and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
713
714  $mesg->encode(
715    abandonRequest => ref($id) ? $id->mesg_id : $id,
716    controls       => $control
717  ) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
718
719  $ldap->_sendmesg($mesg);
720}
721
722sub extension {
723  my $ldap = shift;
724  my $arg  = &_options;
725
726  require Net::LDAP::Extension;
727  my $mesg = $ldap->message('Net::LDAP::Extension' => $arg);
728
729  return _error($ldap, $mesg, LDAP_LOCAL_ERROR, "ExtendedRequest requires LDAPv3")
730    if $ldap->{net_ldap_version} < 3;
731
732  $mesg->encode(
733    extendedReq => {
734      requestName  => $arg->{name},
735      requestValue => $arg->{value}
736    },
737    controls => $arg->{control}
738  ) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
739
740  $ldap->_sendmesg($mesg);
741}
742
743sub sync {
744  my $ldap  = shift;
745  my $mid   = shift;
746  my $table = $ldap->{net_ldap_mesg};
747  my $err   = LDAP_SUCCESS;
748
749  return $err unless defined $table;
750
751  $mid = $mid->mesg_id if ref($mid);
752  while (defined($mid) ? exists $table->{$mid} : %$table) {
753    last if $err = $ldap->process($mid);
754  }
755
756  $err;
757}
758
759sub disconnect {
760  my $self = shift;
761  _drop_conn($self, LDAP_USER_CANCELED, "Explicit disconnect");
762}
763
764sub _sendmesg {
765  my $ldap = shift;
766  my $mesg = shift;
767
768  my $debug;
769  if ($debug = $ldap->debug) {
770    require Convert::ASN1::Debug;
771    print STDERR "$ldap sending:\n";
772
773    Convert::ASN1::asn_hexdump(*STDERR, $mesg->pdu)
774      if $debug & 1;
775
776    Convert::ASN1::asn_dump(*STDERR, $mesg->pdu)
777      if $debug & 4;
778  }
779
780  my $socket = $ldap->socket
781      or return _error($ldap, $mesg, LDAP_SERVER_DOWN, "$!");
782
783  # send packets in sizes that IO::Socket::SSL can chew
784  # originally it was:
785  #syswrite($socket, $mesg->pdu, length($mesg->pdu))
786  #  or return _error($ldap, $mesg, LDAP_LOCAL_ERROR,"$!")
787  my $to_send = \( $mesg->pdu );
788  my $offset = 0;
789  while($offset < length($$to_send)) {
790    my $n = syswrite($socket, substr($$to_send, $offset, 15000), 15000)
791      or return _error($ldap, $mesg, LDAP_LOCAL_ERROR,"$!");
792    $offset += $n;
793  }
794
795  # for CLDAP, here we need to recode when we were sent
796  # so that we can perform timeouts and resends
797
798  my $mid  = $mesg->mesg_id;
799  my $sync = not $ldap->async;
800
801  unless ($mesg->done) { # may not have a responce
802
803    $ldap->{net_ldap_mesg}->{$mid} = $mesg;
804
805    if ($sync) {
806      my $err = $ldap->sync($mid);
807      return _error($ldap, $mesg, $err,$@) if $err;
808    }
809  }
810
811  $sync && $ldap->{net_ldap_onerror} && $mesg->is_error
812    ? scalar &{$ldap->{net_ldap_onerror}}($mesg)
813    : $mesg;
814}
815
816sub process {
817  my $ldap = shift;
818  my $what = shift;
819  my $sock = $ldap->socket or return LDAP_SERVER_DOWN;
820  my $sel = IO::Select->new($sock);
821  my $ready;
822
823  for( $ready = 1 ; $ready ; $ready = $sel->can_read(0)) {
824    my $pdu;
825    asn_read($sock, $pdu)
826      or return _drop_conn($ldap, LDAP_OPERATIONS_ERROR, "Communications Error");
827
828    my $debug;
829    if ($debug = $ldap->debug) {
830      require Convert::ASN1::Debug;
831      print STDERR "$ldap received:\n";
832
833      Convert::ASN1::asn_hexdump(\*STDERR,$pdu)
834	if $debug & 2;
835
836      Convert::ASN1::asn_dump(\*STDERR,$pdu)
837	if $debug & 8;
838    }
839
840    my $result = $LDAPResponse->decode($pdu)
841      or return LDAP_DECODING_ERROR;
842
843    my $mid  = $result->{messageID};
844    my $mesg = $ldap->{net_ldap_mesg}->{$mid};
845
846    unless ($mesg) {
847      if (my $ext = $result->{protocolOp}{extendedResp}) {
848	if (($ext->{responseName} || '') eq '1.3.6.1.4.1.1466.20036') {
849	  # notice of disconnection
850	  return _drop_conn($ldap, LDAP_SERVER_DOWN, "Notice of Disconnection");
851	}
852      }
853
854      print STDERR "Unexpected PDU, ignored\n" if $debug & 10;
855      next;
856    }
857
858    $mesg->decode($result) or
859      return $mesg->code;
860
861    last if defined $what && $what == $mid;
862  }
863
864  # FIXME: in CLDAP here we need to check if any message has timed out
865  # and if so do we resend it or what
866
867  return LDAP_SUCCESS;
868}
869
870*_recvresp = \&process; # compat
871
872sub _drop_conn {
873  my ($self, $err, $etxt) = @_;
874
875  my $sock = delete $self->{net_ldap_socket};
876  close($sock) if $sock;
877
878  if (my $msgs = delete $self->{net_ldap_mesg}) {
879    foreach my $mesg (values %$msgs) {
880      $mesg->set_error($err, $etxt);
881    }
882  }
883
884  $err;
885}
886
887
888sub _forgetmesg {
889  my $ldap = shift;
890  my $mesg = shift;
891
892  my $mid = $mesg->mesg_id;
893
894  delete $ldap->{net_ldap_mesg}->{$mid};
895}
896
897#Mark Wilcox 3-20-2000
898#now accepts named parameters
899#dn => "dn of subschema entry"
900#
901#
902# Clif Harden 2-4-2001.
903# corrected filter for subschema search.
904# added attributes to retrieve on subschema search.
905# added attributes to retrieve on rootDSE search.
906# changed several double qoute character to single quote
907# character, just to be consistent throughout the schema
908# and root_dse functions.
909#
910
911sub schema {
912  require Net::LDAP::Schema;
913  my $self = shift;
914  my %arg = @_;
915  my $base;
916  my $mesg;
917
918  if (exists $arg{'dn'}) {
919    $base = $arg{'dn'};
920  }
921  else {
922    my $root = $self->root_dse( attrs => ['subschemaSubentry'] )
923      or return undef;
924
925    $base = $root->get_value('subschemaSubentry') || 'cn=schema';
926  }
927
928  $mesg = $self->search(
929    base   => $base,
930    scope  => 'base',
931    filter => '(objectClass=subschema)',
932    attrs  => [qw(
933		objectClasses
934		attributeTypes
935		matchingRules
936		matchingRuleUse
937		dITStructureRules
938		dITContentRules
939		nameForms
940		ldapSyntaxes
941                extendedAttributeInfo
942              )],
943  );
944
945  $mesg->code
946    ? undef
947    : Net::LDAP::Schema->new($mesg->entry);
948}
949
950
951sub root_dse {
952  my $ldap = shift;
953  my %arg  = @_;
954  my $attrs = $arg{attrs} || [qw(
955		  subschemaSubentry
956		  namingContexts
957		  altServer
958		  supportedExtension
959		  supportedControl
960		  supportedFeatures
961		  supportedSASLMechanisms
962		  supportedLDAPVersion
963		  vendorName
964		  vendorVersion
965		)];
966  my $root = $arg{attrs} && $ldap->{net_ldap_root_dse};
967
968  return $root if $root;
969
970  my $mesg = $ldap->search(
971    base   => '',
972    scope  => 'base',
973    filter => '(objectClass=*)',
974    attrs  => $attrs,
975  );
976
977  require Net::LDAP::RootDSE;
978  $root = $mesg->entry;
979  bless $root, 'Net::LDAP::RootDSE' if $root; # Naughty, but there you go :-)
980
981  $ldap->{net_ldap_root_dse} = $root unless $arg{attrs};
982
983  return $root;
984}
985
986sub start_tls {
987  my $ldap = shift;
988  my $arg  = &_options;
989  my $sock = $ldap->socket;
990
991  require IO::Socket::SSL;
992  require Net::LDAP::Extension;
993  my $mesg = $ldap->message('Net::LDAP::Extension' => $arg);
994
995  return _error($ldap, $mesg, LDAP_OPERATIONS_ERROR, "TLS already started")
996    if $sock->isa('IO::Socket::SSL');
997
998  return _error($ldap, $mesg, LDAP_PARAM_ERROR, "StartTLS requires LDAPv3")
999    if $ldap->version < 3;
1000
1001  $mesg->encode(
1002    extendedReq => {
1003      requestName => LDAP_EXTENSION_START_TLS,
1004    }
1005  );
1006
1007  $ldap->_sendmesg($mesg);
1008  $mesg->sync();
1009
1010  return $mesg
1011    if $mesg->code;
1012
1013  delete $ldap->{net_ldap_root_dse};
1014
1015  $arg->{sslversion} = 'tlsv1' unless defined $arg->{sslversion};
1016  IO::Socket::SSL::context_init( { _SSL_context_init_args($arg) } );
1017  my $sock_class = ref($sock);
1018
1019  return $mesg
1020    if IO::Socket::SSL::socketToSSL($sock, {_SSL_context_init_args($arg)});
1021
1022  my $err = $@;
1023
1024  if ($sock_class ne ref($sock)) {
1025    $err = $sock->errstr;
1026    bless $sock, $sock_class;
1027  }
1028
1029  _error($ldap, $mesg, LDAP_OPERATIONS_ERROR, $err);
1030}
1031
1032sub cipher {
1033  my $ldap = shift;
1034  $ldap->socket->isa('IO::Socket::SSL')
1035    ? $ldap->socket->get_cipher
1036    : undef;
1037}
1038
1039sub certificate {
1040  my $ldap = shift;
1041  $ldap->socket->isa('IO::Socket::SSL')
1042    ? $ldap->socket->get_peer_certificate
1043    : undef;
1044}
1045
1046# what version are we talking?
1047sub version {
1048  my $ldap = shift;
1049
1050  @_
1051    ? ($ldap->{net_ldap_version},$ldap->{net_ldap_version} = shift)[0]
1052    : $ldap->{net_ldap_version};
1053}
1054
1055sub outer {
1056  my $self = shift;
1057  return $self if tied(%$self);
1058  my %outer;
1059  tie %outer, ref($self), $self;
1060  ++$self->{net_ldap_refcnt};
1061  bless \%outer, ref($self);
1062}
1063
1064sub inner {
1065  tied(%{$_[0]}) || $_[0];
1066}
1067
1068sub TIEHASH {
1069  $_[1];
1070}
1071
1072sub DESTROY {
1073  my $ldap = shift;
1074  my $inner = tied(%$ldap) or return;
1075  _drop_conn($inner, LDAP_UNAVAILABLE, "Implicit disconnect")
1076    unless --$inner->{net_ldap_refcnt};
1077}
1078
10791;
1080
1081