SPOPS::LDAP - Implement object persistence in an LDAP datastore

 use strict;
 use SPOPS::Initialize;

 # Normal SPOPS configuration

 my $config = {
    class      => 'My::LDAP',
    isa        => [ qw/ SPOPS::LDAP / ],
    field      => [ qw/ cn sn givenname displayname mail
                        telephonenumber objectclass uid ou / ],
    id_field   => 'uid',
    ldap_base_dn => 'ou=People,dc=MyCompany,dc=com',
    multivalue => [ qw/ objectclass / ],
    creation_security => {
                 u => undef,
                 g   => { 3 => 'WRITE' },
                 w   => 'READ',
    },
    track        => { create => 0, update => 1, remove => 1 },
    display      => { url => '/Person/show/' },
    name         => 'givenname',
    object_name  => 'Person',
 };

 # Minimal connection handling...

 sub My::LDAP::global_datasource_handle {
     my $ldap = Net::LDAP->new( 'localhost' );
     $ldap->bind;
     return $ldap;
 }

 # Create the class

 SPOPS::Initialize->process({ config => $config });

 # Search for a group of objects and display information

 my $ldap_filter = '&(objectclass=inetOrgPerson)(mail=*cwinters.com)';
 my $list = My::LDAP->fetch_group({ where => $ldap_filter });
 foreach my $object ( @{ $list } ) {
     print "Name: $object->{givenname} at $object->{mail}\n";
 }

 # The same thing, but with an iterator

 my $ldap_filter = '&(objectclass=inetOrgPerson)(mail=*cwinters.com)';
 my $iter = My::LDAP->fetch_iterator({ where => $ldap_filter });
 while ( my $object = $iter->get_next ) {
     print "Name: $object->{givenname} at $object->{mail}\n";
 }

 # This object has a 'global_datasource_handle' method

 my $object = My::Object->fetch( 'blah' );

 # This object does not

 my $object = Your::Object->fetch( 'blah', { ldap => $ldap });

package SPOPS::LDAP;

# $Id: LDAP.pm,v 3.4 2004/06/02 00:48:21 lachoy Exp $

use strict;
use base qw( SPOPS );
use Log::Log4perl qw( get_logger );
use Data::Dumper     qw( Dumper );
use Net::LDAP        qw();
use Net::LDAP::Entry qw();
use Net::LDAP::Util  qw();
use SPOPS;
use SPOPS::Exception::LDAP;
use SPOPS::Secure    qw( :level );

my $log = get_logger();

$SPOPS::LDAP::VERSION   = sprintf("%d.%02d", q$Revision: 3.4 $ =~ /(\d+)\.(\d+)/);


########################################
# CONFIG
########################################

# LDAP config items available from class/object

sub no_insert                { return $_[0]->CONFIG->{no_insert}   || {}  }
sub no_update                { return $_[0]->CONFIG->{no_update}   || {}  }
sub skip_undef               { return $_[0]->CONFIG->{skip_undef}  || {}  }
sub base_dn {
    unless ( $_[0]->CONFIG->{ldap_base_dn} ) {
        SPOPS::Exception->throw( "No Base DN defined" );
    }
    return $_[0]->CONFIG->{ldap_base_dn};
}
sub id_value_field           { return $_[0]->CONFIG->{id_value_field} }
sub ldap_object_class        { return $_[0]->CONFIG->{ldap_object_class} }
sub ldap_fetch_object_class  { return $_[0]->CONFIG->{ldap_fetch_object_class} }
sub ldap_update_only_changed { return $_[0]->CONFIG->{ldap_update_only_changed} }

sub get_superuser_id         { return $_[0]->CONFIG->{ldap_root_dn} }
sub get_supergroup_id        { return $_[0]->CONFIG->{ldap_root_group_dn} }

sub is_superuser {
    my ( $class, $id ) = @_;
    return ( $id eq $class->get_superuser_id );
}

sub is_supergroup {
    my ( $class, @id ) = @_;
    my $super_gid = $class->get_supergroup_id;
    return grep { $_ eq $super_gid } @id;
}


########################################
# CONNECTION RETRIEVAL
########################################

# Subclass must override -- see POD for info

