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::Entry;
6
7use strict;
8use Net::LDAP::ASN qw(LDAPEntry);
9use Net::LDAP::Constant qw(LDAP_LOCAL_ERROR LDAP_OTHER);
10
11use constant CHECK_UTF8 => $] > 5.007;
12
13BEGIN {
14  require Encode
15    if (CHECK_UTF8);
16}
17
18our $VERSION = '0.29';
19
20sub new {
21  my $self = shift;
22  my $type = ref($self) || $self;
23
24  my $entry = bless { changetype => 'add', changes => [] }, $type;
25
26  @_ and $entry->dn( shift );
27  @_ and $entry->add( @_ );
28
29  return $entry;
30}
31
32sub clone {
33  my $self  = shift;
34  my $clone = $self->new();
35
36  $clone->dn($self->dn());
37  foreach ($self->attributes()) {
38    $clone->add($_ => [$self->get_value($_)]);
39  }
40
41  $clone->{changetype} = $self->{changetype};
42  my @changes = @{$self->{changes}};
43  while (my($action, $cmd) = splice(@changes, 0, 2)) {
44    my @new_cmd;
45    my @cmd = @$cmd;
46    while (my($type, $val) = splice(@cmd, 0, 2)) {
47      push @new_cmd, $type, [ @$val ];
48    }
49    push @{$clone->{changes}}, $action, \@new_cmd;
50  }
51
52  $clone;
53}
54
55# Build attrs cache, created when needed
56
57sub _build_attrs {
58  +{ map { (lc($_->{type}), $_->{vals}) }  @{$_[0]->{asn}{attributes}} };
59}
60
61# If we are passed an ASN structure we really do nothing
62
63sub decode {
64  my $self = shift;
65  my $result = ref($_[0]) ? shift : $LDAPEntry->decode(shift)
66    or return;
67  my %arg = @_;
68
69  %{$self} = ( asn => $result, changetype => 'modify', changes => []);
70
71  if (CHECK_UTF8 && $arg{raw}) {
72    $result->{objectName} = Encode::decode_utf8($result->{objectName})
73      if ('dn' !~ /$arg{raw}/);
74
75    foreach my $elem (@{$self->{asn}{attributes}}) {
76      map { $_ = Encode::decode_utf8($_) } @{$elem->{vals}}
77        if ($elem->{type} !~ /$arg{raw}/);
78    }
79  }
80
81  $self;
82}
83
84
85
86sub encode {
87  $LDAPEntry->encode( shift->{asn} );
88}
89
90
91sub dn {
92  my $self = shift;
93  @_ ? ($self->{asn}{objectName} = shift) : $self->{asn}{objectName};
94}
95
96sub get_attribute {
97  require Carp;
98  Carp::carp('->get_attribute deprecated, use ->get_value')  if $^W;
99  shift->get_value(@_, asref => !wantarray);
100}
101
102sub get {
103  require Carp;
104  Carp::carp('->get deprecated, use ->get_value')  if $^W;
105  shift->get_value(@_, asref => !wantarray);
106}
107
108
109sub exists {
110  my $self = shift;
111  my $type = lc(shift);
112  my $attrs = $self->{attrs} ||= _build_attrs($self);
113
114  exists $attrs->{$type};
115}
116
117sub get_value {
118  my $self = shift;
119  my $type = lc(shift);
120  my %opt  = @_;
121
122  if ($opt{alloptions}) {
123    my %ret = map {
124                $_->{type} =~ /^\Q$type\E((?:;.*)?)$/i ? (lc($1), $_->{vals}) : ()
125              } @{$self->{asn}{attributes}};
126    return %ret ? \%ret : undef;
127  }
128
129  my $attrs = $self->{attrs} ||= _build_attrs($self);
130  my $attr;
131
132  if ($opt{nooptions}) {
133    my @vals = map {
134                 $_->{type} =~ /^\Q$type\E((?:;.*)?)$/i ? @{$_->{vals}} : ()
135               } @{$self->{asn}{attributes}};
136
137    return  unless @vals;
138
139    $attr = \@vals;
140  }
141  else {
142    $attr = $attrs->{$type} or return;
143  }
144
145  return $opt{asref}
146	  ? $attr
147	  : wantarray
148	    ? @{$attr}
149	    : $attr->[0];
150}
151
152
153sub changetype {
154
155  my $self = shift;
156  return $self->{changetype}  unless @_;
157  $self->{changes} = [];
158  $self->{changetype} = shift;
159  return $self;
160}
161
162
163
164sub add {
165  my $self  = shift;
166  my $cmd   = $self->{changetype} eq 'modify' ? [] : undef;
167  my $attrs = $self->{attrs} ||= _build_attrs($self);
168
169  while (my($type, $val) = splice(@_, 0, 2)) {
170    my $lc_type = lc $type;
171
172    push @{$self->{asn}{attributes}}, { type => $type, vals => ($attrs->{$lc_type}=[])}
173      unless exists $attrs->{$lc_type};
174
175    push @{$attrs->{$lc_type}}, ref($val) ? @$val : $val;
176
177    push @$cmd, $type, [ ref($val) ? @$val : $val ]
178      if $cmd;
179
180  }
181
182  push(@{$self->{changes}}, 'add', $cmd)  if $cmd;
183
184  return $self;
185}
186
187
188sub replace {
189  my $self  = shift;
190  my $cmd   = $self->{changetype} eq 'modify' ? [] : undef;
191  my $attrs = $self->{attrs} ||= _build_attrs($self);
192
193  while (my($type, $val) = splice(@_, 0, 2)) {
194    my $lc_type = lc $type;
195
196    if (defined($val) and (!ref($val) or @$val)) {
197
198      push @{$self->{asn}{attributes}}, { type => $type, vals => ($attrs->{$lc_type}=[])}
199	unless exists $attrs->{$lc_type};
200
201      @{$attrs->{$lc_type}} = ref($val) ? @$val : ($val);
202
203      push @$cmd, $type, [ ref($val) ? @$val : $val ]
204	if $cmd;
205
206    }
207    else {
208      delete $attrs->{$lc_type};
209
210      @{$self->{asn}{attributes}}
211	= grep { $lc_type ne lc($_->{type}) } @{$self->{asn}{attributes}};
212
213      push @$cmd, $type, []
214	if $cmd;
215
216    }
217  }
218
219  push(@{$self->{changes}}, 'replace', $cmd)  if $cmd;
220
221  return $self;
222}
223
224
225sub delete {
226  my $self = shift;
227
228  unless (@_) {
229    $self->changetype('delete');
230    return $self;
231  }
232
233  my $cmd = $self->{changetype} eq 'modify' ? [] : undef;
234  my $attrs = $self->{attrs} ||= _build_attrs($self);
235
236  while (my($type, $val) = splice(@_, 0, 2)) {
237    my $lc_type = lc $type;
238
239    if (defined($val) and (!ref($val) or @$val)) {
240      my %values;
241      @values{(ref($val) ? @$val : $val)} = ();
242
243      unless (@{$attrs->{$lc_type}}
244              = grep { !exists $values{$_} } @{$attrs->{$lc_type}})
245      {
246	delete $attrs->{$lc_type};
247	@{$self->{asn}{attributes}}
248	  = grep { $lc_type ne lc($_->{type}) } @{$self->{asn}{attributes}};
249      }
250
251      push @$cmd, $type, [ ref($val) ? @$val : $val ]
252	if $cmd;
253    }
254    else {
255      delete $attrs->{$lc_type};
256
257      @{$self->{asn}{attributes}}
258	= grep { $lc_type ne lc($_->{type}) } @{$self->{asn}{attributes}};
259
260      push @$cmd, $type, []  if $cmd;
261    }
262  }
263
264  push(@{$self->{changes}}, 'delete', $cmd)  if $cmd;
265
266  return $self;
267}
268
269
270sub update {
271  my $self = shift;
272  my $target = shift;	# a Net::LDAP or a Net::LDAP::LDIF object
273  my %opt = @_;
274  my $mesg;
275  my $user_cb = delete $opt{callback};
276  my $cb = sub { $self->changetype('modify')  unless $_[0]->code;
277                 $user_cb->(@_)  if $user_cb };
278
279  if (eval { $target->isa('Net::LDAP') }) {
280    if ($self->{changetype} eq 'add') {
281      $mesg = $target->add($self, callback => $cb, %opt);
282    }
283    elsif ($self->{changetype} eq 'delete') {
284      $mesg = $target->delete($self, callback => $cb, %opt);
285    }
286    elsif ($self->{changetype} =~ /modr?dn/o) {
287      my @args = (newrdn => $self->get_value('newrdn') || undef,
288                  deleteoldrdn => $self->get_value('deleteoldrdn') || undef);
289      my $newsuperior = $self->get_value('newsuperior');
290      push(@args, newsuperior => $newsuperior)  if $newsuperior;
291      $mesg = $target->moddn($self, @args, callback => $cb, %opt);
292    }
293    elsif (@{$self->{changes}}) {
294      $mesg = $target->modify($self, changes => $self->{changes}, callback => $cb, %opt);
295    }
296    else {
297      require Net::LDAP::Message;
298      $mesg = Net::LDAP::Message->new( $target );
299      $mesg->set_error(LDAP_LOCAL_ERROR, 'No attributes to update');
300    }
301  }
302  elsif (eval { $target->isa('Net::LDAP::LDIF') }) {
303    require Net::LDAP::Message;
304    $target->write_entry($self, %opt);
305    $mesg = Net::LDAP::Message::Dummy->new();
306    $mesg->set_error(LDAP_OTHER, $target->error())
307      if ($target->error());
308  }
309  else {
310    $mesg = Net::LDAP::Message::Dummy->new();
311    $mesg->set_error(LDAP_OTHER, 'illegal update target');
312  }
313
314  return $mesg;
315}
316
317sub ldif {
318  my $self = shift;
319  my %opt = @_;
320
321  require Net::LDAP::LDIF;
322  open(my $fh, '>', \my $buffer);
323  my $change = exists $opt{change} ? $opt{change} : $self->changes ? 1 : 0;
324  my $ldif = Net::LDAP::LDIF->new($fh, 'w', %opt, version => 0, change => $change);
325  $ldif->write_entry($self);
326  return $buffer;
327}
328
329# Just for debugging
330
331sub dump {
332  my $self = shift;
333  no strict 'refs'; # select may return a GLOB name
334  my $fh = @_ ? shift : select;
335
336  my $asn = $self->{asn};
337  print $fh '-' x 72, "\n";
338  print $fh 'dn:', $asn->{objectName}, "\n\n"  if $asn->{objectName};
339
340  my $l = 0;
341
342  for (keys %{ $self->{attrs} ||= _build_attrs($self) }) {
343    $l = length  if length > $l;
344  }
345
346  my $spc = "\n  " . ' ' x $l;
347
348  foreach my $attr (@{$asn->{attributes}}) {
349    my $val = $attr->{vals};
350    printf $fh "%${l}s: ", $attr->{type};
351    my $i = 0;
352    foreach my $v (@$val) {
353      print $fh $spc  if $i++;
354      print $fh $v;
355    }
356    print $fh "\n";
357  }
358}
359
360sub attributes {
361  my $self = shift;
362  my %opt  = @_;
363
364  if ($opt{nooptions}) {
365    my %done;
366    return map {
367      $_->{type} =~ /^([^;]+)/;
368      $done{lc $1}++ ? () : ($1);
369    } @{$self->{asn}{attributes}};
370  }
371  else {
372    return map { $_->{type} } @{$self->{asn}{attributes}};
373  }
374}
375
376sub asn {
377  shift->{asn}
378}
379
380sub changes {
381  my $ref = shift->{changes};
382  $ref ? @$ref : ();
383}
384
3851;
386