File Coverage

blib/lib/Trinket/Directory/FilterParser/LDAP.pm
Criterion Covered Total %
statement 47 55 85.4
branch 10 14 71.4
condition n/a
subroutine 11 13 84.6
pod 0 5 0.0
total 68 87 78.1


line stmt bran cond sub pod time code
1             ###########################################################################
2             ### Trinket::Directory::FilterParser::LDAP
3             ###
4             ### Foo
5             ###
6             ### $Id: LDAP.pm,v 1.1.1.1 2001/02/15 18:47:50 deus_x Exp $
7             ###
8             ### TODO:
9             ###
10             ###########################################################################
11              
12             package Trinket::Directory::FilterParser::LDAP;
13              
14 2     2   995 use strict;
  2         6  
  2         111  
15 2     2   13 use vars qw($VERSION @ISA @EXPORT $DESCRIPTION $AUTOLOAD);
  2         4  
  2         173  
16 2     2   12 no warnings qw( uninitialized );
  2         4  
  2         101  
17 2     2   11 use Carp qw( confess );
  2         4  
  2         192  
18              
19             # {{{ Begin POD
20              
21             =head1 NAME
22              
23             Trinket::Directory::FilterParser::LDAP - Handle RFC1960 search filters
24              
25             =head1 ABSTRACT
26              
27             Accept an LDAP-like search filter to find objects.
28              
29             =head1 SYNOPSIS
30              
31             my @objs = $serializer->Search
32             ('(&(parent=1)(objectclass=Iaido::Object::Folder))');
33              
34             my @objs = $serializer->Search
35             (qq^
36             (&
37             (path~=/hivemind/*)
38             (objectclass=Iaido::Object::Hivemind::Task)
39             (| (parent=2378)(parent=2124)(parent=2308)(parent=3217) )
40             (| (author=1949)(author=4158) )
41             (& (created>=883976400)(created<=947307600) )
42             (closed=0)
43             )
44             ^);
45              
46             =head1 DESCRIPTION
47              
48             The parse_filter() method accepts a filter string, based on and
49             mostly compatible with RFC1960 (http://www.ietf.org/rfc/rfc1960.txt),
50             the string representation format of Lightweight Directory Access Protocol
51             (LDAP) search filters. (TODO: Detail what features, if any, of the spec
52             are not supported)
53              
54             =cut
55              
56             # }}}
57              
58             # {{{ METADATA
59              
60             BEGIN
61             {
62 2     2   5 $VERSION = "0.0";
63 2         37 @ISA = qw( Trinket::Directory::FilterParser );
64 2         39 $DESCRIPTION = 'LDAP (RFC1960) search filter parser';
65             }
66              
67             # }}}
68              
69 2     2   578 use Trinket::Directory::FilterParser;
  2         5  
  2         269  
70              
71             # {{{ EXPORTS
72              
73             =head1 EXPORTS
74              
75             TODO
76              
77             =cut
78              
79             # }}}
80              
81             # {{{ METHODS
82              
83             =head1 METHODS
84              
85             =over 4
86              
87             =cut
88              
89             # }}}
90              
91             # {{{ init(): Object initializer
92              
93             sub init {
94 2     2   11 no strict 'refs';
  2         3  
  2         1434  
95 7     7 0 24 my ($self, $props) = @_;
96             }
97              
98             # }}}
99              
100             ### To give credit where credit is due: LDAP search filter processing was
101             ### borrowed via cut and paste from Graham Barr's Net::LDAP::Filter module
102              
103             ### Regular expressions to recognize LDAP attributes, operators, and
104             ### search values
105             my($Attr) = qw{ [-;.:\d\w]*[-;\d\w] };
106             my($Op) = qw{ ~=|<=|>=|<|>|= };
107             my($Value) = qw{ (?:\\.|[^\\()]+)* };
108              
109             ### Define a mapping between LDAP filter operators to search filter
110             ### LoL node names
111             # my %Op =
112             # qw(
113             # & FILTER_AND
114             # | FILTER_OR
115             # ! FILTER_NOT
116             # = FILTER_EQ
117             # ~= FILTER_APPROX
118             # > FILTER_GT
119             # >= FILTER_GE
120             # < FILTER_LT
121             # <= FILTER_LE
122             # );
123             my %Op =
124             qw(
125             & AND
126             | OR
127             ! NOT
128             = EQ
129             ~= APPROX
130             > GT
131             >= GE
132             < LT
133             <= LE
134             );
135              
136             ### Reverse the LDAP op to node name mapping.
137             my %Rop = reverse %Op;
138              
139             ### Define a mapping of search filter LoL node names to compilation methods
140             my %node_methods =
141             (
142             'FILTER_AND' => 'sql_and_seq',
143             'FILTER_OR' => 'sql_or_seq',
144             'FILTER_NOT' => 'sql_not_seq',
145             'FILTER_EQ' => 'sql_leaf',
146             'FILTER_APPROX' => 'sql_leaf',
147             'FILTER_GT' => 'sql_leaf',
148             'FILTER_GE' => 'sql_leaf',
149             'FILTER_LT' => 'sql_leaf',
150             'FILTER_LE' => 'sql_leaf',
151             );
152              
153             ### Define a mapping of search filter LoL leaf node names to SQL operators.
154             my %leaf_sql_ops =
155             (
156             'FILTER_EQ' => '=',
157             'FILTER_APPROX' => ' LIKE ',
158             'FILTER_GT' => '>',
159             'FILTER_GE' => '>=',
160             'FILTER_LT' => '<',
161             'FILTER_LE' => '<=',
162             );
163              
164             # {{{ parse: Parse a search filter into an LoL
165              
166             sub parse {
167 15     15 0 108 my ($self, $filter) = @_;
168            
169 15         29 my @stack = (); # stack
170 15         34 my $cur = [];
171            
172             # Algorithm depends on /^\(/;
173 15         83 $filter =~ s/^\s*//;
174 15 100       70 $filter = "(" . $filter . ")" unless $filter =~ /^\(/;
175            
176 15         49 while (length($filter)) {
177             # Process the start of (& (...)(...))
178 42 100       145 if ($filter =~ s/^\(\s*([&|!])\s*//) {
179 9         19 my $n = []; # new list to hold filter elements
180 9         30 push(@$cur, $Op{$1}, $n);
181 9         16 push(@stack,$cur); # push current list on the stack
182 9         15 $cur = $n;
183 9         25 next;
184             }
185            
186             # Process the end of (& (...)(...))
187 33 100       94 if ($filter =~ s/^\)\s*//o) {
188 9         16 $cur = pop @stack;
189 9 100       29 last unless @stack;
190 4         10 next;
191             }
192            
193             # present is a special case (attr=*)
194             #if ($filter =~ s/^\(\s*($Attr)=\*\)\s*//o)
195             # { push(@$cur, FILTER_PRESENT => $1); next; }
196            
197             # process (attr op string)
198 24 50       334 if ($filter =~ s/^\(\s*($Attr)\s*($Op)($Value)\)\s*//o)
199 24         62 { push(@$cur, encode($1,$2,$3)); next; }
  24         150  
200              
201             # If we get here then there is an error in the filter string
202             # so exit loop with data in $filter
203 0         0 last;
204             }
205            
206 15 50       42 if (length $filter) {
207             # If we have anything left in the filter, then there is a problem
208 0         0 confess("Bad filter, error before " . substr($filter,0,20));
209 0         0 return undef;
210             }
211              
212 15         47 return $cur;
213             }
214              
215             # }}}
216             # {{{ encode: Encode a leaf filter node into the LoL
217              
218             sub encode {
219 24     24 0 75 my($attr,$op,$val) = @_;
220 24         66 return ($Op{$op} => [ STRING => $attr, STRING => unescape($val) ]);
221             }
222              
223             # }}}
224             # {{{ escape: Escape 'illegal' characters in the filter
225              
226             sub escape {
227 0     0 0 0 $_[0] =~ s/([\\\(\)\*\0])/sprintf("\\%02x",ord($1))/sge;
  0         0  
228 0         0 $_[0];
229             }
230              
231             # }}}
232             # {{{ unescape: Unescape 'illegal' characters in the filter
233              
234             sub unescape {
235 24 0   24 0 60 $_[0] =~ s/\\([\da-fA-F]{2}|.)/length($1) == 1 ? $1 : chr(hex($1))/soxeg;
  0         0  
236 24         109 $_[0];
237             }
238              
239             # }}}
240              
241             # {{{ DESTROY
242              
243             sub DESTROY
244 0     0     {
245             ## no-op to pacify warnings
246             }
247              
248             # }}}
249              
250             # {{{ End POD
251              
252             =back
253              
254             =head1 AUTHOR
255              
256             Maintained by Leslie Michael Orchard >
257              
258             =head1 COPYRIGHT
259              
260             Copyright (c) 2000, Leslie Michael Orchard. All Rights Reserved.
261             This module is free software; you can redistribute it and/or
262             modify it under the same terms as Perl itself.
263              
264             =cut
265              
266             # }}}
267              
268             1;
269             __END__