Just for the archive.. ------------------------- Original message ------------------------------- Onderwerp: Re: Net::LDAP::FilterMatch Van: "[EMAIL PROTECTED]" <[EMAIL PROTECTED]> Datum: Ma, 19 december, 2005 9:26 Aan: "Mike Jackson" <[EMAIL PROTECTED]> --------------------------------------------------------------------------
Mike, check out: http://search.cpan.org/~aar/Net-LDAP-Server-0.2/Net/LDAP/Server.pm Kind regards, Hans > [EMAIL PROTECTED] wrote: >> Hi, >> >> 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. >> >> Comments are welcome. >> >> Kind regards, >> >> Hans >> > > > Cool. Where do I find Net::LDAP::Server? > > Not here: > > http://svn.mutatus.co.uk/wsvn/perl-ldap/trunk/lib/Net/LDAP/?rev=0&sc=0 > > > -- > mike > > > >> ------------------------------------------------------------------------ >> >> # >> =========================================================================== # Net::LDAP::FilterMatch >> # >> # LDAP entry matching >> # >> # Hans Klunder <[EMAIL PROTECTED]> >> # Copyright (c) 2005. >> # >> # See below for documentation. >> # >> >> package Net::LDAP::FilterMatch; >> >> require Exporter; >> @ISA = qw(Exporter); >> @EXPORT_OK = qw(filterMatch); >> $VERSION = '0.1'; >> >> >> sub filterMatch{ >> my $filter=shift; >> my $entry=shift; >> >> keys(%{$filter}); #this one is to ensure the next each works out fine my ($op, $args)=each(%{$filter}); >> >> return (filterMatch(@{$args}[0],$entry) and >> filterMatch(@{$args}[1],$entry)) if ($op eq 'and'); >> return (filterMatch(@{$args}[0],$entry) or >> filterMatch(@{$args}[1],$entry))if ($op eq 'or'); >> return (not(filterMatch($args,$entry))) if ($op eq 'not'); >> return ($entry->exists($args)) if ($op eq 'present'); >> >> if ($op=~ /^(equalityMatch|greaterOrEqual|lessOrEqual|approxMatch)/){ >> my @values=$entry->get_value($args->{'attributeDesc'}); >> my $type='string'; # should be derived from schema >> my $match= $type.'_'.$op; >> my $filter=$args->{'assertionValue'}; >> foreach my $value(@values){ >> return 1 if eval( "$match".'($filter,$value)'); >> } >> return 0; >> } >> if ($op eq 'substrings'){ >> my @values=$entry->get_value($args->{'type'}); >> my $type='string'; # should be derived from schema >> my $match= $type.'_'.$op; >> my $regexp = join('.*', "",map { $_ } map { values %$_ } >> @{$args->{'substrings'}}); >> $regexp =~ s/^..// if exists $args->{'substrings'}[0]{initial}; $regexp .= '.*' unless exists $args->{'substrings'}[-1]{final}; foreach my $value(@values){ >> return 1 if eval( "$match".'($regexp,$value)' ); >> } >> return 0; >> } >> } >> >> sub string_equalityMatch{ >> return (@_[0] eq @_[1]); >> } >> >> sub string_greaterOrEqual{ >> return (@_[0] ge @_[1]); >> } >> >> sub string_lessOrEqual{ >> return (@_[0] le @_[1]); >> } >> >> sub string_approxMatch{ >> return (@_[0] eq @_[1]); #this needs fixing by using >> String::Approx >> } >> >> sub string_substrings{ >> return ($_[1]=~/$_[0]/); >> } >> >> 1; >> >> __END__ >> >> =head1 NAME >> >> Net::LDAP::FilterMatch - LDAP entry matching >> >> =head1 SYNOPSIS >> >> use Net::LDAP::Entry; >> use Net::LDAP::Filter; >> use Net::LDAP::FilterMatch qw/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=new Net::LDAP::Filter; >> $filter->parse($_); >> print $_,' : ',filterMatch($filter,$entry) ? 'match' : 'no match' >> ,"\n"; >> } >> >> =head1 ABSTRACT >> >> This class provides ldap entry matching functionality which can be used on its >> own or as part of a Net::LDAP::Server based LDAP server. >> Given an entry and a filter it will tell you if the filter matches the entry. >> >> =head1 SEE ALSO >> >> L<Net::LDAP::Server> >> >> =head1 COPYRIGHT >> >> This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. >> >> =head1 AUTHOR >> >> Hans Klunder E<lt>[EMAIL PROTECTED]<gt> >> >> =cut >> >> >> >> >