sub global_datasource_handle { return undef }
sub connection_info          { return undef }


########################################
# CLASS CONFIGURATION
########################################

sub behavior_factory {
    my ( $class ) = @_;
    require SPOPS::ClassFactory::LDAP;
    $log->is_debug &&
        $log->debug( "Installing SPOPS::LDAP behaviors for ($class)" );
    return { read_code => \&SPOPS::ClassFactory::LDAP::conf_read_code,
             has_a     => \&SPOPS::ClassFactory::LDAP::conf_relate_has_a,
             links_to  => \&SPOPS::ClassFactory::LDAP::conf_relate_links_to,
             fetch_by  => \&SPOPS::ClassFactory::LDAP::conf_fetch_by, };

}


########################################
# CLASS INITIALIZATION
########################################

sub class_initialize {
    my ( $class )  = @_;
    $class->_class_initialize;
    return 1;
}

sub _class_initialize {}


########################################
# OBJECT INFO
########################################

sub dn {
    my ( $self, $dn ) = @_;
    unless ( ref $self ) {
        SPOPS::Exception->throw( "Cannot call dn() as class method" );
    }
    $self->{tmp_dn} = $dn if ( $dn );
    return $self->{tmp_dn};
}


########################################
# FETCH
########################################

sub create_id_filter {
    my ( $item, $id ) = @_;
    return join( '=', $item->id_field, $id )  if ( $id );
    unless ( ref $item ) {
        SPOPS::Exception->throw(
               "Cannot create ID filter with a class method call and no ID" );
    }
    return join( '=', $item->id_field, $item->id );
}


# TODO: If the object is requested with a 'filter' argument rather
# than the ID, we might need to fetch the object twice, or perhaps
# fetch the object and create it, and then call 'fetch' again with an
# 'object' argument which we can clone rather than executing the
# actual fetch again. Fetching via filter plays a little havoc with
# the security check and pre_fetch_action -- right now we've
# duct-taped it but it should be fixed shortly...

sub fetch {
    my ( $class, $id, $p ) = @_;
    $p ||= {};
    $log->is_debug &&
        $log->debug( "Trying to fetch an item of $class with ID $id and params ",
                    join " // ",
                    map { $_ . ' -> ' . ( defined( $p->{$_} ) ? $p->{$_} : '' ) }
                          keys %{ $p } );
    return undef unless ( $id or $p->{filter} );

    my $info = $class->_perform_prefetch( $p );

    # Run the search

    my $filter = ( $p->{no_filter} )
                   ? '' : $p->{filter} || $class->create_id_filter( $id );
    my $entry = $class->_fetch_single_entry({ connect_key => $p->{connect_key},
                                              ldap        => $p->{ldap},
                                              base        => $p->{base},
                                              scope       => $p->{scope},
                                              filter      => $filter });
    unless ( $entry ) {
        $log->is_info &&
            $log->info( "No entry found matching object ID ($id)" );
        return undef;
    }
    my $obj = $class->_perform_postfetch( $p, $info, $entry );
    return $obj;
}


sub _perform_prefetch {
    my ( $class, $p, $info ) = @_;
    $info ||= {};

    # If an ID was not passed in but a filter was, we need to delay
    # security checks until after the object has already been fetched
    # so we can grab the ID from the object

    $info->{delay_security_check} = ( ! $p->{id} and $p->{filter} ) ? 1 : 0;

    # Let security errors bubble up

    $info->{level} = $p->{security_level};
    unless ( $info->{delay_security_check} or $p->{skip_security} ) {
        $info->{level} ||= $class->check_action_security({ id       => $p->{id},
                                                           required => SEC_LEVEL_READ });
    }

    # Do any actions the class wants before fetching -- note that if
    # any of the actions returns undef (false), we bail.

    return undef unless ( $class->pre_fetch_action({ %{ $p }, id => $p->{id} }) );
    $log->is_info &&
        $log->info( "Pre fetch actions executed ok" );
    return $info;
}


