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
5package Net::LDAP::Filter;
6
7use strict;
8use 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
44my $ErrStr;
45
46sub 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
59my $Attr  = '[-;.:\d\w]*[-;\d\w]';
60
61my %Op = qw(
62  &   and
63  |   or
64  !   not
65  =   equalityMatch
66  ~=  approxMatch
67  >=  greaterOrEqual
68  <=  lessOrEqual
69  :=  extensibleMatch
70);
71
72my %Rop = reverse %Op;
73
74# Unescape
75#   \xx where xx is a 2-digit hex number
76#   \y  where y is one of ( ) \ *
77
78sub errstr { $ErrStr }
79
80sub _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
91sub _escape { (my $t = $_[0]) =~ s/([\\\(\)\*\0-\37\177-\377])/sprintf("\\%02x",ord($1))/sge; $t }
92
93sub _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
152sub 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
238sub 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
246sub as_string { _string(%{$_[0]}) }
247
248sub _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
2781;
279