source: trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Ldap/objects.pm @ 2488

package LATMOS::Accounts::Bases::Ldap::objects;

use 5.010000;
use strict;
use warnings;

use base qw(LATMOS::Accounts::Bases::Objects);
use Net::LDAP;
use Net::LDAP::Entry;
use Net::LDAP::Control::Paged;
use Net::LDAP::Constant qw( LDAP_CONTROL_PAGED ); 
use Net::LDAP::Util     qw( escape_filter_value );
use LATMOS::Accounts::Log;

our $VERSION = (q$Rev: 652 $ =~ /^Rev: (\d+) /)[0];

=head1 NAME

LATMOS::Ldap - Perl extension for blah blah blah

=head1 SYNOPSIS

  use LATMOS::Ldap;
  blah blah blah

=head1 DESCRIPTION

Stub documentation for LATMOS::Ldap, created by h2xs. It looks like the
author of the extension was negligent enough to leave the stub
unedited.

Blah blah blah.

=head1 FUNCTIONS

=cut

sub _get_attr_schema {
    my ($class, $base, $info) = @_;
    $info ||= {};

    foreach (qw(
            createTimestamp
            creatorsName
            entryUUID
            modifiersName
            modifyTimestamp
            entryCSN
            )) {
        $info->{$_} = { ro => 1 };
    }

    $info->{$class->_key_attribute($base)}{ro} = 1;
    $info->{$class->_dn_attribute($base)}{ro} = 1;

    return $info;
}    

sub _key_attribute {
    my ($self, $base) = @_;
    $base ||= $self->base;

    $base->config($self->type . '_key_attribute') || $self->_key_attr || 'cn';
}

sub _dn_attribute {
    my ($self, $base) = @_;
    $base ||= $self->base;

    $base->config($self->type . '_dn_attribute') || $self->_key_attr || 'cn';
}

sub list {
    my ($class, $base) = @_;
    
    my @uids;
    eval {
    my $xx = $base->_unlimited_search(
        attrs => [ $class->_key_attribute($base) ],
        base => $base->object_base_dn($class->type),
        filter => $class->_class_filter,
        callback => sub {
            my ($mesg, $entry) = @_;
            #$mesg->code and die $mesg->error;
            $entry or return;
            ref $entry eq 'Net::LDAP::Entry' or return;
            push(@uids, $entry->get_value( $class->_key_attribute($base) ));
        },
    );
    };

    return @uids;

}

sub new {
    my ($class, $base, $uid) = @_;
    
    my $mesg = $base->ldap->search(
        filter => sprintf(
            '(&%s (%s=%s))',
            $class->_class_filter,
            $class->_key_attribute($base),
            escape_filter_value($uid),
        ),
        base => $base->object_base_dn($class->type),
        attrs => [ $class->_canonical_fields($base, 'r') ],
    );

    if ($mesg->code)  {
        $base->log(LA_ERR, 'Cannot fetch %s/%s: %s', $class->type, $uid, $mesg->code);
        return;
    }

    my ($entry, @others) = $mesg->entries;

    if(@others) { # we cannot have multiple entries...
        $base->la_log(LA_ERR, 'Multiple entry found for %s/%s', $class->type, $uid);
        return;
    }
    if (!$entry) {
        $base->log(LA_DEBUG, 'Cannot fetch %s/%s: no entry returned', $class->type, $uid);
        return;
    }
    bless({ entry => $entry, _base => $base, _id => $uid }, $class);
}

sub _delete {
    my ($class, $base, $uid) = @_;
    my $obj = $class->new($base, $uid) or return;

    my $mesg = $base->ldap->delete($obj->{entry}->dn);

    if ($mesg->code) {
        $base->log(LA_ERR, "Cannot delete object %s: %s", $uid, $mesg->error);
        return;
    } else {
        $base->log(LA_INFO, "Object (%s) %s deleted", $class->type, $uid);
        return 1
    }
}

