|
Peter, I've added schema awareness. You can now do $filter->match($entry,$schema) and it will filter based on schema, however currently I only included caseIgnore matching. I couldn't get the function prototyping to work with the substrings match in combination with schema lookup while it works with $schema=undef (I'm running Active State 5.8.7). At the end is a small extension to Net::LDAP::Schema, which probably does not belong here ;-) Feedback is welcome, Hans Peter Marschall schreef: Hi Hans, On Sunday, 18. December 2005 21:53, [EMAIL PROTECTED] wrote:attached is Net::LDAP::FilterMatch, a module to match Net::LDAP::Entry objects against a Net::LDAP::Filter filter. It can be used to filter out entries from an LDIF, but also as a simple solution for searching while using Net::LDAP::Server.I made a few changes to the file you sent.Fixes compared to your version: - conjunctions (&...) and disjunctions (|...) may comprise any number of elements. - characters with special meaning in Perl regexes are quoted in equality and substring filters i.e. "(cn=Peter?)" matches "Peter?" but not "Pete" or "Peter". - Net::LDAP::FilterMatch is now an extension of Net::LDAP::Filter Thus loading Net::LDAP::FilterMatch after Net::LDAP::Filter allows you to write $filter->match($entry) - If possible greateOrEqual and lessOrEqual filters do numerical comparison. See the attached file. If you do not mind I'd like to include it into the perl-ldap SVN so that it will be in the next release. Please test if it still matches your idea how this module should behave. Regards Peter |
# ===========================================================================
# Net::LDAP::FilterMatch
#
# LDAP entry matching
#
# Hans Klunder <[EMAIL PROTECTED]>
# Peter Marschall <[EMAIL PROTECTED]>
# Copyright (c) 2005.
#
# See below for documentation.
#
package Net::LDAP::Filter;
require Exporter;
[EMAIL PROTECTED] = qw(Net::LDAP::Filter Exporter);
@ISA = qw(Exporter);
@EXPORT_OK = qw(filterMatch);
$VERSION = '0.12';
sub filterMatch($@);
sub _cis_equalityMatch($@);
sub _cis_greaterOrEqual($@);
sub _cis_lessOrEqual($@);
sub _cis_approxMatch($@);
sub _cis_substrings;
sub _caseIgnoreMatch { return _cis_equalityMatch(@_)};
sub _caseIgnoreSubstringsMatch { return _cis_substrings(@_) };
sub match
{
my $self = shift;
my $entry = shift;
my $schema =shift;
return filterMatch($self, $entry, $schema);
}
# map Ops to schema matches
my %op2schema = qw(
equalityMatch equality
greaterOrEqual equality
lessOrEqual ordering
approxMatch ordering
substrings substr
);
sub filterMatch($@)
{
my $filter = shift;
my $entry = shift;
my $schema = shift;
keys(%{$filter}); # re-initialize each() operator
my ($op, $args) = each(%{$filter});
#print Dumper($args);
# handle combined filters
if ($op eq 'and') { # '(&()...)' => fail on 1st mismatch
foreach my $subfilter (@{$args}) {
return 0 if (!filterMatch($subfilter, $entry));
}
return 1; # all matched or '(&)' => succeed
}
if ($op eq 'or') { # '(|()...)' => succeed on 1st match
foreach my $subfilter (@{$args}) {
return 1 if (filterMatch($subfilter, $entry));
}
return 0; # none matched or '(|)' => fail
}
if ($op eq 'not') {
return (! filterMatch($args, $entry));
}
if ($op eq 'present') {
#return 1 if (lc($args) eq 'objectclass'); # "all match" filter
return ($entry->exists($args));
}
# handle basic filters
if ($op =~
/^(equalityMatch|greaterOrEqual|lessOrEqual|approxMatch|substrings)/o) {
my $attr=($op eq 'substrings') ? $args->{'type'} : $args->{'attributeDesc'}
;
#print $op,'##', $op2schema{$op},'##',$attr,"##";
my @values = $entry->get_value($attr);
my $match;
# approx match is not standardized in schema
if ($schema and ($op ne 'approxMatch') ){
# get matchingrule from schema, be sure that matching subs exist
for every MR in your schema
$match='_' . $schema->matchingruleforattribute( $attr,
$op2schema{$op}) or return undef;
}
else{
# fall back on build-in logic
$match='_cis_' . $op;
}
#print $match,"## ";
return &$match($args, @values);
}
return undef; # all other filters => fail with error
}
sub _cis_equalityMatch($@)
{
my $args=shift;
my $assertion = $args->{'assertionValue'};
return grep(/^\Q$assertion\E$/i, @_) ? 1 : 0;
}
sub _cis_greaterOrEqual($@)
{
my $args=shift;
my $assertion = $args->{'assertionValue'};
if (grep(!/^-?\d+$/o, $assertion, @_)) { # numerical values only =>
compare numerically
return (grep { $_ ge $assertion } @_) ? 1 : 0;
}
else {
return (grep { lc($_) >= lc($assertion) } @_) ? 1 : 0;
}
}
sub _cis_lessOrEqual($@)
{
my $args=shift;
my $assertion = $args->{'assertionValue'};
if (grep(!/^-?\d+$/o, $assertion, @_)) { # numerical values only =>
compare numerically
return (grep { $_ le $assertion } @_) ? 1 : 0;
}
else {
return (grep { lc($_) <= lc($assertion) } @_) ? 1 : 0;
}
}
sub _cis_approxMatch($@)
{
my $args=shift;
my $assertion = $args->{'assertionValue'};
# kludge: treat assertion as regex
$assertion =~ s/\./\\./go;
$assertion =~ s/\*/.*/go;
#print "$assertion\n";
return grep(/^$assertion$/i, @_) ? 1 : 0;
# better: by use String::Approx or similar
}
sub _cis_substrings
{
my $args=shift;
my $regex = join('.*', map { "\Q$_\E" } map { values %$_ }
@{$args->{'substrings'}});
$regex = '^'.$regex if (exists $args->{'substrings'}[0]{initial});
$regex .= '$' if (exists $args->{'substrings'}[-1]{final});
#print "RegEx: ".$regex."\n";
return grep(/$regex/i, @_) ? 1 : 0;
}
package Net::LDAP::Schema;
# given the attribute and a matchtype (e.g. equality) this will return the name
of the rule to apply
sub matchingruleforattribute($@)
{
my $schema = shift;
my $attr = shift;
my $matchtype = shift;
my $attrtype = $schema->attribute( $attr );
if (exists $attrtype->{$matchtype}){
return $attrtype->{$matchtype} ;
}
elsif (exists $attrtype->{'sup'}){
# the assumption is that all superiors result in the same ruleset
return matchingruleforattribute( $schema, $attrtype->{'sup'}[0],
$matchtype);
}
return undef;
}
1;
__END__
=head1 NAME
Net::LDAP::FilterMatch - LDAP entry matching
=head1 SYNOPSIS
use Net::LDAP::Entry;
use Net::LDAP::Filter;
use Net::LDAP::FilterMatch;
my $entry = new Net::LDAP::Entry;
$entry->dn("cn=dummy entry");
$entry->add (
'cn' => 'dummy entry',
'street' => [ '1 some road','nowhere' ] );
my @filters = (qw/(cn=dummy*)
(ou=*)
(&(cn=dummy*)(street=*road))
(&(cn=dummy*)(!(street=nowhere)))/);
for (@filters) {
my $filter = Net::LDAP::Filter->new($_);
print $_,' : ', $filter->match($entry) ? 'match' : 'no match' ,"\n";
}
=head1 ABSTRACT
This extension of the class Net::LDAP::Filter provides entry matching
functionality on the Perl side.
Given an entry it will tell whether the entry matches the filter object.
It can be used on its own or as part of a Net::LDAP::Server based LDAP server.
=head1 METHOD
=over 4
=item match ( ENTRY [ ,SCHEMA ] )
Return whether ENTRY matches the filter object. If a schema object is provided,
the selection of matching algorithms will be derived from schema.
In case of error undef is returned.
=back
=head1 SEE ALSO
L<Net::LDAP::Filter>
=head1 COPYRIGHT
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHORS
Hans Klunder E<lt>[EMAIL PROTECTED]<gt>
Peter Marschall E<lt>[EMAIL PROTECTED]<gt>
=cut
# EOF
