Initial Commit
This commit is contained in:
Riley Schneider
695
database/perl/lib/Params/Check.pm
Normal file
695
database/perl/lib/Params/Check.pm
Normal file
@@ -0,0 +1,695 @@
|
||||
package Params::Check;
|
||||
|
||||
use strict;
|
||||
|
||||
use Carp qw[carp croak];
|
||||
use Locale::Maketext::Simple Style => 'gettext';
|
||||
|
||||
BEGIN {
|
||||
use Exporter ();
|
||||
use vars qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $ALLOW_UNKNOWN
|
||||
$STRICT_TYPE $STRIP_LEADING_DASHES $NO_DUPLICATES
|
||||
$PRESERVE_CASE $ONLY_ALLOW_DEFINED $WARNINGS_FATAL
|
||||
$SANITY_CHECK_TEMPLATE $CALLER_DEPTH $_ERROR_STRING
|
||||
];
|
||||
|
||||
@ISA = qw[ Exporter ];
|
||||
@EXPORT_OK = qw[check allow last_error];
|
||||
|
||||
$VERSION = '0.38';
|
||||
$VERBOSE = $^W ? 1 : 0;
|
||||
$NO_DUPLICATES = 0;
|
||||
$STRIP_LEADING_DASHES = 0;
|
||||
$STRICT_TYPE = 0;
|
||||
$ALLOW_UNKNOWN = 0;
|
||||
$PRESERVE_CASE = 0;
|
||||
$ONLY_ALLOW_DEFINED = 0;
|
||||
$SANITY_CHECK_TEMPLATE = 1;
|
||||
$WARNINGS_FATAL = 0;
|
||||
$CALLER_DEPTH = 0;
|
||||
}
|
||||
|
||||
my %known_keys = map { $_ => 1 }
|
||||
qw| required allow default strict_type no_override
|
||||
store defined |;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Params::Check - A generic input parsing/checking mechanism.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Params::Check qw[check allow last_error];
|
||||
|
||||
sub fill_personal_info {
|
||||
my %hash = @_;
|
||||
my $x;
|
||||
|
||||
my $tmpl = {
|
||||
firstname => { required => 1, defined => 1 },
|
||||
lastname => { required => 1, store => \$x },
|
||||
gender => { required => 1,
|
||||
allow => [qr/M/i, qr/F/i],
|
||||
},
|
||||
married => { allow => [0,1] },
|
||||
age => { default => 21,
|
||||
allow => qr/^\d+$/,
|
||||
},
|
||||
|
||||
phone => { allow => [ sub { return 1 if /$valid_re/ },
|
||||
'1-800-PERL' ]
|
||||
},
|
||||
id_list => { default => [],
|
||||
strict_type => 1
|
||||
},
|
||||
employer => { default => 'NSA', no_override => 1 },
|
||||
};
|
||||
|
||||
### check() returns a hashref of parsed args on success ###
|
||||
my $parsed_args = check( $tmpl, \%hash, $VERBOSE )
|
||||
or die qw[Could not parse arguments!];
|
||||
|
||||
... other code here ...
|
||||
}
|
||||
|
||||
my $ok = allow( $colour, [qw|blue green yellow|] );
|
||||
|
||||
my $error = Params::Check::last_error();
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Params::Check is a generic input parsing/checking mechanism.
|
||||
|
||||
It allows you to validate input via a template. The only requirement
|
||||
is that the arguments must be named.
|
||||
|
||||
Params::Check can do the following things for you:
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Convert all keys to lowercase
|
||||
|
||||
=item *
|
||||
|
||||
Check if all required arguments have been provided
|
||||
|
||||
=item *
|
||||
|
||||
Set arguments that have not been provided to the default
|
||||
|
||||
=item *
|
||||
|
||||
Weed out arguments that are not supported and warn about them to the
|
||||
user
|
||||
|
||||
=item *
|
||||
|
||||
Validate the arguments given by the user based on strings, regexes,
|
||||
lists or even subroutines
|
||||
|
||||
=item *
|
||||
|
||||
Enforce type integrity if required
|
||||
|
||||
=back
|
||||
|
||||
Most of Params::Check's power comes from its template, which we'll
|
||||
discuss below:
|
||||
|
||||
=head1 Template
|
||||
|
||||
As you can see in the synopsis, based on your template, the arguments
|
||||
provided will be validated.
|
||||
|
||||
The template can take a different set of rules per key that is used.
|
||||
|
||||
The following rules are available:
|
||||
|
||||
=over 4
|
||||
|
||||
=item default
|
||||
|
||||
This is the default value if none was provided by the user.
|
||||
This is also the type C<strict_type> will look at when checking type
|
||||
integrity (see below).
|
||||
|
||||
=item required
|
||||
|
||||
A boolean flag that indicates if this argument was a required
|
||||
argument. If marked as required and not provided, check() will fail.
|
||||
|
||||
=item strict_type
|
||||
|
||||
This does a C<ref()> check on the argument provided. The C<ref> of the
|
||||
argument must be the same as the C<ref> of the default value for this
|
||||
check to pass.
|
||||
|
||||
This is very useful if you insist on taking an array reference as
|
||||
argument for example.
|
||||
|
||||
=item defined
|
||||
|
||||
If this template key is true, enforces that if this key is provided by
|
||||
user input, its value is C<defined>. This just means that the user is
|
||||
not allowed to pass C<undef> as a value for this key and is equivalent
|
||||
to:
|
||||
allow => sub { defined $_[0] && OTHER TESTS }
|
||||
|
||||
=item no_override
|
||||
|
||||
This allows you to specify C<constants> in your template. ie, they
|
||||
keys that are not allowed to be altered by the user. It pretty much
|
||||
allows you to keep all your C<configurable> data in one place; the
|
||||
C<Params::Check> template.
|
||||
|
||||
=item store
|
||||
|
||||
This allows you to pass a reference to a scalar, in which the data
|
||||
will be stored:
|
||||
|
||||
my $x;
|
||||
my $args = check(foo => { default => 1, store => \$x }, $input);
|
||||
|
||||
This is basically shorthand for saying:
|
||||
|
||||
my $args = check( { foo => { default => 1 }, $input );
|
||||
my $x = $args->{foo};
|
||||
|
||||
You can alter the global variable $Params::Check::NO_DUPLICATES to
|
||||
control whether the C<store>'d key will still be present in your
|
||||
result set. See the L<Global Variables> section below.
|
||||
|
||||
=item allow
|
||||
|
||||
A set of criteria used to validate a particular piece of data if it
|
||||
has to adhere to particular rules.
|
||||
|
||||
See the C<allow()> function for details.
|
||||
|
||||
=back
|
||||
|
||||
=head1 Functions
|
||||
|
||||
=head2 check( \%tmpl, \%args, [$verbose] );
|
||||
|
||||
This function is not exported by default, so you'll have to ask for it
|
||||
via:
|
||||
|
||||
use Params::Check qw[check];
|
||||
|
||||
or use its fully qualified name instead.
|
||||
|
||||
C<check> takes a list of arguments, as follows:
|
||||
|
||||
=over 4
|
||||
|
||||
=item Template
|
||||
|
||||
This is a hash reference which contains a template as explained in the
|
||||
C<SYNOPSIS> and C<Template> section.
|
||||
|
||||
=item Arguments
|
||||
|
||||
This is a reference to a hash of named arguments which need checking.
|
||||
|
||||
=item Verbose
|
||||
|
||||
A boolean to indicate whether C<check> should be verbose and warn
|
||||
about what went wrong in a check or not.
|
||||
|
||||
You can enable this program wide by setting the package variable
|
||||
C<$Params::Check::VERBOSE> to a true value. For details, see the
|
||||
section on C<Global Variables> below.
|
||||
|
||||
=back
|
||||
|
||||
C<check> will return when it fails, or a hashref with lowercase
|
||||
keys of parsed arguments when it succeeds.
|
||||
|
||||
So a typical call to check would look like this:
|
||||
|
||||
my $parsed = check( \%template, \%arguments, $VERBOSE )
|
||||
or warn q[Arguments could not be parsed!];
|
||||
|
||||
A lot of the behaviour of C<check()> can be altered by setting
|
||||
package variables. See the section on C<Global Variables> for details
|
||||
on this.
|
||||
|
||||
=cut
|
||||
|
||||
sub check {
|
||||
my ($utmpl, $href, $verbose) = @_;
|
||||
|
||||
### clear the current error string ###
|
||||
_clear_error();
|
||||
|
||||
### did we get the arguments we need? ###
|
||||
if ( !$utmpl or !$href ) {
|
||||
_store_error(loc('check() expects two arguments'));
|
||||
return unless $WARNINGS_FATAL;
|
||||
croak(__PACKAGE__->last_error);
|
||||
}
|
||||
|
||||
### sensible defaults ###
|
||||
$verbose ||= $VERBOSE || 0;
|
||||
|
||||
### XXX what type of template is it? ###
|
||||
### { key => { } } ?
|
||||
#if (ref $args eq 'HASH') {
|
||||
# 1;
|
||||
#}
|
||||
|
||||
### clean up the template ###
|
||||
my $args;
|
||||
|
||||
### don't even bother to loop, if there's nothing to clean up ###
|
||||
if( $PRESERVE_CASE and !$STRIP_LEADING_DASHES ) {
|
||||
$args = $href;
|
||||
} else {
|
||||
### keys are not aliased ###
|
||||
for my $key (keys %$href) {
|
||||
my $org = $key;
|
||||
$key = lc $key unless $PRESERVE_CASE;
|
||||
$key =~ s/^-// if $STRIP_LEADING_DASHES;
|
||||
$args->{$key} = $href->{$org};
|
||||
}
|
||||
}
|
||||
|
||||
my %defs;
|
||||
|
||||
### which template entries have a 'store' member
|
||||
my @want_store;
|
||||
|
||||
### sanity check + defaults + required keys set? ###
|
||||
my $fail;
|
||||
for my $key (keys %$utmpl) {
|
||||
my $tmpl = $utmpl->{$key};
|
||||
|
||||
### check if required keys are provided
|
||||
### keys are now lower cased, unless preserve case was enabled
|
||||
### at which point, the utmpl keys must match, but that's the users
|
||||
### problem.
|
||||
if( $tmpl->{'required'} and not exists $args->{$key} ) {
|
||||
_store_error(
|
||||
loc(q|Required option '%1' is not provided for %2 by %3|,
|
||||
$key, _who_was_it(), _who_was_it(1)), $verbose );
|
||||
|
||||
### mark the error ###
|
||||
$fail++;
|
||||
next;
|
||||
}
|
||||
|
||||
### next, set the default, make sure the key exists in %defs ###
|
||||
$defs{$key} = $tmpl->{'default'}
|
||||
if exists $tmpl->{'default'};
|
||||
|
||||
if( $SANITY_CHECK_TEMPLATE ) {
|
||||
### last, check if they provided any weird template keys
|
||||
### -- do this last so we don't always execute this code.
|
||||
### just a small optimization.
|
||||
map { _store_error(
|
||||
loc(q|Template type '%1' not supported [at key '%2']|,
|
||||
$_, $key), 1, 0 );
|
||||
} grep {
|
||||
not $known_keys{$_}
|
||||
} keys %$tmpl;
|
||||
|
||||
### make sure you passed a ref, otherwise, complain about it!
|
||||
if ( exists $tmpl->{'store'} ) {
|
||||
_store_error( loc(
|
||||
q|Store variable for '%1' is not a reference!|, $key
|
||||
), 1, 0 ) unless ref $tmpl->{'store'};
|
||||
}
|
||||
}
|
||||
|
||||
push @want_store, $key if $tmpl->{'store'};
|
||||
}
|
||||
|
||||
### errors found ###
|
||||
return if $fail;
|
||||
|
||||
### flag to see if anything went wrong ###
|
||||
my $wrong;
|
||||
|
||||
### flag to see if we warned for anything, needed for warnings_fatal
|
||||
my $warned;
|
||||
|
||||
for my $key (keys %$args) {
|
||||
my $arg = $args->{$key};
|
||||
|
||||
### you gave us this key, but it's not in the template ###
|
||||
unless( $utmpl->{$key} ) {
|
||||
|
||||
### but we'll allow it anyway ###
|
||||
if( $ALLOW_UNKNOWN ) {
|
||||
$defs{$key} = $arg;
|
||||
|
||||
### warn about the error ###
|
||||
} else {
|
||||
_store_error(
|
||||
loc("Key '%1' is not a valid key for %2 provided by %3",
|
||||
$key, _who_was_it(), _who_was_it(1)), $verbose);
|
||||
$warned ||= 1;
|
||||
}
|
||||
next;
|
||||
}
|
||||
|
||||
### copy of this keys template instructions, to save derefs ###
|
||||
my %tmpl = %{$utmpl->{$key}};
|
||||
|
||||
### check if you're even allowed to override this key ###
|
||||
if( $tmpl{'no_override'} ) {
|
||||
_store_error(
|
||||
loc(q[You are not allowed to override key '%1'].
|
||||
q[for %2 from %3], $key, _who_was_it(), _who_was_it(1)),
|
||||
$verbose
|
||||
);
|
||||
$warned ||= 1;
|
||||
next;
|
||||
}
|
||||
|
||||
### check if you were supposed to provide defined() values ###
|
||||
if( ($tmpl{'defined'} || $ONLY_ALLOW_DEFINED) and not defined $arg ) {
|
||||
_store_error(loc(q|Key '%1' must be defined when passed|, $key),
|
||||
$verbose );
|
||||
$wrong ||= 1;
|
||||
next;
|
||||
}
|
||||
|
||||
### check if they should be of a strict type, and if it is ###
|
||||
if( ($tmpl{'strict_type'} || $STRICT_TYPE) and
|
||||
(ref $arg ne ref $tmpl{'default'})
|
||||
) {
|
||||
_store_error(loc(q|Key '%1' needs to be of type '%2'|,
|
||||
$key, ref $tmpl{'default'} || 'SCALAR'), $verbose );
|
||||
$wrong ||= 1;
|
||||
next;
|
||||
}
|
||||
|
||||
### check if we have an allow handler, to validate against ###
|
||||
### allow() will report its own errors ###
|
||||
if( exists $tmpl{'allow'} and not do {
|
||||
local $_ERROR_STRING;
|
||||
allow( $arg, $tmpl{'allow'} )
|
||||
}
|
||||
) {
|
||||
### stringify the value in the error report -- we don't want dumps
|
||||
### of objects, but we do want to see *roughly* what we passed
|
||||
_store_error(loc(q|Key '%1' (%2) is of invalid type for '%3' |.
|
||||
q|provided by %4|,
|
||||
$key, "$arg", _who_was_it(),
|
||||
_who_was_it(1)), $verbose);
|
||||
$wrong ||= 1;
|
||||
next;
|
||||
}
|
||||
|
||||
### we got here, then all must be OK ###
|
||||
$defs{$key} = $arg;
|
||||
|
||||
}
|
||||
|
||||
### croak with the collected errors if there were errors and
|
||||
### we have the fatal flag toggled.
|
||||
croak(__PACKAGE__->last_error) if ($wrong || $warned) && $WARNINGS_FATAL;
|
||||
|
||||
### done with our loop... if $wrong is set, something went wrong
|
||||
### and the user is already informed, just return...
|
||||
return if $wrong;
|
||||
|
||||
### check if we need to store any of the keys ###
|
||||
### can't do it before, because something may go wrong later,
|
||||
### leaving the user with a few set variables
|
||||
for my $key (@want_store) {
|
||||
next unless exists $defs{$key};
|
||||
my $ref = $utmpl->{$key}{'store'};
|
||||
$$ref = $NO_DUPLICATES ? delete $defs{$key} : $defs{$key};
|
||||
}
|
||||
|
||||
return \%defs;
|
||||
}
|
||||
|
||||
=head2 allow( $test_me, \@criteria );
|
||||
|
||||
The function that handles the C<allow> key in the template is also
|
||||
available for independent use.
|
||||
|
||||
The function takes as first argument a key to test against, and
|
||||
as second argument any form of criteria that are also allowed by
|
||||
the C<allow> key in the template.
|
||||
|
||||
You can use the following types of values for allow:
|
||||
|
||||
=over 4
|
||||
|
||||
=item string
|
||||
|
||||
The provided argument MUST be equal to the string for the validation
|
||||
to pass.
|
||||
|
||||
=item regexp
|
||||
|
||||
The provided argument MUST match the regular expression for the
|
||||
validation to pass.
|
||||
|
||||
=item subroutine
|
||||
|
||||
The provided subroutine MUST return true in order for the validation
|
||||
to pass and the argument accepted.
|
||||
|
||||
(This is particularly useful for more complicated data).
|
||||
|
||||
=item array ref
|
||||
|
||||
The provided argument MUST equal one of the elements of the array
|
||||
ref for the validation to pass. An array ref can hold all the above
|
||||
values.
|
||||
|
||||
=back
|
||||
|
||||
It returns true if the key matched the criteria, or false otherwise.
|
||||
|
||||
=cut
|
||||
|
||||
sub allow {
|
||||
### use $_[0] and $_[1] since this is hot code... ###
|
||||
#my ($val, $ref) = @_;
|
||||
|
||||
### it's a regexp ###
|
||||
if( ref $_[1] eq 'Regexp' ) {
|
||||
local $^W; # silence warnings if $val is undef #
|
||||
return if $_[0] !~ /$_[1]/;
|
||||
|
||||
### it's a sub ###
|
||||
} elsif ( ref $_[1] eq 'CODE' ) {
|
||||
return unless $_[1]->( $_[0] );
|
||||
|
||||
### it's an array ###
|
||||
} elsif ( ref $_[1] eq 'ARRAY' ) {
|
||||
|
||||
### loop over the elements, see if one of them says the
|
||||
### value is OK
|
||||
### also, short-circuit when possible
|
||||
for ( @{$_[1]} ) {
|
||||
return 1 if allow( $_[0], $_ );
|
||||
}
|
||||
|
||||
return;
|
||||
|
||||
### fall back to a simple, but safe 'eq' ###
|
||||
} else {
|
||||
return unless _safe_eq( $_[0], $_[1] );
|
||||
}
|
||||
|
||||
### we got here, no failures ###
|
||||
return 1;
|
||||
}
|
||||
|
||||
### helper functions ###
|
||||
|
||||
sub _safe_eq {
|
||||
### only do a straight 'eq' if they're both defined ###
|
||||
return defined($_[0]) && defined($_[1])
|
||||
? $_[0] eq $_[1]
|
||||
: defined($_[0]) eq defined($_[1]);
|
||||
}
|
||||
|
||||
sub _who_was_it {
|
||||
my $level = $_[0] || 0;
|
||||
|
||||
return (caller(2 + $CALLER_DEPTH + $level))[3] || 'ANON'
|
||||
}
|
||||
|
||||
=head2 last_error()
|
||||
|
||||
Returns a string containing all warnings and errors reported during
|
||||
the last time C<check> was called.
|
||||
|
||||
This is useful if you want to report then some other way than
|
||||
C<carp>'ing when the verbose flag is on.
|
||||
|
||||
It is exported upon request.
|
||||
|
||||
=cut
|
||||
|
||||
{ $_ERROR_STRING = '';
|
||||
|
||||
sub _store_error {
|
||||
my($err, $verbose, $offset) = @_[0..2];
|
||||
$verbose ||= 0;
|
||||
$offset ||= 0;
|
||||
my $level = 1 + $offset;
|
||||
|
||||
local $Carp::CarpLevel = $level;
|
||||
|
||||
carp $err if $verbose;
|
||||
|
||||
$_ERROR_STRING .= $err . "\n";
|
||||
}
|
||||
|
||||
sub _clear_error {
|
||||
$_ERROR_STRING = '';
|
||||
}
|
||||
|
||||
sub last_error { $_ERROR_STRING }
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 Global Variables
|
||||
|
||||
The behaviour of Params::Check can be altered by changing the
|
||||
following global variables:
|
||||
|
||||
=head2 $Params::Check::VERBOSE
|
||||
|
||||
This controls whether Params::Check will issue warnings and
|
||||
explanations as to why certain things may have failed.
|
||||
If you set it to 0, Params::Check will not output any warnings.
|
||||
|
||||
The default is 1 when L<warnings> are enabled, 0 otherwise;
|
||||
|
||||
=head2 $Params::Check::STRICT_TYPE
|
||||
|
||||
This works like the C<strict_type> option you can pass to C<check>,
|
||||
which will turn on C<strict_type> globally for all calls to C<check>.
|
||||
|
||||
The default is 0;
|
||||
|
||||
=head2 $Params::Check::ALLOW_UNKNOWN
|
||||
|
||||
If you set this flag, unknown options will still be present in the
|
||||
return value, rather than filtered out. This is useful if your
|
||||
subroutine is only interested in a few arguments, and wants to pass
|
||||
the rest on blindly to perhaps another subroutine.
|
||||
|
||||
The default is 0;
|
||||
|
||||
=head2 $Params::Check::STRIP_LEADING_DASHES
|
||||
|
||||
If you set this flag, all keys passed in the following manner:
|
||||
|
||||
function( -key => 'val' );
|
||||
|
||||
will have their leading dashes stripped.
|
||||
|
||||
=head2 $Params::Check::NO_DUPLICATES
|
||||
|
||||
If set to true, all keys in the template that are marked as to be
|
||||
stored in a scalar, will also be removed from the result set.
|
||||
|
||||
Default is false, meaning that when you use C<store> as a template
|
||||
key, C<check> will put it both in the scalar you supplied, as well as
|
||||
in the hashref it returns.
|
||||
|
||||
=head2 $Params::Check::PRESERVE_CASE
|
||||
|
||||
If set to true, L<Params::Check> will no longer convert all keys from
|
||||
the user input to lowercase, but instead expect them to be in the
|
||||
case the template provided. This is useful when you want to use
|
||||
similar keys with different casing in your templates.
|
||||
|
||||
Understand that this removes the case-insensitivity feature of this
|
||||
module.
|
||||
|
||||
Default is 0;
|
||||
|
||||
=head2 $Params::Check::ONLY_ALLOW_DEFINED
|
||||
|
||||
If set to true, L<Params::Check> will require all values passed to be
|
||||
C<defined>. If you wish to enable this on a 'per key' basis, use the
|
||||
template option C<defined> instead.
|
||||
|
||||
Default is 0;
|
||||
|
||||
=head2 $Params::Check::SANITY_CHECK_TEMPLATE
|
||||
|
||||
If set to true, L<Params::Check> will sanity check templates, validating
|
||||
for errors and unknown keys. Although very useful for debugging, this
|
||||
can be somewhat slow in hot-code and large loops.
|
||||
|
||||
To disable this check, set this variable to C<false>.
|
||||
|
||||
Default is 1;
|
||||
|
||||
=head2 $Params::Check::WARNINGS_FATAL
|
||||
|
||||
If set to true, L<Params::Check> will C<croak> when an error during
|
||||
template validation occurs, rather than return C<false>.
|
||||
|
||||
Default is 0;
|
||||
|
||||
=head2 $Params::Check::CALLER_DEPTH
|
||||
|
||||
This global modifies the argument given to C<caller()> by
|
||||
C<Params::Check::check()> and is useful if you have a custom wrapper
|
||||
function around C<Params::Check::check()>. The value must be an
|
||||
integer, indicating the number of wrapper functions inserted between
|
||||
the real function call and C<Params::Check::check()>.
|
||||
|
||||
Example wrapper function, using a custom stacktrace:
|
||||
|
||||
sub check {
|
||||
my ($template, $args_in) = @_;
|
||||
|
||||
local $Params::Check::WARNINGS_FATAL = 1;
|
||||
local $Params::Check::CALLER_DEPTH = $Params::Check::CALLER_DEPTH + 1;
|
||||
my $args_out = Params::Check::check($template, $args_in);
|
||||
|
||||
my_stacktrace(Params::Check::last_error) unless $args_out;
|
||||
|
||||
return $args_out;
|
||||
}
|
||||
|
||||
Default is 0;
|
||||
|
||||
=head1 Acknowledgements
|
||||
|
||||
Thanks to Richard Soderberg for his performance improvements.
|
||||
|
||||
=head1 BUG REPORTS
|
||||
|
||||
Please report bugs or other issues to E<lt>bug-params-check@rt.cpan.orgE<gt>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
This library is free software; you may redistribute and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
# Local variables:
|
||||
# c-indentation-style: bsd
|
||||
# c-basic-offset: 4
|
||||
# indent-tabs-mode: nil
|
||||
# End:
|
||||
# vim: expandtab shiftwidth=4:
|
||||
486
database/perl/lib/Params/Util.pm
Normal file
486
database/perl/lib/Params/Util.pm
Normal file
@@ -0,0 +1,486 @@
|
||||
package Params::Util;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Params::Util - Simple, compact and correct param-checking functions
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# Import some functions
|
||||
use Params::Util qw{_SCALAR _HASH _INSTANCE};
|
||||
|
||||
# If you are lazy, or need a lot of them...
|
||||
use Params::Util ':ALL';
|
||||
|
||||
sub foo {
|
||||
my $object = _INSTANCE(shift, 'Foo') or return undef;
|
||||
my $image = _SCALAR(shift) or return undef;
|
||||
my $options = _HASH(shift) or return undef;
|
||||
# etc...
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
C<Params::Util> provides a basic set of importable functions that makes
|
||||
checking parameters a hell of a lot easier
|
||||
|
||||
While they can be (and are) used in other contexts, the main point
|
||||
behind this module is that the functions B<both> Do What You Mean,
|
||||
and Do The Right Thing, so they are most useful when you are getting
|
||||
params passed into your code from someone and/or somewhere else
|
||||
and you can't really trust the quality.
|
||||
|
||||
Thus, C<Params::Util> is of most use at the edges of your API, where
|
||||
params and data are coming in from outside your code.
|
||||
|
||||
The functions provided by C<Params::Util> check in the most strictly
|
||||
correct manner known, are documented as thoroughly as possible so their
|
||||
exact behaviour is clear, and heavily tested so make sure they are not
|
||||
fooled by weird data and Really Bad Things.
|
||||
|
||||
To use, simply load the module providing the functions you want to use
|
||||
as arguments (as shown in the SYNOPSIS).
|
||||
|
||||
To aid in maintainability, C<Params::Util> will B<never> export by
|
||||
default.
|
||||
|
||||
You must explicitly name the functions you want to export, or use the
|
||||
C<:ALL> param to just have it export everything (although this is not
|
||||
recommended if you have any _FOO functions yourself with which future
|
||||
additions to C<Params::Util> may clash)
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=cut
|
||||
|
||||
use 5.00503;
|
||||
use strict;
|
||||
use warnings;
|
||||
use parent qw{Exporter XSLoader};
|
||||
|
||||
use Params::Util::PP qw();
|
||||
|
||||
our $VERSION = '1.102';
|
||||
|
||||
local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY};
|
||||
XSLoader::load("Params::Util", $VERSION) unless $ENV{PERL_PARAMS_UTIL_PP};
|
||||
|
||||
our @EXPORT_OK = qw{
|
||||
_STRING _IDENTIFIER
|
||||
_CLASS _CLASSISA _SUBCLASS _DRIVER _CLASSDOES
|
||||
_NUMBER _POSINT _NONNEGINT
|
||||
_SCALAR _SCALAR0
|
||||
_ARRAY _ARRAY0 _ARRAYLIKE
|
||||
_HASH _HASH0 _HASHLIKE
|
||||
_CODE _CODELIKE
|
||||
_INVOCANT _REGEX _INSTANCE _INSTANCEDOES
|
||||
_SET _SET0
|
||||
_HANDLE
|
||||
};
|
||||
our %EXPORT_TAGS = (ALL => \@EXPORT_OK);
|
||||
|
||||
## no critic (TestingAndDebugging::ProhibitNoStrict)
|
||||
no strict "refs";
|
||||
Params::Util->can($_) or *$_ = Params::Util::PP->can($_) for (@EXPORT_OK);
|
||||
use strict "refs";
|
||||
|
||||
#####################################################################
|
||||
# Param Checking Functions
|
||||
|
||||
=pod
|
||||
|
||||
=head2 _STRING $string
|
||||
|
||||
The C<_STRING> function is intended to be imported into your
|
||||
package, and provides a convenient way to test to see if a value is
|
||||
a normal non-false string of non-zero length.
|
||||
|
||||
Note that this will NOT do anything magic to deal with the special
|
||||
C<'0'> false negative case, but will return it.
|
||||
|
||||
# '0' not considered valid data
|
||||
my $name = _STRING(shift) or die "Bad name";
|
||||
|
||||
# '0' is considered valid data
|
||||
my $string = _STRING($_[0]) ? shift : die "Bad string";
|
||||
|
||||
Please also note that this function expects a normal string. It does
|
||||
not support overloading or other magic techniques to get a string.
|
||||
|
||||
Returns the string as a convenience if it is a valid string, or
|
||||
C<undef> if not.
|
||||
|
||||
=head2 _IDENTIFIER $string
|
||||
|
||||
The C<_IDENTIFIER> function is intended to be imported into your
|
||||
package, and provides a convenient way to test to see if a value is
|
||||
a string that is a valid Perl identifier.
|
||||
|
||||
Returns the string as a convenience if it is a valid identifier, or
|
||||
C<undef> if not.
|
||||
|
||||
=head2 _CLASS $string
|
||||
|
||||
The C<_CLASS> function is intended to be imported into your
|
||||
package, and provides a convenient way to test to see if a value is
|
||||
a string that is a valid Perl class.
|
||||
|
||||
This function only checks that the format is valid, not that the
|
||||
class is actually loaded. It also assumes "normalized" form, and does
|
||||
not accept class names such as C<::Foo> or C<D'Oh>.
|
||||
|
||||
Returns the string as a convenience if it is a valid class name, or
|
||||
C<undef> if not.
|
||||
|
||||
=head2 _CLASSISA $string, $class
|
||||
|
||||
The C<_CLASSISA> function is intended to be imported into your
|
||||
package, and provides a convenient way to test to see if a value is
|
||||
a string that is a particularly class, or a subclass of it.
|
||||
|
||||
This function checks that the format is valid and calls the -E<gt>isa
|
||||
method on the class name. It does not check that the class is actually
|
||||
loaded.
|
||||
|
||||
It also assumes "normalized" form, and does
|
||||
not accept class names such as C<::Foo> or C<D'Oh>.
|
||||
|
||||
Returns the string as a convenience if it is a valid class name, or
|
||||
C<undef> if not.
|
||||
|
||||
=head2 _CLASSDOES $string, $role
|
||||
|
||||
This routine behaves exactly like C<L</_CLASSISA>>, but checks with C<< ->DOES
|
||||
>> rather than C<< ->isa >>. This is probably only a good idea to use on Perl
|
||||
5.10 or later, when L<UNIVERSAL::DOES|UNIVERSAL::DOES/DOES> has been
|
||||
implemented.
|
||||
|
||||
=head2 _SUBCLASS $string, $class
|
||||
|
||||
The C<_SUBCLASS> function is intended to be imported into your
|
||||
package, and provides a convenient way to test to see if a value is
|
||||
a string that is a subclass of a specified class.
|
||||
|
||||
This function checks that the format is valid and calls the -E<gt>isa
|
||||
method on the class name. It does not check that the class is actually
|
||||
loaded.
|
||||
|
||||
It also assumes "normalized" form, and does
|
||||
not accept class names such as C<::Foo> or C<D'Oh>.
|
||||
|
||||
Returns the string as a convenience if it is a valid class name, or
|
||||
C<undef> if not.
|
||||
|
||||
=head2 _NUMBER $scalar
|
||||
|
||||
The C<_NUMBER> function is intended to be imported into your
|
||||
package, and provides a convenient way to test to see if a value is
|
||||
a number. That is, it is defined and perl thinks it's a number.
|
||||
|
||||
This function is basically a Params::Util-style wrapper around the
|
||||
L<Scalar::Util> C<looks_like_number> function.
|
||||
|
||||
Returns the value as a convenience, or C<undef> if the value is not a
|
||||
number.
|
||||
|
||||
=head2 _POSINT $integer
|
||||
|
||||
The C<_POSINT> function is intended to be imported into your
|
||||
package, and provides a convenient way to test to see if a value is
|
||||
a positive integer (of any length).
|
||||
|
||||
Returns the value as a convenience, or C<undef> if the value is not a
|
||||
positive integer.
|
||||
|
||||
The name itself is derived from the XML schema constraint of the same
|
||||
name.
|
||||
|
||||
=head2 _NONNEGINT $integer
|
||||
|
||||
The C<_NONNEGINT> function is intended to be imported into your
|
||||
package, and provides a convenient way to test to see if a value is
|
||||
a non-negative integer (of any length). That is, a positive integer,
|
||||
or zero.
|
||||
|
||||
Returns the value as a convenience, or C<undef> if the value is not a
|
||||
non-negative integer.
|
||||
|
||||
As with other tests that may return false values, care should be taken
|
||||
to test via "defined" in boolean validly contexts.
|
||||
|
||||
unless ( defined _NONNEGINT($value) ) {
|
||||
die "Invalid value";
|
||||
}
|
||||
|
||||
The name itself is derived from the XML schema constraint of the same
|
||||
name.
|
||||
|
||||
=head2 _SCALAR \$scalar
|
||||
|
||||
The C<_SCALAR> function is intended to be imported into your package,
|
||||
and provides a convenient way to test for a raw and unblessed
|
||||
C<SCALAR> reference, with content of non-zero length.
|
||||
|
||||
For a version that allows zero length C<SCALAR> references, see
|
||||
the C<_SCALAR0> function.
|
||||
|
||||
Returns the C<SCALAR> reference itself as a convenience, or C<undef>
|
||||
if the value provided is not a C<SCALAR> reference.
|
||||
|
||||
=head2 _SCALAR0 \$scalar
|
||||
|
||||
The C<_SCALAR0> function is intended to be imported into your package,
|
||||
and provides a convenient way to test for a raw and unblessed
|
||||
C<SCALAR0> reference, allowing content of zero-length.
|
||||
|
||||
For a simpler "give me some content" version that requires non-zero
|
||||
length, C<_SCALAR> function.
|
||||
|
||||
Returns the C<SCALAR> reference itself as a convenience, or C<undef>
|
||||
if the value provided is not a C<SCALAR> reference.
|
||||
|
||||
=head2 _ARRAY $value
|
||||
|
||||
The C<_ARRAY> function is intended to be imported into your package,
|
||||
and provides a convenient way to test for a raw and unblessed
|
||||
C<ARRAY> reference containing B<at least> one element of any kind.
|
||||
|
||||
For a more basic form that allows zero length ARRAY references, see
|
||||
the C<_ARRAY0> function.
|
||||
|
||||
Returns the C<ARRAY> reference itself as a convenience, or C<undef>
|
||||
if the value provided is not an C<ARRAY> reference.
|
||||
|
||||
=head2 _ARRAY0 $value
|
||||
|
||||
The C<_ARRAY0> function is intended to be imported into your package,
|
||||
and provides a convenient way to test for a raw and unblessed
|
||||
C<ARRAY> reference, allowing C<ARRAY> references that contain no
|
||||
elements.
|
||||
|
||||
For a more basic "An array of something" form that also requires at
|
||||
least one element, see the C<_ARRAY> function.
|
||||
|
||||
Returns the C<ARRAY> reference itself as a convenience, or C<undef>
|
||||
if the value provided is not an C<ARRAY> reference.
|
||||
|
||||
=head2 _ARRAYLIKE $value
|
||||
|
||||
The C<_ARRAYLIKE> function tests whether a given scalar value can respond to
|
||||
array dereferencing. If it can, the value is returned. If it cannot,
|
||||
C<_ARRAYLIKE> returns C<undef>.
|
||||
|
||||
=head2 _HASH $value
|
||||
|
||||
The C<_HASH> function is intended to be imported into your package,
|
||||
and provides a convenient way to test for a raw and unblessed
|
||||
C<HASH> reference with at least one entry.
|
||||
|
||||
For a version of this function that allows the C<HASH> to be empty,
|
||||
see the C<_HASH0> function.
|
||||
|
||||
Returns the C<HASH> reference itself as a convenience, or C<undef>
|
||||
if the value provided is not an C<HASH> reference.
|
||||
|
||||
=head2 _HASH0 $value
|
||||
|
||||
The C<_HASH0> function is intended to be imported into your package,
|
||||
and provides a convenient way to test for a raw and unblessed
|
||||
C<HASH> reference, regardless of the C<HASH> content.
|
||||
|
||||
For a simpler "A hash of something" version that requires at least one
|
||||
element, see the C<_HASH> function.
|
||||
|
||||
Returns the C<HASH> reference itself as a convenience, or C<undef>
|
||||
if the value provided is not an C<HASH> reference.
|
||||
|
||||
=head2 _HASHLIKE $value
|
||||
|
||||
The C<_HASHLIKE> function tests whether a given scalar value can respond to
|
||||
hash dereferencing. If it can, the value is returned. If it cannot,
|
||||
C<_HASHLIKE> returns C<undef>.
|
||||
|
||||
=head2 _CODE $value
|
||||
|
||||
The C<_CODE> function is intended to be imported into your package,
|
||||
and provides a convenient way to test for a raw and unblessed
|
||||
C<CODE> reference.
|
||||
|
||||
Returns the C<CODE> reference itself as a convenience, or C<undef>
|
||||
if the value provided is not an C<CODE> reference.
|
||||
|
||||
=head2 _CODELIKE $value
|
||||
|
||||
The C<_CODELIKE> is the more generic version of C<_CODE>. Unlike C<_CODE>,
|
||||
which checks for an explicit C<CODE> reference, the C<_CODELIKE> function
|
||||
also includes things that act like them, such as blessed objects that
|
||||
overload C<'&{}'>.
|
||||
|
||||
Please note that in the case of objects overloaded with '&{}', you will
|
||||
almost always end up also testing it in 'bool' context at some stage.
|
||||
|
||||
For example:
|
||||
|
||||
sub foo {
|
||||
my $code1 = _CODELIKE(shift) or die "No code param provided";
|
||||
my $code2 = _CODELIKE(shift);
|
||||
if ( $code2 ) {
|
||||
print "Got optional second code param";
|
||||
}
|
||||
}
|
||||
|
||||
As such, you will most likely always want to make sure your class has
|
||||
at least the following to allow it to evaluate to true in boolean
|
||||
context.
|
||||
|
||||
# Always evaluate to true in boolean context
|
||||
use overload 'bool' => sub () { 1 };
|
||||
|
||||
Returns the callable value as a convenience, or C<undef> if the
|
||||
value provided is not callable.
|
||||
|
||||
Note - This function was formerly known as _CALLABLE but has been renamed
|
||||
for greater symmetry with the other _XXXXLIKE functions.
|
||||
|
||||
The use of _CALLABLE has been deprecated. It will continue to work, but
|
||||
with a warning, until end-2006, then will be removed.
|
||||
|
||||
I apologize for any inconvenience caused.
|
||||
|
||||
=head2 _INVOCANT $value
|
||||
|
||||
This routine tests whether the given value is a valid method invocant.
|
||||
This can be either an instance of an object, or a class name.
|
||||
|
||||
If so, the value itself is returned. Otherwise, C<_INVOCANT>
|
||||
returns C<undef>.
|
||||
|
||||
=head2 _INSTANCE $object, $class
|
||||
|
||||
The C<_INSTANCE> function is intended to be imported into your package,
|
||||
and provides a convenient way to test for an object of a particular class
|
||||
in a strictly correct manner.
|
||||
|
||||
Returns the object itself as a convenience, or C<undef> if the value
|
||||
provided is not an object of that type.
|
||||
|
||||
=head2 _INSTANCEDOES $object, $role
|
||||
|
||||
This routine behaves exactly like C<L</_INSTANCE>>, but checks with C<< ->DOES
|
||||
>> rather than C<< ->isa >>. This is probably only a good idea to use on Perl
|
||||
5.10 or later, when L<UNIVERSAL::DOES|UNIVERSAL::DOES/DOES> has been
|
||||
implemented.
|
||||
|
||||
=head2 _REGEX $value
|
||||
|
||||
The C<_REGEX> function is intended to be imported into your package,
|
||||
and provides a convenient way to test for a regular expression.
|
||||
|
||||
Returns the value itself as a convenience, or C<undef> if the value
|
||||
provided is not a regular expression.
|
||||
|
||||
=head2 _SET \@array, $class
|
||||
|
||||
The C<_SET> function is intended to be imported into your package,
|
||||
and provides a convenient way to test for set of at least one object of
|
||||
a particular class in a strictly correct manner.
|
||||
|
||||
The set is provided as a reference to an C<ARRAY> of objects of the
|
||||
class provided.
|
||||
|
||||
For an alternative function that allows zero-length sets, see the
|
||||
C<_SET0> function.
|
||||
|
||||
Returns the C<ARRAY> reference itself as a convenience, or C<undef> if
|
||||
the value provided is not a set of that class.
|
||||
|
||||
=head2 _SET0 \@array, $class
|
||||
|
||||
The C<_SET0> function is intended to be imported into your package,
|
||||
and provides a convenient way to test for a set of objects of a
|
||||
particular class in a strictly correct manner, allowing for zero objects.
|
||||
|
||||
The set is provided as a reference to an C<ARRAY> of objects of the
|
||||
class provided.
|
||||
|
||||
For an alternative function that requires at least one object, see the
|
||||
C<_SET> function.
|
||||
|
||||
Returns the C<ARRAY> reference itself as a convenience, or C<undef> if
|
||||
the value provided is not a set of that class.
|
||||
|
||||
=head2 _HANDLE
|
||||
|
||||
The C<_HANDLE> function is intended to be imported into your package,
|
||||
and provides a convenient way to test whether or not a single scalar
|
||||
value is a file handle.
|
||||
|
||||
Unfortunately, in Perl the definition of a file handle can be a little
|
||||
bit fuzzy, so this function is likely to be somewhat imperfect (at first
|
||||
anyway).
|
||||
|
||||
That said, it is implement as well or better than the other file handle
|
||||
detectors in existence (and we stole from the best of them).
|
||||
|
||||
=head2 _DRIVER $string
|
||||
|
||||
sub foo {
|
||||
my $class = _DRIVER(shift, 'My::Driver::Base') or die "Bad driver";
|
||||
...
|
||||
}
|
||||
|
||||
The C<_DRIVER> function is intended to be imported into your
|
||||
package, and provides a convenient way to load and validate
|
||||
a driver class.
|
||||
|
||||
The most common pattern when taking a driver class as a parameter
|
||||
is to check that the name is a class (i.e. check against _CLASS)
|
||||
and then to load the class (if it exists) and then ensure that
|
||||
the class returns true for the isa method on some base driver name.
|
||||
|
||||
Return the value as a convenience, or C<undef> if the value is not
|
||||
a class name, the module does not exist, the module does not load,
|
||||
or the class fails the isa test.
|
||||
|
||||
=head1 TO DO
|
||||
|
||||
- Add _CAN to help resolve the UNIVERSAL::can debacle
|
||||
|
||||
- Implement an assertion-like version of this module, that dies on
|
||||
error.
|
||||
|
||||
- Implement a Test:: version of this module, for use in testing
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Bugs should be reported via the CPAN bug tracker at
|
||||
|
||||
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Params-Util>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Adam Kennedy E<lt>adamk AT cpan.orgE<gt>
|
||||
|
||||
Jens Rehsack E<lt>rehsack AT cpan.orgE<gt>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Params::Validate>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2005 - 2012 Adam Kennedy.
|
||||
|
||||
Copyright 2020 - 2020 Jens Rehsack.
|
||||
|
||||
This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
The full text of the license can be found in the
|
||||
LICENSE file included with this module.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
276
database/perl/lib/Params/Util/PP.pm
Normal file
276
database/perl/lib/Params/Util/PP.pm
Normal file
@@ -0,0 +1,276 @@
|
||||
package Params::Util::PP;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.102';
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Params::Util::PP - PurePerl Params::Util routines
|
||||
|
||||
=cut
|
||||
|
||||
use Scalar::Util ();
|
||||
use overload ();
|
||||
|
||||
Scalar::Util->can("looks_like_number") and Scalar::Util->import("looks_like_number");
|
||||
# Use a private pure-perl copy of looks_like_number if the version of
|
||||
# Scalar::Util is old (for whatever reason).
|
||||
Params::Util::PP->can("looks_like_number") or *looks_like_number = sub {
|
||||
local $_ = shift;
|
||||
|
||||
# checks from perlfaq4
|
||||
return 0 if !defined($_);
|
||||
if (ref($_))
|
||||
{
|
||||
return overload::Overloaded($_) ? defined(0 + $_) : 0;
|
||||
}
|
||||
return 1 if (/^[+-]?[0-9]+$/); # is a +/- integer
|
||||
## no critic (RegularExpressions::ProhibitComplexRegexes)
|
||||
return 1 if (/^(?:[+-]?)(?=[0-9]|\.[0-9])[0-9]*(?:\.[0-9]*)?(?:[Ee](?:[+-]?[0-9]+))?$/); # a C float
|
||||
return 1 if ($] >= 5.008 and /^(?:Inf(?:inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i);
|
||||
|
||||
0;
|
||||
};
|
||||
|
||||
## no critic (Subroutines::ProhibitSubroutinePrototypes, Subroutines::RequireArgUnpacking)
|
||||
## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
|
||||
|
||||
sub _XScompiled { return 0; }
|
||||
|
||||
sub _STRING ($)
|
||||
{
|
||||
my $arg = $_[0];
|
||||
return (defined $arg and not ref $arg and length($arg)) ? $arg : undef;
|
||||
}
|
||||
|
||||
sub _IDENTIFIER ($)
|
||||
{
|
||||
my $arg = $_[0];
|
||||
return (defined $arg and not ref $arg and $arg =~ m/^[^\W\d]\w*\z/s) ? $arg : undef;
|
||||
}
|
||||
|
||||
sub _CLASS ($)
|
||||
{
|
||||
my $arg = $_[0];
|
||||
return (defined $arg and not ref $arg and $arg =~ m/^[^\W\d]\w*(?:::\w+)*\z/s) ? $arg : undef;
|
||||
}
|
||||
|
||||
sub _CLASSISA ($$)
|
||||
{
|
||||
return (defined $_[0] and not ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0]->isa($_[1])) ? $_[0] : undef;
|
||||
}
|
||||
|
||||
sub _CLASSDOES ($$)
|
||||
{
|
||||
return (defined $_[0] and not ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0]->DOES($_[1])) ? $_[0] : undef;
|
||||
}
|
||||
|
||||
sub _SUBCLASS ($$)
|
||||
{
|
||||
return (defined $_[0] and not ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0] ne $_[1] and $_[0]->isa($_[1]))
|
||||
? $_[0]
|
||||
: undef;
|
||||
}
|
||||
|
||||
sub _NUMBER ($)
|
||||
{
|
||||
my $arg = $_[0];
|
||||
return (defined $arg and not ref $arg and looks_like_number($arg)) ? $arg : undef;
|
||||
}
|
||||
|
||||
sub _POSINT ($)
|
||||
{
|
||||
my $arg = $_[0];
|
||||
return (defined $arg and not ref $arg and $arg =~ m/^[1-9]\d*$/) ? $arg : undef;
|
||||
}
|
||||
|
||||
sub _NONNEGINT ($)
|
||||
{
|
||||
my $arg = $_[0];
|
||||
return (defined $arg and not ref $arg and $arg =~ m/^(?:0|[1-9]\d*)$/) ? $arg : undef;
|
||||
}
|
||||
|
||||
sub _SCALAR ($)
|
||||
{
|
||||
return (ref $_[0] eq 'SCALAR' and defined ${$_[0]} and ${$_[0]} ne '') ? $_[0] : undef;
|
||||
}
|
||||
|
||||
sub _SCALAR0 ($)
|
||||
{
|
||||
return ref $_[0] eq 'SCALAR' ? $_[0] : undef;
|
||||
}
|
||||
|
||||
sub _ARRAY ($)
|
||||
{
|
||||
return (ref $_[0] eq 'ARRAY' and @{$_[0]}) ? $_[0] : undef;
|
||||
}
|
||||
|
||||
sub _ARRAY0 ($)
|
||||
{
|
||||
return ref $_[0] eq 'ARRAY' ? $_[0] : undef;
|
||||
}
|
||||
|
||||
sub _ARRAYLIKE
|
||||
{
|
||||
return (
|
||||
defined $_[0] and ref $_[0] and ((Scalar::Util::reftype($_[0]) eq 'ARRAY')
|
||||
or overload::Method($_[0], '@{}'))
|
||||
) ? $_[0] : undef;
|
||||
}
|
||||
|
||||
sub _HASH ($)
|
||||
{
|
||||
return (ref $_[0] eq 'HASH' and scalar %{$_[0]}) ? $_[0] : undef;
|
||||
}
|
||||
|
||||
sub _HASH0 ($)
|
||||
{
|
||||
return ref $_[0] eq 'HASH' ? $_[0] : undef;
|
||||
}
|
||||
|
||||
sub _HASHLIKE
|
||||
{
|
||||
return (
|
||||
defined $_[0] and ref $_[0] and ((Scalar::Util::reftype($_[0]) eq 'HASH')
|
||||
or overload::Method($_[0], '%{}'))
|
||||
) ? $_[0] : undef;
|
||||
}
|
||||
|
||||
sub _CODE ($)
|
||||
{
|
||||
return ref $_[0] eq 'CODE' ? $_[0] : undef;
|
||||
}
|
||||
|
||||
sub _CODELIKE($)
|
||||
{
|
||||
return (
|
||||
(Scalar::Util::reftype($_[0]) || '') eq 'CODE'
|
||||
or Scalar::Util::blessed($_[0]) and overload::Method($_[0], '&{}')
|
||||
) ? $_[0] : undef;
|
||||
}
|
||||
|
||||
sub _INVOCANT($)
|
||||
{
|
||||
return (
|
||||
defined $_[0]
|
||||
and (
|
||||
defined Scalar::Util::blessed($_[0])
|
||||
or
|
||||
# We used to check for stash definedness, but any class-like name is a
|
||||
# valid invocant for UNIVERSAL methods, so we stopped. -- rjbs, 2006-07-02
|
||||
_CLASS($_[0])
|
||||
)
|
||||
) ? $_[0] : undef;
|
||||
}
|
||||
|
||||
sub _INSTANCE ($$)
|
||||
{
|
||||
return (Scalar::Util::blessed($_[0]) and $_[0]->isa($_[1])) ? $_[0] : undef;
|
||||
}
|
||||
|
||||
sub _INSTANCEDOES ($$)
|
||||
{
|
||||
return (Scalar::Util::blessed($_[0]) and $_[0]->DOES($_[1])) ? $_[0] : undef;
|
||||
}
|
||||
|
||||
sub _REGEX ($)
|
||||
{
|
||||
return (defined $_[0] and 'Regexp' eq ref($_[0])) ? $_[0] : undef;
|
||||
}
|
||||
|
||||
sub _SET ($$)
|
||||
{
|
||||
my $set_param = shift;
|
||||
_ARRAY($set_param) or return undef;
|
||||
foreach my $item (@$set_param)
|
||||
{
|
||||
_INSTANCE($item, $_[0]) or return undef;
|
||||
}
|
||||
return $set_param;
|
||||
}
|
||||
|
||||
sub _SET0 ($$)
|
||||
{
|
||||
my $set_param = shift;
|
||||
_ARRAY0($set_param) or return undef;
|
||||
foreach my $item (@$set_param)
|
||||
{
|
||||
_INSTANCE($item, $_[0]) or return undef;
|
||||
}
|
||||
return $set_param;
|
||||
}
|
||||
|
||||
# We're doing this longhand for now. Once everything is perfect,
|
||||
# we'll compress this into something that compiles more efficiently.
|
||||
# Further, testing file handles is not something that is generally
|
||||
# done millions of times, so doing it slowly is not a big speed hit.
|
||||
sub _HANDLE
|
||||
{
|
||||
my $it = shift;
|
||||
|
||||
# It has to be defined, of course
|
||||
unless (defined $it)
|
||||
{
|
||||
return undef;
|
||||
}
|
||||
|
||||
# Normal globs are considered to be file handles
|
||||
if (ref $it eq 'GLOB')
|
||||
{
|
||||
return $it;
|
||||
}
|
||||
|
||||
# Check for a normal tied filehandle
|
||||
# Side Note: 5.5.4's tied() and can() doesn't like getting undef
|
||||
if (tied($it) and tied($it)->can('TIEHANDLE'))
|
||||
{
|
||||
return $it;
|
||||
}
|
||||
|
||||
# There are no other non-object handles that we support
|
||||
unless (Scalar::Util::blessed($it))
|
||||
{
|
||||
return undef;
|
||||
}
|
||||
|
||||
# Check for a common base classes for conventional IO::Handle object
|
||||
if ($it->isa('IO::Handle'))
|
||||
{
|
||||
return $it;
|
||||
}
|
||||
|
||||
# Check for tied file handles using Tie::Handle
|
||||
if ($it->isa('Tie::Handle'))
|
||||
{
|
||||
return $it;
|
||||
}
|
||||
|
||||
# IO::Scalar is not a proper seekable, but it is valid is a
|
||||
# regular file handle
|
||||
if ($it->isa('IO::Scalar'))
|
||||
{
|
||||
return $it;
|
||||
}
|
||||
|
||||
# Yet another special case for IO::String, which refuses (for now
|
||||
# anyway) to become a subclass of IO::Handle.
|
||||
if ($it->isa('IO::String'))
|
||||
{
|
||||
return $it;
|
||||
}
|
||||
|
||||
# This is not any sort of object we know about
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub _DRIVER ($$)
|
||||
{
|
||||
## no critic (BuiltinFunctions::ProhibitStringyEval)
|
||||
return (defined _CLASS($_[0]) and eval "require $_[0];" and not $@ and $_[0]->isa($_[1]) and $_[0] ne $_[1]) ? $_[0] : undef;
|
||||
}
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user