[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/site_perl/5.10.0/Net/LDAP/ -> FilterMatch.pm (source)

   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


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1