diff options
| -rw-r--r-- | Changes | 195 | ||||
| -rw-r--r-- | LICENSE | 398 | ||||
| -rw-r--r-- | MANIFEST | 39 | ||||
| -rw-r--r-- | META.json | 45 | ||||
| -rw-r--r-- | META.yml | 26 | ||||
| -rw-r--r-- | MYMETA.json | 45 | ||||
| -rw-r--r-- | Makefile.PL | 233 | ||||
| -rw-r--r-- | README | 398 | ||||
| -rw-r--r-- | Util.xs | 369 | ||||
| -rw-r--r-- | lib/Params/Util.pm | 866 | ||||
| -rw-r--r-- | t/01_compile.t | 20 | ||||
| -rw-r--r-- | t/02_main.t | 917 | ||||
| -rw-r--r-- | t/03_all.t | 56 | ||||
| -rw-r--r-- | t/04_codelike.t | 134 | ||||
| -rw-r--r-- | t/05_typelike.t | 87 | ||||
| -rw-r--r-- | t/06_invocant.t | 59 | ||||
| -rw-r--r-- | t/07_handle.t | 95 | ||||
| -rw-r--r-- | t/08_driver.t | 127 | ||||
| -rw-r--r-- | t/09_insideout.t | 53 | ||||
| -rw-r--r-- | t/11_compile.t | 20 | ||||
| -rw-r--r-- | t/12_main.t | 917 | ||||
| -rw-r--r-- | t/13_all.t | 56 | ||||
| -rw-r--r-- | t/14_codelike.t | 134 | ||||
| -rw-r--r-- | t/15_typelike.t | 87 | ||||
| -rw-r--r-- | t/16_invocant.t | 59 | ||||
| -rw-r--r-- | t/17_handle.t | 95 | ||||
| -rw-r--r-- | t/18_driver.t | 127 | ||||
| -rw-r--r-- | t/19_insideout.t | 53 | ||||
| -rw-r--r-- | t/driver/A.pm | 14 | ||||
| -rw-r--r-- | t/driver/B.pm | 17 | ||||
| -rw-r--r-- | t/driver/D.pm | 16 | ||||
| -rw-r--r-- | t/driver/E.pm | 14 | ||||
| -rw-r--r-- | t/driver/F.pm | 24 | ||||
| -rw-r--r-- | t/driver/My_B.pm | 17 | ||||
| -rw-r--r-- | t/handles/handle.txt | 1 | ||||
| -rw-r--r-- | t/handles/readfile.txt | 1 | ||||
| -rw-r--r-- | xt/meta.t | 27 | ||||
| -rw-r--r-- | xt/pmv.t | 32 | ||||
| -rw-r--r-- | xt/pod.t | 32 |
39 files changed, 5905 insertions, 0 deletions
@@ -0,0 +1,195 @@ +Revision 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 @@ -0,0 +1,398 @@ + +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 + + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..ebc596a --- /dev/null +++ b/MANIFEST @@ -0,0 +1,39 @@ +Changes +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) diff --git a/META.json b/META.json new file mode 100644 index 0000000..0dbad84 --- /dev/null +++ b/META.json @@ -0,0 +1,45 @@ +{ + "abstract" : "Simple, compact and correct param-checking functions", + "author" : [ + "Adam Kennedy <adamk@cpan.org>" + ], + "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" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..2f2a561 --- /dev/null +++ b/META.yml @@ -0,0 +1,26 @@ +--- +abstract: 'Simple, compact and correct param-checking functions' +author: + - 'Adam Kennedy <adamk@cpan.org>' +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 diff --git a/MYMETA.json b/MYMETA.json new file mode 100644 index 0000000..9d9b9cc --- /dev/null +++ b/MYMETA.json @@ -0,0 +1,45 @@ +{ + "abstract" : "Simple, compact and correct param-checking functions", + "author" : [ + "Adam Kennedy <adamk@cpan.org>" + ], + "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" +} diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..8731ae8 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,233 @@ +use 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 = <FILE>; + 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 <adamk@cpan.org>', + 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; +} @@ -0,0 +1,398 @@ +NAME + 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 + + <http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Params-Util> + + For other issues, contact the author. + +AUTHOR + Adam Kennedy <adamk@cpan.org> + +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. + @@ -0,0 +1,369 @@ +#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; +} + diff --git a/lib/Params/Util.pm b/lib/Params/Util.pm new file mode 100644 index 0000000..9a40e59 --- /dev/null +++ b/lib/Params/Util.pm @@ -0,0 +1,866 @@ +package Params::Util; + +=pod + +=head1 NAME + +Params::Util - Simple, compact and correct param-checking functions + +=head1 SYNOPSIS + + # Import some functions + use Params::Util qw{_SCALAR _HASH _INSTANCE}; + + # If you are lazy, or need a lot of them... + use Params::Util ':ALL'; + + sub foo { + my $object = _INSTANCE(shift, 'Foo') or return undef; + my $image = _SCALAR(shift) or return undef; + my $options = _HASH(shift) or return undef; + # etc... + } + +=head1 DESCRIPTION + +C<Params::Util> provides a basic set of importable functions that makes +checking parameters a hell of a lot easier + +While they can be (and are) used in other contexts, the main point +behind this module is that the functions B<both> Do What You Mean, +and Do The Right Thing, so they are most useful when you are getting +params passed into your code from someone and/or somewhere else +and you can't really trust the quality. + +Thus, C<Params::Util> is of most use at the edges of your API, where +params and data are coming in from outside your code. + +The functions provided by C<Params::Util> check in the most strictly +correct manner known, are documented as thoroughly as possible so their +exact behaviour is clear, and heavily tested so make sure they are not +fooled by weird data and Really Bad Things. + +To use, simply load the module providing the functions you want to use +as arguments (as shown in the SYNOPSIS). + +To aid in maintainability, C<Params::Util> will B<never> export by +default. + +You must explicitly name the functions you want to export, or use the +C<:ALL> param to just have it export everything (although this is not +recommended if you have any _FOO functions yourself with which future +additions to C<Params::Util> may clash) + +=head1 FUNCTIONS + +=cut + +use 5.00503; +use strict; +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<undef> 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<undef> 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<D'Oh>. + +Returns the string as a convenience if it is a valid class name, or +C<undef> 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 -E<gt>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 C<::Foo> or C<D'Oh>. + +Returns the string as a convenience if it is a valid class name, or +C<undef> 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<L</_CLASSISA>>, but checks with C<< ->DOES +>> rather than C<< ->isa >>. This is probably only a good idea to use on Perl +5.10 or later, when L<UNIVERSAL::DOES|UNIVERSAL::DOES/DOES> has been +implemented. + +=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 -E<gt>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 C<::Foo> or C<D'Oh>. + +Returns the string as a convenience if it is a valid class name, or +C<undef> 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<Scalar::Util> C<looks_like_number> function. + +Returns the value as a convience, or C<undef> 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<undef> 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<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. + +=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<SCALAR> reference, with content of non-zero length. + +For a version that allows zero length C<SCALAR> references, see +the C<_SCALAR0> function. + +Returns the C<SCALAR> reference itself as a convenience, or C<undef> +if the value provided is not a C<SCALAR> reference. + +=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<SCALAR0> reference, allowing content of zero-length. + +For a simpler "give me some content" version that requires non-zero +length, C<_SCALAR> function. + +Returns the C<SCALAR> reference itself as a convenience, or C<undef> +if the value provided is not a C<SCALAR> reference. + +=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<ARRAY> reference containing B<at least> one element of any kind. + +For a more basic form that allows zero length ARRAY references, see +the C<_ARRAY0> function. + +Returns the C<ARRAY> reference itself as a convenience, or C<undef> +if the value provided is not an C<ARRAY> reference. + +=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<ARRAY> reference, allowing C<ARRAY> references that contain no +elements. + +For a more basic "An array of something" form that also requires at +least one element, see the C<_ARRAY> function. + +Returns the C<ARRAY> reference itself as a convenience, or C<undef> +if the value provided is not an C<ARRAY> reference. + +=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<undef>. + +=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<HASH> reference with at least one entry. + +For a version of this function that allows the C<HASH> to be empty, +see the C<_HASH0> function. + +Returns the C<HASH> reference itself as a convenience, or C<undef> +if the value provided is not an C<HASH> reference. + +=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<HASH> reference, regardless of the C<HASH> content. + +For a simpler "A hash of something" version that requires at least one +element, see the C<_HASH> function. + +Returns the C<HASH> reference itself as a convenience, or C<undef> +if the value provided is not an C<HASH> reference. + +=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<undef>. + +=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<CODE> reference. + +Returns the C<CODE> reference itself as a convenience, or C<undef> +if the value provided is not an C<CODE> 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<CODE> reference, the C<_CODELIKE> function +also includes things that act like them, such as blessed objects that +overload C<'&{}'>. + +Please note that in the case of objects overloaded with '&{}', you will +almost always end up also testing it in 'bool' context at some stage. + +For example: + + sub foo { + my $code1 = _CODELIKE(shift) or die "No code param provided"; + my $code2 = _CODELIKE(shift); + if ( $code2 ) { + print "Got optional second code param"; + } + } + +As such, you will most likely always want to make sure your class has +at least the following to allow it to evaluate to true in boolean +context. + + # Always evaluate to true in boolean context + use overload 'bool' => sub () { 1 }; + +Returns the callable value as a convenience, or C<undef> if the +value provided is not callable. + +Note - This function was formerly known as _CALLABLE but has been renamed +for greater symmetry with the other _XXXXLIKE functions. + +The use of _CALLABLE has been deprecated. It will continue to work, but +with a warning, until end-2006, then will be removed. + +I 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<undef>. + +=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<undef> 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<L</_INSTANCE>>, but checks with C<< ->DOES +>> rather than C<< ->isa >>. This is probably only a good idea to use on Perl +5.10 or later, when L<UNIVERSAL::DOES|UNIVERSAL::DOES/DOES> has been +implemented. + +=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<undef> 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<ARRAY> of objects of the +class provided. + +For an alternative function that allows zero-length sets, see the +C<_SET0> function. + +Returns the C<ARRAY> reference itself as a convenience, or C<undef> if +the value provided is not a set of that class. + +=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<ARRAY> of objects of the +class provided. + +For an alternative function that requires at least one object, see the +C<_SET> function. + +Returns the C<ARRAY> reference itself as a convenience, or C<undef> if +the value provided is not a set of that class. + +=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<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. + +=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<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Params-Util> + +For other issues, contact the author. + +=head1 AUTHOR + +Adam Kennedy E<lt>adamk@cpan.orgE<gt> + +=head1 SEE ALSO + +L<Params::Validate> + +=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 diff --git a/t/01_compile.t b/t/01_compile.t new file mode 100644 index 0000000..e375547 --- /dev/null +++ b/t/01_compile.t @@ -0,0 +1,20 @@ +#!/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' ); diff --git a/t/02_main.t b/t/02_main.t new file mode 100644 index 0000000..64ef1e4 --- /dev/null +++ b/t/02_main.t @@ -0,0 +1,917 @@ +#!/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; diff --git a/t/03_all.t b/t/03_all.t new file mode 100644 index 0000000..0f8aab7 --- /dev/null +++ b/t/03_all.t @@ -0,0 +1,56 @@ +#!/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' ); diff --git a/t/04_codelike.t b/t/04_codelike.t new file mode 100644 index 0000000..2762c71 --- /dev/null +++ b/t/04_codelike.t @@ -0,0 +1,134 @@ +#!/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; +} diff --git a/t/05_typelike.t b/t/05_typelike.t new file mode 100644 index 0000000..f5f4391 --- /dev/null +++ b/t/05_typelike.t @@ -0,0 +1,87 @@ +#!/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; diff --git a/t/06_invocant.t b/t/06_invocant.t new file mode 100644 index 0000000..2722c63 --- /dev/null +++ b/t/06_invocant.t @@ -0,0 +1,59 @@ +#!/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; +} diff --git a/t/07_handle.t b/t/07_handle.t new file mode 100644 index 0000000..9925b59 --- /dev/null +++ b/t/07_handle.t @@ -0,0 +1,95 @@ +#!/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( $_ ); +} + diff --git a/t/08_driver.t b/t/08_driver.t new file mode 100644 index 0000000..eaef76e --- /dev/null +++ b/t/08_driver.t @@ -0,0 +1,127 @@ +#!/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' ); +} diff --git a/t/09_insideout.t b/t/09_insideout.t new file mode 100644 index 0000000..90cb327 --- /dev/null +++ b/t/09_insideout.t @@ -0,0 +1,53 @@ +#!/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; +} diff --git a/t/11_compile.t b/t/11_compile.t new file mode 100644 index 0000000..e11f727 --- /dev/null +++ b/t/11_compile.t @@ -0,0 +1,20 @@ +#!/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' ); diff --git a/t/12_main.t b/t/12_main.t new file mode 100644 index 0000000..d8cf68f --- /dev/null +++ b/t/12_main.t @@ -0,0 +1,917 @@ +#!/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; diff --git a/t/13_all.t b/t/13_all.t new file mode 100644 index 0000000..90c2618 --- /dev/null +++ b/t/13_all.t @@ -0,0 +1,56 @@ +#!/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' ); diff --git a/t/14_codelike.t b/t/14_codelike.t new file mode 100644 index 0000000..58833fe --- /dev/null +++ b/t/14_codelike.t @@ -0,0 +1,134 @@ +#!/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; +} diff --git a/t/15_typelike.t b/t/15_typelike.t new file mode 100644 index 0000000..e45ee98 --- /dev/null +++ b/t/15_typelike.t @@ -0,0 +1,87 @@ +#!/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; diff --git a/t/16_invocant.t b/t/16_invocant.t new file mode 100644 index 0000000..4a14e74 --- /dev/null +++ b/t/16_invocant.t @@ -0,0 +1,59 @@ +#!/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; +} diff --git a/t/17_handle.t b/t/17_handle.t new file mode 100644 index 0000000..39d7b35 --- /dev/null +++ b/t/17_handle.t @@ -0,0 +1,95 @@ +#!/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( $_ ); +} + diff --git a/t/18_driver.t b/t/18_driver.t new file mode 100644 index 0000000..3cf1c2b --- /dev/null +++ b/t/18_driver.t @@ -0,0 +1,127 @@ +#!/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' ); +} diff --git a/t/19_insideout.t b/t/19_insideout.t new file mode 100644 index 0000000..f2fc781 --- /dev/null +++ b/t/19_insideout.t @@ -0,0 +1,53 @@ +#!/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; +} diff --git a/t/driver/A.pm b/t/driver/A.pm new file mode 100644 index 0000000..7aeb627 --- /dev/null +++ b/t/driver/A.pm @@ -0,0 +1,14 @@ +package A; + +# This is our driver class + +use strict; + +use vars qw{$VERSION}; +BEGIN { + $VERSION = '0.01'; +} + +sub dummy { 1 } + +1; diff --git a/t/driver/B.pm b/t/driver/B.pm new file mode 100644 index 0000000..eb8ccbf --- /dev/null +++ b/t/driver/B.pm @@ -0,0 +1,17 @@ +# 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; diff --git a/t/driver/D.pm b/t/driver/D.pm new file mode 100644 index 0000000..1b147a5 --- /dev/null +++ b/t/driver/D.pm @@ -0,0 +1,16 @@ +package 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; diff --git a/t/driver/E.pm b/t/driver/E.pm new file mode 100644 index 0000000..ad7d060 --- /dev/null +++ b/t/driver/E.pm @@ -0,0 +1,14 @@ +package E; + +# This is a good class, but not a driver + +use strict; + +use vars qw{$VERSION}; +BEGIN { + $VERSION = '0.01'; +} + +sub dummy { 1 } + +1; diff --git a/t/driver/F.pm b/t/driver/F.pm new file mode 100644 index 0000000..e7592d6 --- /dev/null +++ b/t/driver/F.pm @@ -0,0 +1,24 @@ +package 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; diff --git a/t/driver/My_B.pm b/t/driver/My_B.pm new file mode 100644 index 0000000..eb8ccbf --- /dev/null +++ b/t/driver/My_B.pm @@ -0,0 +1,17 @@ +# 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; diff --git a/t/handles/handle.txt b/t/handles/handle.txt new file mode 100644 index 0000000..0637880 --- /dev/null +++ b/t/handles/handle.txt @@ -0,0 +1 @@ +This is a file diff --git a/t/handles/readfile.txt b/t/handles/readfile.txt new file mode 100644 index 0000000..a98faff --- /dev/null +++ b/t/handles/readfile.txt @@ -0,0 +1 @@ +A write filehandle
\ No newline at end of file diff --git a/xt/meta.t b/xt/meta.t new file mode 100644 index 0000000..2f8b2c7 --- /dev/null +++ b/xt/meta.t @@ -0,0 +1,27 @@ +#!/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(); diff --git a/xt/pmv.t b/xt/pmv.t new file mode 100644 index 0000000..f285be3 --- /dev/null +++ b/xt/pmv.t @@ -0,0 +1,32 @@ +#!/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(); diff --git a/xt/pod.t b/xt/pod.t new file mode 100644 index 0000000..170cae0 --- /dev/null +++ b/xt/pod.t @@ -0,0 +1,32 @@ +#!/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(); |