← 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:12:32 2013

Filename/usr/share/koha/lib/C4/Auth_with_ldap.pm
StatementsExecuted 56 statements in 3.44ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1118.87ms609msC4::Auth_with_ldap::::BEGIN@26C4::Auth_with_ldap::BEGIN@26
1115.90ms117msC4::Auth_with_ldap::::BEGIN@31C4::Auth_with_ldap::BEGIN@31
1111.85ms1.97msC4::Auth_with_ldap::::BEGIN@32C4::Auth_with_ldap::BEGIN@32
11144µs51µsC4::Auth_with_ldap::::BEGIN@20C4::Auth_with_ldap::BEGIN@20
11122µs22µsC4::Auth_with_ldap::::BEGIN@36C4::Auth_with_ldap::BEGIN@36
11121µs56µsC4::Auth_with_ldap::::BEGIN@27C4::Auth_with_ldap::BEGIN@27
11121µs60µsC4::Auth_with_ldap::::BEGIN@22C4::Auth_with_ldap::BEGIN@22
11118µs23µsC4::Auth_with_ldap::::BEGIN@25C4::Auth_with_ldap::BEGIN@25
11115µs115µsC4::Auth_with_ldap::::BEGIN@54C4::Auth_with_ldap::BEGIN@54
11115µs53µsC4::Auth_with_ldap::::BEGIN@30C4::Auth_with_ldap::BEGIN@30
11114µs20µsC4::Auth_with_ldap::::BEGIN@28C4::Auth_with_ldap::BEGIN@28
11114µs206µsC4::Auth_with_ldap::::BEGIN@29C4::Auth_with_ldap::BEGIN@29
11113µs123µsC4::Auth_with_ldap::::BEGIN@24C4::Auth_with_ldap::BEGIN@24
11110µs95µsC4::Auth_with_ldap::::BEGIN@34C4::Auth_with_ldap::BEGIN@34
0000s0sC4::Auth_with_ldap::::_do_changepasswordC4::Auth_with_ldap::_do_changepassword
0000s0sC4::Auth_with_ldap::::checkpw_ldapC4::Auth_with_ldap::checkpw_ldap
0000s0sC4::Auth_with_ldap::::descriptionC4::Auth_with_ldap::description
0000s0sC4::Auth_with_ldap::::exists_localC4::Auth_with_ldap::exists_local
0000s0sC4::Auth_with_ldap::::ldap_entry_2_hashC4::Auth_with_ldap::ldap_entry_2_hash
0000s0sC4::Auth_with_ldap::::ldapserver_errorC4::Auth_with_ldap::ldapserver_error
0000s0sC4::Auth_with_ldap::::search_methodC4::Auth_with_ldap::search_method
0000s0sC4::Auth_with_ldap::::update_localC4::Auth_with_ldap::update_local
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package C4::Auth_with_ldap;
2
3# Copyright 2000-2002 Katipo Communications
4#
5# This file is part of Koha.
6#
7# Koha is free software; you can redistribute it and/or modify it under the
8# terms of the GNU General Public License as published by the Free Software
9# Foundation; either version 2 of the License, or (at your option) any later
10# version.
11#
12# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
13# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
14# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
15#
16# You should have received a copy of the GNU General Public License along
17# with Koha; if not, write to the Free Software Foundation, Inc.,
18# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
19
20340µs258µs
# spent 51µs (44+7) within C4::Auth_with_ldap::BEGIN@20 which was called: # once (44µs+7µs) by C4::Auth::BEGIN@39 at line 20
use strict;
# spent 51µs making 1 call to C4::Auth_with_ldap::BEGIN@20 # spent 7µs making 1 call to strict::import
21#use warnings; FIXME - Bug 2505
22342µs299µs
# spent 60µs (21+39) within C4::Auth_with_ldap::BEGIN@22 which was called: # once (21µs+39µs) by C4::Auth::BEGIN@39 at line 22
use Digest::MD5 qw(md5_base64);
# spent 60µs making 1 call to C4::Auth_with_ldap::BEGIN@22 # spent 39µs making 1 call to Exporter::import
23
24354µs2233µs
# spent 123µs (13+110) within C4::Auth_with_ldap::BEGIN@24 which was called: # once (13µs+110µs) by C4::Auth::BEGIN@39 at line 24
use C4::Debug;
# spent 123µs making 1 call to C4::Auth_with_ldap::BEGIN@24 # spent 110µs making 1 call to Exporter::import
25339µs229µs
# spent 23µs (18+6) within C4::Auth_with_ldap::BEGIN@25 which was called: # once (18µs+6µs) by C4::Auth::BEGIN@39 at line 25
use C4::Context;
# spent 23µs making 1 call to C4::Auth_with_ldap::BEGIN@25 # spent 6µs making 1 call to C4::Context::import
263165µs2609ms
# spent 609ms (8.87+600) within C4::Auth_with_ldap::BEGIN@26 which was called: # once (8.87ms+600ms) by C4::Auth::BEGIN@39 at line 26
use C4::Members qw(AddMember changepassword);
# spent 609ms making 1 call to C4::Auth_with_ldap::BEGIN@26 # spent 274µs making 1 call to Exporter::import
27342µs291µs
# spent 56µs (21+35) within C4::Auth_with_ldap::BEGIN@27 which was called: # once (21µs+35µs) by C4::Auth::BEGIN@39 at line 27
use C4::Members::Attributes;
# spent 56µs making 1 call to C4::Auth_with_ldap::BEGIN@27 # spent 35µs making 1 call to Exporter::import
28334µs226µs
# spent 20µs (14+6) within C4::Auth_with_ldap::BEGIN@28 which was called: # once (14µs+6µs) by C4::Auth::BEGIN@39 at line 28
use C4::Members::AttributeTypes;
# spent 20µs making 1 call to C4::Auth_with_ldap::BEGIN@28 # spent 6µs making 1 call to UNIVERSAL::import
29341µs2397µs
# spent 206µs (14+192) within C4::Auth_with_ldap::BEGIN@29 which was called: # once (14µs+192µs) by C4::Auth::BEGIN@39 at line 29
use C4::Utils qw( :all );
# spent 206µs making 1 call to C4::Auth_with_ldap::BEGIN@29 # spent 192µs making 1 call to Exporter::import
30333µs291µs
# spent 53µs (15+38) within C4::Auth_with_ldap::BEGIN@30 which was called: # once (15µs+38µs) by C4::Auth::BEGIN@39 at line 30
use List::MoreUtils qw( any );
# spent 53µs making 1 call to C4::Auth_with_ldap::BEGIN@30 # spent 38µs making 1 call to Exporter::import
313197µs2117ms
# spent 117ms (5.90+111) within C4::Auth_with_ldap::BEGIN@31 which was called: # once (5.90ms+111ms) by C4::Auth::BEGIN@39 at line 31
use Net::LDAP;
# spent 117ms making 1 call to C4::Auth_with_ldap::BEGIN@31 # spent 40µs making 1 call to Net::LDAP::import
323190µs21.97ms
# spent 1.97ms (1.85+117µs) within C4::Auth_with_ldap::BEGIN@32 which was called: # once (1.85ms+117µs) by C4::Auth::BEGIN@39 at line 32
use Net::LDAP::Filter;
# spent 1.97ms making 1 call to C4::Auth_with_ldap::BEGIN@32 # spent 4µs making 1 call to UNIVERSAL::import
33
34361µs2180µs
# spent 95µs (10+85) within C4::Auth_with_ldap::BEGIN@34 which was called: # once (10µs+85µs) by C4::Auth::BEGIN@39 at line 34
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $debug);
# spent 95µs making 1 call to C4::Auth_with_ldap::BEGIN@34 # spent 85µs making 1 call to vars::import
35
36
# spent 22µs within C4::Auth_with_ldap::BEGIN@36 which was called: # once (22µs+0s) by C4::Auth::BEGIN@39 at line 41
BEGIN {
3711µs require Exporter;
3812µs $VERSION = 3.07.00.049; # set the version for version checking
39112µs @ISA = qw(Exporter);
4018µs @EXPORT = qw( checkpw_ldap );
41193µs122µs}
# spent 22µs making 1 call to C4::Auth_with_ldap::BEGIN@36
42
43# Redefine checkpw_ldap:
44# connect to LDAP (named or anonymous)
45# ~ retrieves $userid from KOHA_CONF mapping
46# ~ then compares $password with userPassword
47# ~ then gets the LDAP entry
48# ~ and calls the memberadd if necessary
49
50sub ldapserver_error {
51 return sprintf('No ldapserver "%s" defined in KOHA_CONF: ' . $ENV{KOHA_CONF}, shift);
52}
53
5432.33ms2214µs
# spent 115µs (15+99) within C4::Auth_with_ldap::BEGIN@54 which was called: # once (15µs+99µs) by C4::Auth::BEGIN@39 at line 54
use vars qw($mapping @ldaphosts $base $ldapname $ldappassword);
# spent 115µs making 1 call to C4::Auth_with_ldap::BEGIN@54 # spent 99µs making 1 call to vars::import
55114µs1793µsmy $context = C4::Context->new() or die 'C4::Context->new failed';
# spent 793µs making 1 call to C4::Context::new
5614µs118µsmy $ldap = C4::Context->config("ldapserver") or die 'No "ldapserver" in server hash from KOHA_CONF: ' . $ENV{KOHA_CONF};
# spent 18µs making 1 call to C4::Context::config
5711µsmy $prefhost = $ldap->{hostname} or die ldapserver_error('hostname');
5811µsmy $base = $ldap->{base} or die ldapserver_error('base');
591600ns$ldapname = $ldap->{user} ;
601600ns$ldappassword = $ldap->{pass} ;
61110µsour %mapping = %{$ldap->{mapping}}; # FIXME dpavlin -- don't die because of || (); from 6eaf8511c70eb82d797c941ef528f4310a15e9f9
6214µsmy @mapkeys = keys %mapping;
631300ns$debug and print STDERR "Got ", scalar(@mapkeys), " ldap mapkeys ( total ): ", join ' ', @mapkeys, "\n";
6417µs@mapkeys = grep {defined $mapping{$_}->{is}} @mapkeys;
651200ns$debug and print STDERR "Got ", scalar(@mapkeys), " ldap mapkeys (populated): ", join ' ', @mapkeys, "\n";
66
6714µsmy %config = (
68 anonymous => ($ldapname and $ldappassword) ? 0 : 1,
69 replicate => defined($ldap->{replicate}) ? $ldap->{replicate} : 1, # add from LDAP to Koha database for new user
70 update => defined($ldap->{update} ) ? $ldap->{update} : 1, # update from LDAP to Koha database for existing user
71);
72
73sub description {
74 my $result = shift or return;
75 return "LDAP error #" . $result->code
76 . ": " . $result->error_name . "\n"
77 . "# " . $result->error_text . "\n";
78}
79
80sub search_method {
81 my $db = shift or return;
82 my $userid = shift or return;
83 my $uid_field = $mapping{userid}->{is} or die ldapserver_error("mapping for 'userid'");
84 my $filter = Net::LDAP::Filter->new("$uid_field=$userid") or die "Failed to create new Net::LDAP::Filter";
85 my $search = $db->search(
86 base => $base,
87 filter => $filter,
88 # attrs => ['*'],
89 ) or die "LDAP search failed to return object.";
90 my $count = $search->count;
91 if ($search->code > 0) {
92 warn sprintf("LDAP Auth rejected : %s gets %d hits\n", $filter->as_string, $count) . description($search);
93 return 0;
94 }
95 if ($count != 1) {
96 warn sprintf("LDAP Auth rejected : %s gets %d hits\n", $filter->as_string, $count);
97 return 0;
98 }
99 return $search;
100}
101
102sub checkpw_ldap {
103 my ($dbh, $userid, $password) = @_;
104 my @hosts = split(',', $prefhost);
105 my $db = Net::LDAP->new(\@hosts);
106 unless ( $db ) {
107 warn "LDAP connexion failed";
108 return 0;
109 }
110
111 #$debug and $db->debug(5);
112 my $userldapentry;
113
114 if ( $ldap->{auth_by_bind} ) {
115 my $principal_name;
116 if ( $ldap->{anonymous_bind} ) {
117
118 # Perform an anonymous bind
119 my $res = $db->bind;
120 if ( $res->code ) {
121 warn "Anonymous LDAP bind failed: " . description($res);
122 return 0;
123 }
124
125 # Perform a LDAP search for the given username
126 my $search = search_method( $db, $userid )
127 or return 0; # warnings are in the sub
128 $userldapentry = $search->shift_entry;
129 $principal_name = $userldapentry->dn;
130 }
131 else {
132 $principal_name = $ldap->{principal_name};
133 if ( $principal_name and $principal_name =~ /\%/ ) {
134 $principal_name = sprintf( $principal_name, $userid );
135 }
136 else {
137 $principal_name = $userid;
138 }
139 }
140
141 # Perform a LDAP bind for the given username using the matched DN
142 my $res = $db->bind( $principal_name, password => $password );
143 if ( $res->code ) {
144 warn "LDAP bind failed as kohauser $userid: " . description($res);
145 return 0;
146 }
147 if ( !defined($userldapentry)
148 && ( $config{update} or $config{replicate} ) )
149 {
150 my $search = search_method( $db, $userid ) or return 0;
151 $userldapentry = $search->shift_entry;
152 }
153 } else {
154 my $res = ($config{anonymous}) ? $db->bind : $db->bind($ldapname, password=>$ldappassword);
155 if ($res->code) { # connection refused
156 warn "LDAP bind failed as ldapuser " . ($ldapname || '[ANONYMOUS]') . ": " . description($res);
157 return 0;
158 }
159 my $search = search_method($db, $userid) or return 0; # warnings are in the sub
160 $userldapentry = $search->shift_entry;
161 my $cmpmesg = $db->compare( $userldapentry, attr=>'userpassword', value => $password );
162 if ($cmpmesg->code != 6) {
163 warn "LDAP Auth rejected : invalid password for user '$userid'. " . description($cmpmesg);
164 return 0;
165 }
166 }
167
168 # To get here, LDAP has accepted our user's login attempt.
169 # But we still have work to do. See perldoc below for detailed breakdown.
170
171 my (%borrower);
172 my ($borrowernumber,$cardnumber,$local_userid,$savedpw) = exists_local($userid);
173
174 if (( $borrowernumber and $config{update} ) or
175 (!$borrowernumber and $config{replicate}) ) {
176 %borrower = ldap_entry_2_hash($userldapentry,$userid);
177 $debug and print STDERR "checkpw_ldap received \%borrower w/ " . keys(%borrower), " keys: ", join(' ', keys %borrower), "\n";
178 }
179
180 if ($borrowernumber) {
181 if ($config{update}) { # A1, B1
182 my $c2 = &update_local($local_userid,$password,$borrowernumber,\%borrower) || '';
183 ($cardnumber eq $c2) or warn "update_local returned cardnumber '$c2' instead of '$cardnumber'";
184 } else { # C1, D1
185 # maybe update just the password?
186 return(1, $cardnumber, $local_userid);
187 }
188 } elsif ($config{replicate}) { # A2, C2
189 $borrowernumber = AddMember(%borrower) or die "AddMember failed";
190 } else {
191 return 0; # B2, D2
192 }
193 if (C4::Context->preference('ExtendedPatronAttributes') && $borrowernumber && ($config{update} ||$config{replicate})) {
194 my $extended_patron_attributes;
195 foreach my $attribute_type ( C4::Members::AttributeTypes::GetAttributeTypes() ) {
196 my $code = $attribute_type->{code};
197 if ( exists($borrower{$code}) && $borrower{$code} !~ m/^\s*$/ ) { # skip empty values
198 push @$extended_patron_attributes, { code => $code, value => $borrower{$code} };
199 }
200 }
201 my @errors;
202 #Check before add
203 for (my $i; $i< scalar(@$extended_patron_attributes)-1;$i++) {
204 my $attr=$extended_patron_attributes->[$i];
205 unless (C4::Members::Attributes::CheckUniqueness($attr->{code}, $attr->{value}, $borrowernumber)) {
206 unshift @errors, $i;
207 warn "ERROR_extended_unique_id_failed $attr->{code} $attr->{value}";
208 }
209 }
210 #Removing erroneous attributes
211 foreach my $index (@errors){
212 @$extended_patron_attributes=splice(@$extended_patron_attributes,$index,1);
213 }
214 C4::Members::Attributes::SetBorrowerAttributes($borrowernumber, $extended_patron_attributes);
215 }
216return(1, $cardnumber, $userid);
217}
218
219# Pass LDAP entry object and local cardnumber (userid).
220# Returns borrower hash.
221# Edit KOHA_CONF so $memberhash{'xxx'} fits your ldap structure.
222# Ensure that mandatory fields are correctly filled!
223#
224sub ldap_entry_2_hash {
225 my $userldapentry = shift;
226 my %borrower = ( cardnumber => shift );
227 my %memberhash;
228 $userldapentry->exists('uid'); # This is bad, but required! By side-effect, this initializes the attrs hash.
229 if ($debug) {
230 print STDERR "\nkeys(\%\$userldapentry) = " . join(', ', keys %$userldapentry), "\n", $userldapentry->dump();
231 foreach (keys %$userldapentry) {
232 print STDERR "\n\nLDAP key: $_\t", sprintf('(%s)', ref $userldapentry->{$_}), "\n";
233 hashdump("LDAP key: ",$userldapentry->{$_});
234 }
235 }
236 my $x = $userldapentry->{attrs} or return;
237 foreach (keys %$x) {
238 $memberhash{$_} = join ' ', @{$x->{$_}};
239 $debug and print STDERR sprintf("building \$memberhash{%s} = ", $_, join(' ', @{$x->{$_}})), "\n";
240 }
241 $debug and print STDERR "Finsihed \%memberhash has ", scalar(keys %memberhash), " keys\n",
242 "Referencing \%mapping with ", scalar(keys %mapping), " keys\n";
243 foreach my $key (keys %mapping) {
244 my $data = $memberhash{ lc($mapping{$key}->{is}) }; # Net::LDAP returns all names in lowercase
245 $debug and printf STDERR "mapping %20s ==> %-20s (%s)\n", $key, $mapping{$key}->{is}, $data;
246 unless (defined $data) {
247 $data = $mapping{$key}->{content} || ''; # default or failsafe ''
248 }
249 $borrower{$key} = ($data ne '') ? $data : ' ' ;
250 }
251 $borrower{initials} = $memberhash{initials} ||
252 ( substr($borrower{'firstname'},0,1)
253 . substr($borrower{ 'surname' },0,1)
254 . " ");
255
256 # check if categorycode exists, if not, fallback to default from koha-conf.xml
257 my $dbh = C4::Context->dbh;
258 my $sth = $dbh->prepare("SELECT categorycode FROM categories WHERE categorycode = ?");
259 $sth->execute( uc($borrower{'categorycode'}) );
260 unless ( my $row = $sth->fetchrow_hashref ) {
261 my $default = $mapping{'categorycode'}->{content};
262 $debug && warn "Can't find ", $borrower{'categorycode'}, " default to: $default for ", $borrower{userid};
263 $borrower{'categorycode'} = $default
264 }
265
266 return %borrower;
267}
268
269sub exists_local {
270 my $arg = shift;
271 my $dbh = C4::Context->dbh;
272 my $select = "SELECT borrowernumber,cardnumber,userid,password FROM borrowers ";
273
274 my $sth = $dbh->prepare("$select WHERE userid=?"); # was cardnumber=?
275 $sth->execute($arg);
276 $debug and printf STDERR "Userid '$arg' exists_local? %s\n", $sth->rows;
277 ($sth->rows == 1) and return $sth->fetchrow;
278
279 $sth = $dbh->prepare("$select WHERE cardnumber=?");
280 $sth->execute($arg);
281 $debug and printf STDERR "Cardnumber '$arg' exists_local? %s\n", $sth->rows;
282 ($sth->rows == 1) and return $sth->fetchrow;
283 return 0;
284}
285
286# This function performs a password update, given the userid, borrowerid,
287# and digested password. It will verify that things are correct and return the
288# borrowers cardnumber. The idea is that it is used to keep the local
289# passwords in sync with the LDAP passwords.
290#
291# $cardnum = _do_changepassword($userid, $borrowerid, $digest)
292#
293# Note: if the LDAP config has the update_password tag set to a false value,
294# then this will not update the password, it will simply return the cardnumber.
295sub _do_changepassword {
296 my ( $userid, $borrowerid, $digest ) = @_;
297
298 if ( exists( $ldap->{update_password} ) && !$ldap->{update_password} ) {
299
300 # This path doesn't update the password, just returns the
301 # card number
302 my $sth = C4::Context->dbh->prepare(
303 'SELECT cardnumber FROM borrowers WHERE borrowernumber=?' );
304 $sth->execute($borrowerid);
305 die
306"Unable to access borrowernumber with userid=$userid, borrowernumber=$borrowerid"
307 if !$sth->rows;
308 my ($cardnum) = $sth->fetchrow;
309 return $cardnum;
310 }
311 else {
312
313 # This path updates the password in the database
314 print STDERR
315"changing local password for borrowernumber=$borrowerid to '$digest'\n"
316 if $debug;
317 changepassword( $userid, $borrowerid, $digest );
318
319 # Confirm changes
320 my $sth = C4::Context->dbh->prepare(
321 "SELECT password,cardnumber FROM borrowers WHERE borrowernumber=? "
322 );
323 $sth->execute($borrowerid);
324 if ( $sth->rows ) {
325 my ( $md5password, $cardnum ) = $sth->fetchrow;
326 ( $digest eq $md5password ) and return $cardnum;
327 warn
328"Password mismatch after update to cardnumber=$cardnum (borrowernumber=$borrowerid)";
329 return;
330 }
331 die
332"Unexpected error after password update to userid/borrowernumber: $userid / $borrowerid.";
333 }
334}
335
336sub update_local {
337 my $userid = shift or return;
338 my $digest = md5_base64(shift) or return;
339 my $borrowerid = shift or return;
340 my $borrower = shift or return;
341 my @keys = keys %$borrower;
342 my $dbh = C4::Context->dbh;
343 my $query = "UPDATE borrowers\nSET " .
344 join(',', map {"$_=?"} @keys) .
345 "\nWHERE borrowernumber=? ";
346 my $sth = $dbh->prepare($query);
347 if ($debug) {
348 print STDERR $query, "\n",
349 join "\n", map {"$_ = '" . $borrower->{$_} . "'"} @keys;
350 print STDERR "\nuserid = $userid\n";
351 }
352 $sth->execute(
353 ((map {$borrower->{$_}} @keys), $borrowerid)
354 );
355
356 # MODIFY PASSWORD/LOGIN
357 _do_changepassword($userid, $borrowerid, $digest);
358}
359
36018µs1;
361__END__
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.