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