[Summary view] [Print] [Text view]

   1  # Copyright (c) 1997-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
   2  # This program is free software; you can redistribute it and/or
   3  # modify it under the same terms as Perl itself.
   4  
   5  package Net::LDAP::Filter;
   6  
   7  use strict;
   8  use vars qw($VERSION);
   9  
  10  $VERSION = "0.15";
  11  
  12  # filter       = "(" filtercomp ")"
  13  # filtercomp   = and / or / not / item
  14  # and          = "&" filterlist
  15  # or           = "|" filterlist
  16  # not          = "!" filter
  17  # filterlist   = 1*filter
  18  # item         = simple / present / substring / extensible
  19  # simple       = attr filtertype value
  20  # filtertype   = equal / approx / greater / less
  21  # equal        = "="
  22  # approx       = "~="
  23  # greater      = ">="
  24  # less         = "<="
  25  # extensible   = attr [":dn"] [":" matchingrule] ":=" value
  26  #                / [":dn"] ":" matchingrule ":=" value
  27  # present      = attr "=*"
  28  # substring    = attr "=" [initial] any [final]
  29  # initial      = value
  30  # any          = "*" *(value "*")
  31  # final        = value
  32  # attr         = AttributeDescription from Section 4.1.5 of [1]
  33  # matchingrule = MatchingRuleId from Section 4.1.9 of [1]
  34  # value        = AttributeValue from Section 4.1.6 of [1]
  35  # 
  36  # Special Character encodings
  37  # ---------------------------
  38  #    *               \2a, \*
  39  #    (               \28, \(
  40  #    )               \29, \)
  41  #    \               \5c, \\
  42  #    NUL             \00
  43  
  44  my $ErrStr;
  45  
  46  sub new {
  47    my $self = shift;
  48    my $class = ref($self) || $self;
  49    
  50    my $me = bless {}, $class;
  51  
  52    if (@_) {
  53      $me->parse(shift) or
  54        return undef;
  55    }
  56    $me;
  57  }
  58  
  59  my $Attr  = '[-;.:\d\w]*[-;\d\w]';
  60  
  61  my %Op = qw(
  62    &   and
  63    |   or
  64    !   not
  65    =   equalityMatch
  66    ~=  approxMatch
  67    >=  greaterOrEqual
  68    <=  lessOrEqual
  69    :=  extensibleMatch
  70  );
  71  
  72  my %Rop = reverse %Op;
  73  
  74  # Unescape
  75  #   \xx where xx is a 2-digit hex number
  76  #   \y  where y is one of ( ) \ *
  77  
  78  sub errstr { $ErrStr }
  79  
  80  sub _unescape {
  81    $_[0] =~ s/
  82           \\([\da-fA-F]{2}|.)
  83          /
  84           length($1) == 1
  85             ? $1
  86             : chr(hex($1))
  87          /soxeg;
  88    $_[0];
  89  }
  90  
  91  sub _escape { (my $t = $_[0]) =~ s/([\\\(\)\*\0-\37\177-\377])/sprintf("\\%02x",ord($1))/sge; $t }
  92  
  93  sub _encode {
  94    my($attr,$op,$val) = @_;
  95  
  96    # An extensible match
  97  
  98    if ($op eq ':=') {
  99  
 100      # attr must be in the form type:dn:1.2.3.4
 101      unless ($attr =~ /^([-;\d\w]*)(:dn)?(:(\w+|[.\d]+))?$/) {
 102        $ErrStr = "Bad attribute $attr";
 103        return undef;
 104      }
 105      my($type,$dn,$rule) = ($1,$2,$4);
 106  
 107      return ( {
 108        extensibleMatch => {
 109      matchingRule => $rule,
 110      type         => length($type) ? $type : undef,
 111      matchValue   => _unescape($val), 
 112      dnAttributes => $dn ? 1 : undef
 113        }
 114      });
 115    }
 116  
 117    # If the op is = and contains one or more * not
 118    # preceeded by \ then do partial matches
 119  
 120    if ($op eq '=' && $val =~ /^(\\.|[^\\*]+)*\*/o ) {
 121  
 122      my $n = [];
 123      my $type = 'initial';
 124  
 125      while ($val =~ s/^((\\.|[^\\*]+)*)\*//) {
 126        push(@$n, { $type, _unescape("$1") })         # $1 is readonly, copy it
 127      if length($1) or $type eq 'any';
 128  
 129        $type = 'any';
 130      }
 131  
 132      push(@$n, { 'final', _unescape($val) })
 133        if length $val;
 134  
 135      return ({
 136        substrings => {
 137      type       => $attr,
 138      substrings => $n
 139        }
 140      });
 141    }
 142  
 143    # Well we must have an operator and no un-escaped *'s on the RHS
 144  
 145    return {
 146      $Op{$op} => {
 147        attributeDesc => $attr, assertionValue =>  _unescape($val)
 148      }
 149    };
 150  }
 151  
 152  sub parse {
 153    my $self   = shift;
 154    my $filter = shift;
 155  
 156    my @stack = ();   # stack
 157    my $cur   = [];
 158    my $op;
 159  
 160    undef $ErrStr;
 161  
 162    # a filter is required
 163    if (!defined $filter) {
 164      $ErrStr = "Undefined filter";
 165      return undef;
 166    }
 167  
 168    # Algorithm depends on /^\(/;
 169    $filter =~ s/^\s*//;
 170  
 171    $filter = "(" . $filter . ")"
 172      unless $filter =~ /^\(/;
 173  
 174    while (length($filter)) {
 175  
 176      # Process the start of  (& (...)(...))
 177  
 178      if ($filter =~ s/^\(\s*([&!|])\s*//) {
 179        push @stack, [$op,$cur];
 180        $op = $1;
 181        $cur = [];
 182        next;
 183      }
 184  
 185      # Process the end of  (& (...)(...))
 186  
 187      elsif ($filter =~ s/^\)\s*//o) {
 188        unless (@stack) {
 189      $ErrStr = "Bad filter, unmatched )";
 190      return undef;
 191        }
 192        my($myop,$mydata) = ($op,$cur);
 193        ($op,$cur) = @{ pop @stack };
 194      # Need to do more checking here
 195        push @$cur, { $Op{$myop} => $myop eq '!' ? $mydata->[0] : $mydata };
 196        next if @stack;
 197      }
 198      
 199      # present is a special case (attr=*)
 200  
 201      elsif ($filter =~ s/^\(\s*($Attr)=\*\)\s*//o) {
 202        push(@$cur, { present => $1 } );
 203        next if @stack;
 204      }
 205  
 206      # process (attr op string)
 207  
 208      elsif ($filter =~ s/^\(\s*
 209                          ($Attr)\s*
 210                          ([:~<>]?=)
 211                          ((?:\\.|[^\\()]+)*)
 212                          \)\s*
 213                         //xo) {
 214        push(@$cur, _encode($1,$2,$3));
 215        next if @stack;
 216      }
 217  
 218      # If we get here then there is an error in the filter string
 219      # so exit loop with data in $filter
 220      last;
 221    }
 222  
 223    if (length $filter) {
 224      # If we have anything left in the filter, then there is a problem
 225      $ErrStr = "Bad filter, error before " . substr($filter,0,20);
 226      return undef;
 227    }
 228    if (@stack) {
 229      $ErrStr = "Bad filter, unmatched (";
 230      return undef;
 231    }
 232  
 233    %$self = %{$cur->[0]};
 234  
 235    $self;
 236  }
 237  
 238  sub print {
 239    my $self = shift;
 240    no strict 'refs'; # select may return a GLOB name
 241    my $fh = @_ ? shift : select;
 242  
 243    print $fh $self->as_string,"\n";
 244  }
 245  
 246  sub as_string { _string(%{$_[0]}) }
 247  
 248  sub _string {    # prints things of the form (<op> (<list>) ... )
 249    my $i;
 250    my $str = "";
 251  
 252    for ($_[0]) {
 253      /^and/ and return "(&" . join("", map { _string(%$_) } @{$_[1]}) . ")";
 254      /^or/  and return "(|" . join("", map { _string(%$_) } @{$_[1]}) . ")";
 255      /^not/ and return "(!" . _string(%{$_[1]}) . ")";
 256      /^present/ and return "($_[1]=*)";
 257      /^(equalityMatch|greaterOrEqual|lessOrEqual|approxMatch)/
 258        and return "(" . $_[1]->{attributeDesc} . $Rop{$1} . _escape($_[1]->{assertionValue})  .")";
 259      /^substrings/ and do {
 260        my $str = join("*", "",map { _escape($_) } map { values %$_ } @{$_[1]->{substrings}});
 261        $str =~ s/^.// if exists $_[1]->{substrings}[0]{initial};
 262        $str .= '*' unless exists $_[1]->{substrings}[-1]{final};
 263        return "($_[1]->{type}=$str)";
 264      };
 265      /^extensibleMatch/ and do {
 266        my $str = "(";
 267        $str .= $_[1]->{type} if defined $_[1]->{type};
 268        $str .= ":dn" if $_[1]->{dnAttributes};
 269        $str .= ":$_[1]->{matchingRule}" if defined $_[1]->{matchingRule};
 270        $str .= ":=" . _escape($_[1]->{matchValue}) . ")";
 271        return $str;
 272      };
 273    }
 274  
 275    die "Internal error $_[0]";
 276  }
 277  
 278  1;