sub _perform_postfetch {
    my ( $class, $p, $info, $entry ) = @_;
    $log->is_info &&
        $log->info( "Single entry found ok; setting values into object",
                    "(Delay security: $info->{delay_security_check})" );
    my $obj = $class->new({ skip_default_values => 1 });
    $obj->_fetch_assign_row( undef, $entry );
    if ( $info->{delay_security_check} && !  $p->{skip_security} ) {
        $info->{level} ||= $class->check_action_security({ id       => $obj->id,
                                                           required => SEC_LEVEL_READ })
    }
    $obj->_fetch_post_process( $p, $info->{level} );
    return $obj;
}


sub _fetch_single_entry {
    my ( $class, $p ) = @_;
    my $ldap = $p->{ldap} || $class->global_datasource_handle( $p->{connect_key} );
    $log->is_info &&
        $log->info( "Base DN (", $class->base_dn( $p->{connect_key} ), ")",
                    "and filter <<$p->{filter}>> being used to fetch single object" );
    my %args = ( base   => $p->{base} || $class->base_dn( $p->{connect_key} ),
                 scope  => $p->{scope} || 'sub' );
    $args{filter} = $p->{filter} if ( $p->{filter} );
    my $ldap_msg = $ldap->search( %args );
    $class->_check_error( $ldap_msg, 'fetch' );

    # Go ahead and use $count here since we've hopefully only
    # retrieved a single record and don't have to worry about blocking
    # (etc.) for a long time

    my $count = $ldap_msg->count;
    if ( $count > 1 ) {
        SPOPS::Exception::LDAP->throw( "Trying to retrieve unique record, retrieved [$count]",
                                       { filter => $p->{filter} } );
    }
    if ( $count == 0 ) {
        $log->is_info &&
            $log->info( "No entry found matching filter ($p->{filter})" );
        return undef;
    }
    return $ldap_msg->entry( 0 );
}


# Given a DN, return an object

sub fetch_by_dn {
    my ( $class, $dn, $p ) = @_;
    $p->{base}   = $dn;
    $p->{scope}  = 'base';
    $p->{filter} = '(objectclass=*)';
    return $class->fetch( undef, $p );
}


# Return implementation of SPOPS::Iterator with results

sub fetch_iterator {
    my ( $class, $p ) = @_;
    require SPOPS::Iterator::LDAP;
    $log->is_info &&
        $log->info( "Trying to create an Iterator with: ", Dumper( $p ) );
    $p->{class}                    = $class;
    ( $p->{offset}, $p->{max} )    = SPOPS::Utility->determine_limit( $p->{limit} );
    unless ( ref $p->{id_list} ) {
        $p->{ldap_msg} = $class->_execute_multiple_record_query( $p );
        $class->_check_error( $p->{ldap_msg}, 'fetch_iterator' );
    }
    return SPOPS::Iterator::LDAP->new( { %{ $p }, skip_default_values => 1 });
}


# Given a filter, return an arrayref of objects

sub fetch_group {
    my ( $class, $p ) = @_;
    my ( $offset, $max ) = SPOPS::Utility->determine_limit( $p->{limit} );
    my $ldap_msg = $class->_execute_multiple_record_query( $p );
    $class->_check_error( $ldap_msg, 'fetch_group' );

    my $entry_count = 0;
    my @group = ();
ENTRY:
    while ( my $entry = $ldap_msg->shift_entry ) {
        my $obj = $class->new({ skip_default_values => 1 });
        $obj->_fetch_assign_row( undef, $entry );
        my $level = ( $p->{skip_security} )
                      ? SEC_LEVEL_WRITE
                      : eval { $obj->check_action_security({ required => SEC_LEVEL_READ }) };
        if ( $@ ) {
            $log->is_info &&
                $log->info( "Security check for object (", $obj->dn, ")",
                            "in fetch_group() failed, skipping." );
            next ENTRY;
        }

        if ( $offset and ( $entry_count < $offset ) ) {
            $entry_count++;
            next ENTRY
        }
        last ENTRY if ( $max and ( $entry_count >= $max ) );
        $entry_count++;

        $obj->_fetch_post_process( $p, $level );
        push @group, $obj;
    }
    return \@group;
}


