← Index
NYTProf Performance Profile   « line view »
For split.pl
  Run on Thu Apr 20 02:05:47 2023
Reported on Thu Apr 20 18:31:09 2023

Filename/usr/share/perl/5.36/Params/Check.pm
StatementsExecuted 27 statements in 1.01ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
111964µs1.08msParams::Check::::BEGIN@6Params::Check::BEGIN@6
1119µs9µsParams::Check::::BEGIN@8Params::Check::BEGIN@8
1117µs9µsParams::Check::::BEGIN@3Params::Check::BEGIN@3
1114µs64µsParams::Check::::BEGIN@10Params::Check::BEGIN@10
1113µs19µsParams::Check::::BEGIN@5Params::Check::BEGIN@5
1112µs2µsParams::Check::::BEGIN@9Params::Check::BEGIN@9
0000s0sParams::Check::::_clear_errorParams::Check::_clear_error
0000s0sParams::Check::::_safe_eqParams::Check::_safe_eq
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
3219µs210µs
# spent 9µs (7+2) within Params::Check::BEGIN@3 which was called: # once (7µs+2µs) by IPC::Cmd::BEGIN@59 at line 3
use strict;
# spent 9µs making 1 call to Params::Check::BEGIN@3 # spent 2µs making 1 call to strict::import
4
5215µs234µs
# spent 19µs (3+15) within Params::Check::BEGIN@5 which was called: # once (3µs+15µs) by IPC::Cmd::BEGIN@59 at line 5
use Carp qw[carp croak];
# spent 19µs making 1 call to Params::Check::BEGIN@5 # spent 15µs making 1 call to Exporter::import
6296µs21.18ms
# spent 1.08ms (964µs+117µs) within Params::Check::BEGIN@6 which was called: # once (964µs+117µs) by IPC::Cmd::BEGIN@59 at line 6
use Locale::Maketext::Simple Style => 'gettext';
# spent 1.08ms making 1 call to Params::Check::BEGIN@6 # spent 96µs making 1 call to Locale::Maketext::Simple::import
7
8
# spent 9µs within Params::Check::BEGIN@8 which was called: # once (9µs+0s) by IPC::Cmd::BEGIN@59 at line 30
BEGIN {
9224µs12µs
# spent 2µs within Params::Check::BEGIN@9 which was called: # once (2µs+0s) by IPC::Cmd::BEGIN@59 at line 9
use Exporter ();
# spent 2µs making 1 call to Params::Check::BEGIN@9
1013µs159µs
# spent 64µs (4+59) within Params::Check::BEGIN@10 which was called: # once (4µs+59µs) by IPC::Cmd::BEGIN@59 at line 14
use vars qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $ALLOW_UNKNOWN
# spent 59µs making 1 call to vars::import
11 $STRICT_TYPE $STRIP_LEADING_DASHES $NO_DUPLICATES
12 $PRESERVE_CASE $ONLY_ALLOW_DEFINED $WARNINGS_FATAL
13 $SANITY_CHECK_TEMPLATE $CALLER_DEPTH $_ERROR_STRING
14145µs164µs ];
# spent 64µs making 1 call to Params::Check::BEGIN@10
15
1615µs @ISA = qw[ Exporter ];
171400ns @EXPORT_OK = qw[check allow last_error];
18
191200ns $VERSION = '0.38';
201600ns $VERBOSE = $^W ? 1 : 0;
211100ns $NO_DUPLICATES = 0;
221100ns $STRIP_LEADING_DASHES = 0;
2310s $STRICT_TYPE = 0;
241100ns $ALLOW_UNKNOWN = 0;
2510s $PRESERVE_CASE = 0;
261100ns $ONLY_ALLOW_DEFINED = 0;
2710s $SANITY_CHECK_TEMPLATE = 1;
281100ns $WARNINGS_FATAL = 0;
2912µs $CALLER_DEPTH = 0;
301795µs19µs}
# spent 9µs making 1 call to Params::Check::BEGIN@8
31
3213µsmy %known_keys = map { $_ => 1 }
33 qw| required allow default strict_type no_override
34 store defined |;
35
36=pod
37
38=head1 NAME
39
40Params::Check - A generic input parsing/checking mechanism.
41
42=head1 SYNOPSIS
43
44 use Params::Check qw[check allow last_error];
45
46 sub fill_personal_info {
47 my %hash = @_;
48 my $x;
49
50 my $tmpl = {
51 firstname => { required => 1, defined => 1 },
52 lastname => { required => 1, store => \$x },
53 gender => { required => 1,
54 allow => [qr/M/i, qr/F/i],
55 },
56 married => { allow => [0,1] },
57 age => { default => 21,
58 allow => qr/^\d+$/,
59 },
60
61 phone => { allow => [ sub { return 1 if /$valid_re/ },
62 '1-800-PERL' ]
63 },
64 id_list => { default => [],
65 strict_type => 1
66 },
67 employer => { default => 'NSA', no_override => 1 },
68 };
69
70 ### check() returns a hashref of parsed args on success ###
71 my $parsed_args = check( $tmpl, \%hash, $VERBOSE )
72 or die qw[Could not parse arguments!];
73
74 ... other code here ...
75 }
76
77 my $ok = allow( $colour, [qw|blue green yellow|] );
78
79 my $error = Params::Check::last_error();
80
81
82=head1 DESCRIPTION
83
84Params::Check is a generic input parsing/checking mechanism.
85
86It allows you to validate input via a template. The only requirement
87is that the arguments must be named.
88
89Params::Check can do the following things for you:
90
91=over 4
92
93=item *
94
95Convert all keys to lowercase
96
97=item *
98
99Check if all required arguments have been provided
100
101=item *
102
103Set arguments that have not been provided to the default
104
105=item *
106
107Weed out arguments that are not supported and warn about them to the
108user
109
110=item *
111
112Validate the arguments given by the user based on strings, regexes,
113lists or even subroutines
114
115=item *
116
117Enforce type integrity if required
118
119=back
120
121Most of Params::Check's power comes from its template, which we'll
122discuss below:
123
124=head1 Template
125
126As you can see in the synopsis, based on your template, the arguments
127provided will be validated.
128
129The template can take a different set of rules per key that is used.
130
131The following rules are available:
132
133=over 4
134
135=item default
136
137This is the default value if none was provided by the user.
138This is also the type C<strict_type> will look at when checking type
139integrity (see below).
140
141=item required
142
143A boolean flag that indicates if this argument was a required
144argument. If marked as required and not provided, check() will fail.
145
146=item strict_type
147
148This does a C<ref()> check on the argument provided. The C<ref> of the
149argument must be the same as the C<ref> of the default value for this
150check to pass.
151
152This is very useful if you insist on taking an array reference as
153argument for example.
154
155=item defined
156
157If this template key is true, enforces that if this key is provided by
158user input, its value is C<defined>. This just means that the user is
159not allowed to pass C<undef> as a value for this key and is equivalent
160to:
161 allow => sub { defined $_[0] && OTHER TESTS }
162
163=item no_override
164
165This allows you to specify C<constants> in your template. ie, they
166keys that are not allowed to be altered by the user. It pretty much
167allows you to keep all your C<configurable> data in one place; the
168C<Params::Check> template.
169
170=item store
171
172This allows you to pass a reference to a scalar, in which the data
173will be stored:
174
175 my $x;
176 my $args = check(foo => { default => 1, store => \$x }, $input);
177
178This is basically shorthand for saying:
179
180 my $args = check( { foo => { default => 1 }, $input );
181 my $x = $args->{foo};
182
183You can alter the global variable $Params::Check::NO_DUPLICATES to
184control whether the C<store>'d key will still be present in your
185result set. See the L<Global Variables> section below.
186
187=item allow
188
189A set of criteria used to validate a particular piece of data if it
190has to adhere to particular rules.
191
192See the C<allow()> function for details.
193
194=back
195
196=head1 Functions
197
198=head2 check( \%tmpl, \%args, [$verbose] );
199
200This function is not exported by default, so you'll have to ask for it
201via:
202
203 use Params::Check qw[check];
204
205or use its fully qualified name instead.
206
207C<check> takes a list of arguments, as follows:
208
209=over 4
210
211=item Template
212
213This is a hash reference which contains a template as explained in the
214C<SYNOPSIS> and C<Template> section.
215
216=item Arguments
217
218This is a reference to a hash of named arguments which need checking.
219
220=item Verbose
221
222A boolean to indicate whether C<check> should be verbose and warn
223about what went wrong in a check or not.
224
225You can enable this program wide by setting the package variable
226C<$Params::Check::VERBOSE> to a true value. For details, see the
227section on C<Global Variables> below.
228
229=back
230
231C<check> will return when it fails, or a hashref with lowercase
232keys of parsed arguments when it succeeds.
233
234So a typical call to check would look like this:
235
236 my $parsed = check( \%template, \%arguments, $VERBOSE )
237 or warn q[Arguments could not be parsed!];
238
239A lot of the behaviour of C<check()> can be altered by setting
240package variables. See the section on C<Global Variables> for details
241on this.
242
243=cut
244
245sub check {
246 my ($utmpl, $href, $verbose) = @_;
247
248 ### clear the current error string ###
249 _clear_error();
250
251 ### did we get the arguments we need? ###
252 if ( !$utmpl or !$href ) {
253 _store_error(loc('check() expects two arguments'));
254 return unless $WARNINGS_FATAL;
255 croak(__PACKAGE__->last_error);
256 }
257
258 ### sensible defaults ###
259 $verbose ||= $VERBOSE || 0;
260
261 ### XXX what type of template is it? ###
262 ### { key => { } } ?
263 #if (ref $args eq 'HASH') {
264 # 1;
265 #}
266
267 ### clean up the template ###
268 my $args;
269
270 ### don't even bother to loop, if there's nothing to clean up ###
271 if( $PRESERVE_CASE and !$STRIP_LEADING_DASHES ) {
272 $args = $href;
273 } else {
274 ### keys are not aliased ###
275 for my $key (keys %$href) {
276 my $org = $key;
277 $key = lc $key unless $PRESERVE_CASE;
278 $key =~ s/^-// if $STRIP_LEADING_DASHES;
279 $args->{$key} = $href->{$org};
280 }
281 }
282
283 my %defs;
284
285 ### which template entries have a 'store' member
286 my @want_store;
287
288 ### sanity check + defaults + required keys set? ###
289 my $fail;
290 for my $key (keys %$utmpl) {
291 my $tmpl = $utmpl->{$key};
292
293 ### check if required keys are provided
294 ### keys are now lower cased, unless preserve case was enabled
295 ### at which point, the utmpl keys must match, but that's the users
296 ### problem.
297 if( $tmpl->{'required'} and not exists $args->{$key} ) {
298 _store_error(
299 loc(q|Required option '%1' is not provided for %2 by %3|,
300 $key, _who_was_it(), _who_was_it(1)), $verbose );
301
302 ### mark the error ###
303 $fail++;
304 next;
305 }
306
307 ### next, set the default, make sure the key exists in %defs ###
308 $defs{$key} = $tmpl->{'default'}
309 if exists $tmpl->{'default'};
310
311 if( $SANITY_CHECK_TEMPLATE ) {
312 ### last, check if they provided any weird template keys
313 ### -- do this last so we don't always execute this code.
314 ### just a small optimization.
315 map { _store_error(
316 loc(q|Template type '%1' not supported [at key '%2']|,
317 $_, $key), 1, 0 );
318 } grep {
319 not $known_keys{$_}
320 } keys %$tmpl;
321
322 ### make sure you passed a ref, otherwise, complain about it!
323 if ( exists $tmpl->{'store'} ) {
324 _store_error( loc(
325 q|Store variable for '%1' is not a reference!|, $key
326 ), 1, 0 ) unless ref $tmpl->{'store'};
327 }
328 }
329
330 push @want_store, $key if $tmpl->{'store'};
331 }
332
333 ### errors found ###
334 return if $fail;
335
336 ### flag to see if anything went wrong ###
337 my $wrong;
338
339 ### flag to see if we warned for anything, needed for warnings_fatal
340 my $warned;
341
342 for my $key (keys %$args) {
343 my $arg = $args->{$key};
344
345 ### you gave us this key, but it's not in the template ###
346 unless( $utmpl->{$key} ) {
347
348 ### but we'll allow it anyway ###
349 if( $ALLOW_UNKNOWN ) {
350 $defs{$key} = $arg;
351
352 ### warn about the error ###
353 } else {
354 _store_error(
355 loc("Key '%1' is not a valid key for %2 provided by %3",
356 $key, _who_was_it(), _who_was_it(1)), $verbose);
357 $warned ||= 1;
358 }
359 next;
360 }
361
362 ### copy of this keys template instructions, to save derefs ###
363 my %tmpl = %{$utmpl->{$key}};
364
365 ### check if you're even allowed to override this key ###
366 if( $tmpl{'no_override'} ) {
367 _store_error(
368 loc(q[You are not allowed to override key '%1'].
369 q[for %2 from %3], $key, _who_was_it(), _who_was_it(1)),
370 $verbose
371 );
372 $warned ||= 1;
373 next;
374 }
375
376 ### check if you were supposed to provide defined() values ###
377 if( ($tmpl{'defined'} || $ONLY_ALLOW_DEFINED) and not defined $arg ) {
378 _store_error(loc(q|Key '%1' must be defined when passed|, $key),
379 $verbose );
380 $wrong ||= 1;
381 next;
382 }
383
384 ### check if they should be of a strict type, and if it is ###
385 if( ($tmpl{'strict_type'} || $STRICT_TYPE) and
386 (ref $arg ne ref $tmpl{'default'})
387 ) {
388 _store_error(loc(q|Key '%1' needs to be of type '%2'|,
389 $key, ref $tmpl{'default'} || 'SCALAR'), $verbose );
390 $wrong ||= 1;
391 next;
392 }
393
394 ### check if we have an allow handler, to validate against ###
395 ### allow() will report its own errors ###
396 if( exists $tmpl{'allow'} and not do {
397 local $_ERROR_STRING;
398 allow( $arg, $tmpl{'allow'} )
399 }
400 ) {
401 ### stringify the value in the error report -- we don't want dumps
402 ### of objects, but we do want to see *roughly* what we passed
403 _store_error(loc(q|Key '%1' (%2) is of invalid type for '%3' |.
404 q|provided by %4|,
405 $key, "$arg", _who_was_it(),
406 _who_was_it(1)), $verbose);
407 $wrong ||= 1;
408 next;
409 }
410
411 ### we got here, then all must be OK ###
412 $defs{$key} = $arg;
413
414 }
415
416 ### croak with the collected errors if there were errors and
417 ### we have the fatal flag toggled.
418 croak(__PACKAGE__->last_error) if ($wrong || $warned) && $WARNINGS_FATAL;
419
420 ### done with our loop... if $wrong is set, something went wrong
421 ### and the user is already informed, just return...
422 return if $wrong;
423
424 ### check if we need to store any of the keys ###
425 ### can't do it before, because something may go wrong later,
426 ### leaving the user with a few set variables
427 for my $key (@want_store) {
428 next unless exists $defs{$key};
429 my $ref = $utmpl->{$key}{'store'};
430 $$ref = $NO_DUPLICATES ? delete $defs{$key} : $defs{$key};
431 }
432
433 return \%defs;
434}
435
436=head2 allow( $test_me, \@criteria );
437
438The function that handles the C<allow> key in the template is also
439available for independent use.
440
441The function takes as first argument a key to test against, and
442as second argument any form of criteria that are also allowed by
443the C<allow> key in the template.
444
445You can use the following types of values for allow:
446
447=over 4
448
449=item string
450
451The provided argument MUST be equal to the string for the validation
452to pass.
453
454=item regexp
455
456The provided argument MUST match the regular expression for the
457validation to pass.
458
459=item subroutine
460
461The provided subroutine MUST return true in order for the validation
462to pass and the argument accepted.
463
464(This is particularly useful for more complicated data).
465
466=item array ref
467
468The provided argument MUST equal one of the elements of the array
469ref for the validation to pass. An array ref can hold all the above
470values.
471
472=back
473
474It returns true if the key matched the criteria, or false otherwise.
475
476=cut
477
478sub allow {
479 ### use $_[0] and $_[1] since this is hot code... ###
480 #my ($val, $ref) = @_;
481
482 ### it's a regexp ###
483 if( ref $_[1] eq 'Regexp' ) {
484 local $^W; # silence warnings if $val is undef #
485 return if $_[0] !~ /$_[1]/;
486
487 ### it's a sub ###
488 } elsif ( ref $_[1] eq 'CODE' ) {
489 return unless $_[1]->( $_[0] );
490
491 ### it's an array ###
492 } elsif ( ref $_[1] eq 'ARRAY' ) {
493
494 ### loop over the elements, see if one of them says the
495 ### value is OK
496 ### also, short-circuit when possible
497 for ( @{$_[1]} ) {
498 return 1 if allow( $_[0], $_ );
499 }
500
501 return;
502
503 ### fall back to a simple, but safe 'eq' ###
504 } else {
505 return unless _safe_eq( $_[0], $_[1] );
506 }
507
508 ### we got here, no failures ###
509 return 1;
510}
511
512### helper functions ###
513
514sub _safe_eq {
515 ### only do a straight 'eq' if they're both defined ###
516 return defined($_[0]) && defined($_[1])
517 ? $_[0] eq $_[1]
518 : defined($_[0]) eq defined($_[1]);
519}
520
521sub _who_was_it {
522 my $level = $_[0] || 0;
523
524 return (caller(2 + $CALLER_DEPTH + $level))[3] || 'ANON'
525}
526
527=head2 last_error()
528
529Returns a string containing all warnings and errors reported during
530the last time C<check> was called.
531
532This is useful if you want to report then some other way than
533C<carp>'ing when the verbose flag is on.
534
535It is exported upon request.
536
537=cut
538
5391200ns{ $_ERROR_STRING = '';
540
541 sub _store_error {
542 my($err, $verbose, $offset) = @_[0..2];
543 $verbose ||= 0;
544 $offset ||= 0;
545 my $level = 1 + $offset;
546
547 local $Carp::CarpLevel = $level;
548
549 carp $err if $verbose;
550
551 $_ERROR_STRING .= $err . "\n";
552 }
553
554 sub _clear_error {
555 $_ERROR_STRING = '';
556 }
557
558 sub last_error { $_ERROR_STRING }
559}
560
56124µs1;
562
563=head1 Global Variables
564
565The behaviour of Params::Check can be altered by changing the
566following global variables:
567
568=head2 $Params::Check::VERBOSE
569
570This controls whether Params::Check will issue warnings and
571explanations as to why certain things may have failed.
572If you set it to 0, Params::Check will not output any warnings.
573
574The default is 1 when L<warnings> are enabled, 0 otherwise;
575
576=head2 $Params::Check::STRICT_TYPE
577
578This works like the C<strict_type> option you can pass to C<check>,
579which will turn on C<strict_type> globally for all calls to C<check>.
580
581The default is 0;
582
583=head2 $Params::Check::ALLOW_UNKNOWN
584
585If you set this flag, unknown options will still be present in the
586return value, rather than filtered out. This is useful if your
587subroutine is only interested in a few arguments, and wants to pass
588the rest on blindly to perhaps another subroutine.
589
590The default is 0;
591
592=head2 $Params::Check::STRIP_LEADING_DASHES
593
594If you set this flag, all keys passed in the following manner:
595
596 function( -key => 'val' );
597
598will have their leading dashes stripped.
599
600=head2 $Params::Check::NO_DUPLICATES
601
602If set to true, all keys in the template that are marked as to be
603stored in a scalar, will also be removed from the result set.
604
605Default is false, meaning that when you use C<store> as a template
606key, C<check> will put it both in the scalar you supplied, as well as
607in the hashref it returns.
608
609=head2 $Params::Check::PRESERVE_CASE
610
611If set to true, L<Params::Check> will no longer convert all keys from
612the user input to lowercase, but instead expect them to be in the
613case the template provided. This is useful when you want to use
614similar keys with different casing in your templates.
615
616Understand that this removes the case-insensitivity feature of this
617module.
618
619Default is 0;
620
621=head2 $Params::Check::ONLY_ALLOW_DEFINED
622
623If set to true, L<Params::Check> will require all values passed to be
624C<defined>. If you wish to enable this on a 'per key' basis, use the
625template option C<defined> instead.
626
627Default is 0;
628
629=head2 $Params::Check::SANITY_CHECK_TEMPLATE
630
631If set to true, L<Params::Check> will sanity check templates, validating
632for errors and unknown keys. Although very useful for debugging, this
633can be somewhat slow in hot-code and large loops.
634
635To disable this check, set this variable to C<false>.
636
637Default is 1;
638
639=head2 $Params::Check::WARNINGS_FATAL
640
641If set to true, L<Params::Check> will C<croak> when an error during
642template validation occurs, rather than return C<false>.
643
644Default is 0;
645
646=head2 $Params::Check::CALLER_DEPTH
647
648This global modifies the argument given to C<caller()> by
649C<Params::Check::check()> and is useful if you have a custom wrapper
650function around C<Params::Check::check()>. The value must be an
651integer, indicating the number of wrapper functions inserted between
652the real function call and C<Params::Check::check()>.
653
654Example wrapper function, using a custom stacktrace:
655
656 sub check {
657 my ($template, $args_in) = @_;
658
659 local $Params::Check::WARNINGS_FATAL = 1;
660 local $Params::Check::CALLER_DEPTH = $Params::Check::CALLER_DEPTH + 1;
661 my $args_out = Params::Check::check($template, $args_in);
662
663 my_stacktrace(Params::Check::last_error) unless $args_out;
664
665 return $args_out;
666 }
667
668Default is 0;
669
670=head1 Acknowledgements
671
672Thanks to Richard Soderberg for his performance improvements.
673
674=head1 BUG REPORTS
675
676Please report bugs or other issues to E<lt>bug-params-check@rt.cpan.orgE<gt>.
677
678=head1 AUTHOR
679
680This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
681
682=head1 COPYRIGHT
683
684This library is free software; you may redistribute and/or modify it
685under the same terms as Perl itself.
686
687
688=cut
689
690# Local variables:
691# c-indentation-style: bsd
692# c-basic-offset: 4
693# indent-tabs-mode: nil
694# End:
695# vim: expandtab shiftwidth=4:
Report produced by the NYTProf 6.12 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.