← 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 11:58:52 2013
Reported on Tue Oct 15 12:01:02 2013

Filename/usr/share/perl/5.10/Params/Check.pm
StatementsExecuted 35 statements in 1.95ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1114.69ms5.56msParams::Check::::BEGIN@8Params::Check::BEGIN@8
1111.46ms1.71msParams::Check::::BEGIN@6Params::Check::BEGIN@6
11124µs24µsParams::Check::::BEGIN@10Params::Check::BEGIN@10
11120µs135µsParams::Check::::BEGIN@5Params::Check::BEGIN@5
11116µs241µsParams::Check::::BEGIN@12Params::Check::BEGIN@12
11116µs20µsParams::Check::::BEGIN@3Params::Check::BEGIN@3
1117µs7µsParams::Check::::BEGIN@11Params::Check::BEGIN@11
0000s0sParams::Check::::_clean_up_argsParams::Check::_clean_up_args
0000s0sParams::Check::::_clear_errorParams::Check::_clear_error
0000s0sParams::Check::::_safe_eqParams::Check::_safe_eq
0000s0sParams::Check::::_sanity_check_and_defaultsParams::Check::_sanity_check_and_defaults
0000s0sParams::Check::::_store_errorParams::Check::_store_error
0000s0sParams::Check::::_who_was_itParams::Check::_who_was_it
0000s0sParams::Check::::allowParams::Check::allow
0000s0sParams::Check::::checkParams::Check::check
0000s0sParams::Check::::last_errorParams::Check::last_error
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package Params::Check;
2
3333µs224µs
# spent 20µs (16+4) within Params::Check::BEGIN@3 which was called: # once (16µs+4µs) by Module::Load::Conditional::BEGIN@6 at line 3
use strict;
# spent 20µs making 1 call to Params::Check::BEGIN@3 # spent 4µs making 1 call to strict::import
4
5367µs2250µs
# spent 135µs (20+115) within Params::Check::BEGIN@5 which was called: # once (20µs+115µs) by Module::Load::Conditional::BEGIN@6 at line 5
use Carp qw[carp croak];
# spent 135µs making 1 call to Params::Check::BEGIN@5 # spent 115µs making 1 call to Exporter::import
63192µs21.88ms
# spent 1.71ms (1.46+251µs) within Params::Check::BEGIN@6 which was called: # once (1.46ms+251µs) by Module::Load::Conditional::BEGIN@6 at line 6
use Locale::Maketext::Simple Style => 'gettext';
# spent 1.71ms making 1 call to Params::Check::BEGIN@6 # spent 167µs making 1 call to Locale::Maketext::Simple::import
7
83176µs25.63ms
# spent 5.56ms (4.69+867µs) within Params::Check::BEGIN@8 which was called: # once (4.69ms+867µs) by Module::Load::Conditional::BEGIN@6 at line 8
use Data::Dumper;
# spent 5.56ms making 1 call to Params::Check::BEGIN@8 # spent 70µs making 1 call to Exporter::import
9
10
# spent 24µs within Params::Check::BEGIN@10 which was called: # once (24µs+0s) by Module::Load::Conditional::BEGIN@6 at line 32
BEGIN {
11350µs17µs
# spent 7µs within Params::Check::BEGIN@11 which was called: # once (7µs+0s) by Module::Load::Conditional::BEGIN@6 at line 11
use Exporter ();
# spent 7µs making 1 call to Params::Check::BEGIN@11
121225µs
# spent 241µs (16+225) within Params::Check::BEGIN@12 which was called: # once (16µs+225µs) by Module::Load::Conditional::BEGIN@6 at line 16
use vars qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $ALLOW_UNKNOWN
# spent 225µs making 1 call to vars::import
13 $STRICT_TYPE $STRIP_LEADING_DASHES $NO_DUPLICATES
14 $PRESERVE_CASE $ONLY_ALLOW_DEFINED $WARNINGS_FATAL
15 $SANITY_CHECK_TEMPLATE $CALLER_DEPTH $_ERROR_STRING
163141µs1241µs ];
# spent 241µs making 1 call to Params::Check::BEGIN@12
17
181324µs @ISA = qw[ Exporter ];
19 @EXPORT_OK = qw[check allow last_error];
20
21 $VERSION = '0.26';
22 $VERBOSE = $^W ? 1 : 0;
23 $NO_DUPLICATES = 0;
24 $STRIP_LEADING_DASHES = 0;
25 $STRICT_TYPE = 0;
26 $ALLOW_UNKNOWN = 0;
27 $PRESERVE_CASE = 0;
28 $ONLY_ALLOW_DEFINED = 0;
29 $SANITY_CHECK_TEMPLATE = 1;
30 $WARNINGS_FATAL = 0;
31 $CALLER_DEPTH = 0;
3211.24ms124µs}
# spent 24µs making 1 call to Params::Check::BEGIN@10
33
34112µsmy %known_keys = map { $_ => 1 }
35 qw| required allow default strict_type no_override
36 store defined |;
37
38=pod
39
- -
247sub check {
248 my ($utmpl, $href, $verbose) = @_;
249
250 ### did we get the arguments we need? ###
251 return if !$utmpl or !$href;
252
253 ### sensible defaults ###
254 $verbose ||= $VERBOSE || 0;
255
256 ### clear the current error string ###
257 _clear_error();
258
259 ### XXX what type of template is it? ###
260 ### { key => { } } ?
261 #if (ref $args eq 'HASH') {
262 # 1;
263 #}
264
265 ### clean up the template ###
266 my $args = _clean_up_args( $href ) or return;
267
268 ### sanity check + defaults + required keys set? ###
269 my $defs = _sanity_check_and_defaults( $utmpl, $args, $verbose )
270 or return;
271
272 ### deref only once ###
273 my %utmpl = %$utmpl;
274 my %args = %$args;
275 my %defs = %$defs;
276
277 ### flag to see if anything went wrong ###
278 my $wrong;
279
280 ### flag to see if we warned for anything, needed for warnings_fatal
281 my $warned;
282
283 for my $key (keys %args) {
284
285 ### you gave us this key, but it's not in the template ###
286 unless( $utmpl{$key} ) {
287
288 ### but we'll allow it anyway ###
289 if( $ALLOW_UNKNOWN ) {
290 $defs{$key} = $args{$key};
291
292 ### warn about the error ###
293 } else {
294 _store_error(
295 loc("Key '%1' is not a valid key for %2 provided by %3",
296 $key, _who_was_it(), _who_was_it(1)), $verbose);
297 $warned ||= 1;
298 }
299 next;
300 }
301
302 ### check if you're even allowed to override this key ###
303 if( $utmpl{$key}->{'no_override'} ) {
304 _store_error(
305 loc(q[You are not allowed to override key '%1'].
306 q[for %2 from %3], $key, _who_was_it(), _who_was_it(1)),
307 $verbose
308 );
309 $warned ||= 1;
310 next;
311 }
312
313 ### copy of this keys template instructions, to save derefs ###
314 my %tmpl = %{$utmpl{$key}};
315
316 ### check if you were supposed to provide defined() values ###
317 if( ($tmpl{'defined'} || $ONLY_ALLOW_DEFINED) and
318 not defined $args{$key}
319 ) {
320 _store_error(loc(q|Key '%1' must be defined when passed|, $key),
321 $verbose );
322 $wrong ||= 1;
323 next;
324 }
325
326 ### check if they should be of a strict type, and if it is ###
327 if( ($tmpl{'strict_type'} || $STRICT_TYPE) and
328 (ref $args{$key} ne ref $tmpl{'default'})
329 ) {
330 _store_error(loc(q|Key '%1' needs to be of type '%2'|,
331 $key, ref $tmpl{'default'} || 'SCALAR'), $verbose );
332 $wrong ||= 1;
333 next;
334 }
335
336 ### check if we have an allow handler, to validate against ###
337 ### allow() will report its own errors ###
338 if( exists $tmpl{'allow'} and not do {
339 local $_ERROR_STRING;
340 allow( $args{$key}, $tmpl{'allow'} )
341 }
342 ) {
343 ### stringify the value in the error report -- we don't want dumps
344 ### of objects, but we do want to see *roughly* what we passed
345 _store_error(loc(q|Key '%1' (%2) is of invalid type for '%3' |.
346 q|provided by %4|,
347 $key, "$args{$key}", _who_was_it(),
348 _who_was_it(1)), $verbose);
349 $wrong ||= 1;
350 next;
351 }
352
353 ### we got here, then all must be OK ###
354 $defs{$key} = $args{$key};
355
356 }
357
358 ### croak with the collected errors if there were errors and
359 ### we have the fatal flag toggled.
360 croak(__PACKAGE__->last_error) if ($wrong || $warned) && $WARNINGS_FATAL;
361
362 ### done with our loop... if $wrong is set, somethign went wrong
363 ### and the user is already informed, just return...
364 return if $wrong;
365
366 ### check if we need to store any of the keys ###
367 ### can't do it before, because something may go wrong later,
368 ### leaving the user with a few set variables
369 for my $key (keys %defs) {
370 if( my $ref = $utmpl{$key}->{'store'} ) {
371 $$ref = $NO_DUPLICATES ? delete $defs{$key} : $defs{$key};
372 }
373 }
374
375 return \%defs;
376}
377
378=head2 allow( $test_me, \@criteria );
379
- -
420sub allow {
421 ### use $_[0] and $_[1] since this is hot code... ###
422 #my ($val, $ref) = @_;
423
424 ### it's a regexp ###
425 if( ref $_[1] eq 'Regexp' ) {
426 local $^W; # silence warnings if $val is undef #
427 return if $_[0] !~ /$_[1]/;
428
429 ### it's a sub ###
430 } elsif ( ref $_[1] eq 'CODE' ) {
431 return unless $_[1]->( $_[0] );
432
433 ### it's an array ###
434 } elsif ( ref $_[1] eq 'ARRAY' ) {
435
436 ### loop over the elements, see if one of them says the
437 ### value is OK
438 ### also, short-cicruit when possible
439 for ( @{$_[1]} ) {
440 return 1 if allow( $_[0], $_ );
441 }
442
443 return;
444
445 ### fall back to a simple, but safe 'eq' ###
446 } else {
447 return unless _safe_eq( $_[0], $_[1] );
448 }
449
450 ### we got here, no failures ###
451 return 1;
452}
453
454### helper functions ###
455
456### clean up the template ###
457sub _clean_up_args {
458 ### don't even bother to loop, if there's nothing to clean up ###
459 return $_[0] if $PRESERVE_CASE and !$STRIP_LEADING_DASHES;
460
461 my %args = %{$_[0]};
462
463 ### keys are note aliased ###
464 for my $key (keys %args) {
465 my $org = $key;
466 $key = lc $key unless $PRESERVE_CASE;
467 $key =~ s/^-// if $STRIP_LEADING_DASHES;
468 $args{$key} = delete $args{$org} if $key ne $org;
469 }
470
471 ### return references so we always return 'true', even on empty
472 ### arguments
473 return \%args;
474}
475
476sub _sanity_check_and_defaults {
477 my %utmpl = %{$_[0]};
478 my %args = %{$_[1]};
479 my $verbose = $_[2];
480
481 my %defs; my $fail;
482 for my $key (keys %utmpl) {
483
484 ### check if required keys are provided
485 ### keys are now lower cased, unless preserve case was enabled
486 ### at which point, the utmpl keys must match, but that's the users
487 ### problem.
488 if( $utmpl{$key}->{'required'} and not exists $args{$key} ) {
489 _store_error(
490 loc(q|Required option '%1' is not provided for %2 by %3|,
491 $key, _who_was_it(1), _who_was_it(2)), $verbose );
492
493 ### mark the error ###
494 $fail++;
495 next;
496 }
497
498 ### next, set the default, make sure the key exists in %defs ###
499 $defs{$key} = $utmpl{$key}->{'default'}
500 if exists $utmpl{$key}->{'default'};
501
502 if( $SANITY_CHECK_TEMPLATE ) {
503 ### last, check if they provided any weird template keys
504 ### -- do this last so we don't always execute this code.
505 ### just a small optimization.
506 map { _store_error(
507 loc(q|Template type '%1' not supported [at key '%2']|,
508 $_, $key), 1, 1 );
509 } grep {
510 not $known_keys{$_}
511 } keys %{$utmpl{$key}};
512
513 ### make sure you passed a ref, otherwise, complain about it!
514 if ( exists $utmpl{$key}->{'store'} ) {
515 _store_error( loc(
516 q|Store variable for '%1' is not a reference!|, $key
517 ), 1, 1 ) unless ref $utmpl{$key}->{'store'};
518 }
519 }
520 }
521
522 ### errors found ###
523 return if $fail;
524
525 ### return references so we always return 'true', even on empty
526 ### defaults
527 return \%defs;
528}
529
530sub _safe_eq {
531 ### only do a straight 'eq' if they're both defined ###
532 return defined($_[0]) && defined($_[1])
533 ? $_[0] eq $_[1]
534 : defined($_[0]) eq defined($_[1]);
535}
536
537sub _who_was_it {
538 my $level = $_[0] || 0;
539
540 return (caller(2 + $CALLER_DEPTH + $level))[3] || 'ANON'
541}
542
543=head2 last_error()
544
- -
55522µs{ $_ERROR_STRING = '';
556
557 sub _store_error {
558 my($err, $verbose, $offset) = @_[0..2];
559 $verbose ||= 0;
560 $offset ||= 0;
561 my $level = 1 + $offset;
562
563 local $Carp::CarpLevel = $level;
564
565 carp $err if $verbose;
566
567 $_ERROR_STRING .= $err . "\n";
568 }
569
570 sub _clear_error {
571 $_ERROR_STRING = '';
572 }
573
574 sub last_error { $_ERROR_STRING }
575}
576
57717µs1;
578
579=head1 Global Variables
580
- -
707# Local variables:
708# c-indentation-style: bsd
709# c-basic-offset: 4
710# indent-tabs-mode: nil
711# End:
712# vim: expandtab shiftwidth=4:
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.