sub _execute_multiple_record_query {
    my ( $class, $p ) = @_;
    my $filter = $p->{where} || $p->{filter} || '';

    # If there is a filter, be sure it's in ()
    if ( $filter and $filter !~ /^\(.*\)$/ ) {
        $filter = "($filter)";
    }

    # Specify an object class in the filter if the filter doesn't
    # already specify an object class and our config says we should

    if ( ( my $fetch_oc = $class->ldap_fetch_object_class ) and $filter !~ /objectclass/ ) {
        my $oc_filter = "(objectclass=$fetch_oc)";
        $log->is_debug &&
            $log->debug( "Adding filter for object class ($fetch_oc)" );
        $filter = ( $filter ) ? "(&$oc_filter$filter)" : $oc_filter;
    }
    my $ldap = $p->{ldap} || $class->global_datasource_handle( $p->{connect_key} );
    $log->is_info &&
        $log->info( "Base DN (", $class->base_dn( $p->{connect_key} ), ")\nFilter <<$filter>>\n",
                    "being used to fetch one or more objects" );
    return $ldap->search( base   => $class->base_dn( $p->{connect_key} ),
                          scope  => 'sub',
                          filter => $filter );
}


sub _fetch_assign_row {
    my ( $self, $field_list, $entry ) = @_;
    $log->is_info &&
        $log->info( "Setting data from row into", ref $self, "using DN of entry ", $entry->dn  );
    $self->clear_all_loaded();
    my $CONF = $self->CONFIG;
    $field_list ||= $self->field_list;
    foreach my $field ( @{ $field_list } ) {
        my @values = $entry->get_value( $field );
        if ( $CONF->{multivalue}{ $field } ) {
            $self->{ $field } = \@values;
            $log->is_info &&
                $log->info( sprintf( " ( multi) %-20s --> %s", $field, join( '||', @values ) ) );
        }
        else {
            $self->{ $field } = $values[0];
            $log->is_info &&
                $log->info( sprintf( " (single) %-20s --> %s", $field, $values[0] ) );
        }
        $self->set_loaded( $field );
    }
    $self->dn( $entry->dn );
    return $self;
}


sub _fetch_post_process {
    my ( $self, $p, $security_level ) = @_;

    # Create an entry for this object in the cache unless either the
    # class or this call to fetch() doesn't want us to.

    $self->set_cached_object( $p );

    # Execute any actions the class (or any parent) wants after
    # creating the object (see SPOPS.pm)

    return undef unless ( $self->post_fetch_action( $p ) );

    # Set object flags

    $self->clear_change;
    $self->has_save;

    # Set the security fetched from above into this object
    # as a temporary property (see SPOPS::Tie for more info
    # on temporary properties); note that this is set whether
    # we retrieve a cached copy or not

    $self->{tmp_security_level} = $security_level;
    $log->is_info &&
        $log->info( ref $self, "(", $self->id, ") : cache set (if available),",
                    "post_fetch_action() done, change flag cleared and save ",
                    "flag set. Security: $security_level" );
    return $self;
}


########################################
# SAVE
########################################

sub save {
    my ( $self, $p ) = @_;
    my $id = $self->id;
    $log->is_info &&
        $log->info( "Trying to save a (", ref $self, ") with ID ($id)" );

    # We can force save() to be an INSERT by passing in a true value
    # for the is_add parameter; otherwise, we rely on the flag within
    # SPOPS::Tie to reflect whether an object has been saved or not.

    my $is_add = ( $p->{is_add} or ! $self->saved );

    # If this is an update and it hasn't changed, we don't need to do
    # anything.

    unless ( $is_add or $self->changed ) {
        $log->is_info &&
            $log->info( "This object exists and has not changed. Exiting." );
        return $self;
    }

    # Check security for create/update

    my ( $level );
    unless ( $p->{skip_security} ) {
        $level = $self->check_action_security({ required => SEC_LEVEL_WRITE,
                                                is_add   => $is_add });
    }
    $log->is_info &&
        $log->info( "Security check passed ok. Continuing." );

    # Callback for objects to do something before they're saved

    return undef unless ( $self->pre_save_action({ %{ $p },
                                                   is_add => $is_add }) );

    # Do the insert/update based on whether the object is new; don't
    # catch the die() that might be thrown -- let that percolate

    if ( $is_add ) { $self->_save_insert( $p )  }
    else           { $self->_save_update( $p )  }

    # Do any actions that need to happen after you save the object

    return undef unless ( $self->post_save_action({ %{ $p },
                                                    is_add => $is_add }) );
    $log->is_info &&
        $log->info( "Post save action executed ok." );

    # Save the newly-created/updated object to the cache

    $self->set_cached_object( $p );

    # Note the action that we've just taken (opportunity for subclasses)

    my $action = ( $is_add ) ? 'create' : 'update';
    unless ( $p->{skip_log} ) {
        $self->log_action( $action, $self->id );
    }

    # Set object flags and we're done

    $self->has_save;
    $self->clear_change;
    return $self;
}


