[Summary view] [Print] [Text view]

   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  
   5  package Net::LDAP::Entry;
   6  
   7  use strict;
   8  use Net::LDAP::ASN qw(LDAPEntry);
   9  use Net::LDAP::Constant qw(LDAP_LOCAL_ERROR);
  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.24";
  21  
  22  sub 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  
  34  sub 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  
  59  sub _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  
  65  sub 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  
  88  sub encode {
  89    $LDAPEntry->encode( shift->{asn} );
  90  }
  91  
  92  
  93  sub dn {
  94    my $self = shift;
  95    @_ ? ($self->{asn}{objectName} = shift) : $self->{asn}{objectName};
  96  }
  97  
  98  sub get_attribute {
  99    require Carp;
 100    Carp::carp("->get_attribute deprecated, use ->get_value") if $^W;
 101    shift->get_value(@_, asref => !wantarray);
 102  }
 103  
 104  sub get {
 105    require Carp;
 106    Carp::carp("->get deprecated, use ->get_value") if $^W;
 107    shift->get_value(@_, asref => !wantarray);
 108  }
 109  
 110  
 111  sub 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  
 119  sub 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  
 142  sub 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  
 153  sub 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  
 177  sub 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  
 214  sub 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  
 259  sub 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  
 296  sub 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  
 327  sub 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  
 343  sub asn {
 344    shift->{asn}
 345  }
 346  
 347  sub changes {
 348    my $ref = shift->{'changes'};
 349    $ref ? @$ref : ();
 350  }
 351  
 352  1;