Net::LDAP::Class - object-relational mapper for Net::LDAP

 # define your class

 package MyLDAPClass;
 use base qw( Net::LDAP::Class );

 __PACKAGE__->metadata->setup(
    attributes          => [qw( name address phone email )],
    unique_attributes   => [qw( email )],
    base_dn             => 'dc=mycompany,dc=com',
 );

 1;

 # then use your class

 use MyLDAPClass;
 use Net::LDAP;

 my $ldap = create_Net_LDAP_object_and_bind();  # you write this

 # create an instance of your class
 my $person = MyLDAPClass->new( ldap => $ldap, email => 'foo@bar.com' );

 # load from LDAP or write if not yet existing
 $person->read or $person->create;

 # set the 'name' attribute
 $person->name( 'Joe Foo' );

 # write your changes 
 $person->update;

 # change your mind?
 $person->delete;

 $nlc->dump;                # same as Data::Dump::dump( $nlc )
 $nlc->ldap_entry->dump;    # see Net::LDAP::Entry dump() method

    perldoc Net::LDAP::Class

package Net::LDAP::Class;

use strict;
use warnings;
use base qw( Rose::Object );
use Carp;
use Data::Dump ();
use Net::LDAP;
use Net::LDAP::Entry;
use Net::LDAP::Control::Paged;
use Net::LDAP::Constant qw(LDAP_CONTROL_PAGED);
use Net::LDAP::Batch;
use Net::LDAP::Class::Metadata;
use Net::LDAP::Class::Iterator;
use Net::LDAP::Class::MultiIterator;
use Net::LDAP::Class::SimpleIterator;

use Net::LDAP::Class::MethodMaker (
    'scalar --get_set_init' => [qw( ldap ldap_entry debug error )],
    'scalar'                => [qw( batch prev_batch )],
    'object_or_class_meta'  => [qw( attributes unique_attributes base_dn )],
);

use overload '""' => 'stringify', 'bool' => sub {1}, 'fallback' => 1;

our $VERSION = '0.26';

sub init {
    my $self = shift;
    $self->SUPER::init(@_);

    my $meta = $self->metadata;
    if ( !$meta or !$meta->is_initialized ) {
        croak
            "must initialize Metadata class before instantiating a new object";
    }

    $self->{ldap} ||= $self->init_ldap;

    if ( !$self->ldap->isa('Net::LDAP') ) {
        croak "ldap value is not a Net::LDAP-derived object";
    }

    return $self;
}

sub metadata_class {'Net::LDAP::Class::Metadata'}

sub metadata {
    my ($self) = shift;

    # object method
    if ( ref $self ) {
        return $self->{_meta}
            ||= $self->metadata_class->for_class( ref $self );
    }

    # class method
    return $Net::LDAP::Class::Metadata::Objects{$self}
        || $self->metadata_class->for_class($self);
}

sub init_ldap {
    my $self = shift;
    if ( !$self->ldap_uri ) {
        croak "must set ldap_uri() or override init_ldap()";
    }

    my $ldap = Net::LDAP->new( $self->ldap_uri )
        or croak "can't create new Net::LDAP: $!";
    my $msg = $ldap->bind() or croak "can't do anonymous LDAP bind: $!";
    if ( $msg->code ) {
        croak "LDAP bind failed: " . $self->get_ldap_error($msg);
    }
    return $ldap;
}

sub init_debug { $ENV{PERL_DEBUG} || $ENV{LDAP_DEBUG} }

sub init_ldap_entry { return undef }

sub get_ldap_error {
    my $self = shift;
    my $msg  = shift or croak "ldap_msg required";
    my $str  = "\n"
        . join( "\n",
        "Return code: " . $msg->code,
        "Message: " . $msg->error_name,
        " :" . $msg->error_text,
        "MessageID: " . $msg->mesg_id,
        "DN: " . $msg->dn,
        ) . "\n";
    return $str;
}

sub stringify {
    my $self = shift;
    for my $key ( @{ $self->unique_attributes } ) {
        my $val = $self->$key;
        return $val if defined $val;
    }
    return $self;
}

