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

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->top_dn,
        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->top_dn,
    );

    $mesg->code and return;

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

    return if(@others); # we cannot have multiple entries...
    return if (!$entry);
    bless({ entry => $entry }, $class);
}

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

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

    $field eq 'dn' and return $self->{entry}->dn;
    return $self->{entry}->get_value($field);
}

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 return;
        $self->_populate_entry($self->{entry}, $_, $fields{$_});
    }
    
    my $mesg = $self->{entry}->update($self->base->ldap);

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

sub get_group_users {
    my ($self, $groupname, @searchargs) = @_;
    my $gr = $self->get_group($groupname, attrs => [ qw(cn member) ]);

    my @res;
    foreach my $dnu (@{ $gr->get_value('member', asref => 1) || [] }) {
        my $mesg = $self->search(
            filter => '(objectClass=*)', # TODO can we get something else than user ?
            @searchargs,
            base => $dnu,
        );

        $mesg->code and return; # ensure error is propagate here
        foreach my $entry ($mesg->entries) {
           push(@res, $entry);
       } 
    }
    @res
}

sub get_user_groups {
    my ($self, $username, @searchargs) = @_;
    my $user = $self->get_user($username);

    my @res;
    $self->unlimited_search(
        base => $self->top_dn,
        filter => sprintf(
            '(&(objectClass=group)(member=%s))',
            escape_filter_value($user->dn),
        ),
        @searchargs,
        callback => sub {
            my ($mesg, $entry) = @_;
            ref $entry eq 'Net::LDAP::Entry' or return;
            push(@res, $entry);
        },
    );

    @res
}

sub add_user_group {
    my ($self, $username, $groupname) = @_;

    my $user = $self->get_user($username) or return;
    my $group = $self->get_group($groupname) or return;

    $group->add(member => $user->dn);

    my $mesg = $group->update($self);
    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