1# =========================================================================== 2# Net::LDAP::FilterMatch 3# 4# LDAP entry matching 5# 6# Hans Klunder <hans.klunder@bigfoot.com> 7# Peter Marschall <peter@adpm.de> 8# Copyright (c) 2005-2006. 9# 10# See below for documentation. 11# 12 13package Net::LDAP::FilterMatch; 14 15use strict; 16use Net::LDAP::Filter; 17use Net::LDAP::Schema; 18 19use vars qw($VERSION); 20$VERSION = '0.17'; 21 22sub import { 23 shift; 24 25 push(@_, @Net::LDAP::Filter::approxMatchers) unless @_; 26 @Net::LDAP::Filter::approxMatchers = grep { eval "require $_" } @_ ; 27} 28 29package Net::LDAP::Filter; 30 31use vars qw(@approxMatchers); 32@approxMatchers = qw( 33 String::Approx 34 Text::Metaphone 35 Text::Soundex 36); 37 38sub _filterMatch($@); 39 40sub _cis_equalityMatch($@); 41sub _exact_equalityMatch($@); 42sub _numeric_equalityMatch($@); 43sub _cis_orderingMatch($@); 44sub _numeric_orderingMatch($@); 45sub _cis_greaterOrEqual($@); 46sub _cis_lessOrEqual($@); 47sub _cis_approxMatch($@); 48sub _cis_substrings($@); 49sub _exact_substrings($@); 50 51# all known matches from the OL 2.2 schema, 52*_bitStringMatch = \&_exact_equalityMatch; 53*_booleanMatch = \&_cis_equalityMatch; # this might need to be reworked 54*_caseExactIA5Match = \&_exact_equalityMatch; 55*_caseExactIA5SubstringsMatch = \&_exact_substrings; 56*_caseExactMatch = \&_exact_equalityMatch; 57*_caseExactOrderingMatch = \&_exact_orderingMatch; 58*_caseExactSubstringsMatch = \&_exact_substrings; 59*_caseIgnoreIA5Match = \&_cis_equalityMatch; 60*_caseIgnoreIA5SubstringsMatch = \&_cis_substrings; 61*_caseIgnoreMatch = \&_cis_equalityMatch; 62*_caseIgnoreOrderingMatch = \&_cis_orderingMatch; 63*_caseIgnoreSubstringsMatch = \&_cis_substrings; 64*_certificateExactMatch = \&_exact_equalityMatch; 65*_certificateMatch = \&_exact_equalityMatch; 66*_distinguishedNameMatch = \&_exact_equalityMatch; 67*_generalizedTimeMatch = \&_exact_equalityMatch; 68*_generalizedTimeOrderingMatch = \&_exact_orderingMatch; 69*_integerBitAndMatch = \&_exact_equalityMatch; # this needs to be reworked 70*_integerBitOrMatch = \&_exact_equalityMatch; # this needs to be reworked 71*_integerFirstComponentMatch = \&_exact_equalityMatch; 72*_integerMatch = \&_numeric_equalityMatch; 73*_integerOrderingMatch = \&_numeric_orderingMatch; 74*_numericStringMatch = \&_numeric_equalityMatch; 75*_numericStringOrderingMatch = \&_numeric_orderingMatch; 76*_numericStringSubstringsMatch = \&_numeric_substrings; 77*_objectIdentifierFirstComponentMatch = \&_exact_equalityMatch; # this needs to be reworked 78*_objectIdentifierMatch = \&_exact_equalityMatch; 79*_octetStringMatch = \&_exact_equalityMatch; 80*_octetStringOrderingMatch = \&_exact_orderingMatch; 81*_octetStringSubstringsMatch = \&_exact_substrings; 82*_telephoneNumberMatch = \&_exact_equalityMatch; 83*_telephoneNumberSubstringsMatch = \&_exact_substrings; 84*_uniqueMemberMatch = \&_cis_equalityMatch; # this needs to be reworked 85 86sub match 87{ 88 my $self = shift; 89 my $entry = shift; 90 my $schema =shift; 91 92 return _filterMatch($self, $entry, $schema); 93} 94 95# map Ops to schema matches 96my %op2schema = qw( 97 equalityMatch equality 98 greaterOrEqual equality 99 lessOrEqual ordering 100 approxMatch approx 101 substrings substr 102); 103 104sub _filterMatch($@) 105{ 106 my $filter = shift; 107 my $entry = shift; 108 my $schema = shift; 109 110 keys(%{$filter}); # re-initialize each() operator 111 my ($op, $args) = each(%{$filter}); 112 113 # handle combined filters 114 if ($op eq 'and') { # '(&()...)' => fail on 1st mismatch 115 foreach my $subfilter (@{$args}) { 116 return 0 if (!_filterMatch($subfilter, $entry)); 117 } 118 return 1; # all matched or '(&)' => succeed 119 } 120 if ($op eq 'or') { # '(|()...)' => succeed on 1st match 121 foreach my $subfilter (@{$args}) { 122 return 1 if (_filterMatch($subfilter, $entry)); 123 } 124 return 0; # none matched or '(|)' => fail 125 } 126 if ($op eq 'not') { 127 return (! _filterMatch($args, $entry)); 128 } 129 if ($op eq 'present') { 130 #return 1 if (lc($args) eq 'objectclass'); # "all match" filter 131 return ($entry->exists($args)); 132 } 133 134 # handle basic filters 135 if ($op =~ /^(equalityMatch|greaterOrEqual|lessOrEqual|approxMatch|substrings)/o) { 136 my $attr; 137 my $assertion; 138 my $match; 139 140 if ($op eq 'substrings') { 141 $attr = $args->{'type'}; 142 # build a regexp as assertion value 143 $assertion = join('.*', map { "\Q$_\E" } map { values %$_ } @{$args->{'substrings'}}); 144 $assertion = '^'. $assertion if (exists $args->{'substrings'}[0]{'initial'}); 145 $assertion .= '$' if (exists $args->{'substrings'}[-1]{'final'}); 146 } 147 else { 148 $attr = $args->{'attributeDesc'}; 149 $assertion = $args->{'assertionValue'} 150 } 151 152 my @values = $entry->get_value($attr); 153 154 # approx match is not standardized in schema 155 if ($schema and ($op ne 'approxMatch') ) { 156 # get matchingrule from schema, be sure that matching subs exist for every MR in your schema 157 $match='_' . $schema->matchingrule_for_attribute( $attr, $op2schema{$op}) 158 or return undef; 159 } 160 else { 161 # fall back on build-in logic 162 $match='_cis_' . $op; 163 } 164 165 return eval( "$match".'($assertion,$op,@values)' ) ; 166 } 167 168 return undef; # all other filters => fail with error 169} 170 171sub _cis_equalityMatch($@) 172{ 173 my $assertion = shift; 174 my $op = shift; 175 176 return grep(/^\Q$assertion\E$/i, @_) ? 1 : 0; 177} 178 179sub _exact_equalityMatch($@) 180{ 181 my $assertion = shift; 182 my $op = shift; 183 184 return grep(/^\Q$assertion\E$/, @_) ? 1 : 0; 185} 186 187sub _numeric_equalityMatch($@) 188{ 189 my $assertion = shift; 190 my $op = shift; 191 192 return grep(/^\Q$assertion\E$/, @_) ? 1 : 0; 193} 194 195sub _cis_orderingMatch($@) 196{ 197 my $assertion = shift; 198 my $op = shift; 199 200 if ($op eq 'greaterOrEqual') { 201 return (grep { lc($_) ge lc($assertion) } @_) ? 1 : 0; 202 } 203 elsif ($op eq 'lessOrEqual') { 204 return (grep { lc($_) le lc($assertion) } @_) ? 1 : 0; 205 } 206 else { 207 return undef; #something went wrong 208 }; 209} 210 211sub _exact_orderingMatch($@) 212{ 213 my $assertion = shift; 214 my $op = shift; 215 216 if ($op eq 'greaterOrEqual') { 217 return (grep { $_ ge $assertion } @_) ? 1 : 0; 218 } 219 elsif ($op eq 'lessOrEqual') { 220 return (grep { $_ le $assertion } @_) ? 1 : 0; 221 } 222 else { 223 return undef; #something went wrong 224 }; 225} 226 227sub _numeric_orderingMatch($@) 228{ 229 my $assertion = shift; 230 my $op = shift; 231 232 if ($op eq 'greaterOrEqual') { 233 return (grep { $_ >= $assertion } @_) ? 1 : 0; 234 } 235 elsif ($op eq 'lessOrEqual') { 236 return (grep { $_ <= $assertion } @_) ? 1 : 0; 237 } 238 else { 239 return undef; #something went wrong 240 }; 241} 242 243sub _cis_substrings($@) 244{ 245 my $regex=shift; 246 my $op=shift; 247 return 1 if ($regex =~ /^$/); 248 return grep(/\Q$regex\E/i, @_) ? 1 : 0; 249} 250 251sub _exact_substrings($@) 252{ 253 my $regex=shift; 254 my $op=shift; 255 return 1 if ($regex =~ /^$/); 256 return grep(/\Q$regex\E/, @_) ? 1 : 0; 257} 258 259# this one is here in case we don't use schema 260 261sub _cis_greaterOrEqual($@) 262{ 263 my $assertion=shift; 264 my $op=shift; 265 266 if (grep(!/^-?\d+$/o, $assertion, @_)) { # numerical values only => compare numerically 267 return _cis_orderingMatch($assertion,$op,@_); 268 } 269 else { 270 return _numeric_orderingMatch($assertion,$op,@_); 271 } 272} 273 274*_cis_lessOrEqual = \&_cis_greaterOrEqual; 275 276sub _cis_approxMatch($@) 277{ 278 my $assertion=shift; 279 my $op=shift; 280 281 foreach (@approxMatchers) { 282 # print "using $_\n"; 283 if (/String::Approx/){ 284 return String::Approx::amatch($assertion, @_) ? 1 : 0; 285 } 286 elsif (/Text::Metaphone/){ 287 my $metamatch = Text::Metaphone::Metaphone($assertion); 288 return grep((Text::Metaphone::Metaphone($_) eq $metamatch), @_) ? 1 : 0; 289 } 290 elsif (/Text::Soundex/){ 291 my $smatch = Text::Soundex::soundex($assertion); 292 return grep((Text::Soundex::soundex($_) eq $smatch), @_) ? 1 : 0; 293 } 294 } 295 #we really have nothing, use plain regexp 296 return 1 if ($assertion =~ /^$/); 297 return grep(/^$assertion$/i, @_) ? 1 : 0; 298} 299 3001; 301 302 303__END__ 304 305=head1 NAME 306 307Net::LDAP::FilterMatch - LDAP entry matching 308 309=head1 SYNOPSIS 310 311 use Net::LDAP::Entry; 312 use Net::LDAP::Filter; 313 use Net::LDAP::FilterMatch; 314 315 my $entry = new Net::LDAP::Entry; 316 $entry->dn("cn=dummy entry"); 317 $entry->add ( 318 'cn' => 'dummy entry', 319 'street' => [ '1 some road','nowhere' ] ); 320 321 my @filters = (qw/(cn=dummy*) 322 (ou=*) 323 (&(cn=dummy*)(street=*road)) 324 (&(cn=dummy*)(!(street=nowhere)))/); 325 326 327 for (@filters) { 328 my $filter = Net::LDAP::Filter->new($_); 329 print $_,' : ', $filter->match($entry) ? 'match' : 'no match' ,"\n"; 330 } 331 332=head1 ABSTRACT 333 334This extension of the class Net::LDAP::Filter provides entry matching 335functionality on the Perl side. 336 337Given an entry it will tell whether the entry matches the filter object. 338 339It can be used on its own or as part of a Net::LDAP::Server based LDAP server. 340 341=head1 METHOD 342 343=over 4 344 345=item match ( ENTRY [ ,SCHEMA ] ) 346 347Return whether ENTRY matches the filter object. If a schema object is provided, 348the selection of matching algorithms will be derived from schema. 349 350In case of error undef is returned. 351 352=back 353 354For approximate matching like (cn~=Schmidt) there are several modules that can 355be used. By default the following modules will be tried in this order: 356 357 String::Approx 358 Text::Metaphone 359 Text::Soundex 360 361If none of these modules is found it will fall back on a simple regexp algorithm. 362 363If you want to specifically use one implementation only, simply do 364 365 use Net::LDAP::FilterMatch qw(Text::Soundex); 366 367=head1 SEE ALSO 368 369L<Net::LDAP::Filter> 370 371=head1 COPYRIGHT 372 373This library is free software; you can redistribute it and/or modify 374it under the same terms as Perl itself. 375 376=head1 AUTHORS 377 378Hans Klunder E<lt>hans.klunder@bigfoot.comE<gt> 379Peter Marschall E<lt>peter@adpm.deE<gt> 380 381=cut 382 383# EOF 384