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