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::LDIF;
6
7use strict;
8use SelectSaver;
9require Net::LDAP::Entry;
10use vars qw($VERSION);
11
12use constant CHECK_UTF8 => $] > 5.007;
13
14BEGIN {
15  require Encode
16    if (CHECK_UTF8);
17}
18
19
20$VERSION = "0.18";
21
22my %mode = qw(w > r < a >>);
23
24sub 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
88sub _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)
139sub _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
170sub _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):\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
352sub 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
364sub 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
375sub eof {
376  my $self = shift;
377  my $eof = shift;
378
379  if ($eof) {
380    $self->{_eof} = $eof;
381  }
382
383  $self->{_eof};
384}
385
386sub _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
396sub _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)
418sub _cmpAttrs {
419  ($a =~ /^objectclass$/io)
420  ? -1 : (($b =~ /^objectclass$/io) ? 1 : ($a cmp $b));
421}
422
423sub _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
436sub _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
462sub write {
463  my $self = shift;
464
465  $self->_write_entry(0, @_);
466}
467
468sub write_entry {
469  my $self = shift;
470
471  $self->_write_entry($self->{change}, @_);
472}
473
474sub 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
485sub _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
569sub 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
586sub write_cmd {
587  my $self = shift;
588
589  $self->_write_entry(1, @_);
590}
591
592sub 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
605sub handle {
606  my $self = shift;
607
608  return $self->{fh};
609}
610
611my %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
630sub _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
638sub _clear_error {
639  my $self = shift;
640
641  undef $self->{_err_msg};
642  undef $self->{_err_lines};
643}
644
645sub error {
646  my $self = shift;
647  $self->{_err_msg};
648}
649
650sub error_lines {
651  my $self = shift;
652  $self->{_err_lines};
653}
654
655sub current_entry {
656  my $self = shift;
657  $self->{_current_entry};
658}
659
660sub current_lines {
661  my $self = shift;
662  $self->{_current_lines};
663}
664
665sub version {
666  my $self = shift;
667  return $self->{'version'} unless @_;
668  $self->{'version'} = shift || 0;
669}
670
671sub next_lines {
672  my $self = shift;
673  $self->{_next_lines};
674}
675
676sub DESTROY {
677  my $self = shift;
678  $self->done();
679}
680
6811;
682