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