# Copyright (c) 1997-2004 Graham Barr <gbarr@pobox.com>. 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);
use vars qw($VERSION);

use constant CHECK_UTF8 => $] > 5.007;

BEGIN {
  require Encode
    if (CHECK_UTF8);
}


$VERSION = "0.24";

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  = $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;
  }

  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 $ldap = shift;
  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 ($self->{'changetype'} eq 'add') {
    $mesg = $ldap->add($self, 'callback' => $cb, %opt);
  }
  elsif ($self->{'changetype'} eq 'delete') {
    $mesg = $ldap->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 = $ldap->moddn($self, @args, 'callback' => $cb, %opt);
  }
  elsif (@{$self->{'changes'}}) {
    $mesg = $ldap->modify($self, 'changes' => $self->{'changes'}, 'callback' => $cb, %opt);
  }
  else {
    require Net::LDAP::Message;
    $mesg = Net::LDAP::Message->new( $ldap );
    $mesg->set_error(LDAP_LOCAL_ERROR,"No attributes to update");
  }

  return $mesg;
}


# 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($attr,$val);
  my $l = 0;

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

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

  foreach $attr (@{$asn->{attributes}}) {
    $val = $attr->{vals};
    printf $fh "%${l}s: ", $attr->{type};
    my($i,$v);
    $i = 0;
    foreach $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;