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