File Coverage

blib/lib/Net/LDAP/Express.pm

Criterion	Covered	Total	%
statement	29	176	16.4
branch	1	76	1.3
condition	1	11	9.0
subroutine	9	22	40.9
pod	9	9	100.0
total	49	294	16.6

package Net::LDAP::Express;

use 5.006;
use strict;
use warnings;

our $VERSION = '0.12';

use Carp ;

use base 'Net::LDAP' ;
use constant DEBUG => 0 ;

# Preloaded methods go here.
sub new {
  my $class  = shift ;
  my %args = @_ ;

  croak "Not an object method" if ref $class ;

  my %myParms = _new_parms() ;
  my @myParmNames = keys %myParms ;
  foreach my $parm (grep $myParms{$_} eq 'req',@myParmNames) {
    croak "$parm parameter is required" unless $args{$parm} ;
  }

  my $host = $args{host} ;

  # Keep parameters that are local to this class, and pass to
  # Net::LDAP::new all the rest
  my %localparms ;
  @localparms{@myParmNames} =
    delete @args{@myParmNames} ;

  # Test for onlyattrs not overlapping with searchextras; in
  # case they do, warn
  if (defined $localparms{onlyattrs} and
      defined $localparms{searchextras}) {
    carp "Useless use of parameter onlyattrs with searchextras" if $^W ;
  }

  # try connection
  my $ldap = $class->SUPER::new($host,%args) ;
  croak "Cannot connect to $host: $@" if $@ ;

  # bind if necessary
  if ($localparms{bindDN}) {
    my @bindArgs = ($localparms{bindDN}) ;
    push @bindArgs,('password',$localparms{bindpw})
      if defined $localparms{bindpw} ;
    my $msg = $ldap->bind(@bindArgs) ;
    if ($msg->is_error) {
      $ldap->_seterr($msg) ;
      croak "Cannot bind: ".$msg->error ;
    }
  }

  # Prepare object and return
  ##! I should use accessors here... maybe building a code string
  ##! and then passing it to eval.
  while (my ($parm,$value) = each %localparms) {
    $ldap->{"net_ldap_express_$parm"} = $value ;
  }
  return $ldap ;
}

{
  my @lasterr   = (0,'') ;
  my %errcache = @lasterr ;
  sub error   { return $lasterr[1] }
  sub errcode { return $lasterr[0] }
  sub _seterr {
    my $ldap = shift ;
    # _seterr sets error code an name in the error cache
    # If it is passed one argument, then it should be an object in the
    # Net::LDAP::Message class
    # If it is passed two arguments, then they are an error code and
    # an error name respectively

    # Redefine @_ if $_[0] is a Net::LDAP::Message
    if (ref $_[0]) {
      my $msg = shift ;
      @_ = ($msg->code,$msg->error) ;
    }
    # Get error code
    $lasterr[0] = shift ;

    # Update cache, if needed
    $errcache{$lasterr[0]} = shift unless exists $errcache{$lasterr[0]} ;

    # Get error message from cache
    $lasterr[1] = $errcache{$lasterr[0]} ;

    carp "LDAP ERROR @lasterr" if $^W;

    return @lasterr ;
  }
}

sub add_many {
  my $ldap = shift ;
  my @parms = @_ ;
  my $msg ;

  # Iterate over the entries, return those that succeeded
  my @success ;
  while (my $e = shift @parms) {
    eval { $e->isa('Net::LDAP::Entry') } ;
    if ($@) {
      carp "Invalid input: $@" if $^W ;
      $ldap->_seterr(-1,'Invalid input') ;
      return \@success ;
    }

    $msg = $ldap->SUPER::add($e) ;
    if ($msg->is_error) {
      $ldap->_seterr($msg) ;
      return \@success ;
    }
    push @success,$e ;
  }

  $ldap->_seterr(0) ;
  return \@success ;
}

sub delete_many {
  my $ldap = shift ;
  my @parms = @_ ;
  my $msg ;

  my @success ;
  while (my $e = shift @parms) {
    eval { $e->isa('Net::LDAP::Entry') } ;
    if ($@) {
      carp "Invalid input: $@" if $^W ;
      $ldap->_seterr(-1,'Invalid input') ;
      return \@success ;
    }

    $msg = $ldap->SUPER::delete($e) ;
    if ($msg->is_error) {
      $ldap->_seterr($msg) ;
      return \@success ;
    }

    push @success,$e ;
  }

  $ldap->_seterr(0) ;
  return \@success ;
}

sub search {
  my $ldap = shift ;
  my $query ;

  # If search is passed an odd number of parameters, we assume that
  # the first is a query string; anyway, we'll override it if a
  # "filter" parameter is specified
  if (@_%2) {
    $query = shift ;
  }

  # Load defaults from _makesearchparms, override them with the values
  # in @_.
  my %parms = ($ldap->_makesearchparms,@_) ;

  # What about filters?
  $parms{filter} ||= $ldap->_makefilter($query) ;

  return $ldap->SUPER::search(%parms) ;
}

