source: LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Ad/objects.pm @ 105

package LATMOS::Accounts::Bases::Ad::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 );

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

=head1 NAME

LATMOS::Ad - Perl extension for blah blah blah

=head1 SYNOPSIS

  use LATMOS::Ad;
  blah blah blah

=head1 DESCRIPTION

Stub documentation for LATMOS::Ad, 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 list {
    my ($class, $base) = @_;
    
    my @uids;
    eval {
    my $xx = $base->_unlimited_search(
        attrs => [ $class->_key_attr ],
        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_attr ));
        },
    );
    };

    return @uids;

}

sub _get_field_name {
    my ($self, $field, $base, $for) = @_;

    my %fields = map { $_ => 1 } $self->_canonical_fields($base, $for);

    return $fields{$field} ? $field : undef;
}

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

    $mesg->code and return;

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

    return if(@others); # we cannot have multiple entries...
    return if (!$entry);
    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) {
        warn $mesg->error;
        return;
    } else { return 1 }
}

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) = @_;
    $entry->replace($field, $value);
}

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

    foreach (keys %fields) {
        $self->get_field_name($_, 'w') or next;
        $self->_populate_entry($self->{entry}, $_, $fields{$_});
    }
    
    my $mesg = $self->{entry}->update($self->base->ldap);

    if ($mesg->code) {
        warn $mesg->error;
        return;
    } else { return 1 }
}

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