sub find {
    my $self  = shift;
    my $class = ref($self) || $self;
    my %opts  = @_;
    my $ldap  = delete $opts{ldap} || $self->ldap;

    if ( !$ldap ) {
        croak "Net::LDAP object required";
    }

    my $base = delete $opts{base_dn} || $self->base_dn;

    if ( !$base ) {
        croak "must indicate base_dn in opts or call as object method";
    }

    my $attr = delete $opts{attrs} || $self->attributes;

    my $msg = $ldap->search(
        base  => $base,
        attrs => $attr,
        %opts,
    );

    if ( $msg->code ) {
        croak $self->get_ldap_error($msg);
    }

    my @results;

    for my $entry ( $msg->entries() ) {
        push(
            @results,
            $class->new(
                ldap       => $ldap,
                ldap_entry => $entry,
            )
        );
    }

    return unless @results;
    return wantarray ? @results : \@results;
}

sub create {
    my $self = shift;
    unless ( $self->check_unique_attributes_set ) {
        croak
            "at least one unique attribute must be set in order to create()";
    }
    my @action = $self->action_for_create(@_) or return;
    $self->do_batch(@action);
    $self->read or croak "cannot read newly created $self";
    return $self;
}

sub read {
    my $self = shift;
    my %opts = @_;

    my ( $filter, $value );

    if ( !$opts{filter} && !$opts{value} ) {

        unless ( $self->check_unique_attributes_set ) {
            croak "cannot read() without unique attribute set. "
                . "Unique attributes include: "
                . join( ', ', @{ $self->unique_attributes } );
        }

        # get first unique key set for filter

        for my $key ( @{ $self->unique_attributes } ) {
            if ( defined $self->$key ) {
                $filter = $key;
                $value  = $self->$key;
                last;
            }
        }

    }
    else {
        $filter = delete $opts{filter};
        $value  = delete $opts{value};
    }

    if ( !defined $filter ) {
        croak "could not find a unique filter to read() on";
    }
    if ( !defined $value ) {
        croak "could not find a unique value to read() on";
    }

    my $base_dn = delete $opts{base_dn} || $self->base_dn;

    $self->debug && warn "read() within $base_dn : $filter=$value\n";

    my $msg = $self->ldap->search(
        base   => $base_dn,
        scope  => "sub",
        filter => "($filter=$value)",
        attrs  => $self->attributes,
    );

    if ( $msg->count() > 0 ) {
        carp "$filter $value exists" if $self->debug;

        my $entry = $msg->entry(0);

        # set any entry attributes we've got cached in $self
        for my $attr ( keys %{ $self->{_not_yet_set} } ) {

            my $new = $self->{_not_yet_set}->{$attr};
            my $old = $entry->get_value($attr) || '';
            if ( $new ne $old ) {
                $entry->replace( $attr,
                    delete $self->{_not_yet_set}->{$attr} );
                $self->{_was_set}->{$attr}->{new} = $new;
                $self->{_was_set}->{$attr}->{old} = $old;
            }
            else {
                delete $self->{_not_yet_set}->{$attr};
            }

        }

        # this will cause any existing entry to be DESTROYed
        $self->ldap_entry($entry);

        return $self;
    }
    else {
        return;
    }
}

sub update {
    my $self = shift;
    $self->check_unique_attributes_set;
    unless ( $self->ldap_entry ) {
        croak "can't update() without first having a Net::LDAP::Entry loaded";
    }
    my @action = $self->action_for_update(@_) or return;

    # clear, since action_for_update() has already used them.
    $self->{_was_set} = {};

    $self->do_batch(@action);

    return $self->read;
}

sub delete {
    my $self = shift;
    $self->check_unique_attributes_set;
    unless ( $self->ldap_entry ) {
        croak "can't delete() without having a Net::LDAP::Entry loaded";
    }
    my @action = $self->action_for_delete or return;
    return $self->do_batch(@action);
}

sub read_or_create {
    my $self = shift;
    if ( !$self->read(@_) ) {
        $self->create(@_);
    }
    return $self;
}

sub save {
    my $self = shift;
    if ( $self->ldap_entry ) {
        $self->update;
    }
    else {
        $self->read_or_create;
    }
    return $self;
}

sub validate {
    my ( $self, $attr, $value ) = @_;
    if ( $self->debug ) {
        warn "validate $attr: $value\n";
    }
    return 1;
}

