File Coverage

blib/lib/Net/LDAP/Entry.pm

Criterion	Covered	Total	%
statement	128	229	55.9
branch	61	124	49.1
condition	12	37	32.4
subroutine	19	28	67.8
pod	13	19	68.4
total	233	437	53.3

# Copyright (c) 1997-2004 Graham Barr . All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package Net::LDAP::Entry;

use strict;
use Net::LDAP::ASN qw(LDAPEntry);
use Net::LDAP::Constant qw(LDAP_LOCAL_ERROR LDAP_OTHER);

use constant CHECK_UTF8 => $] > 5.007;

BEGIN {
  require Encode
    if (CHECK_UTF8);
}

our $VERSION = '0.29';

sub new {
  my $self = shift;
  my $type = ref($self) || $self;

  my $entry = bless { changetype => 'add', changes => [] }, $type;

  @_ and $entry->dn( shift );
  @_ and $entry->add( @_ );

  return $entry;
}

sub clone {
  my $self  = shift;
  my $clone = $self->new();

  $clone->dn($self->dn());
  foreach ($self->attributes()) {
    $clone->add($_ => [$self->get_value($_)]);
  }

  $clone->{changetype} = $self->{changetype};
  my @changes = @{$self->{changes}};
  while (my($action, $cmd) = splice(@changes, 0, 2)) {
    my @new_cmd;
    my @cmd = @$cmd;
    while (my($type, $val) = splice(@cmd, 0, 2)) {
      push @new_cmd, $type, [ @$val ];
    }
    push @{$clone->{changes}}, $action, \@new_cmd;
  }

  $clone;
}

# Build attrs cache, created when needed

sub _build_attrs {
  +{ map { (lc($_->{type}), $_->{vals}) }  @{$_[0]->{asn}{attributes}} };
}

# If we are passed an ASN structure we really do nothing

sub decode {
  my $self = shift;
  my $result = ref($_[0]) ? shift : $LDAPEntry->decode(shift)
    or return;
  my %arg = @_;

  %{$self} = ( asn => $result, changetype => 'modify', changes => []);

  if (CHECK_UTF8 && $arg{raw}) {
    $result->{objectName} = Encode::decode_utf8($result->{objectName})
      if ('dn' !~ /$arg{raw}/);

    foreach my $elem (@{$self->{asn}{attributes}}) {
      map { $_ = Encode::decode_utf8($_) } @{$elem->{vals}}
        if ($elem->{type} !~ /$arg{raw}/);
    }
  }

  $self;
}



sub encode {
  $LDAPEntry->encode( shift->{asn} );
}


sub dn {
  my $self = shift;
  @_ ? ($self->{asn}{objectName} = shift) : $self->{asn}{objectName};
}

sub get_attribute {
  require Carp;
  Carp::carp('->get_attribute deprecated, use ->get_value')  if $^W;
  shift->get_value(@_, asref => !wantarray);
}

sub get {
  require Carp;
  Carp::carp('->get deprecated, use ->get_value')  if $^W;
  shift->get_value(@_, asref => !wantarray);
}


sub exists {
  my $self = shift;
  my $type = lc(shift);
  my $attrs = $self->{attrs} ||= _build_attrs($self);

  exists $attrs->{$type};
}

sub get_value {
  my $self = shift;
  my $type = lc(shift);
  my %opt  = @_;

  if ($opt{alloptions}) {
    my %ret = map {
                $_->{type} =~ /^\Q$type\E((?:;.*)?)$/i ? (lc($1), $_->{vals}) : ()
              } @{$self->{asn}{attributes}};
    return %ret ? \%ret : undef;
  }

  my $attrs = $self->{attrs} ||= _build_attrs($self);
  my $attr;

  if ($opt{nooptions}) {
    my @vals = map {
                 $_->{type} =~ /^\Q$type\E((?:;.*)?)$/i ? @{$_->{vals}} : ()
               } @{$self->{asn}{attributes}};

    return  unless @vals;

    $attr = \@vals;
  }
  else {
    $attr = $attrs->{$type} or return;
  }

  return $opt{asref}
	  ? $attr
	  : wantarray
	    ? @{$attr}
	    : $attr->[0];
}


sub changetype {

  my $self = shift;
  return $self->{changetype}  unless @_;
  $self->{changes} = [];
  $self->{changetype} = shift;
  return $self;
}



sub add {
  my $self  = shift;
  my $cmd   = $self->{changetype} eq 'modify' ? [] : undef;
  my $attrs = $self->{attrs} ||= _build_attrs($self);

  while (my($type, $val) = splice(@_, 0, 2)) {
    my $lc_type = lc $type;

    push @{$self->{asn}{attributes}}, { type => $type, vals => ($attrs->{$lc_type}=[])}
      unless exists $attrs->{$lc_type};

    push @{$attrs->{$lc_type}}, ref($val) ? @$val : $val;

    push @$cmd, $type, [ ref($val) ? @$val : $val ]
      if $cmd;

  }

  push(@{$self->{changes}}, 'add', $cmd)  if $cmd;

  return $self;
}


