Params-Util-1.07/0000755000175100017510000000000011726772164012204 5ustar adamadamParams-Util-1.07/META.json0000644000175100017510000000203411726772164013624 0ustar adamadam{ "abstract" : "Simple, compact and correct param-checking functions", "author" : [ "Adam Kennedy " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.112621", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Params-Util", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "6.52", "File::Spec" : "0.80", "Test::More" : "0.42" } }, "configure" : { "requires" : { "ExtUtils::CBuilder" : "0.27", "ExtUtils::MakeMaker" : "6.52" } }, "runtime" : { "requires" : { "Scalar::Util" : "1.18", "perl" : "5.00503" } } }, "release_status" : "stable", "version" : "1.07" } Params-Util-1.07/META.yml0000644000175100017510000000113011726772164013450 0ustar adamadam--- abstract: 'Simple, compact and correct param-checking functions' author: - 'Adam Kennedy ' build_requires: ExtUtils::MakeMaker: 6.52 File::Spec: 0.80 Test::More: 0.42 configure_requires: ExtUtils::CBuilder: 0.27 ExtUtils::MakeMaker: 6.52 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.112621' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Params-Util no_index: directory: - t - inc requires: Scalar::Util: 1.18 perl: 5.00503 version: 1.07 Params-Util-1.07/README0000644000175100017510000003561111726772122013064 0ustar adamadamNAME Params::Util - Simple, compact and correct param-checking functions 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... } DESCRIPTION "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 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, "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 "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, "Params::Util" will never export by default. You must explicitly name the functions you want to export, or use the ":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 "Params::Util" may clash) FUNCTIONS _STRING $string The "_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 '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 conveince if it is a valid string, or "undef" if not. _IDENTIFIER $string The "_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 "undef" if not. _CLASS $string The "_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 "normalised" form, and does not accept class names such as "::Foo" or "D'Oh". Returns the string as a convenience if it is a valid class name, or "undef" if not. _CLASSISA $string, $class The "_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 ->isa method on the class name. It does not check that the class is actually loaded. It also assumes "normalised" form, and does not accept class names such as "::Foo" or "D'Oh". Returns the string as a convenience if it is a valid class name, or "undef" if not. _CLASSDOES $string, $role This routine behaves exactly like "_CLASSISA", but checks with "->DOES" rather than "->isa". This is probably only a good idea to use on Perl 5.10 or later, when UNIVERSAL::DOES has been implemented. _SUBCLASS $string, $class The "_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 ->isa method on the class name. It does not check that the class is actually loaded. It also assumes "normalised" form, and does not accept class names such as "::Foo" or "D'Oh". Returns the string as a convenience if it is a valid class name, or "undef" if not. _NUMBER $scalar The "_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 Scalar::Util "looks_like_number" function. Returns the value as a convience, or "undef" if the value is not a number. _POSINT $integer The "_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 convience, or "undef" if the value is not a positive integer. The name itself is derived from the XML schema constraint of the same name. _NONNEGINT $integer The "_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 convience, or "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 validy contexts. unless ( defined _NONNEGINT($value) ) { die "Invalid value"; } The name itself is derived from the XML schema constraint of the same name. _SCALAR \$scalar The "_SCALAR" function is intended to be imported into your package, and provides a convenient way to test for a raw and unblessed "SCALAR" reference, with content of non-zero length. For a version that allows zero length "SCALAR" references, see the "_SCALAR0" function. Returns the "SCALAR" reference itself as a convenience, or "undef" if the value provided is not a "SCALAR" reference. _SCALAR0 \$scalar The "_SCALAR0" function is intended to be imported into your package, and provides a convenient way to test for a raw and unblessed "SCALAR0" reference, allowing content of zero-length. For a simpler "give me some content" version that requires non-zero length, "_SCALAR" function. Returns the "SCALAR" reference itself as a convenience, or "undef" if the value provided is not a "SCALAR" reference. _ARRAY $value The "_ARRAY" function is intended to be imported into your package, and provides a convenient way to test for a raw and unblessed "ARRAY" reference containing at least one element of any kind. For a more basic form that allows zero length ARRAY references, see the "_ARRAY0" function. Returns the "ARRAY" reference itself as a convenience, or "undef" if the value provided is not an "ARRAY" reference. _ARRAY0 $value The "_ARRAY0" function is intended to be imported into your package, and provides a convenient way to test for a raw and unblessed "ARRAY" reference, allowing "ARRAY" references that contain no elements. For a more basic "An array of something" form that also requires at least one element, see the "_ARRAY" function. Returns the "ARRAY" reference itself as a convenience, or "undef" if the value provided is not an "ARRAY" reference. _ARRAYLIKE $value The "_ARRAYLIKE" function tests whether a given scalar value can respond to array dereferencing. If it can, the value is returned. If it cannot, "_ARRAYLIKE" returns "undef". _HASH $value The "_HASH" function is intended to be imported into your package, and provides a convenient way to test for a raw and unblessed "HASH" reference with at least one entry. For a version of this function that allows the "HASH" to be empty, see the "_HASH0" function. Returns the "HASH" reference itself as a convenience, or "undef" if the value provided is not an "HASH" reference. _HASH0 $value The "_HASH0" function is intended to be imported into your package, and provides a convenient way to test for a raw and unblessed "HASH" reference, regardless of the "HASH" content. For a simpler "A hash of something" version that requires at least one element, see the "_HASH" function. Returns the "HASH" reference itself as a convenience, or "undef" if the value provided is not an "HASH" reference. _HASHLIKE $value The "_HASHLIKE" function tests whether a given scalar value can respond to hash dereferencing. If it can, the value is returned. If it cannot, "_HASHLIKE" returns "undef". _CODE $value The "_CODE" function is intended to be imported into your package, and provides a convenient way to test for a raw and unblessed "CODE" reference. Returns the "CODE" reference itself as a convenience, or "undef" if the value provided is not an "CODE" reference. _CODELIKE $value The "_CODELIKE" is the more generic version of "_CODE". Unlike "_CODE", which checks for an explicit "CODE" reference, the "_CODELIKE" function also includes things that act like them, such as blessed objects that overload '&{}'. 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 "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 apologise for any inconvenience caused. _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, "_INVOCANT" returns "undef". _INSTANCE $object, $class The "_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 "undef" if the value provided is not an object of that type. _INSTANCEDOES $object, $role This routine behaves exactly like "_INSTANCE", but checks with "->DOES" rather than "->isa". This is probably only a good idea to use on Perl 5.10 or later, when UNIVERSAL::DOES has been implemented. _REGEX $value The "_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 "undef" if the value provided is not a regular expression. _SET \@array, $class The "_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 "ARRAY" of objects of the class provided. For an alternative function that allows zero-length sets, see the "_SET0" function. Returns the "ARRAY" reference itself as a convenience, or "undef" if the value provided is not a set of that class. _SET0 \@array, $class The "_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 "ARRAY" of objects of the class provided. For an alternative function that requires at least one object, see the "_SET" function. Returns the "ARRAY" reference itself as a convenience, or "undef" if the value provided is not a set of that class. _HANDLE The "_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 existance (and we stole from the best of them). _DRIVER $string sub foo { my $class = _DRIVER(shift, 'My::Driver::Base') or die "Bad driver"; ... } The "_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 "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. TO DO - Add _CAN to help resolve the UNIVERSAL::can debacle - Would be even nicer if someone would demonstrate how the hell to build a Module::Install dist of the ::Util dual Perl/XS type. :/ - Implement an assertion-like version of this module, that dies on error. - Implement a Test:: version of this module, for use in testing SUPPORT Bugs should be reported via the CPAN bug tracker at For other issues, contact the author. AUTHOR Adam Kennedy SEE ALSO Params::Validate COPYRIGHT Copyright 2005 - 2012 Adam Kennedy. 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. Params-Util-1.07/Makefile.PL0000644000175100017510000001275311726772122014160 0ustar adamadamuse strict; BEGIN { require 5.00503; } use Config; use ExtUtils::MakeMaker (); # Should we build the XS version? my $make_xs = undef; foreach ( @ARGV ) { /^-pm/ and $make_xs = 0; /^-xs/ and $make_xs = 1; } unless ( defined $make_xs ) { $make_xs = can_xs(); } if ( $^O eq 'cygwin' and $make_xs == 1 and not /^-xs/ ) { # Cygwin goes bonkers breaking `` if using Params::Util XS version # for no apparent reason. $make_xs = 0; } # Generate the non-XS tests if we are making the XS version my @tests = qw{ t/01_compile.t t/02_main.t t/03_all.t t/04_codelike.t t/05_typelike.t t/06_invocant.t t/07_handle.t t/08_driver.t t/09_insideout.t }; if ( $make_xs ) { foreach my $file ( @tests ) { # Load the original local *FILE; local $/ = undef; open( FILE, "<$file" ) or die("Failed to open '$file'"); my $buffer = ; close( FILE ) or die("Failed to close '$file'"); # Convert it to a pure perl version $file =~ s/0/1/; $buffer =~ s/0;/1;/; # Write the pure perl version open( FILE, ">$file" ) or die("Failed to open '$file'"); print FILE $buffer; close( FILE ) or die("Failed to close '$file'"); } } my @clean = ( # 'test.c', '*.old' ); if ( $make_xs ) { push @clean, @tests; } WriteMakefile( # We created our own META.yml # NO_META => 1, NAME => 'Params::Util', ABSTRACT => 'Simple, compact and correct param-checking functions', VERSION_FROM => 'lib/Params/Util.pm', AUTHOR => 'Adam Kennedy ', LICENSE => 'perl', DEFINE => '-DPERL_EXT', MIN_PERL_VERSION => '5.00503', CONFIGURE_REQUIRES => { 'ExtUtils::MakeMaker' => '6.52', 'ExtUtils::CBuilder' => '0.27', }, PREREQ_PM => { 'Scalar::Util' => $make_xs ? '1.18' : '1.10', }, BUILD_REQUIRES => { 'ExtUtils::MakeMaker' => '6.52', 'Test::More' => '0.42', 'File::Spec' => '0.80', }, # Special stuff CONFIGURE => sub { my $hash = $_[1]; unless ( $make_xs ) { $hash->{XS} = {}; $hash->{C} = []; } return $hash; }, clean => { FILES => join( ' ', @clean ), }, ); ##################################################################### # Support Functions (adapted from Module::Install) # Modified from eumm-upgrade by Alexandr Ciornii. sub WriteMakefile { my %params=@_; my $eumm_version=$ExtUtils::MakeMaker::VERSION; $eumm_version=eval $eumm_version; die "EXTRA_META is deprecated" if exists $params{EXTRA_META}; die "License not specified" unless exists $params{LICENSE}; if ( $params{BUILD_REQUIRES} and $eumm_version < 6.5503 ) { #EUMM 6.5502 has problems with BUILD_REQUIRES $params{PREREQ_PM} = { %{$params{PREREQ_PM} || {}}, %{$params{BUILD_REQUIRES}}, }; delete $params{BUILD_REQUIRES}; } delete $params{CONFIGURE_REQUIRES} if $eumm_version < 6.52; delete $params{MIN_PERL_VERSION} if $eumm_version < 6.48; delete $params{META_MERGE} if $eumm_version < 6.46; delete $params{META_ADD} if $eumm_version < 6.46; delete $params{LICENSE} if $eumm_version < 6.31; delete $params{AUTHOR} if $] < 5.005; delete $params{ABSTRACT_FROM} if $] < 5.005; delete $params{BINARY_LOCATION} if $] < 5.005; ExtUtils::MakeMaker::WriteMakefile(%params); } # Secondary compile testing via ExtUtils::CBuilder sub can_xs { # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return can_cc(); } # Do a simple compile that consumes the headers we need my @libs = (); my $object = undef; my $builder = ExtUtils::CBuilder->new( quiet => 1 ); unless ( $builder->have_compiler ) { # Lack of a compiler at all return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "sanexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; eval { $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $broken = !! $@; foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink $_; } if ( $broken ) { ### NOTE: Don't do this in a production release. # Compiler is officially screwed, you don't deserve # to do any of our downstream depedencies as you'll # probably end up choking on them as well. # Trigger an NA for their own protection. print "Unresolvable broken external dependency.\n"; print "This package requires a C compiler with full perl headers.\n"; print "Trivial test code using them failed to compile.\n"; print STDERR "NA: Unable to build distribution on this platform.\n"; exit(0); } return 1; } sub can_cc { my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while ( @chunks ) { return can_run("@chunks") || (pop(@chunks), next); } return; } sub can_run { my ($cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } Params-Util-1.07/LICENSE0000644000175100017510000005014011726772122013203 0ustar adamadam Terms of Perl itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" ---------------------------------------------------------------------------- GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Lesser General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS ---------------------------------------------------------------------------- The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End Params-Util-1.07/MYMETA.json0000644000175100017510000000203411726772157014074 0ustar adamadam{ "abstract" : "Simple, compact and correct param-checking functions", "author" : [ "Adam Kennedy " ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.112621", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Params-Util", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "6.52", "File::Spec" : "0.80", "Test::More" : "0.42" } }, "configure" : { "requires" : { "ExtUtils::CBuilder" : "0.27", "ExtUtils::MakeMaker" : "6.52" } }, "runtime" : { "requires" : { "Scalar::Util" : "1.18", "perl" : "5.00503" } } }, "release_status" : "stable", "version" : "1.07" } Params-Util-1.07/xt/0000755000175100017510000000000011726772164012637 5ustar adamadamParams-Util-1.07/xt/meta.t0000644000175100017510000000107311726772122013745 0ustar adamadam#!/usr/bin/perl # Test that our META.yml file matches the current specification. use strict; BEGIN { $| = 1; $^W = 1; } my $MODULE = 'Test::CPAN::Meta 0.17'; # Don't run tests for installs use Test::More; unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Load the testing module eval "use $MODULE"; if ( $@ ) { $ENV{RELEASE_TESTING} ? die( "Failed to load required release-testing module $MODULE" ) : plan( skip_all => "$MODULE not available for testing" ); } meta_yaml_ok(); Params-Util-1.07/xt/pmv.t0000644000175100017510000000125211726772122013620 0ustar adamadam#!/usr/bin/perl # Test that our declared minimum Perl version matches our syntax use strict; BEGIN { $| = 1; $^W = 1; } my @MODULES = ( 'Perl::MinimumVersion 1.27', 'Test::MinimumVersion 0.101080', ); # Don't run tests for installs use Test::More; unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Load the testing modules foreach my $MODULE ( @MODULES ) { eval "use $MODULE"; if ( $@ ) { $ENV{RELEASE_TESTING} ? die( "Failed to load required release-testing module $MODULE" ) : plan( skip_all => "$MODULE not available for testing" ); } } all_minimum_version_from_metayml_ok(); Params-Util-1.07/xt/pod.t0000644000175100017510000000116711726772122013605 0ustar adamadam#!/usr/bin/perl # Test that the syntax of our POD documentation is valid use strict; BEGIN { $| = 1; $^W = 1; } my @MODULES = ( 'Pod::Simple 3.14', 'Test::Pod 1.44', ); # Don't run tests for installs use Test::More; unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Load the testing modules foreach my $MODULE ( @MODULES ) { eval "use $MODULE"; if ( $@ ) { $ENV{RELEASE_TESTING} ? die( "Failed to load required release-testing module $MODULE" ) : plan( skip_all => "$MODULE not available for testing" ); } } all_pod_files_ok(); Params-Util-1.07/Util.xs0000644000175100017510000001373311726772122013476 0ustar adamadam#include "EXTERN.h" #include "perl.h" #include "XSUB.h" /* Changes in 5.7 series mean that now IOK is only set if scalar is precisely integer but in 5.6 and earlier we need to do a more complex test */ #if PERL_VERSION <= 6 #define DD_is_integer(sv) (SvIOK(sv) && (SvIsUV(val) ? SvUV(sv) == SvNV(sv) : SvIV(sv) == SvNV(sv))) #else #define DD_is_integer(sv) SvIOK(sv) #endif static int is_string0( SV *sv ) { return SvFLAGS(sv) & (SVf_OK & ~SVf_ROK); } static int is_string( SV *sv ) { STRLEN len = 0; if( is_string0(sv) ) { const char *pv = SvPV(sv, len); } return len; } static int is_array( SV *sv ) { return SvROK(sv) && ( SVt_PVAV == SvTYPE(SvRV(sv) ) ); } static int is_hash( SV *sv ) { return SvROK(sv) && ( SVt_PVHV == SvTYPE(SvRV(sv) ) ); } static int is_like( SV *sv, const char *like ) { int likely = 0; if( sv_isobject( sv ) ) { dSP; int count; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs( sv_2mortal( newSVsv( sv ) ) ); XPUSHs( sv_2mortal( newSVpv( like, strlen(like) ) ) ); PUTBACK; if( ( count = call_pv("overload::Method", G_SCALAR) ) ) { I32 ax; SPAGAIN; SP -= count; ax = (SP - PL_stack_base) + 1; if( SvTRUE(ST(0)) ) ++likely; } PUTBACK; FREETMPS; LEAVE; } return likely; } MODULE = Params::Util PACKAGE = Params::Util void _STRING(sv) SV *sv PROTOTYPE: $ CODE: { if( SvMAGICAL(sv) ) mg_get(sv); if( is_string( sv ) ) { ST(0) = sv; XSRETURN(1); } XSRETURN_UNDEF; } void _NUMBER(sv) SV *sv; PROTOTYPE: $ CODE: { if( SvMAGICAL(sv) ) mg_get(sv); if( ( SvIOK(sv) ) || ( SvNOK(sv) ) || ( is_string( sv ) && looks_like_number( sv ) ) ) { ST(0) = sv; XSRETURN(1); } XSRETURN_UNDEF; } void _SCALAR0(ref) SV *ref; PROTOTYPE: $ CODE: { if( SvMAGICAL(ref) ) mg_get(ref); if( SvROK(ref) ) { if( ( SvTYPE(SvRV(ref)) <= SVt_PVBM ) && !sv_isobject(ref) ) { ST(0) = ref; XSRETURN(1); } } XSRETURN_UNDEF; } void _SCALAR(ref) SV *ref; PROTOTYPE: $ CODE: { if( SvMAGICAL(ref) ) mg_get(ref); if( SvROK(ref) ) { svtype tp = SvTYPE(SvRV(ref)); if( ( SvTYPE(SvRV(ref)) <= SVt_PVBM ) && (!sv_isobject(ref)) && is_string( SvRV(ref) ) ) { ST(0) = ref; XSRETURN(1); } } XSRETURN_UNDEF; } void _REGEX(ref) SV *ref; PROTOTYPE: $ CODE: { if( SvMAGICAL(ref) ) mg_get(ref); if( SvROK(ref) ) { svtype tp = SvTYPE(SvRV(ref)); #if PERL_VERSION >= 11 if( ( SVt_REGEXP == tp ) ) #else if( ( SVt_PVMG == tp ) && sv_isobject(ref) && ( 0 == strncmp( "Regexp", sv_reftype(SvRV(ref),TRUE), strlen("Regexp") ) ) ) #endif { ST(0) = ref; XSRETURN(1); } } XSRETURN_UNDEF; } void _ARRAY0(ref) SV *ref; PROTOTYPE: $ CODE: { if( SvMAGICAL(ref) ) mg_get(ref); if( is_array(ref) ) { ST(0) = ref; XSRETURN(1); } XSRETURN_UNDEF; } void _ARRAY(ref) SV *ref; PROTOTYPE: $ CODE: { if( SvMAGICAL(ref) ) mg_get(ref); if( is_array(ref) && ( av_len((AV *)(SvRV(ref))) >= 0 ) ) { ST(0) = ref; XSRETURN(1); } XSRETURN_UNDEF; } void _ARRAYLIKE(ref) SV *ref; PROTOTYPE: $ CODE: { if( SvMAGICAL(ref) ) mg_get(ref); if( SvROK(ref) ) { if( is_array(ref) || is_like( ref, "@{}" ) ) { ST(0) = ref; XSRETURN(1); } } XSRETURN_UNDEF; } void _HASH0(ref) SV *ref; PROTOTYPE: $ CODE: { if( SvMAGICAL(ref) ) mg_get(ref); if( is_hash(ref) ) { ST(0) = ref; XSRETURN(1); } XSRETURN_UNDEF; } void _HASH(ref) SV *ref; PROTOTYPE: $ CODE: { if( SvMAGICAL(ref) ) mg_get(ref); if( is_hash(ref) && ( HvKEYS(SvRV(ref)) >= 1 ) ) { ST(0) = ref; XSRETURN(1); } XSRETURN_UNDEF; } void _HASHLIKE(ref) SV *ref; PROTOTYPE: $ CODE: { if( SvMAGICAL(ref) ) mg_get(ref); if( SvROK(ref) ) { if( is_hash(ref) || is_like( ref, "%{}" ) ) { ST(0) = ref; XSRETURN(1); } } XSRETURN_UNDEF; } void _CODE(ref) SV *ref; PROTOTYPE: $ CODE: { if( SvMAGICAL(ref) ) mg_get(ref); if( SvROK(ref) ) { if( SVt_PVCV == SvTYPE(SvRV(ref)) ) { ST(0) = ref; XSRETURN(1); } } XSRETURN_UNDEF; } void _CODELIKE(ref) SV *ref; PROTOTYPE: $ CODE: { if( SvMAGICAL(ref) ) mg_get(ref); if( SvROK(ref) ) { if( ( SVt_PVCV == SvTYPE(SvRV(ref)) ) || ( is_like(ref, "&{}" ) ) ) { ST(0) = ref; XSRETURN(1); } } XSRETURN_UNDEF; } void _INSTANCE(ref,type) SV *ref; char *type; PROTOTYPE: $$ CODE: { STRLEN len; if( SvMAGICAL(ref) ) mg_get(ref); if( SvROK(ref) && type && ( ( len = strlen(type) ) > 0 ) ) { if( sv_isobject(ref) ) { I32 isa_type = 0; int count; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs( sv_2mortal( newSVsv( ref ) ) ); XPUSHs( sv_2mortal( newSVpv( type, len ) ) ); PUTBACK; if( ( count = call_method("isa", G_SCALAR) ) ) { I32 oldax = ax; SPAGAIN; SP -= count; ax = (SP - PL_stack_base) + 1; isa_type = SvTRUE(ST(0)); ax = oldax; } PUTBACK; FREETMPS; LEAVE; if( isa_type ) { ST(0) = ref; XSRETURN(1); } } } XSRETURN_UNDEF; } Params-Util-1.07/MANIFEST0000644000175100017510000000126511726772164013341 0ustar adamadamChanges lib/Params/Util.pm LICENSE Makefile.PL MANIFEST This list of files MYMETA.json README t/01_compile.t t/02_main.t t/03_all.t t/04_codelike.t t/05_typelike.t t/06_invocant.t t/07_handle.t t/08_driver.t t/09_insideout.t t/11_compile.t t/12_main.t t/13_all.t t/14_codelike.t t/15_typelike.t t/16_invocant.t t/17_handle.t t/18_driver.t t/19_insideout.t t/driver/A.pm t/driver/B.pm t/driver/D.pm t/driver/E.pm t/driver/F.pm t/driver/My_B.pm t/handles/handle.txt t/handles/readfile.txt Util.xs xt/meta.t xt/pmv.t xt/pod.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Params-Util-1.07/lib/0000755000175100017510000000000011726772164012752 5ustar adamadamParams-Util-1.07/lib/Params/0000755000175100017510000000000011726772164014175 5ustar adamadamParams-Util-1.07/lib/Params/Util.pm0000644000175100017510000005354711726772122015460 0ustar adamadampackage 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 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 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 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 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 will B 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 may clash) =head1 FUNCTIONS =cut use 5.00503; use strict; require overload; require Exporter; require Scalar::Util; require DynaLoader; use vars qw{$VERSION @ISA @EXPORT_OK %EXPORT_TAGS}; $VERSION = '1.07'; @ISA = qw{ Exporter DynaLoader }; @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 }; %EXPORT_TAGS = ( ALL => \@EXPORT_OK ); eval { local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY}; bootstrap Params::Util $VERSION; 1; } unless $ENV{PERL_PARAMS_UTIL_PP}; # Use a private pure-perl copy of looks_like_number if the version of # Scalar::Util is old (for whatever reason). my $SU = eval "$Scalar::Util::VERSION" || 0; if ( $SU >= 1.18 ) { Scalar::Util->import('looks_like_number'); } else { eval <<'END_PERL'; sub looks_like_number { 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 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; } END_PERL } ##################################################################### # 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 conveince if it is a valid string, or C if not. =cut eval <<'END_PERL' unless defined &_STRING; sub _STRING ($) { (defined $_[0] and ! ref $_[0] and length($_[0])) ? $_[0] : undef; } END_PERL =pod =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 if not. =cut eval <<'END_PERL' unless defined &_IDENTIFIER; sub _IDENTIFIER ($) { (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*\z/s) ? $_[0] : undef; } END_PERL =pod =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 "normalised" form, and does not accept class names such as C<::Foo> or C. Returns the string as a convenience if it is a valid class name, or C if not. =cut eval <<'END_PERL' unless defined &_CLASS; sub _CLASS ($) { (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s) ? $_[0] : undef; } END_PERL =pod =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 -Eisa method on the class name. It does not check that the class is actually loaded. It also assumes "normalised" form, and does not accept class names such as C<::Foo> or C. Returns the string as a convenience if it is a valid class name, or C if not. =cut eval <<'END_PERL' unless defined &_CLASSISA; sub _CLASSISA ($$) { (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0]->isa($_[1])) ? $_[0] : undef; } END_PERL =head2 _CLASSDOES $string, $role This routine behaves exactly like C>, 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 has been implemented. =cut eval <<'END_PERL' unless defined &_CLASSDOES; sub _CLASSDOES ($$) { (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0]->DOES($_[1])) ? $_[0] : undef; } END_PERL =pod =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 -Eisa method on the class name. It does not check that the class is actually loaded. It also assumes "normalised" form, and does not accept class names such as C<::Foo> or C. Returns the string as a convenience if it is a valid class name, or C if not. =cut eval <<'END_PERL' unless defined &_SUBCLASS; sub _SUBCLASS ($$) { (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0] ne $_[1] and $_[0]->isa($_[1])) ? $_[0] : undef; } END_PERL =pod =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 C function. Returns the value as a convience, or C if the value is not a number. =cut eval <<'END_PERL' unless defined &_NUMBER; sub _NUMBER ($) { ( defined $_[0] and ! ref $_[0] and looks_like_number($_[0]) ) ? $_[0] : undef; } END_PERL =pod =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 convience, or C if the value is not a positive integer. The name itself is derived from the XML schema constraint of the same name. =cut eval <<'END_PERL' unless defined &_POSINT; sub _POSINT ($) { (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[1-9]\d*$/) ? $_[0] : undef; } END_PERL =pod =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 convience, or C 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 validy contexts. unless ( defined _NONNEGINT($value) ) { die "Invalid value"; } The name itself is derived from the XML schema constraint of the same name. =cut eval <<'END_PERL' unless defined &_NONNEGINT; sub _NONNEGINT ($) { (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^(?:0|[1-9]\d*)$/) ? $_[0] : undef; } END_PERL =pod =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 reference, with content of non-zero length. For a version that allows zero length C references, see the C<_SCALAR0> function. Returns the C reference itself as a convenience, or C if the value provided is not a C reference. =cut eval <<'END_PERL' unless defined &_SCALAR; sub _SCALAR ($) { (ref $_[0] eq 'SCALAR' and defined ${$_[0]} and ${$_[0]} ne '') ? $_[0] : undef; } END_PERL =pod =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 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 reference itself as a convenience, or C if the value provided is not a C reference. =cut eval <<'END_PERL' unless defined &_SCALAR0; sub _SCALAR0 ($) { ref $_[0] eq 'SCALAR' ? $_[0] : undef; } END_PERL =pod =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 reference containing B one element of any kind. For a more basic form that allows zero length ARRAY references, see the C<_ARRAY0> function. Returns the C reference itself as a convenience, or C if the value provided is not an C reference. =cut eval <<'END_PERL' unless defined &_ARRAY; sub _ARRAY ($) { (ref $_[0] eq 'ARRAY' and @{$_[0]}) ? $_[0] : undef; } END_PERL =pod =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 reference, allowing C 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 reference itself as a convenience, or C if the value provided is not an C reference. =cut eval <<'END_PERL' unless defined &_ARRAY0; sub _ARRAY0 ($) { ref $_[0] eq 'ARRAY' ? $_[0] : undef; } END_PERL =pod =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. =cut eval <<'END_PERL' unless defined &_ARRAYLIKE; sub _ARRAYLIKE { (defined $_[0] and ref $_[0] and ( (Scalar::Util::reftype($_[0]) eq 'ARRAY') or overload::Method($_[0], '@{}') )) ? $_[0] : undef; } END_PERL =pod =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 reference with at least one entry. For a version of this function that allows the C to be empty, see the C<_HASH0> function. Returns the C reference itself as a convenience, or C if the value provided is not an C reference. =cut eval <<'END_PERL' unless defined &_HASH; sub _HASH ($) { (ref $_[0] eq 'HASH' and scalar %{$_[0]}) ? $_[0] : undef; } END_PERL =pod =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 reference, regardless of the C content. For a simpler "A hash of something" version that requires at least one element, see the C<_HASH> function. Returns the C reference itself as a convenience, or C if the value provided is not an C reference. =cut eval <<'END_PERL' unless defined &_HASH0; sub _HASH0 ($) { ref $_[0] eq 'HASH' ? $_[0] : undef; } END_PERL =pod =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. =cut eval <<'END_PERL' unless defined &_HASHLIKE; sub _HASHLIKE { (defined $_[0] and ref $_[0] and ( (Scalar::Util::reftype($_[0]) eq 'HASH') or overload::Method($_[0], '%{}') )) ? $_[0] : undef; } END_PERL =pod =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 reference. Returns the C reference itself as a convenience, or C if the value provided is not an C reference. =cut eval <<'END_PERL' unless defined &_CODE; sub _CODE ($) { ref $_[0] eq 'CODE' ? $_[0] : undef; } END_PERL =pod =head2 _CODELIKE $value The C<_CODELIKE> is the more generic version of C<_CODE>. Unlike C<_CODE>, which checks for an explicit C 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 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 apologise for any inconvenience caused. =cut eval <<'END_PERL' unless defined &_CODELIKE; sub _CODELIKE($) { ( (Scalar::Util::reftype($_[0])||'') eq 'CODE' or Scalar::Util::blessed($_[0]) and overload::Method($_[0],'&{}') ) ? $_[0] : undef; } END_PERL =pod =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. =cut eval <<'END_PERL' unless defined &_INVOCANT; sub _INVOCANT($) { (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 Params::Util::_CLASS($_[0])) ) ? $_[0] : undef; } END_PERL =pod =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 if the value provided is not an object of that type. =cut eval <<'END_PERL' unless defined &_INSTANCE; sub _INSTANCE ($$) { (Scalar::Util::blessed($_[0]) and $_[0]->isa($_[1])) ? $_[0] : undef; } END_PERL =head2 _INSTANCEDOES $object, $role This routine behaves exactly like C>, 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 has been implemented. =cut eval <<'END_PERL' unless defined &_INSTANCEDOES; sub _INSTANCEDOES ($$) { (Scalar::Util::blessed($_[0]) and $_[0]->DOES($_[1])) ? $_[0] : undef; } END_PERL =pod =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 if the value provided is not a regular expression. =cut eval <<'END_PERL' unless defined &_REGEX; sub _REGEX ($) { (defined $_[0] and 'Regexp' eq ref($_[0])) ? $_[0] : undef; } END_PERL =pod =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 of objects of the class provided. For an alternative function that allows zero-length sets, see the C<_SET0> function. Returns the C reference itself as a convenience, or C if the value provided is not a set of that class. =cut eval <<'END_PERL' unless defined &_SET; sub _SET ($$) { my $set = shift; _ARRAY($set) or return undef; foreach my $item ( @$set ) { _INSTANCE($item,$_[0]) or return undef; } $set; } END_PERL =pod =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 of objects of the class provided. For an alternative function that requires at least one object, see the C<_SET> function. Returns the C reference itself as a convenience, or C if the value provided is not a set of that class. =cut eval <<'END_PERL' unless defined &_SET0; sub _SET0 ($$) { my $set = shift; _ARRAY0($set) or return undef; foreach my $item ( @$set ) { _INSTANCE($item,$_[0]) or return undef; } $set; } END_PERL =pod =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 existance (and we stole from the best of them). =cut # 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. eval <<'END_PERL' unless defined &_HANDLE; 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; } END_PERL =pod =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 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. =cut eval <<'END_PERL' unless defined &_DRIVER; sub _DRIVER ($$) { (defined _CLASS($_[0]) and eval "require $_[0];" and ! $@ and $_[0]->isa($_[1]) and $_[0] ne $_[1]) ? $_[0] : undef; } END_PERL 1; =pod =head1 TO DO - Add _CAN to help resolve the UNIVERSAL::can debacle - Would be even nicer if someone would demonstrate how the hell to build a Module::Install dist of the ::Util dual Perl/XS type. :/ - 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 For other issues, contact the author. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 SEE ALSO L =head1 COPYRIGHT Copyright 2005 - 2012 Adam Kennedy. 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 Params-Util-1.07/Changes0000644000175100017510000001407211726772122013475 0ustar adamadamRevision history for Perl extension Params-Util 1.07 Sun 11 Mar 2012 - Disable XS version on cygwin as it shows bizarre behaviour that breaks form when using Params::Util XS verwion. 1.06 Thu 1 Mar 2012 - Remove the need for the sanexs.c file by generating into a temp file instead. 1.05 Thu 1 Mar 2012 - Restore compatibility with pre-5.8.8 Perls without a working compiler available install time (RIBASUSHI) 1.04 Wed 20 Apr 2011 - Fixed #67522 have_compiler returns 1.03 Mon 22 Nov 2010 - No CPAN Testers failures, moving to production release 1.02_01 Thu 16 Sep 2010 - Trying for a much more advanced can_xs() alternative to can_cc() to deal with the situation where a host has a superficially working compiler, but completely screwed up headers. - Adding some fallback strategies to deal with cases where these same machines don't support configure_requires. - Adopt Chorny's eumm-upgrade style for the Makefile.PL. - Allow the Makefile.PL to build it's own META.yml now. 1.01 Thu 18 Mar 2010 - Fixed can_cc() bug in Makefile.PL where it was checking an existence of PATH directory rather than executables. RT#55668 (DGOLDEN, MIYAGAWA) 1.00 Sun 31 May 2009 - Now all known XS bugs are worked out, I've removed the experimental flags and set that as the first 1+ release. - Fixed XS implementation of _*LIKE and _INSTANCE - Added test for a negative custom isa returning ('') - Improving the 'clean' file list in a Makefile.PL 0.38 Tue 17 Feb 2009 - Fix _IDENTIFIER to return false for "foo\n" (ZEFRAM) - Fix _CLASS to return false for "foo\n" (ZEFRAM) 0.37 Wed 4 Feb 2009 - Fix _HASH for bleadperl (patch from RAFL) - Fix regex (more) for bleadperl (patch from RAFL) 0.36 Fri 30 Jan 2009 - Fixing the overload for _REGEX - Adding the tests for _REGEX - Reorganising the Makefile.PL - Adding duplicate tests for when the XS version isn't compiled 0.35 Tue 11 Nov 2008 - No changes - CPAN Testers results look good, moving to production version 0.34_01 Mon 3 Nov 2008 - Adding experimental XS implementation by the awesome Jens Rehsack 0.33 Tue 27 May 2008 - Upgrading to Module::Install 0.74 - Bumping Scalar::Util version to 1.18 to get a fixed better looks_like_number - Moved B driver test class to My_B to prevent collision with the B modules 0.32_01 Sat 23 Feb 2008 - Moving 01_compile.t minimum version to 5.005 to match Makefile.PL (Resolves rt.cpan.org #26674) - Removing the deprecated _CALLABLE function 0.31 Wed 14 Nov 2007 - Upgrading to Module::Install 0.68 0.30 Mon 22 Oct 2007 - Incremental release to get a newer and non-broken version of the author-only tests. 0.29 Thu 23 Aug 2007 - Correcting a test which only ran under AUTOMATED_TESTING, apparently my release automation isn't doing what I think it is doing. 0.28 Sat 18 Aug 2007 - Dropping the Perl version requirement in 01_compile.t to 5.004 0.27 Sat 18 Aug 2007 - Skipping one particularly evil test that we know fails on a few OS unless AUTOMATED_TESTING is enabled. These failures weren't worth preventing installation at all. 0.26 Fri 27 Jul 2007 - Adding the _NONNEGINT function 0.25 Mon 14 May 2007 - Adding the _CLASSISA and _SUBCLASS functions to fill a gap between _CLASS and _DRIVER 0.24 Wed 9 May 2007 - Adding the _DRIVER function for use in writing driver APIs 0.23 Tue 20 Feb 2007 - Bug fix to _INVOCANT to handle false classes. 0.22 Wed 1 Nov 2006 - Bug fix to _CODELIKE to handle CODE refs properly - Updating tests to work more accurately in this regard. 0.21 Tue 10 Oct 2006 - When no compiler available, minimise the dependency on Scalar::Util, because it's better to leave them with a slightly leaky version than to fail altogether. 0.20 Tue 26 Sep 2006 - Advanced deprecation of _CALLABLE to "warn but work". - Correctly refer to _CALLABLE being deprecated, not _CODELIKE. - Add support for Tie::Handle objects to _HANDLE - Add support for IO::Scalar objects to _HANDLE - Add support for IO::String objects to _HANDLE 0.19 Thu 14 Sep 2006 - Adding more Scalar::Util tests, this time with some diagnostics 0.18 Thu 14 Sep 2006 - Explicitly importing refaddr in t/07_handle.t to fix test failure on ActivePerl 5.8.0. - Increased Scalar::Util dep to 1.14 because we may well be hurt by tied handles-related bug. 0.17 Tue 8 Aug 2006 - Adding experimental _HANDLE implementation 0.16 Sun 2 Jul 2006 - We don't check for stash definedness for _INVOCANT. (This is required for 5.005 compat.) 0.15 Sun 2 Jul 2006 # This release contains only build-time changes - Updating to Module::Install 0.63 to add 5.004 support (sorta) - Dropping version dependency to 5.004 (Ricardo Signes) 0.14 Wed 10 May 2006 - No features() used in this dist, so removing auto_install - Moved _CALLABLE to _CODELIKE for symmetry reasons. Sorry :( Immediate doc changover. Silent alias for a month, then warning alias for 3 months, then full deprecation at the end of August. - Removed RJBS's use warnings that broke 5.005-compatibility. - Other minor test cleanups. 0.13 Sun May 7 2006 # This release contains only build-time changes - Upgrading Module::Install to 0.62 final 0.12 Mon May 1 2006 - Added _ARRAYLIKE and _HASHLIKE (Ricardo Signes again) - Added _INVOCANT (Ricardo Signes again!) - Expanded test suite (Does Ricardo Signes ever sleep??) 0.11 Wed Apr 12 2006 - Update _CLASS to allow numeric parts in the tail, like Foo::10 (provided by Ricardo Signes) 0.10 Sat Jan 14 2006 - Updated copyright - Added _STRING 0.09 Fri Dec 30 2005 - Fixed broken link to RT in POD 0.08 Mon Dec 19 2005 - Moved from old CVS repository to newer SVN repository - Added _CALLABLE (provided by Ricardo Signes) 0.07 Mon Oct 10 2005 - Adding the :ALL tag 0.06 Wed Oct 5 2005 - Rereleasing with newer Module::Install that correctly includes ExtUtils::AutoInstall. 0.05 Mon May 2 2005 - Added _POSINT 0.04 Wed Apr 27 2005 - Fixed a POD bug in the synopsis 0.03 Sun Apr 24 2005 - Added the _CODE function 0.02 Fri Apr 22 2005 - Added the _CLASS function 0.01 Fri Apr 22 2005 - Completed the first implementation Params-Util-1.07/t/0000755000175100017510000000000011726772164012447 5ustar adamadamParams-Util-1.07/t/04_codelike.t0000644000175100017510000000516711726772122014721 0ustar adamadam#!/usr/bin/perl use strict; BEGIN { $| = 1; $^W = 1; $ENV{PERL_PARAMS_UTIL_PP} ||= 0; } sub _CODELIKE($); use Test::More; use File::Spec::Functions ':ALL'; use Scalar::Util qw( blessed reftype refaddr ); use overload; sub c_ok { is( refaddr(_CODELIKE($_[0])), refaddr($_[0]), "callable: $_[1]", ) } sub nc_ok { my $left = shift; $left = _CODELIKE($left); is( $left, undef, "not callable: $_[0]" ); } my @callables = ( "callable itself" => \&_CODELIKE, "a boring plain code ref" => sub {}, 'an object with overloaded &{}' => C::O->new, 'a object build from a coderef' => C::C->new, 'an object with inherited overloaded &{}' => C::O::S->new, 'a coderef blessed into CODE' => (bless sub {} => 'CODE'), ); my @uncallables = ( "undef" => undef, "a string" => "a string", "a number" => 19780720, "a ref to a ref to code" => \(sub {}), "a boring plain hash ref" => {}, 'a class that builds from coderefs' => "C::C", 'a class with overloaded &{}' => "C::O", 'a class with inherited overloaded &{}' => "C::O::S", 'a plain boring hash-based object' => UC->new, 'a non-coderef blessed into CODE' => (bless {} => 'CODE'), ); my $tests = (@callables + @uncallables) / 2 + 2; if ( $] > 5.006 ) { push @uncallables, 'a regular expression', qr/foo/; $tests += 1; } plan tests => $tests; # Import the function use_ok( 'Params::Util', '_CODELIKE' ); ok( defined *_CODELIKE{CODE}, '_CODELIKE imported ok' ); while ( @callables ) { my $name = shift @callables; my $object = shift @callables; c_ok( $object, $name ); } while ( @uncallables ) { my $name = shift @uncallables; my $object = shift @uncallables; nc_ok( $object, $name ); } ###################################################################### # callable: is a blessed code ref package C::C; sub new { bless sub {} => shift; } ###################################################################### # callable: overloads &{} # but only objects are callable, not class package C::O; sub new { bless {} => shift; } use overload '&{}' => sub { sub {} }; use overload 'bool' => sub () { 1 }; ###################################################################### # callable: subclasses C::O package C::O::S; use vars qw{@ISA}; BEGIN { @ISA = 'C::O'; } ###################################################################### # uncallable: some boring object with no codey magic package UC; sub new { bless {} => shift; } Params-Util-1.07/t/08_driver.t0000644000175100017510000001112411726772122014427 0ustar adamadam#!/usr/bin/perl use strict; BEGIN { $| = 1; $^W = 1; $ENV{PERL_PARAMS_UTIL_PP} ||= 0; } use Test::More tests => 91; use File::Spec::Functions ':ALL'; BEGIN { ok( ! defined &_CLASSISA, '_CLASSISA does not exist' ); ok( ! defined &_SUBCLASS, '_SUBCLASS does not exist' ); ok( ! defined &_DRIVER, '_DRIVER does not exist' ); use_ok('Params::Util', qw(_CLASSISA _SUBCLASS _DRIVER)); ok( defined &_CLASSISA, '_CLASSISA imported ok' ); ok( defined &_SUBCLASS, '_SUBCLASS imported ok' ); ok( defined &_DRIVER, '_DRIVER imported ok' ); } # Import refaddr to make certain we have it use Scalar::Util 'refaddr'; ##################################################################### # Preparing my $A = catfile( 't', 'driver', 'A.pm' ); ok( -f $A, 'A exists' ); my $B = catfile( 't', 'driver', 'My_B.pm' ); ok( -f $B, 'My_B exists' ); my $C = catfile( 't', 'driver', 'C.pm' ); ok( ! -f $C, 'C does not exist' ); my $D = catfile( 't', 'driver', 'D.pm' ); ok( -f $D, 'D does not exist' ); my $E = catfile( 't', 'driver', 'E.pm' ); ok( -f $E, 'E does not exist' ); my $F = catfile( 't', 'driver', 'F.pm' ); ok( -f $F, 'F does not exist' ); unshift @INC, catdir( 't', 'driver' ); ##################################################################### # Things that are not file handles foreach ( undef, '', ' ', 'foo bar', 1, 0, -1, 1.23, [], {}, \'', bless( {}, "foo" ) ) { is( _CLASSISA($_, 'A'), undef, 'Non-classisa returns undef' ); is( _SUBCLASS($_, 'A'), undef, 'Non-subclass returns undef' ); is( _DRIVER($_, 'A'), undef, 'Non-driver returns undef' ); } ##################################################################### # Sample Classes # classisa should not load classes is( _CLASSISA('A', 'A'), 'A', 'A: Driver base class is undef' ); is( _CLASSISA('My_B', 'A'), undef, 'B: Good driver returns ok' ); is( _CLASSISA('My_B', 'H'), undef, 'B: Good driver return undef for incorrect base' ); is( _CLASSISA('C', 'A'), undef, 'C: Non-existant driver is undef' ); is( _CLASSISA('D', 'A'), undef, 'D: Broken driver is undef' ); is( _CLASSISA('E', 'A'), undef, 'E: Not a driver returns undef' ); is( _CLASSISA('F', 'A'), undef, 'F: Faked isa returns ok' ); # classisa should not load classes is( _SUBCLASS('A', 'A'), undef, 'A: Driver base class is undef' ); is( _SUBCLASS('My_B', 'A'), undef, 'B: Good driver returns ok' ); is( _SUBCLASS('My_B', 'H'), undef, 'B: Good driver return undef for incorrect base' ); is( _SUBCLASS('C', 'A'), undef, 'C: Non-existant driver is undef' ); is( _SUBCLASS('D', 'A'), undef, 'D: Broken driver is undef' ); is( _SUBCLASS('E', 'A'), undef, 'E: Not a driver returns undef' ); is( _SUBCLASS('F', 'A'), undef, 'F: Faked isa returns ok' ); # The base class itself is not a driver is( _DRIVER('A', 'A'), undef, 'A: Driver base class is undef' ); ok( $A::VERSION, 'A: Class is loaded ok' ); is( _DRIVER('My_B', 'A'), 'My_B', 'B: Good driver returns ok' ); is( _DRIVER('My_B', 'H'), undef, 'B: Good driver return undef for incorrect base' ); ok( $My_B::VERSION, 'B: Class is loaded ok' ); is( _DRIVER('C', 'A'), undef, 'C: Non-existant driver is undef' ); is( _DRIVER('D', 'A'), undef, 'D: Broken driver is undef' ); is( _DRIVER('E', 'A'), undef, 'E: Not a driver returns undef' ); is( _DRIVER('F', 'A'), 'F', 'F: Faked isa returns ok' ); # Repeat for classisa is( _CLASSISA('A', 'A'), 'A', 'A: Driver base class is undef' ); is( _CLASSISA('My_B', 'A'), 'My_B', 'B: Good driver returns ok' ); is( _CLASSISA('My_B', 'H'), undef, 'B: Good driver return undef for incorrect base' ); is( _CLASSISA('C', 'A'), undef, 'C: Non-existant driver is undef' ); is( _CLASSISA('D', 'A'), 'D', 'D: Broken driver is undef' ); is( _CLASSISA('E', 'A'), undef, 'E: Not a driver returns undef' ); is( _CLASSISA('F', 'A'), 'F', 'F: Faked isa returns ok' ); # Repeat for subclasses is( _SUBCLASS('A', 'A'), undef, 'A: Driver base class is undef' ); is( _SUBCLASS('My_B', 'A'), 'My_B', 'B: Good driver returns ok' ); is( _SUBCLASS('My_B', 'H'), undef, 'B: Good driver return undef for incorrect base' ); is( _SUBCLASS('C', 'A'), undef, 'C: Non-existant driver is undef' ); is( _SUBCLASS('D', 'A'), 'D', 'D: Broken driver is undef' ); is( _SUBCLASS('E', 'A'), undef, 'E: Not a driver returns undef' ); is( _SUBCLASS('F', 'A'), 'F', 'F: Faked isa returns ok' ); SKIP: { use_ok('Params::Util', qw(_CLASSDOES)); skip "DOES tests do not make sense on perls before 5.10", 4 unless $] >= 5.010; is( _CLASSDOES('A', 'A'), 'A', 'A: DOES A' ); is( _CLASSDOES('My_B', 'A'), 'My_B', 'My_B: DOES A' ); is( _CLASSDOES('E', 'A'), undef, 'E: DOES not A' ); is( _CLASSDOES('F', 'A'), 'F', 'F: DOES A' ); } Params-Util-1.07/t/16_invocant.t0000644000175100017510000000327611726772157014775 0ustar adamadam#!/usr/bin/perl use strict; BEGIN { $| = 1; $^W = 1; $ENV{PERL_PARAMS_UTIL_PP} ||= 1; } use Test::More tests => 11; use File::Spec::Functions ':ALL'; BEGIN { use_ok('Params::Util', qw(_INVOCANT)); } my $object = bless \do { my $i } => 'Params::Util::Test::Bogus::Whatever'; my $false_obj1 = bless \do { my $i } => 0; my $false_obj2 = bless \do { my $i } => "\0"; my $tied = tie my $x, 'Params::Util::Test::_INVOCANT::Tied'; my $unpkg = 'Params::Util::Test::_INVOCANT::Fake'; my $pkg = 'Params::Util::Test::_INVOCANT::Real'; eval "package $pkg;"; ## no critic my @data = (# I [ undef , 0, 'undef' ], [ 1000 => 0, '1000' ], [ $unpkg => 1, qq("$unpkg") ], [ $pkg => 1, qq("$pkg") ], [ [] => 0, '[]' ], [ {} => 0, '{}' ], [ $object => 1, 'blessed reference' ], [ $false_obj1 => 1, 'blessed reference' ], [ $tied => 1, 'tied value' ], ); for my $datum (@data) { is( _INVOCANT($datum->[0]) ? 1 : 0, $datum->[1], "$datum->[2] " . ($datum->[1] ? 'is' : "isn't") . " _IN" ); } # Skip the most evil test except on automated testing, because it # fails on at least one common production OS (RedHat Enterprise Linux 4) # and the test case should be practically impossible to encounter # in real life. The damage the bug could cause users in production is # far lower than the damage caused by Params::Util failing to install. SKIP: { unless ( $ENV{AUTOMATED_TESTING} ) { skip("Skipping nasty test unless AUTOMATED_TESTING", 1); } ok( !! _INVOCANT($false_obj2), 'Testing null class as an invocant' ); } package Params::Util::Test::_INVOCANT::Tied; sub TIESCALAR { my ($class, $value) = @_; return bless \$value => $class; } Params-Util-1.07/t/14_codelike.t0000644000175100017510000000516711726772157014732 0ustar adamadam#!/usr/bin/perl use strict; BEGIN { $| = 1; $^W = 1; $ENV{PERL_PARAMS_UTIL_PP} ||= 1; } sub _CODELIKE($); use Test::More; use File::Spec::Functions ':ALL'; use Scalar::Util qw( blessed reftype refaddr ); use overload; sub c_ok { is( refaddr(_CODELIKE($_[0])), refaddr($_[0]), "callable: $_[1]", ) } sub nc_ok { my $left = shift; $left = _CODELIKE($left); is( $left, undef, "not callable: $_[0]" ); } my @callables = ( "callable itself" => \&_CODELIKE, "a boring plain code ref" => sub {}, 'an object with overloaded &{}' => C::O->new, 'a object build from a coderef' => C::C->new, 'an object with inherited overloaded &{}' => C::O::S->new, 'a coderef blessed into CODE' => (bless sub {} => 'CODE'), ); my @uncallables = ( "undef" => undef, "a string" => "a string", "a number" => 19780720, "a ref to a ref to code" => \(sub {}), "a boring plain hash ref" => {}, 'a class that builds from coderefs' => "C::C", 'a class with overloaded &{}' => "C::O", 'a class with inherited overloaded &{}' => "C::O::S", 'a plain boring hash-based object' => UC->new, 'a non-coderef blessed into CODE' => (bless {} => 'CODE'), ); my $tests = (@callables + @uncallables) / 2 + 2; if ( $] > 5.006 ) { push @uncallables, 'a regular expression', qr/foo/; $tests += 1; } plan tests => $tests; # Import the function use_ok( 'Params::Util', '_CODELIKE' ); ok( defined *_CODELIKE{CODE}, '_CODELIKE imported ok' ); while ( @callables ) { my $name = shift @callables; my $object = shift @callables; c_ok( $object, $name ); } while ( @uncallables ) { my $name = shift @uncallables; my $object = shift @uncallables; nc_ok( $object, $name ); } ###################################################################### # callable: is a blessed code ref package C::C; sub new { bless sub {} => shift; } ###################################################################### # callable: overloads &{} # but only objects are callable, not class package C::O; sub new { bless {} => shift; } use overload '&{}' => sub { sub {} }; use overload 'bool' => sub () { 1 }; ###################################################################### # callable: subclasses C::O package C::O::S; use vars qw{@ISA}; BEGIN { @ISA = 'C::O'; } ###################################################################### # uncallable: some boring object with no codey magic package UC; sub new { bless {} => shift; } Params-Util-1.07/t/18_driver.t0000644000175100017510000001112411726772157014440 0ustar adamadam#!/usr/bin/perl use strict; BEGIN { $| = 1; $^W = 1; $ENV{PERL_PARAMS_UTIL_PP} ||= 1; } use Test::More tests => 91; use File::Spec::Functions ':ALL'; BEGIN { ok( ! defined &_CLASSISA, '_CLASSISA does not exist' ); ok( ! defined &_SUBCLASS, '_SUBCLASS does not exist' ); ok( ! defined &_DRIVER, '_DRIVER does not exist' ); use_ok('Params::Util', qw(_CLASSISA _SUBCLASS _DRIVER)); ok( defined &_CLASSISA, '_CLASSISA imported ok' ); ok( defined &_SUBCLASS, '_SUBCLASS imported ok' ); ok( defined &_DRIVER, '_DRIVER imported ok' ); } # Import refaddr to make certain we have it use Scalar::Util 'refaddr'; ##################################################################### # Preparing my $A = catfile( 't', 'driver', 'A.pm' ); ok( -f $A, 'A exists' ); my $B = catfile( 't', 'driver', 'My_B.pm' ); ok( -f $B, 'My_B exists' ); my $C = catfile( 't', 'driver', 'C.pm' ); ok( ! -f $C, 'C does not exist' ); my $D = catfile( 't', 'driver', 'D.pm' ); ok( -f $D, 'D does not exist' ); my $E = catfile( 't', 'driver', 'E.pm' ); ok( -f $E, 'E does not exist' ); my $F = catfile( 't', 'driver', 'F.pm' ); ok( -f $F, 'F does not exist' ); unshift @INC, catdir( 't', 'driver' ); ##################################################################### # Things that are not file handles foreach ( undef, '', ' ', 'foo bar', 1, 0, -1, 1.23, [], {}, \'', bless( {}, "foo" ) ) { is( _CLASSISA($_, 'A'), undef, 'Non-classisa returns undef' ); is( _SUBCLASS($_, 'A'), undef, 'Non-subclass returns undef' ); is( _DRIVER($_, 'A'), undef, 'Non-driver returns undef' ); } ##################################################################### # Sample Classes # classisa should not load classes is( _CLASSISA('A', 'A'), 'A', 'A: Driver base class is undef' ); is( _CLASSISA('My_B', 'A'), undef, 'B: Good driver returns ok' ); is( _CLASSISA('My_B', 'H'), undef, 'B: Good driver return undef for incorrect base' ); is( _CLASSISA('C', 'A'), undef, 'C: Non-existant driver is undef' ); is( _CLASSISA('D', 'A'), undef, 'D: Broken driver is undef' ); is( _CLASSISA('E', 'A'), undef, 'E: Not a driver returns undef' ); is( _CLASSISA('F', 'A'), undef, 'F: Faked isa returns ok' ); # classisa should not load classes is( _SUBCLASS('A', 'A'), undef, 'A: Driver base class is undef' ); is( _SUBCLASS('My_B', 'A'), undef, 'B: Good driver returns ok' ); is( _SUBCLASS('My_B', 'H'), undef, 'B: Good driver return undef for incorrect base' ); is( _SUBCLASS('C', 'A'), undef, 'C: Non-existant driver is undef' ); is( _SUBCLASS('D', 'A'), undef, 'D: Broken driver is undef' ); is( _SUBCLASS('E', 'A'), undef, 'E: Not a driver returns undef' ); is( _SUBCLASS('F', 'A'), undef, 'F: Faked isa returns ok' ); # The base class itself is not a driver is( _DRIVER('A', 'A'), undef, 'A: Driver base class is undef' ); ok( $A::VERSION, 'A: Class is loaded ok' ); is( _DRIVER('My_B', 'A'), 'My_B', 'B: Good driver returns ok' ); is( _DRIVER('My_B', 'H'), undef, 'B: Good driver return undef for incorrect base' ); ok( $My_B::VERSION, 'B: Class is loaded ok' ); is( _DRIVER('C', 'A'), undef, 'C: Non-existant driver is undef' ); is( _DRIVER('D', 'A'), undef, 'D: Broken driver is undef' ); is( _DRIVER('E', 'A'), undef, 'E: Not a driver returns undef' ); is( _DRIVER('F', 'A'), 'F', 'F: Faked isa returns ok' ); # Repeat for classisa is( _CLASSISA('A', 'A'), 'A', 'A: Driver base class is undef' ); is( _CLASSISA('My_B', 'A'), 'My_B', 'B: Good driver returns ok' ); is( _CLASSISA('My_B', 'H'), undef, 'B: Good driver return undef for incorrect base' ); is( _CLASSISA('C', 'A'), undef, 'C: Non-existant driver is undef' ); is( _CLASSISA('D', 'A'), 'D', 'D: Broken driver is undef' ); is( _CLASSISA('E', 'A'), undef, 'E: Not a driver returns undef' ); is( _CLASSISA('F', 'A'), 'F', 'F: Faked isa returns ok' ); # Repeat for subclasses is( _SUBCLASS('A', 'A'), undef, 'A: Driver base class is undef' ); is( _SUBCLASS('My_B', 'A'), 'My_B', 'B: Good driver returns ok' ); is( _SUBCLASS('My_B', 'H'), undef, 'B: Good driver return undef for incorrect base' ); is( _SUBCLASS('C', 'A'), undef, 'C: Non-existant driver is undef' ); is( _SUBCLASS('D', 'A'), 'D', 'D: Broken driver is undef' ); is( _SUBCLASS('E', 'A'), undef, 'E: Not a driver returns undef' ); is( _SUBCLASS('F', 'A'), 'F', 'F: Faked isa returns ok' ); SKIP: { use_ok('Params::Util', qw(_CLASSDOES)); skip "DOES tests do not make sense on perls before 5.10", 4 unless $] >= 5.010; is( _CLASSDOES('A', 'A'), 'A', 'A: DOES A' ); is( _CLASSDOES('My_B', 'A'), 'My_B', 'My_B: DOES A' ); is( _CLASSDOES('E', 'A'), undef, 'E: DOES not A' ); is( _CLASSDOES('F', 'A'), 'F', 'F: DOES A' ); } Params-Util-1.07/t/12_main.t0000644000175100017510000012556211726772157014077 0ustar adamadam#!/usr/bin/perl use strict; BEGIN { $| = 1; $^W = 1; $ENV{PERL_PARAMS_UTIL_PP} ||= 1; } use Test::More tests => 632; use File::Spec::Functions ':ALL'; use Scalar::Util 'refaddr'; use Params::Util (); # Utility functions sub true { is( shift, 1, shift || () ) } sub false { is( shift, '', shift || () ) } sub null { is( shift, undef, shift || () ) } sub dies { my ($code, $regexp, $message) = @_; eval "$code"; ok( (defined($@) and length($@)), $message ); if ( defined $regexp ) { like( $@, $regexp, '... with expected error message' ); } } ##################################################################### # Tests for _STRING # Test bad things against the actual function dies( "Params::Util::_STRING()", qr/Not enough arguments/, '...::_STRING() dies' ); null( Params::Util::_STRING(undef), '...::_STRING(undef) returns undef' ); null( Params::Util::_STRING(''), '...::_STRING(nullstring) returns undef' ); null( Params::Util::_STRING({ foo => 1 }), '...::_STRING(HASH) returns undef' ); null( Params::Util::_STRING(sub () { 1 }), '...::_STRING(CODE) returns undef' ); null( Params::Util::_STRING([]), '...::_STRING(ARRAY) returns undef' ); null( Params::Util::_STRING(\""), '...::_STRING(null constant) returns undef' ); null( Params::Util::_STRING(\"foo"), '...::_STRING(SCALAR) returns undef' ); # Test good things against the actual function (carefully) foreach my $ident ( qw{0 1 foo _foo foo1 __foo_1 Foo::Bar}, ' ', ' foo' ) { is( Params::Util::_STRING($ident), $ident, "...::_STRING('$ident') returns ok" ); } # Import the function use_ok( 'Params::Util', '_STRING' ); ok( defined *_STRING{CODE}, '_STRING imported ok' ); # Test bad things against the actual function dies( "_STRING()", qr/Not enough arguments/, '...::_STRING() dies' ); null( _STRING(undef), '_STRING(undef) returns undef' ); null( _STRING(''), '_STRING(nullstring) returns undef' ); null( _STRING({ foo => 1 }), '_STRING(HASH) returns undef' ); null( _STRING(sub () { 1 }), '_STRING(CODE) returns undef' ); null( _STRING([]), '_STRING(ARRAY) returns undef' ); null( _STRING(\""), '_STRING(null constant) returns undef' ); null( _STRING(\"foo"), '_STRING(SCALAR) returns undef' ); # Test good things against the actual function (carefully) foreach my $ident ( qw{0 1 foo _foo foo1 __foo_1 Foo::Bar}, ' ', ' foo' ) { is( _STRING($ident), $ident, "...::_STRING('$ident') returns ok" ); } ##################################################################### # Tests for _IDENTIFIER # Test bad things against the actual function dies( "Params::Util::_IDENTIFIER()", qr/Not enough arguments/, '...::_IDENTIFIER() dies' ); null( Params::Util::_IDENTIFIER(undef), '...::_IDENTIFIER(undef) returns undef' ); null( Params::Util::_IDENTIFIER(''), '...::_IDENTIFIER(nullstring) returns undef' ); null( Params::Util::_IDENTIFIER(1), '...::_IDENTIFIER(number) returns undef' ); null( Params::Util::_IDENTIFIER(' foo'), '...::_IDENTIFIER(string) returns undef' ); null( Params::Util::_IDENTIFIER({ foo => 1 }), '...::_IDENTIFIER(HASH) returns undef' ); null( Params::Util::_IDENTIFIER(sub () { 1 }), '...::_IDENTIFIER(CODE) returns undef' ); null( Params::Util::_IDENTIFIER([]), '...::_IDENTIFIER(ARRAY) returns undef' ); null( Params::Util::_IDENTIFIER(\""), '...::_IDENTIFIER(null constant) returns undef' ); null( Params::Util::_IDENTIFIER(\"foo"), '...::_IDENTIFIER(SCALAR) returns undef' ); null( Params::Util::_IDENTIFIER("Foo::Bar"), '...::_IDENTIFIER(CLASS) returns undef' ); null( Params::Util::_IDENTIFIER("foo\n"), '...::_IDENTIFIER(BAD) returns undef' ); # Test good things against the actual function (carefully) foreach my $ident ( qw{foo _foo foo1 __foo_1} ) { is( Params::Util::_IDENTIFIER($ident), $ident, "...::_IDENTIFIER('$ident') returns ok" ); } # Import the function use_ok( 'Params::Util', '_IDENTIFIER' ); ok( defined *_IDENTIFIER{CODE}, '_IDENTIFIER imported ok' ); # Test bad things against the actual function dies( "_IDENTIFIER()", qr/Not enough arguments/, '...::_IDENTIFIER() dies' ); null( _IDENTIFIER(undef), '_IDENTIFIER(undef) returns undef' ); null( _IDENTIFIER(''), '_IDENTIFIER(nullstring) returns undef' ); null( _IDENTIFIER(1), '_IDENTIFIER(number) returns undef' ); null( _IDENTIFIER(' foo'), '_IDENTIFIER(string) returns undef' ); null( _IDENTIFIER({ foo => 1 }), '_IDENTIFIER(HASH) returns undef' ); null( _IDENTIFIER(sub () { 1 }), '_IDENTIFIER(CODE) returns undef' ); null( _IDENTIFIER([]), '_IDENTIFIER(ARRAY) returns undef' ); null( _IDENTIFIER(\""), '_IDENTIFIER(null constant) returns undef' ); null( _IDENTIFIER(\"foo"), '_IDENTIFIER(SCALAR) returns undef' ); null( _IDENTIFIER("Foo::Bar"), '_IDENTIFIER(CLASS) returns undef' ); null( _IDENTIFIER("foo\n"), '_IDENTIFIER(BAD) returns undef' ); # Test good things against the actual function (carefully) foreach my $ident ( qw{foo _foo foo1 __foo_1} ) { is( _IDENTIFIER($ident), $ident, "...::_IDENTIFIER('$ident') returns ok" ); } ##################################################################### # Tests for _CLASS # Test bad things against the actual function dies( "Params::Util::_CLASS()", qr/Not enough arguments/, '...::_CLASS() dies' ); null( Params::Util::_CLASS(undef), '...::_CLASS(undef) returns undef' ); null( Params::Util::_CLASS(''), '...::_CLASS(nullstring) returns undef' ); null( Params::Util::_CLASS(1), '...::_CLASS(number) returns undef' ); null( Params::Util::_CLASS(' foo'), '...::_CLASS(string) returns undef' ); null( Params::Util::_CLASS({ foo => 1 }), '...::_CLASS(HASH) returns undef' ); null( Params::Util::_CLASS(sub () { 1 }), '...::_CLASS(CODE) returns undef' ); null( Params::Util::_CLASS([]), '...::_CLASS(ARRAY) returns undef' ); null( Params::Util::_CLASS(\""), '...::_CLASS(null constant) returns undef' ); null( Params::Util::_CLASS(\"foo"), '...::_CLASS(SCALAR) returns undef' ); null( Params::Util::_CLASS("D'oh"), '...::_CLASS(bad class) returns undef' ); null( Params::Util::_CLASS("::Foo"), '...::_CLASS(bad class) returns undef' ); null( Params::Util::_CLASS("1::X"), '...::_CLASS(bad class) returns undef' ); # Test good things against the actual function (carefully) foreach my $ident ( qw{foo _foo foo1 __foo_1 Foo::Bar _Foo::Baaar::Baz X::1} ) { is( Params::Util::_CLASS($ident), $ident, "...::_CLASS('$ident') returns ok" ); } # Import the function use_ok( 'Params::Util', '_CLASS' ); ok( defined *_CLASS{CODE}, '_CLASS imported ok' ); # Test bad things against the actual function dies( "_CLASS()", qr/Not enough arguments/, '_CLASS() dies' ); null( _CLASS(undef), '_CLASS(undef) returns undef' ); null( _CLASS(''), '_CLASS(nullstring) returns undef' ); null( _CLASS(1), '_CLASS(number) returns undef' ); null( _CLASS(' foo'), '_CLASS(string) returns undef' ); null( _CLASS({ foo => 1 }), '_CLASS(HASH) returns undef' ); null( _CLASS(sub () { 1 }), '_CLASS(CODE) returns undef' ); null( _CLASS([]), '_CLASS(ARRAY) returns undef' ); null( _CLASS(\""), '_CLASS(null constant) returns undef' ); null( _CLASS(\"foo"), '_CLASS(SCALAR) returns undef' ); null( _CLASS("D'oh"), '_CLASS(bad class) returns undef' ); null( _CLASS("::Foo"), '_CLASS(bad class) returns undef' ); null( _CLASS("1::X"), '_CLASS(bad class) returns undef' ); # Test good things against the actual function (carefully) foreach my $ident ( qw{foo _foo foo1 __foo_1 Foo::Bar _Foo::Baaar::Baz X::1} ) { is( _CLASS($ident), $ident, "_CLASS('$ident') returns ok" ); } ##################################################################### # Tests for _NUMBER # Test bad things against the actual function dies( "Params::Util::_NUMBER()", qr/Not enough arguments/, '...::_NUMBER() dies' ); null( Params::Util::_NUMBER(undef), '...::_NUMBER(undef) returns undef' ); null( Params::Util::_NUMBER(''), '...::_NUMBER(nullstring) returns undef' ); null( Params::Util::_NUMBER(' foo'), '...::_NUMBER(string) returns undef' ); null( Params::Util::_NUMBER({ foo => 1 }), '...::_NUMBER(HASH) returns undef' ); null( Params::Util::_NUMBER(sub () { 1 }), '...::_NUMBER(CODE) returns undef' ); null( Params::Util::_NUMBER([]), '...::_NUMBER(ARRAY) returns undef' ); null( Params::Util::_NUMBER(\""), '...::_NUMBER(null constant) returns undef' ); null( Params::Util::_NUMBER(\"foo"), '...::_NUMBER(SCALAR) returns undef' ); null( Params::Util::_NUMBER("D'oh"), '...::_NUMBER(bad class) returns undef' ); # Test good things against the actual function (carefully) foreach my $id ( qw{1 2 10 123456789 -1 0 +1 02 .1 0.013e-3 1e1} ) { is( Params::Util::_NUMBER($id), $id, "...::_NUMBER('$id') returns ok" ); } # Import the function use_ok( 'Params::Util', '_NUMBER' ); ok( defined *_NUMBER{CODE}, '_NUMBER imported ok' ); # Test bad things against the actual function dies( "_NUMBER()", qr/Not enough arguments/, '_NUMBER() dies' ); null( _NUMBER(undef), '_NUMBER(undef) returns undef' ); null( _NUMBER(''), '_NUMBER(nullstring) returns undef' ); null( _NUMBER(' foo'), '_NUMBER(string) returns undef' ); null( _NUMBER({ foo => 1 }), '_NUMBER(HASH) returns undef' ); null( _NUMBER(sub () { 1 }), '_NUMBER(CODE) returns undef' ); null( _NUMBER([]), '_NUMBER(ARRAY) returns undef' ); null( _NUMBER(\""), '_NUMBER(null constant) returns undef' ); null( _NUMBER(\"foo"), '_NUMBER(SCALAR) returns undef' ); null( _NUMBER("D'oh"), '_NUMBER(bad class) returns undef' ); # Test good things against the actual function (carefully) foreach my $id ( qw{1 2 10 123456789 -1 0 +1 02 .1 0.013e-3 1e1} ) { is( _NUMBER($id), $id, "_NUMBER('$id') returns ok" ); } ##################################################################### # Tests for _POSINT # Test bad things against the actual function dies( "Params::Util::_POSINT()", qr/Not enough arguments/, '...::_POSINT() dies' ); null( Params::Util::_POSINT(undef), '...::_POSINT(undef) returns undef' ); null( Params::Util::_POSINT(''), '...::_POSINT(nullstring) returns undef' ); null( Params::Util::_POSINT(' foo'), '...::_POSINT(string) returns undef' ); null( Params::Util::_POSINT({ foo => 1 }), '...::_POSINT(HASH) returns undef' ); null( Params::Util::_POSINT(sub () { 1 }), '...::_POSINT(CODE) returns undef' ); null( Params::Util::_POSINT([]), '...::_POSINT(ARRAY) returns undef' ); null( Params::Util::_POSINT(\""), '...::_POSINT(null constant) returns undef' ); null( Params::Util::_POSINT(\"foo"), '...::_POSINT(SCALAR) returns undef' ); null( Params::Util::_POSINT("D'oh"), '...::_POSINT(bad class) returns undef' ); null( Params::Util::_POSINT(-1), '...::_POSINT(negative) returns undef' ); null( Params::Util::_POSINT(0), '...::_POSINT(zero) returns undef' ); null( Params::Util::_POSINT("+1"), '...::_POSINT(explicit positive) returns undef' ); null( Params::Util::_POSINT("02"), '...::_POSINT(zero lead) returns undef' ); # Test good things against the actual function (carefully) foreach my $id ( qw{1 2 10 123456789} ) { is( Params::Util::_POSINT($id), $id, "...::_POSINT('$id') returns ok" ); } # Import the function use_ok( 'Params::Util', '_POSINT' ); ok( defined *_POSINT{CODE}, '_POSINT imported ok' ); # Test bad things against the actual function dies( "_POSINT()", qr/Not enough arguments/, '_POSINT() dies' ); null( _POSINT(undef), '_POSINT(undef) returns undef' ); null( _POSINT(''), '_POSINT(nullstring) returns undef' ); null( _POSINT(' foo'), '_POSINT(string) returns undef' ); null( _POSINT({ foo => 1 }), '_POSINT(HASH) returns undef' ); null( _POSINT(sub () { 1 }), '_POSINT(CODE) returns undef' ); null( _POSINT([]), '_POSINT(ARRAY) returns undef' ); null( _POSINT(\""), '_POSINT(null constant) returns undef' ); null( _POSINT(\"foo"), '_POSINT(SCALAR) returns undef' ); null( _POSINT("D'oh"), '_POSINT(bad class) returns undef' ); null( _POSINT(-1), '_POSINT(negative) returns undef' ); null( _POSINT(0), '_POSINT(zero) returns undef' ); null( _POSINT("+1"), '_POSINT(explicit positive) returns undef' ); null( _POSINT("02"), '_POSINT(zero lead) returns undef' ); # Test good things against the actual function (carefully) foreach my $id ( qw{1 2 10 123456789} ) { is( _POSINT($id), $id, "_POSINT('$id') returns ok" ); } ##################################################################### # Tests for _NONNEGINT # Test bad things against the actual function dies( "Params::Util::_NONNEGINT()", qr/Not enough arguments/, '...::_NONNEGINT() dies' ); null( Params::Util::_NONNEGINT(undef), '...::_NONNEGINT(undef) returns undef' ); null( Params::Util::_NONNEGINT(''), '...::_NONNEGINT(nullstring) returns undef' ); null( Params::Util::_NONNEGINT(' foo'), '...::_NONNEGINT(string) returns undef' ); null( Params::Util::_NONNEGINT({ foo => 1 }), '...::_NONNEGINT(HASH) returns undef' ); null( Params::Util::_NONNEGINT(sub () { 1 }), '...::_NONNEGINT(CODE) returns undef' ); null( Params::Util::_NONNEGINT([]), '...::_NONNEGINT(ARRAY) returns undef' ); null( Params::Util::_NONNEGINT(\""), '...::_NONNEGINT(null constant) returns undef' ); null( Params::Util::_NONNEGINT(\"foo"), '...::_NONNEGINT(SCALAR) returns undef' ); null( Params::Util::_NONNEGINT("D'oh"), '...::_NONNEGINT(bad class) returns undef' ); null( Params::Util::_NONNEGINT(-1), '...::_NONNEGINT(negative) returns undef' ); null( Params::Util::_NONNEGINT("+1"), '...::_NONNEGINT(explicit positive) returns undef' ); null( Params::Util::_NONNEGINT("02"), '...::_NONNEGINT(zero lead) returns undef' ); # Test good things against the actual function (carefully) foreach my $id ( qw{0 1 2 10 123456789} ) { is( Params::Util::_NONNEGINT($id), $id, "...::_NONNEGINT('$id') returns ok" ); } # Import the function use_ok( 'Params::Util', '_NONNEGINT' ); ok( defined *_NONNEGINT{CODE}, '_NONNEGINT imported ok' ); # Test bad things against the actual function dies( "_NONNEGINT()", qr/Not enough arguments/, '_NONNEGINT() dies' ); null( _NONNEGINT(undef), '_NONNEGINT(undef) returns undef' ); null( _NONNEGINT(''), '_NONNEGINT(nullstring) returns undef' ); null( _NONNEGINT(' foo'), '_NONNEGINT(string) returns undef' ); null( _NONNEGINT({ foo => 1 }), '_NONNEGINT(HASH) returns undef' ); null( _NONNEGINT(sub () { 1 }), '_NONNEGINT(CODE) returns undef' ); null( _NONNEGINT([]), '_NONNEGINT(ARRAY) returns undef' ); null( _NONNEGINT(\""), '_NONNEGINT(null constant) returns undef' ); null( _NONNEGINT(\"foo"), '_NONNEGINT(SCALAR) returns undef' ); null( _NONNEGINT("D'oh"), '_NONNEGINT(bad class) returns undef' ); null( _NONNEGINT(-1), '_NONNEGINT(negative) returns undef' ); null( _NONNEGINT("+1"), '_NONNEGINT(explicit positive) returns undef' ); null( _NONNEGINT("02"), '_NONNEGINT(zero lead) returns undef' ); # Test good things against the actual function (carefully) foreach my $id ( qw{0 1 2 10 123456789} ) { is( _NONNEGINT($id), $id, "_NONNEGINT('$id') returns ok" ); } ##################################################################### # Tests for _SCALAR my $foo = "foo"; my $scalar = \$foo; # Test bad things against the actual function dies( "Params::Util::_SCALAR()", qr/Not enough arguments/, '...::_SCALAR() dies' ); null( Params::Util::_SCALAR(undef), '...::_SCALAR(undef) returns undef' ); null( Params::Util::_SCALAR(\undef), '...::_SCALAR(\undef) returns undef' ); null( Params::Util::_SCALAR(''), '...::_SCALAR(nullstring) returns undef' ); null( Params::Util::_SCALAR(1), '...::_SCALAR(number) returns undef' ); null( Params::Util::_SCALAR('foo'), '...::_SCALAR(string) returns undef' ); null( Params::Util::_SCALAR({ foo => 1 }), '...::_SCALAR(HASH) returns undef' ); null( Params::Util::_SCALAR(sub () { 1 }), '...::_SCALAR(CODE) returns undef' ); null( Params::Util::_SCALAR([]), '...::_SCALAR(ARRAY) returns undef' ); null( Params::Util::_SCALAR(\""), '...::_SCALAR(null constant) returns undef' ); # Test good things against the actual function (carefully) is( ref(Params::Util::_SCALAR(\"foo")), 'SCALAR', '...::_SCALAR(constant) returns true' ); is( ref(Params::Util::_SCALAR($scalar)), 'SCALAR', "...::_SCALAR(['foo']) returns true" ); is( refaddr(Params::Util::_SCALAR($scalar)), refaddr($scalar), '...::_SCALAR returns the same SCALAR reference'); # Import the function use_ok( 'Params::Util', '_SCALAR' ); ok( defined *_SCALAR{CODE}, '_SCALAR imported ok' ); # Test bad things against the imported function dies( "_SCALAR()", qr/Not enough arguments/, '...::_SCALAR() dies' ); null( _SCALAR(undef), '...::_SCALAR(undef) returns undef' ); null( _SCALAR(\undef), '...::_SCALAR(\undef) returns undef' ); null( _SCALAR(''), '...::_SCALAR(nullstring) returns undef' ); null( _SCALAR(1), '...::_SCALAR(number) returns undef' ); null( _SCALAR('foo'), '...::_SCALAR(string) returns undef' ); null( _SCALAR({ foo => 1 }), '...::_SCALAR(HASH) returns undef' ); null( _SCALAR(sub () { 1 }), '...::_SCALAR(CODE) returns undef' ); null( _SCALAR([]), '...::_SCALAR(ARRAY) returns undef' ); null( _SCALAR(\""), '...::_SCALAR(null constant) returns undef' ); # Test good things against the actual function (carefully) is( ref(_SCALAR(\"foo")), 'SCALAR', '...::_SCALAR(constant) returns true' ); is( ref(_SCALAR($scalar)), 'SCALAR', "...::_SCALAR(SCALAR) returns true" ); is( refaddr(_SCALAR($scalar)), refaddr($scalar), '...::_SCALAR returns the same SCALAR reference'); ##################################################################### # Tests for _SCALAR0 my $null = ""; my $scalar0 = \$null; # Test bad things against the actual function dies( "Params::Util::_SCALAR0()", qr/Not enough arguments/, '...::_SCALAR0() dies' ); null( Params::Util::_SCALAR0(undef), '...::_SCALAR0(undef) returns undef' ); null( Params::Util::_SCALAR0(''), '...::_SCALAR0(nullstring) returns undef' ); null( Params::Util::_SCALAR0(1), '...::_SCALAR0(number) returns undef' ); null( Params::Util::_SCALAR0('foo'), '...::_SCALAR0(string) returns undef' ); null( Params::Util::_SCALAR0({ foo => 1 }), '...::_SCALAR0(HASH) returns undef' ); null( Params::Util::_SCALAR0(sub () { 1 }), '...::_SCALAR0(CODE) returns undef' ); null( Params::Util::_SCALAR0([]), '...::_SCALAR0(ARRAY) returns undef' ); # Test good things against the actual function (carefully) is( ref(Params::Util::_SCALAR0(\"foo")), 'SCALAR', '...::_SCALAR0(constant) returns true' ); is( ref(Params::Util::_SCALAR0(\"")), 'SCALAR', '...::_SCALAR0(constant) returns true' ); is( ref(Params::Util::_SCALAR0(\undef)), 'SCALAR', '...::_SCALAR0(\undef) returns true' ); is( ref(Params::Util::_SCALAR0($scalar)), 'SCALAR', "...::_SCALAR0(constant) returns true" ); is( ref(Params::Util::_SCALAR0($scalar0)), 'SCALAR', "...::_SCALAR0(constant) returns true" ); is( refaddr(Params::Util::_SCALAR0($scalar)), refaddr($scalar), '...::_SCALAR returns the same SCALAR reference'); is( refaddr(Params::Util::_SCALAR0($scalar0)), refaddr($scalar0), '...::_SCALAR returns the same SCALAR reference'); # Import the function use_ok( 'Params::Util', '_SCALAR0' ); ok( defined *_SCALAR0{CODE}, '_SCALAR0 imported ok' ); # Test bad things against the imported function dies( "_SCALAR0()", qr/Not enough arguments/, '...::_SCALAR0() dies' ); null( _SCALAR0(undef), '...::_SCALAR0(undef) returns undef' ); null( _SCALAR0(''), '...::_SCALAR0(nullstring) returns undef' ); null( _SCALAR0(1), '...::_SCALAR0(number) returns undef' ); null( _SCALAR0('foo'), '...::_SCALAR0(string) returns undef' ); null( _SCALAR0({ foo => 1 }), '...::_SCALAR0(HASH) returns undef' ); null( _SCALAR0(sub () { 1 }), '...::_SCALAR0(CODE) returns undef' ); null( _SCALAR0([]), '...::_SCALAR0(ARRAY) returns undef' ); # Test good things against the actual function (carefully) is( ref(_SCALAR0(\"foo")), 'SCALAR', '...::_SCALAR0(constant) returns true' ); is( ref(_SCALAR0(\"")), 'SCALAR', '...::_SCALAR0(constant) returns true' ); is( ref(_SCALAR0(\undef)), 'SCALAR', '...::_SCALAR0(\undef) returns true' ); is( ref(_SCALAR0($scalar)), 'SCALAR', "...::_SCALAR0(constant) returns true" ); is( ref(_SCALAR0($scalar0)), 'SCALAR', "...::_SCALAR0(constant) returns true" ); is( refaddr(_SCALAR0($scalar)), refaddr($scalar), '...::_SCALAR returns the same SCALAR reference'); is( refaddr(_SCALAR0($scalar0)), refaddr($scalar0), '...::_SCALAR returns the same SCALAR reference'); ##################################################################### # Tests for _ARRAY my $array = [ 'foo', 'bar' ]; # Test bad things against the actual function dies( "Params::Util::_ARRAY()", qr/Not enough arguments/, '...::_ARRAY() dies' ); null( Params::Util::_ARRAY(undef), '...::_ARRAY(undef) returns undef' ); null( Params::Util::_ARRAY(''), '...::_ARRAY(nullstring) returns undef' ); null( Params::Util::_ARRAY(1), '...::_ARRAY(number) returns undef' ); null( Params::Util::_ARRAY('foo'), '...::_ARRAY(string) returns undef' ); null( Params::Util::_ARRAY(\'foo'), '...::_ARRAY(SCALAR) returns undef' ); null( Params::Util::_ARRAY({ foo => 1 }), '...::_ARRAY(HASH) returns undef' ); null( Params::Util::_ARRAY(sub () { 1 }), '...::_ARRAY(CODE) returns undef' ); null( Params::Util::_ARRAY([]), '...::_ARRAY(empty ARRAY) returns undef' ); # Test good things against the actual function (carefully) is( ref(Params::Util::_ARRAY([ undef ])), 'ARRAY', '...::_ARRAY([undef]) returns true' ); is( ref(Params::Util::_ARRAY([ 'foo' ])), 'ARRAY', "...::_ARRAY(['foo']) returns true" ); is( ref(Params::Util::_ARRAY($array)), 'ARRAY', '...::_ARRAY returns an ARRAY ok' ); is( refaddr(Params::Util::_ARRAY($array)), refaddr($array), '...::_ARRAY($array) returns the same ARRAY reference'); # Import the function use_ok( 'Params::Util', '_ARRAY' ); ok( defined *_ARRAY{CODE}, '_ARRAY imported ok' ); # Test bad things against the actual function dies( "_ARRAY();", qr/Not enough arguments/, '_ARRAY() dies' ); null( _ARRAY(undef), '_ARRAY(undef) returns undef' ); null( _ARRAY(''), '_ARRAY(nullstring) returns undef' ); null( _ARRAY(1), '_ARRAY(number) returns undef' ); null( _ARRAY('foo'), '_ARRAY(string) returns undef' ); null( _ARRAY(\'foo'), '_ARRAY(SCALAR) returns undef' ); null( _ARRAY({ foo => 1 }), '_ARRAY(HASH) returns undef' ); null( _ARRAY(sub () { 1 }), '_ARRAY(CODE) returns undef' ); null( _ARRAY([]), '_ARRAY(empty ARRAY) returns undef' ); # Test good things against the actual function (carefully) is( ref(_ARRAY([ undef ])), 'ARRAY', '_ARRAY([undef]) returns true' ); is( ref(_ARRAY([ 'foo' ])), 'ARRAY', "_ARRAY(['foo']) returns true" ); is( ref(_ARRAY($array)), 'ARRAY', '_ARRAY returns an ARRAY ok' ); is( refaddr(_ARRAY($array)), refaddr($array), '_ARRAY($array) returns the same ARRAY reference'); ##################################################################### # Tests for _ARRAY0 # Test bad things against the actual function dies( "Params::Util::_ARRAY0();", qr/Not enough arguments/, '...::_ARRAY0() dies' ); null( Params::Util::_ARRAY0(undef), '...::_ARRAY0(undef) returns undef' ); null( Params::Util::_ARRAY0(''), '...::_ARRAY0(nullstring) returns undef' ); null( Params::Util::_ARRAY0(1), '...::_ARRAY0(number) returns undef' ); null( Params::Util::_ARRAY0('foo'), '...::_ARRAY0(string) returns undef' ); null( Params::Util::_ARRAY0(\'foo'), '...::_ARRAY0(SCALAR) returns undef' ); null( Params::Util::_ARRAY0({ foo => 1 }), '...::_ARRAY0(HASH) returns undef' ); null( Params::Util::_ARRAY0(sub () { 1 }), '...::_ARRAY0(CODE) returns undef' ); # Test good things against the actual function (carefully) is( ref(Params::Util::_ARRAY0([])), 'ARRAY', '...::_ARRAY0(empty ARRAY) returns undef' ); is( ref(Params::Util::_ARRAY0([ undef ])), 'ARRAY', '...::_ARRAY0([undef]) returns true' ); is( ref(Params::Util::_ARRAY0([ 'foo' ])), 'ARRAY', "...::_ARRAY0(['foo']) returns true" ); is( ref(Params::Util::_ARRAY0($array)), 'ARRAY', '...::_ARRAY0 returns an ARRAY ok' ); is( refaddr(Params::Util::_ARRAY0($array)), refaddr($array), '...::_ARRAY0($array) returns the same ARRAY reference'); # Import the function use_ok( 'Params::Util', '_ARRAY0' ); ok( defined *_ARRAY0{CODE}, '_ARRAY0 imported ok' ); # Test bad things against the actual function dies( "_ARRAY0();", qr/Not enough arguments/, '_ARRAY0() dies' ); null( _ARRAY0(undef), '_ARRAY0(undef) returns undef' ); null( _ARRAY0(''), '_ARRAY0(nullstring) returns undef' ); null( _ARRAY0(1), '_ARRAY0(number) returns undef' ); null( _ARRAY0('foo'), '_ARRAY0(string) returns undef' ); null( _ARRAY0(\'foo'), '_ARRAY0(SCALAR) returns undef' ); null( _ARRAY0({ foo => 1 }), '_ARRAY0(HASH) returns undef' ); null( _ARRAY0(sub () { 1 }), '_ARRAY0(CODE) returns undef' ); # Test good things against the actual function (carefully) is( ref(_ARRAY0([])), 'ARRAY', '_ARRAY0(empty ARRAY) returns undef' ); is( ref(_ARRAY0([ undef ])), 'ARRAY', '_ARRAY0([undef]) returns true' ); is( ref(_ARRAY0([ 'foo' ])), 'ARRAY', "_ARRAY0(['foo']) returns true" ); is( ref(_ARRAY0($array)), 'ARRAY', '_ARRAY0 returns an ARRAY ok' ); is( refaddr(_ARRAY0($array)), refaddr($array), '_ARRAY0($array) returns the same reference'); ##################################################################### # Tests for _HASH my $hash = { 'foo' => 'bar' }; # Test bad things against the actual function dies( "Params::Util::_HASH();", qr/Not enough arguments/, '...::_HASH() dies' ); null( Params::Util::_HASH(undef), '...::_HASH(undef) returns undef' ); null( Params::Util::_HASH(''), '...::_HASH(nullstring) returns undef' ); null( Params::Util::_HASH(1), '...::_HASH(number) returns undef' ); null( Params::Util::_HASH('foo'), '...::_HASH(string) returns undef' ); null( Params::Util::_HASH(\'foo'), '...::_HASH(SCALAR) returns undef' ); null( Params::Util::_HASH([ 'foo' ]), '...::_HASH(ARRAY) returns undef' ); null( Params::Util::_HASH(sub () { 1 }), '...::_HASH(CODE) returns undef' ); null( Params::Util::_HASH({}), '...::_HASH(empty HASH) returns undef' ); # Test good things against the actual function (carefully) is( ref(Params::Util::_HASH({ foo => 1 })), 'HASH', '...::_HASH([undef]) returns ok' ); is( ref(Params::Util::_HASH($hash)), 'HASH', '...::_HASH returns an HASH ok' ); is( refaddr(Params::Util::_HASH($hash)), refaddr($hash), '...::_HASH($hash) returns the same reference', ); # Import the function use_ok( 'Params::Util', '_HASH' ); ok( defined *_HASH{CODE}, '_HASH imported ok' ); # Test bad things against the actual function dies( "_HASH();", qr/Not enough arguments/, '_HASH() dies' ); null( _HASH(undef), '_HASH(undef) returns undef' ); null( _HASH(''), '_HASH(nullstring) returns undef' ); null( _HASH(1), '_HASH(number) returns undef' ); null( _HASH('foo'), '_HASH(string) returns undef' ); null( _HASH(\'foo'), '_HASH(SCALAR) returns undef' ); null( _HASH([]), '_HASH(ARRAY) returns undef' ); null( _HASH(sub () { 1 }), '_HASH(CODE) returns undef' ); null( _HASH({}), '...::_HASH(empty HASH) returns undef' ); # Test good things against the actual function (carefully) is( ref(_HASH({ foo => 1 })), 'HASH', '_HASH([undef]) returns true' ); is( ref(_HASH($hash)), 'HASH', '_HASH returns an ARRAY ok' ); is( refaddr(_HASH($hash)), refaddr($hash), '_HASH($hash) returns the same reference', ); ##################################################################### # Tests for _HASH0 # Test bad things against the actual function dies( "Params::Util::_HASH0();", qr/Not enough arguments/, '...::_HASH0() dies' ); null( Params::Util::_HASH0(undef), '...::_HASH0(undef) returns undef' ); null( Params::Util::_HASH0(''), '...::_HASH0(nullstring) returns undef' ); null( Params::Util::_HASH0(1), '...::_HASH0(number) returns undef' ); null( Params::Util::_HASH0('foo'), '...::_HASH0(string) returns undef' ); null( Params::Util::_HASH0(\'foo'), '...::_HASH0(SCALAR) returns undef' ); null( Params::Util::_HASH0([ 'foo' ]), '...::_HASH0(ARRAY) returns undef' ); null( Params::Util::_HASH0(sub () { 1 }), '...::_HASH0(CODE) returns undef' ); # Test good things against the actual function (carefully) is( ref(Params::Util::_HASH0({})), 'HASH', '...::_HASH0(empty ARRAY) returns undef' ); is( ref(Params::Util::_HASH0({ foo => 1 })), 'HASH', '...::_HASH0([undef]) returns true' ); is( ref(Params::Util::_HASH0($hash)), 'HASH', '...::_HASH0 returns an ARRAY ok' ); is( refaddr(Params::Util::_HASH0($hash)), refaddr($hash), '...::_HASH0($hash) returns the same reference', ); # Import the function use_ok( 'Params::Util', '_HASH0' ); ok( defined *_HASH0{CODE}, '_HASH0 imported ok' ); # Test bad things against the actual function dies( "_HASH0();", qr/Not enough arguments/, '_HASH0() dies' ); null( _HASH0(undef), '_HASH0(undef) returns undef' ); null( _HASH0(''), '_HASH0(nullstring) returns undef' ); null( _HASH0(1), '_HASH0(number) returns undef' ); null( _HASH0('foo'), '_HASH0(string) returns undef' ); null( _HASH0(\'foo'), '_HASH0(SCALAR) returns undef' ); null( _HASH0([]), '_HASH0(ARRAY) returns undef' ); null( _HASH0(sub () { 1 }), '_HASH0(CODE) returns undef' ); # Test good things against the actual function (carefully) is( ref(_HASH0({})), 'HASH', '_HASH0(empty ARRAY) returns undef' ); is( ref(_HASH0({ foo => 1 })), 'HASH', '_HASH0([undef]) returns true' ); is( ref(_HASH0($hash)), 'HASH', '_HASH0 returns an ARRAY ok' ); is( refaddr(_HASH0($hash)), refaddr($hash), '_HASH0($hash) returns the same reference', ); ##################################################################### # Tests for _CODE my $code = sub () { 1 }; sub testcode { 3 }; # Import the function use_ok( 'Params::Util', '_CODE' ); ok( defined *_CODE{CODE}, '_CODE imported ok' ); # Test bad things against the actual function dies( "Params::Util::_CODE();", qr/Not enough arguments/, '...::_CODE() dies' ); null( Params::Util::_CODE(undef), '...::_CODE(undef) returns undef' ); null( Params::Util::_CODE(''), '...::_CODE(nullstring) returns undef' ); null( Params::Util::_CODE(1), '...::_CODE(number) returns undef' ); null( Params::Util::_CODE('foo'), '...::_CODE(string) returns undef' ); null( Params::Util::_CODE(\'foo'), '...::_CODE(SCALAR) returns undef' ); null( Params::Util::_CODE([ 'foo' ]), '...::_CODE(ARRAY) returns undef' ); null( Params::Util::_CODE({}), '...::_CODE(empty HASH) returns undef' ); # Test bad things against the actual function dies( "_CODE();", qr/Not enough arguments/, '_CODE() dies' ); null( _CODE(undef), '_CODE(undef) returns undef' ); null( _CODE(''), '_CODE(nullstring) returns undef' ); null( _CODE(1), '_CODE(number) returns undef' ); null( _CODE('foo'), '_CODE(string) returns undef' ); null( _CODE(\'foo'), '_CODE(SCALAR) returns undef' ); null( _CODE([]), '_CODE(ARRAY) returns undef' ); null( _CODE({}), '...::_CODE(empty HASH) returns undef' ); # Test good things against the actual function is( ref(Params::Util::_CODE(sub { 2 })), 'CODE', '...::_CODE(anon) returns ok' ); is( ref(Params::Util::_CODE($code)), 'CODE', '...::_CODE(ref) returns ok' ); is( ref(Params::Util::_CODE(\&testsub)), 'CODE', '...::_CODE(\&func) returns ok' ); is( refaddr(Params::Util::_CODE($code)), refaddr($code), '...::_CODE(ref) returns the same reference'); is( refaddr(Params::Util::_CODE(\&testsub)), refaddr(\&testsub), '...::_CODE(\&func) returns the same reference'); # Test good things against the imported function is( ref(_CODE(sub { 2 })), 'CODE', '_CODE(anon) returns ok' ); is( ref(_CODE($code)), 'CODE', '_CODE(ref) returns ok' ); is( ref(_CODE(\&testsub)), 'CODE', '_CODE(\&func) returns ok' ); is( refaddr(_CODE($code)), refaddr($code), '_CODE(ref) returns the same reference'); is( refaddr(_CODE(\&testsub)), refaddr(\&testsub), '_CODE(\&func) returns the same reference'); ##################################################################### # Tests for _INSTANCE my $s1 = "foo"; my $s2 = "bar"; my $s3 = "baz"; my $scalar1 = \$s1; my $scalar2 = \$s2; my $scalar3 = \$s3; my @objects = ( bless( {}, 'Foo'), bless( [], 'Foo'), bless( $scalar1, 'Foo'), bless( {}, 'Bar'), bless( [], 'Bar'), bless( $scalar1, 'Bar'), bless( {}, 'Baz'), bless( [], 'Baz'), bless( $scalar3, 'Baz'), ); # Test bad things against the actual function dies( "Params::Util::_INSTANCE()", qr/Not enough arguments/, '...::_INSTANCE() dies' ); dies( "Params::Util::_INSTANCE(bless {}, 'Foo')", qr/Not enough arguments/, '...::_INSTANCE(object) dies' ); null( Params::Util::_INSTANCE(undef, 'Foo'), '...::_INSTANCE(undef) returns undef' ); null( Params::Util::_INSTANCE('', 'Foo'), '...::_INSTANCE(nullstring) returns undef' ); null( Params::Util::_INSTANCE(1, 'Foo'), '...::_INSTANCE(number) returns undef' ); null( Params::Util::_INSTANCE('foo', 'Foo'), '...::_INSTANCE(string) returns undef' ); null( Params::Util::_INSTANCE({ foo => 1 }, 'Foo'), '...::_INSTANCE(HASH) returns undef' ); null( Params::Util::_INSTANCE(sub () { 1 }, 'Foo'), '...::_INSTANCE(CODE) returns undef' ); null( Params::Util::_INSTANCE([], 'Foo'), '...::_INSTANCE(ARRAY) returns undef' ); null( Params::Util::_INSTANCE(\"", 'Foo'), '...::_INSTANCE(null constant) returns undef' ); null( Params::Util::_INSTANCE(\"foo", 'Foo'), '...::_INSTANCE(SCALAR) returns undef' ); null( Params::Util::_INSTANCE(bless({},'Bad'), 'Foo'), '...::_INSTANCE(bad object) returns undef' ); # Import the function use_ok( 'Params::Util', '_INSTANCE' ); ok( defined *_INSTANCE{CODE}, '_INSTANCE imported ok' ); # Test bad things against the actual function dies( "_INSTANCE()", qr/Not enough arguments/, '_INSTANCE() dies' ); dies( "_INSTANCE(bless {}, 'Foo')", qr/Not enough arguments/, '_INSTANCE(object) dies' ); null( _INSTANCE(undef, 'Foo'), '_INSTANCE(undef) returns undef' ); null( _INSTANCE('', 'Foo'), '_INSTANCE(nullstring) returns undef' ); null( _INSTANCE(1, 'Foo'), '_INSTANCE(number) returns undef' ); null( _INSTANCE('foo', 'Foo'), '_INSTANCE(string) returns undef' ); null( _INSTANCE({ foo => 1 }, 'Foo'), '_INSTANCE(HASH) returns undef' ); null( _INSTANCE(sub () { 1 }, 'Foo'), '_INSTANCE(CODE) returns undef' ); null( _INSTANCE([], 'Foo'), '_INSTANCE(ARRAY) returns undef' ); null( _INSTANCE(\"", 'Foo'), '_INSTANCE(null constant) returns undef' ); null( _INSTANCE(\"foo", 'Foo'), '_INSTANCE(SCALAR) returns undef' ); null( _INSTANCE(bless({},'Bad'), 'Foo'), '_INSTANCE(bad object) returns undef' ); # Testing good things is a little more complicated in this case, # so lets do the basic ones first. foreach my $object ( @objects ) { ok( Params::Util::_INSTANCE($object, 'Foo'), '...::_INSTANCE(object, class) returns true when expected' ); is( refaddr(Params::Util::_INSTANCE($object, 'Foo')), refaddr($object), '...::_INSTANCE(object, class) returns the same object' ); } # Testing good things is a little more complicated in this case, # so lets do the basic ones first. foreach my $object ( @objects ) { ok( _INSTANCE($object, 'Foo'), '_INSTANCE(object, class) returns true when expected' ); is( refaddr(_INSTANCE($object, 'Foo')), refaddr($object), '_INSTANCE(object, class) returns the same object' ); } SKIP: { use_ok( 'Params::Util', '_INSTANCEDOES' ); skip "DOES tests do not make sense on perls before 5.10", 19 unless $] >= 5.010; null( _INSTANCEDOES(bless({},'Bad'), 'Foo'), '_INSTANCEDOES(bad object) returns undef' ); foreach my $object ( @objects ) { ok( _INSTANCEDOES($object, 'Foo'), '_INSTANCEDOES(object, class) returns true when expected' ); is( refaddr(_INSTANCEDOES($object, 'Foo')), refaddr($object), '_INSTANCEDOES(object, class) returns the same object' ); } } ##################################################################### # Tests for _REGEX # Test bad things against the actual function dies( "Params::Util::_REGEX();", qr/Not enough arguments/, '...::_REGEX() dies' ); null( Params::Util::_REGEX(undef), '...::_REGEX(undef) returns undef' ); null( Params::Util::_REGEX(''), '...::_REGEX(STRING0) returns undef' ); null( Params::Util::_REGEX(1), '...::_REGEX(number) returns undef' ); null( Params::Util::_REGEX('foo'), '...::_REGEX(string) returns undef' ); null( Params::Util::_REGEX(\'foo'), '...::_REGEX(SCALAR) returns undef' ); null( Params::Util::_REGEX([ 'foo' ]), '...::_REGEX(ARRAY) returns undef' ); null( Params::Util::_REGEX(sub () { 1 }), '...::_REGEX(CODE) returns undef' ); null( Params::Util::_REGEX({}), '...::_REGEX(HASH0) returns undef' ); null( Params::Util::_REGEX({ foo => 1 }), '...::_REGEX(HASH) returns undef' ); ok( Params::Util::_REGEX(qr//), '...::_REGEX(qr//) ok' ); ok( Params::Util::_REGEX(qr/foo/), '...::_REGEX(qr//) ok' ); # Import the function use_ok( 'Params::Util', '_REGEX' ); ok( defined *_REGEX{CODE}, '_REGEX imported ok' ); # Test bad things against the actual function dies( "_REGEX();", qr/Not enough arguments/, '_REGEX() dies' ); null( _REGEX(undef), '_REGEX(undef) returns undef' ); null( _REGEX(''), '_REGEX(STRING0) returns undef' ); null( _REGEX(1), '_REGEX(number) returns undef' ); null( _REGEX('foo'), '_REGEX(string) returns undef' ); null( _REGEX(\'foo'), '_REGEX(SCALAR) returns undef' ); null( _REGEX([]), '_REGEX(ARRAY) returns undef' ); null( _REGEX(sub () { 1 }), '_REGEX(CODE) returns undef' ); null( _REGEX({}), 'REGEX(HASH0) returns undef' ); null( _REGEX({ foo => 1 }), 'REGEX(HASH) returns undef' ); ok( _REGEX(qr//), '_REGEX(qr//) ok' ); ok( _REGEX(qr/foo/), '_REGEX(qr//) ok' ); ##################################################################### # Tests for _SET my %set = ( good => [ map { bless {} => 'Foo' } qw(1..3) ], mixed => [ map { bless {} => "Foo$_" } qw(1..3) ], unblessed => [ map { {} } qw(1..3) ], ); # Test bad things against the actual function dies( "Params::Util::_SET()", qr/Not enough arguments/, '...::_SET() dies' ); dies( "Params::Util::_SET([])", qr/Not enough arguments/, '...::_SET(single) dies' ); null( Params::Util::_SET(undef, 'Foo'), '...::_SET(undef) returns undef' ); null( Params::Util::_SET('', 'Foo'), '...::_SET(nullstring) returns undef' ); null( Params::Util::_SET(1, 'Foo'), '...::_SET(number) returns undef' ); null( Params::Util::_SET('foo', 'Foo'), '...::_SET(string) returns undef' ); null( Params::Util::_SET(\'foo', 'Foo'), '...::_SET(SCALAR) returns undef' ); null( Params::Util::_SET({ foo => 1 }, 'Foo'), '...::_SET(HASH) returns undef' ); null( Params::Util::_SET(sub () { 1 }, 'Foo'), '...::_SET(CODE) returns undef' ); null( Params::Util::_SET([], 'Foo'), '...::_SET(empty ARRAY) returns undef' ); ok( Params::Util::_SET($set{good}, 'Foo'), '...::_SET(homogenous ARRAY) returns true' ); null( Params::Util::_SET($set{mixed}, 'Foo'), '...::_SET(mixed ARRAY) returns undef' ); null( Params::Util::_SET($set{unblessed}, 'Foo'), '...::_SET(unblessed ARRAY) returns undef' ); # Import the function use_ok( 'Params::Util', '_SET' ); ok( defined *_SET{CODE}, '_SET imported ok' ); # Test bad things against the actual function dies( "_SET()", qr/Not enough arguments/, '_SET() dies' ); dies( "_SET([])", qr/Not enough arguments/, '_SET(single) dies' ); null( _SET(undef, 'Foo'), '_SET(undef) returns undef' ); null( _SET('', 'Foo'), '_SET(nullstring) returns undef' ); null( _SET(1, 'Foo'), '_SET(number) returns undef' ); null( _SET('foo', 'Foo'), '_SET(string) returns undef' ); null( _SET(\'foo', 'Foo'), '_SET(SCALAR) returns undef' ); null( _SET({ foo => 1 }, 'Foo'), '_SET(HASH) returns undef' ); null( _SET(sub () { 1 }, 'Foo'), '_SET(CODE) returns undef' ); null( _SET([], 'Foo'), '_SET(empty ARRAY) returns undef' ); ok( _SET($set{good}, 'Foo'), '_SET(homogenous ARRAY) returns true'); null( _SET($set{mixed}, 'Foo'), '_SET(mixed ARRAY) returns undef'); null( _SET($set{unblessed}, 'Foo'), '_SET(unblessed ARRAY) returns undef'); ##################################################################### # Tests for _SET0 # Test bad things against the actual function dies( "Params::Util::_SET0()", qr/Not enough arguments/, '...::_SET0() dies' ); dies( "Params::Util::_SET0([])", qr/Not enough arguments/, '...::_SET0(single) dies' ); null( Params::Util::_SET0(undef, 'Foo'), '...::_SET0(undef) returns undef' ); null( Params::Util::_SET0('', 'Foo'), '...::_SET0(nullstring) returns undef' ); null( Params::Util::_SET0(1, 'Foo'), '...::_SET0(number) returns undef' ); null( Params::Util::_SET0('foo', 'Foo'), '...::_SET0(string) returns undef' ); null( Params::Util::_SET0(\'foo', 'Foo'), '...::_SET0(SCALAR) returns undef' ); null( Params::Util::_SET0({ foo => 1 }, 'Foo'), '...::_SET0(HASH) returns undef' ); null( Params::Util::_SET0(sub () { 1 }, 'Foo'), '...::_SET0(CODE) returns undef' ); ok( Params::Util::_SET0([], 'Foo'), '...::_SET0(empty ARRAY) returns true' ); ok( Params::Util::_SET0($set{good}, 'Foo'), '...::_SET0(homogenous ARRAY) returns true' ); null( Params::Util::_SET0($set{mixed}, 'Foo'), '...::_SET0(mixed ARRAY) returns undef' ); null( Params::Util::_SET0($set{unblessed}, 'Foo'), '...::_SET0(unblessed ARRAY) returns undef' ); # Import the function use_ok( 'Params::Util', '_SET0' ); ok( defined *_SET0{CODE}, '_SET0 imported ok' ); # Test bad things against the actual function dies( "_SET0()", qr/Not enough arguments/, '_SET0() dies' ); dies( "_SET0([])", qr/Not enough arguments/, '_SET0(single) dies' ); null( _SET0(undef, 'Foo'), '_SET0(undef) returns undef' ); null( _SET0('', 'Foo'), '_SET0(nullstring) returns undef' ); null( _SET0(1, 'Foo'), '_SET0(number) returns undef' ); null( _SET0('foo', 'Foo'), '_SET0(string) returns undef' ); null( _SET0(\'foo', 'Foo'), '_SET0(SCALAR) returns undef' ); null( _SET0({ foo => 1 }, 'Foo'), '_SET0(HASH) returns undef' ); null( _SET0(sub () { 1 }, 'Foo'), '_SET0(CODE) returns undef' ); ok( _SET0([], 'Foo'), '_SET0(empty ARRAY) returns true' ); ok( _SET0($set{good}, 'Foo'), '_SET0(homogenous ARRAY) returns true' ); null( _SET0($set{mixed}, 'Foo'), '_SET0(mixed ARRAY) returns undef' ); null( _SET0($set{unblessed}, 'Foo'), '_SET0(unblessed ARRAY) returns undef' ); exit(0); # Base class package Foo; sub foo { 1 } # Normal inheritance package Bar; use vars qw{@ISA}; BEGIN { @ISA = 'Foo'; } # Coded isa package Baz; sub isa { return 1 if $_[1] eq 'Foo'; shift->SUPER::isa(@_); } # Not a subclass package Bad; sub bad { 1 } 1; Params-Util-1.07/t/02_main.t0000644000175100017510000012556211726772122014066 0ustar adamadam#!/usr/bin/perl use strict; BEGIN { $| = 1; $^W = 1; $ENV{PERL_PARAMS_UTIL_PP} ||= 0; } use Test::More tests => 632; use File::Spec::Functions ':ALL'; use Scalar::Util 'refaddr'; use Params::Util (); # Utility functions sub true { is( shift, 1, shift || () ) } sub false { is( shift, '', shift || () ) } sub null { is( shift, undef, shift || () ) } sub dies { my ($code, $regexp, $message) = @_; eval "$code"; ok( (defined($@) and length($@)), $message ); if ( defined $regexp ) { like( $@, $regexp, '... with expected error message' ); } } ##################################################################### # Tests for _STRING # Test bad things against the actual function dies( "Params::Util::_STRING()", qr/Not enough arguments/, '...::_STRING() dies' ); null( Params::Util::_STRING(undef), '...::_STRING(undef) returns undef' ); null( Params::Util::_STRING(''), '...::_STRING(nullstring) returns undef' ); null( Params::Util::_STRING({ foo => 1 }), '...::_STRING(HASH) returns undef' ); null( Params::Util::_STRING(sub () { 1 }), '...::_STRING(CODE) returns undef' ); null( Params::Util::_STRING([]), '...::_STRING(ARRAY) returns undef' ); null( Params::Util::_STRING(\""), '...::_STRING(null constant) returns undef' ); null( Params::Util::_STRING(\"foo"), '...::_STRING(SCALAR) returns undef' ); # Test good things against the actual function (carefully) foreach my $ident ( qw{0 1 foo _foo foo1 __foo_1 Foo::Bar}, ' ', ' foo' ) { is( Params::Util::_STRING($ident), $ident, "...::_STRING('$ident') returns ok" ); } # Import the function use_ok( 'Params::Util', '_STRING' ); ok( defined *_STRING{CODE}, '_STRING imported ok' ); # Test bad things against the actual function dies( "_STRING()", qr/Not enough arguments/, '...::_STRING() dies' ); null( _STRING(undef), '_STRING(undef) returns undef' ); null( _STRING(''), '_STRING(nullstring) returns undef' ); null( _STRING({ foo => 1 }), '_STRING(HASH) returns undef' ); null( _STRING(sub () { 1 }), '_STRING(CODE) returns undef' ); null( _STRING([]), '_STRING(ARRAY) returns undef' ); null( _STRING(\""), '_STRING(null constant) returns undef' ); null( _STRING(\"foo"), '_STRING(SCALAR) returns undef' ); # Test good things against the actual function (carefully) foreach my $ident ( qw{0 1 foo _foo foo1 __foo_1 Foo::Bar}, ' ', ' foo' ) { is( _STRING($ident), $ident, "...::_STRING('$ident') returns ok" ); } ##################################################################### # Tests for _IDENTIFIER # Test bad things against the actual function dies( "Params::Util::_IDENTIFIER()", qr/Not enough arguments/, '...::_IDENTIFIER() dies' ); null( Params::Util::_IDENTIFIER(undef), '...::_IDENTIFIER(undef) returns undef' ); null( Params::Util::_IDENTIFIER(''), '...::_IDENTIFIER(nullstring) returns undef' ); null( Params::Util::_IDENTIFIER(1), '...::_IDENTIFIER(number) returns undef' ); null( Params::Util::_IDENTIFIER(' foo'), '...::_IDENTIFIER(string) returns undef' ); null( Params::Util::_IDENTIFIER({ foo => 1 }), '...::_IDENTIFIER(HASH) returns undef' ); null( Params::Util::_IDENTIFIER(sub () { 1 }), '...::_IDENTIFIER(CODE) returns undef' ); null( Params::Util::_IDENTIFIER([]), '...::_IDENTIFIER(ARRAY) returns undef' ); null( Params::Util::_IDENTIFIER(\""), '...::_IDENTIFIER(null constant) returns undef' ); null( Params::Util::_IDENTIFIER(\"foo"), '...::_IDENTIFIER(SCALAR) returns undef' ); null( Params::Util::_IDENTIFIER("Foo::Bar"), '...::_IDENTIFIER(CLASS) returns undef' ); null( Params::Util::_IDENTIFIER("foo\n"), '...::_IDENTIFIER(BAD) returns undef' ); # Test good things against the actual function (carefully) foreach my $ident ( qw{foo _foo foo1 __foo_1} ) { is( Params::Util::_IDENTIFIER($ident), $ident, "...::_IDENTIFIER('$ident') returns ok" ); } # Import the function use_ok( 'Params::Util', '_IDENTIFIER' ); ok( defined *_IDENTIFIER{CODE}, '_IDENTIFIER imported ok' ); # Test bad things against the actual function dies( "_IDENTIFIER()", qr/Not enough arguments/, '...::_IDENTIFIER() dies' ); null( _IDENTIFIER(undef), '_IDENTIFIER(undef) returns undef' ); null( _IDENTIFIER(''), '_IDENTIFIER(nullstring) returns undef' ); null( _IDENTIFIER(1), '_IDENTIFIER(number) returns undef' ); null( _IDENTIFIER(' foo'), '_IDENTIFIER(string) returns undef' ); null( _IDENTIFIER({ foo => 1 }), '_IDENTIFIER(HASH) returns undef' ); null( _IDENTIFIER(sub () { 1 }), '_IDENTIFIER(CODE) returns undef' ); null( _IDENTIFIER([]), '_IDENTIFIER(ARRAY) returns undef' ); null( _IDENTIFIER(\""), '_IDENTIFIER(null constant) returns undef' ); null( _IDENTIFIER(\"foo"), '_IDENTIFIER(SCALAR) returns undef' ); null( _IDENTIFIER("Foo::Bar"), '_IDENTIFIER(CLASS) returns undef' ); null( _IDENTIFIER("foo\n"), '_IDENTIFIER(BAD) returns undef' ); # Test good things against the actual function (carefully) foreach my $ident ( qw{foo _foo foo1 __foo_1} ) { is( _IDENTIFIER($ident), $ident, "...::_IDENTIFIER('$ident') returns ok" ); } ##################################################################### # Tests for _CLASS # Test bad things against the actual function dies( "Params::Util::_CLASS()", qr/Not enough arguments/, '...::_CLASS() dies' ); null( Params::Util::_CLASS(undef), '...::_CLASS(undef) returns undef' ); null( Params::Util::_CLASS(''), '...::_CLASS(nullstring) returns undef' ); null( Params::Util::_CLASS(1), '...::_CLASS(number) returns undef' ); null( Params::Util::_CLASS(' foo'), '...::_CLASS(string) returns undef' ); null( Params::Util::_CLASS({ foo => 1 }), '...::_CLASS(HASH) returns undef' ); null( Params::Util::_CLASS(sub () { 1 }), '...::_CLASS(CODE) returns undef' ); null( Params::Util::_CLASS([]), '...::_CLASS(ARRAY) returns undef' ); null( Params::Util::_CLASS(\""), '...::_CLASS(null constant) returns undef' ); null( Params::Util::_CLASS(\"foo"), '...::_CLASS(SCALAR) returns undef' ); null( Params::Util::_CLASS("D'oh"), '...::_CLASS(bad class) returns undef' ); null( Params::Util::_CLASS("::Foo"), '...::_CLASS(bad class) returns undef' ); null( Params::Util::_CLASS("1::X"), '...::_CLASS(bad class) returns undef' ); # Test good things against the actual function (carefully) foreach my $ident ( qw{foo _foo foo1 __foo_1 Foo::Bar _Foo::Baaar::Baz X::1} ) { is( Params::Util::_CLASS($ident), $ident, "...::_CLASS('$ident') returns ok" ); } # Import the function use_ok( 'Params::Util', '_CLASS' ); ok( defined *_CLASS{CODE}, '_CLASS imported ok' ); # Test bad things against the actual function dies( "_CLASS()", qr/Not enough arguments/, '_CLASS() dies' ); null( _CLASS(undef), '_CLASS(undef) returns undef' ); null( _CLASS(''), '_CLASS(nullstring) returns undef' ); null( _CLASS(1), '_CLASS(number) returns undef' ); null( _CLASS(' foo'), '_CLASS(string) returns undef' ); null( _CLASS({ foo => 1 }), '_CLASS(HASH) returns undef' ); null( _CLASS(sub () { 1 }), '_CLASS(CODE) returns undef' ); null( _CLASS([]), '_CLASS(ARRAY) returns undef' ); null( _CLASS(\""), '_CLASS(null constant) returns undef' ); null( _CLASS(\"foo"), '_CLASS(SCALAR) returns undef' ); null( _CLASS("D'oh"), '_CLASS(bad class) returns undef' ); null( _CLASS("::Foo"), '_CLASS(bad class) returns undef' ); null( _CLASS("1::X"), '_CLASS(bad class) returns undef' ); # Test good things against the actual function (carefully) foreach my $ident ( qw{foo _foo foo1 __foo_1 Foo::Bar _Foo::Baaar::Baz X::1} ) { is( _CLASS($ident), $ident, "_CLASS('$ident') returns ok" ); } ##################################################################### # Tests for _NUMBER # Test bad things against the actual function dies( "Params::Util::_NUMBER()", qr/Not enough arguments/, '...::_NUMBER() dies' ); null( Params::Util::_NUMBER(undef), '...::_NUMBER(undef) returns undef' ); null( Params::Util::_NUMBER(''), '...::_NUMBER(nullstring) returns undef' ); null( Params::Util::_NUMBER(' foo'), '...::_NUMBER(string) returns undef' ); null( Params::Util::_NUMBER({ foo => 1 }), '...::_NUMBER(HASH) returns undef' ); null( Params::Util::_NUMBER(sub () { 1 }), '...::_NUMBER(CODE) returns undef' ); null( Params::Util::_NUMBER([]), '...::_NUMBER(ARRAY) returns undef' ); null( Params::Util::_NUMBER(\""), '...::_NUMBER(null constant) returns undef' ); null( Params::Util::_NUMBER(\"foo"), '...::_NUMBER(SCALAR) returns undef' ); null( Params::Util::_NUMBER("D'oh"), '...::_NUMBER(bad class) returns undef' ); # Test good things against the actual function (carefully) foreach my $id ( qw{1 2 10 123456789 -1 0 +1 02 .1 0.013e-3 1e1} ) { is( Params::Util::_NUMBER($id), $id, "...::_NUMBER('$id') returns ok" ); } # Import the function use_ok( 'Params::Util', '_NUMBER' ); ok( defined *_NUMBER{CODE}, '_NUMBER imported ok' ); # Test bad things against the actual function dies( "_NUMBER()", qr/Not enough arguments/, '_NUMBER() dies' ); null( _NUMBER(undef), '_NUMBER(undef) returns undef' ); null( _NUMBER(''), '_NUMBER(nullstring) returns undef' ); null( _NUMBER(' foo'), '_NUMBER(string) returns undef' ); null( _NUMBER({ foo => 1 }), '_NUMBER(HASH) returns undef' ); null( _NUMBER(sub () { 1 }), '_NUMBER(CODE) returns undef' ); null( _NUMBER([]), '_NUMBER(ARRAY) returns undef' ); null( _NUMBER(\""), '_NUMBER(null constant) returns undef' ); null( _NUMBER(\"foo"), '_NUMBER(SCALAR) returns undef' ); null( _NUMBER("D'oh"), '_NUMBER(bad class) returns undef' ); # Test good things against the actual function (carefully) foreach my $id ( qw{1 2 10 123456789 -1 0 +1 02 .1 0.013e-3 1e1} ) { is( _NUMBER($id), $id, "_NUMBER('$id') returns ok" ); } ##################################################################### # Tests for _POSINT # Test bad things against the actual function dies( "Params::Util::_POSINT()", qr/Not enough arguments/, '...::_POSINT() dies' ); null( Params::Util::_POSINT(undef), '...::_POSINT(undef) returns undef' ); null( Params::Util::_POSINT(''), '...::_POSINT(nullstring) returns undef' ); null( Params::Util::_POSINT(' foo'), '...::_POSINT(string) returns undef' ); null( Params::Util::_POSINT({ foo => 1 }), '...::_POSINT(HASH) returns undef' ); null( Params::Util::_POSINT(sub () { 1 }), '...::_POSINT(CODE) returns undef' ); null( Params::Util::_POSINT([]), '...::_POSINT(ARRAY) returns undef' ); null( Params::Util::_POSINT(\""), '...::_POSINT(null constant) returns undef' ); null( Params::Util::_POSINT(\"foo"), '...::_POSINT(SCALAR) returns undef' ); null( Params::Util::_POSINT("D'oh"), '...::_POSINT(bad class) returns undef' ); null( Params::Util::_POSINT(-1), '...::_POSINT(negative) returns undef' ); null( Params::Util::_POSINT(0), '...::_POSINT(zero) returns undef' ); null( Params::Util::_POSINT("+1"), '...::_POSINT(explicit positive) returns undef' ); null( Params::Util::_POSINT("02"), '...::_POSINT(zero lead) returns undef' ); # Test good things against the actual function (carefully) foreach my $id ( qw{1 2 10 123456789} ) { is( Params::Util::_POSINT($id), $id, "...::_POSINT('$id') returns ok" ); } # Import the function use_ok( 'Params::Util', '_POSINT' ); ok( defined *_POSINT{CODE}, '_POSINT imported ok' ); # Test bad things against the actual function dies( "_POSINT()", qr/Not enough arguments/, '_POSINT() dies' ); null( _POSINT(undef), '_POSINT(undef) returns undef' ); null( _POSINT(''), '_POSINT(nullstring) returns undef' ); null( _POSINT(' foo'), '_POSINT(string) returns undef' ); null( _POSINT({ foo => 1 }), '_POSINT(HASH) returns undef' ); null( _POSINT(sub () { 1 }), '_POSINT(CODE) returns undef' ); null( _POSINT([]), '_POSINT(ARRAY) returns undef' ); null( _POSINT(\""), '_POSINT(null constant) returns undef' ); null( _POSINT(\"foo"), '_POSINT(SCALAR) returns undef' ); null( _POSINT("D'oh"), '_POSINT(bad class) returns undef' ); null( _POSINT(-1), '_POSINT(negative) returns undef' ); null( _POSINT(0), '_POSINT(zero) returns undef' ); null( _POSINT("+1"), '_POSINT(explicit positive) returns undef' ); null( _POSINT("02"), '_POSINT(zero lead) returns undef' ); # Test good things against the actual function (carefully) foreach my $id ( qw{1 2 10 123456789} ) { is( _POSINT($id), $id, "_POSINT('$id') returns ok" ); } ##################################################################### # Tests for _NONNEGINT # Test bad things against the actual function dies( "Params::Util::_NONNEGINT()", qr/Not enough arguments/, '...::_NONNEGINT() dies' ); null( Params::Util::_NONNEGINT(undef), '...::_NONNEGINT(undef) returns undef' ); null( Params::Util::_NONNEGINT(''), '...::_NONNEGINT(nullstring) returns undef' ); null( Params::Util::_NONNEGINT(' foo'), '...::_NONNEGINT(string) returns undef' ); null( Params::Util::_NONNEGINT({ foo => 1 }), '...::_NONNEGINT(HASH) returns undef' ); null( Params::Util::_NONNEGINT(sub () { 1 }), '...::_NONNEGINT(CODE) returns undef' ); null( Params::Util::_NONNEGINT([]), '...::_NONNEGINT(ARRAY) returns undef' ); null( Params::Util::_NONNEGINT(\""), '...::_NONNEGINT(null constant) returns undef' ); null( Params::Util::_NONNEGINT(\"foo"), '...::_NONNEGINT(SCALAR) returns undef' ); null( Params::Util::_NONNEGINT("D'oh"), '...::_NONNEGINT(bad class) returns undef' ); null( Params::Util::_NONNEGINT(-1), '...::_NONNEGINT(negative) returns undef' ); null( Params::Util::_NONNEGINT("+1"), '...::_NONNEGINT(explicit positive) returns undef' ); null( Params::Util::_NONNEGINT("02"), '...::_NONNEGINT(zero lead) returns undef' ); # Test good things against the actual function (carefully) foreach my $id ( qw{0 1 2 10 123456789} ) { is( Params::Util::_NONNEGINT($id), $id, "...::_NONNEGINT('$id') returns ok" ); } # Import the function use_ok( 'Params::Util', '_NONNEGINT' ); ok( defined *_NONNEGINT{CODE}, '_NONNEGINT imported ok' ); # Test bad things against the actual function dies( "_NONNEGINT()", qr/Not enough arguments/, '_NONNEGINT() dies' ); null( _NONNEGINT(undef), '_NONNEGINT(undef) returns undef' ); null( _NONNEGINT(''), '_NONNEGINT(nullstring) returns undef' ); null( _NONNEGINT(' foo'), '_NONNEGINT(string) returns undef' ); null( _NONNEGINT({ foo => 1 }), '_NONNEGINT(HASH) returns undef' ); null( _NONNEGINT(sub () { 1 }), '_NONNEGINT(CODE) returns undef' ); null( _NONNEGINT([]), '_NONNEGINT(ARRAY) returns undef' ); null( _NONNEGINT(\""), '_NONNEGINT(null constant) returns undef' ); null( _NONNEGINT(\"foo"), '_NONNEGINT(SCALAR) returns undef' ); null( _NONNEGINT("D'oh"), '_NONNEGINT(bad class) returns undef' ); null( _NONNEGINT(-1), '_NONNEGINT(negative) returns undef' ); null( _NONNEGINT("+1"), '_NONNEGINT(explicit positive) returns undef' ); null( _NONNEGINT("02"), '_NONNEGINT(zero lead) returns undef' ); # Test good things against the actual function (carefully) foreach my $id ( qw{0 1 2 10 123456789} ) { is( _NONNEGINT($id), $id, "_NONNEGINT('$id') returns ok" ); } ##################################################################### # Tests for _SCALAR my $foo = "foo"; my $scalar = \$foo; # Test bad things against the actual function dies( "Params::Util::_SCALAR()", qr/Not enough arguments/, '...::_SCALAR() dies' ); null( Params::Util::_SCALAR(undef), '...::_SCALAR(undef) returns undef' ); null( Params::Util::_SCALAR(\undef), '...::_SCALAR(\undef) returns undef' ); null( Params::Util::_SCALAR(''), '...::_SCALAR(nullstring) returns undef' ); null( Params::Util::_SCALAR(1), '...::_SCALAR(number) returns undef' ); null( Params::Util::_SCALAR('foo'), '...::_SCALAR(string) returns undef' ); null( Params::Util::_SCALAR({ foo => 1 }), '...::_SCALAR(HASH) returns undef' ); null( Params::Util::_SCALAR(sub () { 1 }), '...::_SCALAR(CODE) returns undef' ); null( Params::Util::_SCALAR([]), '...::_SCALAR(ARRAY) returns undef' ); null( Params::Util::_SCALAR(\""), '...::_SCALAR(null constant) returns undef' ); # Test good things against the actual function (carefully) is( ref(Params::Util::_SCALAR(\"foo")), 'SCALAR', '...::_SCALAR(constant) returns true' ); is( ref(Params::Util::_SCALAR($scalar)), 'SCALAR', "...::_SCALAR(['foo']) returns true" ); is( refaddr(Params::Util::_SCALAR($scalar)), refaddr($scalar), '...::_SCALAR returns the same SCALAR reference'); # Import the function use_ok( 'Params::Util', '_SCALAR' ); ok( defined *_SCALAR{CODE}, '_SCALAR imported ok' ); # Test bad things against the imported function dies( "_SCALAR()", qr/Not enough arguments/, '...::_SCALAR() dies' ); null( _SCALAR(undef), '...::_SCALAR(undef) returns undef' ); null( _SCALAR(\undef), '...::_SCALAR(\undef) returns undef' ); null( _SCALAR(''), '...::_SCALAR(nullstring) returns undef' ); null( _SCALAR(1), '...::_SCALAR(number) returns undef' ); null( _SCALAR('foo'), '...::_SCALAR(string) returns undef' ); null( _SCALAR({ foo => 1 }), '...::_SCALAR(HASH) returns undef' ); null( _SCALAR(sub () { 1 }), '...::_SCALAR(CODE) returns undef' ); null( _SCALAR([]), '...::_SCALAR(ARRAY) returns undef' ); null( _SCALAR(\""), '...::_SCALAR(null constant) returns undef' ); # Test good things against the actual function (carefully) is( ref(_SCALAR(\"foo")), 'SCALAR', '...::_SCALAR(constant) returns true' ); is( ref(_SCALAR($scalar)), 'SCALAR', "...::_SCALAR(SCALAR) returns true" ); is( refaddr(_SCALAR($scalar)), refaddr($scalar), '...::_SCALAR returns the same SCALAR reference'); ##################################################################### # Tests for _SCALAR0 my $null = ""; my $scalar0 = \$null; # Test bad things against the actual function dies( "Params::Util::_SCALAR0()", qr/Not enough arguments/, '...::_SCALAR0() dies' ); null( Params::Util::_SCALAR0(undef), '...::_SCALAR0(undef) returns undef' ); null( Params::Util::_SCALAR0(''), '...::_SCALAR0(nullstring) returns undef' ); null( Params::Util::_SCALAR0(1), '...::_SCALAR0(number) returns undef' ); null( Params::Util::_SCALAR0('foo'), '...::_SCALAR0(string) returns undef' ); null( Params::Util::_SCALAR0({ foo => 1 }), '...::_SCALAR0(HASH) returns undef' ); null( Params::Util::_SCALAR0(sub () { 1 }), '...::_SCALAR0(CODE) returns undef' ); null( Params::Util::_SCALAR0([]), '...::_SCALAR0(ARRAY) returns undef' ); # Test good things against the actual function (carefully) is( ref(Params::Util::_SCALAR0(\"foo")), 'SCALAR', '...::_SCALAR0(constant) returns true' ); is( ref(Params::Util::_SCALAR0(\"")), 'SCALAR', '...::_SCALAR0(constant) returns true' ); is( ref(Params::Util::_SCALAR0(\undef)), 'SCALAR', '...::_SCALAR0(\undef) returns true' ); is( ref(Params::Util::_SCALAR0($scalar)), 'SCALAR', "...::_SCALAR0(constant) returns true" ); is( ref(Params::Util::_SCALAR0($scalar0)), 'SCALAR', "...::_SCALAR0(constant) returns true" ); is( refaddr(Params::Util::_SCALAR0($scalar)), refaddr($scalar), '...::_SCALAR returns the same SCALAR reference'); is( refaddr(Params::Util::_SCALAR0($scalar0)), refaddr($scalar0), '...::_SCALAR returns the same SCALAR reference'); # Import the function use_ok( 'Params::Util', '_SCALAR0' ); ok( defined *_SCALAR0{CODE}, '_SCALAR0 imported ok' ); # Test bad things against the imported function dies( "_SCALAR0()", qr/Not enough arguments/, '...::_SCALAR0() dies' ); null( _SCALAR0(undef), '...::_SCALAR0(undef) returns undef' ); null( _SCALAR0(''), '...::_SCALAR0(nullstring) returns undef' ); null( _SCALAR0(1), '...::_SCALAR0(number) returns undef' ); null( _SCALAR0('foo'), '...::_SCALAR0(string) returns undef' ); null( _SCALAR0({ foo => 1 }), '...::_SCALAR0(HASH) returns undef' ); null( _SCALAR0(sub () { 1 }), '...::_SCALAR0(CODE) returns undef' ); null( _SCALAR0([]), '...::_SCALAR0(ARRAY) returns undef' ); # Test good things against the actual function (carefully) is( ref(_SCALAR0(\"foo")), 'SCALAR', '...::_SCALAR0(constant) returns true' ); is( ref(_SCALAR0(\"")), 'SCALAR', '...::_SCALAR0(constant) returns true' ); is( ref(_SCALAR0(\undef)), 'SCALAR', '...::_SCALAR0(\undef) returns true' ); is( ref(_SCALAR0($scalar)), 'SCALAR', "...::_SCALAR0(constant) returns true" ); is( ref(_SCALAR0($scalar0)), 'SCALAR', "...::_SCALAR0(constant) returns true" ); is( refaddr(_SCALAR0($scalar)), refaddr($scalar), '...::_SCALAR returns the same SCALAR reference'); is( refaddr(_SCALAR0($scalar0)), refaddr($scalar0), '...::_SCALAR returns the same SCALAR reference'); ##################################################################### # Tests for _ARRAY my $array = [ 'foo', 'bar' ]; # Test bad things against the actual function dies( "Params::Util::_ARRAY()", qr/Not enough arguments/, '...::_ARRAY() dies' ); null( Params::Util::_ARRAY(undef), '...::_ARRAY(undef) returns undef' ); null( Params::Util::_ARRAY(''), '...::_ARRAY(nullstring) returns undef' ); null( Params::Util::_ARRAY(1), '...::_ARRAY(number) returns undef' ); null( Params::Util::_ARRAY('foo'), '...::_ARRAY(string) returns undef' ); null( Params::Util::_ARRAY(\'foo'), '...::_ARRAY(SCALAR) returns undef' ); null( Params::Util::_ARRAY({ foo => 1 }), '...::_ARRAY(HASH) returns undef' ); null( Params::Util::_ARRAY(sub () { 1 }), '...::_ARRAY(CODE) returns undef' ); null( Params::Util::_ARRAY([]), '...::_ARRAY(empty ARRAY) returns undef' ); # Test good things against the actual function (carefully) is( ref(Params::Util::_ARRAY([ undef ])), 'ARRAY', '...::_ARRAY([undef]) returns true' ); is( ref(Params::Util::_ARRAY([ 'foo' ])), 'ARRAY', "...::_ARRAY(['foo']) returns true" ); is( ref(Params::Util::_ARRAY($array)), 'ARRAY', '...::_ARRAY returns an ARRAY ok' ); is( refaddr(Params::Util::_ARRAY($array)), refaddr($array), '...::_ARRAY($array) returns the same ARRAY reference'); # Import the function use_ok( 'Params::Util', '_ARRAY' ); ok( defined *_ARRAY{CODE}, '_ARRAY imported ok' ); # Test bad things against the actual function dies( "_ARRAY();", qr/Not enough arguments/, '_ARRAY() dies' ); null( _ARRAY(undef), '_ARRAY(undef) returns undef' ); null( _ARRAY(''), '_ARRAY(nullstring) returns undef' ); null( _ARRAY(1), '_ARRAY(number) returns undef' ); null( _ARRAY('foo'), '_ARRAY(string) returns undef' ); null( _ARRAY(\'foo'), '_ARRAY(SCALAR) returns undef' ); null( _ARRAY({ foo => 1 }), '_ARRAY(HASH) returns undef' ); null( _ARRAY(sub () { 1 }), '_ARRAY(CODE) returns undef' ); null( _ARRAY([]), '_ARRAY(empty ARRAY) returns undef' ); # Test good things against the actual function (carefully) is( ref(_ARRAY([ undef ])), 'ARRAY', '_ARRAY([undef]) returns true' ); is( ref(_ARRAY([ 'foo' ])), 'ARRAY', "_ARRAY(['foo']) returns true" ); is( ref(_ARRAY($array)), 'ARRAY', '_ARRAY returns an ARRAY ok' ); is( refaddr(_ARRAY($array)), refaddr($array), '_ARRAY($array) returns the same ARRAY reference'); ##################################################################### # Tests for _ARRAY0 # Test bad things against the actual function dies( "Params::Util::_ARRAY0();", qr/Not enough arguments/, '...::_ARRAY0() dies' ); null( Params::Util::_ARRAY0(undef), '...::_ARRAY0(undef) returns undef' ); null( Params::Util::_ARRAY0(''), '...::_ARRAY0(nullstring) returns undef' ); null( Params::Util::_ARRAY0(1), '...::_ARRAY0(number) returns undef' ); null( Params::Util::_ARRAY0('foo'), '...::_ARRAY0(string) returns undef' ); null( Params::Util::_ARRAY0(\'foo'), '...::_ARRAY0(SCALAR) returns undef' ); null( Params::Util::_ARRAY0({ foo => 1 }), '...::_ARRAY0(HASH) returns undef' ); null( Params::Util::_ARRAY0(sub () { 1 }), '...::_ARRAY0(CODE) returns undef' ); # Test good things against the actual function (carefully) is( ref(Params::Util::_ARRAY0([])), 'ARRAY', '...::_ARRAY0(empty ARRAY) returns undef' ); is( ref(Params::Util::_ARRAY0([ undef ])), 'ARRAY', '...::_ARRAY0([undef]) returns true' ); is( ref(Params::Util::_ARRAY0([ 'foo' ])), 'ARRAY', "...::_ARRAY0(['foo']) returns true" ); is( ref(Params::Util::_ARRAY0($array)), 'ARRAY', '...::_ARRAY0 returns an ARRAY ok' ); is( refaddr(Params::Util::_ARRAY0($array)), refaddr($array), '...::_ARRAY0($array) returns the same ARRAY reference'); # Import the function use_ok( 'Params::Util', '_ARRAY0' ); ok( defined *_ARRAY0{CODE}, '_ARRAY0 imported ok' ); # Test bad things against the actual function dies( "_ARRAY0();", qr/Not enough arguments/, '_ARRAY0() dies' ); null( _ARRAY0(undef), '_ARRAY0(undef) returns undef' ); null( _ARRAY0(''), '_ARRAY0(nullstring) returns undef' ); null( _ARRAY0(1), '_ARRAY0(number) returns undef' ); null( _ARRAY0('foo'), '_ARRAY0(string) returns undef' ); null( _ARRAY0(\'foo'), '_ARRAY0(SCALAR) returns undef' ); null( _ARRAY0({ foo => 1 }), '_ARRAY0(HASH) returns undef' ); null( _ARRAY0(sub () { 1 }), '_ARRAY0(CODE) returns undef' ); # Test good things against the actual function (carefully) is( ref(_ARRAY0([])), 'ARRAY', '_ARRAY0(empty ARRAY) returns undef' ); is( ref(_ARRAY0([ undef ])), 'ARRAY', '_ARRAY0([undef]) returns true' ); is( ref(_ARRAY0([ 'foo' ])), 'ARRAY', "_ARRAY0(['foo']) returns true" ); is( ref(_ARRAY0($array)), 'ARRAY', '_ARRAY0 returns an ARRAY ok' ); is( refaddr(_ARRAY0($array)), refaddr($array), '_ARRAY0($array) returns the same reference'); ##################################################################### # Tests for _HASH my $hash = { 'foo' => 'bar' }; # Test bad things against the actual function dies( "Params::Util::_HASH();", qr/Not enough arguments/, '...::_HASH() dies' ); null( Params::Util::_HASH(undef), '...::_HASH(undef) returns undef' ); null( Params::Util::_HASH(''), '...::_HASH(nullstring) returns undef' ); null( Params::Util::_HASH(1), '...::_HASH(number) returns undef' ); null( Params::Util::_HASH('foo'), '...::_HASH(string) returns undef' ); null( Params::Util::_HASH(\'foo'), '...::_HASH(SCALAR) returns undef' ); null( Params::Util::_HASH([ 'foo' ]), '...::_HASH(ARRAY) returns undef' ); null( Params::Util::_HASH(sub () { 1 }), '...::_HASH(CODE) returns undef' ); null( Params::Util::_HASH({}), '...::_HASH(empty HASH) returns undef' ); # Test good things against the actual function (carefully) is( ref(Params::Util::_HASH({ foo => 1 })), 'HASH', '...::_HASH([undef]) returns ok' ); is( ref(Params::Util::_HASH($hash)), 'HASH', '...::_HASH returns an HASH ok' ); is( refaddr(Params::Util::_HASH($hash)), refaddr($hash), '...::_HASH($hash) returns the same reference', ); # Import the function use_ok( 'Params::Util', '_HASH' ); ok( defined *_HASH{CODE}, '_HASH imported ok' ); # Test bad things against the actual function dies( "_HASH();", qr/Not enough arguments/, '_HASH() dies' ); null( _HASH(undef), '_HASH(undef) returns undef' ); null( _HASH(''), '_HASH(nullstring) returns undef' ); null( _HASH(1), '_HASH(number) returns undef' ); null( _HASH('foo'), '_HASH(string) returns undef' ); null( _HASH(\'foo'), '_HASH(SCALAR) returns undef' ); null( _HASH([]), '_HASH(ARRAY) returns undef' ); null( _HASH(sub () { 1 }), '_HASH(CODE) returns undef' ); null( _HASH({}), '...::_HASH(empty HASH) returns undef' ); # Test good things against the actual function (carefully) is( ref(_HASH({ foo => 1 })), 'HASH', '_HASH([undef]) returns true' ); is( ref(_HASH($hash)), 'HASH', '_HASH returns an ARRAY ok' ); is( refaddr(_HASH($hash)), refaddr($hash), '_HASH($hash) returns the same reference', ); ##################################################################### # Tests for _HASH0 # Test bad things against the actual function dies( "Params::Util::_HASH0();", qr/Not enough arguments/, '...::_HASH0() dies' ); null( Params::Util::_HASH0(undef), '...::_HASH0(undef) returns undef' ); null( Params::Util::_HASH0(''), '...::_HASH0(nullstring) returns undef' ); null( Params::Util::_HASH0(1), '...::_HASH0(number) returns undef' ); null( Params::Util::_HASH0('foo'), '...::_HASH0(string) returns undef' ); null( Params::Util::_HASH0(\'foo'), '...::_HASH0(SCALAR) returns undef' ); null( Params::Util::_HASH0([ 'foo' ]), '...::_HASH0(ARRAY) returns undef' ); null( Params::Util::_HASH0(sub () { 1 }), '...::_HASH0(CODE) returns undef' ); # Test good things against the actual function (carefully) is( ref(Params::Util::_HASH0({})), 'HASH', '...::_HASH0(empty ARRAY) returns undef' ); is( ref(Params::Util::_HASH0({ foo => 1 })), 'HASH', '...::_HASH0([undef]) returns true' ); is( ref(Params::Util::_HASH0($hash)), 'HASH', '...::_HASH0 returns an ARRAY ok' ); is( refaddr(Params::Util::_HASH0($hash)), refaddr($hash), '...::_HASH0($hash) returns the same reference', ); # Import the function use_ok( 'Params::Util', '_HASH0' ); ok( defined *_HASH0{CODE}, '_HASH0 imported ok' ); # Test bad things against the actual function dies( "_HASH0();", qr/Not enough arguments/, '_HASH0() dies' ); null( _HASH0(undef), '_HASH0(undef) returns undef' ); null( _HASH0(''), '_HASH0(nullstring) returns undef' ); null( _HASH0(1), '_HASH0(number) returns undef' ); null( _HASH0('foo'), '_HASH0(string) returns undef' ); null( _HASH0(\'foo'), '_HASH0(SCALAR) returns undef' ); null( _HASH0([]), '_HASH0(ARRAY) returns undef' ); null( _HASH0(sub () { 1 }), '_HASH0(CODE) returns undef' ); # Test good things against the actual function (carefully) is( ref(_HASH0({})), 'HASH', '_HASH0(empty ARRAY) returns undef' ); is( ref(_HASH0({ foo => 1 })), 'HASH', '_HASH0([undef]) returns true' ); is( ref(_HASH0($hash)), 'HASH', '_HASH0 returns an ARRAY ok' ); is( refaddr(_HASH0($hash)), refaddr($hash), '_HASH0($hash) returns the same reference', ); ##################################################################### # Tests for _CODE my $code = sub () { 1 }; sub testcode { 3 }; # Import the function use_ok( 'Params::Util', '_CODE' ); ok( defined *_CODE{CODE}, '_CODE imported ok' ); # Test bad things against the actual function dies( "Params::Util::_CODE();", qr/Not enough arguments/, '...::_CODE() dies' ); null( Params::Util::_CODE(undef), '...::_CODE(undef) returns undef' ); null( Params::Util::_CODE(''), '...::_CODE(nullstring) returns undef' ); null( Params::Util::_CODE(1), '...::_CODE(number) returns undef' ); null( Params::Util::_CODE('foo'), '...::_CODE(string) returns undef' ); null( Params::Util::_CODE(\'foo'), '...::_CODE(SCALAR) returns undef' ); null( Params::Util::_CODE([ 'foo' ]), '...::_CODE(ARRAY) returns undef' ); null( Params::Util::_CODE({}), '...::_CODE(empty HASH) returns undef' ); # Test bad things against the actual function dies( "_CODE();", qr/Not enough arguments/, '_CODE() dies' ); null( _CODE(undef), '_CODE(undef) returns undef' ); null( _CODE(''), '_CODE(nullstring) returns undef' ); null( _CODE(1), '_CODE(number) returns undef' ); null( _CODE('foo'), '_CODE(string) returns undef' ); null( _CODE(\'foo'), '_CODE(SCALAR) returns undef' ); null( _CODE([]), '_CODE(ARRAY) returns undef' ); null( _CODE({}), '...::_CODE(empty HASH) returns undef' ); # Test good things against the actual function is( ref(Params::Util::_CODE(sub { 2 })), 'CODE', '...::_CODE(anon) returns ok' ); is( ref(Params::Util::_CODE($code)), 'CODE', '...::_CODE(ref) returns ok' ); is( ref(Params::Util::_CODE(\&testsub)), 'CODE', '...::_CODE(\&func) returns ok' ); is( refaddr(Params::Util::_CODE($code)), refaddr($code), '...::_CODE(ref) returns the same reference'); is( refaddr(Params::Util::_CODE(\&testsub)), refaddr(\&testsub), '...::_CODE(\&func) returns the same reference'); # Test good things against the imported function is( ref(_CODE(sub { 2 })), 'CODE', '_CODE(anon) returns ok' ); is( ref(_CODE($code)), 'CODE', '_CODE(ref) returns ok' ); is( ref(_CODE(\&testsub)), 'CODE', '_CODE(\&func) returns ok' ); is( refaddr(_CODE($code)), refaddr($code), '_CODE(ref) returns the same reference'); is( refaddr(_CODE(\&testsub)), refaddr(\&testsub), '_CODE(\&func) returns the same reference'); ##################################################################### # Tests for _INSTANCE my $s1 = "foo"; my $s2 = "bar"; my $s3 = "baz"; my $scalar1 = \$s1; my $scalar2 = \$s2; my $scalar3 = \$s3; my @objects = ( bless( {}, 'Foo'), bless( [], 'Foo'), bless( $scalar1, 'Foo'), bless( {}, 'Bar'), bless( [], 'Bar'), bless( $scalar1, 'Bar'), bless( {}, 'Baz'), bless( [], 'Baz'), bless( $scalar3, 'Baz'), ); # Test bad things against the actual function dies( "Params::Util::_INSTANCE()", qr/Not enough arguments/, '...::_INSTANCE() dies' ); dies( "Params::Util::_INSTANCE(bless {}, 'Foo')", qr/Not enough arguments/, '...::_INSTANCE(object) dies' ); null( Params::Util::_INSTANCE(undef, 'Foo'), '...::_INSTANCE(undef) returns undef' ); null( Params::Util::_INSTANCE('', 'Foo'), '...::_INSTANCE(nullstring) returns undef' ); null( Params::Util::_INSTANCE(1, 'Foo'), '...::_INSTANCE(number) returns undef' ); null( Params::Util::_INSTANCE('foo', 'Foo'), '...::_INSTANCE(string) returns undef' ); null( Params::Util::_INSTANCE({ foo => 1 }, 'Foo'), '...::_INSTANCE(HASH) returns undef' ); null( Params::Util::_INSTANCE(sub () { 1 }, 'Foo'), '...::_INSTANCE(CODE) returns undef' ); null( Params::Util::_INSTANCE([], 'Foo'), '...::_INSTANCE(ARRAY) returns undef' ); null( Params::Util::_INSTANCE(\"", 'Foo'), '...::_INSTANCE(null constant) returns undef' ); null( Params::Util::_INSTANCE(\"foo", 'Foo'), '...::_INSTANCE(SCALAR) returns undef' ); null( Params::Util::_INSTANCE(bless({},'Bad'), 'Foo'), '...::_INSTANCE(bad object) returns undef' ); # Import the function use_ok( 'Params::Util', '_INSTANCE' ); ok( defined *_INSTANCE{CODE}, '_INSTANCE imported ok' ); # Test bad things against the actual function dies( "_INSTANCE()", qr/Not enough arguments/, '_INSTANCE() dies' ); dies( "_INSTANCE(bless {}, 'Foo')", qr/Not enough arguments/, '_INSTANCE(object) dies' ); null( _INSTANCE(undef, 'Foo'), '_INSTANCE(undef) returns undef' ); null( _INSTANCE('', 'Foo'), '_INSTANCE(nullstring) returns undef' ); null( _INSTANCE(1, 'Foo'), '_INSTANCE(number) returns undef' ); null( _INSTANCE('foo', 'Foo'), '_INSTANCE(string) returns undef' ); null( _INSTANCE({ foo => 1 }, 'Foo'), '_INSTANCE(HASH) returns undef' ); null( _INSTANCE(sub () { 1 }, 'Foo'), '_INSTANCE(CODE) returns undef' ); null( _INSTANCE([], 'Foo'), '_INSTANCE(ARRAY) returns undef' ); null( _INSTANCE(\"", 'Foo'), '_INSTANCE(null constant) returns undef' ); null( _INSTANCE(\"foo", 'Foo'), '_INSTANCE(SCALAR) returns undef' ); null( _INSTANCE(bless({},'Bad'), 'Foo'), '_INSTANCE(bad object) returns undef' ); # Testing good things is a little more complicated in this case, # so lets do the basic ones first. foreach my $object ( @objects ) { ok( Params::Util::_INSTANCE($object, 'Foo'), '...::_INSTANCE(object, class) returns true when expected' ); is( refaddr(Params::Util::_INSTANCE($object, 'Foo')), refaddr($object), '...::_INSTANCE(object, class) returns the same object' ); } # Testing good things is a little more complicated in this case, # so lets do the basic ones first. foreach my $object ( @objects ) { ok( _INSTANCE($object, 'Foo'), '_INSTANCE(object, class) returns true when expected' ); is( refaddr(_INSTANCE($object, 'Foo')), refaddr($object), '_INSTANCE(object, class) returns the same object' ); } SKIP: { use_ok( 'Params::Util', '_INSTANCEDOES' ); skip "DOES tests do not make sense on perls before 5.10", 19 unless $] >= 5.010; null( _INSTANCEDOES(bless({},'Bad'), 'Foo'), '_INSTANCEDOES(bad object) returns undef' ); foreach my $object ( @objects ) { ok( _INSTANCEDOES($object, 'Foo'), '_INSTANCEDOES(object, class) returns true when expected' ); is( refaddr(_INSTANCEDOES($object, 'Foo')), refaddr($object), '_INSTANCEDOES(object, class) returns the same object' ); } } ##################################################################### # Tests for _REGEX # Test bad things against the actual function dies( "Params::Util::_REGEX();", qr/Not enough arguments/, '...::_REGEX() dies' ); null( Params::Util::_REGEX(undef), '...::_REGEX(undef) returns undef' ); null( Params::Util::_REGEX(''), '...::_REGEX(STRING0) returns undef' ); null( Params::Util::_REGEX(1), '...::_REGEX(number) returns undef' ); null( Params::Util::_REGEX('foo'), '...::_REGEX(string) returns undef' ); null( Params::Util::_REGEX(\'foo'), '...::_REGEX(SCALAR) returns undef' ); null( Params::Util::_REGEX([ 'foo' ]), '...::_REGEX(ARRAY) returns undef' ); null( Params::Util::_REGEX(sub () { 1 }), '...::_REGEX(CODE) returns undef' ); null( Params::Util::_REGEX({}), '...::_REGEX(HASH0) returns undef' ); null( Params::Util::_REGEX({ foo => 1 }), '...::_REGEX(HASH) returns undef' ); ok( Params::Util::_REGEX(qr//), '...::_REGEX(qr//) ok' ); ok( Params::Util::_REGEX(qr/foo/), '...::_REGEX(qr//) ok' ); # Import the function use_ok( 'Params::Util', '_REGEX' ); ok( defined *_REGEX{CODE}, '_REGEX imported ok' ); # Test bad things against the actual function dies( "_REGEX();", qr/Not enough arguments/, '_REGEX() dies' ); null( _REGEX(undef), '_REGEX(undef) returns undef' ); null( _REGEX(''), '_REGEX(STRING0) returns undef' ); null( _REGEX(1), '_REGEX(number) returns undef' ); null( _REGEX('foo'), '_REGEX(string) returns undef' ); null( _REGEX(\'foo'), '_REGEX(SCALAR) returns undef' ); null( _REGEX([]), '_REGEX(ARRAY) returns undef' ); null( _REGEX(sub () { 1 }), '_REGEX(CODE) returns undef' ); null( _REGEX({}), 'REGEX(HASH0) returns undef' ); null( _REGEX({ foo => 1 }), 'REGEX(HASH) returns undef' ); ok( _REGEX(qr//), '_REGEX(qr//) ok' ); ok( _REGEX(qr/foo/), '_REGEX(qr//) ok' ); ##################################################################### # Tests for _SET my %set = ( good => [ map { bless {} => 'Foo' } qw(1..3) ], mixed => [ map { bless {} => "Foo$_" } qw(1..3) ], unblessed => [ map { {} } qw(1..3) ], ); # Test bad things against the actual function dies( "Params::Util::_SET()", qr/Not enough arguments/, '...::_SET() dies' ); dies( "Params::Util::_SET([])", qr/Not enough arguments/, '...::_SET(single) dies' ); null( Params::Util::_SET(undef, 'Foo'), '...::_SET(undef) returns undef' ); null( Params::Util::_SET('', 'Foo'), '...::_SET(nullstring) returns undef' ); null( Params::Util::_SET(1, 'Foo'), '...::_SET(number) returns undef' ); null( Params::Util::_SET('foo', 'Foo'), '...::_SET(string) returns undef' ); null( Params::Util::_SET(\'foo', 'Foo'), '...::_SET(SCALAR) returns undef' ); null( Params::Util::_SET({ foo => 1 }, 'Foo'), '...::_SET(HASH) returns undef' ); null( Params::Util::_SET(sub () { 1 }, 'Foo'), '...::_SET(CODE) returns undef' ); null( Params::Util::_SET([], 'Foo'), '...::_SET(empty ARRAY) returns undef' ); ok( Params::Util::_SET($set{good}, 'Foo'), '...::_SET(homogenous ARRAY) returns true' ); null( Params::Util::_SET($set{mixed}, 'Foo'), '...::_SET(mixed ARRAY) returns undef' ); null( Params::Util::_SET($set{unblessed}, 'Foo'), '...::_SET(unblessed ARRAY) returns undef' ); # Import the function use_ok( 'Params::Util', '_SET' ); ok( defined *_SET{CODE}, '_SET imported ok' ); # Test bad things against the actual function dies( "_SET()", qr/Not enough arguments/, '_SET() dies' ); dies( "_SET([])", qr/Not enough arguments/, '_SET(single) dies' ); null( _SET(undef, 'Foo'), '_SET(undef) returns undef' ); null( _SET('', 'Foo'), '_SET(nullstring) returns undef' ); null( _SET(1, 'Foo'), '_SET(number) returns undef' ); null( _SET('foo', 'Foo'), '_SET(string) returns undef' ); null( _SET(\'foo', 'Foo'), '_SET(SCALAR) returns undef' ); null( _SET({ foo => 1 }, 'Foo'), '_SET(HASH) returns undef' ); null( _SET(sub () { 1 }, 'Foo'), '_SET(CODE) returns undef' ); null( _SET([], 'Foo'), '_SET(empty ARRAY) returns undef' ); ok( _SET($set{good}, 'Foo'), '_SET(homogenous ARRAY) returns true'); null( _SET($set{mixed}, 'Foo'), '_SET(mixed ARRAY) returns undef'); null( _SET($set{unblessed}, 'Foo'), '_SET(unblessed ARRAY) returns undef'); ##################################################################### # Tests for _SET0 # Test bad things against the actual function dies( "Params::Util::_SET0()", qr/Not enough arguments/, '...::_SET0() dies' ); dies( "Params::Util::_SET0([])", qr/Not enough arguments/, '...::_SET0(single) dies' ); null( Params::Util::_SET0(undef, 'Foo'), '...::_SET0(undef) returns undef' ); null( Params::Util::_SET0('', 'Foo'), '...::_SET0(nullstring) returns undef' ); null( Params::Util::_SET0(1, 'Foo'), '...::_SET0(number) returns undef' ); null( Params::Util::_SET0('foo', 'Foo'), '...::_SET0(string) returns undef' ); null( Params::Util::_SET0(\'foo', 'Foo'), '...::_SET0(SCALAR) returns undef' ); null( Params::Util::_SET0({ foo => 1 }, 'Foo'), '...::_SET0(HASH) returns undef' ); null( Params::Util::_SET0(sub () { 1 }, 'Foo'), '...::_SET0(CODE) returns undef' ); ok( Params::Util::_SET0([], 'Foo'), '...::_SET0(empty ARRAY) returns true' ); ok( Params::Util::_SET0($set{good}, 'Foo'), '...::_SET0(homogenous ARRAY) returns true' ); null( Params::Util::_SET0($set{mixed}, 'Foo'), '...::_SET0(mixed ARRAY) returns undef' ); null( Params::Util::_SET0($set{unblessed}, 'Foo'), '...::_SET0(unblessed ARRAY) returns undef' ); # Import the function use_ok( 'Params::Util', '_SET0' ); ok( defined *_SET0{CODE}, '_SET0 imported ok' ); # Test bad things against the actual function dies( "_SET0()", qr/Not enough arguments/, '_SET0() dies' ); dies( "_SET0([])", qr/Not enough arguments/, '_SET0(single) dies' ); null( _SET0(undef, 'Foo'), '_SET0(undef) returns undef' ); null( _SET0('', 'Foo'), '_SET0(nullstring) returns undef' ); null( _SET0(1, 'Foo'), '_SET0(number) returns undef' ); null( _SET0('foo', 'Foo'), '_SET0(string) returns undef' ); null( _SET0(\'foo', 'Foo'), '_SET0(SCALAR) returns undef' ); null( _SET0({ foo => 1 }, 'Foo'), '_SET0(HASH) returns undef' ); null( _SET0(sub () { 1 }, 'Foo'), '_SET0(CODE) returns undef' ); ok( _SET0([], 'Foo'), '_SET0(empty ARRAY) returns true' ); ok( _SET0($set{good}, 'Foo'), '_SET0(homogenous ARRAY) returns true' ); null( _SET0($set{mixed}, 'Foo'), '_SET0(mixed ARRAY) returns undef' ); null( _SET0($set{unblessed}, 'Foo'), '_SET0(unblessed ARRAY) returns undef' ); exit(0); # Base class package Foo; sub foo { 1 } # Normal inheritance package Bar; use vars qw{@ISA}; BEGIN { @ISA = 'Foo'; } # Coded isa package Baz; sub isa { return 1 if $_[1] eq 'Foo'; shift->SUPER::isa(@_); } # Not a subclass package Bad; sub bad { 1 } 1; Params-Util-1.07/t/06_invocant.t0000644000175100017510000000327611726772122014764 0ustar adamadam#!/usr/bin/perl use strict; BEGIN { $| = 1; $^W = 1; $ENV{PERL_PARAMS_UTIL_PP} ||= 0; } use Test::More tests => 11; use File::Spec::Functions ':ALL'; BEGIN { use_ok('Params::Util', qw(_INVOCANT)); } my $object = bless \do { my $i } => 'Params::Util::Test::Bogus::Whatever'; my $false_obj1 = bless \do { my $i } => 0; my $false_obj2 = bless \do { my $i } => "\0"; my $tied = tie my $x, 'Params::Util::Test::_INVOCANT::Tied'; my $unpkg = 'Params::Util::Test::_INVOCANT::Fake'; my $pkg = 'Params::Util::Test::_INVOCANT::Real'; eval "package $pkg;"; ## no critic my @data = (# I [ undef , 0, 'undef' ], [ 1000 => 0, '1000' ], [ $unpkg => 1, qq("$unpkg") ], [ $pkg => 1, qq("$pkg") ], [ [] => 0, '[]' ], [ {} => 0, '{}' ], [ $object => 1, 'blessed reference' ], [ $false_obj1 => 1, 'blessed reference' ], [ $tied => 1, 'tied value' ], ); for my $datum (@data) { is( _INVOCANT($datum->[0]) ? 1 : 0, $datum->[1], "$datum->[2] " . ($datum->[1] ? 'is' : "isn't") . " _IN" ); } # Skip the most evil test except on automated testing, because it # fails on at least one common production OS (RedHat Enterprise Linux 4) # and the test case should be practically impossible to encounter # in real life. The damage the bug could cause users in production is # far lower than the damage caused by Params::Util failing to install. SKIP: { unless ( $ENV{AUTOMATED_TESTING} ) { skip("Skipping nasty test unless AUTOMATED_TESTING", 1); } ok( !! _INVOCANT($false_obj2), 'Testing null class as an invocant' ); } package Params::Util::Test::_INVOCANT::Tied; sub TIESCALAR { my ($class, $value) = @_; return bless \$value => $class; } Params-Util-1.07/t/19_insideout.t0000644000175100017510000000150411726772157015152 0ustar adamadam#!/usr/bin/perl # Test for a custom isa method that returns the same way that # Object::InsideOut does. use strict; BEGIN { $| = 1; $^W = 1; $ENV{PERL_PARAMS_UTIL_PP} ||= 1; } use Test::More tests => 2; use Scalar::Util (); use Params::Util (); ##################################################################### # Create an object and test it SCOPE: { my $object = Foo->new; ok( Scalar::Util::blessed($object), 'Foo' ); my $instance = Params::Util::_INSTANCE($object, 'Foo'); is( $instance, undef, '_INSTANCE correctly returns undef' ); } ##################################################################### # Create a package to simulate Object::InsideOut CLASS: { package Foo; sub new { my $foo = 1234; my $self = \$foo; bless $self, $_[0]; return $self; } sub isa { return (''); } 1; } Params-Util-1.07/t/15_typelike.t0000644000175100017510000000403211726772157014770 0ustar adamadam#!/usr/bin/perl use strict; BEGIN { $| = 1; $^W = 1; $ENV{PERL_PARAMS_UTIL_PP} ||= 1; } use Test::More tests => 44; use Scalar::Util 'refaddr'; use File::Spec::Functions ':ALL'; use Params::Util qw{_ARRAYLIKE _HASHLIKE}; # Tests that two objects are the same object sub addr { my $have = shift; my $want = shift; is( refaddr($have), refaddr($want), 'Objects are the same object' ); } my $listS = bless \do { my $i } => 'Foo::Listy'; my $hashS = bless \do { my $i } => 'Foo::Hashy'; my $bothS = bless \do { my $i } => 'Foo::Bothy'; my $listH = bless {} => 'Foo::Listy'; my $hashH = bless {} => 'Foo::Hashy'; my $bothH = bless {} => 'Foo::Bothy'; my $listA = bless [] => 'Foo::Listy'; my $hashA = bless [] => 'Foo::Hashy'; my $bothA = bless [] => 'Foo::Bothy'; my @data = (# A H [ undef , 0, 0, 'undef' ], [ 1000 => 0, 0, '1000' ], [ 'Foo' => 0, 0, '"Foo"' ], [ [] => 1, 0, '[]' ], [ {} => 0, 1, '{}' ], [ $listS => 1, 0, 'scalar-based Foo::Listy' ], [ $hashS => 0, 1, 'scalar-based Foo::Hashy' ], [ $bothS => 1, 1, 'scalar-based Foo::Bothy' ], [ $listH => 1, 1, 'hash-based Foo::Listy' ], [ $hashH => 0, 1, 'hash-based Foo::Hashy' ], [ $bothH => 1, 1, 'hash-based Foo::Bothy' ], [ $listA => 1, 0, 'array-based Foo::Listy' ], [ $hashA => 1, 1, 'array-based Foo::Hashy' ], [ $bothA => 1, 1, 'array-based Foo::Bothy' ], ); for my $t (@data) { is( _ARRAYLIKE($t->[0]) ? 1 : 0, $t->[1], "$t->[3] " . ($t->[1] ? 'is' : "isn't") . ' @ish' ); if ( _ARRAYLIKE($t->[0]) ) { addr( _ARRAYLIKE($t->[0]), $t->[0] ); } is( _HASHLIKE( $t->[0]) ? 1 : 0, $t->[2], "$t->[3] " . ($t->[2] ? 'is' : "isn't") . ' %ish' ); if ( _HASHLIKE($t->[0]) ) { addr( _HASHLIKE($t->[0]), $t->[0] ); } } package Foo; # this package is totally unremarkable; package Foo::Listy; use overload '@{}' => sub { [] }, fallback => 1; package Foo::Hashy; use overload '%{}' => sub { {} }, fallback => 1; package Foo::Bothy; use overload '@{}' => sub { [] }, '%{}' => sub { {} }, fallback => 1; Params-Util-1.07/t/07_handle.t0000644000175100017510000000405711726772122014375 0ustar adamadam#!/usr/bin/perl use strict; BEGIN { $| = 1; $^W = 1; $ENV{PERL_PARAMS_UTIL_PP} ||= 0; } use Test::More tests => 23; use File::Spec::Functions ':ALL'; BEGIN { ok( ! defined &_HANDLE, '_HANDLE does not exist' ); use_ok('Params::Util', qw(_HANDLE)); ok( defined &_HANDLE, '_HANDLE imported ok' ); } # Import refaddr to make certain we have it use Scalar::Util 'refaddr'; ##################################################################### # Preparing my $readfile = catfile( 't', 'handles', 'readfile.txt' ); ok( -f $readfile, "$readfile exists" ); my $writefile = catfile( 't', 'handles', 'writefile.txt' ); if ( -f $writefile ) { unlink $writefile }; END { if ( -f $writefile ) { unlink $writefile }; } ok( ! -e $writefile, "$writefile does not exist" ); sub is_handle { my $maybe = shift; my $message = shift || 'Is a file handle'; my $result = _HANDLE($maybe); ok( defined $result, '_HANDLE does not return undef' ); is( refaddr($result), refaddr($maybe), '_HANDLE returns the passed value' ); } sub not_handle { my $maybe = shift; my $message = shift || 'Is not a file handle'; my $result = _HANDLE($maybe); ok( ! defined $result, '_HANDLE returns undef' ); } ##################################################################### # Basic Filesystem Handles # A read filehandle SCOPE: { local *HANDLE; open( HANDLE, $readfile ); is_handle( \*HANDLE, 'Ordinary read filehandle' ); close HANDLE; } # A write filehandle SCOPE: { local *HANDLE; open( HANDLE, "> $readfile" ); is_handle( \*HANDLE, 'Ordinary read filehandle' ); print HANDLE "A write filehandle"; close HANDLE; if ( -f $writefile ) { unlink $writefile }; } # On 5.8+ the new style filehandle SKIP: { skip( "Skipping 5.8-style 'my \$fh' handles", 2 ) if $] < 5.008; open( my $handle, $readfile ); is_handle( $handle, '5.8-style read filehandle' ); } ##################################################################### # Things that are not file handles foreach ( undef, '', ' ', 'foo', 1, 0, -1, 1.23, [], {}, \'', bless( {}, "foo" ) ) { not_handle( $_ ); } Params-Util-1.07/t/05_typelike.t0000644000175100017510000000403211726772122014757 0ustar adamadam#!/usr/bin/perl use strict; BEGIN { $| = 1; $^W = 1; $ENV{PERL_PARAMS_UTIL_PP} ||= 0; } use Test::More tests => 44; use Scalar::Util 'refaddr'; use File::Spec::Functions ':ALL'; use Params::Util qw{_ARRAYLIKE _HASHLIKE}; # Tests that two objects are the same object sub addr { my $have = shift; my $want = shift; is( refaddr($have), refaddr($want), 'Objects are the same object' ); } my $listS = bless \do { my $i } => 'Foo::Listy'; my $hashS = bless \do { my $i } => 'Foo::Hashy'; my $bothS = bless \do { my $i } => 'Foo::Bothy'; my $listH = bless {} => 'Foo::Listy'; my $hashH = bless {} => 'Foo::Hashy'; my $bothH = bless {} => 'Foo::Bothy'; my $listA = bless [] => 'Foo::Listy'; my $hashA = bless [] => 'Foo::Hashy'; my $bothA = bless [] => 'Foo::Bothy'; my @data = (# A H [ undef , 0, 0, 'undef' ], [ 1000 => 0, 0, '1000' ], [ 'Foo' => 0, 0, '"Foo"' ], [ [] => 1, 0, '[]' ], [ {} => 0, 1, '{}' ], [ $listS => 1, 0, 'scalar-based Foo::Listy' ], [ $hashS => 0, 1, 'scalar-based Foo::Hashy' ], [ $bothS => 1, 1, 'scalar-based Foo::Bothy' ], [ $listH => 1, 1, 'hash-based Foo::Listy' ], [ $hashH => 0, 1, 'hash-based Foo::Hashy' ], [ $bothH => 1, 1, 'hash-based Foo::Bothy' ], [ $listA => 1, 0, 'array-based Foo::Listy' ], [ $hashA => 1, 1, 'array-based Foo::Hashy' ], [ $bothA => 1, 1, 'array-based Foo::Bothy' ], ); for my $t (@data) { is( _ARRAYLIKE($t->[0]) ? 1 : 0, $t->[1], "$t->[3] " . ($t->[1] ? 'is' : "isn't") . ' @ish' ); if ( _ARRAYLIKE($t->[0]) ) { addr( _ARRAYLIKE($t->[0]), $t->[0] ); } is( _HASHLIKE( $t->[0]) ? 1 : 0, $t->[2], "$t->[3] " . ($t->[2] ? 'is' : "isn't") . ' %ish' ); if ( _HASHLIKE($t->[0]) ) { addr( _HASHLIKE($t->[0]), $t->[0] ); } } package Foo; # this package is totally unremarkable; package Foo::Listy; use overload '@{}' => sub { [] }, fallback => 1; package Foo::Hashy; use overload '%{}' => sub { {} }, fallback => 1; package Foo::Bothy; use overload '@{}' => sub { [] }, '%{}' => sub { {} }, fallback => 1; Params-Util-1.07/t/17_handle.t0000644000175100017510000000405711726772157014406 0ustar adamadam#!/usr/bin/perl use strict; BEGIN { $| = 1; $^W = 1; $ENV{PERL_PARAMS_UTIL_PP} ||= 1; } use Test::More tests => 23; use File::Spec::Functions ':ALL'; BEGIN { ok( ! defined &_HANDLE, '_HANDLE does not exist' ); use_ok('Params::Util', qw(_HANDLE)); ok( defined &_HANDLE, '_HANDLE imported ok' ); } # Import refaddr to make certain we have it use Scalar::Util 'refaddr'; ##################################################################### # Preparing my $readfile = catfile( 't', 'handles', 'readfile.txt' ); ok( -f $readfile, "$readfile exists" ); my $writefile = catfile( 't', 'handles', 'writefile.txt' ); if ( -f $writefile ) { unlink $writefile }; END { if ( -f $writefile ) { unlink $writefile }; } ok( ! -e $writefile, "$writefile does not exist" ); sub is_handle { my $maybe = shift; my $message = shift || 'Is a file handle'; my $result = _HANDLE($maybe); ok( defined $result, '_HANDLE does not return undef' ); is( refaddr($result), refaddr($maybe), '_HANDLE returns the passed value' ); } sub not_handle { my $maybe = shift; my $message = shift || 'Is not a file handle'; my $result = _HANDLE($maybe); ok( ! defined $result, '_HANDLE returns undef' ); } ##################################################################### # Basic Filesystem Handles # A read filehandle SCOPE: { local *HANDLE; open( HANDLE, $readfile ); is_handle( \*HANDLE, 'Ordinary read filehandle' ); close HANDLE; } # A write filehandle SCOPE: { local *HANDLE; open( HANDLE, "> $readfile" ); is_handle( \*HANDLE, 'Ordinary read filehandle' ); print HANDLE "A write filehandle"; close HANDLE; if ( -f $writefile ) { unlink $writefile }; } # On 5.8+ the new style filehandle SKIP: { skip( "Skipping 5.8-style 'my \$fh' handles", 2 ) if $] < 5.008; open( my $handle, $readfile ); is_handle( $handle, '5.8-style read filehandle' ); } ##################################################################### # Things that are not file handles foreach ( undef, '', ' ', 'foo', 1, 0, -1, 1.23, [], {}, \'', bless( {}, "foo" ) ) { not_handle( $_ ); } Params-Util-1.07/t/09_insideout.t0000644000175100017510000000150411726772122015141 0ustar adamadam#!/usr/bin/perl # Test for a custom isa method that returns the same way that # Object::InsideOut does. use strict; BEGIN { $| = 1; $^W = 1; $ENV{PERL_PARAMS_UTIL_PP} ||= 0; } use Test::More tests => 2; use Scalar::Util (); use Params::Util (); ##################################################################### # Create an object and test it SCOPE: { my $object = Foo->new; ok( Scalar::Util::blessed($object), 'Foo' ); my $instance = Params::Util::_INSTANCE($object, 'Foo'); is( $instance, undef, '_INSTANCE correctly returns undef' ); } ##################################################################### # Create a package to simulate Object::InsideOut CLASS: { package Foo; sub new { my $foo = 1234; my $self = \$foo; bless $self, $_[0]; return $self; } sub isa { return (''); } 1; } Params-Util-1.07/t/handles/0000755000175100017510000000000011726772164014065 5ustar adamadamParams-Util-1.07/t/handles/readfile.txt0000644000175100017510000000002211726772163016372 0ustar adamadamA write filehandleParams-Util-1.07/t/handles/handle.txt0000644000175100017510000000001711726772122016051 0ustar adamadamThis is a file Params-Util-1.07/t/01_compile.t0000644000175100017510000000070311726772122014556 0ustar adamadam#!/usr/bin/perl use 5.00503; use strict; BEGIN { $| = 1; $^W = 1; $ENV{PERL_PARAMS_UTIL_PP} ||= 0; } use Test::More tests => 4; use File::Spec::Functions ':ALL'; # Does the module load use_ok('Params::Util'); # Double check that Scalar::Util is valid require_ok( 'Scalar::Util' ); ok( $Scalar::Util::VERSION >= 1.10, 'Scalar::Util version is at least 1.18' ); ok( defined &Scalar::Util::refaddr, 'Scalar::Util has a refaddr implementation' ); Params-Util-1.07/t/11_compile.t0000644000175100017510000000070311726772157014567 0ustar adamadam#!/usr/bin/perl use 5.00503; use strict; BEGIN { $| = 1; $^W = 1; $ENV{PERL_PARAMS_UTIL_PP} ||= 1; } use Test::More tests => 4; use File::Spec::Functions ':ALL'; # Does the module load use_ok('Params::Util'); # Double check that Scalar::Util is valid require_ok( 'Scalar::Util' ); ok( $Scalar::Util::VERSION >= 1.10, 'Scalar::Util version is at least 1.18' ); ok( defined &Scalar::Util::refaddr, 'Scalar::Util has a refaddr implementation' ); Params-Util-1.07/t/driver/0000755000175100017510000000000011726772164013742 5ustar adamadamParams-Util-1.07/t/driver/E.pm0000644000175100017510000000021511726772122014454 0ustar adamadampackage E; # This is a good class, but not a driver use strict; use vars qw{$VERSION}; BEGIN { $VERSION = '0.01'; } sub dummy { 1 } 1; Params-Util-1.07/t/driver/A.pm0000644000175100017510000000017711726772122014457 0ustar adamadampackage A; # This is our driver class use strict; use vars qw{$VERSION}; BEGIN { $VERSION = '0.01'; } sub dummy { 1 } 1; Params-Util-1.07/t/driver/D.pm0000644000175100017510000000024611726772122014457 0ustar adamadampackage D; # This is our broken driver class use strict; use A (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '0.01'; @ISA = 'A'; } sub dummy { 1 } 0; Params-Util-1.07/t/driver/My_B.pm0000644000175100017510000000032411726772122015117 0ustar adamadam# Don't want to collide with the B:: modules package My_B; # This is our good driver class use strict; use A (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '0.01'; @ISA = 'A'; } sub dummy { 1 } 1; Params-Util-1.07/t/driver/F.pm0000644000175100017510000000044711726772122014464 0ustar adamadampackage F; # This is a driver with a faked ->isa use strict; use vars qw{$VERSION}; BEGIN { $VERSION = '0.01'; } sub isa { my $class = shift; my $parent = shift; if ( defined $parent and ! ref $parent and $parent eq 'A' ) { return !!1; } else { return !1; } } sub dummy { 1 } 1; Params-Util-1.07/t/driver/B.pm0000644000175100017510000000032411726772122014452 0ustar adamadam# Don't want to collide with the B:: modules package My_B; # This is our good driver class use strict; use A (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '0.01'; @ISA = 'A'; } sub dummy { 1 } 1; Params-Util-1.07/t/13_all.t0000644000175100017510000000322611726772157013714 0ustar adamadam#!/usr/bin/perl use strict; BEGIN { $| = 1; $^W = 1; $ENV{PERL_PARAMS_UTIL_PP} ||= 1; } use Test::More tests => 26; use File::Spec::Functions ':ALL'; BEGIN { use_ok( 'Params::Util', ':ALL' ); } ##################################################################### # Is everything imported ok( defined &_STRING, '_STRING imported ok' ); ok( defined &_IDENTIFIER, '_IDENTIFIER imported ok' ); ok( defined &_CLASS, '_CLASS imported ok' ); ok( defined &_CLASSISA, '_CLASSISA imported ok' ); ok( defined &_SUBCLASS, '_SUBCLASS imported ok' ); ok( defined &_DRIVER, '_DRIVER imported ok' ); ok( defined &_NUMBER, '_NUMBER imported ok' ); ok( defined &_POSINT, '_POSINT imported ok' ); ok( defined &_NONNEGINT, '_NONNEGINT imported ok' ); ok( defined &_SCALAR, '_SCALAR imported ok' ); ok( defined &_SCALAR0, '_SCALAR0 imported ok' ); ok( defined &_ARRAY, '_ARRAY imported ok' ); ok( defined &_ARRAY0, '_ARRAY0 imported ok' ); ok( defined &_ARRAYLIKE, '_ARRAYLIKE imported ok' ); ok( defined &_HASH, '_HASH imported ok' ); ok( defined &_HASH0, '_HASH0 imported ok' ); ok( defined &_HASHLIKE, '_HASHLIKE imported ok' ); ok( defined &_CODE, '_CODE imported ok' ); ok( defined &_CODELIKE, '_CODELIKE imported ok' ); ok( defined &_INVOCANT, '_INVOCANT imported ok' ); ok( defined &_INSTANCE, '_INSTANCE imported ok' ); ok( defined &_REGEX, '_REGEX imported ok' ); ok( defined &_SET, '_SET imported ok' ); ok( defined &_SET0, '_SET0 imported ok' ); ok( defined &_HANDLE, '_HANDLE imported ok' ); Params-Util-1.07/t/03_all.t0000644000175100017510000000322611726772122013703 0ustar adamadam#!/usr/bin/perl use strict; BEGIN { $| = 1; $^W = 1; $ENV{PERL_PARAMS_UTIL_PP} ||= 0; } use Test::More tests => 26; use File::Spec::Functions ':ALL'; BEGIN { use_ok( 'Params::Util', ':ALL' ); } ##################################################################### # Is everything imported ok( defined &_STRING, '_STRING imported ok' ); ok( defined &_IDENTIFIER, '_IDENTIFIER imported ok' ); ok( defined &_CLASS, '_CLASS imported ok' ); ok( defined &_CLASSISA, '_CLASSISA imported ok' ); ok( defined &_SUBCLASS, '_SUBCLASS imported ok' ); ok( defined &_DRIVER, '_DRIVER imported ok' ); ok( defined &_NUMBER, '_NUMBER imported ok' ); ok( defined &_POSINT, '_POSINT imported ok' ); ok( defined &_NONNEGINT, '_NONNEGINT imported ok' ); ok( defined &_SCALAR, '_SCALAR imported ok' ); ok( defined &_SCALAR0, '_SCALAR0 imported ok' ); ok( defined &_ARRAY, '_ARRAY imported ok' ); ok( defined &_ARRAY0, '_ARRAY0 imported ok' ); ok( defined &_ARRAYLIKE, '_ARRAYLIKE imported ok' ); ok( defined &_HASH, '_HASH imported ok' ); ok( defined &_HASH0, '_HASH0 imported ok' ); ok( defined &_HASHLIKE, '_HASHLIKE imported ok' ); ok( defined &_CODE, '_CODE imported ok' ); ok( defined &_CODELIKE, '_CODELIKE imported ok' ); ok( defined &_INVOCANT, '_INVOCANT imported ok' ); ok( defined &_INSTANCE, '_INSTANCE imported ok' ); ok( defined &_REGEX, '_REGEX imported ok' ); ok( defined &_SET, '_SET imported ok' ); ok( defined &_SET0, '_SET0 imported ok' ); ok( defined &_HANDLE, '_HANDLE imported ok' );