[ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
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 13 package Net::LDAP::FilterMatch; 14 15 use strict; 16 use Net::LDAP::Filter; 17 use Net::LDAP::Schema; 18 19 use vars qw($VERSION); 20 $VERSION = '0.17'; 21 22 sub import { 23 shift; 24 25 push(@_, @Net::LDAP::Filter::approxMatchers) unless @_; 26 @Net::LDAP::Filter::approxMatchers = grep { eval "require $_" } @_ ; 27 } 28 29 package Net::LDAP::Filter; 30 31 use vars qw(@approxMatchers); 32 @approxMatchers = qw( 33 String::Approx 34 Text::Metaphone 35 Text::Soundex 36 ); 37 38 sub _filterMatch($@); 39 40 sub _cis_equalityMatch($@); 41 sub _exact_equalityMatch($@); 42 sub _numeric_equalityMatch($@); 43 sub _cis_orderingMatch($@); 44 sub _numeric_orderingMatch($@); 45 sub _cis_greaterOrEqual($@); 46 sub _cis_lessOrEqual($@); 47 sub _cis_approxMatch($@); 48 sub _cis_substrings($@); 49 sub _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 86 sub 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 96 my %op2schema = qw( 97 equalityMatch equality 98 greaterOrEqual equality 99 lessOrEqual ordering 100 approxMatch approx 101 substrings substr 102 ); 103 104 sub _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 171 sub _cis_equalityMatch($@) 172 { 173 my $assertion = shift; 174 my $op = shift; 175 176 return grep(/^\Q$assertion\E$/i, @_) ? 1 : 0; 177 } 178 179 sub _exact_equalityMatch($@) 180 { 181 my $assertion = shift; 182 my $op = shift; 183 184 return grep(/^\Q$assertion\E$/, @_) ? 1 : 0; 185 } 186 187 sub _numeric_equalityMatch($@) 188 { 189 my $assertion = shift; 190 my $op = shift; 191 192 return grep(/^\Q$assertion\E$/, @_) ? 1 : 0; 193 } 194 195 sub _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 211 sub _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 227 sub _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 243 sub _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 251 sub _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 261 sub _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 276 sub _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 300 1; 301 302 303 __END__ 304 305 =head1 NAME 306 307 Net::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 334 This extension of the class Net::LDAP::Filter provides entry matching 335 functionality on the Perl side. 336 337 Given an entry it will tell whether the entry matches the filter object. 338 339 It 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 347 Return whether ENTRY matches the filter object. If a schema object is provided, 348 the selection of matching algorithms will be derived from schema. 349 350 In case of error undef is returned. 351 352 =back 353 354 For approximate matching like (cn~=Schmidt) there are several modules that can 355 be used. By default the following modules will be tried in this order: 356 357 String::Approx 358 Text::Metaphone 359 Text::Soundex 360 361 If none of these modules is found it will fall back on a simple regexp algorithm. 362 363 If 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 369 L<Net::LDAP::Filter> 370 371 =head1 COPYRIGHT 372 373 This library is free software; you can redistribute it and/or modify 374 it under the same terms as Perl itself. 375 376 =head1 AUTHORS 377 378 Hans Klunder E<lt>hans.klunder@bigfoot.comE<gt> 379 Peter Marschall E<lt>peter@adpm.deE<gt> 380 381 =cut 382 383 # EOF
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |