[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/site_perl/5.10.0/Net/LDAP/ -> LDIF.pm (source)

   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;


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1