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