Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

353 lines (261 sloc) 7.632 kb
# 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;
Jump to Line
Something went wrong with that request. Please try again.