sub simplesearch {
  my $ldap    = shift ;
  my ($query) = @_ ;
  my %parms = $ldap->_makesearchparms;

  # Set filter
  $parms{filter} = $ldap->_makefilter($query) ;

  my $msg = $ldap->SUPER::search(%parms) ;
  if ($msg->is_error) {
    $ldap->_seterr($msg) ;
    return undef ;
  }

  $ldap->_seterr(0) ;

  return $ldap->_sort_by ?
    [$msg->sorted(@{$ldap->_sort_by})] :
      [$msg->entries] ;
}


sub rename {
  my $ldap = shift ;
  my ($e,$rdn) = @_ ;

  my $msg = $ldap->moddn($e,
			 newrdn       => $rdn,
			 deleteoldrdn => 'yes') ;
  if ($msg->is_error) {
    $ldap->_seterr($msg) ;
    return undef ;
  }

  return $ldap->_seterr(0) ;
  return $e ;
}


sub update {
  my $ldap  = shift ;
  my @parms = @_ ;
  my @success ;
  my $msg ;

  while (my $e = shift @parms) {
    eval { $e->isa('Net::LDAP::Entry') } ;
    if ($@) {
      carp "Invalid input: $@" if $^W ;
      $ldap->_seterr(-1,'Invalid input') ;
      return \@success ;
    }

    $msg = $e->update($ldap) ;

    if ($msg->is_error) {
      # Don't complain if error code is 82
      # (that means: the entry hasn't been modified)
      unless ($msg->code == 82) {
	$ldap->_seterr($msg) ;
	return \@success ;
      }
    }

    push @success,$e ;
  }

  $ldap->_seterr(0) ;
  return \@success ;
}


########################################################################
# These methods should be considered PRIVATE!
BEGIN {
  sub _new_parms {
    return (
	    host         => 'req',
	    base         => 'req',
	    searchattrs  => 'req',
	    bindDN       => 'opt',
	    bindpw       => 'opt',
	    searchbool   => 'opt',
	    searchmatch  => 'opt',
	    searchextras => 'opt',
	    onlyattrs    => 'opt',
	    sort_by      => 'opt',
	   )
  }

  carp __PACKAGE__.": Dynamically building accessors at compile time"
    if $^W and DEBUG ;

  {
    no strict 'refs' ;
    my %myParms = _new_parms() ;
    foreach my $attr (keys %myParms) {
      my $subname = "_$attr" ;
      my $parm    = "net_ldap_express_$attr" ;
      *$subname = sub {
	my $ldap = shift ;
	return $ldap->{$parm} if @_ == 0 ;
	return $ldap->{$parm} = shift ;
      } ;
    }
  }
}

sub _makefilter {
  my $ldap = shift ;
  my ($query) = @_ ;

  my $bool  = $ldap->_searchbool  ? $ldap->_searchbool  : '|'  ;
  my $match = $ldap->_searchmatch ;

  my $op    = '~=' ;

  if ($match) {
    $op = '=' if $match eq 'substr' or $match eq 'exact' ;
    $query = qq/*$query*/ if $match eq 'substr';
  }

  my @attrs = @{$ldap->_searchattrs} ;

  my $filter ;
  if (@attrs == 1) {
    $filter = qq/($attrs[0]$op$query)/ ;
  } else {
    $filter = "($bool".
              join("",map("($_$op$query)",@attrs)).
	      ")" ;
  }

  #carp "Search filter is $filter" if DEBUG ;
  return $filter ;
}

sub _makesearchparms {
  my $ldap = shift ;

  unless (exists $ldap->{net_ldap_express_searchparms}) {
    my %parms ;

    # Set search base
    $parms{base} = $ldap->_base ;

    # Retrieve onlyattrs, or all; add searchextras if needed
    my $attrs = $ldap->_onlyattrs ? $ldap->_onlyattrs : ['*'] ;

    if (my $extras = $ldap->_searchextras) {
      push @$attrs,@$extras ;
    }

    # Now what if one specifies also sort_by, and the attributes are not
    # in $attrs? The sorting would fail...  First, let's see if the
    # first element of @$attrs is a '*', in that case just skip
    if (my $sortattrs = $ldap->_sort_by) {
      unless ($attrs->[0] eq '*') {
	# We have to compare each @$sortattrs element with the elements
	# of @$attrs; better to have some precompiled patterns handy.
	my @qrattrs = map qr/^$_$/i,@$attrs ;
	foreach my $attr (@$sortattrs) {
	  push @$attrs,$attr unless grep $attr =~ $_ ,@qrattrs ;
	}
      }
    }

    # Now we can assign the resulting $attrs to $parms{attrs}...
    $parms{attrs} = $attrs ;

    $ldap->{net_ldap_express_searchparms} = \%parms ;
  }

  return %{$ldap->{net_ldap_express_searchparms}} ;
}


1;
__END__