sub _save_insert {
    my ( $self, $p ) = @_;
    $p ||= {};
    $log->is_info &&
        $log->info( 'Treating save as INSERT' );
    my $ldap = $p->{ldap} || $self->global_datasource_handle( $p->{connect_key} );
    $self->dn( $self->build_dn );
    my $num_objectclass = ( ref $self->{objectclass} )
                            ? @{ $self->{objectclass} } : 0;
    if ( $num_objectclass == 0 ) {
        $self->{objectclass} = $self->ldap_object_class;
        $log->is_info &&
            $log->info( "Using object class from config in new object (",
                        join( ', ', @{ $self->{objectclass} } ), ")" );
    }
    $log->is_info &&
        $log->info( "Trying to create record with DN: (", $self->dn, ")" );
    my %insert_data = ();

    $p->{no_insert} ||= [];
    my $no_insert = $self->no_insert;
    map { $no_insert->{ $_ } = 1 } @{ $p->{no_insert} };
    $p->{skip_undef} ||= [];
    my $skip_undef = $self->skip_undef;
    map { $skip_undef->{ $_ } = 1 } @{ $p->{skip_undef} };

    foreach my $attr ( @{ $self->field_list } ) {
        next if ( $no_insert->{ $attr } );
        next if ( $skip_undef->{ $attr } and ! defined $self->{ $attr } );
        $insert_data{ $attr } = $self->{ $attr };

        # Trick LDAP to creating object with multivalue property that
        # has no values

        if ( ref $insert_data{ $attr } eq 'ARRAY'
             and scalar @{ $insert_data{ $attr } } == 0 ) {
            $insert_data{ $attr } = undef;
        }
    }
    $log->is_info &&
        $log->info( "Trying to create a record with:\n", Dumper( \%insert_data ) );
    my $ldap_msg = $ldap->add( dn   => $self->dn,
                               attr => [ %insert_data ]);
    $self->_check_error( $ldap_msg, 'save' );
    $log->is_info &&
        $log->info( "Record created ok." );
}


sub _save_update {
    my ( $self, $p ) = @_;
    $p ||= {};
    $log->is_info &&
        $log->info( "Treating save as UPDATE with DN: (", $self->dn, ")" );
    my $ldap = $p->{ldap} || $self->global_datasource_handle( $p->{connect_key} );
    my $entry = $self->_fetch_single_entry({ filter => $self->create_id_filter,
                                             ldap   => $ldap });
    $log->is_info &&
        $log->info( "Loaded entry for update:\n", Dumper( $entry ) );
    $p->{no_update} ||= [];
    my $no_update  = $self->no_update;
    map { $no_update->{ $_ } = 1 } @{ $p->{no_update} };
    $p->{skip_undef} ||= [];
    my $skip_undef = $self->skip_undef;
    map { $skip_undef->{ $_ } = 1 } @{ $p->{skip_undef} };

    my $only_changed = $self->ldap_update_only_changed;

ATTRIB:
    foreach my $attr ( @{ $self->field_list } ) {
        next ATTRIB if ( $no_update->{ $attr } );
        my $object_value = $self->{ $attr };
        next ATTRIB if ( $skip_undef->{ $attr } and ! defined $object_value );
        if ( $only_changed ) {
            my @existing_values = $entry->get_value( $attr );
            $log->is_info &&
                $log->info( "Toggle for updating only changed values set.",
                            "Checking if ($attr) different: ", Dumper( $object_value ),
                            "vs.", Dumper( \@existing_values ) );
            next ATTRIB if ( $self->_values_are_same( $object_value, \@existing_values ) );
            $log->is_info &&
                $log->info( "Values for ($attr) are different. Updating..." );
        }

        # Trick LDAP to updating object with multivalue property that
        # has no values

        if ( ref $object_value eq 'ARRAY' and scalar @{ $object_value } == 0 ) {
            $object_value = undef;
        }
        $entry->replace( $attr, $object_value );
    }
    $log->is_info &&
        $log->info( "Entry before Update:\n", Dumper( $entry ) );
    my $ldap_msg = $entry->update( $ldap );
    $self->_check_error( $ldap_msg, 'save' );
    $log->is_info &&
        $log->info( "Record updated ok." );
}


