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