sub replace {
  my $self  = shift;
  my $cmd   = $self->{changetype} eq 'modify' ? [] : undef;
  my $attrs = $self->{attrs} ||= _build_attrs($self);

  while (my($type, $val) = splice(@_, 0, 2)) {
    my $lc_type = lc $type;

    if (defined($val) and (!ref($val) or @$val)) {

      push @{$self->{asn}{attributes}}, { type => $type, vals => ($attrs->{$lc_type}=[])}
	unless exists $attrs->{$lc_type};

      @{$attrs->{$lc_type}} = ref($val) ? @$val : ($val);

      push @$cmd, $type, [ ref($val) ? @$val : $val ]
	if $cmd;

    }
    else {
      delete $attrs->{$lc_type};

      @{$self->{asn}{attributes}}
	= grep { $lc_type ne lc($_->{type}) } @{$self->{asn}{attributes}};

      push @$cmd, $type, []
	if $cmd;

    }
  }

  push(@{$self->{changes}}, 'replace', $cmd)  if $cmd;

  return $self;
}


sub delete {
  my $self = shift;

  unless (@_) {
    $self->changetype('delete');
    return $self;
  }

  my $cmd = $self->{changetype} eq 'modify' ? [] : undef;
  my $attrs = $self->{attrs} ||= _build_attrs($self);

  while (my($type, $val) = splice(@_, 0, 2)) {
    my $lc_type = lc $type;

    if (defined($val) and (!ref($val) or @$val)) {
      my %values;
      @values{(ref($val) ? @$val : $val)} = ();

      unless (@{$attrs->{$lc_type}}
              = grep { !exists $values{$_} } @{$attrs->{$lc_type}})
      {
	delete $attrs->{$lc_type};
	@{$self->{asn}{attributes}}
	  = grep { $lc_type ne lc($_->{type}) } @{$self->{asn}{attributes}};
      }

      push @$cmd, $type, [ ref($val) ? @$val : $val ]
	if $cmd;
    }
    else {
      delete $attrs->{$lc_type};

      @{$self->{asn}{attributes}}
	= grep { $lc_type ne lc($_->{type}) } @{$self->{asn}{attributes}};

      push @$cmd, $type, []  if $cmd;
    }
  }

  push(@{$self->{changes}}, 'delete', $cmd)  if $cmd;

  return $self;
}


sub update {
  my $self = shift;
  my $target = shift;	# a Net::LDAP or a Net::LDAP::LDIF object
  my %opt = @_;
  my $mesg;
  my $user_cb = delete $opt{callback};
  my $cb = sub { $self->changetype('modify')  unless $_[0]->code;
                 $user_cb->(@_)  if $user_cb };

  if (eval { $target->isa('Net::LDAP') }) {
    if ($self->{changetype} eq 'add') {
      $mesg = $target->add($self, callback => $cb, %opt);
    }
    elsif ($self->{changetype} eq 'delete') {
      $mesg = $target->delete($self, callback => $cb, %opt);
    }
    elsif ($self->{changetype} =~ /modr?dn/o) {
      my @args = (newrdn => $self->get_value('newrdn') || undef,
                  deleteoldrdn => $self->get_value('deleteoldrdn') || undef);
      my $newsuperior = $self->get_value('newsuperior');
      push(@args, newsuperior => $newsuperior)  if $newsuperior;
      $mesg = $target->moddn($self, @args, callback => $cb, %opt);
    }
    elsif (@{$self->{changes}}) {
      $mesg = $target->modify($self, changes => $self->{changes}, callback => $cb, %opt);
    }
    else {
      require Net::LDAP::Message;
      $mesg = Net::LDAP::Message->new( $target );
      $mesg->set_error(LDAP_LOCAL_ERROR, 'No attributes to update');
    }
  }
  elsif (eval { $target->isa('Net::LDAP::LDIF') }) {
    require Net::LDAP::Message;
    $target->write_entry($self, %opt);
    $mesg = Net::LDAP::Message::Dummy->new();
    $mesg->set_error(LDAP_OTHER, $target->error())
      if ($target->error());
  }
  else {
    $mesg = Net::LDAP::Message::Dummy->new();
    $mesg->set_error(LDAP_OTHER, 'illegal update target');
  }

  return $mesg;
}

sub ldif {
  my $self = shift;
  my %opt = @_;

  require Net::LDAP::LDIF;
  open(my $fh, '>', \my $buffer);
  my $change = exists $opt{change} ? $opt{change} : $self->changes ? 1 : 0;
  my $ldif = Net::LDAP::LDIF->new($fh, 'w', %opt, version => 0, change => $change);
  $ldif->write_entry($self);
  return $buffer;
}

# Just for debugging

sub dump {
  my $self = shift;
  no strict 'refs'; # select may return a GLOB name
  my $fh = @_ ? shift : select;

  my $asn = $self->{asn};
  print $fh '-' x 72, "\n";
  print $fh 'dn:', $asn->{objectName}, "\n\n"  if $asn->{objectName};

  my $l = 0;

  for (keys %{ $self->{attrs} ||= _build_attrs($self) }) {
    $l = length  if length > $l;
  }

  my $spc = "\n  " . ' ' x $l;

  foreach my $attr (@{$asn->{attributes}}) {
    my $val = $attr->{vals};
    printf $fh "%${l}s: ", $attr->{type};
    my $i = 0;
    foreach my $v (@$val) {
      print $fh $spc  if $i++;
      print $fh $v;
    }
    print $fh "\n";
  }
}

sub attributes {
  my $self = shift;
  my %opt  = @_;

  if ($opt{nooptions}) {
    my %done;
    return map {
      $_->{type} =~ /^([^;]+)/;
      $done{lc $1}++ ? () : ($1);
    } @{$self->{asn}{attributes}};
  }
  else {
    return map { $_->{type} } @{$self->{asn}{attributes}};
  }
}

sub asn {
  shift->{asn}
}

sub changes {
  my $ref = shift->{changes};
  $ref ? @$ref : ();
}

1;