# Return true if the two values are the same, false if not.

sub _values_are_same {
    my ( $self, $val1, $val2 ) = @_;
    $val1 = ( ref $val1 ) ? $val1 : [ $val1 ];
    $val2 = ( ref $val2 ) ? $val2 : [ $val2 ];
    my %v1 = map { $_ => 1 } @{ $val1 };
    my %v2 = map { $_ => 1 } @{ $val2 };
    foreach my $field ( keys %v1 ) {
        return undef unless ( $v2{ $field } );
    }
    foreach my $field ( keys %v2 ) {
        return undef unless ( $v1{ $field } );
    }
    return 1;
}


########################################
# REMOVE
########################################

sub remove {
    my ( $self, $p ) = @_;

    # Don't remove it unless it's been saved already

    return undef   unless ( $self->is_saved );

    my $level = SEC_LEVEL_WRITE;
    unless ( $p->{skip_security} ) {
        $level = $self->check_action_security({ required => SEC_LEVEL_WRITE });
    }

    $log->is_info &&
        $log->info( "Security check passed ok. Continuing." );

    # Allow members to perform an action before getting removed

    return undef unless ( $self->pre_remove_action( $p ) );

    # Do the removal, building the where clause if necessary

    my $id = $self->id;
    my $dn = $self->dn;
    my $ldap = $p->{ldap} || $self->global_datasource_handle( $p->{connect_key} );;
    my $ldap_msg = $ldap->delete( $dn );
    $self->_check_error( $ldap_msg, 'remove' );

    # Otherwise...
    # ... remove this item from the cache

    if ( $self->use_cache( $p ) ) {
        $self->global_cache->clear({ data => $self });
    }

    # ... execute any actions after a successful removal

    return undef unless ( $self->post_remove_action( $p ) );

    # ... and log the deletion

    $self->log_action( 'delete', $id ) unless ( $p->{skip_log} );

    # Clear flags

    $self->clear_change;
    $self->clear_save;
    return 1;
}


########################################
# INTERNAL METHODS
########################################

# Error consolidation routine

sub _check_error {
    my ( $class, $ldap_msg, $action ) = @_;
    my $code = $ldap_msg->code;
    return undef unless ( $code );
    SPOPS::Exception::LDAP->throw(
               Net::LDAP::Util::ldap_error_desc( $code ),
               { code       => $code,
                 action     => $action,
                 error_name => Net::LDAP::Util::ldap_error_name( $code ),
                 error_text => Net::LDAP::Util::ldap_error_text( $code ) } );
}


# Build the full DN

sub build_dn {
    my ( $item, $p ) = @_;
    my $base_dn        = $p->{base_dn}  || $item->base_dn( $p->{connect_key} );
    my $id_field       = $p->{id_field} || $item->id_field;
    my $id_value_field = $p->{id_value_field} || $item->id_value_field;
    my $id_value       = $p->{id};
    unless ( $id_value ) {
        unless ( ref $item ) {
            SPOPS::Exception->throw(
                    "Cannot create DN for object without an ID value as " .
                    "parameter when called as class method" );
        }
        $id_value = $item->{ $id_value_field } || $item->id;
        unless ( $id_value ) {
            SPOPS::Exception->throw(
                    "Cannot create DN for object without an ID value" );
        }
    }
    unless ( $id_field and $id_value and $base_dn ) {
        SPOPS::Exception->throw(
                    "Cannot create Base DN without all parts: ",
                    "field: [$id_field]; ID: [$id_value]; BaseDN: [$base_dn]" );
    }
    return join( ',', join( '=', $id_field, $id_value ), $base_dn );
}

1;

__END__