sub _rename {
    my ($class, $base, $uid, $newuid) = @_;
    my $obj = $class->new($base, $uid) or return;

    my $mesg;

    if ($class->_key_attribute($base) ne
                $class->_dn_attribute($base)) {

        my $entry = $obj->{entry}->clone;
        $entry->add(
            $class->_key_attribute($base),
            $newuid
        );
        $mesg = $entry->update($base->ldap);
        if ($mesg->code && $mesg->code ne 20) {
            $base->log(LA_ERR, "Cannot update key_attribute for object %s: %s", $uid, $mesg->error);
            return;
        }
    }


    $mesg = $base->ldap->moddn(
        $obj->{entry},
        newrdn => $class->_dn_attribute($base) . '=' .  escape_filter_value($newuid),
        deleteoldrdn => 1,
    );
    if ($mesg->code) {
        $base->log(LA_ERR, "Cannot rename object %s: %s", $uid, $mesg->error);
        return;
    }

    $mesg = $base->ldap->search(
        filter => sprintf(
            '(&%s (%s=%s))',
            $class->_class_filter,
            $class->_key_attribute($base),
            escape_filter_value($newuid),
        ),
        base => $base->object_base_dn($class->type),
        attrs => [ $class->_canonical_fields($base, 'r') ],
    );

    if ($mesg->code)  {
        $base->log(LA_ERR, 'Cannot fetch %s/%s: %s', $class->type, $uid, $mesg->code);
        return;
    }

    my ($entry, @others) = $mesg->entries;

    $obj->{entry} = $entry;

    $obj->{entry}->replace(
        $class->_key_attribute($base),
        $newuid
    );
    $mesg = $obj->{entry}->update($base->ldap);

    if ($mesg->code) {
        $base->log(LA_ERR, "Cannot rename object %s: %s", $uid, $mesg->error);
        return;
    } else {
        return 1;
    }
}

=head2 ldap

A shortcut to return the L<Net::LDAP> object

=cut

sub ldap {
    return $_[0]->base->{_ldap};
}

sub get_field {
    my ($self, $field) = @_;

    $field eq 'dn' and return $self->{entry}->dn;
    my ($first, @others) = $self->{entry}->get_value($field);
    return @others ? [ sort($first, @others) ] : $first;
}

sub _populate_entry {
    my ($self, $entry, $field, $value, $base) = @_;
    my $val = ref $self ? $self->get_field($field) : undef;
    my $tr =  join(', ', map { $_ || '' } ($field, $val, $value));
    if ($value) {
        if ((!$val) || $val ne $value) {
            $entry->replace($field, $value);
        }
    } elsif($val) {
        $entry->delete($field);
    }
}

sub _set_c_fields {
    my ($self, %fields) = @_;

    {
        my $oclass = join(',', sort $self->{entry}->get_value('objectClass'));
        my $cclass = join(',', sort $self->_my_ldap_classes);
        if ($oclass ne $cclass) {
            $self->_update_class();
        }
    }

    $self->SUPER::_set_c_fields(%fields);

    my $mesg = $self->{entry}->update($self->base->ldap);

    if ($mesg->code && $mesg->code != 82) {
        $self->base->log(LA_ERR, "Cannot set attributes: %s", $mesg->error);
        return;
    } else { return 1 }
}

sub set_fields {
    my ($self, %fields) = @_;

    foreach (keys %fields) {
        my $attr = $self->attribute($_) or do {
            $self->base->log(LA_ERR, "Unknow attribute %s (%s)",
                $_, $self->type);
            return;
        };
        $attr->ro and next;
        $self->_populate_entry($self->{entry}, $_, $fields{$_});
    }
    
    return 1;
}

sub _update_class {
    my ($self, %attr) = @_;


    $self->base->log(
        LA_NOTICE,
        "Updating ObjectClass for %s/%s: %s",
        $self->type, $self->id, join(', ', $self->_my_ldap_classes)
    );
    $self->base->log(
        LA_NOTICE,
        "Updating ObjectClass Attribute %s",
        join(', ', %attr)
    ) if (%attr);
    $self->{entry}->replace(
        'objectClass' => [ $self->_my_ldap_classes ],
        %attr,
    );
}

1;

__END__

=head1 SEE ALSO

=head1 AUTHOR

Olivier Thauvin, E<lt>olivier.thauvin@aerov.jussieu.frE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2008 CNRS SA/CETP/LATMOS

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.10.0 or,
at your option, any later version of Perl 5 you may have available.


=cut