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