sub do_batch {
    my $self    = shift;
    my @actions = @_;
    if ( !@actions ) {
        warn "no actions to execute\n";
        return;
    }
    my $batch = $self->batch || Net::LDAP::Batch->new(
        ldap  => $self->ldap,
        debug => $self->debug,
    );
    if ( $self->debug ) {
        warn "Batch: " . Data::Dump::dump($batch);
    }
    $batch->add_actions(@actions);
    $self->prev_batch($batch);
    $batch->do or croak $batch->error;
    return $batch;
}

sub add_to_batch {
    my $self = shift;
    my $batch = $self->batch || Net::LDAP::Batch->new(
        ldap  => $self->ldap,
        debug => $self->debug
    );
    $batch->add_actions(@_);
    $self->batch($batch);
}

sub rollback {
    my $self = shift;
    if ( $self->prev_batch ) {
        $self->prev_batch->rollback or croak $self->prev_batch->error;
    }
    else {
        croak "no prev_batch to rollback";
    }
    return 1;
}

sub action_for_create {
    croak "must override action_for_create()";
}

sub action_for_update {
    croak "must override action_for_update()";
}

sub action_for_delete {
    croak "must override action_for_delete()";
}

sub check_unique_attributes_set {
    my $self = shift;
    my $uk   = $self->unique_attributes;
    if ( !ref($uk) eq 'ARRAY' ) {
        croak "unique_attributes must be an ARRAY ref";
    }
    for my $key (@$uk) {
        if ( defined $self->$key ) {
            return 1;
        }
    }
    return 0;
}

sub AUTOLOAD {
    my ( $self, @args ) = @_;

    my ($attribute) = ( our $AUTOLOAD =~ /([^:]+)$/ );

    #    carp "AUTOLOAD called for "
    #        . ref($self)
    #        . " -> $attribute "
    #        . Data::Dump::dump( \@args );

    if ( $attribute eq 'DESTROY' ) {

        #Data::Dump::dump($self);
        return;
    }

    croak qq[no such attribute or method "$attribute" defined for package "]
        . ref($self)
        . qq[ -- do you need to add '$attribute' to your setup() call?"];
}

sub dump {
    my $self = shift;
    return Data::Dump::dump($self);
}

sub has_local_changes {
    my $self = shift;
    return scalar keys %{ $self->{_was_set} };
}

sub act_on_all {
    my $self    = shift;
    my $coderef = shift or croak "coderef required";
    my $opts    = shift || {};
    my $class   = ref($self) || $self;

    if ( ref $coderef ne 'CODE' ) {
        croak "coderef is not a CODE reference";
    }

    my $filter = $opts->{filter}
        || $self->metadata->unique_attributes->[0] . '=*';
    my $page_size = $opts->{page_size} || 500;

    my $ldap = $opts->{ldap} || $self->ldap;
    my $page = Net::LDAP::Control::Paged->new( size => $page_size );
    my $cookie;
    my @args = (
        'base'    => $self->metadata->base_dn,
        'filter'  => "($filter)",
        'attrs'   => $self->metadata->attributes,
        'control' => [$page],
    );

    my $count = 0;

PAGE: while ( my $ldap_search = $ldap->search(@args) ) {

        # fatal on search error
        croak "error searching ldap: ", $self->get_ldap_error($ldap_search)
            if ( $ldap_search->code );

    ENTRY: while ( my $ldap_entry = $ldap_search->shift_entry ) {

            $count++;

            my $nlc = $class->new(
                ldap       => $ldap,
                ldap_entry => $ldap_entry
            );

            $self->debug and warn sprintf( "%6d %s\n", $count, $nlc );

            $coderef->($nlc);
        }

        # handle next search page
        my ($resp) = $ldap_search->control(LDAP_CONTROL_PAGED) or last PAGE;
        $cookie = $resp->cookie;
        if ( !$cookie ) {
            last PAGE;
        }
        $page->cookie($cookie);

    }

    # be nice to the server and stop the search if we still have a cookie
    if ($cookie) {
        $page->cookie($cookie);
        $page->size(0);
        $ldap->ldap->search(@args);
        croak "LDAP seach ended prematurely.";
    }

    return $count;

}

sub isa_user {
    return shift->isa('Net::LDAP::Class::User');
}

sub isa_group {
    return shift->isa('Net::LDAP::Class::Group');
}

1;

__END__