JezK
Edit File: PP.pm
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;