[ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 # Copyright (c) 1997-2008 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::LDIF; 6 7 use strict; 8 use SelectSaver; 9 require Net::LDAP::Entry; 10 use vars qw($VERSION); 11 12 use constant CHECK_UTF8 => $] > 5.007; 13 14 BEGIN { 15 require Encode 16 if (CHECK_UTF8); 17 } 18 19 20 $VERSION = "0.18"; 21 22 my %mode = qw(w > r < a >>); 23 24 sub new { 25 my $pkg = shift; 26 my $file = shift || "-"; 27 my $mode = shift || "r"; 28 my %opt = @_; 29 my $fh; 30 my $opened_fh = 0; 31 32 if (ref($file)) { 33 $fh = $file; 34 } 35 else { 36 if ($file eq "-") { 37 if ($mode eq "w") { 38 ($file,$fh) = ("STDOUT",\*STDOUT); 39 } 40 else { 41 ($file,$fh) = ("STDIN",\*STDIN); 42 } 43 } 44 else { 45 require Symbol; 46 $fh = Symbol::gensym(); 47 my $open = $file =~ /^\| | \|$/x 48 ? $file 49 : (($mode{$mode} || "<") . $file); 50 open($fh,$open) or return; 51 $opened_fh = 1; 52 } 53 } 54 55 # Default the encoding of DNs to 'none' unless the user specifies 56 $opt{'encode'} = 'none' unless exists $opt{'encode'}; 57 58 # Default the error handling to die 59 $opt{'onerror'} = 'die' unless exists $opt{'onerror'}; 60 61 # sanitize options 62 $opt{'lowercase'} ||= 0; 63 $opt{'change'} ||= 0; 64 $opt{'sort'} ||= 0; 65 $opt{'version'} ||= 0; 66 67 my $self = { 68 changetype => "modify", 69 modify => 'add', 70 wrap => 78, 71 %opt, 72 fh => $fh, 73 file => "$file", 74 opened_fh => $opened_fh, 75 _eof => 0, 76 write_count => ($mode eq 'a' and tell($fh) > 0) ? 1 : 0, 77 }; 78 79 # fetch glob for URL type attributes (one per LDIF object) 80 if ($mode eq "r") { 81 require Symbol; 82 $self->{_attr_fh} = Symbol::gensym(); 83 } 84 85 bless $self, $pkg; 86 } 87 88 sub _read_lines { 89 my $self = shift; 90 my $fh = $self->{'fh'}; 91 my @ldif = (); 92 my $entry = ''; 93 my $in_comment = 0; 94 my $entry_completed = 0; 95 my $ln; 96 97 return @ldif if ($self->eof()); 98 99 while (defined($ln = $self->{_buffered_line} || scalar <$fh>)) { 100 delete($self->{_buffered_line}); 101 if ($ln =~ /^#/o) { # ignore 1st line of comments 102 $in_comment = 1; 103 } 104 else { 105 if ($ln =~ /^[ \t]/o) { # append wrapped line (if not in a comment) 106 $entry .= $ln if (!$in_comment); 107 } 108 else { 109 $in_comment = 0; 110 if ($ln =~ /^\r?\n$/o) { 111 # ignore empty line on start of entry 112 # empty line at non-empty entry indicate entry completion 113 $entry_completed++ if (length($entry)); 114 } 115 else { 116 if ($entry_completed) { 117 $self->{_buffered_line} = $ln; 118 last; 119 } 120 else { 121 # append non-empty line 122 $entry .= $ln; 123 } 124 } 125 } 126 } 127 } 128 $self->eof(1) if (!defined($ln)); 129 $entry =~ s/\r?\n //sgo; # un-wrap wrapped lines 130 $entry =~ s/\r?\n\t/ /sgo; # OpenLDAP extension !!! 131 @ldif = split(/^/, $entry); 132 map { s/\r?\n$//; } @ldif; 133 134 @ldif; 135 } 136 137 138 # read attribute value from URL (currently only file: URLs) 139 sub _read_url_attribute { 140 my $self = shift; 141 my $url = shift; 142 my @ldif = @_; 143 my $line; 144 145 if ($url =~ s/^file:(?:\/\/)?//) { 146 my $fh = $self->{_attr_fh}; 147 unless (open($fh, '<'.$url)) { 148 $self->_error("can't open $line: $!", @ldif); 149 return; 150 } 151 binmode($fh); 152 { # slurp in whole file at once 153 local $/; 154 $line = <$fh>; 155 } 156 close($fh); 157 } else { 158 $self->_error("unsupported URL type", @ldif); 159 return; 160 } 161 162 $line; 163 } 164 165 166 # _read_one() is deprecated and will be removed 167 # in a future version 168 *_read_one = \&_read_entry; 169 170 sub _read_entry { 171 my $self = shift; 172 my @ldif; 173 $self->_clear_error(); 174 175 @ldif = $self->_read_lines; 176 177 unless (@ldif) { # empty records are errors if not at eof 178 $self->_error("illegal empty LDIF entry") if (!$self->eof()); 179 return; 180 } 181 182 if (@ldif and $ldif[0] =~ /^version:\s+(\d+)/) { 183 $self->{'version'} = $1; 184 shift @ldif; 185 return $self->_read_entry 186 unless @ldif; 187 } 188 189 if (@ldif < 1) { 190 $self->_error("LDIF entry is not valid", @ldif); 191 return; 192 } 193 elsif (not ( $ldif[0] =~ s/^dn:(:?) *//) ) { 194 $self->_error("First line of LDIF entry does not begin with 'dn:'", @ldif); 195 return; 196 } 197 198 my $dn = shift @ldif; 199 200 if (length($1)) { # $1 is the optional colon from above 201 eval { require MIME::Base64 }; 202 if ($@) { 203 $self->_error($@, @ldif); 204 return; 205 } 206 $dn = MIME::Base64::decode($dn); 207 } 208 209 my $entry = Net::LDAP::Entry->new; 210 $dn = Encode::decode_utf8($dn) 211 if (CHECK_UTF8 && $self->{raw} && ('dn' !~ /$self->{raw}/)); 212 $entry->dn($dn); 213 214 if ((scalar @ldif) && ($ldif[0] =~ /^changetype:\s*/)) { 215 my $changetype = $ldif[0] =~ s/^changetype:\s*// 216 ? shift(@ldif) : $self->{'changetype'}; 217 $entry->changetype($changetype); 218 219 return $entry if ($changetype eq "delete"); 220 221 unless (@ldif) { 222 $self->_error("LDAP entry is not valid",@ldif); 223 return; 224 } 225 226 while(@ldif) { 227 my $modify = $self->{'modify'}; 228 my $modattr; 229 my $lastattr; 230 if($changetype eq "modify") { 231 unless ( (my $tmp = shift @ldif) =~ s/^(add|delete|replace|increment):\s*([-;\w]+)// ) { 232 $self->_error("LDAP entry is not valid",@ldif); 233 return; 234 } 235 $lastattr = $modattr = $2; 236 $modify = $1; 237 } 238 my @values; 239 while(@ldif) { 240 my $line = shift @ldif; 241 my $attr; 242 my $xattr; 243 244 if ($line eq "-") { 245 if (defined $lastattr) { 246 if (CHECK_UTF8 && $self->{raw}) { 247 map { $_ = Encode::decode_utf8($_) } @values 248 if ($lastattr !~ /$self->{raw}/); 249 } 250 $entry->$modify($lastattr, \@values); 251 } 252 undef $lastattr; 253 @values = (); 254 last; 255 } 256 257 $line =~ s/^([-;\w]+):([\<\:]?)\s*// and 258 ($attr, $xattr) = ($1, $2); 259 260 # base64 encoded attribute: decode it 261 if ($xattr eq ':') { 262 eval { require MIME::Base64 }; 263 if ($@) { 264 $self->_error($@, @ldif); 265 return; 266 } 267 $line = MIME::Base64::decode($line); 268 } 269 # url attribute: read in file:// url, fail on others 270 elsif ($xattr eq '<' and $line =~ s/^(.*?)\s*$/$1/) { 271 $line = $self->_read_url_attribute($line, @ldif); 272 return if !defined($line); 273 } 274 275 if( defined($modattr) && $attr ne $modattr ) { 276 $self->_error("LDAP entry is not valid", @ldif); 277 return; 278 } 279 280 if(!defined($lastattr) || $lastattr ne $attr) { 281 if (defined $lastattr) { 282 if (CHECK_UTF8 && $self->{raw}) { 283 map { $_ = Encode::decode_utf8($_) } @values 284 if ($lastattr !~ /$self->{raw}/); 285 } 286 $entry->$modify($lastattr, \@values); 287 } 288 $lastattr = $attr; 289 @values = ($line); 290 next; 291 } 292 push @values, $line; 293 } 294 if (defined $lastattr) { 295 if (CHECK_UTF8 && $self->{raw}) { 296 map { $_ = Encode::decode_utf8($_) } @values 297 if ($lastattr !~ /$self->{raw}/); 298 } 299 $entry->$modify($lastattr, \@values); 300 } 301 } 302 } 303 304 else { 305 my @attr; 306 my $last = ""; 307 my $vals = []; 308 my $line; 309 my $attr; 310 my $xattr; 311 312 foreach $line (@ldif) { 313 $line =~ s/^([-;\w]+):([\<\:]?)\s*// && 314 (($attr, $xattr) = ($1, $2)) or next; 315 316 # base64 encoded attribute: decode it 317 if ($xattr eq ':') { 318 eval { require MIME::Base64 }; 319 if ($@) { 320 $self->_error($@, @ldif); 321 return; 322 } 323 $line = MIME::Base64::decode($line); 324 } 325 # url attribute: read in file:// url, fail on others 326 elsif ($xattr eq '<' and $line =~ s/^(.*?)\s*$/$1/) { 327 $line = $self->_read_url_attribute($line, @ldif); 328 return if !defined($line); 329 } 330 331 if (CHECK_UTF8 && $self->{raw}) { 332 $line = Encode::decode_utf8($line) 333 if ($attr !~ /$self->{raw}/); 334 } 335 336 if ($attr eq $last) { 337 push @$vals, $line; 338 next; 339 } 340 else { 341 $vals = [$line]; 342 push(@attr,$last=$attr,$vals); 343 } 344 } 345 $entry->add(@attr); 346 } 347 $self->{_current_entry} = $entry; 348 349 $entry; 350 } 351 352 sub read_entry { 353 my $self = shift; 354 355 unless ($self->{'fh'}) { 356 $self->_error("LDIF file handle not valid"); 357 return; 358 } 359 $self->_read_entry(); 360 } 361 362 # read() is deprecated and will be removed 363 # in a future version 364 sub read { 365 my $self = shift; 366 367 return $self->read_entry() unless wantarray; 368 369 my($entry, @entries); 370 push(@entries,$entry) while $entry = $self->read_entry; 371 372 @entries; 373 } 374 375 sub eof { 376 my $self = shift; 377 my $eof = shift; 378 379 if ($eof) { 380 $self->{_eof} = $eof; 381 } 382 383 $self->{_eof}; 384 } 385 386 sub _wrap { 387 my $len=$_[1]; # needs to be >= 2 to avoid division by zero 388 return $_[0] if length($_[0]) <= $len or $len <= 40; 389 use integer; 390 my $l2 = $len-1; 391 my $x = (length($_[0]) - $len) / $l2; 392 my $extra = (length($_[0]) == ($l2 * $x + $len)) ? "" : "a*"; 393 join("\n ",unpack("a$len" . "a$l2" x $x . $extra,$_[0])); 394 } 395 396 sub _write_attr { 397 my($attr,$val,$wrap,$lower) = @_; 398 my $v; 399 my $res = 1; # result value 400 foreach $v (@$val) { 401 my $ln = $lower ? lc $attr : $attr; 402 403 $v = Encode::encode_utf8($v) 404 if (CHECK_UTF8 and Encode::is_utf8($v)); 405 if ($v =~ /(^[ :<]|[\x00-\x1f\x7f-\xff])/) { 406 require MIME::Base64; 407 $ln .= ":: " . MIME::Base64::encode($v,""); 408 } 409 else { 410 $ln .= ": " . $v; 411 } 412 $res &&= print _wrap($ln,$wrap),"\n"; 413 } 414 $res; 415 } 416 417 # helper function to compare attribute names (sort objectClass first) 418 sub _cmpAttrs { 419 ($a =~ /^objectclass$/io) 420 ? -1 : (($b =~ /^objectclass$/io) ? 1 : ($a cmp $b)); 421 } 422 423 sub _write_attrs { 424 my($entry,$wrap,$lower,$sort) = @_; 425 my @attributes = $entry->attributes(); 426 my $attr; 427 my $res = 1; # result value 428 @attributes = sort _cmpAttrs @attributes if ($sort); 429 foreach $attr (@attributes) { 430 my $val = $entry->get_value($attr, asref => 1); 431 $res &&= _write_attr($attr,$val,$wrap,$lower); 432 } 433 $res; 434 } 435 436 sub _write_dn { 437 my($dn,$encode,$wrap) = @_; 438 439 $dn = Encode::encode_utf8($dn) 440 if (CHECK_UTF8 and Encode::is_utf8($dn)); 441 if ($dn =~ /^[ :<]|[\x00-\x1f\x7f-\xff]/) { 442 if ($encode =~ /canonical/i) { 443 require Net::LDAP::Util; 444 $dn = Net::LDAP::Util::canonical_dn($dn); 445 # Canonicalizer won't fix leading spaces, colons or less-thans, which 446 # are special in LDIF, so we fix those up here. 447 $dn =~ s/^([ :<])/\\$1/; 448 } elsif ($encode =~ /base64/i) { 449 require MIME::Base64; 450 $dn = "dn:: " . MIME::Base64::encode($dn,""); 451 } else { 452 $dn = "dn: $dn"; 453 } 454 } else { 455 $dn = "dn: $dn"; 456 } 457 print _wrap($dn,$wrap), "\n"; 458 } 459 460 # write() is deprecated and will be removed 461 # in a future version 462 sub write { 463 my $self = shift; 464 465 $self->_write_entry(0, @_); 466 } 467 468 sub write_entry { 469 my $self = shift; 470 471 $self->_write_entry($self->{change}, @_); 472 } 473 474 sub write_version { 475 my $self = shift; 476 my $res = 1; 477 478 $res &&= print "version: $self->{'version'}\n" 479 if ($self->{'version'} && !$self->{version_written}++); 480 481 return $res; 482 } 483 484 # internal helper: write entry in different format depending on 1st arg 485 sub _write_entry { 486 my $self = shift; 487 my $change = shift; 488 my $entry; 489 my $wrap = int($self->{'wrap'}); 490 my $lower = $self->{'lowercase'}; 491 my $sort = $self->{'sort'}; 492 my $res = 1; # result value 493 local($\,$,); # output field and record separators 494 495 unless ($self->{'fh'}) { 496 $self->_error("LDIF file handle not valid"); 497 return; 498 } 499 my $saver = SelectSaver->new($self->{'fh'}); 500 501 my $fh = $self->{'fh'}; 502 foreach $entry (@_) { 503 unless (ref $entry) { 504 $self->_error("Entry '$entry' is not a valid Net::LDAP::Entry object."); 505 $res = 0; 506 next; 507 } 508 509 if ($change) { 510 my @changes = $entry->changes; 511 my $type = $entry->changetype; 512 513 # Skip entry if there is nothing to write 514 next if $type eq 'modify' and !@changes; 515 516 $res &&= $self->write_version() unless $self->{write_count}++; 517 $res &&= print "\n"; 518 $res &&= _write_dn($entry->dn,$self->{'encode'},$wrap); 519 520 $res &&= print "changetype: $type\n"; 521 522 if ($type eq 'delete') { 523 next; 524 } 525 elsif ($type eq 'add') { 526 $res &&= _write_attrs($entry,$wrap,$lower,$sort); 527 next; 528 } 529 elsif ($type =~ /modr?dn/o) { 530 my $deleteoldrdn = $entry->get_value('deleteoldrdn') || 0; 531 $res &&= _write_attr('newrdn',$entry->get_value('newrdn', asref => 1),$wrap,$lower); 532 $res &&= print 'deleteoldrdn: ', $deleteoldrdn,"\n"; 533 my $ns = $entry->get_value('newsuperior', asref => 1); 534 $res &&= _write_attr('newsuperior',$ns,$wrap,$lower) if defined $ns; 535 next; 536 } 537 538 my $dash=0; 539 foreach my $chg (@changes) { 540 unless (ref($chg)) { 541 $type = $chg; 542 next; 543 } 544 my $i = 0; 545 while ($i < @$chg) { 546 $res &&= print "-\n" if (!$self->{'version'} && $dash++); 547 my $attr = $chg->[$i++]; 548 my $val = $chg->[$i++]; 549 $res &&= print $type,": ",$attr,"\n"; 550 $res &&= _write_attr($attr,$val,$wrap,$lower); 551 $res &&= print "-\n" if ($self->{'version'}); 552 } 553 } 554 } 555 556 else { 557 $res &&= $self->write_version() unless $self->{write_count}++; 558 $res &&= print "\n"; 559 $res &&= _write_dn($entry->dn,$self->{'encode'},$wrap); 560 $res &&= _write_attrs($entry,$wrap,$lower,$sort); 561 } 562 } 563 564 $res; 565 } 566 567 # read_cmd() is deprecated in favor of read_entry() 568 # and will be removed in a future version 569 sub read_cmd { 570 my $self = shift; 571 572 return $self->read_entry() unless wantarray; 573 574 my($entry, @entries); 575 push(@entries,$entry) while $entry = $self->read_entry; 576 577 @entries; 578 } 579 580 # _read_one_cmd() is deprecated in favor of _read_one() 581 # and will be removed in a future version 582 *_read_one_cmd = \&_read_entry; 583 584 # write_cmd() is deprecated in favor of write_entry() 585 # and will be removed in a future version 586 sub write_cmd { 587 my $self = shift; 588 589 $self->_write_entry(1, @_); 590 } 591 592 sub done { 593 my $self = shift; 594 my $res = 1; # result value 595 if ($self->{fh}) { 596 if ($self->{opened_fh}) { 597 $res = close $self->{fh}; 598 undef $self->{opened_fh}; 599 } 600 delete $self->{fh}; 601 } 602 $res; 603 } 604 605 sub handle { 606 my $self = shift; 607 608 return $self->{fh}; 609 } 610 611 my %onerror = ( 612 'die' => sub { 613 my $self = shift; 614 require Carp; 615 $self->done; 616 Carp::croak($self->error(@_)); 617 }, 618 'warn' => sub { 619 my $self = shift; 620 require Carp; 621 Carp::carp($self->error(@_)); 622 }, 623 'undef' => sub { 624 my $self = shift; 625 require Carp; 626 Carp::carp($self->error(@_)) if $^W; 627 }, 628 ); 629 630 sub _error { 631 my ($self,$errmsg,@errlines) = @_; 632 $self->{_err_msg} = $errmsg; 633 $self->{_err_lines} = join "\n",@errlines; 634 635 scalar &{ $onerror{ $self->{onerror} } }($self,$self->{_err_msg}) if $self->{onerror}; 636 } 637 638 sub _clear_error { 639 my $self = shift; 640 641 undef $self->{_err_msg}; 642 undef $self->{_err_lines}; 643 } 644 645 sub error { 646 my $self = shift; 647 $self->{_err_msg}; 648 } 649 650 sub error_lines { 651 my $self = shift; 652 $self->{_err_lines}; 653 } 654 655 sub current_entry { 656 my $self = shift; 657 $self->{_current_entry}; 658 } 659 660 sub current_lines { 661 my $self = shift; 662 $self->{_current_lines}; 663 } 664 665 sub version { 666 my $self = shift; 667 return $self->{'version'} unless @_; 668 $self->{'version'} = shift || 0; 669 } 670 671 sub next_lines { 672 my $self = shift; 673 $self->{_next_lines}; 674 } 675 676 sub DESTROY { 677 my $self = shift; 678 $self->done(); 679 } 680 681 1;
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 |