← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 17:10:45 2013
Reported on Tue Oct 15 17:11:27 2013

Filename/usr/share/perl5/Net/LDAP/Filter.pm
StatementsExecuted 15 statements in 1.72ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11124µs30µsNet::LDAP::Filter::::BEGIN@7Net::LDAP::Filter::BEGIN@7
11113µs36µsNet::LDAP::Filter::::BEGIN@240Net::LDAP::Filter::BEGIN@240
11111µs47µsNet::LDAP::Filter::::BEGIN@8Net::LDAP::Filter::BEGIN@8
0000s0sNet::LDAP::Filter::::_encodeNet::LDAP::Filter::_encode
0000s0sNet::LDAP::Filter::::_escapeNet::LDAP::Filter::_escape
0000s0sNet::LDAP::Filter::::_stringNet::LDAP::Filter::_string
0000s0sNet::LDAP::Filter::::_unescapeNet::LDAP::Filter::_unescape
0000s0sNet::LDAP::Filter::::as_stringNet::LDAP::Filter::as_string
0000s0sNet::LDAP::Filter::::errstrNet::LDAP::Filter::errstr
0000s0sNet::LDAP::Filter::::newNet::LDAP::Filter::new
0000s0sNet::LDAP::Filter::::parseNet::LDAP::Filter::parse
0000s0sNet::LDAP::Filter::::printNet::LDAP::Filter::print
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
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
7339µs237µs
# spent 30µs (24+7) within Net::LDAP::Filter::BEGIN@7 which was called: # once (24µs+7µs) by C4::Auth_with_ldap::BEGIN@32 at line 7
use strict;
# spent 30µs making 1 call to Net::LDAP::Filter::BEGIN@7 # spent 7µs making 1 call to strict::import
831.07ms283µs
# spent 47µs (11+36) within Net::LDAP::Filter::BEGIN@8 which was called: # once (11µs+36µs) by C4::Auth_with_ldap::BEGIN@32 at line 8
use vars qw($VERSION);
# spent 47µs making 1 call to Net::LDAP::Filter::BEGIN@8 # spent 36µs making 1 call to vars::import
9
101700ns$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
441400nsmy $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
591300nsmy $Attr = '[-;.:\d\w]*[-;\d\w]';
60
6118µsmy %Op = qw(
62 & and
63 | or
64 ! not
65 = equalityMatch
66 ~= approxMatch
67 >= greaterOrEqual
68 <= lessOrEqual
69 := extensibleMatch
70);
71
7218µsmy %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;
2403592µs258µs
# spent 36µs (13+23) within Net::LDAP::Filter::BEGIN@240 which was called: # once (13µs+23µs) by C4::Auth_with_ldap::BEGIN@32 at line 240
no strict 'refs'; # select may return a GLOB name
# spent 36µs making 1 call to Net::LDAP::Filter::BEGIN@240 # spent 23µs making 1 call to strict::unimport
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
27816µs1;
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.