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