diff options
| author | Lorry Tar Creator <lorry-tar-importer@lorry> | 2015-06-28 14:34:36 +0000 |
|---|---|---|
| committer | Lorry Tar Creator <lorry-tar-importer@lorry> | 2015-06-28 14:34:36 +0000 |
| commit | 11197f6fc2fdd0d2a139a74ff1302244c4911e4e (patch) | |
| tree | c5e13a504c33aa05b559c860f90eb8270d3e73c4 | |
| download | Params-Validate-tarball-11197f6fc2fdd0d2a139a74ff1302244c4911e4e.tar.gz | |
Params-Validate-1.20HEADParams-Validate-1.20master
124 files changed, 21410 insertions, 0 deletions
diff --git a/Build.PL b/Build.PL new file mode 100644 index 0000000..badcae7 --- /dev/null +++ b/Build.PL @@ -0,0 +1,95 @@ + +# This file was automatically generated by inc::MyModuleBuild v(dev). +use strict; +use warnings; + +use Module::Build 0.28; + + +my %module_build_args = ( + "build_requires" => { + "Module::Build" => "0.28" + }, + "c_source" => "c", + "configure_requires" => { + "Module::Build" => "0.28" + }, + "dist_abstract" => "Validate method/function parameters", + "dist_author" => [ + "Dave Rolsky <autarch\@urth.org>", + "Ilya Martynov <ilya\@martynov.org>" + ], + "dist_name" => "Params-Validate", + "dist_version" => "1.20", + "license" => "artistic_2", + "module_name" => "Params::Validate", + "recommends" => {}, + "recursive_test_files" => 1, + "requires" => { + "Attribute::Handlers" => "0.79", + "Carp" => 0, + "Exporter" => 0, + "Module::Implementation" => 0, + "Scalar::Util" => "1.10", + "XSLoader" => 0, + "attributes" => 0, + "perl" => "5.008001", + "strict" => 0, + "vars" => 0, + "warnings" => 0 + }, + "script_files" => [], + "test_requires" => { + "Devel::Peek" => 0, + "ExtUtils::MakeMaker" => 0, + "File::Spec" => 0, + "File::Temp" => 0, + "Test::Fatal" => 0, + "Test::More" => "0.96", + "Test::Requires" => 0, + "Tie::Array" => 0, + "Tie::Hash" => 0, + "base" => 0, + "lib" => 0, + "overload" => 0 + } +); + + +my %fallback_build_requires = ( + "Devel::Peek" => 0, + "ExtUtils::MakeMaker" => 0, + "File::Spec" => 0, + "File::Temp" => 0, + "Module::Build" => "0.28", + "Test::Fatal" => 0, + "Test::More" => "0.96", + "Test::Requires" => 0, + "Tie::Array" => 0, + "Tie::Hash" => 0, + "base" => 0, + "lib" => 0, + "overload" => 0 +); + + +unless ( eval { Module::Build->VERSION(0.4004) } ) { + delete $module_build_args{test_requires}; + $module_build_args{build_requires} = \%fallback_build_requires; +} + +my $build = Module::Build->new(%module_build_args); + +my $skip_xs; +if ( grep { $_ eq '--pp' } @ARGV ) { + $skip_xs = 1; +} +elsif ( ! $build->have_c_compiler() ) { + $skip_xs = 1; +} + +if ($skip_xs) { + $build->build_elements( + [ grep { $_ ne 'xs' } @{ $build->build_elements() } ] ); +} +$build->create_build_script; @@ -0,0 +1,860 @@ +1.20 2015-06-28 + +- Fixed a bug with stack handling in the XS code. If a callback sub caused + Perl to reallocate the stack this could trigger weird errors of the form + "Bizarre copy of ARRAY" from Perl itself. Fixed by Noel Maddy. GH #5. + +- Fixed use of inlining in the XS code to work when "gcc -std=c89" is + specified. Fixed by Vincent Pit. GH #6. + +- Previously, Params::Validate would eagerly stringify all values it was + validating, even though this stringification was only needed for error + messages that are used when a parameter fails. For objects which overload + stringification and do real work, this added an unnecessary + slowdown. Stringification is now delayed until it is needed. Reported by + Klaus. RT #105326. + + +1.19 2015-06-12 + +- Fixed an uninitialized value warning from the pure Perl implementation under + 5.8.8. Reported by Jim Bacon. RT #105198. + + +1.18 2015-02-13 + +- We no longer attempt to save and restore an existing $SIG{__DIE__} hook + before calling a validation callback. This uses undocumented black magic + poking at the Perl interpreter guts, which seems to cause sporadic + segfaults. Reported by David Wheeler with help from Andreas Koenig. RT + #102112. + + +1.17 2015-01-08 + +- More XS fixes. Simplified how we localize $@ in the XS code and fixed error + with Perls compiled with -DDEBUGGING. Reported by Lars Dɪᴇᴄᴋᴏᴡ. RT #101416. + + +1.16 2015-01-07 + +- The changes in 1.14 introduced a memory leak any time a callback was called + and it did not throw an error that was a reference. This affected the + DateTime constructor and probably many other things. Reported by David + Kayal. RT #101380. + + +1.15 2015-01-01 + +- No changes from 1.14 + + +1.14 2014-12-20 (TRIAL RELEASE) + +- Callbacks can now die to provide a custom error message or exception + object. Requested by multiple people. Addresses RT #95701 and will allow + MooseX::Params::Validate to use messages provided by the type object. + + +1.13 2014-06-28 + +- Fix my brain damage so that this code compiles with Perl 5.14. + + +1.12 2014-06-27 + +- Temporarily skip tests that use Readonly with Readonly 1.50+ until various + bugs are worked out in Readonly. + + +1.11 2014-06-26 + +- Fixes for MSVC compilation. Patch by J.R. Mash. PR #1. + + +1.10 2014-05-11 + +- Require Readonly 1.03+ and Scalar::Util 1.20 for testing with + Readonly. AFAICT, earlier versions of Readonly worked very differently, + and/or this is related to Scalar::Util. Either way, this test isn't that + important anyway. RT #95402. + + +1.09 2014-05-04 + +- A call to validate() where the spec was a reference to a Readonly hash would + segfault. Reported by Salvatore Bonaccorso. RT #80572. + +- When using the XS implementation, attempting to validate parameters with + tainted values would cause an "Insecure dependency in eval_sv() while + running with -T switch" exception from Perl *if the validation failed*. This + is fixed, but only for Perl 5.14+. Older Perls do not include the necessary + XS API. RT #70174. + +- Fixed some potential segfaults from the XS implementation including the one + reported by Анатолий Гришаев in RT #50412. However, the XS code in general + is pretty crufty and tends to assume that values which could be NULL aren't. + +- Fixed bad example of state() in POD. Reported by Salvatore Bonaccorso. RT + #80250. + + +1.08 2013-06-07 + +- The handling of defaults in the XS version of validate_pos was broken. The + default were simply pushed into the returned array, rather than being + explicitly stored in the right index based on the order of the specs passed + to validate_pos(). RT #83780. + + +1.07 2012-10-26 + +- Params::Validate's XS implementation would overwrite $@ when validation subs + were called. Patch by Salvador Fandino. RT #80124. + +- The use of state in the POD was broken. It only works with scalars. Reported + by Salvatore Bonaccorso. RT #80250. + + +1.06 2012-02-10 + +- Shut up warnings when XS is loaded on older 5.8.x Perl versions. Reported by + Aaron James Trevena. RT #74742. + + +1.05 2012-02-08 + +- The XS code had a code path where it could pass the contents of a Perl + variable as the first argument to the XS croak() subroutine. This subroutine + is like printf(), and should receive a format string as its first + argument. According to RT #74777, this can lead to segfaults on some systems. + + This could in theory be a security bug, but it's very unlikely that + untrusted user input could end up being passed to this croak(). It is called + when a spec specifies a "depend" value on another parameter. The value of + the "depend" parameter was passed in the first argument to croak(). + + Reported by Andreas Voegele. + + +1.04 2012-02-08 + +- Use the latest Module::XSOrPP dzil plugin to generate a saner Build.PL. No + need update if you're using an earlier version. + + +1.03 2012-02-06 + +- This release uses Module::Implementation to handle loading the XS or pure + Perl implementation of Params::Validate. + + +1.02 2012-02-06 + +- The previous release never loaded the XS implementation, even if it had been + compiled. + +- With newer versions of Perl, the pure Perl implementation treated regexp + objects differently than the XS implementation. They should be treated as + belonging to the SCALARREF type for backwards compatibility. + +- These two bugs combined managed to break the test suites of a number of + modules on CPAN. This release should fix them. + + +1.01 2012-02-05 + +- The generated Build.PL detects whether or not the machine it's run on has a + working compiler, and disables XS automatically if it doesn't. Fixes RT + #44719. + + +1.00 2011-06-11 + +- Fix documentation indexing on search.cpan.org. Reported by Lutz Gehlen. RT + #68756. + + +0.99 2011-05-27 + +- The metadata file - META.{json,yml} - had references to a different distro + because of a copy and paste error. Reported by Bernhad Graf. RT #68514. + + +0.98 2011-04-23 + +- Attribute::Params::Validate's $VERSION regressed in 0.96. It now manually + set to 1.07. Reported by tokuhirom. RT #67715. + + +0.97 2011-04-19 + +- The spec validation added in 0.96 broke MooseX::Params::Validate, so it has + been removed until I can work out how to make the two modules play nice. + + +0.96 2011-04-19 + +- The XS version of the code always called Carp::confess, regardless of + whether you provided your own on_fail callback. Reported by Scott Bolte. RT + #66359. + +- There were a couple spots that called eval without localizing $@ first. RT + #58087. + +- The parameters for each key validation (can, isa, regex) are now checked, + and an error is thrown if any of the keys are not valid. Basically, we + validate the validation spec. Based on a patch by Andreas Faafeng. RT + #57831. + +- Lots of little pod fixes. RT #61002. + +- This module now requires Perl 5.8.1. + +- Switched to version 2.0 of the Artistic License. + + +0.95 2010-02-16 + +- Skip t/29-taint-mode.t entirely, since it seems to randomly fail for people, + despite already being marked a todo test. + + +0.94 2009-12-01 + +- Removed the Makefile.PL entirely. If it was used then the XS code was never + built, because I'm using the Module::Build XS layout. Reported by jawnsy on + IRC. + + +0.93 2009-11-30 + +- If the pure Perl version of validate() received a hash reference it would + alter that reference directly. Reported by Paul Eckhardt. RT #51155. + +- Author-only tests now only run if $ENV{AUTHOR_TESTING} is true. RT #49890. + + +0.92 2009-09-25 + +- Switched to Module::Build and don't try to detect a compiler. If you want to + force a Perl-only build, run the Build.PL as "perl Build.PL --pp". Addresses + RT #44719 (more or less), Reported by Olivier Mengué. + +- Require Scalar::Util 1.10, since that is the first version with + looks_like_number. Reported by Olivier Mengué. RT #45103. + +- Require Attribute::Handlers 0.79. Reported by Olivier Mengué. RT #44066. + + +0.91 2008-05-03 + +- The fix for handling @_'s readonly-ness introduced a refcounting + bug. One symptom of this was a failing Log::Dispatch test. Reported + by Andreas Koenig. RT #35608. + + +0.90 2008-05-01 + +- Make the XS version of Params::Validate recognize regexp objects + with Perl 5.11.0-to-be. Patch by Andreas Koenig. RT #32872. + +- With the XS version, when you passed @_ directly to validate() and + then got a hash reference back, the values of that hash reference + would be marked readonly. Reported by W J Moore. RT #34410. + + +0.89 2007-10-31 + +- With validation turned off, the pure Perl version incorrectly + ignored an odd number of parameters when a hash was expected (no + validation still does the bare minimum of checks needed to set + defaults). + +- Added pod & pod coverage tests. + +- Modernized test suite to use Test::More and fixed some test suite + bugs along the way. + +- Attribute::Params::Validate would die when given a ValidatePos + attribute containing one element. + +- More tests are skipped on 5.6.0. + + +0.88 2007-03-07 + +- The XS version threw an error when it attempted to do "isa" or "can" + validation on a value that was not a string or object, such as undef + or a number. Reported by Steffen Winkler. RT #25229. + +- Fixed a compilation failure with bleadperl (5.9.x) that happened + because of a new scalar type introduced in blead. Patch by Nicholas + Clark. Fixes RT #24458. + + +0.87 2007-01-18 + +- When determining the caller of a function in the XS version, use + Perl's caller() function rather than CopSTASHPV. The caller() + function apparently ignores the DB package, whereas the latter + doesn't. This caused validate_options to be ignored when running + under profiling (and probably the debugger as well). Thanks to Jeff + Weisberg for pointing this out. + + +0.86 2006-08-09 + +* I cannot get this module to compile with Perl 5.00504 any more. I + get errors from including CORE/perl.h, so the problem may be outside + my control, but help is welcome. + +- Only turn inlining on if __GNUC__ is defined, since it seems that so + many other compilers don't support this. RT #20881. + +- Removed spaces in #define, #ifdef, etc. Suggested by Peter + Marquardt. + +- If a type is specified as a string ('SCALAR', not SCALAR), this is + now caught and a useful error is thrown. RT #9660. + + +0.85 2006-06-07 + +- Compiles without warnings under gcc's -Wall. Warnings reported by + Scott Godin. + +- Turned off inlining with HP-UX compiler. RT #19763. + + +0.84 2006-05-29 + +- The XS version of the code used Carp::croak to report failures, + while the Perl version used Carp::confess. The module has always + been documented as using confess, so now the XS version uses this. + +- The new compiler detection code always returned false if you didn't + have ExtUtils::CBuilder installed. + + +0.83 2006-05-28 + +- Change how C compiler detection is done in the Makefile.PL so it + does not rely on having make on the system. The new way should work + on (most?) Unix and Win32 systems. Suggested by David Golden. See RT + 18969 (for DateTime.pm, but equally applicable to this module). Will + hopefully fix RT 17644. + +- Previously, if a parameter was undefined, regex checks for that + parameter always failed. However, it's quite possible for a regex to + successfully match an undefined value (qr/^$/, for example). Now the + code treats undef as an empty string ('') in regex checks. Reported + by Duncan Salada. + + +0.82 2006-05-09 + +- Disabled function inlining if _MSC_VER is defined. Patch from Audrey + Tang. + +- Check isa by calling it as a method on the thing being checked. + +- Do the same for can in the pure Perl version. This was already fixed + for the XS version in 0.75. + + +0.81 2006-04-01 + +- Speed up no validation in XS version by short-circuiting immediately + if validation is off. This gives a noticeable speed boost when + $ENV{NO_VALIDATION} is in use. Patch by Daisuke Maki. + +- Inlined some C functions for additional speed in the XS + version. Patch by Daisuke Maki. + + +0.80 2006-01-22 + +- If a undef value was given for a parameter that had a regex in its + spec, a warning was emitted. RT #15196. + + +0.79 2006-01-13 + +- The XS version of Params::Validate did not work if a spec hash + reference was marked Readonly using Readonly::XS. + +- Added some tests for using tied values for params or spec, and + discovered that a tied spec causes a segfault, but could not figure + out how to fix this (Grr, Perl magic is a huge pain in the nether + regions). + + +0.78 2005-07-19 + +- If an overloaded object returned false in boolean context, then it + would always fail "can" tests. Patch by Chi-Fung Fan. + + +0.77 2005-04-29 + +- Neither --xs or --pm worked with the Makefile.PL the way they were + supposed to. Reported by Doug Treder. + +- Moved source to my personal SVN repo. + https://svn.urth.org/svn/Params-Validate + +- Updated ppport.h, which allows XS version to work with 5.00504. + This was broken since 0.75, at least. + + +0.76 2004-11-13 + +(The "Cancan some more" release) + +- Make sure that both the XS and Perl versions give the same error + when checking "can" for an undefined value. + + +0.75 2004-11-13 + +(The "Cancan" release) + +- When checking if a parameter has a method, P::V now calls the ->can + method on the parameter, rather than calling UNIVERSAL::can() + directly. Requested by Don Armstrong. + + +0.74 2004-04-04 + +(The "I hate old Perls" release) + +- Sometimes, but not always, Perl 5.00504 and 5.00503 cannot produce a + string value for a glob (as opposed to glob reference) parameter. + This was uncovered by a test in the HTML::Mason test suite, but I + cannot reproduce it in a simple testable form for this test suite. + Sigh ... + + +0.73 2004-03-28 + +(The "YAPC::Taipei release party" release) + +- The minimum number of arguments required was reported incorrectly by + the XS code when a call to validate_pos() failed because too few + parameters were given. Patch from Britton Kerin. + +- Add a new untaint key to the validation spec, which untaints a value + if it passes its validation checks. + + +0.72 2003-12-03 + +- If a normalize_keys callback returns the same normalized key for two + different inputs, Params::Validate will die. + +- The pure Perl implementation had a bug where if the same hash + reference was used for the spec in multiple calls to validate(), + then any call made after a parameter failed a validation check could + exhibit strange behaviors (like parameters passing that shouldn't, + etc.). This was due to the fact that the Perl implementation uses + each() internally, and was leaving the hash's iterator partially + iterated. Reported via an apparent problem with DateTime.pm by Jost + Krieger. + + +0.71 2003-12-02 + +- Suppressed some annoying "subroutine redefined" warnings if the pure + Perl version ended up being loaded after attempting to load the XS + version. + + +0.70 2003-11-23 + +- Any validation call that used a callback leaked memory when using + the XS version. This was introduced in 0.67, when callbacks started + receiving a reference to the parameters as a second argument. + Reported by Eugene van der Pijll. + + +0.69 2003-11-03 + +- The key normalization feature introduced in 0.66 leaked one SV* + every time a parameter _hash_ was run through the XS version of + validate() or validate_with(). This happened if one of + normalize_keys, allow_extra, or ignore_case was set, or if + validate_with() was used. Upgrading is strongly recommended! + Reported by Ruslan. + + +0.68 2003-10-21 + +- Added spiffy new parameter dependency feature. Implemented by + Daisuke Maki. + + +0.67 2003-10-10 + +- The test count for 06-option.t was off. Reported by Christian + Schaffner. + +- Validation callbacks now receive a reference to the (normalized) + parameter hash/array as their second argument. + +- Shut up an "unitialized value in subroutine entry" warning caused by + calling validate_pos() with an undef value in the parameter array. + This was introduced in 0.66. + + +0.66 2003-10-08 + +- Skip a few more tests under Perl 5.6.0. Patch from Christian + Schaffner. + +- Error messages now include the stringified value of the variable + that was invalid. Implemented by Daisuke Maki. + +- Added a new parameter normalization callback feature, the + "normalize_keys" option. Implemented by Daisuke Maki. + +* The "strip_leading" and "ignore_case" options are now + deprecated. Use the new "normalize" feature instead. + + +0.65 2003-08-07 + +- It is now possible to turn validation on and off at runtime. To + make this easier, it can be set via the PERL_NO_VALIDATION + environment variable, or the $Params::Validate::NO_VALIDATION global + variable. Go ahead, shoot yourself in the foot with it! + + +0.64 2003-07-14 + +- Fix an XS compilation error under 5.6.1: + + Validate.xs: In function `validate_isa': + Validate.xs:381: `perl_on_error' undeclared (first use in this function) + + +0.63 2003-07-14 + +- The XS version of validate_with failed if the params key contained + an array reference containing a single hash reference. Since this + works with the pure Perl version, it should work with the XS + version. Reported by Diab Jerius. Bug #2791 on rt.cpan.org. + + +0.62 2003-06-25 + +- Remove a warn() statement left in from debugging. Reported by Shane + McCarron. + + +0.61 2003-06-23 + +- The last release had some debugging code left in which tried to load + Devel::StackTrace. Reported by Iain Truskett. + + +0.60 2003-06-21 + +- Fixed a weird segfault that could occur with Perl 5.6.1 when a + user-defined on_fail callback died with an object as its argument. + This only happened with the XS version of the code. Reported by Ken + Williams. + + The end result is that the version of the XS code that is used with + Perl 5.6.0 and 5.6.1 is slightly slower than that used with 5.00503 + or 5.8.0, as it requires an additional Perl-level wrapper. + +- Use XSLoader in preference to Dynaloader with Perl 5.6.0+. + + +0.59 2003-05-24 + +- If an odd number of parameters was given to validate() in the array + as its first argument, the error given would be different depending + on whether or not the pure Perl or XS version of the code was being + used. + +- Fixed incredibly odd bug that occurred in XS code when tainting was + on with Perl 5.00503. Unfortunately, the only test case that + reliably reproduces this is one of Mason's tests, so no test was + added. + + +0.58 2003-04-03 + +- Fix some compiler warnings from MS Visual Studio 6. Reported by Ron + Hill. + + +0.57 2003-02-28 + +- When called from the main body of a script, the validation routines + would cause an undefined value warning if validation failed. + Reported by Britton Kerin and fixed by Ilya Martynov. + + +0.56 2003-02-24 + +- The XS code that handled callbacks expected all callbacks to return + an integer, instead of simply testing the returned value for truth. + This could cause strange warnings like 'Argument "InMemory" isn't + numeric in subroutine entry...'. Based on a bug report from Robert + Dick for another module I wrote (Lingua::ZH::CCDICT). + + +0.55 2003-02-21 + +- Fixed Params::Validate for Perl configurations where sizeof(IV) != + sizeof(int). Reported by Alain Barbet. + + +0.54 2003-02-20 + +- Something around test 5 in 06-options.t appear to cause Perl to + die/segfault/something under 5.6.0. These tests will be skipped + with 5.6.0 in the future. Reported by Christian Schaffner. + + +0.53 2003-02-19 + +- When testing for a compiler, use nmake on Win32. Implemented by + Ronald Hill. + + +0.52 2003-02-14 + +- Added regex validation option. + + +0.51 2003-01-14 + +- Added copyright info to each source file. Added LICENSE file to + distro. + + +0.50 2003-01-09 + +- Added an XS implementation, written by Ilya Martynov. The pure Perl + implementation is still included as a fallback for users who do not + have a compiler handy. The XS implementation gives a speed boost of + 150% to 300%, depending on the complexity of the validation being + done. + + This XS code is known to work Perl 5.00503+, but it may not work + with earlier versions of Perl. + + +0.24 2002-07-19 + +- Fix Attribute::Params::Validate docs to show that attribute + declaration must have open paren immediately after "Validate" or + "ValidatePos". Reported by Britton Kerin. + +- Fix bug with Perl 5.8.0 when in PERL_NO_VALIDATION mode and calling + validate() expecting a hash ref to be returned. Reported by Randal + Schwartz. + + +0.23 2002-07-19 + +- Argh. In 0.22 some of the tests printed their test counts (1..x) + after doing the tests. This works with newer versions of + Test::Harness so I didn't notice it. Reported by Peter Asemann. + + +0.22 2002-07-15 + +- The last version's tarball was a mess, and had blib and other junk + in it. This is a nice clean one. + + +0.21 2002-07-14 + +- The various validation functions are now context sensitive, and will + return a reference in scalar context. This may be a helpful + speedup, especially for large parameter lists. + + +0.20 2002-07-13 + +- Improved the speed of both validate() and validate_pos() by about + 20-25%. + +- Improved the speed of the 'no validation' mode for validate() by + over 30%, for validation_pos() by 15%, and for validate_with() by + 125%. + +- The speed of validate_with() has been improved by over 100%, but + this was at the expense of not validating its own incoming + arguments, thus making it a little more fragile. + +- The PERL_NO_VALIDATION env var is now _only_ checked when the module + is loaded. This means you cannot change it mid-program. This is a + backwards incompatibility. + + +0.18 2002-06-18 + +- Added a new function, validate_with(), that allow you to set various + options on a per-invocation basis, rather than on a per-package + basis. Patch by Ken Williams. + + +0.17 2002-06-15 + +- Fix a doc nit where I had a wrong code example. Reported by Britton + Kerin. + +- Added a new validation option parameter, stack_skip, which allows + you to change how errors are reported by Params::Validate. + + +0.16 2002-05-11 + +- Improve skipping of tests when run with 5.6.0. Patch by Ken + Williams. + +- Silence an uninit value warning + + +0.15 2002-04-19 + +- validate_pos would die stupidly when it received an array with an + odd number of elements. + + +0.14 2002-03-14 + +- validate_pos used exists on an array element, which only works with + Perl 5.6.0. This release makes it work 5.00503 again. Reported by + Jon Swartz. + + +0.13 2002-03-10 + +- Apply some of the same optimizations to positional parameters. The + speedup here seems to be about 7-8%. + +- Fix stupid bug in 04-defaults tests. + + +0.12 2002-03-10 + +- Add BOOLEAN type (equivalent to UNDEF | SCALAR). Suggested by Ken + Williams. + +- This version is about 8-10% faster on named parameters than previous + versions. This may not seem like that much but if most, or all, of + your subroutines/methods use validation then this can be a + significant improvement. + +- This version has slightly different semantics for dealing with + missing parameters. Previously, if parameters were missing, an + exception was thrown before any of the other validation parameters + were checked. Now, the validation parameters (type, isa, etc.) are + checked first, so that these errors will show up before missing + parameters. + + +0.11 2002-01-04 + +- Accidentally removed the set_options function (in 0.08). Though this + will go away in the future it isn't happening quite yet. + + +0.10 2002-01-04 + +- Apparently making a tarball for CPAN is beyond my limited abilities. + 0.09 was missing a file needed for tests. Also reported by Blair + Zajac. + +- When running Makefile.PL you get some warnings that can be ignored. + Add a message saying you can ignore them. + + +0.09 2002-01-04 + +- I forgot to put the Makefile.PL in the MANIFEST. I am dumb. + Reported by Blair Zajac. + + +0.08 2002-01-03 + +- Explicitly mention that, by default, Params::Validate uses + Carp::confess to report a validation failure. Suggested by Mark + Stosberg. + +- The 'NO_VALIDATION' mode was seriously broken in that it didn't + handle defaults at all. + +- The 'NO_VALIDATION' env var was mis-documented as being + 'NO_VALIDATE'. + +- The 'NO_VALIDATION' env var is now 'PERL_NO_VALIDATION' and this + method of disabling validation is no longer considered alpha. + +- The validation functions now check this environment variable every + time they are called. This is probably a bit slower than the + previous implementation, which only checked once when the module was + loaded. If you have a problem with this, let me know. + + +0.07 2001-09-23 + +- Fix problem with CPAN shell's 'r' command that + Attribute::Params::Validate was causing with older Perl's. Reported + by Rob BloodGood. + +- Add ability to specify defaults for parameters and get a new + hash/array back from validate or validate_pos. Partial patch + submitted by Ken Williams. + + +0.06 2001-08-23 + +- Require Attribute::Handlers if using Perl 5.6.0+. + +- fix doc nits. + + +0.05 2001-08-23 + +- Added Attribute::Params::Validate - do validation via attributes! + +- Rename set_options to validation_options. This can now be exported + safely and is included in the :all export tag. set_options is + deprecated and will be removed in a future release. Thanks to Jon + Swartz for the suggestion. + + +0.04 2001-04-14 + +- Tweaks to make the code work under 5.00404 + + +0.03 2001-03-17 + +- Make sure all error messages contain the name of the subroutine that + was called. + +- The error message given when an argument doesn't match the 'isa' + spec has been improved. + +- Use Carp::confess by default when dying with an error. This + produces a more useful error message. + + +0.02 2001-03-06 + +- Fix a bug in the test suite that caused failures in 5.6.0. + + +0.01 2001-02-16 + +- Original release + @@ -0,0 +1,43 @@ +This is the Perl distribution Params-Validate. + +Installing Params-Validate is straightforward. + +## Installation with cpanm + +If you have cpanm, you only need one line: + + % cpanm Params::Validate + +If you are installing into a system-wide directory, you may need to pass the +"-S" flag to cpanm, which uses sudo to install the module: + + % cpanm -S Params::Validate + +## Installing with the CPAN shell + +Alternatively, if your CPAN shell is set up, you should just be able to do: + + % cpan Params::Validate + +## Manual installation + +As a last resort, you can manually install it. Download the tarball, untar it, +then build it: + + % perl Build.PL + % ./Build && ./Build test + +Then install it: + + % ./Build install + +If you are installing into a system-wide directory, you may need to run: + + % sudo ./Build install + +## Documentation + +Params-Validate documentation is available as POD. +You can run perldoc from a shell to read the documentation: + + % perldoc Params::Validate @@ -0,0 +1,207 @@ +This software is Copyright (c) 2001 - 2015 by Dave Rolsky and Ilya Martynov. + +This is free software, licensed under: + + The Artistic License 2.0 (GPL Compatible) + + The Artistic License 2.0 + + Copyright (c) 2000-2006, The Perl Foundation. + + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +Preamble + +This license establishes the terms under which a given free software +Package may be copied, modified, distributed, and/or redistributed. +The intent is that the Copyright Holder maintains some artistic +control over the development of that Package while still keeping the +Package available as open source and free software. + +You are always permitted to make arrangements wholly outside of this +license directly with the Copyright Holder of a given Package. If the +terms of this license do not permit the full use that you propose to +make of the Package, you should contact the Copyright Holder and seek +a different licensing arrangement. + +Definitions + + "Copyright Holder" means the individual(s) or organization(s) + named in the copyright notice for the entire Package. + + "Contributor" means any party that has contributed code or other + material to the Package, in accordance with the Copyright Holder's + procedures. + + "You" and "your" means any person who would like to copy, + distribute, or modify the Package. + + "Package" means the collection of files distributed by the + Copyright Holder, and derivatives of that collection and/or of + those files. A given Package may consist of either the Standard + Version, or a Modified Version. + + "Distribute" means providing a copy of the Package or making it + accessible to anyone else, or in the case of a company or + organization, to others outside of your company or organization. + + "Distributor Fee" means any fee that you charge for Distributing + this Package or providing support for this Package to another + party. It does not mean licensing fees. + + "Standard Version" refers to the Package if it has not been + modified, or has been modified only in ways explicitly requested + by the Copyright Holder. + + "Modified Version" means the Package, if it has been changed, and + such changes were not explicitly requested by the Copyright + Holder. + + "Original License" means this Artistic License as Distributed with + the Standard Version of the Package, in its current version or as + it may be modified by The Perl Foundation in the future. + + "Source" form means the source code, documentation source, and + configuration files for the Package. + + "Compiled" form means the compiled bytecode, object code, binary, + or any other form resulting from mechanical transformation or + translation of the Source form. + + +Permission for Use and Modification Without Distribution + +(1) You are permitted to use the Standard Version and create and use +Modified Versions for any purpose without restriction, provided that +you do not Distribute the Modified Version. + + +Permissions for Redistribution of the Standard Version + +(2) You may Distribute verbatim copies of the Source form of the +Standard Version of this Package in any medium without restriction, +either gratis or for a Distributor Fee, provided that you duplicate +all of the original copyright notices and associated disclaimers. At +your discretion, such verbatim copies may or may not include a +Compiled form of the Package. + +(3) You may apply any bug fixes, portability changes, and other +modifications made available from the Copyright Holder. The resulting +Package will still be considered the Standard Version, and as such +will be subject to the Original License. + + +Distribution of Modified Versions of the Package as Source + +(4) You may Distribute your Modified Version as Source (either gratis +or for a Distributor Fee, and with or without a Compiled form of the +Modified Version) provided that you clearly document how it differs +from the Standard Version, including, but not limited to, documenting +any non-standard features, executables, or modules, and provided that +you do at least ONE of the following: + + (a) make the Modified Version available to the Copyright Holder + of the Standard Version, under the Original License, so that the + Copyright Holder may include your modifications in the Standard + Version. + + (b) ensure that installation of your Modified Version does not + prevent the user installing or running the Standard Version. In + addition, the Modified Version must bear a name that is different + from the name of the Standard Version. + + (c) allow anyone who receives a copy of the Modified Version to + make the Source form of the Modified Version available to others + under + + (i) the Original License or + + (ii) a license that permits the licensee to freely copy, + modify and redistribute the Modified Version using the same + licensing terms that apply to the copy that the licensee + received, and requires that the Source form of the Modified + Version, and of any works derived from it, be made freely + available in that license fees are prohibited but Distributor + Fees are allowed. + + +Distribution of Compiled Forms of the Standard Version +or Modified Versions without the Source + +(5) You may Distribute Compiled forms of the Standard Version without +the Source, provided that you include complete instructions on how to +get the Source of the Standard Version. Such instructions must be +valid at the time of your distribution. If these instructions, at any +time while you are carrying out such distribution, become invalid, you +must provide new instructions on demand or cease further distribution. +If you provide valid instructions or cease distribution within thirty +days after you become aware that the instructions are invalid, then +you do not forfeit any of your rights under this license. + +(6) You may Distribute a Modified Version in Compiled form without +the Source, provided that you comply with Section 4 with respect to +the Source of the Modified Version. + + +Aggregating or Linking the Package + +(7) You may aggregate the Package (either the Standard Version or +Modified Version) with other packages and Distribute the resulting +aggregation provided that you do not charge a licensing fee for the +Package. Distributor Fees are permitted, and licensing fees for other +components in the aggregation are permitted. The terms of this license +apply to the use and Distribution of the Standard or Modified Versions +as included in the aggregation. + +(8) You are permitted to link Modified and Standard Versions with +other works, to embed the Package in a larger work of your own, or to +build stand-alone binary or bytecode versions of applications that +include the Package, and Distribute the result without restriction, +provided the result does not expose a direct interface to the Package. + + +Items That are Not Considered Part of a Modified Version + +(9) Works (including, but not limited to, modules and scripts) that +merely extend or make use of the Package, do not, by themselves, cause +the Package to be a Modified Version. In addition, such works are not +considered parts of the Package itself, and are not subject to the +terms of this license. + + +General Provisions + +(10) Any use, modification, and distribution of the Standard or +Modified Versions is governed by this Artistic License. By using, +modifying or distributing the Package, you accept this license. Do not +use, modify, or distribute the Package, if you do not accept this +license. + +(11) If your Modified Version has been derived from a Modified +Version made by someone other than you, you are nevertheless required +to ensure that your Modified Version complies with the requirements of +this license. + +(12) This license does not grant you the right to use any trademark, +service mark, tradename, or logo of the Copyright Holder. + +(13) This license includes the non-exclusive, worldwide, +free-of-charge patent license to make, have made, use, offer to sell, +sell, import and otherwise transfer the Package with respect to any +patent claims licensable by the Copyright Holder that are necessarily +infringed by the Package. If you institute patent litigation +(including a cross-claim or counterclaim) against any party alleging +that the Package constitutes direct or contributory patent +infringement, then this Artistic License to you shall terminate on the +date that such litigation is filed. + +(14) Disclaimer of Warranty: +THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS +IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED +WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR +NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL +LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL +BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL +DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..60dfd96 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,125 @@ +# This file was automatically generated by Dist::Zilla::Plugin::Manifest v5.037. +Build.PL +Changes +INSTALL +LICENSE +MANIFEST +META.json +META.yml +README.md +TODO +benchmarks/basic +c/ppport.h +cpanfile +dist.ini +inc/MyModuleBuild.pm +lib/Attribute/Params/Validate.pm +lib/Params/Validate.pm +lib/Params/Validate/Constants.pm +lib/Params/Validate/PP.pm +lib/Params/Validate/XS.pm +lib/Params/Validate/XS.xs +lib/Params/ValidatePP.pm +lib/Params/ValidateXS.pm +perlcriticrc +perltidyrc +t/00-report-prereqs.dd +t/00-report-prereqs.t +t/01-validate.t +t/02-noop.t +t/03-attribute.t +t/04-defaults.t +t/05-noop_default.t +t/06-options.t +t/07-with.t +t/08-noop_with.t +t/09-regex.t +t/10-noop_regex.t +t/11-cb.t +t/12-noop_cb.t +t/13-taint.t +t/14-no_validate.t +t/15-case.t +t/16-normalize.t +t/17-callbacks.t +t/18-depends.t +t/19-untaint.t +t/21-can.t +t/22-overload-can-bug.t +t/23-readonly.t +t/24-tied.t +t/25-undef-regex.t +t/26-isa.t +t/27-string-as-type.t +t/28-readonly-return.t +t/29-taint-mode.t +t/30-hashref-alteration.t +t/31-incorrect-spelling.t +t/32-regex-as-value.t +t/33-keep-errsv.t +t/34-recursive-validation.t +t/35-default-xs-bug.t +t/36-large-arrays.t +t/37-exports.t +t/38-callback-message.t +t/author-00-compile.t +t/author-eol.t +t/author-no-tabs.t +t/author-pod-spell.t +t/lib/PVTests.pm +t/lib/PVTests/Callbacks.pm +t/lib/PVTests/Defaults.pm +t/lib/PVTests/Regex.pm +t/lib/PVTests/Standard.pm +t/lib/PVTests/With.pm +t/release-cpan-changes.t +t/release-memory-leak.t +t/release-pod-coverage.t +t/release-pod-linkcheck.t +t/release-pod-no404s.t +t/release-pod-syntax.t +t/release-portability.t +t/release-pp-01-validate.t +t/release-pp-02-noop.t +t/release-pp-03-attribute.t +t/release-pp-04-defaults.t +t/release-pp-05-noop_default.t +t/release-pp-06-options.t +t/release-pp-07-with.t +t/release-pp-08-noop_with.t +t/release-pp-09-regex.t +t/release-pp-10-noop_regex.t +t/release-pp-11-cb.t +t/release-pp-12-noop_cb.t +t/release-pp-13-taint.t +t/release-pp-14-no_validate.t +t/release-pp-15-case.t +t/release-pp-16-normalize.t +t/release-pp-17-callbacks.t +t/release-pp-18-depends.t +t/release-pp-19-untaint.t +t/release-pp-21-can.t +t/release-pp-22-overload-can-bug.t +t/release-pp-23-readonly.t +t/release-pp-24-tied.t +t/release-pp-25-undef-regex.t +t/release-pp-26-isa.t +t/release-pp-27-string-as-type.t +t/release-pp-28-readonly-return.t +t/release-pp-29-taint-mode.t +t/release-pp-30-hashref-alteration.t +t/release-pp-31-incorrect-spelling.t +t/release-pp-32-regex-as-value.t +t/release-pp-33-keep-errsv.t +t/release-pp-34-recursive-validation.t +t/release-pp-35-default-xs-bug.t +t/release-pp-36-large-arrays.t +t/release-pp-37-exports.t +t/release-pp-38-callback-message.t +t/release-pp-is-loaded.t +t/release-synopsis.t +t/release-xs-is-loaded.t +t/release-xs-segfault.t +t/release-xs-stack-realloc.t +tidyall.ini +weaver.ini diff --git a/META.json b/META.json new file mode 100644 index 0000000..8615af0 --- /dev/null +++ b/META.json @@ -0,0 +1,791 @@ +{ + "abstract" : "Validate method/function parameters", + "author" : [ + "Dave Rolsky <autarch@urth.org>", + "Ilya Martynov <ilya@martynov.org>" + ], + "dynamic_config" : 0, + "generated_by" : "Dist::Zilla version 5.037, CPAN::Meta::Converter version 2.150005", + "license" : [ + "artistic_2" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : 2 + }, + "name" : "Params-Validate", + "prereqs" : { + "build" : { + "requires" : { + "Module::Build" : "0.28" + } + }, + "configure" : { + "requires" : { + "Module::Build" : "0.28" + } + }, + "develop" : { + "requires" : { + "File::Spec" : "0", + "IO::Handle" : "0", + "IPC::Open3" : "0", + "Perl::Critic" : "1.123", + "Perl::Tidy" : "20140711", + "Pod::Coverage::TrustPod" : "0", + "Readonly" : "1.03", + "Scalar::Util" : "1.20", + "Test::CPAN::Changes" : "0.19", + "Test::EOL" : "0", + "Test::LeakTrace" : "0.15", + "Test::More" : "0.96", + "Test::NoTabs" : "0", + "Test::Pod" : "1.41", + "Test::Pod::Coverage" : "1.08", + "Test::Spelling" : "0.12", + "Test::Synopsis" : "0", + "Test::Taint" : "0.02" + } + }, + "runtime" : { + "requires" : { + "Attribute::Handlers" : "0.79", + "Carp" : "0", + "Exporter" : "0", + "Module::Implementation" : "0", + "Scalar::Util" : "1.10", + "XSLoader" : "0", + "attributes" : "0", + "perl" : "5.008001", + "strict" : "0", + "vars" : "0", + "warnings" : "0" + } + }, + "test" : { + "recommends" : { + "CPAN::Meta" : "2.120900" + }, + "requires" : { + "Devel::Peek" : "0", + "ExtUtils::MakeMaker" : "0", + "File::Spec" : "0", + "File::Temp" : "0", + "Test::Fatal" : "0", + "Test::More" : "0.96", + "Test::Requires" : "0", + "Tie::Array" : "0", + "Tie::Hash" : "0", + "base" : "0", + "lib" : "0", + "overload" : "0" + } + } + }, + "provides" : { + "Attribute::Params::Validate" : { + "file" : "lib/Attribute/Params/Validate.pm", + "version" : "1.20" + }, + "Params::Validate" : { + "file" : "lib/Params/Validate.pm", + "version" : "1.20" + }, + "Params::Validate::Constants" : { + "file" : "lib/Params/Validate/Constants.pm", + "version" : "1.20" + }, + "Params::Validate::PP" : { + "file" : "lib/Params/Validate/PP.pm", + "version" : "1.20" + }, + "Params::Validate::XS" : { + "file" : "lib/Params/Validate/XS.pm", + "version" : "1.20" + } + }, + "release_status" : "stable", + "resources" : { + "bugtracker" : { + "mailto" : "bug-params-validate@rt.cpan.org", + "web" : "http://rt.cpan.org/Public/Dist/Display.html?Name=Params-Validate" + }, + "homepage" : "http://metacpan.org/release/Params-Validate", + "repository" : { + "type" : "git", + "url" : "git://github.com/autarch/Params-Validate.git", + "web" : "https://github.com/autarch/Params-Validate" + } + }, + "version" : "1.20", + "x_Dist_Zilla" : { + "perl" : { + "version" : "5.020001" + }, + "plugins" : [ + { + "class" : "Dist::Zilla::Plugin::Authority", + "name" : "@DROLSKY/Authority", + "version" : "1.009" + }, + { + "class" : "Dist::Zilla::Plugin::AutoPrereqs", + "name" : "@DROLSKY/AutoPrereqs", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::CopyFilesFromBuild", + "name" : "@DROLSKY/CopyFilesFromBuild", + "version" : "0.151680" + }, + { + "class" : "Dist::Zilla::Plugin::Git::GatherDir", + "config" : { + "Dist::Zilla::Plugin::GatherDir" : { + "exclude_filename" : [ + "README.md", + "cpanfile", + "LICENSE", + "Makefile.PL", + "Build.PL" + ], + "exclude_match" : [], + "follow_symlinks" : "0", + "include_dotfiles" : "0", + "prefix" : "", + "prune_directory" : [], + "root" : "." + }, + "Dist::Zilla::Plugin::Git::GatherDir" : { + "include_untracked" : "0" + } + }, + "name" : "@DROLSKY/Git::GatherDir", + "version" : "2.035" + }, + { + "class" : "Dist::Zilla::Plugin::GitHub::Meta", + "name" : "@DROLSKY/GitHub::Meta", + "version" : "0.40" + }, + { + "class" : "Dist::Zilla::Plugin::GitHub::Update", + "name" : "@DROLSKY/GitHub::Update", + "version" : "0.40" + }, + { + "class" : "Dist::Zilla::Plugin::MetaResources", + "name" : "@DROLSKY/MetaResources", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::MetaProvides::Package", + "config" : { + "Dist::Zilla::Plugin::MetaProvides::Package" : { + "finder_objects" : [ + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : "@DROLSKY/MetaProvides::Package/AUTOVIV/:InstallModulesPM", + "version" : "5.037" + } + ] + }, + "Dist::Zilla::Role::MetaProvider::Provider" : { + "inherit_missing" : "1", + "inherit_version" : "1", + "meta_noindex" : "1" + } + }, + "name" : "@DROLSKY/MetaProvides::Package", + "version" : "2.003001" + }, + { + "class" : "Dist::Zilla::Plugin::NextRelease", + "name" : "@DROLSKY/NextRelease", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::Prereqs", + "config" : { + "Dist::Zilla::Plugin::Prereqs" : { + "phase" : "test", + "type" : "requires" + } + }, + "name" : "@DROLSKY/Test::More with subtest()", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::Prereqs", + "config" : { + "Dist::Zilla::Plugin::Prereqs" : { + "phase" : "develop", + "type" : "requires" + } + }, + "name" : "@DROLSKY/Modules for use with tidyall", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::PromptIfStale", + "config" : { + "Dist::Zilla::Plugin::PromptIfStale" : { + "check_all_plugins" : "1", + "check_all_prereqs" : "1", + "modules" : [], + "phase" : "release", + "skip" : [ + "Dist::Zilla::Plugin::DROLSKY::Contributors", + "Dist::Zilla::Plugin::DROLSKY::License", + "Dist::Zilla::Plugin::DROLSKY::TidyAll" + ] + } + }, + "name" : "@DROLSKY/PromptIfStale", + "version" : "0.045" + }, + { + "class" : "Dist::Zilla::Plugin::ReadmeAnyFromPod", + "name" : "@DROLSKY/README.md in build", + "version" : "0.150250" + }, + { + "class" : "Dist::Zilla::Plugin::ReadmeAnyFromPod", + "name" : "@DROLSKY/README.md in root", + "version" : "0.150250" + }, + { + "class" : "Dist::Zilla::Plugin::Test::Pod::Coverage::Configurable", + "name" : "@DROLSKY/Test::Pod::Coverage::Configurable", + "version" : "0.05" + }, + { + "class" : "Dist::Zilla::Plugin::Test::PodSpelling", + "name" : "@DROLSKY/Test::PodSpelling", + "version" : "2.006009" + }, + { + "class" : "Dist::Zilla::Plugin::Test::ReportPrereqs", + "name" : "@DROLSKY/Test::ReportPrereqs", + "version" : "0.021" + }, + { + "class" : "Dist::Zilla::Plugin::ManifestSkip", + "name" : "@DROLSKY/ManifestSkip", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::MetaYAML", + "name" : "@DROLSKY/MetaYAML", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::License", + "name" : "@DROLSKY/License", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::ExtraTests", + "name" : "@DROLSKY/ExtraTests", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::ExecDir", + "name" : "@DROLSKY/ExecDir", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::ShareDir", + "name" : "@DROLSKY/ShareDir", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::Manifest", + "name" : "@DROLSKY/Manifest", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::CheckVersionIncrement", + "name" : "@DROLSKY/CheckVersionIncrement", + "version" : "0.121750" + }, + { + "class" : "Dist::Zilla::Plugin::TestRelease", + "name" : "@DROLSKY/TestRelease", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::ConfirmRelease", + "name" : "@DROLSKY/ConfirmRelease", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::UploadToCPAN", + "name" : "@DROLSKY/UploadToCPAN", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::CheckPrereqsIndexed", + "name" : "@DROLSKY/CheckPrereqsIndexed", + "version" : "0.016" + }, + { + "class" : "Dist::Zilla::Plugin::CPANFile", + "name" : "@DROLSKY/CPANFile", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::DROLSKY::Contributors", + "name" : "@DROLSKY/DROLSKY::Contributors", + "version" : "0.34" + }, + { + "class" : "Dist::Zilla::Plugin::DROLSKY::License", + "name" : "@DROLSKY/DROLSKY::License", + "version" : "0.34" + }, + { + "class" : "Dist::Zilla::Plugin::DROLSKY::TidyAll", + "name" : "@DROLSKY/DROLSKY::TidyAll", + "version" : "0.34" + }, + { + "class" : "Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch", + "config" : { + "Dist::Zilla::Role::Git::Repo" : { + "repo_root" : "." + } + }, + "name" : "@DROLSKY/Git::CheckFor::CorrectBranch", + "version" : "0.013" + }, + { + "class" : "Dist::Zilla::Plugin::Git::CheckFor::MergeConflicts", + "config" : { + "Dist::Zilla::Role::Git::Repo" : { + "repo_root" : "." + } + }, + "name" : "@DROLSKY/Git::CheckFor::MergeConflicts", + "version" : "0.013" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Contributors", + "config" : { + "Dist::Zilla::Plugin::Git::Contributors" : { + "include_authors" : "0", + "include_releaser" : "1", + "order_by" : "name", + "paths" : [] + } + }, + "name" : "@DROLSKY/Git::Contributors", + "version" : "0.011" + }, + { + "class" : "Dist::Zilla::Plugin::InstallGuide", + "name" : "@DROLSKY/InstallGuide", + "version" : "1.200006" + }, + { + "class" : "Dist::Zilla::Plugin::Meta::Contributors", + "name" : "@DROLSKY/Meta::Contributors", + "version" : "0.002" + }, + { + "class" : "Dist::Zilla::Plugin::MetaConfig", + "name" : "@DROLSKY/MetaConfig", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::MetaJSON", + "name" : "@DROLSKY/MetaJSON", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::RewriteVersion", + "name" : "@DROLSKY/RewriteVersion", + "version" : "0.009" + }, + { + "class" : "Dist::Zilla::Plugin::SurgicalPodWeaver", + "config" : { + "Dist::Zilla::Plugin::PodWeaver" : { + "finder" : [ + ":InstallModules", + ":ExecFiles" + ], + "plugins" : [ + { + "class" : "Pod::Weaver::Plugin::EnsurePod5", + "name" : "@CorePrep/EnsurePod5", + "version" : "4.010" + }, + { + "class" : "Pod::Weaver::Plugin::H1Nester", + "name" : "@CorePrep/H1Nester", + "version" : "4.010" + }, + { + "class" : "Pod::Weaver::Section::Name", + "name" : "Name", + "version" : "4.010" + }, + { + "class" : "Pod::Weaver::Section::Version", + "name" : "Version", + "version" : "4.010" + }, + { + "class" : "Pod::Weaver::Section::Region", + "name" : "prelude", + "version" : "4.010" + }, + { + "class" : "Pod::Weaver::Section::Generic", + "name" : "SYNOPSIS", + "version" : "4.010" + }, + { + "class" : "Pod::Weaver::Section::Generic", + "name" : "DESCRIPTION", + "version" : "4.010" + }, + { + "class" : "Pod::Weaver::Section::Leftovers", + "name" : "Leftovers", + "version" : "4.010" + }, + { + "class" : "Pod::Weaver::Section::Region", + "name" : "postlude", + "version" : "4.010" + }, + { + "class" : "Pod::Weaver::Section::Authors", + "name" : "Authors", + "version" : "4.010" + }, + { + "class" : "Pod::Weaver::Section::Contributors", + "name" : "Contributors", + "version" : "0.009" + }, + { + "class" : "Pod::Weaver::Section::Legal", + "name" : "Legal", + "version" : "4.010" + } + ] + } + }, + "name" : "@DROLSKY/SurgicalPodWeaver", + "version" : "0.0023" + }, + { + "class" : "Dist::Zilla::Plugin::PodSyntaxTests", + "name" : "@DROLSKY/PodSyntaxTests", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::Test::CPAN::Changes", + "name" : "@DROLSKY/Test::CPAN::Changes", + "version" : "0.009" + }, + { + "class" : "Dist::Zilla::Plugin::Test::EOL", + "config" : { + "Dist::Zilla::Plugin::Test::EOL" : { + "filename" : "xt/author/eol.t", + "finder" : [ + ":InstallModules", + ":ExecFiles", + ":TestFiles" + ], + "trailing_whitespace" : "1" + } + }, + "name" : "@DROLSKY/Test::EOL", + "version" : "0.18" + }, + { + "class" : "Dist::Zilla::Plugin::Test::NoTabs", + "config" : { + "Dist::Zilla::Plugin::Test::NoTabs" : { + "filename" : "xt/author/no-tabs.t", + "finder" : [ + ":InstallModules", + ":ExecFiles", + ":TestFiles" + ] + } + }, + "name" : "@DROLSKY/Test::NoTabs", + "version" : "0.15" + }, + { + "class" : "Dist::Zilla::Plugin::Test::Pod::LinkCheck", + "name" : "@DROLSKY/Test::Pod::LinkCheck", + "version" : "1.001" + }, + { + "class" : "Dist::Zilla::Plugin::Test::Pod::No404s", + "name" : "@DROLSKY/Test::Pod::No404s", + "version" : "1.001" + }, + { + "class" : "Dist::Zilla::Plugin::Test::Portability", + "name" : "@DROLSKY/Test::Portability", + "version" : "2.000006" + }, + { + "class" : "Dist::Zilla::Plugin::Test::Synopsis", + "name" : "@DROLSKY/Test::Synopsis", + "version" : "2.000006" + }, + { + "class" : "Dist::Zilla::Plugin::Test::Compile", + "config" : { + "Dist::Zilla::Plugin::Test::Compile" : { + "bail_out_on_fail" : "0", + "fail_on_warning" : "author", + "fake_home" : "0", + "filename" : "xt/author/00-compile.t", + "module_finder" : [ + ":InstallModules" + ], + "needs_display" : "0", + "phase" : "develop", + "script_finder" : [ + ":ExecFiles" + ], + "skips" : [] + } + }, + "name" : "@DROLSKY/Test::Compile", + "version" : "2.053" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Check", + "config" : { + "Dist::Zilla::Plugin::Git::Check" : { + "untracked_files" : "die" + }, + "Dist::Zilla::Role::Git::DirtyFiles" : { + "allow_dirty" : [ + "README.md", + "cpanfile", + "LICENSE", + "Makefile.PL", + "Build.PL", + "Changes", + "CONTRIBUTING.md" + ], + "allow_dirty_match" : [], + "changelog" : "Changes" + }, + "Dist::Zilla::Role::Git::Repo" : { + "repo_root" : "." + } + }, + "name" : "@DROLSKY/Git::Check", + "version" : "2.035" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Commit", + "config" : { + "Dist::Zilla::Plugin::Git::Commit" : { + "add_files_in" : [], + "commit_msg" : "v%v%n%n%c", + "time_zone" : "local" + }, + "Dist::Zilla::Role::Git::DirtyFiles" : { + "allow_dirty" : [ + "README.md", + "cpanfile", + "LICENSE", + "Makefile.PL", + "Build.PL", + "Changes", + "CONTRIBUTING.md" + ], + "allow_dirty_match" : [], + "changelog" : "Changes" + }, + "Dist::Zilla::Role::Git::Repo" : { + "repo_root" : "." + } + }, + "name" : "@DROLSKY/commit generated files", + "version" : "2.035" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Tag", + "config" : { + "Dist::Zilla::Plugin::Git::Tag" : { + "branch" : null, + "signed" : 0, + "tag" : "v1.20", + "tag_format" : "v%v", + "tag_message" : "v%v", + "time_zone" : "local" + }, + "Dist::Zilla::Role::Git::Repo" : { + "repo_root" : "." + } + }, + "name" : "@DROLSKY/Git::Tag", + "version" : "2.035" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Push", + "config" : { + "Dist::Zilla::Plugin::Git::Push" : { + "push_to" : [ + "origin" + ], + "remotes_must_exist" : 1 + }, + "Dist::Zilla::Role::Git::Repo" : { + "repo_root" : "." + } + }, + "name" : "@DROLSKY/Git::Push", + "version" : "2.035" + }, + { + "class" : "Dist::Zilla::Plugin::BumpVersionAfterRelease", + "name" : "@DROLSKY/BumpVersionAfterRelease", + "version" : "0.009" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Commit", + "config" : { + "Dist::Zilla::Plugin::Git::Commit" : { + "add_files_in" : [], + "commit_msg" : "Bump version after release", + "time_zone" : "local" + }, + "Dist::Zilla::Role::Git::DirtyFiles" : { + "allow_dirty" : [ + "dist.ini", + "Changes" + ], + "allow_dirty_match" : [ + "(?^:.+)" + ], + "changelog" : "Changes" + }, + "Dist::Zilla::Role::Git::Repo" : { + "repo_root" : "." + } + }, + "name" : "@DROLSKY/commit version bump", + "version" : "2.035" + }, + { + "class" : "Dist::Zilla::Plugin::Git::Push", + "config" : { + "Dist::Zilla::Plugin::Git::Push" : { + "push_to" : [ + "origin" + ], + "remotes_must_exist" : 1 + }, + "Dist::Zilla::Role::Git::Repo" : { + "repo_root" : "." + } + }, + "name" : "@DROLSKY/push version bump", + "version" : "2.035" + }, + { + "class" : "Dist::Zilla::Plugin::Prereqs", + "config" : { + "Dist::Zilla::Plugin::Prereqs" : { + "phase" : "develop", + "type" : "requires" + } + }, + "name" : "DevelopRequires", + "version" : "5.037" + }, + { + "class" : "inc::MyModuleBuild", + "config" : { + "Dist::Zilla::Role::TestRunner" : { + "default_jobs" : 1 + } + }, + "name" : "=inc::MyModuleBuild", + "version" : null + }, + { + "class" : "Dist::Zilla::Plugin::PurePerlTests", + "name" : "PurePerlTests", + "version" : "0.05" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":InstallModules", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":IncModules", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":TestFiles", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":ExecFiles", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":ShareFiles", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":MainModule", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":AllFiles", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : ":NoFiles", + "version" : "5.037" + }, + { + "class" : "Dist::Zilla::Plugin::FinderCode", + "name" : "@DROLSKY/MetaProvides::Package/AUTOVIV/:InstallModulesPM", + "version" : "5.037" + } + ], + "zilla" : { + "class" : "Dist::Zilla::Dist::Builder", + "config" : { + "is_trial" : "0" + }, + "version" : "5.037" + } + }, + "x_authority" : "cpan:DROLSKY", + "x_contributors" : [ + "Ivan Bessarabov <ivan@bessarabov.ru>", + "J.R. Mash <jmash.code@gmail.com>", + "Noel Maddy <zhtwnpanta@gmail.com>", + "Olivier Mengué <dolmen@cpan.org>", + "Vincent Pit <perl@profvince.com>" + ] +} + diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..9706d8d --- /dev/null +++ b/META.yml @@ -0,0 +1,575 @@ +--- +abstract: 'Validate method/function parameters' +author: + - 'Dave Rolsky <autarch@urth.org>' + - 'Ilya Martynov <ilya@martynov.org>' +build_requires: + Devel::Peek: '0' + ExtUtils::MakeMaker: '0' + File::Spec: '0' + File::Temp: '0' + Module::Build: '0.28' + Test::Fatal: '0' + Test::More: '0.96' + Test::Requires: '0' + Tie::Array: '0' + Tie::Hash: '0' + base: '0' + lib: '0' + overload: '0' +configure_requires: + Module::Build: '0.28' +dynamic_config: 0 +generated_by: 'Dist::Zilla version 5.037, CPAN::Meta::Converter version 2.150005' +license: artistic_2 +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: Params-Validate +provides: + Attribute::Params::Validate: + file: lib/Attribute/Params/Validate.pm + version: '1.20' + Params::Validate: + file: lib/Params/Validate.pm + version: '1.20' + Params::Validate::Constants: + file: lib/Params/Validate/Constants.pm + version: '1.20' + Params::Validate::PP: + file: lib/Params/Validate/PP.pm + version: '1.20' + Params::Validate::XS: + file: lib/Params/Validate/XS.pm + version: '1.20' +requires: + Attribute::Handlers: '0.79' + Carp: '0' + Exporter: '0' + Module::Implementation: '0' + Scalar::Util: '1.10' + XSLoader: '0' + attributes: '0' + perl: '5.008001' + strict: '0' + vars: '0' + warnings: '0' +resources: + bugtracker: http://rt.cpan.org/Public/Dist/Display.html?Name=Params-Validate + homepage: http://metacpan.org/release/Params-Validate + repository: git://github.com/autarch/Params-Validate.git +version: '1.20' +x_Dist_Zilla: + perl: + version: '5.020001' + plugins: + - + class: Dist::Zilla::Plugin::Authority + name: '@DROLSKY/Authority' + version: '1.009' + - + class: Dist::Zilla::Plugin::AutoPrereqs + name: '@DROLSKY/AutoPrereqs' + version: '5.037' + - + class: Dist::Zilla::Plugin::CopyFilesFromBuild + name: '@DROLSKY/CopyFilesFromBuild' + version: '0.151680' + - + class: Dist::Zilla::Plugin::Git::GatherDir + config: + Dist::Zilla::Plugin::GatherDir: + exclude_filename: + - README.md + - cpanfile + - LICENSE + - Makefile.PL + - Build.PL + exclude_match: [] + follow_symlinks: '0' + include_dotfiles: '0' + prefix: '' + prune_directory: [] + root: . + Dist::Zilla::Plugin::Git::GatherDir: + include_untracked: '0' + name: '@DROLSKY/Git::GatherDir' + version: '2.035' + - + class: Dist::Zilla::Plugin::GitHub::Meta + name: '@DROLSKY/GitHub::Meta' + version: '0.40' + - + class: Dist::Zilla::Plugin::GitHub::Update + name: '@DROLSKY/GitHub::Update' + version: '0.40' + - + class: Dist::Zilla::Plugin::MetaResources + name: '@DROLSKY/MetaResources' + version: '5.037' + - + class: Dist::Zilla::Plugin::MetaProvides::Package + config: + Dist::Zilla::Plugin::MetaProvides::Package: + finder_objects: + - + class: Dist::Zilla::Plugin::FinderCode + name: '@DROLSKY/MetaProvides::Package/AUTOVIV/:InstallModulesPM' + version: '5.037' + Dist::Zilla::Role::MetaProvider::Provider: + inherit_missing: '1' + inherit_version: '1' + meta_noindex: '1' + name: '@DROLSKY/MetaProvides::Package' + version: '2.003001' + - + class: Dist::Zilla::Plugin::NextRelease + name: '@DROLSKY/NextRelease' + version: '5.037' + - + class: Dist::Zilla::Plugin::Prereqs + config: + Dist::Zilla::Plugin::Prereqs: + phase: test + type: requires + name: '@DROLSKY/Test::More with subtest()' + version: '5.037' + - + class: Dist::Zilla::Plugin::Prereqs + config: + Dist::Zilla::Plugin::Prereqs: + phase: develop + type: requires + name: '@DROLSKY/Modules for use with tidyall' + version: '5.037' + - + class: Dist::Zilla::Plugin::PromptIfStale + config: + Dist::Zilla::Plugin::PromptIfStale: + check_all_plugins: '1' + check_all_prereqs: '1' + modules: [] + phase: release + skip: + - Dist::Zilla::Plugin::DROLSKY::Contributors + - Dist::Zilla::Plugin::DROLSKY::License + - Dist::Zilla::Plugin::DROLSKY::TidyAll + name: '@DROLSKY/PromptIfStale' + version: '0.045' + - + class: Dist::Zilla::Plugin::ReadmeAnyFromPod + name: '@DROLSKY/README.md in build' + version: '0.150250' + - + class: Dist::Zilla::Plugin::ReadmeAnyFromPod + name: '@DROLSKY/README.md in root' + version: '0.150250' + - + class: Dist::Zilla::Plugin::Test::Pod::Coverage::Configurable + name: '@DROLSKY/Test::Pod::Coverage::Configurable' + version: '0.05' + - + class: Dist::Zilla::Plugin::Test::PodSpelling + name: '@DROLSKY/Test::PodSpelling' + version: '2.006009' + - + class: Dist::Zilla::Plugin::Test::ReportPrereqs + name: '@DROLSKY/Test::ReportPrereqs' + version: '0.021' + - + class: Dist::Zilla::Plugin::ManifestSkip + name: '@DROLSKY/ManifestSkip' + version: '5.037' + - + class: Dist::Zilla::Plugin::MetaYAML + name: '@DROLSKY/MetaYAML' + version: '5.037' + - + class: Dist::Zilla::Plugin::License + name: '@DROLSKY/License' + version: '5.037' + - + class: Dist::Zilla::Plugin::ExtraTests + name: '@DROLSKY/ExtraTests' + version: '5.037' + - + class: Dist::Zilla::Plugin::ExecDir + name: '@DROLSKY/ExecDir' + version: '5.037' + - + class: Dist::Zilla::Plugin::ShareDir + name: '@DROLSKY/ShareDir' + version: '5.037' + - + class: Dist::Zilla::Plugin::Manifest + name: '@DROLSKY/Manifest' + version: '5.037' + - + class: Dist::Zilla::Plugin::CheckVersionIncrement + name: '@DROLSKY/CheckVersionIncrement' + version: '0.121750' + - + class: Dist::Zilla::Plugin::TestRelease + name: '@DROLSKY/TestRelease' + version: '5.037' + - + class: Dist::Zilla::Plugin::ConfirmRelease + name: '@DROLSKY/ConfirmRelease' + version: '5.037' + - + class: Dist::Zilla::Plugin::UploadToCPAN + name: '@DROLSKY/UploadToCPAN' + version: '5.037' + - + class: Dist::Zilla::Plugin::CheckPrereqsIndexed + name: '@DROLSKY/CheckPrereqsIndexed' + version: '0.016' + - + class: Dist::Zilla::Plugin::CPANFile + name: '@DROLSKY/CPANFile' + version: '5.037' + - + class: Dist::Zilla::Plugin::DROLSKY::Contributors + name: '@DROLSKY/DROLSKY::Contributors' + version: '0.34' + - + class: Dist::Zilla::Plugin::DROLSKY::License + name: '@DROLSKY/DROLSKY::License' + version: '0.34' + - + class: Dist::Zilla::Plugin::DROLSKY::TidyAll + name: '@DROLSKY/DROLSKY::TidyAll' + version: '0.34' + - + class: Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch + config: + Dist::Zilla::Role::Git::Repo: + repo_root: . + name: '@DROLSKY/Git::CheckFor::CorrectBranch' + version: '0.013' + - + class: Dist::Zilla::Plugin::Git::CheckFor::MergeConflicts + config: + Dist::Zilla::Role::Git::Repo: + repo_root: . + name: '@DROLSKY/Git::CheckFor::MergeConflicts' + version: '0.013' + - + class: Dist::Zilla::Plugin::Git::Contributors + config: + Dist::Zilla::Plugin::Git::Contributors: + include_authors: '0' + include_releaser: '1' + order_by: name + paths: [] + name: '@DROLSKY/Git::Contributors' + version: '0.011' + - + class: Dist::Zilla::Plugin::InstallGuide + name: '@DROLSKY/InstallGuide' + version: '1.200006' + - + class: Dist::Zilla::Plugin::Meta::Contributors + name: '@DROLSKY/Meta::Contributors' + version: '0.002' + - + class: Dist::Zilla::Plugin::MetaConfig + name: '@DROLSKY/MetaConfig' + version: '5.037' + - + class: Dist::Zilla::Plugin::MetaJSON + name: '@DROLSKY/MetaJSON' + version: '5.037' + - + class: Dist::Zilla::Plugin::RewriteVersion + name: '@DROLSKY/RewriteVersion' + version: '0.009' + - + class: Dist::Zilla::Plugin::SurgicalPodWeaver + config: + Dist::Zilla::Plugin::PodWeaver: + finder: + - ':InstallModules' + - ':ExecFiles' + plugins: + - + class: Pod::Weaver::Plugin::EnsurePod5 + name: '@CorePrep/EnsurePod5' + version: '4.010' + - + class: Pod::Weaver::Plugin::H1Nester + name: '@CorePrep/H1Nester' + version: '4.010' + - + class: Pod::Weaver::Section::Name + name: Name + version: '4.010' + - + class: Pod::Weaver::Section::Version + name: Version + version: '4.010' + - + class: Pod::Weaver::Section::Region + name: prelude + version: '4.010' + - + class: Pod::Weaver::Section::Generic + name: SYNOPSIS + version: '4.010' + - + class: Pod::Weaver::Section::Generic + name: DESCRIPTION + version: '4.010' + - + class: Pod::Weaver::Section::Leftovers + name: Leftovers + version: '4.010' + - + class: Pod::Weaver::Section::Region + name: postlude + version: '4.010' + - + class: Pod::Weaver::Section::Authors + name: Authors + version: '4.010' + - + class: Pod::Weaver::Section::Contributors + name: Contributors + version: '0.009' + - + class: Pod::Weaver::Section::Legal + name: Legal + version: '4.010' + name: '@DROLSKY/SurgicalPodWeaver' + version: '0.0023' + - + class: Dist::Zilla::Plugin::PodSyntaxTests + name: '@DROLSKY/PodSyntaxTests' + version: '5.037' + - + class: Dist::Zilla::Plugin::Test::CPAN::Changes + name: '@DROLSKY/Test::CPAN::Changes' + version: '0.009' + - + class: Dist::Zilla::Plugin::Test::EOL + config: + Dist::Zilla::Plugin::Test::EOL: + filename: xt/author/eol.t + finder: + - ':InstallModules' + - ':ExecFiles' + - ':TestFiles' + trailing_whitespace: '1' + name: '@DROLSKY/Test::EOL' + version: '0.18' + - + class: Dist::Zilla::Plugin::Test::NoTabs + config: + Dist::Zilla::Plugin::Test::NoTabs: + filename: xt/author/no-tabs.t + finder: + - ':InstallModules' + - ':ExecFiles' + - ':TestFiles' + name: '@DROLSKY/Test::NoTabs' + version: '0.15' + - + class: Dist::Zilla::Plugin::Test::Pod::LinkCheck + name: '@DROLSKY/Test::Pod::LinkCheck' + version: '1.001' + - + class: Dist::Zilla::Plugin::Test::Pod::No404s + name: '@DROLSKY/Test::Pod::No404s' + version: '1.001' + - + class: Dist::Zilla::Plugin::Test::Portability + name: '@DROLSKY/Test::Portability' + version: '2.000006' + - + class: Dist::Zilla::Plugin::Test::Synopsis + name: '@DROLSKY/Test::Synopsis' + version: '2.000006' + - + class: Dist::Zilla::Plugin::Test::Compile + config: + Dist::Zilla::Plugin::Test::Compile: + bail_out_on_fail: '0' + fail_on_warning: author + fake_home: '0' + filename: xt/author/00-compile.t + module_finder: + - ':InstallModules' + needs_display: '0' + phase: develop + script_finder: + - ':ExecFiles' + skips: [] + name: '@DROLSKY/Test::Compile' + version: '2.053' + - + class: Dist::Zilla::Plugin::Git::Check + config: + Dist::Zilla::Plugin::Git::Check: + untracked_files: die + Dist::Zilla::Role::Git::DirtyFiles: + allow_dirty: + - README.md + - cpanfile + - LICENSE + - Makefile.PL + - Build.PL + - Changes + - CONTRIBUTING.md + allow_dirty_match: [] + changelog: Changes + Dist::Zilla::Role::Git::Repo: + repo_root: . + name: '@DROLSKY/Git::Check' + version: '2.035' + - + class: Dist::Zilla::Plugin::Git::Commit + config: + Dist::Zilla::Plugin::Git::Commit: + add_files_in: [] + commit_msg: v%v%n%n%c + time_zone: local + Dist::Zilla::Role::Git::DirtyFiles: + allow_dirty: + - README.md + - cpanfile + - LICENSE + - Makefile.PL + - Build.PL + - Changes + - CONTRIBUTING.md + allow_dirty_match: [] + changelog: Changes + Dist::Zilla::Role::Git::Repo: + repo_root: . + name: '@DROLSKY/commit generated files' + version: '2.035' + - + class: Dist::Zilla::Plugin::Git::Tag + config: + Dist::Zilla::Plugin::Git::Tag: + branch: ~ + signed: 0 + tag: v1.20 + tag_format: v%v + tag_message: v%v + time_zone: local + Dist::Zilla::Role::Git::Repo: + repo_root: . + name: '@DROLSKY/Git::Tag' + version: '2.035' + - + class: Dist::Zilla::Plugin::Git::Push + config: + Dist::Zilla::Plugin::Git::Push: + push_to: + - origin + remotes_must_exist: 1 + Dist::Zilla::Role::Git::Repo: + repo_root: . + name: '@DROLSKY/Git::Push' + version: '2.035' + - + class: Dist::Zilla::Plugin::BumpVersionAfterRelease + name: '@DROLSKY/BumpVersionAfterRelease' + version: '0.009' + - + class: Dist::Zilla::Plugin::Git::Commit + config: + Dist::Zilla::Plugin::Git::Commit: + add_files_in: [] + commit_msg: 'Bump version after release' + time_zone: local + Dist::Zilla::Role::Git::DirtyFiles: + allow_dirty: + - dist.ini + - Changes + allow_dirty_match: + - (?^:.+) + changelog: Changes + Dist::Zilla::Role::Git::Repo: + repo_root: . + name: '@DROLSKY/commit version bump' + version: '2.035' + - + class: Dist::Zilla::Plugin::Git::Push + config: + Dist::Zilla::Plugin::Git::Push: + push_to: + - origin + remotes_must_exist: 1 + Dist::Zilla::Role::Git::Repo: + repo_root: . + name: '@DROLSKY/push version bump' + version: '2.035' + - + class: Dist::Zilla::Plugin::Prereqs + config: + Dist::Zilla::Plugin::Prereqs: + phase: develop + type: requires + name: DevelopRequires + version: '5.037' + - + class: inc::MyModuleBuild + config: + Dist::Zilla::Role::TestRunner: + default_jobs: 1 + name: =inc::MyModuleBuild + version: ~ + - + class: Dist::Zilla::Plugin::PurePerlTests + name: PurePerlTests + version: '0.05' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':InstallModules' + version: '5.037' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':IncModules' + version: '5.037' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':TestFiles' + version: '5.037' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':ExecFiles' + version: '5.037' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':ShareFiles' + version: '5.037' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':MainModule' + version: '5.037' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':AllFiles' + version: '5.037' + - + class: Dist::Zilla::Plugin::FinderCode + name: ':NoFiles' + version: '5.037' + - + class: Dist::Zilla::Plugin::FinderCode + name: '@DROLSKY/MetaProvides::Package/AUTOVIV/:InstallModulesPM' + version: '5.037' + zilla: + class: Dist::Zilla::Dist::Builder + config: + is_trial: '0' + version: '5.037' +x_authority: cpan:DROLSKY +x_contributors: + - 'Ivan Bessarabov <ivan@bessarabov.ru>' + - 'J.R. Mash <jmash.code@gmail.com>' + - 'Noel Maddy <zhtwnpanta@gmail.com>' + - 'Olivier Mengué <dolmen@cpan.org>' + - 'Vincent Pit <perl@profvince.com>' diff --git a/README.md b/README.md new file mode 100644 index 0000000..59b86fa --- /dev/null +++ b/README.md @@ -0,0 +1,789 @@ +NAME + + Params::Validate - Validate method/function parameters + +VERSION + + version 1.20 + +SYNOPSIS + + use Params::Validate qw(:all); + + # takes named params (hash or hashref) + sub foo { + validate( + @_, { + foo => 1, # mandatory + bar => 0, # optional + } + ); + } + + # takes positional params + sub bar { + # first two are mandatory, third is optional + validate_pos( @_, 1, 1, 0 ); + } + + sub foo2 { + validate( + @_, { + foo => + # specify a type + { type => ARRAYREF }, + bar => + # specify an interface + { can => [ 'print', 'flush', 'frobnicate' ] }, + baz => { + type => SCALAR, # a scalar ... + # ... that is a plain integer ... + regex => qr/^\d+$/, + callbacks => { # ... and smaller than 90 + 'less than 90' => sub { shift() < 90 }, + }, + } + } + ); + } + + sub callback_with_custom_error { + validate( + @_, + { + foo => callbacks => { + 'is an integer' => sub { + return 1 if $_[0] =~ /^-?[1-9][0-9]*$/; + die "$_[0] is not a valid integer value"; + }, + } + } + ); + } + + sub with_defaults { + my %p = validate( + @_, { + # required + foo => 1, + # $p{bar} will be 99 if bar is not given. bar is now + # optional. + bar => { default => 99 } + } + ); + } + + sub pos_with_defaults { + my @p = validate_pos( @_, 1, { default => 99 } ); + } + + sub sets_options_on_call { + my %p = validate_with( + params => \@_, + spec => { foo => { type => SCALAR, default => 2 } }, + normalize_keys => sub { $_[0] =~ s/^-//; lc $_[0] }, + ); + } + +DESCRIPTION + + The Params::Validate module allows you to validate method or function + call parameters to an arbitrary level of specificity. At the simplest + level, it is capable of validating the required parameters were given + and that no unspecified additional parameters were passed in. + + It is also capable of determining that a parameter is of a specific + type, that it is an object of a certain class hierarchy, that it + possesses certain methods, or applying validation callbacks to + arguments. + + EXPORT + + The module always exports the validate() and validate_pos() functions. + + It also has an additional function available for export, validate_with, + which can be used to validate any type of parameters, and set various + options on a per-invocation basis. + + In addition, it can export the following constants, which are used as + part of the type checking. These are SCALAR, ARRAYREF, HASHREF, + CODEREF, GLOB, GLOBREF, and SCALARREF, UNDEF, OBJECT, BOOLEAN, and + HANDLE. These are explained in the section on Type Validation. + + The constants are available via the export tag :types. There is also an + :all tag which includes all of the constants as well as the + validation_options() function. + +PARAMETER VALIDATION + + The validation mechanisms provided by this module can handle both named + or positional parameters. For the most part, the same features are + available for each. The biggest difference is the way that the + validation specification is given to the relevant subroutine. The other + difference is in the error messages produced when validation checks + fail. + + When handling named parameters, the module will accept either a hash or + a hash reference. + + Subroutines expecting named parameters should call the validate() + subroutine like this: + + validate( + @_, { + parameter1 => validation spec, + parameter2 => validation spec, + ... + } + ); + + Subroutines expecting positional parameters should call the + validate_pos() subroutine like this: + + validate_pos( @_, { validation spec }, { validation spec } ); + + Mandatory/Optional Parameters + + If you just want to specify that some parameters are mandatory and + others are optional, this can be done very simply. + + For a subroutine expecting named parameters, you would do this: + + validate( @_, { foo => 1, bar => 1, baz => 0 } ); + + This says that the "foo" and "bar" parameters are mandatory and that + the "baz" parameter is optional. The presence of any other parameters + will cause an error. + + For a subroutine expecting positional parameters, you would do this: + + validate_pos( @_, 1, 1, 0, 0 ); + + This says that you expect at least 2 and no more than 4 parameters. If + you have a subroutine that has a minimum number of parameters but can + take any maximum number, you can do this: + + validate_pos( @_, 1, 1, (0) x (@_ - 2) ); + + This will always be valid as long as at least two parameters are given. + A similar construct could be used for the more complex validation + parameters described further on. + + Please note that this: + + validate_pos( @_, 1, 1, 0, 1, 1 ); + + makes absolutely no sense, so don't do it. Any zeros must come at the + end of the validation specification. + + In addition, if you specify that a parameter can have a default, then + it is considered optional. + + Type Validation + + This module supports the following simple types, which can be exported + as constants: + + * SCALAR + + A scalar which is not a reference, such as 10 or 'hello'. A parameter + that is undefined is not treated as a scalar. If you want to allow + undefined values, you will have to specify SCALAR | UNDEF. + + * ARRAYREF + + An array reference such as [1, 2, 3] or \@foo. + + * HASHREF + + A hash reference such as { a => 1, b => 2 } or \%bar. + + * CODEREF + + A subroutine reference such as \&foo_sub or sub { print "hello" }. + + * GLOB + + This one is a bit tricky. A glob would be something like *FOO, but + not \*FOO, which is a glob reference. It should be noted that this + trick: + + my $fh = do { local *FH; }; + + makes $fh a glob, not a glob reference. On the other hand, the return + value from Symbol::gensym is a glob reference. Either can be used as + a file or directory handle. + + * GLOBREF + + A glob reference such as \*FOO. See the GLOB entry above for more + details. + + * SCALARREF + + A reference to a scalar such as \$x. + + * UNDEF + + An undefined value + + * OBJECT + + A blessed reference. + + * BOOLEAN + + This is a special option, and is just a shortcut for UNDEF | SCALAR. + + * HANDLE + + This option is also special, and is just a shortcut for GLOB | + GLOBREF. However, it seems likely that most people interested in + either globs or glob references are likely to really be interested in + whether the parameter in question could be a valid file or directory + handle. + + To specify that a parameter must be of a given type when using named + parameters, do this: + + validate( + @_, { + foo => { type => SCALAR }, + bar => { type => HASHREF } + } + ); + + If a parameter can be of more than one type, just use the bitwise or + (|) operator to combine them. + + validate( @_, { foo => { type => GLOB | GLOBREF } ); + + For positional parameters, this can be specified as follows: + + validate_pos( @_, { type => SCALAR | ARRAYREF }, { type => CODEREF } ); + + Interface Validation + + To specify that a parameter is expected to have a certain set of + methods, we can do the following: + + validate( + @_, { + foo => + # just has to be able to ->bar + { can => 'bar' } + } + ); + + ... or ... + + validate( + @_, { + foo => + # must be able to ->bar and ->print + { can => [qw( bar print )] } + } + ); + + Class Validation + + A word of warning. When constructing your external interfaces, it is + probably better to specify what methods you expect an object to have + rather than what class it should be of (or a child of). This will make + your API much more flexible. + + With that said, if you want to validate that an incoming parameter + belongs to a class (or child class) or classes, do: + + validate( + @_, + { foo => { isa => 'My::Frobnicator' } } + ); + + ... or ... + + validate( + @_, + # must be both, not either! + { foo => { isa => [qw( My::Frobnicator IO::Handle )] } } + ); + + Regex Validation + + If you want to specify that a given parameter must match a specific + regular expression, this can be done with "regex" spec key. For + example: + + validate( + @_, + { foo => { regex => qr/^\d+$/ } } + ); + + The value of the "regex" key may be either a string or a pre-compiled + regex created via qr. + + If the value being checked against a regex is undefined, the regex is + explicitly checked against the empty string ('') instead, in order to + avoid "Use of uninitialized value" warnings. + + The Regexp::Common module on CPAN is an excellent source of regular + expressions suitable for validating input. + + Callback Validation + + If none of the above are enough, it is possible to pass in one or more + callbacks to validate the parameter. The callback will be given the + value of the parameter as its first argument. Its second argument will + be all the parameters, as a reference to either a hash or array. + Callbacks are specified as hash reference. The key is an id for the + callback (used in error messages) and the value is a subroutine + reference, such as: + + validate( + @_, + { + foo => { + callbacks => { + 'smaller than a breadbox' => sub { shift() < $breadbox }, + 'green or blue' => sub { + return 1 if $_[0] eq 'green' || $_[0] eq 'blue'; + die "$_[0] is not green or blue!"; + } + } + } + } + ); + + validate( + @_, { + foo => { + callbacks => { + 'bigger than baz' => sub { $_[0] > $_[1]->{baz} } + } + } + } + ); + + The callback should return a true value if the value is valid. If not, + it can return false or die. If you return false, a generic error + message will be thrown by Params::Validate. + + If your callback dies instead you can provide a custom error message. + If the callback dies with a plain string, this string will be appended + to an exception message generated by Params::Validate. If the callback + dies with a reference (blessed or not), then this will be rethrown + as-is by Params::Validate. + + Untainting + + If you want values untainted, set the "untaint" key in a spec hashref + to a true value, like this: + + my %p = validate( + @_, { + foo => { type => SCALAR, untaint => 1 }, + bar => { type => ARRAYREF } + } + ); + + This will untaint the "foo" parameter if the parameters are valid. + + Note that untainting is only done if all parameters are valid. Also, + only the return values are untainted, not the original values passed + into the validation function. + + Asking for untainting of a reference value will not do anything, as + Params::Validate will only attempt to untaint the reference itself. + + Mandatory/Optional Revisited + + If you want to specify something such as type or interface, plus the + fact that a parameter can be optional, do this: + + validate( + @_, { + foo => { type => SCALAR }, + bar => { type => ARRAYREF, optional => 1 } + } + ); + + or this for positional parameters: + + validate_pos( + @_, + { type => SCALAR }, + { type => ARRAYREF, optional => 1 } + ); + + By default, parameters are assumed to be mandatory unless specified as + optional. + + Dependencies + + It also possible to specify that a given optional parameter depends on + the presence of one or more other optional parameters. + + validate( + @_, { + cc_number => { + type => SCALAR, + optional => 1, + depends => [ 'cc_expiration', 'cc_holder_name' ], + }, + cc_expiration => { type => SCALAR, optional => 1 }, + cc_holder_name => { type => SCALAR, optional => 1 }, + } + ); + + In this case, "cc_number", "cc_expiration", and "cc_holder_name" are + all optional. However, if "cc_number" is provided, then "cc_expiration" + and "cc_holder_name" must be provided as well. + + This allows you to group together sets of parameters that all must be + provided together. + + The validate_pos() version of dependencies is slightly different, in + that you can only depend on one other parameter. Also, if for example, + the second parameter 2 depends on the fourth parameter, then it implies + a dependency on the third parameter as well. This is because if the + fourth parameter is required, then the user must also provide a third + parameter so that there can be four parameters in total. + + Params::Validate will die if you try to depend on a parameter not + declared as part of your parameter specification. + + Specifying defaults + + If the validate() or validate_pos() functions are called in a list + context, they will return a hash or containing the original parameters + plus defaults as indicated by the validation spec. + + If the function is not called in a list context, providing a default in + the validation spec still indicates that the parameter is optional. + + The hash or array returned from the function will always be a copy of + the original parameters, in order to leave @_ untouched for the calling + function. + + Simple examples of defaults would be: + + my %p = validate( @_, { foo => 1, bar => { default => 99 } } ); + + my @p = validate_pos( @_, 1, { default => 99 } ); + + In scalar context, a hash reference or array reference will be + returned, as appropriate. + +USAGE NOTES + + Validation failure + + By default, when validation fails Params::Validate calls + Carp::confess(). This can be overridden by setting the on_fail option, + which is described in the "GLOBAL" OPTIONS section. + + Method calls + + When using this module to validate the parameters passed to a method + call, you will probably want to remove the class/object from the + parameter list before calling validate() or validate_pos(). If your + method expects named parameters, then this is necessary for the + validate() function to actually work, otherwise @_ will not be usable + as a hash, because it will first have your object (or class) followed + by a set of keys and values. + + Thus the idiomatic usage of validate() in a method call will look + something like this: + + sub method { + my $self = shift; + + my %params = validate( + @_, { + foo => 1, + bar => { type => ARRAYREF }, + } + ); + } + + Speeding Up Validation + + In most cases, the validation spec will remain the same for each call + to a subroutine. In that case, you can speed up validation by defining + the validation spec just once, rather than on each call to the + subroutine: + + my %spec = ( ... ); + sub foo { + my %params = validate( @_, \%spec ); + } + + You can also use the state feature to do this: + + use feature 'state'; + + sub foo { + state $spec = { ... }; + my %params = validate( @_, $spec ); + } + +"GLOBAL" OPTIONS + + Because the API for the validate() and validate_pos() functions does + not make it possible to specify any options other than the validation + spec, it is possible to set some options as pseudo-'globals'. These + allow you to specify such things as whether or not the validation of + named parameters should be case sensitive, for one example. + + These options are called pseudo-'globals' because these settings are + only applied to calls originating from the package that set the + options. + + In other words, if I am in package Foo and I call validation_options(), + those options are only in effect when I call validate() from package + Foo. + + While this is quite different from how most other modules operate, I + feel that this is necessary in able to make it possible for one + module/application to use Params::Validate while still using other + modules that also use Params::Validate, perhaps with different options + set. + + The downside to this is that if you are writing an app with a standard + calling style for all functions, and your app has ten modules, each + module must include a call to validation_options(). You could of course + write a module that all your modules use which uses various trickery to + do this when imported. + + Options + + * normalize_keys => $callback + + This option is only relevant when dealing with named parameters. + + This callback will be used to transform the hash keys of both the + parameters and the parameter spec when validate() or validate_with() + are called. + + Any alterations made by this callback will be reflected in the + parameter hash that is returned by the validation function. For + example: + + sub foo { + return validate_with( + params => \@_, + spec => { foo => { type => SCALAR } }, + normalize_keys => + sub { my $k = shift; $k =~ s/^-//; return uc $k }, + ); + + } + + %p = foo( foo => 20 ); + + # $p{FOO} is now 20 + + %p = foo( -fOo => 50 ); + + # $p{FOO} is now 50 + + The callback must return a defined value. + + If a callback is given then the deprecated "ignore_case" and + "strip_leading" options are ignored. + + * allow_extra => $boolean + + If true, then the validation routine will allow extra parameters not + named in the validation specification. In the case of positional + parameters, this allows an unlimited number of maximum parameters + (though a minimum may still be set). Defaults to false. + + * on_fail => $callback + + If given, this callback will be called whenever a validation check + fails. It will be called with a single parameter, which will be a + string describing the failure. This is useful if you wish to have + this module throw exceptions as objects rather than as strings, for + example. + + This callback is expected to die() internally. If it does not, the + validation will proceed onwards, with unpredictable results. + + The default is to simply use the Carp module's confess() function. + + * stack_skip => $number + + This tells Params::Validate how many stack frames to skip when + finding a subroutine name to use in error messages. By default, it + looks one frame back, at the immediate caller to validate() or + validate_pos(). If this option is set, then the given number of + frames are skipped instead. + + * ignore_case => $boolean + + DEPRECATED + + This is only relevant when dealing with named parameters. If it is + true, then the validation code will ignore the case of parameter + names. Defaults to false. + + * strip_leading => $characters + + DEPRECATED + + This too is only relevant when dealing with named parameters. If this + is given then any parameters starting with these characters will be + considered equivalent to parameters without them entirely. For + example, if this is specified as '-', then -foo and foo would be + considered identical. + +PER-INVOCATION OPTIONS + + The validate_with() function can be used to set the options listed + above on a per-invocation basis. For example: + + my %p = validate_with( + params => \@_, + spec => { + foo => { type => SCALAR }, + bar => { default => 10 } + }, + allow_extra => 1, + ); + + In addition to the options listed above, it is also possible to set the + option "called", which should be a string. This string will be used in + any error messages caused by a failure to meet the validation spec. + + This subroutine will validate named parameters as a hash if the "spec" + parameter is a hash reference. If it is an array reference, the + parameters are assumed to be positional. + + my %p = validate_with( + params => \@_, + spec => { + foo => { type => SCALAR }, + bar => { default => 10 } + }, + allow_extra => 1, + called => 'The Quux::Baz class constructor', + ); + + my @p = validate_with( + params => \@_, + spec => [ + { type => SCALAR }, + { default => 10 } + ], + allow_extra => 1, + called => 'The Quux::Baz class constructor', + ); + +DISABLING VALIDATION + + If the environment variable PERL_NO_VALIDATION is set to something + true, then validation is turned off. This may be useful if you only + want to use this module during development but don't want the speed hit + during production. + + The only error that will be caught will be when an odd number of + parameters are passed into a function/method that expects a hash. + + If you want to selectively turn validation on and off at runtime, you + can directly set the $Params::Validate::NO_VALIDATION global variable. + It is strongly recommended that you localize any changes to this + variable, because other modules you are using may expect validation to + be on when they execute. For example: + + { + local $Params::Validate::NO_VALIDATION = 1; + + # no error + foo( bar => 2 ); + } + + # error + foo( bar => 2 ); + + sub foo { + my %p = validate( @_, { foo => 1 } ); + ...; + } + + But if you want to shoot yourself in the foot and just turn it off, go + ahead! + +TAINT MODE + + The XS implementation of this module has some problems Under taint mode + with version of Perl before 5.14. If validation fails, then instead of + getting the expected error message you'll get a message like "Insecure + dependency in eval_sv". This can be worked around by either untainting + the arguments yourself, using the pure Perl implementation, or + upgrading your Perl. + +LIMITATIONS + + Right now there is no way (short of a callback) to specify that + something must be of one of a list of classes, or that it must possess + one of a list of methods. If this is desired, it can be added in the + future. + + Ideally, there would be only one validation function. If someone + figures out how to do this, please let me know. + +SUPPORT + + Please submit bugs and patches to the CPAN RT system at + http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Params%3A%3AValidate or + via email at bug-params-validate@rt.cpan.org. + + Support questions can be sent to Dave at autarch@urth.org. + +DONATIONS + + If you'd like to thank me for the work I've done on this module, please + consider making a "donation" to me via PayPal. I spend a lot of free + time creating free software, and would appreciate any support you'd + care to offer. + + Please note that I am not suggesting that you must do this in order for + me to continue working on this particular software. I will continue to + do so, inasmuch as I have in the past, for as long as it interests me. + + Similarly, a donation made in this way will probably not make me work + on this software much more, unless I get so many donations that I can + consider working on free software full time, which seems unlikely at + best. + + To donate, log into PayPal and send money to autarch@urth.org or use + the button on this page: http://www.urth.org/~autarch/fs-donation.html + +AUTHORS + + * Dave Rolsky <autarch@urth.org> + + * Ilya Martynov <ilya@martynov.org> + +CONTRIBUTORS + + * Ivan Bessarabov <ivan@bessarabov.ru> + + * J.R. Mash <jmash.code@gmail.com> + + * Noel Maddy <zhtwnpanta@gmail.com> + + * Olivier Mengué <dolmen@cpan.org> + + * Vincent Pit <perl@profvince.com> + +COPYRIGHT AND LICENSE + + This software is Copyright (c) 2001 - 2015 by Dave Rolsky and Ilya + Martynov. + + This is free software, licensed under: + + The Artistic License 2.0 (GPL Compatible) + @@ -0,0 +1,19 @@ +- isa/can validation in XS allows this: + + { a => { isa => \%hash } } + +and tries to see if a->isa("HASH(0x1581)"). Instead, we should die if +given a non-array reference. Same for can, etc. See how this is +handled in callbacks for example. + + +- make it possible to explicitly not use the XS version in a non-hacky +way. + + +- is there something better than "N/A" that could be used when +validation is being done outside a sub? + + +- add an excludes param to the spec as the opposite of depends, +suggested by Diab Jerius (see rt.cpan.org). diff --git a/benchmarks/basic b/benchmarks/basic new file mode 100644 index 0000000..d31c7e2 --- /dev/null +++ b/benchmarks/basic @@ -0,0 +1,76 @@ +use Params::Validate (); + +use Benchmark; + +use strict; + +my @a = ( 1,[ 1, 2, 3 ], bless {}, 'Foo' ); +my @h = ( a => 1, b => [ 1, 2, 3 ], c => (bless {}, 'Foo'), f => 99 ); + +Benchmark::timethese( 50000, + { array => \&array, + hash => \&hash, + with => \&with, + sub1 => sub { sub1( x => 1 ) }, + sub2 => sub { sub2( x => 1 ) }, + sub3 => sub { sub3() }, + sub4 => sub { sub4(1) }, + sub5 => sub { sub5(1) }, + sub6 => sub { sub6() }, + } + ); + +sub array +{ + my %f = + eval { Params::Validate::validate_pos + ( @a, + { type => Params::Validate::SCALAR }, + { type => Params::Validate::ARRAYREF }, + { isa => 'Foo' }, + { default => {1=>2} }, + ); }; + die $@ if $@; +} + +sub hash +{ + my %f = + eval { Params::Validate::validate + ( @h, { a => { type => Params::Validate::SCALAR }, + b => { type => Params::Validate::ARRAYREF }, + c => { isa => 'Foo' }, + d => { default => {1=>2} }, + e => { optional => 1 }, + f => 1, + } ) }; + die $@ if $@; +} + +sub with +{ + my %f = + eval { Params::Validate::validate_with + ( params => \@h, + spec => { a => { type => Params::Validate::SCALAR }, + b => { type => Params::Validate::ARRAYREF }, + c => { isa => 'Foo' }, + d => { default => {1=>2} }, + e => { optional => 1 }, + f => 1, + } ) }; + die $@ if $@; +} + + +sub sub1 { Params::Validate::validate(@_, { x => 1 } ) } + +sub sub2 { my %p = Params::Validate::validate(@_, { x => 1 } ) } + +sub sub3 { my %p = Params::Validate::validate(@_, { x => { default => 1 } } ) } + +sub sub4 { Params::Validate::validate_pos(@_, 1) } + +sub sub5 { my @p = Params::Validate::validate_pos(@_, 1) }; + +sub sub6 { my @p = Params::Validate::validate_pos(@_, { default => 1 } ) } diff --git a/c/ppport.h b/c/ppport.h new file mode 100644 index 0000000..382f8b1 --- /dev/null +++ b/c/ppport.h @@ -0,0 +1,7258 @@ +#if 0 +<<'SKIP'; +#endif +/* +---------------------------------------------------------------------- + + ppport.h -- Perl/Pollution/Portability Version 3.20 + + Automatically created by Devel::PPPort running under perl 5.014002. + + Do NOT edit this file directly! -- Edit PPPort_pm.PL and the + includes in parts/inc/ instead. + + Use 'perldoc ppport.h' to view the documentation below. + +---------------------------------------------------------------------- + +SKIP + +=pod + +=head1 NAME + +ppport.h - Perl/Pollution/Portability version 3.20 + +=head1 SYNOPSIS + + perl ppport.h [options] [source files] + + Searches current directory for files if no [source files] are given + + --help show short help + + --version show version + + --patch=file write one patch file with changes + --copy=suffix write changed copies with suffix + --diff=program use diff program and options + + --compat-version=version provide compatibility with Perl version + --cplusplus accept C++ comments + + --quiet don't output anything except fatal errors + --nodiag don't show diagnostics + --nohints don't show hints + --nochanges don't suggest changes + --nofilter don't filter input files + + --strip strip all script and doc functionality from + ppport.h + + --list-provided list provided API + --list-unsupported list unsupported API + --api-info=name show Perl API portability information + +=head1 COMPATIBILITY + +This version of F<ppport.h> is designed to support operation with Perl +installations back to 5.003, and has been tested up to 5.11.5. + +=head1 OPTIONS + +=head2 --help + +Display a brief usage summary. + +=head2 --version + +Display the version of F<ppport.h>. + +=head2 --patch=I<file> + +If this option is given, a single patch file will be created if +any changes are suggested. This requires a working diff program +to be installed on your system. + +=head2 --copy=I<suffix> + +If this option is given, a copy of each file will be saved with +the given suffix that contains the suggested changes. This does +not require any external programs. Note that this does not +automagially add a dot between the original filename and the +suffix. If you want the dot, you have to include it in the option +argument. + +If neither C<--patch> or C<--copy> are given, the default is to +simply print the diffs for each file. This requires either +C<Text::Diff> or a C<diff> program to be installed. + +=head2 --diff=I<program> + +Manually set the diff program and options to use. The default +is to use C<Text::Diff>, when installed, and output unified +context diffs. + +=head2 --compat-version=I<version> + +Tell F<ppport.h> to check for compatibility with the given +Perl version. The default is to check for compatibility with Perl +version 5.003. You can use this option to reduce the output +of F<ppport.h> if you intend to be backward compatible only +down to a certain Perl version. + +=head2 --cplusplus + +Usually, F<ppport.h> will detect C++ style comments and +replace them with C style comments for portability reasons. +Using this option instructs F<ppport.h> to leave C++ +comments untouched. + +=head2 --quiet + +Be quiet. Don't print anything except fatal errors. + +=head2 --nodiag + +Don't output any diagnostic messages. Only portability +alerts will be printed. + +=head2 --nohints + +Don't output any hints. Hints often contain useful portability +notes. Warnings will still be displayed. + +=head2 --nochanges + +Don't suggest any changes. Only give diagnostic output and hints +unless these are also deactivated. + +=head2 --nofilter + +Don't filter the list of input files. By default, files not looking +like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. + +=head2 --strip + +Strip all script and documentation functionality from F<ppport.h>. +This reduces the size of F<ppport.h> dramatically and may be useful +if you want to include F<ppport.h> in smaller modules without +increasing their distribution size too much. + +The stripped F<ppport.h> will have a C<--unstrip> option that allows +you to undo the stripping, but only if an appropriate C<Devel::PPPort> +module is installed. + +=head2 --list-provided + +Lists the API elements for which compatibility is provided by +F<ppport.h>. Also lists if it must be explicitly requested, +if it has dependencies, and if there are hints or warnings for it. + +=head2 --list-unsupported + +Lists the API elements that are known not to be supported by +F<ppport.h> and below which version of Perl they probably +won't be available or work. + +=head2 --api-info=I<name> + +Show portability information for API elements matching I<name>. +If I<name> is surrounded by slashes, it is interpreted as a regular +expression. + +=head1 DESCRIPTION + +In order for a Perl extension (XS) module to be as portable as possible +across differing versions of Perl itself, certain steps need to be taken. + +=over 4 + +=item * + +Including this header is the first major one. This alone will give you +access to a large part of the Perl API that hasn't been available in +earlier Perl releases. Use + + perl ppport.h --list-provided + +to see which API elements are provided by ppport.h. + +=item * + +You should avoid using deprecated parts of the API. For example, using +global Perl variables without the C<PL_> prefix is deprecated. Also, +some API functions used to have a C<perl_> prefix. Using this form is +also deprecated. You can safely use the supported API, as F<ppport.h> +will provide wrappers for older Perl versions. + +=item * + +If you use one of a few functions or variables that were not present in +earlier versions of Perl, and that can't be provided using a macro, you +have to explicitly request support for these functions by adding one or +more C<#define>s in your source code before the inclusion of F<ppport.h>. + +These functions or variables will be marked C<explicit> in the list shown +by C<--list-provided>. + +Depending on whether you module has a single or multiple files that +use such functions or variables, you want either C<static> or global +variants. + +For a C<static> function or variable (used only in a single source +file), use: + + #define NEED_function + #define NEED_variable + +For a global function or variable (used in multiple source files), +use: + + #define NEED_function_GLOBAL + #define NEED_variable_GLOBAL + +Note that you mustn't have more than one global request for the +same function or variable in your project. + + Function / Variable Static Request Global Request + ----------------------------------------------------------------------------------------- + PL_parser NEED_PL_parser NEED_PL_parser_GLOBAL + PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL + eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL + grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL + grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL + grok_number() NEED_grok_number NEED_grok_number_GLOBAL + grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL + grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL + load_module() NEED_load_module NEED_load_module_GLOBAL + my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL + my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL + my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL + my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL + newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL + newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL + newSV_type() NEED_newSV_type NEED_newSV_type_GLOBAL + newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL + newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL + pv_display() NEED_pv_display NEED_pv_display_GLOBAL + pv_escape() NEED_pv_escape NEED_pv_escape_GLOBAL + pv_pretty() NEED_pv_pretty NEED_pv_pretty_GLOBAL + sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL + sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL + sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL + sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL + sv_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_GLOBAL + sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL + sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL + vload_module() NEED_vload_module NEED_vload_module_GLOBAL + vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL + warner() NEED_warner NEED_warner_GLOBAL + +To avoid namespace conflicts, you can change the namespace of the +explicitly exported functions / variables using the C<DPPP_NAMESPACE> +macro. Just C<#define> the macro before including C<ppport.h>: + + #define DPPP_NAMESPACE MyOwnNamespace_ + #include "ppport.h" + +The default namespace is C<DPPP_>. + +=back + +The good thing is that most of the above can be checked by running +F<ppport.h> on your source code. See the next section for +details. + +=head1 EXAMPLES + +To verify whether F<ppport.h> is needed for your module, whether you +should make any changes to your code, and whether any special defines +should be used, F<ppport.h> can be run as a Perl script to check your +source code. Simply say: + + perl ppport.h + +The result will usually be a list of patches suggesting changes +that should at least be acceptable, if not necessarily the most +efficient solution, or a fix for all possible problems. + +If you know that your XS module uses features only available in +newer Perl releases, if you're aware that it uses C++ comments, +and if you want all suggestions as a single patch file, you could +use something like this: + + perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff + +If you only want your code to be scanned without any suggestions +for changes, use: + + perl ppport.h --nochanges + +You can specify a different C<diff> program or options, using +the C<--diff> option: + + perl ppport.h --diff='diff -C 10' + +This would output context diffs with 10 lines of context. + +If you want to create patched copies of your files instead, use: + + perl ppport.h --copy=.new + +To display portability information for the C<newSVpvn> function, +use: + + perl ppport.h --api-info=newSVpvn + +Since the argument to C<--api-info> can be a regular expression, +you can use + + perl ppport.h --api-info=/_nomg$/ + +to display portability information for all C<_nomg> functions or + + perl ppport.h --api-info=/./ + +to display information for all known API elements. + +=head1 BUGS + +If this version of F<ppport.h> is causing failure during +the compilation of this module, please check if newer versions +of either this module or C<Devel::PPPort> are available on CPAN +before sending a bug report. + +If F<ppport.h> was generated using the latest version of +C<Devel::PPPort> and is causing failure of this module, please +file a bug report using the CPAN Request Tracker at L<http://rt.cpan.org/>. + +Please include the following information: + +=over 4 + +=item 1. + +The complete output from running "perl -V" + +=item 2. + +This file. + +=item 3. + +The name and version of the module you were trying to build. + +=item 4. + +A full log of the build that failed. + +=item 5. + +Any other information that you think could be relevant. + +=back + +For the latest version of this code, please get the C<Devel::PPPort> +module from CPAN. + +=head1 COPYRIGHT + +Version 3.x, Copyright (c) 2004-2010, Marcus Holland-Moritz. + +Version 2.x, Copyright (C) 2001, Paul Marquess. + +Version 1.x, Copyright (C) 1999, Kenneth Albanowski. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<Devel::PPPort>. + +=cut + +use strict; + +# Disable broken TRIE-optimization +BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } + +my $VERSION = 3.20; + +my %opt = ( + quiet => 0, + diag => 1, + hints => 1, + changes => 1, + cplusplus => 0, + filter => 1, + strip => 0, + version => 0, +); + +my($ppport) = $0 =~ /([\w.]+)$/; +my $LF = '(?:\r\n|[\r\n])'; # line feed +my $HS = "[ \t]"; # horizontal whitespace + +# Never use C comments in this file! +my $ccs = '/'.'*'; +my $cce = '*'.'/'; +my $rccs = quotemeta $ccs; +my $rcce = quotemeta $cce; + +eval { + require Getopt::Long; + Getopt::Long::GetOptions(\%opt, qw( + help quiet diag! filter! hints! changes! cplusplus strip version + patch=s copy=s diff=s compat-version=s + list-provided list-unsupported api-info=s + )) or usage(); +}; + +if ($@ and grep /^-/, @ARGV) { + usage() if "@ARGV" =~ /^--?h(?:elp)?$/; + die "Getopt::Long not found. Please don't use any options.\n"; +} + +if ($opt{version}) { + print "This is $0 $VERSION.\n"; + exit 0; +} + +usage() if $opt{help}; +strip() if $opt{strip}; + +if (exists $opt{'compat-version'}) { + my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; + if ($@) { + die "Invalid version number format: '$opt{'compat-version'}'\n"; + } + die "Only Perl 5 is supported\n" if $r != 5; + die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; + $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; +} +else { + $opt{'compat-version'} = 5; +} + +my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ + ? ( $1 => { + ($2 ? ( base => $2 ) : ()), + ($3 ? ( todo => $3 ) : ()), + (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), + (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), + (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), + } ) + : die "invalid spec: $_" } qw( +AvFILLp|5.004050||p +AvFILL||| +BhkDISABLE||5.014000| +BhkENABLE||5.014000| +BhkENTRY_set||5.014000| +BhkENTRY||| +BhkFLAGS||| +CALL_BLOCK_HOOKS||| +CLASS|||n +CPERLscope|5.005000||p +CX_CURPAD_SAVE||| +CX_CURPAD_SV||| +CopFILEAV|5.006000||p +CopFILEGV_set|5.006000||p +CopFILEGV|5.006000||p +CopFILESV|5.006000||p +CopFILE_set|5.006000||p +CopFILE|5.006000||p +CopSTASHPV_set|5.006000||p +CopSTASHPV|5.006000||p +CopSTASH_eq|5.006000||p +CopSTASH_set|5.006000||p +CopSTASH|5.006000||p +CopyD|5.009002||p +Copy||| +CvPADLIST||| +CvSTASH||| +CvWEAKOUTSIDE||| +DEFSV_set|5.010001||p +DEFSV|5.004050||p +END_EXTERN_C|5.005000||p +ENTER||| +ERRSV|5.004050||p +EXTEND||| +EXTERN_C|5.005000||p +F0convert|||n +FREETMPS||| +GIMME_V||5.004000|n +GIMME|||n +GROK_NUMERIC_RADIX|5.007002||p +G_ARRAY||| +G_DISCARD||| +G_EVAL||| +G_METHOD|5.006001||p +G_NOARGS||| +G_SCALAR||| +G_VOID||5.004000| +GetVars||| +GvSVn|5.009003||p +GvSV||| +Gv_AMupdate||5.011000| +HEf_SVKEY||5.004000| +HeHASH||5.004000| +HeKEY||5.004000| +HeKLEN||5.004000| +HePV||5.004000| +HeSVKEY_force||5.004000| +HeSVKEY_set||5.004000| +HeSVKEY||5.004000| +HeUTF8||5.010001| +HeVAL||5.004000| +HvENAME||5.013007| +HvNAMELEN_get|5.009003||p +HvNAME_get|5.009003||p +HvNAME||| +INT2PTR|5.006000||p +IN_LOCALE_COMPILETIME|5.007002||p +IN_LOCALE_RUNTIME|5.007002||p +IN_LOCALE|5.007002||p +IN_PERL_COMPILETIME|5.008001||p +IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p +IS_NUMBER_INFINITY|5.007002||p +IS_NUMBER_IN_UV|5.007002||p +IS_NUMBER_NAN|5.007003||p +IS_NUMBER_NEG|5.007002||p +IS_NUMBER_NOT_INT|5.007002||p +IVSIZE|5.006000||p +IVTYPE|5.006000||p +IVdf|5.006000||p +LEAVE||| +LINKLIST||5.013006| +LVRET||| +MARK||| +MULTICALL||5.014000| +MY_CXT_CLONE|5.009002||p +MY_CXT_INIT|5.007003||p +MY_CXT|5.007003||p +MoveD|5.009002||p +Move||| +NOOP|5.005000||p +NUM2PTR|5.006000||p +NVTYPE|5.006000||p +NVef|5.006001||p +NVff|5.006001||p +NVgf|5.006001||p +Newxc|5.009003||p +Newxz|5.009003||p +Newx|5.009003||p +Nullav||| +Nullch||| +Nullcv||| +Nullhv||| +Nullsv||| +OP_CLASS||5.013007| +OP_DESC||5.007003| +OP_NAME||5.007003| +ORIGMARK||| +PAD_BASE_SV||| +PAD_CLONE_VARS||| +PAD_COMPNAME_FLAGS||| +PAD_COMPNAME_GEN_set||| +PAD_COMPNAME_GEN||| +PAD_COMPNAME_OURSTASH||| +PAD_COMPNAME_PV||| +PAD_COMPNAME_TYPE||| +PAD_DUP||| +PAD_RESTORE_LOCAL||| +PAD_SAVE_LOCAL||| +PAD_SAVE_SETNULLPAD||| +PAD_SETSV||| +PAD_SET_CUR_NOSAVE||| +PAD_SET_CUR||| +PAD_SVl||| +PAD_SV||| +PERLIO_FUNCS_CAST|5.009003||p +PERLIO_FUNCS_DECL|5.009003||p +PERL_ABS|5.008001||p +PERL_BCDVERSION|5.014000||p +PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p +PERL_HASH|5.004000||p +PERL_INT_MAX|5.004000||p +PERL_INT_MIN|5.004000||p +PERL_LONG_MAX|5.004000||p +PERL_LONG_MIN|5.004000||p +PERL_MAGIC_arylen|5.007002||p +PERL_MAGIC_backref|5.007002||p +PERL_MAGIC_bm|5.007002||p +PERL_MAGIC_collxfrm|5.007002||p +PERL_MAGIC_dbfile|5.007002||p +PERL_MAGIC_dbline|5.007002||p +PERL_MAGIC_defelem|5.007002||p +PERL_MAGIC_envelem|5.007002||p +PERL_MAGIC_env|5.007002||p +PERL_MAGIC_ext|5.007002||p +PERL_MAGIC_fm|5.007002||p +PERL_MAGIC_glob|5.014000||p +PERL_MAGIC_isaelem|5.007002||p +PERL_MAGIC_isa|5.007002||p +PERL_MAGIC_mutex|5.014000||p +PERL_MAGIC_nkeys|5.007002||p +PERL_MAGIC_overload_elem|5.007002||p +PERL_MAGIC_overload_table|5.007002||p +PERL_MAGIC_overload|5.007002||p +PERL_MAGIC_pos|5.007002||p +PERL_MAGIC_qr|5.007002||p +PERL_MAGIC_regdata|5.007002||p +PERL_MAGIC_regdatum|5.007002||p +PERL_MAGIC_regex_global|5.007002||p +PERL_MAGIC_shared_scalar|5.007003||p +PERL_MAGIC_shared|5.007003||p +PERL_MAGIC_sigelem|5.007002||p +PERL_MAGIC_sig|5.007002||p +PERL_MAGIC_substr|5.007002||p +PERL_MAGIC_sv|5.007002||p +PERL_MAGIC_taint|5.007002||p +PERL_MAGIC_tiedelem|5.007002||p +PERL_MAGIC_tiedscalar|5.007002||p +PERL_MAGIC_tied|5.007002||p +PERL_MAGIC_utf8|5.008001||p +PERL_MAGIC_uvar_elem|5.007003||p +PERL_MAGIC_uvar|5.007002||p +PERL_MAGIC_vec|5.007002||p +PERL_MAGIC_vstring|5.008001||p +PERL_PV_ESCAPE_ALL|5.009004||p +PERL_PV_ESCAPE_FIRSTCHAR|5.009004||p +PERL_PV_ESCAPE_NOBACKSLASH|5.009004||p +PERL_PV_ESCAPE_NOCLEAR|5.009004||p +PERL_PV_ESCAPE_QUOTE|5.009004||p +PERL_PV_ESCAPE_RE|5.009005||p +PERL_PV_ESCAPE_UNI_DETECT|5.009004||p +PERL_PV_ESCAPE_UNI|5.009004||p +PERL_PV_PRETTY_DUMP|5.009004||p +PERL_PV_PRETTY_ELLIPSES|5.010000||p +PERL_PV_PRETTY_LTGT|5.009004||p +PERL_PV_PRETTY_NOCLEAR|5.010000||p +PERL_PV_PRETTY_QUOTE|5.009004||p +PERL_PV_PRETTY_REGPROP|5.009004||p +PERL_QUAD_MAX|5.004000||p +PERL_QUAD_MIN|5.004000||p +PERL_REVISION|5.006000||p +PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p +PERL_SCAN_DISALLOW_PREFIX|5.007003||p +PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p +PERL_SCAN_SILENT_ILLDIGIT|5.008001||p +PERL_SHORT_MAX|5.004000||p +PERL_SHORT_MIN|5.004000||p +PERL_SIGNALS_UNSAFE_FLAG|5.008001||p +PERL_SUBVERSION|5.006000||p +PERL_SYS_INIT3||5.006000| +PERL_SYS_INIT||| +PERL_SYS_TERM||5.014000| +PERL_UCHAR_MAX|5.004000||p +PERL_UCHAR_MIN|5.004000||p +PERL_UINT_MAX|5.004000||p +PERL_UINT_MIN|5.004000||p +PERL_ULONG_MAX|5.004000||p +PERL_ULONG_MIN|5.004000||p +PERL_UNUSED_ARG|5.009003||p +PERL_UNUSED_CONTEXT|5.009004||p +PERL_UNUSED_DECL|5.007002||p +PERL_UNUSED_VAR|5.007002||p +PERL_UQUAD_MAX|5.004000||p +PERL_UQUAD_MIN|5.004000||p +PERL_USE_GCC_BRACE_GROUPS|5.009004||p +PERL_USHORT_MAX|5.004000||p +PERL_USHORT_MIN|5.004000||p +PERL_VERSION|5.006000||p +PL_DBsignal|5.005000||p +PL_DBsingle|||pn +PL_DBsub|||pn +PL_DBtrace|||pn +PL_Sv|5.005000||p +PL_bufend|5.014000||p +PL_bufptr|5.014000||p +PL_compiling|5.004050||p +PL_copline|5.014000||p +PL_curcop|5.004050||p +PL_curstash|5.004050||p +PL_debstash|5.004050||p +PL_defgv|5.004050||p +PL_diehook|5.004050||p +PL_dirty|5.004050||p +PL_dowarn|||pn +PL_errgv|5.004050||p +PL_error_count|5.014000||p +PL_expect|5.014000||p +PL_hexdigit|5.005000||p +PL_hints|5.005000||p +PL_in_my_stash|5.014000||p +PL_in_my|5.014000||p +PL_keyword_plugin||5.011002| +PL_last_in_gv|||n +PL_laststatval|5.005000||p +PL_lex_state|5.014000||p +PL_lex_stuff|5.014000||p +PL_linestr|5.014000||p +PL_modglobal||5.005000|n +PL_na|5.004050||pn +PL_no_modify|5.006000||p +PL_ofsgv|||n +PL_opfreehook||5.011000|n +PL_parser|5.009005|5.009005|p +PL_peepp||5.007003|n +PL_perl_destruct_level|5.004050||p +PL_perldb|5.004050||p +PL_ppaddr|5.006000||p +PL_rpeepp||5.013005|n +PL_rsfp_filters|5.014000||p +PL_rsfp|5.014000||p +PL_rs|||n +PL_signals|5.008001||p +PL_stack_base|5.004050||p +PL_stack_sp|5.004050||p +PL_statcache|5.005000||p +PL_stdingv|5.004050||p +PL_sv_arenaroot|5.004050||p +PL_sv_no|5.004050||pn +PL_sv_undef|5.004050||pn +PL_sv_yes|5.004050||pn +PL_tainted|5.004050||p +PL_tainting|5.004050||p +PL_tokenbuf|5.014000||p +POP_MULTICALL||5.014000| +POPi|||n +POPl|||n +POPn|||n +POPpbytex||5.007001|n +POPpx||5.005030|n +POPp|||n +POPs|||n +PTR2IV|5.006000||p +PTR2NV|5.006000||p +PTR2UV|5.006000||p +PTR2nat|5.009003||p +PTR2ul|5.007001||p +PTRV|5.006000||p +PUSHMARK||| +PUSH_MULTICALL||5.014000| +PUSHi||| +PUSHmortal|5.009002||p +PUSHn||| +PUSHp||| +PUSHs||| +PUSHu|5.004000||p +PUTBACK||| +PerlIO_clearerr||5.007003| +PerlIO_close||5.007003| +PerlIO_context_layers||5.009004| +PerlIO_eof||5.007003| +PerlIO_error||5.007003| +PerlIO_fileno||5.007003| +PerlIO_fill||5.007003| +PerlIO_flush||5.007003| +PerlIO_get_base||5.007003| +PerlIO_get_bufsiz||5.007003| +PerlIO_get_cnt||5.007003| +PerlIO_get_ptr||5.007003| +PerlIO_read||5.007003| +PerlIO_seek||5.007003| +PerlIO_set_cnt||5.007003| +PerlIO_set_ptrcnt||5.007003| +PerlIO_setlinebuf||5.007003| +PerlIO_stderr||5.007003| +PerlIO_stdin||5.007003| +PerlIO_stdout||5.007003| +PerlIO_tell||5.007003| +PerlIO_unread||5.007003| +PerlIO_write||5.007003| +Perl_signbit||5.009005|n +PoisonFree|5.009004||p +PoisonNew|5.009004||p +PoisonWith|5.009004||p +Poison|5.008000||p +RETVAL|||n +Renewc||| +Renew||| +SAVECLEARSV||| +SAVECOMPPAD||| +SAVEPADSV||| +SAVETMPS||| +SAVE_DEFSV|5.004050||p +SPAGAIN||| +SP||| +START_EXTERN_C|5.005000||p +START_MY_CXT|5.007003||p +STMT_END|||p +STMT_START|||p +STR_WITH_LEN|5.009003||p +ST||| +SV_CONST_RETURN|5.009003||p +SV_COW_DROP_PV|5.008001||p +SV_COW_SHARED_HASH_KEYS|5.009005||p +SV_GMAGIC|5.007002||p +SV_HAS_TRAILING_NUL|5.009004||p +SV_IMMEDIATE_UNREF|5.007001||p +SV_MUTABLE_RETURN|5.009003||p +SV_NOSTEAL|5.009002||p +SV_SMAGIC|5.009003||p +SV_UTF8_NO_ENCODING|5.008001||p +SVfARG|5.009005||p +SVf_UTF8|5.006000||p +SVf|5.006000||p +SVt_IV||| +SVt_NV||| +SVt_PVAV||| +SVt_PVCV||| +SVt_PVHV||| +SVt_PVMG||| +SVt_PV||| +Safefree||| +Slab_Alloc||| +Slab_Free||| +Slab_to_rw||| +StructCopy||| +SvCUR_set||| +SvCUR||| +SvEND||| +SvGAMAGIC||5.006001| +SvGETMAGIC|5.004050||p +SvGROW||| +SvIOK_UV||5.006000| +SvIOK_notUV||5.006000| +SvIOK_off||| +SvIOK_only_UV||5.006000| +SvIOK_only||| +SvIOK_on||| +SvIOKp||| +SvIOK||| +SvIVX||| +SvIV_nomg|5.009001||p +SvIV_set||| +SvIVx||| +SvIV||| +SvIsCOW_shared_hash||5.008003| +SvIsCOW||5.008003| +SvLEN_set||| +SvLEN||| +SvLOCK||5.007003| +SvMAGIC_set|5.009003||p +SvNIOK_off||| +SvNIOKp||| +SvNIOK||| +SvNOK_off||| +SvNOK_only||| +SvNOK_on||| +SvNOKp||| +SvNOK||| +SvNVX||| +SvNV_nomg||5.013002| +SvNV_set||| +SvNVx||| +SvNV||| +SvOK||| +SvOOK_offset||5.011000| +SvOOK||| +SvPOK_off||| +SvPOK_only_UTF8||5.006000| +SvPOK_only||| +SvPOK_on||| +SvPOKp||| +SvPOK||| +SvPVX_const|5.009003||p +SvPVX_mutable|5.009003||p +SvPVX||| +SvPV_const|5.009003||p +SvPV_flags_const_nolen|5.009003||p +SvPV_flags_const|5.009003||p +SvPV_flags_mutable|5.009003||p +SvPV_flags|5.007002||p +SvPV_force_flags_mutable|5.009003||p +SvPV_force_flags_nolen|5.009003||p +SvPV_force_flags|5.007002||p +SvPV_force_mutable|5.009003||p +SvPV_force_nolen|5.009003||p +SvPV_force_nomg_nolen|5.009003||p +SvPV_force_nomg|5.007002||p +SvPV_force|||p +SvPV_mutable|5.009003||p +SvPV_nolen_const|5.009003||p +SvPV_nolen|5.006000||p +SvPV_nomg_const_nolen|5.009003||p +SvPV_nomg_const|5.009003||p +SvPV_nomg_nolen||5.013007| +SvPV_nomg|5.007002||p +SvPV_renew|5.009003||p +SvPV_set||| +SvPVbyte_force||5.009002| +SvPVbyte_nolen||5.006000| +SvPVbytex_force||5.006000| +SvPVbytex||5.006000| +SvPVbyte|5.006000||p +SvPVutf8_force||5.006000| +SvPVutf8_nolen||5.006000| +SvPVutf8x_force||5.006000| +SvPVutf8x||5.006000| +SvPVutf8||5.006000| +SvPVx||| +SvPV||| +SvREFCNT_dec||| +SvREFCNT_inc_NN|5.009004||p +SvREFCNT_inc_simple_NN|5.009004||p +SvREFCNT_inc_simple_void_NN|5.009004||p +SvREFCNT_inc_simple_void|5.009004||p +SvREFCNT_inc_simple|5.009004||p +SvREFCNT_inc_void_NN|5.009004||p +SvREFCNT_inc_void|5.009004||p +SvREFCNT_inc|||p +SvREFCNT||| +SvROK_off||| +SvROK_on||| +SvROK||| +SvRV_set|5.009003||p +SvRV||| +SvRXOK||5.009005| +SvRX||5.009005| +SvSETMAGIC||| +SvSHARED_HASH|5.009003||p +SvSHARE||5.007003| +SvSTASH_set|5.009003||p +SvSTASH||| +SvSetMagicSV_nosteal||5.004000| +SvSetMagicSV||5.004000| +SvSetSV_nosteal||5.004000| +SvSetSV||| +SvTAINTED_off||5.004000| +SvTAINTED_on||5.004000| +SvTAINTED||5.004000| +SvTAINT||| +SvTRUE_nomg||5.013006| +SvTRUE||| +SvTYPE||| +SvUNLOCK||5.007003| +SvUOK|5.007001|5.006000|p +SvUPGRADE||| +SvUTF8_off||5.006000| +SvUTF8_on||5.006000| +SvUTF8||5.006000| +SvUVXx|5.004000||p +SvUVX|5.004000||p +SvUV_nomg|5.009001||p +SvUV_set|5.009003||p +SvUVx|5.004000||p +SvUV|5.004000||p +SvVOK||5.008001| +SvVSTRING_mg|5.009004||p +THIS|||n +UNDERBAR|5.009002||p +UTF8_MAXBYTES|5.009002||p +UVSIZE|5.006000||p +UVTYPE|5.006000||p +UVXf|5.007001||p +UVof|5.006000||p +UVuf|5.006000||p +UVxf|5.006000||p +WARN_ALL|5.006000||p +WARN_AMBIGUOUS|5.006000||p +WARN_ASSERTIONS|5.014000||p +WARN_BAREWORD|5.006000||p +WARN_CLOSED|5.006000||p +WARN_CLOSURE|5.006000||p +WARN_DEBUGGING|5.006000||p +WARN_DEPRECATED|5.006000||p +WARN_DIGIT|5.006000||p +WARN_EXEC|5.006000||p +WARN_EXITING|5.006000||p +WARN_GLOB|5.006000||p +WARN_INPLACE|5.006000||p +WARN_INTERNAL|5.006000||p +WARN_IO|5.006000||p +WARN_LAYER|5.008000||p +WARN_MALLOC|5.006000||p +WARN_MISC|5.006000||p +WARN_NEWLINE|5.006000||p +WARN_NUMERIC|5.006000||p +WARN_ONCE|5.006000||p +WARN_OVERFLOW|5.006000||p +WARN_PACK|5.006000||p +WARN_PARENTHESIS|5.006000||p +WARN_PIPE|5.006000||p +WARN_PORTABLE|5.006000||p +WARN_PRECEDENCE|5.006000||p +WARN_PRINTF|5.006000||p +WARN_PROTOTYPE|5.006000||p +WARN_QW|5.006000||p +WARN_RECURSION|5.006000||p +WARN_REDEFINE|5.006000||p +WARN_REGEXP|5.006000||p +WARN_RESERVED|5.006000||p +WARN_SEMICOLON|5.006000||p +WARN_SEVERE|5.006000||p +WARN_SIGNAL|5.006000||p +WARN_SUBSTR|5.006000||p +WARN_SYNTAX|5.006000||p +WARN_TAINT|5.006000||p +WARN_THREADS|5.008000||p +WARN_UNINITIALIZED|5.006000||p +WARN_UNOPENED|5.006000||p +WARN_UNPACK|5.006000||p +WARN_UNTIE|5.006000||p +WARN_UTF8|5.006000||p +WARN_VOID|5.006000||p +XCPT_CATCH|5.009002||p +XCPT_RETHROW|5.009002||p +XCPT_TRY_END|5.009002||p +XCPT_TRY_START|5.009002||p +XPUSHi||| +XPUSHmortal|5.009002||p +XPUSHn||| +XPUSHp||| +XPUSHs||| +XPUSHu|5.004000||p +XSPROTO|5.010000||p +XSRETURN_EMPTY||| +XSRETURN_IV||| +XSRETURN_NO||| +XSRETURN_NV||| +XSRETURN_PV||| +XSRETURN_UNDEF||| +XSRETURN_UV|5.008001||p +XSRETURN_YES||| +XSRETURN|||p +XST_mIV||| +XST_mNO||| +XST_mNV||| +XST_mPV||| +XST_mUNDEF||| +XST_mUV|5.008001||p +XST_mYES||| +XS_APIVERSION_BOOTCHECK||5.013004| +XS_VERSION_BOOTCHECK||| +XS_VERSION||| +XSprePUSH|5.006000||p +XS||| +XopDISABLE||5.014000| +XopENABLE||5.014000| +XopENTRY_set||5.014000| +XopENTRY||5.014000| +XopFLAGS||5.013007| +ZeroD|5.009002||p +Zero||| +_aMY_CXT|5.007003||p +_append_range_to_invlist||| +_new_invlist||| +_pMY_CXT|5.007003||p +_swash_inversion_hash||| +_swash_to_invlist||| +aMY_CXT_|5.007003||p +aMY_CXT|5.007003||p +aTHXR_|5.014000||p +aTHXR|5.014000||p +aTHX_|5.006000||p +aTHX|5.006000||p +add_alternate||| +add_cp_to_invlist||| +add_data|||n +add_range_to_invlist||| +add_utf16_textfilter||| +addmad||| +allocmy||| +amagic_call||| +amagic_cmp_locale||| +amagic_cmp||| +amagic_deref_call||5.013007| +amagic_i_ncmp||| +amagic_ncmp||| +anonymise_cv_maybe||| +any_dup||| +ao||| +append_madprops||| +apply_attrs_my||| +apply_attrs_string||5.006001| +apply_attrs||| +apply||| +assert_uft8_cache_coherent||| +atfork_lock||5.007003|n +atfork_unlock||5.007003|n +av_arylen_p||5.009003| +av_clear||| +av_create_and_push||5.009005| +av_create_and_unshift_one||5.009005| +av_delete||5.006000| +av_exists||5.006000| +av_extend||| +av_fetch||| +av_fill||| +av_iter_p||5.011000| +av_len||| +av_make||| +av_pop||| +av_push||| +av_reify||| +av_shift||| +av_store||| +av_undef||| +av_unshift||| +ax|||n +bad_type||| +bind_match||| +block_end||| +block_gimme||5.004000| +block_start||| +blockhook_register||5.013003| +boolSV|5.004000||p +boot_core_PerlIO||| +boot_core_UNIVERSAL||| +boot_core_mro||| +bytes_cmp_utf8||5.013007| +bytes_from_utf8||5.007001| +bytes_to_uni|||n +bytes_to_utf8||5.006001| +call_argv|5.006000||p +call_atexit||5.006000| +call_list||5.004000| +call_method|5.006000||p +call_pv|5.006000||p +call_sv|5.006000||p +caller_cx||5.013005| +calloc||5.007002|n +cando||| +cast_i32||5.006000| +cast_iv||5.006000| +cast_ulong||5.006000| +cast_uv||5.006000| +check_type_and_open||| +check_uni||| +check_utf8_print||| +checkcomma||| +checkposixcc||| +ckWARN|5.006000||p +ck_entersub_args_list||5.013006| +ck_entersub_args_proto_or_list||5.013006| +ck_entersub_args_proto||5.013006| +ck_warner_d||5.011001|v +ck_warner||5.011001|v +ckwarn_common||| +ckwarn_d||5.009003| +ckwarn||5.009003| +cl_and|||n +cl_anything|||n +cl_init|||n +cl_is_anything|||n +cl_or|||n +clear_placeholders||| +clone_params_del|||n +clone_params_new|||n +closest_cop||| +convert||| +cop_free||| +cop_hints_2hv||5.013007| +cop_hints_fetch_pvn||5.013007| +cop_hints_fetch_pvs||5.013007| +cop_hints_fetch_pv||5.013007| +cop_hints_fetch_sv||5.013007| +cophh_2hv||5.013007| +cophh_copy||5.013007| +cophh_delete_pvn||5.013007| +cophh_delete_pvs||5.013007| +cophh_delete_pv||5.013007| +cophh_delete_sv||5.013007| +cophh_fetch_pvn||5.013007| +cophh_fetch_pvs||5.013007| +cophh_fetch_pv||5.013007| +cophh_fetch_sv||5.013007| +cophh_free||5.013007| +cophh_new_empty||5.014000| +cophh_store_pvn||5.013007| +cophh_store_pvs||5.013007| +cophh_store_pv||5.013007| +cophh_store_sv||5.013007| +cr_textfilter||| +create_eval_scope||| +croak_no_modify||5.013003| +croak_nocontext|||vn +croak_sv||5.013001| +croak_xs_usage||5.010001| +croak|||v +csighandler||5.009003|n +curmad||| +curse||| +custom_op_desc||5.007003| +custom_op_name||5.007003| +custom_op_register||5.013007| +custom_op_xop||5.013007| +cv_ckproto_len||| +cv_clone||| +cv_const_sv||5.004000| +cv_dump||| +cv_get_call_checker||5.013006| +cv_set_call_checker||5.013006| +cv_undef||| +cvgv_set||| +cvstash_set||| +cx_dump||5.005000| +cx_dup||| +cxinc||| +dAXMARK|5.009003||p +dAX|5.007002||p +dITEMS|5.007002||p +dMARK||| +dMULTICALL||5.009003| +dMY_CXT_SV|5.007003||p +dMY_CXT|5.007003||p +dNOOP|5.006000||p +dORIGMARK||| +dSP||| +dTHR|5.004050||p +dTHXR|5.014000||p +dTHXa|5.006000||p +dTHXoa|5.006000||p +dTHX|5.006000||p +dUNDERBAR|5.009002||p +dVAR|5.009003||p +dXCPT|5.009002||p +dXSARGS||| +dXSI32||| +dXSTARG|5.006000||p +deb_curcv||| +deb_nocontext|||vn +deb_stack_all||| +deb_stack_n||| +debop||5.005000| +debprofdump||5.005000| +debprof||| +debstackptrs||5.007003| +debstack||5.007003| +debug_start_match||| +deb||5.007003|v +del_sv||| +delete_eval_scope||| +delimcpy||5.004000|n +deprecate_commaless_var_list||| +despatch_signals||5.007001| +destroy_matcher||| +die_nocontext|||vn +die_sv||5.013001| +die_unwind||| +die|||v +dirp_dup||| +div128||| +djSP||| +do_aexec5||| +do_aexec||| +do_aspawn||| +do_binmode||5.004050| +do_chomp||| +do_close||| +do_delete_local||| +do_dump_pad||| +do_eof||| +do_exec3||| +do_execfree||| +do_exec||| +do_gv_dump||5.006000| +do_gvgv_dump||5.006000| +do_hv_dump||5.006000| +do_ipcctl||| +do_ipcget||| +do_join||| +do_magic_dump||5.006000| +do_msgrcv||| +do_msgsnd||| +do_oddball||| +do_op_dump||5.006000| +do_op_xmldump||| +do_open9||5.006000| +do_openn||5.007001| +do_open||5.004000| +do_pmop_dump||5.006000| +do_pmop_xmldump||| +do_print||| +do_readline||| +do_seek||| +do_semop||| +do_shmio||| +do_smartmatch||| +do_spawn_nowait||| +do_spawn||| +do_sprintf||| +do_sv_dump||5.006000| +do_sysseek||| +do_tell||| +do_trans_complex_utf8||| +do_trans_complex||| +do_trans_count_utf8||| +do_trans_count||| +do_trans_simple_utf8||| +do_trans_simple||| +do_trans||| +do_vecget||| +do_vecset||| +do_vop||| +docatch||| +doeval||| +dofile||| +dofindlabel||| +doform||| +doing_taint||5.008001|n +dooneliner||| +doopen_pm||| +doparseform||| +dopoptoeval||| +dopoptogiven||| +dopoptolabel||| +dopoptoloop||| +dopoptosub_at||| +dopoptowhen||| +doref||5.009003| +dounwind||| +dowantarray||| +dump_all_perl||| +dump_all||5.006000| +dump_eval||5.006000| +dump_exec_pos||| +dump_fds||| +dump_form||5.006000| +dump_indent||5.006000|v +dump_mstats||| +dump_packsubs_perl||| +dump_packsubs||5.006000| +dump_sub_perl||| +dump_sub||5.006000| +dump_sv_child||| +dump_trie_interim_list||| +dump_trie_interim_table||| +dump_trie||| +dump_vindent||5.006000| +dumpuntil||| +dup_attrlist||| +emulate_cop_io||| +eval_pv|5.006000||p +eval_sv|5.006000||p +exec_failed||| +expect_number||| +fbm_compile||5.005000| +fbm_instr||5.005000| +feature_is_enabled||| +fetch_cop_label||5.011000| +filter_add||| +filter_del||| +filter_gets||| +filter_read||| +find_and_forget_pmops||| +find_array_subscript||| +find_beginning||| +find_byclass||| +find_hash_subscript||| +find_in_my_stash||| +find_runcv||5.008001| +find_rundefsvoffset||5.009002| +find_rundefsv||5.013002| +find_script||| +find_uninit_var||| +first_symbol|||n +foldEQ_latin1||5.013008|n +foldEQ_locale||5.013002|n +foldEQ_utf8_flags||5.013010| +foldEQ_utf8||5.013002| +foldEQ||5.013002|n +fold_constants||| +forbid_setid||| +force_ident||| +force_list||| +force_next||| +force_strict_version||| +force_version||| +force_word||| +forget_pmop||| +form_nocontext|||vn +form||5.004000|v +fp_dup||| +fprintf_nocontext|||vn +free_global_struct||| +free_tied_hv_pool||| +free_tmps||| +gen_constant_list||| +get_aux_mg||| +get_av|5.006000||p +get_context||5.006000|n +get_cvn_flags|5.009005||p +get_cvs|5.011000||p +get_cv|5.006000||p +get_db_sub||| +get_debug_opts||| +get_hash_seed||| +get_hv|5.006000||p +get_mstats||| +get_no_modify||| +get_num||| +get_op_descs||5.005000| +get_op_names||5.005000| +get_opargs||| +get_ppaddr||5.006000| +get_re_arg||| +get_sv|5.006000||p +get_vtbl||5.005030| +getcwd_sv||5.007002| +getenv_len||| +glob_2number||| +glob_assign_glob||| +glob_assign_ref||| +gp_dup||| +gp_free||| +gp_ref||| +grok_bin|5.007003||p +grok_bslash_c||| +grok_bslash_o||| +grok_hex|5.007003||p +grok_number|5.007002||p +grok_numeric_radix|5.007002||p +grok_oct|5.007003||p +group_end||| +gv_AVadd||| +gv_HVadd||| +gv_IOadd||| +gv_SVadd||| +gv_add_by_type||5.011000| +gv_autoload4||5.004000| +gv_check||| +gv_const_sv||5.009003| +gv_dump||5.006000| +gv_efullname3||5.004000| +gv_efullname4||5.006001| +gv_efullname||| +gv_ename||| +gv_fetchfile_flags||5.009005| +gv_fetchfile||| +gv_fetchmeth_autoload||5.007003| +gv_fetchmethod_autoload||5.004000| +gv_fetchmethod_flags||5.011000| +gv_fetchmethod||| +gv_fetchmeth||| +gv_fetchpvn_flags|5.009002||p +gv_fetchpvs|5.009004||p +gv_fetchpv||| +gv_fetchsv|5.009002||p +gv_fullname3||5.004000| +gv_fullname4||5.006001| +gv_fullname||| +gv_get_super_pkg||| +gv_handler||5.007001| +gv_init_sv||| +gv_init||| +gv_magicalize_isa||| +gv_magicalize_overload||| +gv_name_set||5.009004| +gv_stashpvn|5.004000||p +gv_stashpvs|5.009003||p +gv_stashpv||| +gv_stashsv||| +gv_try_downgrade||| +he_dup||| +hek_dup||| +hfreeentries||| +hsplit||| +hv_assert||| +hv_auxinit|||n +hv_backreferences_p||| +hv_clear_placeholders||5.009001| +hv_clear||| +hv_common_key_len||5.010000| +hv_common||5.010000| +hv_copy_hints_hv||5.009004| +hv_delayfree_ent||5.004000| +hv_delete_common||| +hv_delete_ent||5.004000| +hv_delete||| +hv_eiter_p||5.009003| +hv_eiter_set||5.009003| +hv_ename_add||| +hv_ename_delete||| +hv_exists_ent||5.004000| +hv_exists||| +hv_fetch_ent||5.004000| +hv_fetchs|5.009003||p +hv_fetch||| +hv_fill||5.013002| +hv_free_ent||5.004000| +hv_iterinit||| +hv_iterkeysv||5.004000| +hv_iterkey||| +hv_iternext_flags||5.008000| +hv_iternextsv||| +hv_iternext||| +hv_iterval||| +hv_kill_backrefs||| +hv_ksplit||5.004000| +hv_magic_check|||n +hv_magic||| +hv_name_set||5.009003| +hv_notallowed||| +hv_placeholders_get||5.009003| +hv_placeholders_p||5.009003| +hv_placeholders_set||5.009003| +hv_riter_p||5.009003| +hv_riter_set||5.009003| +hv_scalar||5.009001| +hv_store_ent||5.004000| +hv_store_flags||5.008000| +hv_stores|5.009004||p +hv_store||| +hv_undef_flags||| +hv_undef||| +ibcmp_locale||5.004000| +ibcmp_utf8||5.007003| +ibcmp||| +incline||| +incpush_if_exists||| +incpush_use_sep||| +incpush||| +ingroup||| +init_argv_symbols||| +init_dbargs||| +init_debugger||| +init_global_struct||| +init_i18nl10n||5.006000| +init_i18nl14n||5.006000| +init_ids||| +init_interp||| +init_main_stash||| +init_perllib||| +init_postdump_symbols||| +init_predump_symbols||| +init_stacks||5.005000| +init_tm||5.007002| +instr|||n +intro_my||| +intuit_method||| +intuit_more||| +invert||| +invlist_array||| +invlist_destroy||| +invlist_extend||| +invlist_intersection||| +invlist_len||| +invlist_max||| +invlist_set_array||| +invlist_set_len||| +invlist_set_max||| +invlist_trim||| +invlist_union||| +invoke_exception_hook||| +io_close||| +isALNUMC|5.006000||p +isALPHA||| +isASCII|5.006000||p +isBLANK|5.006001||p +isCNTRL|5.006000||p +isDIGIT||| +isGRAPH|5.006000||p +isGV_with_GP|5.009004||p +isLOWER||| +isOCTAL||5.013005| +isPRINT|5.004000||p +isPSXSPC|5.006001||p +isPUNCT|5.006000||p +isSPACE||| +isUPPER||| +isWORDCHAR||5.013006| +isXDIGIT|5.006000||p +is_an_int||| +is_ascii_string||5.011000|n +is_gv_magical_sv||| +is_handle_constructor|||n +is_inplace_av||| +is_list_assignment||| +is_lvalue_sub||5.007001| +is_uni_alnum_lc||5.006000| +is_uni_alnum||5.006000| +is_uni_alpha_lc||5.006000| +is_uni_alpha||5.006000| +is_uni_ascii_lc||5.006000| +is_uni_ascii||5.006000| +is_uni_cntrl_lc||5.006000| +is_uni_cntrl||5.006000| +is_uni_digit_lc||5.006000| +is_uni_digit||5.006000| +is_uni_graph_lc||5.006000| +is_uni_graph||5.006000| +is_uni_idfirst_lc||5.006000| +is_uni_idfirst||5.006000| +is_uni_lower_lc||5.006000| +is_uni_lower||5.006000| +is_uni_print_lc||5.006000| +is_uni_print||5.006000| +is_uni_punct_lc||5.006000| +is_uni_punct||5.006000| +is_uni_space_lc||5.006000| +is_uni_space||5.006000| +is_uni_upper_lc||5.006000| +is_uni_upper||5.006000| +is_uni_xdigit_lc||5.006000| +is_uni_xdigit||5.006000| +is_utf8_X_LVT||| +is_utf8_X_LV_LVT_V||| +is_utf8_X_LV||| +is_utf8_X_L||| +is_utf8_X_T||| +is_utf8_X_V||| +is_utf8_X_begin||| +is_utf8_X_extend||| +is_utf8_X_non_hangul||| +is_utf8_X_prepend||| +is_utf8_alnum||5.006000| +is_utf8_alpha||5.006000| +is_utf8_ascii||5.006000| +is_utf8_char_slow|||n +is_utf8_char||5.006000|n +is_utf8_cntrl||5.006000| +is_utf8_common||| +is_utf8_digit||5.006000| +is_utf8_graph||5.006000| +is_utf8_idcont||5.008000| +is_utf8_idfirst||5.006000| +is_utf8_lower||5.006000| +is_utf8_mark||5.006000| +is_utf8_perl_space||5.011001| +is_utf8_perl_word||5.011001| +is_utf8_posix_digit||5.011001| +is_utf8_print||5.006000| +is_utf8_punct||5.006000| +is_utf8_space||5.006000| +is_utf8_string_loclen||5.009003|n +is_utf8_string_loc||5.008001|n +is_utf8_string||5.006001|n +is_utf8_upper||5.006000| +is_utf8_xdigit||5.006000| +is_utf8_xidcont||5.013010| +is_utf8_xidfirst||5.013010| +isa_lookup||| +items|||n +ix|||n +jmaybe||| +join_exact||| +keyword_plugin_standard||| +keyword||| +leave_scope||| +lex_bufutf8||5.011002| +lex_discard_to||5.011002| +lex_grow_linestr||5.011002| +lex_next_chunk||5.011002| +lex_peek_unichar||5.011002| +lex_read_space||5.011002| +lex_read_to||5.011002| +lex_read_unichar||5.011002| +lex_start||5.009005| +lex_stuff_pvn||5.011002| +lex_stuff_pvs||5.013005| +lex_stuff_pv||5.013006| +lex_stuff_sv||5.011002| +lex_unstuff||5.011002| +listkids||| +list||| +load_module_nocontext|||vn +load_module|5.006000||pv +localize||| +looks_like_bool||| +looks_like_number||| +lop||| +mPUSHi|5.009002||p +mPUSHn|5.009002||p +mPUSHp|5.009002||p +mPUSHs|5.010001||p +mPUSHu|5.009002||p +mXPUSHi|5.009002||p +mXPUSHn|5.009002||p +mXPUSHp|5.009002||p +mXPUSHs|5.010001||p +mXPUSHu|5.009002||p +mad_free||| +madlex||| +madparse||| +magic_clear_all_env||| +magic_clearenv||| +magic_clearhints||| +magic_clearhint||| +magic_clearisa||| +magic_clearpack||| +magic_clearsig||| +magic_dump||5.006000| +magic_existspack||| +magic_freearylen_p||| +magic_freeovrld||| +magic_getarylen||| +magic_getdefelem||| +magic_getnkeys||| +magic_getpack||| +magic_getpos||| +magic_getsig||| +magic_getsubstr||| +magic_gettaint||| +magic_getuvar||| +magic_getvec||| +magic_get||| +magic_killbackrefs||| +magic_len||| +magic_methcall1||| +magic_methcall|||v +magic_methpack||| +magic_nextpack||| +magic_regdata_cnt||| +magic_regdatum_get||| +magic_regdatum_set||| +magic_scalarpack||| +magic_set_all_env||| +magic_setamagic||| +magic_setarylen||| +magic_setcollxfrm||| +magic_setdbline||| +magic_setdefelem||| +magic_setenv||| +magic_sethint||| +magic_setisa||| +magic_setmglob||| +magic_setnkeys||| +magic_setpack||| +magic_setpos||| +magic_setregexp||| +magic_setsig||| +magic_setsubstr||| +magic_settaint||| +magic_setutf8||| +magic_setuvar||| +magic_setvec||| +magic_set||| +magic_sizepack||| +magic_wipepack||| +make_matcher||| +make_trie_failtable||| +make_trie||| +malloc_good_size|||n +malloced_size|||n +malloc||5.007002|n +markstack_grow||| +matcher_matches_sv||| +measure_struct||| +memEQs|5.009005||p +memEQ|5.004000||p +memNEs|5.009005||p +memNE|5.004000||p +mem_collxfrm||| +mem_log_common|||n +mess_alloc||| +mess_nocontext|||vn +mess_sv||5.013001| +mess||5.006000|v +method_common||| +mfree||5.007002|n +mg_clear||| +mg_copy||| +mg_dup||| +mg_findext||5.013008| +mg_find||| +mg_free_type||5.013006| +mg_free||| +mg_get||| +mg_length||5.005000| +mg_localize||| +mg_magical||| +mg_set||| +mg_size||5.005000| +mini_mktime||5.007002| +missingterm||| +mode_from_discipline||| +modkids||| +mod||| +more_bodies||| +more_sv||| +moreswitches||| +mro_clean_isarev||| +mro_gather_and_rename||| +mro_get_from_name||5.010001| +mro_get_linear_isa_dfs||| +mro_get_linear_isa||5.009005| +mro_get_private_data||5.010001| +mro_isa_changed_in||| +mro_meta_dup||| +mro_meta_init||| +mro_method_changed_in||5.009005| +mro_package_moved||| +mro_register||5.010001| +mro_set_mro||5.010001| +mro_set_private_data||5.010001| +mul128||| +mulexp10|||n +munge_qwlist_to_paren_list||| +my_atof2||5.007002| +my_atof||5.006000| +my_attrs||| +my_bcopy|||n +my_betoh16|||n +my_betoh32|||n +my_betoh64|||n +my_betohi|||n +my_betohl|||n +my_betohs|||n +my_bzero|||n +my_chsize||| +my_clearenv||| +my_cxt_index||| +my_cxt_init||| +my_dirfd||5.009005| +my_exit_jump||| +my_exit||| +my_failure_exit||5.004000| +my_fflush_all||5.006000| +my_fork||5.007003|n +my_htobe16|||n +my_htobe32|||n +my_htobe64|||n +my_htobei|||n +my_htobel|||n +my_htobes|||n +my_htole16|||n +my_htole32|||n +my_htole64|||n +my_htolei|||n +my_htolel|||n +my_htoles|||n +my_htonl||| +my_kid||| +my_letoh16|||n +my_letoh32|||n +my_letoh64|||n +my_letohi|||n +my_letohl|||n +my_letohs|||n +my_lstat_flags||| +my_lstat||5.014000| +my_memcmp||5.004000|n +my_memset|||n +my_ntohl||| +my_pclose||5.004000| +my_popen_list||5.007001| +my_popen||5.004000| +my_setenv||| +my_snprintf|5.009004||pvn +my_socketpair||5.007003|n +my_sprintf|5.009003||pvn +my_stat_flags||| +my_stat||5.014000| +my_strftime||5.007002| +my_strlcat|5.009004||pn +my_strlcpy|5.009004||pn +my_swabn|||n +my_swap||| +my_unexec||| +my_vsnprintf||5.009004|n +need_utf8|||n +newANONATTRSUB||5.006000| +newANONHASH||| +newANONLIST||| +newANONSUB||| +newASSIGNOP||| +newATTRSUB||5.006000| +newAVREF||| +newAV||| +newBINOP||| +newCONDOP||| +newCONSTSUB|5.004050||p +newCVREF||| +newDEFSVOP||| +newFORM||| +newFOROP||5.013007| +newGIVENOP||5.009003| +newGIVWHENOP||| +newGP||| +newGVOP||| +newGVREF||| +newGVgen||| +newHVREF||| +newHVhv||5.005000| +newHV||| +newIO||| +newLISTOP||| +newLOGOP||| +newLOOPEX||| +newLOOPOP||| +newMADPROP||| +newMADsv||| +newMYSUB||| +newNULLLIST||| +newOP||| +newPADOP||| +newPMOP||| +newPROG||| +newPVOP||| +newRANGE||| +newRV_inc|5.004000||p +newRV_noinc|5.004000||p +newRV||| +newSLICEOP||| +newSTATEOP||| +newSUB||| +newSVOP||| +newSVREF||| +newSV_type|5.009005||p +newSVhek||5.009003| +newSViv||| +newSVnv||| +newSVpv_share||5.013006| +newSVpvf_nocontext|||vn +newSVpvf||5.004000|v +newSVpvn_flags|5.010001||p +newSVpvn_share|5.007001||p +newSVpvn_utf8|5.010001||p +newSVpvn|5.004050||p +newSVpvs_flags|5.010001||p +newSVpvs_share|5.009003||p +newSVpvs|5.009003||p +newSVpv||| +newSVrv||| +newSVsv||| +newSVuv|5.006000||p +newSV||| +newTOKEN||| +newUNOP||| +newWHENOP||5.009003| +newWHILEOP||5.013007| +newXS_flags||5.009004| +newXSproto||5.006000| +newXS||5.006000| +new_collate||5.006000| +new_constant||| +new_ctype||5.006000| +new_he||| +new_logop||| +new_numeric||5.006000| +new_stackinfo||5.005000| +new_version||5.009000| +new_warnings_bitfield||| +next_symbol||| +nextargv||| +nextchar||| +ninstr|||n +no_bareword_allowed||| +no_fh_allowed||| +no_op||| +not_a_number||| +nothreadhook||5.008000| +nuke_stacks||| +num_overflow|||n +oopsAV||| +oopsHV||| +op_append_elem||5.013006| +op_append_list||5.013006| +op_clear||| +op_const_sv||| +op_contextualize||5.013006| +op_dump||5.006000| +op_free||| +op_getmad_weak||| +op_getmad||| +op_linklist||5.013006| +op_lvalue||5.013007| +op_null||5.007002| +op_prepend_elem||5.013006| +op_refcnt_dec||| +op_refcnt_inc||| +op_refcnt_lock||5.009002| +op_refcnt_unlock||5.009002| +op_scope||5.013007| +op_xmldump||| +open_script||| +opt_scalarhv||| +pMY_CXT_|5.007003||p +pMY_CXT|5.007003||p +pTHX_|5.006000||p +pTHX|5.006000||p +packWARN|5.007003||p +pack_cat||5.007003| +pack_rec||| +package_version||| +package||| +packlist||5.008001| +pad_add_anon||| +pad_add_name_sv||| +pad_add_name||| +pad_alloc||| +pad_block_start||| +pad_check_dup||| +pad_compname_type||| +pad_findlex||| +pad_findmy||5.011002| +pad_fixup_inner_anons||| +pad_free||| +pad_leavemy||| +pad_new||| +pad_peg|||n +pad_push||| +pad_reset||| +pad_setsv||| +pad_sv||| +pad_swipe||| +pad_tidy||| +padlist_dup||| +parse_arithexpr||5.013008| +parse_barestmt||5.013007| +parse_block||5.013007| +parse_body||| +parse_fullexpr||5.013008| +parse_fullstmt||5.013005| +parse_label||5.013007| +parse_listexpr||5.013008| +parse_stmtseq||5.013006| +parse_termexpr||5.013008| +parse_unicode_opts||| +parser_dup||| +parser_free||| +path_is_absolute|||n +peep||| +pending_Slabs_to_ro||| +perl_alloc_using|||n +perl_alloc|||n +perl_clone_using|||n +perl_clone|||n +perl_construct|||n +perl_destruct||5.007003|n +perl_free|||n +perl_parse||5.006000|n +perl_run|||n +pidgone||| +pm_description||| +pmop_dump||5.006000| +pmop_xmldump||| +pmruntime||| +pmtrans||| +pop_scope||| +populate_isa|||v +pregcomp||5.009005| +pregexec||| +pregfree2||5.011000| +pregfree||| +prepend_madprops||| +prescan_version||5.011004| +printbuf||| +printf_nocontext|||vn +process_special_blocks||| +ptr_table_clear||5.009005| +ptr_table_fetch||5.009005| +ptr_table_find|||n +ptr_table_free||5.009005| +ptr_table_new||5.009005| +ptr_table_split||5.009005| +ptr_table_store||5.009005| +push_scope||| +put_byte||| +pv_display|5.006000||p +pv_escape|5.009004||p +pv_pretty|5.009004||p +pv_uni_display||5.007003| +qerror||| +qsortsvu||| +re_compile||5.009005| +re_croak2||| +re_dup_guts||| +re_intuit_start||5.009005| +re_intuit_string||5.006000| +readpipe_override||| +realloc||5.007002|n +reentrant_free||| +reentrant_init||| +reentrant_retry|||vn +reentrant_size||| +ref_array_or_hash||| +refcounted_he_chain_2hv||| +refcounted_he_fetch_pvn||| +refcounted_he_fetch_pvs||| +refcounted_he_fetch_pv||| +refcounted_he_fetch_sv||| +refcounted_he_free||| +refcounted_he_inc||| +refcounted_he_new_pvn||| +refcounted_he_new_pvs||| +refcounted_he_new_pv||| +refcounted_he_new_sv||| +refcounted_he_value||| +refkids||| +refto||| +ref||5.014000| +reg_check_named_buff_matched||| +reg_named_buff_all||5.009005| +reg_named_buff_exists||5.009005| +reg_named_buff_fetch||5.009005| +reg_named_buff_firstkey||5.009005| +reg_named_buff_iter||| +reg_named_buff_nextkey||5.009005| +reg_named_buff_scalar||5.009005| +reg_named_buff||| +reg_namedseq||| +reg_node||| +reg_numbered_buff_fetch||| +reg_numbered_buff_length||| +reg_numbered_buff_store||| +reg_qr_package||| +reg_recode||| +reg_scan_name||| +reg_skipcomment||| +reg_temp_copy||| +reganode||| +regatom||| +regbranch||| +regclass_swash||5.009004| +regclass||| +regcppop||| +regcppush||| +regcurly||| +regdump_extflags||| +regdump||5.005000| +regdupe_internal||| +regexec_flags||5.005000| +regfree_internal||5.009005| +reghop3|||n +reghop4|||n +reghopmaybe3|||n +reginclass||| +reginitcolors||5.006000| +reginsert||| +regmatch||| +regnext||5.005000| +regpiece||| +regpposixcc||| +regprop||| +regrepeat||| +regtail_study||| +regtail||| +regtry||| +reguni||| +regwhite|||n +reg||| +repeatcpy|||n +report_evil_fh||| +report_uninit||| +report_wrongway_fh||| +require_pv||5.006000| +require_tie_mod||| +restore_magic||| +rninstr|||n +rpeep||| +rsignal_restore||| +rsignal_save||| +rsignal_state||5.004000| +rsignal||5.004000| +run_body||| +run_user_filter||| +runops_debug||5.005000| +runops_standard||5.005000| +rv2cv_op_cv||5.013006| +rvpv_dup||| +rxres_free||| +rxres_restore||| +rxres_save||| +safesyscalloc||5.006000|n +safesysfree||5.006000|n +safesysmalloc||5.006000|n +safesysrealloc||5.006000|n +same_dirent||| +save_I16||5.004000| +save_I32||| +save_I8||5.006000| +save_adelete||5.011000| +save_aelem_flags||5.011000| +save_aelem||5.004050| +save_alloc||5.006000| +save_aptr||| +save_ary||| +save_bool||5.008001| +save_clearsv||| +save_delete||| +save_destructor_x||5.006000| +save_destructor||5.006000| +save_freeop||| +save_freepv||| +save_freesv||| +save_generic_pvref||5.006001| +save_generic_svref||5.005030| +save_gp||5.004000| +save_hash||| +save_hdelete||5.011000| +save_hek_flags|||n +save_helem_flags||5.011000| +save_helem||5.004050| +save_hints||5.010001| +save_hptr||| +save_int||| +save_item||| +save_iv||5.005000| +save_lines||| +save_list||| +save_long||| +save_magic||| +save_mortalizesv||5.007001| +save_nogv||| +save_op||5.005000| +save_padsv_and_mortalize||5.010001| +save_pptr||| +save_pushi32ptr||5.010001| +save_pushptri32ptr||| +save_pushptrptr||5.010001| +save_pushptr||5.010001| +save_re_context||5.006000| +save_scalar_at||| +save_scalar||| +save_set_svflags||5.009000| +save_shared_pvref||5.007003| +save_sptr||| +save_svref||| +save_vptr||5.006000| +savepvn||| +savepvs||5.009003| +savepv||| +savesharedpvn||5.009005| +savesharedpvs||5.013006| +savesharedpv||5.007003| +savesharedsvpv||5.013006| +savestack_grow_cnt||5.008001| +savestack_grow||| +savesvpv||5.009002| +sawparens||| +scalar_mod_type|||n +scalarboolean||| +scalarkids||| +scalarseq||| +scalarvoid||| +scalar||| +scan_bin||5.006000| +scan_commit||| +scan_const||| +scan_formline||| +scan_heredoc||| +scan_hex||| +scan_ident||| +scan_inputsymbol||| +scan_num||5.007001| +scan_oct||| +scan_pat||| +scan_str||| +scan_subst||| +scan_trans||| +scan_version||5.009001| +scan_vstring||5.009005| +scan_word||| +screaminstr||5.005000| +search_const||| +seed||5.008001| +sequence_num||| +sequence_tail||| +sequence||| +set_context||5.006000|n +set_numeric_local||5.006000| +set_numeric_radix||5.006000| +set_numeric_standard||5.006000| +set_regclass_bit_fold||| +set_regclass_bit||| +setdefout||| +share_hek_flags||| +share_hek||5.004000| +si_dup||| +sighandler|||n +simplify_sort||| +skipspace0||| +skipspace1||| +skipspace2||| +skipspace||| +softref2xv||| +sortcv_stacked||| +sortcv_xsub||| +sortcv||| +sortsv_flags||5.009003| +sortsv||5.007003| +space_join_names_mortal||| +ss_dup||| +stack_grow||| +start_force||| +start_glob||| +start_subparse||5.004000| +stashpv_hvname_match||5.014000| +stdize_locale||| +store_cop_label||| +strEQ||| +strGE||| +strGT||| +strLE||| +strLT||| +strNE||| +str_to_version||5.006000| +strip_return||| +strnEQ||| +strnNE||| +study_chunk||| +sub_crush_depth||| +sublex_done||| +sublex_push||| +sublex_start||| +sv_2bool_flags||5.013006| +sv_2bool||| +sv_2cv||| +sv_2io||| +sv_2iuv_common||| +sv_2iuv_non_preserve||| +sv_2iv_flags||5.009001| +sv_2iv||| +sv_2mortal||| +sv_2num||| +sv_2nv_flags||5.013001| +sv_2pv_flags|5.007002||p +sv_2pv_nolen|5.006000||p +sv_2pvbyte_nolen|5.006000||p +sv_2pvbyte|5.006000||p +sv_2pvutf8_nolen||5.006000| +sv_2pvutf8||5.006000| +sv_2pv||| +sv_2uv_flags||5.009001| +sv_2uv|5.004000||p +sv_add_arena||| +sv_add_backref||| +sv_backoff||| +sv_bless||| +sv_cat_decode||5.008001| +sv_catpv_flags||5.013006| +sv_catpv_mg|5.004050||p +sv_catpv_nomg||5.013006| +sv_catpvf_mg_nocontext|||pvn +sv_catpvf_mg|5.006000|5.004000|pv +sv_catpvf_nocontext|||vn +sv_catpvf||5.004000|v +sv_catpvn_flags||5.007002| +sv_catpvn_mg|5.004050||p +sv_catpvn_nomg|5.007002||p +sv_catpvn||| +sv_catpvs_flags||5.013006| +sv_catpvs_mg||5.013006| +sv_catpvs_nomg||5.013006| +sv_catpvs|5.009003||p +sv_catpv||| +sv_catsv_flags||5.007002| +sv_catsv_mg|5.004050||p +sv_catsv_nomg|5.007002||p +sv_catsv||| +sv_catxmlpvn||| +sv_catxmlpv||| +sv_catxmlsv||| +sv_chop||| +sv_clean_all||| +sv_clean_objs||| +sv_clear||| +sv_cmp_flags||5.013006| +sv_cmp_locale_flags||5.013006| +sv_cmp_locale||5.004000| +sv_cmp||| +sv_collxfrm_flags||5.013006| +sv_collxfrm||| +sv_compile_2op_is_broken||| +sv_compile_2op||5.008001| +sv_copypv||5.007003| +sv_dec_nomg||5.013002| +sv_dec||| +sv_del_backref||| +sv_derived_from||5.004000| +sv_destroyable||5.010000| +sv_does||5.009004| +sv_dump||| +sv_dup_common||| +sv_dup_inc_multiple||| +sv_dup_inc||| +sv_dup||| +sv_eq_flags||5.013006| +sv_eq||| +sv_exp_grow||| +sv_force_normal_flags||5.007001| +sv_force_normal||5.006000| +sv_free2||| +sv_free_arenas||| +sv_free||| +sv_gets||5.004000| +sv_grow||| +sv_i_ncmp||| +sv_inc_nomg||5.013002| +sv_inc||| +sv_insert_flags||5.010001| +sv_insert||| +sv_isa||| +sv_isobject||| +sv_iv||5.005000| +sv_kill_backrefs||| +sv_len_utf8||5.006000| +sv_len||| +sv_magic_portable|5.014000|5.004000|p +sv_magicext||5.007003| +sv_magic||| +sv_mortalcopy||| +sv_ncmp||| +sv_newmortal||| +sv_newref||| +sv_nolocking||5.007003| +sv_nosharing||5.007003| +sv_nounlocking||| +sv_nv||5.005000| +sv_peek||5.005000| +sv_pos_b2u_midway||| +sv_pos_b2u||5.006000| +sv_pos_u2b_cached||| +sv_pos_u2b_flags||5.011005| +sv_pos_u2b_forwards|||n +sv_pos_u2b_midway|||n +sv_pos_u2b||5.006000| +sv_pvbyten_force||5.006000| +sv_pvbyten||5.006000| +sv_pvbyte||5.006000| +sv_pvn_force_flags|5.007002||p +sv_pvn_force||| +sv_pvn_nomg|5.007003|5.005000|p +sv_pvn||5.005000| +sv_pvutf8n_force||5.006000| +sv_pvutf8n||5.006000| +sv_pvutf8||5.006000| +sv_pv||5.006000| +sv_recode_to_utf8||5.007003| +sv_reftype||| +sv_release_COW||| +sv_replace||| +sv_report_used||| +sv_reset||| +sv_rvweaken||5.006000| +sv_setiv_mg|5.004050||p +sv_setiv||| +sv_setnv_mg|5.006000||p +sv_setnv||| +sv_setpv_mg|5.004050||p +sv_setpvf_mg_nocontext|||pvn +sv_setpvf_mg|5.006000|5.004000|pv +sv_setpvf_nocontext|||vn +sv_setpvf||5.004000|v +sv_setpviv_mg||5.008001| +sv_setpviv||5.008001| +sv_setpvn_mg|5.004050||p +sv_setpvn||| +sv_setpvs_mg||5.013006| +sv_setpvs|5.009004||p +sv_setpv||| +sv_setref_iv||| +sv_setref_nv||| +sv_setref_pvn||| +sv_setref_pvs||5.013006| +sv_setref_pv||| +sv_setref_uv||5.007001| +sv_setsv_cow||| +sv_setsv_flags||5.007002| +sv_setsv_mg|5.004050||p +sv_setsv_nomg|5.007002||p +sv_setsv||| +sv_setuv_mg|5.004050||p +sv_setuv|5.004000||p +sv_tainted||5.004000| +sv_taint||5.004000| +sv_true||5.005000| +sv_unglob||| +sv_uni_display||5.007003| +sv_unmagicext||5.013008| +sv_unmagic||| +sv_unref_flags||5.007001| +sv_unref||| +sv_untaint||5.004000| +sv_upgrade||| +sv_usepvn_flags||5.009004| +sv_usepvn_mg|5.004050||p +sv_usepvn||| +sv_utf8_decode||5.006000| +sv_utf8_downgrade||5.006000| +sv_utf8_encode||5.006000| +sv_utf8_upgrade_flags_grow||5.011000| +sv_utf8_upgrade_flags||5.007002| +sv_utf8_upgrade_nomg||5.007002| +sv_utf8_upgrade||5.007001| +sv_uv|5.005000||p +sv_vcatpvf_mg|5.006000|5.004000|p +sv_vcatpvfn||5.004000| +sv_vcatpvf|5.006000|5.004000|p +sv_vsetpvf_mg|5.006000|5.004000|p +sv_vsetpvfn||5.004000| +sv_vsetpvf|5.006000|5.004000|p +sv_xmlpeek||| +svtype||| +swallow_bom||| +swash_fetch||5.007002| +swash_get||| +swash_init||5.006000| +sys_init3||5.010000|n +sys_init||5.010000|n +sys_intern_clear||| +sys_intern_dup||| +sys_intern_init||| +sys_term||5.010000|n +taint_env||| +taint_proper||| +tied_method|||v +tmps_grow||5.006000| +toLOWER||| +toUPPER||| +to_byte_substr||| +to_uni_fold||5.007003| +to_uni_lower_lc||5.006000| +to_uni_lower||5.007003| +to_uni_title_lc||5.006000| +to_uni_title||5.007003| +to_uni_upper_lc||5.006000| +to_uni_upper||5.007003| +to_utf8_case||5.007003| +to_utf8_fold||5.007003| +to_utf8_lower||5.007003| +to_utf8_substr||| +to_utf8_title||5.007003| +to_utf8_upper||5.007003| +token_free||| +token_getmad||| +tokenize_use||| +tokeq||| +tokereport||| +too_few_arguments||| +too_many_arguments||| +try_amagic_bin||| +try_amagic_un||| +uiv_2buf|||n +unlnk||| +unpack_rec||| +unpack_str||5.007003| +unpackstring||5.008001| +unreferenced_to_tmp_stack||| +unshare_hek_or_pvn||| +unshare_hek||| +unsharepvn||5.004000| +unwind_handler_stack||| +update_debugger_info||| +upg_version||5.009005| +usage||| +utf16_textfilter||| +utf16_to_utf8_reversed||5.006001| +utf16_to_utf8||5.006001| +utf8_distance||5.006000| +utf8_hop||5.006000| +utf8_length||5.007001| +utf8_mg_len_cache_update||| +utf8_mg_pos_cache_update||| +utf8_to_bytes||5.006001| +utf8_to_uvchr||5.007001| +utf8_to_uvuni||5.007001| +utf8n_to_uvchr||| +utf8n_to_uvuni||5.007001| +utilize||| +uvchr_to_utf8_flags||5.007003| +uvchr_to_utf8||| +uvuni_to_utf8_flags||5.007003| +uvuni_to_utf8||5.007001| +validate_suid||| +varname||| +vcmp||5.009000| +vcroak||5.006000| +vdeb||5.007003| +vform||5.006000| +visit||| +vivify_defelem||| +vivify_ref||| +vload_module|5.006000||p +vmess||5.006000| +vnewSVpvf|5.006000|5.004000|p +vnormal||5.009002| +vnumify||5.009000| +vstringify||5.009000| +vverify||5.009003| +vwarner||5.006000| +vwarn||5.006000| +wait4pid||| +warn_nocontext|||vn +warn_sv||5.013001| +warner_nocontext|||vn +warner|5.006000|5.004000|pv +warn|||v +watch||| +whichsig||| +with_queued_errors||| +write_no_mem||| +write_to_stderr||| +xmldump_all_perl||| +xmldump_all||| +xmldump_attr||| +xmldump_eval||| +xmldump_form||| +xmldump_indent|||v +xmldump_packsubs_perl||| +xmldump_packsubs||| +xmldump_sub_perl||| +xmldump_sub||| +xmldump_vindent||| +xs_apiversion_bootcheck||| +xs_version_bootcheck||| +yyerror||| +yylex||| +yyparse||| +yyunlex||| +yywarn||| +); + +if (exists $opt{'list-unsupported'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{todo}; + print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; + } + exit 0; +} + +# Scan for possible replacement candidates + +my(%replace, %need, %hints, %warnings, %depends); +my $replace = 0; +my($hint, $define, $function); + +sub find_api +{ + my $code = shift; + $code =~ s{ + / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) + | "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; + grep { exists $API{$_} } $code =~ /(\w+)/mg; +} + +while (<DATA>) { + if ($hint) { + my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; + if (m{^\s*\*\s(.*?)\s*$}) { + for (@{$hint->[1]}) { + $h->{$_} ||= ''; # suppress warning with older perls + $h->{$_} .= "$1\n"; + } + } + else { undef $hint } + } + + $hint = [$1, [split /,?\s+/, $2]] + if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}; + + if ($define) { + if ($define->[1] =~ /\\$/) { + $define->[1] .= $_; + } + else { + if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { + my @n = find_api($define->[1]); + push @{$depends{$define->[0]}}, @n if @n + } + undef $define; + } + } + + $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; + + if ($function) { + if (/^}/) { + if (exists $API{$function->[0]}) { + my @n = find_api($function->[1]); + push @{$depends{$function->[0]}}, @n if @n + } + undef $function; + } + else { + $function->[1] .= $_; + } + } + + $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; + + $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; + $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; + $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; + $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; + + if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { + my @deps = map { s/\s+//g; $_ } split /,/, $3; + my $d; + for $d (map { s/\s+//g; $_ } split /,/, $1) { + push @{$depends{$d}}, @deps; + } + } + + $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; +} + +for (values %depends) { + my %s; + $_ = [sort grep !$s{$_}++, @$_]; +} + +if (exists $opt{'api-info'}) { + my $f; + my $count = 0; + my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $f =~ /$match/; + print "\n=== $f ===\n\n"; + my $info = 0; + if ($API{$f}{base} || $API{$f}{todo}) { + my $base = format_version($API{$f}{base} || $API{$f}{todo}); + print "Supported at least starting from perl-$base.\n"; + $info++; + } + if ($API{$f}{provided}) { + my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; + print "Support by $ppport provided back to perl-$todo.\n"; + print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; + print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; + print "\n$hints{$f}" if exists $hints{$f}; + print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; + $info++; + } + print "No portability information available.\n" unless $info; + $count++; + } + $count or print "Found no API matching '$opt{'api-info'}'."; + print "\n"; + exit 0; +} + +if (exists $opt{'list-provided'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{provided}; + my @flags; + push @flags, 'explicit' if exists $need{$f}; + push @flags, 'depend' if exists $depends{$f}; + push @flags, 'hint' if exists $hints{$f}; + push @flags, 'warning' if exists $warnings{$f}; + my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; + print "$f$flags\n"; + } + exit 0; +} + +my @files; +my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); +my $srcext = join '|', map { quotemeta $_ } @srcext; + +if (@ARGV) { + my %seen; + for (@ARGV) { + if (-e) { + if (-f) { + push @files, $_ unless $seen{$_}++; + } + else { warn "'$_' is not a file.\n" } + } + else { + my @new = grep { -f } glob $_ + or warn "'$_' does not exist.\n"; + push @files, grep { !$seen{$_}++ } @new; + } + } +} +else { + eval { + require File::Find; + File::Find::find(sub { + $File::Find::name =~ /($srcext)$/i + and push @files, $File::Find::name; + }, '.'); + }; + if ($@) { + @files = map { glob "*$_" } @srcext; + } +} + +if (!@ARGV || $opt{filter}) { + my(@in, @out); + my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; + for (@files) { + my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i; + push @{ $out ? \@out : \@in }, $_; + } + if (@ARGV && @out) { + warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); + } + @files = @in; +} + +die "No input files given!\n" unless @files; + +my(%files, %global, %revreplace); +%revreplace = reverse %replace; +my $filename; +my $patch_opened = 0; + +for $filename (@files) { + unless (open IN, "<$filename") { + warn "Unable to read from $filename: $!\n"; + next; + } + + info("Scanning $filename ..."); + + my $c = do { local $/; <IN> }; + close IN; + + my %file = (orig => $c, changes => 0); + + # Temporarily remove C/XS comments and strings from the code + my @ccom; + + $c =~ s{ + ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]* + | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* ) + | ( ^$HS*\#[^\r\n]* + | "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' + | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) ) + }{ defined $2 and push @ccom, $2; + defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex; + + $file{ccom} = \@ccom; + $file{code} = $c; + $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m; + + my $func; + + for $func (keys %API) { + my $match = $func; + $match .= "|$revreplace{$func}" if exists $revreplace{$func}; + if ($c =~ /\b(?:Perl_)?($match)\b/) { + $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; + $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; + if (exists $API{$func}{provided}) { + $file{uses_provided}{$func}++; + if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { + $file{uses}{$func}++; + my @deps = rec_depend($func); + if (@deps) { + $file{uses_deps}{$func} = \@deps; + for (@deps) { + $file{uses}{$_} = 0 unless exists $file{uses}{$_}; + } + } + for ($func, @deps) { + $file{needs}{$_} = 'static' if exists $need{$_}; + } + } + } + if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { + if ($c =~ /\b$func\b/) { + $file{uses_todo}{$func}++; + } + } + } + } + + while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { + if (exists $need{$2}) { + $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; + } + else { warning("Possibly wrong #define $1 in $filename") } + } + + for (qw(uses needs uses_todo needed_global needed_static)) { + for $func (keys %{$file{$_}}) { + push @{$global{$_}{$func}}, $filename; + } + } + + $files{$filename} = \%file; +} + +# Globally resolve NEED_'s +my $need; +for $need (keys %{$global{needs}}) { + if (@{$global{needs}{$need}} > 1) { + my @targets = @{$global{needs}{$need}}; + my @t = grep $files{$_}{needed_global}{$need}, @targets; + @targets = @t if @t; + @t = grep /\.xs$/i, @targets; + @targets = @t if @t; + my $target = shift @targets; + $files{$target}{needs}{$need} = 'global'; + for (@{$global{needs}{$need}}) { + $files{$_}{needs}{$need} = 'extern' if $_ ne $target; + } + } +} + +for $filename (@files) { + exists $files{$filename} or next; + + info("=== Analyzing $filename ==="); + + my %file = %{$files{$filename}}; + my $func; + my $c = $file{code}; + my $warnings = 0; + + for $func (sort keys %{$file{uses_Perl}}) { + if ($API{$func}{varargs}) { + unless ($API{$func}{nothxarg}) { + my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} + { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); + if ($changes) { + warning("Doesn't pass interpreter argument aTHX to Perl_$func"); + $file{changes} += $changes; + } + } + } + else { + warning("Uses Perl_$func instead of $func"); + $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} + {$func$1(}g); + } + } + + for $func (sort keys %{$file{uses_replace}}) { + warning("Uses $func instead of $replace{$func}"); + $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); + } + + for $func (sort keys %{$file{uses_provided}}) { + if ($file{uses}{$func}) { + if (exists $file{uses_deps}{$func}) { + diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); + } + else { + diag("Uses $func"); + } + } + $warnings += hint($func); + } + + unless ($opt{quiet}) { + for $func (sort keys %{$file{uses_todo}}) { + print "*** WARNING: Uses $func, which may not be portable below perl ", + format_version($API{$func}{todo}), ", even with '$ppport'\n"; + $warnings++; + } + } + + for $func (sort keys %{$file{needed_static}}) { + my $message = ''; + if (not exists $file{uses}{$func}) { + $message = "No need to define NEED_$func if $func is never used"; + } + elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { + $message = "No need to define NEED_$func when already needed globally"; + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); + } + } + + for $func (sort keys %{$file{needed_global}}) { + my $message = ''; + if (not exists $global{uses}{$func}) { + $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; + } + elsif (exists $file{needs}{$func}) { + if ($file{needs}{$func} eq 'extern') { + $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; + } + elsif ($file{needs}{$func} eq 'static') { + $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; + } + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); + } + } + + $file{needs_inc_ppport} = keys %{$file{uses}}; + + if ($file{needs_inc_ppport}) { + my $pp = ''; + + for $func (sort keys %{$file{needs}}) { + my $type = $file{needs}{$func}; + next if $type eq 'extern'; + my $suffix = $type eq 'global' ? '_GLOBAL' : ''; + unless (exists $file{"needed_$type"}{$func}) { + if ($type eq 'global') { + diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); + } + else { + diag("File needs $func, adding static request"); + } + $pp .= "#define NEED_$func$suffix\n"; + } + } + + if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { + $pp = ''; + $file{changes}++; + } + + unless ($file{has_inc_ppport}) { + diag("Needs to include '$ppport'"); + $pp .= qq(#include "$ppport"\n) + } + + if ($pp) { + $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) + || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) + || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) + || ($c =~ s/^/$pp/); + } + } + else { + if ($file{has_inc_ppport}) { + diag("No need to include '$ppport'"); + $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); + } + } + + # put back in our C comments + my $ix; + my $cppc = 0; + my @ccom = @{$file{ccom}}; + for $ix (0 .. $#ccom) { + if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { + $cppc++; + $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; + } + else { + $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; + } + } + + if ($cppc) { + my $s = $cppc != 1 ? 's' : ''; + warning("Uses $cppc C++ style comment$s, which is not portable"); + } + + my $s = $warnings != 1 ? 's' : ''; + my $warn = $warnings ? " ($warnings warning$s)" : ''; + info("Analysis completed$warn"); + + if ($file{changes}) { + if (exists $opt{copy}) { + my $newfile = "$filename$opt{copy}"; + if (-e $newfile) { + error("'$newfile' already exists, refusing to write copy of '$filename'"); + } + else { + local *F; + if (open F, ">$newfile") { + info("Writing copy of '$filename' with changes to '$newfile'"); + print F $c; + close F; + } + else { + error("Cannot open '$newfile' for writing: $!"); + } + } + } + elsif (exists $opt{patch} || $opt{changes}) { + if (exists $opt{patch}) { + unless ($patch_opened) { + if (open PATCH, ">$opt{patch}") { + $patch_opened = 1; + } + else { + error("Cannot open '$opt{patch}' for writing: $!"); + delete $opt{patch}; + $opt{changes} = 1; + goto fallback; + } + } + mydiff(\*PATCH, $filename, $c); + } + else { +fallback: + info("Suggested changes:"); + mydiff(\*STDOUT, $filename, $c); + } + } + else { + my $s = $file{changes} == 1 ? '' : 's'; + info("$file{changes} potentially required change$s detected"); + } + } + else { + info("Looks good"); + } +} + +close PATCH if $patch_opened; + +exit 0; + + +sub try_use { eval "use @_;"; return $@ eq '' } + +sub mydiff +{ + local *F = shift; + my($file, $str) = @_; + my $diff; + + if (exists $opt{diff}) { + $diff = run_diff($opt{diff}, $file, $str); + } + + if (!defined $diff and try_use('Text::Diff')) { + $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); + $diff = <<HEADER . $diff; +--- $file ++++ $file.patched +HEADER + } + + if (!defined $diff) { + $diff = run_diff('diff -u', $file, $str); + } + + if (!defined $diff) { + $diff = run_diff('diff', $file, $str); + } + + if (!defined $diff) { + error("Cannot generate a diff. Please install Text::Diff or use --copy."); + return; + } + + print F $diff; +} + +sub run_diff +{ + my($prog, $file, $str) = @_; + my $tmp = 'dppptemp'; + my $suf = 'aaa'; + my $diff = ''; + local *F; + + while (-e "$tmp.$suf") { $suf++ } + $tmp = "$tmp.$suf"; + + if (open F, ">$tmp") { + print F $str; + close F; + + if (open F, "$prog $file $tmp |") { + while (<F>) { + s/\Q$tmp\E/$file.patched/; + $diff .= $_; + } + close F; + unlink $tmp; + return $diff; + } + + unlink $tmp; + } + else { + error("Cannot open '$tmp' for writing: $!"); + } + + return undef; +} + +sub rec_depend +{ + my($func, $seen) = @_; + return () unless exists $depends{$func}; + $seen = {%{$seen||{}}}; + return () if $seen->{$func}++; + my %s; + grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}}; +} + +sub parse_version +{ + my $ver = shift; + + if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { + return ($1, $2, $3); + } + elsif ($ver !~ /^\d+\.[\d_]+$/) { + die "cannot parse version '$ver'\n"; + } + + $ver =~ s/_//g; + $ver =~ s/$/000000/; + + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "cannot parse version '$ver'\n"; + } + } + + return ($r, $v, $s); +} + +sub format_version +{ + my $ver = shift; + + $ver =~ s/$/000000/; + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "invalid version '$ver'\n"; + } + $s /= 10; + + $ver = sprintf "%d.%03d", $r, $v; + $s > 0 and $ver .= sprintf "_%02d", $s; + + return $ver; + } + + return sprintf "%d.%d.%d", $r, $v, $s; +} + +sub info +{ + $opt{quiet} and return; + print @_, "\n"; +} + +sub diag +{ + $opt{quiet} and return; + $opt{diag} and print @_, "\n"; +} + +sub warning +{ + $opt{quiet} and return; + print "*** ", @_, "\n"; +} + +sub error +{ + print "*** ERROR: ", @_, "\n"; +} + +my %given_hints; +my %given_warnings; +sub hint +{ + $opt{quiet} and return; + my $func = shift; + my $rv = 0; + if (exists $warnings{$func} && !$given_warnings{$func}++) { + my $warn = $warnings{$func}; + $warn =~ s!^!*** !mg; + print "*** WARNING: $func\n", $warn; + $rv++; + } + if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { + my $hint = $hints{$func}; + $hint =~ s/^/ /mg; + print " --- hint for $func ---\n", $hint; + } + $rv; +} + +sub usage +{ + my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; + my %M = ( 'I' => '*' ); + $usage =~ s/^\s*perl\s+\S+/$^X $0/; + $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; + + print <<ENDUSAGE; + +Usage: $usage + +See perldoc $0 for details. + +ENDUSAGE + + exit 2; +} + +sub strip +{ + my $self = do { local(@ARGV,$/)=($0); <> }; + my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; + $copy =~ s/^(?=\S+)/ /gms; + $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; + $self =~ s/^SKIP.*(?=^__DATA__)/SKIP +if (\@ARGV && \$ARGV[0] eq '--unstrip') { + eval { require Devel::PPPort }; + \$@ and die "Cannot require Devel::PPPort, please install.\\n"; + if (eval \$Devel::PPPort::VERSION < $VERSION) { + die "$0 was originally generated with Devel::PPPort $VERSION.\\n" + . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" + . "Please install a newer version, or --unstrip will not work.\\n"; + } + Devel::PPPort::WriteFile(\$0); + exit 0; +} +print <<END; + +Sorry, but this is a stripped version of \$0. + +To be able to use its original script and doc functionality, +please try to regenerate this file using: + + \$^X \$0 --unstrip + +END +/ms; + my($pl, $c) = $self =~ /(.*^__DATA__)(.*)/ms; + $c =~ s{ + / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) + | ( "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' ) + | ($HS+) }{ defined $2 ? ' ' : ($1 || '') }gsex; + $c =~ s!\s+$!!mg; + $c =~ s!^$LF!!mg; + $c =~ s!^\s*#\s*!#!mg; + $c =~ s!^\s+!!mg; + + open OUT, ">$0" or die "cannot strip $0: $!\n"; + print OUT "$pl$c\n"; + + exit 0; +} + +__DATA__ +*/ + +#ifndef _P_P_PORTABILITY_H_ +#define _P_P_PORTABILITY_H_ + +#ifndef DPPP_NAMESPACE +# define DPPP_NAMESPACE DPPP_ +#endif + +#define DPPP_CAT2(x,y) CAT2(x,y) +#define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) + +#ifndef PERL_REVISION +# if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) +# define PERL_PATCHLEVEL_H_IMPLICIT +# include <patchlevel.h> +# endif +# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) +# include <could_not_find_Perl_patchlevel.h> +# endif +# ifndef PERL_REVISION +# define PERL_REVISION (5) + /* Replace: 1 */ +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION + /* Replace PERL_PATCHLEVEL with PERL_VERSION */ + /* Replace: 0 */ +# endif +#endif + +#define _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) +#define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(PERL_SUBVERSION)) + +/* It is very unlikely that anyone will try to use this with Perl 6 + (or greater), but who knows. + */ +#if PERL_REVISION != 5 +# error ppport.h only works with Perl version 5 +#endif /* PERL_REVISION != 5 */ +#ifndef dTHR +# define dTHR dNOOP +#endif +#ifndef dTHX +# define dTHX dNOOP +#endif + +#ifndef dTHXa +# define dTHXa(x) dNOOP +#endif +#ifndef pTHX +# define pTHX void +#endif + +#ifndef pTHX_ +# define pTHX_ +#endif + +#ifndef aTHX +# define aTHX +#endif + +#ifndef aTHX_ +# define aTHX_ +#endif + +#if (PERL_BCDVERSION < 0x5006000) +# ifdef USE_THREADS +# define aTHXR thr +# define aTHXR_ thr, +# else +# define aTHXR +# define aTHXR_ +# endif +# define dTHXR dTHR +#else +# define aTHXR aTHX +# define aTHXR_ aTHX_ +# define dTHXR dTHX +#endif +#ifndef dTHXoa +# define dTHXoa(x) dTHXa(x) +#endif + +#ifdef I_LIMITS +# include <limits.h> +#endif + +#ifndef PERL_UCHAR_MIN +# define PERL_UCHAR_MIN ((unsigned char)0) +#endif + +#ifndef PERL_UCHAR_MAX +# ifdef UCHAR_MAX +# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) +# else +# ifdef MAXUCHAR +# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) +# else +# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) +# endif +# endif +#endif + +#ifndef PERL_USHORT_MIN +# define PERL_USHORT_MIN ((unsigned short)0) +#endif + +#ifndef PERL_USHORT_MAX +# ifdef USHORT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) +# else +# ifdef MAXUSHORT +# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) +# else +# ifdef USHRT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) +# else +# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MAX +# ifdef SHORT_MAX +# define PERL_SHORT_MAX ((short)SHORT_MAX) +# else +# ifdef MAXSHORT /* Often used in <values.h> */ +# define PERL_SHORT_MAX ((short)MAXSHORT) +# else +# ifdef SHRT_MAX +# define PERL_SHORT_MAX ((short)SHRT_MAX) +# else +# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MIN +# ifdef SHORT_MIN +# define PERL_SHORT_MIN ((short)SHORT_MIN) +# else +# ifdef MINSHORT +# define PERL_SHORT_MIN ((short)MINSHORT) +# else +# ifdef SHRT_MIN +# define PERL_SHORT_MIN ((short)SHRT_MIN) +# else +# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +#ifndef PERL_UINT_MAX +# ifdef UINT_MAX +# define PERL_UINT_MAX ((unsigned int)UINT_MAX) +# else +# ifdef MAXUINT +# define PERL_UINT_MAX ((unsigned int)MAXUINT) +# else +# define PERL_UINT_MAX (~(unsigned int)0) +# endif +# endif +#endif + +#ifndef PERL_UINT_MIN +# define PERL_UINT_MIN ((unsigned int)0) +#endif + +#ifndef PERL_INT_MAX +# ifdef INT_MAX +# define PERL_INT_MAX ((int)INT_MAX) +# else +# ifdef MAXINT /* Often used in <values.h> */ +# define PERL_INT_MAX ((int)MAXINT) +# else +# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_INT_MIN +# ifdef INT_MIN +# define PERL_INT_MIN ((int)INT_MIN) +# else +# ifdef MININT +# define PERL_INT_MIN ((int)MININT) +# else +# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MAX +# ifdef ULONG_MAX +# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) +# else +# ifdef MAXULONG +# define PERL_ULONG_MAX ((unsigned long)MAXULONG) +# else +# define PERL_ULONG_MAX (~(unsigned long)0) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MIN +# define PERL_ULONG_MIN ((unsigned long)0L) +#endif + +#ifndef PERL_LONG_MAX +# ifdef LONG_MAX +# define PERL_LONG_MAX ((long)LONG_MAX) +# else +# ifdef MAXLONG +# define PERL_LONG_MAX ((long)MAXLONG) +# else +# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_LONG_MIN +# ifdef LONG_MIN +# define PERL_LONG_MIN ((long)LONG_MIN) +# else +# ifdef MINLONG +# define PERL_LONG_MIN ((long)MINLONG) +# else +# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#if defined(HAS_QUAD) && (defined(convex) || defined(uts)) +# ifndef PERL_UQUAD_MAX +# ifdef ULONGLONG_MAX +# define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) +# else +# ifdef MAXULONGLONG +# define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) +# else +# define PERL_UQUAD_MAX (~(unsigned long long)0) +# endif +# endif +# endif + +# ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN ((unsigned long long)0L) +# endif + +# ifndef PERL_QUAD_MAX +# ifdef LONGLONG_MAX +# define PERL_QUAD_MAX ((long long)LONGLONG_MAX) +# else +# ifdef MAXLONGLONG +# define PERL_QUAD_MAX ((long long)MAXLONGLONG) +# else +# define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) +# endif +# endif +# endif + +# ifndef PERL_QUAD_MIN +# ifdef LONGLONG_MIN +# define PERL_QUAD_MIN ((long long)LONGLONG_MIN) +# else +# ifdef MINLONGLONG +# define PERL_QUAD_MIN ((long long)MINLONGLONG) +# else +# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +/* This is based on code from 5.003 perl.h */ +#ifdef HAS_QUAD +# ifdef cray +#ifndef IVTYPE +# define IVTYPE int +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_INT_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_INT_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UINT_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UINT_MAX +#endif + +# ifdef INTSIZE +#ifndef IVSIZE +# define IVSIZE INTSIZE +#endif + +# endif +# else +# if defined(convex) || defined(uts) +#ifndef IVTYPE +# define IVTYPE long long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_QUAD_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_QUAD_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UQUAD_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UQUAD_MAX +#endif + +# ifdef LONGLONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGLONGSIZE +#endif + +# endif +# else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +# ifdef LONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGSIZE +#endif + +# endif +# endif +# endif +#ifndef IVSIZE +# define IVSIZE 8 +#endif + +#ifndef PERL_QUAD_MIN +# define PERL_QUAD_MIN IV_MIN +#endif + +#ifndef PERL_QUAD_MAX +# define PERL_QUAD_MAX IV_MAX +#endif + +#ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN UV_MIN +#endif + +#ifndef PERL_UQUAD_MAX +# define PERL_UQUAD_MAX UV_MAX +#endif + +#else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +#endif + +#ifndef IVSIZE +# ifdef LONGSIZE +# define IVSIZE LONGSIZE +# else +# define IVSIZE 4 /* A bold guess, but the best we can make. */ +# endif +#endif +#ifndef UVTYPE +# define UVTYPE unsigned IVTYPE +#endif + +#ifndef UVSIZE +# define UVSIZE IVSIZE +#endif +#ifndef sv_setuv +# define sv_setuv(sv, uv) \ + STMT_START { \ + UV TeMpUv = uv; \ + if (TeMpUv <= IV_MAX) \ + sv_setiv(sv, TeMpUv); \ + else \ + sv_setnv(sv, (double)TeMpUv); \ + } STMT_END +#endif +#ifndef newSVuv +# define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) +#endif +#ifndef sv_2uv +# define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) +#endif + +#ifndef SvUVX +# define SvUVX(sv) ((UV)SvIVX(sv)) +#endif + +#ifndef SvUVXx +# define SvUVXx(sv) SvUVX(sv) +#endif + +#ifndef SvUV +# define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) +#endif + +#ifndef SvUVx +# define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) +#endif + +/* Hint: sv_uv + * Always use the SvUVx() macro instead of sv_uv(). + */ +#ifndef sv_uv +# define sv_uv(sv) SvUVx(sv) +#endif + +#if !defined(SvUOK) && defined(SvIOK_UV) +# define SvUOK(sv) SvIOK_UV(sv) +#endif +#ifndef XST_mUV +# define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) +#endif + +#ifndef XSRETURN_UV +# define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END +#endif +#ifndef PUSHu +# define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END +#endif + +#ifndef XPUSHu +# define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END +#endif + +#ifdef HAS_MEMCMP +#ifndef memNE +# define memNE(s1,s2,l) (memcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) +#endif + +#else +#ifndef memNE +# define memNE(s1,s2,l) (bcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) +#endif + +#endif +#ifndef memEQs +# define memEQs(s1, l, s2) \ + (sizeof(s2)-1 == l && memEQ(s1, (s2 ""), (sizeof(s2)-1))) +#endif + +#ifndef memNEs +# define memNEs(s1, l, s2) !memEQs(s1, l, s2) +#endif +#ifndef MoveD +# define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifndef CopyD +# define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifdef HAS_MEMSET +#ifndef ZeroD +# define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) +#endif + +#else +#ifndef ZeroD +# define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d) +#endif + +#endif +#ifndef PoisonWith +# define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)) +#endif + +#ifndef PoisonNew +# define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB) +#endif + +#ifndef PoisonFree +# define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF) +#endif + +#ifndef Poison +# define Poison(d,n,t) PoisonFree(d,n,t) +#endif +#ifndef Newx +# define Newx(v,n,t) New(0,v,n,t) +#endif + +#ifndef Newxc +# define Newxc(v,n,t,c) Newc(0,v,n,t,c) +#endif + +#ifndef Newxz +# define Newxz(v,n,t) Newz(0,v,n,t) +#endif + +#ifndef PERL_UNUSED_DECL +# ifdef HASATTRIBUTE +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif +# else +# define PERL_UNUSED_DECL +# endif +#endif + +#ifndef PERL_UNUSED_ARG +# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ +# include <note.h> +# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) +# else +# define PERL_UNUSED_ARG(x) ((void)x) +# endif +#endif + +#ifndef PERL_UNUSED_VAR +# define PERL_UNUSED_VAR(x) ((void)x) +#endif + +#ifndef PERL_UNUSED_CONTEXT +# ifdef USE_ITHREADS +# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) +# else +# define PERL_UNUSED_CONTEXT +# endif +#endif +#ifndef NOOP +# define NOOP /*EMPTY*/(void)0 +#endif + +#ifndef dNOOP +# define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL +#endif + +#ifndef NVTYPE +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) +# define NVTYPE long double +# else +# define NVTYPE double +# endif +typedef NVTYPE NV; +#endif + +#ifndef INT2PTR +# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) +# define PTRV UV +# define INT2PTR(any,d) (any)(d) +# else +# if PTRSIZE == LONGSIZE +# define PTRV unsigned long +# else +# define PTRV unsigned +# endif +# define INT2PTR(any,d) (any)(PTRV)(d) +# endif +#endif + +#ifndef PTR2ul +# if PTRSIZE == LONGSIZE +# define PTR2ul(p) (unsigned long)(p) +# else +# define PTR2ul(p) INT2PTR(unsigned long,p) +# endif +#endif +#ifndef PTR2nat +# define PTR2nat(p) (PTRV)(p) +#endif + +#ifndef NUM2PTR +# define NUM2PTR(any,d) (any)PTR2nat(d) +#endif + +#ifndef PTR2IV +# define PTR2IV(p) INT2PTR(IV,p) +#endif + +#ifndef PTR2UV +# define PTR2UV(p) INT2PTR(UV,p) +#endif + +#ifndef PTR2NV +# define PTR2NV(p) NUM2PTR(NV,p) +#endif + +#undef START_EXTERN_C +#undef END_EXTERN_C +#undef EXTERN_C +#ifdef __cplusplus +# define START_EXTERN_C extern "C" { +# define END_EXTERN_C } +# define EXTERN_C extern "C" +#else +# define START_EXTERN_C +# define END_EXTERN_C +# define EXTERN_C extern +#endif + +#if defined(PERL_GCC_PEDANTIC) +# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN +# define PERL_GCC_BRACE_GROUPS_FORBIDDEN +# endif +#endif + +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) +# ifndef PERL_USE_GCC_BRACE_GROUPS +# define PERL_USE_GCC_BRACE_GROUPS +# endif +#endif + +#undef STMT_START +#undef STMT_END +#ifdef PERL_USE_GCC_BRACE_GROUPS +# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ +# define STMT_END ) +#else +# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) +# define STMT_START if (1) +# define STMT_END else (void)0 +# else +# define STMT_START do +# define STMT_END while (0) +# endif +#endif +#ifndef boolSV +# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) +#endif + +/* DEFSV appears first in 5.004_56 */ +#ifndef DEFSV +# define DEFSV GvSV(PL_defgv) +#endif + +#ifndef SAVE_DEFSV +# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) +#endif + +#ifndef DEFSV_set +# define DEFSV_set(sv) (DEFSV = (sv)) +#endif + +/* Older perls (<=5.003) lack AvFILLp */ +#ifndef AvFILLp +# define AvFILLp AvFILL +#endif +#ifndef ERRSV +# define ERRSV get_sv("@",FALSE) +#endif + +/* Hint: gv_stashpvn + * This function's backport doesn't support the length parameter, but + * rather ignores it. Portability can only be ensured if the length + * parameter is used for speed reasons, but the length can always be + * correctly computed from the string argument. + */ +#ifndef gv_stashpvn +# define gv_stashpvn(str,len,create) gv_stashpv(str,create) +#endif + +/* Replace: 1 */ +#ifndef get_cv +# define get_cv perl_get_cv +#endif + +#ifndef get_sv +# define get_sv perl_get_sv +#endif + +#ifndef get_av +# define get_av perl_get_av +#endif + +#ifndef get_hv +# define get_hv perl_get_hv +#endif + +/* Replace: 0 */ +#ifndef dUNDERBAR +# define dUNDERBAR dNOOP +#endif + +#ifndef UNDERBAR +# define UNDERBAR DEFSV +#endif +#ifndef dAX +# define dAX I32 ax = MARK - PL_stack_base + 1 +#endif + +#ifndef dITEMS +# define dITEMS I32 items = SP - MARK +#endif +#ifndef dXSTARG +# define dXSTARG SV * targ = sv_newmortal() +#endif +#ifndef dAXMARK +# define dAXMARK I32 ax = POPMARK; \ + register SV ** const mark = PL_stack_base + ax++ +#endif +#ifndef XSprePUSH +# define XSprePUSH (sp = PL_stack_base + ax - 1) +#endif + +#if (PERL_BCDVERSION < 0x5005000) +# undef XSRETURN +# define XSRETURN(off) \ + STMT_START { \ + PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ + return; \ + } STMT_END +#endif +#ifndef XSPROTO +# define XSPROTO(name) void name(pTHX_ CV* cv) +#endif + +#ifndef SVfARG +# define SVfARG(p) ((void*)(p)) +#endif +#ifndef PERL_ABS +# define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) +#endif +#ifndef dVAR +# define dVAR dNOOP +#endif +#ifndef SVf +# define SVf "_" +#endif +#ifndef UTF8_MAXBYTES +# define UTF8_MAXBYTES UTF8_MAXLEN +#endif +#ifndef CPERLscope +# define CPERLscope(x) x +#endif +#ifndef PERL_HASH +# define PERL_HASH(hash,str,len) \ + STMT_START { \ + const char *s_PeRlHaSh = str; \ + I32 i_PeRlHaSh = len; \ + U32 hash_PeRlHaSh = 0; \ + while (i_PeRlHaSh--) \ + hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ + (hash) = hash_PeRlHaSh; \ + } STMT_END +#endif + +#ifndef PERLIO_FUNCS_DECL +# ifdef PERLIO_FUNCS_CONST +# define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs +# define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) +# else +# define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs +# define PERLIO_FUNCS_CAST(funcs) (funcs) +# endif +#endif + +/* provide these typedefs for older perls */ +#if (PERL_BCDVERSION < 0x5009003) + +# ifdef ARGSproto +typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); +# else +typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); +# endif + +typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); + +#endif +#ifndef isPSXSPC +# define isPSXSPC(c) (isSPACE(c) || (c) == '\v') +#endif + +#ifndef isBLANK +# define isBLANK(c) ((c) == ' ' || (c) == '\t') +#endif + +#ifdef EBCDIC +#ifndef isALNUMC +# define isALNUMC(c) isalnum(c) +#endif + +#ifndef isASCII +# define isASCII(c) isascii(c) +#endif + +#ifndef isCNTRL +# define isCNTRL(c) iscntrl(c) +#endif + +#ifndef isGRAPH +# define isGRAPH(c) isgraph(c) +#endif + +#ifndef isPRINT +# define isPRINT(c) isprint(c) +#endif + +#ifndef isPUNCT +# define isPUNCT(c) ispunct(c) +#endif + +#ifndef isXDIGIT +# define isXDIGIT(c) isxdigit(c) +#endif + +#else +# if (PERL_BCDVERSION < 0x5010000) +/* Hint: isPRINT + * The implementation in older perl versions includes all of the + * isSPACE() characters, which is wrong. The version provided by + * Devel::PPPort always overrides a present buggy version. + */ +# undef isPRINT +# endif +#ifndef isALNUMC +# define isALNUMC(c) (isALPHA(c) || isDIGIT(c)) +#endif + +#ifndef isASCII +# define isASCII(c) ((U8) (c) <= 127) +#endif + +#ifndef isCNTRL +# define isCNTRL(c) ((U8) (c) < ' ' || (c) == 127) +#endif + +#ifndef isGRAPH +# define isGRAPH(c) (isALNUM(c) || isPUNCT(c)) +#endif + +#ifndef isPRINT +# define isPRINT(c) (((c) >= 32 && (c) < 127)) +#endif + +#ifndef isPUNCT +# define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126)) +#endif + +#ifndef isXDIGIT +# define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F')) +#endif + +#endif + +#ifndef PERL_SIGNALS_UNSAFE_FLAG + +#define PERL_SIGNALS_UNSAFE_FLAG 0x0001 + +#if (PERL_BCDVERSION < 0x5008000) +# define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG +#else +# define D_PPP_PERL_SIGNALS_INIT 0 +#endif + +#if defined(NEED_PL_signals) +static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; +#elif defined(NEED_PL_signals_GLOBAL) +U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; +#else +extern U32 DPPP_(my_PL_signals); +#endif +#define PL_signals DPPP_(my_PL_signals) + +#endif + +/* Hint: PL_ppaddr + * Calling an op via PL_ppaddr requires passing a context argument + * for threaded builds. Since the context argument is different for + * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will + * automatically be defined as the correct argument. + */ + +#if (PERL_BCDVERSION <= 0x5005005) +/* Replace: 1 */ +# define PL_ppaddr ppaddr +# define PL_no_modify no_modify +/* Replace: 0 */ +#endif + +#if (PERL_BCDVERSION <= 0x5004005) +/* Replace: 1 */ +# define PL_DBsignal DBsignal +# define PL_DBsingle DBsingle +# define PL_DBsub DBsub +# define PL_DBtrace DBtrace +# define PL_Sv Sv +# define PL_bufend bufend +# define PL_bufptr bufptr +# define PL_compiling compiling +# define PL_copline copline +# define PL_curcop curcop +# define PL_curstash curstash +# define PL_debstash debstash +# define PL_defgv defgv +# define PL_diehook diehook +# define PL_dirty dirty +# define PL_dowarn dowarn +# define PL_errgv errgv +# define PL_error_count error_count +# define PL_expect expect +# define PL_hexdigit hexdigit +# define PL_hints hints +# define PL_in_my in_my +# define PL_laststatval laststatval +# define PL_lex_state lex_state +# define PL_lex_stuff lex_stuff +# define PL_linestr linestr +# define PL_na na +# define PL_perl_destruct_level perl_destruct_level +# define PL_perldb perldb +# define PL_rsfp_filters rsfp_filters +# define PL_rsfp rsfp +# define PL_stack_base stack_base +# define PL_stack_sp stack_sp +# define PL_statcache statcache +# define PL_stdingv stdingv +# define PL_sv_arenaroot sv_arenaroot +# define PL_sv_no sv_no +# define PL_sv_undef sv_undef +# define PL_sv_yes sv_yes +# define PL_tainted tainted +# define PL_tainting tainting +# define PL_tokenbuf tokenbuf +/* Replace: 0 */ +#endif + +/* Warning: PL_parser + * For perl versions earlier than 5.9.5, this is an always + * non-NULL dummy. Also, it cannot be dereferenced. Don't + * use it if you can avoid is and unless you absolutely know + * what you're doing. + * If you always check that PL_parser is non-NULL, you can + * define DPPP_PL_parser_NO_DUMMY to avoid the creation of + * a dummy parser structure. + */ + +#if (PERL_BCDVERSION >= 0x5009005) +# ifdef DPPP_PL_parser_NO_DUMMY +# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ + (croak("panic: PL_parser == NULL in %s:%d", \ + __FILE__, __LINE__), (yy_parser *) NULL))->var) +# else +# ifdef DPPP_PL_parser_NO_DUMMY_WARNING +# define D_PPP_parser_dummy_warning(var) +# else +# define D_PPP_parser_dummy_warning(var) \ + warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__), +# endif +# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ + (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var) +#if defined(NEED_PL_parser) +static yy_parser DPPP_(dummy_PL_parser); +#elif defined(NEED_PL_parser_GLOBAL) +yy_parser DPPP_(dummy_PL_parser); +#else +extern yy_parser DPPP_(dummy_PL_parser); +#endif + +# endif + +/* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */ +/* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf + * Do not use this variable unless you know exactly what you're + * doint. It is internal to the perl parser and may change or even + * be removed in the future. As of perl 5.9.5, you have to check + * for (PL_parser != NULL) for this variable to have any effect. + * An always non-NULL PL_parser dummy is provided for earlier + * perl versions. + * If PL_parser is NULL when you try to access this variable, a + * dummy is being accessed instead and a warning is issued unless + * you define DPPP_PL_parser_NO_DUMMY_WARNING. + * If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access + * this variable will croak with a panic message. + */ + +# define PL_expect D_PPP_my_PL_parser_var(expect) +# define PL_copline D_PPP_my_PL_parser_var(copline) +# define PL_rsfp D_PPP_my_PL_parser_var(rsfp) +# define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters) +# define PL_linestr D_PPP_my_PL_parser_var(linestr) +# define PL_bufptr D_PPP_my_PL_parser_var(bufptr) +# define PL_bufend D_PPP_my_PL_parser_var(bufend) +# define PL_lex_state D_PPP_my_PL_parser_var(lex_state) +# define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff) +# define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf) +# define PL_in_my D_PPP_my_PL_parser_var(in_my) +# define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash) +# define PL_error_count D_PPP_my_PL_parser_var(error_count) + + +#else + +/* ensure that PL_parser != NULL and cannot be dereferenced */ +# define PL_parser ((void *) 1) + +#endif +#ifndef mPUSHs +# define mPUSHs(s) PUSHs(sv_2mortal(s)) +#endif + +#ifndef PUSHmortal +# define PUSHmortal PUSHs(sv_newmortal()) +#endif + +#ifndef mPUSHp +# define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) +#endif + +#ifndef mPUSHn +# define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) +#endif + +#ifndef mPUSHi +# define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) +#endif + +#ifndef mPUSHu +# define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) +#endif +#ifndef mXPUSHs +# define mXPUSHs(s) XPUSHs(sv_2mortal(s)) +#endif + +#ifndef XPUSHmortal +# define XPUSHmortal XPUSHs(sv_newmortal()) +#endif + +#ifndef mXPUSHp +# define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END +#endif + +#ifndef mXPUSHn +# define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END +#endif + +#ifndef mXPUSHi +# define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END +#endif + +#ifndef mXPUSHu +# define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END +#endif + +/* Replace: 1 */ +#ifndef call_sv +# define call_sv perl_call_sv +#endif + +#ifndef call_pv +# define call_pv perl_call_pv +#endif + +#ifndef call_argv +# define call_argv perl_call_argv +#endif + +#ifndef call_method +# define call_method perl_call_method +#endif +#ifndef eval_sv +# define eval_sv perl_eval_sv +#endif + +/* Replace: 0 */ +#ifndef PERL_LOADMOD_DENY +# define PERL_LOADMOD_DENY 0x1 +#endif + +#ifndef PERL_LOADMOD_NOIMPORT +# define PERL_LOADMOD_NOIMPORT 0x2 +#endif + +#ifndef PERL_LOADMOD_IMPORT_OPS +# define PERL_LOADMOD_IMPORT_OPS 0x4 +#endif + +#ifndef G_METHOD +# define G_METHOD 64 +# ifdef call_sv +# undef call_sv +# endif +# if (PERL_BCDVERSION < 0x5006000) +# define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \ + (flags) & ~G_METHOD) : perl_call_sv(sv, flags)) +# else +# define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \ + (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags)) +# endif +#endif + +/* Replace perl_eval_pv with eval_pv */ + +#ifndef eval_pv +#if defined(NEED_eval_pv) +static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +static +#else +extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +#endif + +#ifdef eval_pv +# undef eval_pv +#endif +#define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) +#define Perl_eval_pv DPPP_(my_eval_pv) + +#if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) + +SV* +DPPP_(my_eval_pv)(char *p, I32 croak_on_error) +{ + dSP; + SV* sv = newSVpv(p, 0); + + PUSHMARK(sp); + eval_sv(sv, G_SCALAR); + SvREFCNT_dec(sv); + + SPAGAIN; + sv = POPs; + PUTBACK; + + if (croak_on_error && SvTRUE(GvSV(errgv))) + croak(SvPVx(GvSV(errgv), na)); + + return sv; +} + +#endif +#endif + +#ifndef vload_module +#if defined(NEED_vload_module) +static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); +static +#else +extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); +#endif + +#ifdef vload_module +# undef vload_module +#endif +#define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) +#define Perl_vload_module DPPP_(my_vload_module) + +#if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) + +void +DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) +{ + dTHR; + dVAR; + OP *veop, *imop; + + OP * const modname = newSVOP(OP_CONST, 0, name); + /* 5.005 has a somewhat hacky force_normal that doesn't croak on + SvREADONLY() if PL_compling is true. Current perls take care in + ck_require() to correctly turn off SvREADONLY before calling + force_normal_flags(). This seems a better fix than fudging PL_compling + */ + SvREADONLY_off(((SVOP*)modname)->op_sv); + modname->op_private |= OPpCONST_BARE; + if (ver) { + veop = newSVOP(OP_CONST, 0, ver); + } + else + veop = NULL; + if (flags & PERL_LOADMOD_NOIMPORT) { + imop = sawparens(newNULLLIST()); + } + else if (flags & PERL_LOADMOD_IMPORT_OPS) { + imop = va_arg(*args, OP*); + } + else { + SV *sv; + imop = NULL; + sv = va_arg(*args, SV*); + while (sv) { + imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); + sv = va_arg(*args, SV*); + } + } + { + const line_t ocopline = PL_copline; + COP * const ocurcop = PL_curcop; + const int oexpect = PL_expect; + +#if (PERL_BCDVERSION >= 0x5004000) + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), + veop, modname, imop); +#else + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), + modname, imop); +#endif + PL_expect = oexpect; + PL_copline = ocopline; + PL_curcop = ocurcop; + } +} + +#endif +#endif + +#ifndef load_module +#if defined(NEED_load_module) +static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); +static +#else +extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); +#endif + +#ifdef load_module +# undef load_module +#endif +#define load_module DPPP_(my_load_module) +#define Perl_load_module DPPP_(my_load_module) + +#if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) + +void +DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) +{ + va_list args; + va_start(args, ver); + vload_module(flags, name, ver, &args); + va_end(args); +} + +#endif +#endif +#ifndef newRV_inc +# define newRV_inc(sv) newRV(sv) /* Replace */ +#endif + +#ifndef newRV_noinc +#if defined(NEED_newRV_noinc) +static SV * DPPP_(my_newRV_noinc)(SV *sv); +static +#else +extern SV * DPPP_(my_newRV_noinc)(SV *sv); +#endif + +#ifdef newRV_noinc +# undef newRV_noinc +#endif +#define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) +#define Perl_newRV_noinc DPPP_(my_newRV_noinc) + +#if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) +SV * +DPPP_(my_newRV_noinc)(SV *sv) +{ + SV *rv = (SV *)newRV(sv); + SvREFCNT_dec(sv); + return rv; +} +#endif +#endif + +/* Hint: newCONSTSUB + * Returns a CV* as of perl-5.7.1. This return value is not supported + * by Devel::PPPort. + */ + +/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ +#if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) +#if defined(NEED_newCONSTSUB) +static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); +static +#else +extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); +#endif + +#ifdef newCONSTSUB +# undef newCONSTSUB +#endif +#define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) +#define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) + +#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) + +/* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */ +/* (There's no PL_parser in perl < 5.005, so this is completely safe) */ +#define D_PPP_PL_copline PL_copline + +void +DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv) +{ + U32 oldhints = PL_hints; + HV *old_cop_stash = PL_curcop->cop_stash; + HV *old_curstash = PL_curstash; + line_t oldline = PL_curcop->cop_line; + PL_curcop->cop_line = D_PPP_PL_copline; + + PL_hints &= ~HINT_BLOCK_SCOPE; + if (stash) + PL_curstash = PL_curcop->cop_stash = stash; + + newSUB( + +#if (PERL_BCDVERSION < 0x5003022) + start_subparse(), +#elif (PERL_BCDVERSION == 0x5003022) + start_subparse(0), +#else /* 5.003_23 onwards */ + start_subparse(FALSE, 0), +#endif + + newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), + newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ + newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) + ); + + PL_hints = oldhints; + PL_curcop->cop_stash = old_cop_stash; + PL_curstash = old_curstash; + PL_curcop->cop_line = oldline; +} +#endif +#endif + +/* + * Boilerplate macros for initializing and accessing interpreter-local + * data from C. All statics in extensions should be reworked to use + * this, if you want to make the extension thread-safe. See ext/re/re.xs + * for an example of the use of these macros. + * + * Code that uses these macros is responsible for the following: + * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" + * 2. Declare a typedef named my_cxt_t that is a structure that contains + * all the data that needs to be interpreter-local. + * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. + * 4. Use the MY_CXT_INIT macro such that it is called exactly once + * (typically put in the BOOT: section). + * 5. Use the members of the my_cxt_t structure everywhere as + * MY_CXT.member. + * 6. Use the dMY_CXT macro (a declaration) in all the functions that + * access MY_CXT. + */ + +#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ + defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) + +#ifndef START_MY_CXT + +/* This must appear in all extensions that define a my_cxt_t structure, + * right after the definition (i.e. at file scope). The non-threads + * case below uses it to declare the data as static. */ +#define START_MY_CXT + +#if (PERL_BCDVERSION < 0x5004068) +/* Fetches the SV that keeps the per-interpreter data. */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) +#else /* >= perl5.004_68 */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ + sizeof(MY_CXT_KEY)-1, TRUE) +#endif /* < perl5.004_68 */ + +/* This declaration should be used within all functions that use the + * interpreter-local data. */ +#define dMY_CXT \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) + +/* Creates and zeroes the per-interpreter data. + * (We allocate my_cxtp in a Perl SV so that it will be released when + * the interpreter goes away.) */ +#define MY_CXT_INIT \ + dMY_CXT_SV; \ + /* newSV() allocates one more than needed */ \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Zero(my_cxtp, 1, my_cxt_t); \ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) + +/* This macro must be used to access members of the my_cxt_t structure. + * e.g. MYCXT.some_data */ +#define MY_CXT (*my_cxtp) + +/* Judicious use of these macros can reduce the number of times dMY_CXT + * is used. Use is similar to pTHX, aTHX etc. */ +#define pMY_CXT my_cxt_t *my_cxtp +#define pMY_CXT_ pMY_CXT, +#define _pMY_CXT ,pMY_CXT +#define aMY_CXT my_cxtp +#define aMY_CXT_ aMY_CXT, +#define _aMY_CXT ,aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +/* Clones the per-interpreter data. */ +#define MY_CXT_CLONE \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) +#endif + +#else /* single interpreter */ + +#ifndef START_MY_CXT + +#define START_MY_CXT static my_cxt_t my_cxt; +#define dMY_CXT_SV dNOOP +#define dMY_CXT dNOOP +#define MY_CXT_INIT NOOP +#define MY_CXT my_cxt + +#define pMY_CXT void +#define pMY_CXT_ +#define _pMY_CXT +#define aMY_CXT +#define aMY_CXT_ +#define _aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +#define MY_CXT_CLONE NOOP +#endif + +#endif + +#ifndef IVdf +# if IVSIZE == LONGSIZE +# define IVdf "ld" +# define UVuf "lu" +# define UVof "lo" +# define UVxf "lx" +# define UVXf "lX" +# else +# if IVSIZE == INTSIZE +# define IVdf "d" +# define UVuf "u" +# define UVof "o" +# define UVxf "x" +# define UVXf "X" +# endif +# endif +#endif + +#ifndef NVef +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ + defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000) + /* Not very likely, but let's try anyway. */ +# define NVef PERL_PRIeldbl +# define NVff PERL_PRIfldbl +# define NVgf PERL_PRIgldbl +# else +# define NVef "e" +# define NVff "f" +# define NVgf "g" +# endif +#endif + +#ifndef SvREFCNT_inc +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + if (_sv) \ + (SvREFCNT(_sv))++; \ + _sv; \ + }) +# else +# define SvREFCNT_inc(sv) \ + ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) +# endif +#endif + +#ifndef SvREFCNT_inc_simple +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_simple(sv) \ + ({ \ + if (sv) \ + (SvREFCNT(sv))++; \ + (SV *)(sv); \ + }) +# else +# define SvREFCNT_inc_simple(sv) \ + ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) +# endif +#endif + +#ifndef SvREFCNT_inc_NN +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_NN(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + SvREFCNT(_sv)++; \ + _sv; \ + }) +# else +# define SvREFCNT_inc_NN(sv) \ + (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) +# endif +#endif + +#ifndef SvREFCNT_inc_void +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_void(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + if (_sv) \ + (void)(SvREFCNT(_sv)++); \ + }) +# else +# define SvREFCNT_inc_void(sv) \ + (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) +# endif +#endif +#ifndef SvREFCNT_inc_simple_void +# define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END +#endif + +#ifndef SvREFCNT_inc_simple_NN +# define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) +#endif + +#ifndef SvREFCNT_inc_void_NN +# define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) +#endif + +#ifndef SvREFCNT_inc_simple_void_NN +# define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) +#endif + +#ifndef newSV_type + +#if defined(NEED_newSV_type) +static SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); +static +#else +extern SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); +#endif + +#ifdef newSV_type +# undef newSV_type +#endif +#define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a) +#define Perl_newSV_type DPPP_(my_newSV_type) + +#if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL) + +SV* +DPPP_(my_newSV_type)(pTHX_ svtype const t) +{ + SV* const sv = newSV(0); + sv_upgrade(sv, t); + return sv; +} + +#endif + +#endif + +#if (PERL_BCDVERSION < 0x5006000) +# define D_PPP_CONSTPV_ARG(x) ((char *) (x)) +#else +# define D_PPP_CONSTPV_ARG(x) (x) +#endif +#ifndef newSVpvn +# define newSVpvn(data,len) ((data) \ + ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ + : newSV(0)) +#endif +#ifndef newSVpvn_utf8 +# define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) +#endif +#ifndef SVf_UTF8 +# define SVf_UTF8 0 +#endif + +#ifndef newSVpvn_flags + +#if defined(NEED_newSVpvn_flags) +static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); +static +#else +extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); +#endif + +#ifdef newSVpvn_flags +# undef newSVpvn_flags +#endif +#define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) +#define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) + +#if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) + +SV * +DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) +{ + SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len); + SvFLAGS(sv) |= (flags & SVf_UTF8); + return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; +} + +#endif + +#endif + +/* Backwards compatibility stuff... :-( */ +#if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) +# define NEED_sv_2pv_flags +#endif +#if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) +# define NEED_sv_2pv_flags_GLOBAL +#endif + +/* Hint: sv_2pv_nolen + * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). + */ +#ifndef sv_2pv_nolen +# define sv_2pv_nolen(sv) SvPV_nolen(sv) +#endif + +#ifdef SvPVbyte + +/* Hint: SvPVbyte + * Does not work in perl-5.6.1, ppport.h implements a version + * borrowed from perl-5.7.3. + */ + +#if (PERL_BCDVERSION < 0x5007000) + +#if defined(NEED_sv_2pvbyte) +static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); +static +#else +extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); +#endif + +#ifdef sv_2pvbyte +# undef sv_2pvbyte +#endif +#define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) +#define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) + +#if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) + +char * +DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp) +{ + sv_utf8_downgrade(sv,0); + return SvPV(sv,*lp); +} + +#endif + +/* Hint: sv_2pvbyte + * Use the SvPVbyte() macro instead of sv_2pvbyte(). + */ + +#undef SvPVbyte + +#define SvPVbyte(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) + +#endif + +#else + +# define SvPVbyte SvPV +# define sv_2pvbyte sv_2pv + +#endif +#ifndef sv_2pvbyte_nolen +# define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) +#endif + +/* Hint: sv_pvn + * Always use the SvPV() macro instead of sv_pvn(). + */ + +/* Hint: sv_pvn_force + * Always use the SvPV_force() macro instead of sv_pvn_force(). + */ + +/* If these are undefined, they're not handled by the core anyway */ +#ifndef SV_IMMEDIATE_UNREF +# define SV_IMMEDIATE_UNREF 0 +#endif + +#ifndef SV_GMAGIC +# define SV_GMAGIC 0 +#endif + +#ifndef SV_COW_DROP_PV +# define SV_COW_DROP_PV 0 +#endif + +#ifndef SV_UTF8_NO_ENCODING +# define SV_UTF8_NO_ENCODING 0 +#endif + +#ifndef SV_NOSTEAL +# define SV_NOSTEAL 0 +#endif + +#ifndef SV_CONST_RETURN +# define SV_CONST_RETURN 0 +#endif + +#ifndef SV_MUTABLE_RETURN +# define SV_MUTABLE_RETURN 0 +#endif + +#ifndef SV_SMAGIC +# define SV_SMAGIC 0 +#endif + +#ifndef SV_HAS_TRAILING_NUL +# define SV_HAS_TRAILING_NUL 0 +#endif + +#ifndef SV_COW_SHARED_HASH_KEYS +# define SV_COW_SHARED_HASH_KEYS 0 +#endif + +#if (PERL_BCDVERSION < 0x5007002) + +#if defined(NEED_sv_2pv_flags) +static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +static +#else +extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +#endif + +#ifdef sv_2pv_flags +# undef sv_2pv_flags +#endif +#define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) +#define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) + +#if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) + +char * +DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) +{ + STRLEN n_a = (STRLEN) flags; + return sv_2pv(sv, lp ? lp : &n_a); +} + +#endif + +#if defined(NEED_sv_pvn_force_flags) +static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +static +#else +extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +#endif + +#ifdef sv_pvn_force_flags +# undef sv_pvn_force_flags +#endif +#define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) +#define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) + +#if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) + +char * +DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) +{ + STRLEN n_a = (STRLEN) flags; + return sv_pvn_force(sv, lp ? lp : &n_a); +} + +#endif + +#endif + +#if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) +# define DPPP_SVPV_NOLEN_LP_ARG &PL_na +#else +# define DPPP_SVPV_NOLEN_LP_ARG 0 +#endif +#ifndef SvPV_const +# define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_mutable +# define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) +#endif +#ifndef SvPV_flags +# define SvPV_flags(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) +#endif +#ifndef SvPV_flags_const +# define SvPV_flags_const(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ + (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) +#endif +#ifndef SvPV_flags_const_nolen +# define SvPV_flags_const_nolen(sv, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX_const(sv) : \ + (const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN)) +#endif +#ifndef SvPV_flags_mutable +# define SvPV_flags_mutable(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ + sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) +#endif +#ifndef SvPV_force +# define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_force_nolen +# define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) +#endif + +#ifndef SvPV_force_mutable +# define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_force_nomg +# define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) +#endif + +#ifndef SvPV_force_nomg_nolen +# define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) +#endif +#ifndef SvPV_force_flags +# define SvPV_force_flags(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) +#endif +#ifndef SvPV_force_flags_nolen +# define SvPV_force_flags_nolen(sv, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags)) +#endif +#ifndef SvPV_force_flags_mutable +# define SvPV_force_flags_mutable(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ + : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) +#endif +#ifndef SvPV_nolen +# define SvPV_nolen(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC)) +#endif +#ifndef SvPV_nolen_const +# define SvPV_nolen_const(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) +#endif +#ifndef SvPV_nomg +# define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) +#endif + +#ifndef SvPV_nomg_const +# define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) +#endif + +#ifndef SvPV_nomg_const_nolen +# define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) +#endif +#ifndef SvPV_renew +# define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \ + SvPV_set((sv), (char *) saferealloc( \ + (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \ + } STMT_END +#endif +#ifndef SvMAGIC_set +# define SvMAGIC_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ + (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END +#endif + +#if (PERL_BCDVERSION < 0x5009003) +#ifndef SvPVX_const +# define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) +#endif + +#ifndef SvPVX_mutable +# define SvPVX_mutable(sv) (0 + SvPVX(sv)) +#endif +#ifndef SvRV_set +# define SvRV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ + (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END +#endif + +#else +#ifndef SvPVX_const +# define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) +#endif + +#ifndef SvPVX_mutable +# define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) +#endif +#ifndef SvRV_set +# define SvRV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ + ((sv)->sv_u.svu_rv = (val)); } STMT_END +#endif + +#endif +#ifndef SvSTASH_set +# define SvSTASH_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ + (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END +#endif + +#if (PERL_BCDVERSION < 0x5004000) +#ifndef SvUV_set +# define SvUV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ + (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END +#endif + +#else +#ifndef SvUV_set +# define SvUV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ + (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END +#endif + +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) +#if defined(NEED_vnewSVpvf) +static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); +static +#else +extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); +#endif + +#ifdef vnewSVpvf +# undef vnewSVpvf +#endif +#define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) +#define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) + +#if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) + +SV * +DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) +{ + register SV *sv = newSV(0); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return sv; +} + +#endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) +# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) +# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg) +#if defined(NEED_sv_catpvf_mg) +static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +#endif + +#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) + +#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +#ifdef PERL_IMPLICIT_CONTEXT +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext) +#if defined(NEED_sv_catpvf_mg_nocontext) +static void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); +#endif + +#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) +#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) + +#if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +/* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ +#ifndef sv_catpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext +# else +# define sv_catpvf_mg Perl_sv_catpvf_mg +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg) +# define sv_vcatpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg) +#if defined(NEED_sv_setpvf_mg) +static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +#endif + +#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) + +#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +#ifdef PERL_IMPLICIT_CONTEXT +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext) +#if defined(NEED_sv_setpvf_mg_nocontext) +static void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); +#endif + +#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) +#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) + +#if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +/* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ +#ifndef sv_setpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext +# else +# define sv_setpvf_mg Perl_sv_setpvf_mg +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg) +# define sv_vsetpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +/* Hint: newSVpvn_share + * The SVs created by this function only mimic the behaviour of + * shared PVs without really being shared. Only use if you know + * what you're doing. + */ + +#ifndef newSVpvn_share + +#if defined(NEED_newSVpvn_share) +static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); +static +#else +extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); +#endif + +#ifdef newSVpvn_share +# undef newSVpvn_share +#endif +#define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) +#define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) + +#if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) + +SV * +DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) +{ + SV *sv; + if (len < 0) + len = -len; + if (!hash) + PERL_HASH(hash, (char*) src, len); + sv = newSVpvn((char *) src, len); + sv_upgrade(sv, SVt_PVIV); + SvIVX(sv) = hash; + SvREADONLY_on(sv); + SvPOK_on(sv); + return sv; +} + +#endif + +#endif +#ifndef SvSHARED_HASH +# define SvSHARED_HASH(sv) (0 + SvUVX(sv)) +#endif +#ifndef HvNAME_get +# define HvNAME_get(hv) HvNAME(hv) +#endif +#ifndef HvNAMELEN_get +# define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0) +#endif +#ifndef GvSVn +# define GvSVn(gv) GvSV(gv) +#endif + +#ifndef isGV_with_GP +# define isGV_with_GP(gv) isGV(gv) +#endif + +#ifndef gv_fetchpvn_flags +# define gv_fetchpvn_flags(name, len, flags, svt) gv_fetchpv(name, flags, svt) +#endif + +#ifndef gv_fetchsv +# define gv_fetchsv(name, flags, svt) gv_fetchpv(SvPV_nolen_const(name), flags, svt) +#endif +#ifndef get_cvn_flags +# define get_cvn_flags(name, namelen, flags) get_cv(name, flags) +#endif +#ifndef WARN_ALL +# define WARN_ALL 0 +#endif + +#ifndef WARN_CLOSURE +# define WARN_CLOSURE 1 +#endif + +#ifndef WARN_DEPRECATED +# define WARN_DEPRECATED 2 +#endif + +#ifndef WARN_EXITING +# define WARN_EXITING 3 +#endif + +#ifndef WARN_GLOB +# define WARN_GLOB 4 +#endif + +#ifndef WARN_IO +# define WARN_IO 5 +#endif + +#ifndef WARN_CLOSED +# define WARN_CLOSED 6 +#endif + +#ifndef WARN_EXEC +# define WARN_EXEC 7 +#endif + +#ifndef WARN_LAYER +# define WARN_LAYER 8 +#endif + +#ifndef WARN_NEWLINE +# define WARN_NEWLINE 9 +#endif + +#ifndef WARN_PIPE +# define WARN_PIPE 10 +#endif + +#ifndef WARN_UNOPENED +# define WARN_UNOPENED 11 +#endif + +#ifndef WARN_MISC +# define WARN_MISC 12 +#endif + +#ifndef WARN_NUMERIC +# define WARN_NUMERIC 13 +#endif + +#ifndef WARN_ONCE +# define WARN_ONCE 14 +#endif + +#ifndef WARN_OVERFLOW +# define WARN_OVERFLOW 15 +#endif + +#ifndef WARN_PACK +# define WARN_PACK 16 +#endif + +#ifndef WARN_PORTABLE +# define WARN_PORTABLE 17 +#endif + +#ifndef WARN_RECURSION +# define WARN_RECURSION 18 +#endif + +#ifndef WARN_REDEFINE +# define WARN_REDEFINE 19 +#endif + +#ifndef WARN_REGEXP +# define WARN_REGEXP 20 +#endif + +#ifndef WARN_SEVERE +# define WARN_SEVERE 21 +#endif + +#ifndef WARN_DEBUGGING +# define WARN_DEBUGGING 22 +#endif + +#ifndef WARN_INPLACE +# define WARN_INPLACE 23 +#endif + +#ifndef WARN_INTERNAL +# define WARN_INTERNAL 24 +#endif + +#ifndef WARN_MALLOC +# define WARN_MALLOC 25 +#endif + +#ifndef WARN_SIGNAL +# define WARN_SIGNAL 26 +#endif + +#ifndef WARN_SUBSTR +# define WARN_SUBSTR 27 +#endif + +#ifndef WARN_SYNTAX +# define WARN_SYNTAX 28 +#endif + +#ifndef WARN_AMBIGUOUS +# define WARN_AMBIGUOUS 29 +#endif + +#ifndef WARN_BAREWORD +# define WARN_BAREWORD 30 +#endif + +#ifndef WARN_DIGIT +# define WARN_DIGIT 31 +#endif + +#ifndef WARN_PARENTHESIS +# define WARN_PARENTHESIS 32 +#endif + +#ifndef WARN_PRECEDENCE +# define WARN_PRECEDENCE 33 +#endif + +#ifndef WARN_PRINTF +# define WARN_PRINTF 34 +#endif + +#ifndef WARN_PROTOTYPE +# define WARN_PROTOTYPE 35 +#endif + +#ifndef WARN_QW +# define WARN_QW 36 +#endif + +#ifndef WARN_RESERVED +# define WARN_RESERVED 37 +#endif + +#ifndef WARN_SEMICOLON +# define WARN_SEMICOLON 38 +#endif + +#ifndef WARN_TAINT +# define WARN_TAINT 39 +#endif + +#ifndef WARN_THREADS +# define WARN_THREADS 40 +#endif + +#ifndef WARN_UNINITIALIZED +# define WARN_UNINITIALIZED 41 +#endif + +#ifndef WARN_UNPACK +# define WARN_UNPACK 42 +#endif + +#ifndef WARN_UNTIE +# define WARN_UNTIE 43 +#endif + +#ifndef WARN_UTF8 +# define WARN_UTF8 44 +#endif + +#ifndef WARN_VOID +# define WARN_VOID 45 +#endif + +#ifndef WARN_ASSERTIONS +# define WARN_ASSERTIONS 46 +#endif +#ifndef packWARN +# define packWARN(a) (a) +#endif + +#ifndef ckWARN +# ifdef G_WARN_ON +# define ckWARN(a) (PL_dowarn & G_WARN_ON) +# else +# define ckWARN(a) PL_dowarn +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) +#if defined(NEED_warner) +static void DPPP_(my_warner)(U32 err, const char *pat, ...); +static +#else +extern void DPPP_(my_warner)(U32 err, const char *pat, ...); +#endif + +#define Perl_warner DPPP_(my_warner) + +#if defined(NEED_warner) || defined(NEED_warner_GLOBAL) + +void +DPPP_(my_warner)(U32 err, const char *pat, ...) +{ + SV *sv; + va_list args; + + PERL_UNUSED_ARG(err); + + va_start(args, pat); + sv = vnewSVpvf(pat, &args); + va_end(args); + sv_2mortal(sv); + warn("%s", SvPV_nolen(sv)); +} + +#define warner Perl_warner + +#define Perl_warner_nocontext Perl_warner + +#endif +#endif + +/* concatenating with "" ensures that only literal strings are accepted as argument + * note that STR_WITH_LEN() can't be used as argument to macros or functions that + * under some configurations might be macros + */ +#ifndef STR_WITH_LEN +# define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) +#endif +#ifndef newSVpvs +# define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) +#endif + +#ifndef newSVpvs_flags +# define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags) +#endif + +#ifndef newSVpvs_share +# define newSVpvs_share(str) newSVpvn_share(str "", sizeof(str) - 1, 0) +#endif + +#ifndef sv_catpvs +# define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1) +#endif + +#ifndef sv_setpvs +# define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) +#endif + +#ifndef hv_fetchs +# define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) +#endif + +#ifndef hv_stores +# define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) +#endif +#ifndef gv_fetchpvs +# define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt) +#endif + +#ifndef gv_stashpvs +# define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags) +#endif +#ifndef get_cvs +# define get_cvs(name, flags) get_cvn_flags(name "", sizeof(name)-1, flags) +#endif +#ifndef SvGETMAGIC +# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END +#endif +#ifndef PERL_MAGIC_sv +# define PERL_MAGIC_sv '\0' +#endif + +#ifndef PERL_MAGIC_overload +# define PERL_MAGIC_overload 'A' +#endif + +#ifndef PERL_MAGIC_overload_elem +# define PERL_MAGIC_overload_elem 'a' +#endif + +#ifndef PERL_MAGIC_overload_table +# define PERL_MAGIC_overload_table 'c' +#endif + +#ifndef PERL_MAGIC_bm +# define PERL_MAGIC_bm 'B' +#endif + +#ifndef PERL_MAGIC_regdata +# define PERL_MAGIC_regdata 'D' +#endif + +#ifndef PERL_MAGIC_regdatum +# define PERL_MAGIC_regdatum 'd' +#endif + +#ifndef PERL_MAGIC_env +# define PERL_MAGIC_env 'E' +#endif + +#ifndef PERL_MAGIC_envelem +# define PERL_MAGIC_envelem 'e' +#endif + +#ifndef PERL_MAGIC_fm +# define PERL_MAGIC_fm 'f' +#endif + +#ifndef PERL_MAGIC_regex_global +# define PERL_MAGIC_regex_global 'g' +#endif + +#ifndef PERL_MAGIC_isa +# define PERL_MAGIC_isa 'I' +#endif + +#ifndef PERL_MAGIC_isaelem +# define PERL_MAGIC_isaelem 'i' +#endif + +#ifndef PERL_MAGIC_nkeys +# define PERL_MAGIC_nkeys 'k' +#endif + +#ifndef PERL_MAGIC_dbfile +# define PERL_MAGIC_dbfile 'L' +#endif + +#ifndef PERL_MAGIC_dbline +# define PERL_MAGIC_dbline 'l' +#endif + +#ifndef PERL_MAGIC_mutex +# define PERL_MAGIC_mutex 'm' +#endif + +#ifndef PERL_MAGIC_shared +# define PERL_MAGIC_shared 'N' +#endif + +#ifndef PERL_MAGIC_shared_scalar +# define PERL_MAGIC_shared_scalar 'n' +#endif + +#ifndef PERL_MAGIC_collxfrm +# define PERL_MAGIC_collxfrm 'o' +#endif + +#ifndef PERL_MAGIC_tied +# define PERL_MAGIC_tied 'P' +#endif + +#ifndef PERL_MAGIC_tiedelem +# define PERL_MAGIC_tiedelem 'p' +#endif + +#ifndef PERL_MAGIC_tiedscalar +# define PERL_MAGIC_tiedscalar 'q' +#endif + +#ifndef PERL_MAGIC_qr +# define PERL_MAGIC_qr 'r' +#endif + +#ifndef PERL_MAGIC_sig +# define PERL_MAGIC_sig 'S' +#endif + +#ifndef PERL_MAGIC_sigelem +# define PERL_MAGIC_sigelem 's' +#endif + +#ifndef PERL_MAGIC_taint +# define PERL_MAGIC_taint 't' +#endif + +#ifndef PERL_MAGIC_uvar +# define PERL_MAGIC_uvar 'U' +#endif + +#ifndef PERL_MAGIC_uvar_elem +# define PERL_MAGIC_uvar_elem 'u' +#endif + +#ifndef PERL_MAGIC_vstring +# define PERL_MAGIC_vstring 'V' +#endif + +#ifndef PERL_MAGIC_vec +# define PERL_MAGIC_vec 'v' +#endif + +#ifndef PERL_MAGIC_utf8 +# define PERL_MAGIC_utf8 'w' +#endif + +#ifndef PERL_MAGIC_substr +# define PERL_MAGIC_substr 'x' +#endif + +#ifndef PERL_MAGIC_defelem +# define PERL_MAGIC_defelem 'y' +#endif + +#ifndef PERL_MAGIC_glob +# define PERL_MAGIC_glob '*' +#endif + +#ifndef PERL_MAGIC_arylen +# define PERL_MAGIC_arylen '#' +#endif + +#ifndef PERL_MAGIC_pos +# define PERL_MAGIC_pos '.' +#endif + +#ifndef PERL_MAGIC_backref +# define PERL_MAGIC_backref '<' +#endif + +#ifndef PERL_MAGIC_ext +# define PERL_MAGIC_ext '~' +#endif + +/* That's the best we can do... */ +#ifndef sv_catpvn_nomg +# define sv_catpvn_nomg sv_catpvn +#endif + +#ifndef sv_catsv_nomg +# define sv_catsv_nomg sv_catsv +#endif + +#ifndef sv_setsv_nomg +# define sv_setsv_nomg sv_setsv +#endif + +#ifndef sv_pvn_nomg +# define sv_pvn_nomg sv_pvn +#endif + +#ifndef SvIV_nomg +# define SvIV_nomg SvIV +#endif + +#ifndef SvUV_nomg +# define SvUV_nomg SvUV +#endif + +#ifndef sv_catpv_mg +# define sv_catpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catpvn_mg +# define sv_catpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catsv_mg +# define sv_catsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_catsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setiv_mg +# define sv_setiv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setiv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setnv_mg +# define sv_setnv_mg(sv, num) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setnv(TeMpSv,num); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpv_mg +# define sv_setpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpvn_mg +# define sv_setpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setsv_mg +# define sv_setsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_setsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setuv_mg +# define sv_setuv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setuv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_usepvn_mg +# define sv_usepvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_usepvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif +#ifndef SvVSTRING_mg +# define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) +#endif + +/* Hint: sv_magic_portable + * This is a compatibility function that is only available with + * Devel::PPPort. It is NOT in the perl core. + * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when + * it is being passed a name pointer with namlen == 0. In that + * case, perl 5.8.0 and later store the pointer, not a copy of it. + * The compatibility can be provided back to perl 5.004. With + * earlier versions, the code will not compile. + */ + +#if (PERL_BCDVERSION < 0x5004000) + + /* code that uses sv_magic_portable will not compile */ + +#elif (PERL_BCDVERSION < 0x5008000) + +# define sv_magic_portable(sv, obj, how, name, namlen) \ + STMT_START { \ + SV *SvMp_sv = (sv); \ + char *SvMp_name = (char *) (name); \ + I32 SvMp_namlen = (namlen); \ + if (SvMp_name && SvMp_namlen == 0) \ + { \ + MAGIC *mg; \ + sv_magic(SvMp_sv, obj, how, 0, 0); \ + mg = SvMAGIC(SvMp_sv); \ + mg->mg_len = -42; /* XXX: this is the tricky part */ \ + mg->mg_ptr = SvMp_name; \ + } \ + else \ + { \ + sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ + } \ + } STMT_END + +#else + +# define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) + +#endif + +#ifdef USE_ITHREADS +#ifndef CopFILE +# define CopFILE(c) ((c)->cop_file) +#endif + +#ifndef CopFILEGV +# define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) ((c)->cop_stashpv) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ + || (CopSTASHPV(c) && HvNAME(hv) \ + && strEQ(CopSTASHPV(c), HvNAME(hv))))) +#endif + +#else +#ifndef CopFILEGV +# define CopFILEGV(c) ((c)->cop_filegv) +#endif + +#ifndef CopFILEGV_set +# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) +#endif + +#ifndef CopFILE +# define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) ((c)->cop_stash) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) +#endif + +#endif /* USE_ITHREADS */ +#ifndef IN_PERL_COMPILETIME +# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) +#endif + +#ifndef IN_LOCALE_RUNTIME +# define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE_COMPILETIME +# define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE +# define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) +#endif +#ifndef IS_NUMBER_IN_UV +# define IS_NUMBER_IN_UV 0x01 +#endif + +#ifndef IS_NUMBER_GREATER_THAN_UV_MAX +# define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef IS_NUMBER_NOT_INT +# define IS_NUMBER_NOT_INT 0x04 +#endif + +#ifndef IS_NUMBER_NEG +# define IS_NUMBER_NEG 0x08 +#endif + +#ifndef IS_NUMBER_INFINITY +# define IS_NUMBER_INFINITY 0x10 +#endif + +#ifndef IS_NUMBER_NAN +# define IS_NUMBER_NAN 0x20 +#endif +#ifndef GROK_NUMERIC_RADIX +# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) +#endif +#ifndef PERL_SCAN_GREATER_THAN_UV_MAX +# define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef PERL_SCAN_SILENT_ILLDIGIT +# define PERL_SCAN_SILENT_ILLDIGIT 0x04 +#endif + +#ifndef PERL_SCAN_ALLOW_UNDERSCORES +# define PERL_SCAN_ALLOW_UNDERSCORES 0x01 +#endif + +#ifndef PERL_SCAN_DISALLOW_PREFIX +# define PERL_SCAN_DISALLOW_PREFIX 0x02 +#endif + +#ifndef grok_numeric_radix +#if defined(NEED_grok_numeric_radix) +static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +static +#else +extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +#endif + +#ifdef grok_numeric_radix +# undef grok_numeric_radix +#endif +#define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) +#define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) + +#if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) +bool +DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) +{ +#ifdef USE_LOCALE_NUMERIC +#ifdef PL_numeric_radix_sv + if (PL_numeric_radix_sv && IN_LOCALE) { + STRLEN len; + char* radix = SvPV(PL_numeric_radix_sv, len); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#else + /* older perls don't have PL_numeric_radix_sv so the radix + * must manually be requested from locale.h + */ +#include <locale.h> + dTHR; /* needed for older threaded perls */ + struct lconv *lc = localeconv(); + char *radix = lc->decimal_point; + if (radix && IN_LOCALE) { + STRLEN len = strlen(radix); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#endif +#endif /* USE_LOCALE_NUMERIC */ + /* always try "." if numeric radix didn't match because + * we may have data from different locales mixed */ + if (*sp < send && **sp == '.') { + ++*sp; + return TRUE; + } + return FALSE; +} +#endif +#endif + +#ifndef grok_number +#if defined(NEED_grok_number) +static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +static +#else +extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +#endif + +#ifdef grok_number +# undef grok_number +#endif +#define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) +#define Perl_grok_number DPPP_(my_grok_number) + +#if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) +int +DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) +{ + const char *s = pv; + const char *send = pv + len; + const UV max_div_10 = UV_MAX / 10; + const char max_mod_10 = UV_MAX % 10; + int numtype = 0; + int sawinf = 0; + int sawnan = 0; + + while (s < send && isSPACE(*s)) + s++; + if (s == send) { + return 0; + } else if (*s == '-') { + s++; + numtype = IS_NUMBER_NEG; + } + else if (*s == '+') + s++; + + if (s == send) + return 0; + + /* next must be digit or the radix separator or beginning of infinity */ + if (isDIGIT(*s)) { + /* UVs are at least 32 bits, so the first 9 decimal digits cannot + overflow. */ + UV value = *s - '0'; + /* This construction seems to be more optimiser friendly. + (without it gcc does the isDIGIT test and the *s - '0' separately) + With it gcc on arm is managing 6 instructions (6 cycles) per digit. + In theory the optimiser could deduce how far to unroll the loop + before checking for overflow. */ + if (++s < send) { + int digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + /* Now got 9 digits, so need to check + each time for overflow. */ + digit = *s - '0'; + while (digit >= 0 && digit <= 9 + && (value < max_div_10 + || (value == max_div_10 + && digit <= max_mod_10))) { + value = value * 10 + digit; + if (++s < send) + digit = *s - '0'; + else + break; + } + if (digit >= 0 && digit <= 9 + && (s < send)) { + /* value overflowed. + skip the remaining digits, don't + worry about setting *valuep. */ + do { + s++; + } while (s < send && isDIGIT(*s)); + numtype |= + IS_NUMBER_GREATER_THAN_UV_MAX; + goto skip_value; + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + numtype |= IS_NUMBER_IN_UV; + if (valuep) + *valuep = value; + + skip_value: + if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT; + while (s < send && isDIGIT(*s)) /* optional digits after the radix */ + s++; + } + } + else if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ + /* no digits before the radix means we need digits after it */ + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + if (valuep) { + /* integer approximation is valid - it's 0. */ + *valuep = 0; + } + } + else + return 0; + } else if (*s == 'I' || *s == 'i') { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; + s++; if (s < send && (*s == 'I' || *s == 'i')) { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; + s++; if (s == send || (*s != 'T' && *s != 't')) return 0; + s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; + s++; + } + sawinf = 1; + } else if (*s == 'N' || *s == 'n') { + /* XXX TODO: There are signaling NaNs and quiet NaNs. */ + s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; + sawnan = 1; + } else + return 0; + + if (sawinf) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; + } else if (sawnan) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + } else if (s < send) { + /* we can have an optional exponent part */ + if (*s == 'e' || *s == 'E') { + /* The only flag we keep is sign. Blow away any "it's UV" */ + numtype &= IS_NUMBER_NEG; + numtype |= IS_NUMBER_NOT_INT; + s++; + if (s < send && (*s == '-' || *s == '+')) + s++; + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + } + else + return 0; + } + } + while (s < send && isSPACE(*s)) + s++; + if (s >= send) + return numtype; + if (len == 10 && memEQ(pv, "0 but true", 10)) { + if (valuep) + *valuep = 0; + return IS_NUMBER_IN_UV; + } + return 0; +} +#endif +#endif + +/* + * The grok_* routines have been modified to use warn() instead of + * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, + * which is why the stack variable has been renamed to 'xdigit'. + */ + +#ifndef grok_bin +#if defined(NEED_grok_bin) +static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_bin +# undef grok_bin +#endif +#define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) +#define Perl_grok_bin DPPP_(my_grok_bin) + +#if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) +UV +DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_2 = UV_MAX / 2; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading b or 0b. + for compatibility silently suffer "b" and "0b" as valid binary + numbers. */ + if (len >= 1) { + if (s[0] == 'b') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'b') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + char bit = *s; + if (bit == '0' || bit == '1') { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_bin. */ + redo: + if (!overflowed) { + if (value <= max_div_2) { + value = (value << 1) | (bit - '0'); + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in binary number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 2.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount. */ + value_nv += (NV)(bit - '0'); + continue; + } + if (bit == '_' && len && allow_underscores && (bit = s[1]) + && (bit == '0' || bit == '1')) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal binary digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Binary number > 0b11111111111111111111111111111111 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_hex +#if defined(NEED_grok_hex) +static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_hex +# undef grok_hex +#endif +#define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) +#define Perl_grok_hex DPPP_(my_grok_hex) + +#if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) +UV +DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_16 = UV_MAX / 16; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + const char *xdigit; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading x or 0x. + for compatibility silently suffer "x" and "0x" as valid hex numbers. + */ + if (len >= 1) { + if (s[0] == 'x') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'x') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + xdigit = strchr((char *) PL_hexdigit, *s); + if (xdigit) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_hex. */ + redo: + if (!overflowed) { + if (value <= max_div_16) { + value = (value << 4) | ((xdigit - PL_hexdigit) & 15); + continue; + } + warn("Integer overflow in hexadecimal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 16.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 16-tuples. */ + value_nv += (NV)((xdigit - PL_hexdigit) & 15); + continue; + } + if (*s == '_' && len && allow_underscores && s[1] + && (xdigit = strchr((char *) PL_hexdigit, s[1]))) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal hexadecimal digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Hexadecimal number > 0xffffffff non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_oct +#if defined(NEED_grok_oct) +static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_oct +# undef grok_oct +#endif +#define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) +#define Perl_grok_oct DPPP_(my_grok_oct) + +#if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) +UV +DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_8 = UV_MAX / 8; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + for (; len-- && *s; s++) { + /* gcc 2.95 optimiser not smart enough to figure that this subtraction + out front allows slicker code. */ + int digit = *s - '0'; + if (digit >= 0 && digit <= 7) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + */ + redo: + if (!overflowed) { + if (value <= max_div_8) { + value = (value << 3) | digit; + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in octal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 8.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 8-tuples. */ + value_nv += (NV)digit; + continue; + } + if (digit == ('_' - '0') && len && allow_underscores + && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) + { + --len; + ++s; + goto redo; + } + /* Allow \octal to work the DWIM way (that is, stop scanning + * as soon as non-octal characters are seen, complain only iff + * someone seems to want to use the digits eight and nine). */ + if (digit == 8 || digit == 9) { + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal octal digit '%c' ignored", *s); + } + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Octal number > 037777777777 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#if !defined(my_snprintf) +#if defined(NEED_my_snprintf) +static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); +static +#else +extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); +#endif + +#define my_snprintf DPPP_(my_my_snprintf) +#define Perl_my_snprintf DPPP_(my_my_snprintf) + +#if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) + +int +DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...) +{ + dTHX; + int retval; + va_list ap; + va_start(ap, format); +#ifdef HAS_VSNPRINTF + retval = vsnprintf(buffer, len, format, ap); +#else + retval = vsprintf(buffer, format, ap); +#endif + va_end(ap); + if (retval < 0 || (len > 0 && (Size_t)retval >= len)) + Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); + return retval; +} + +#endif +#endif + +#if !defined(my_sprintf) +#if defined(NEED_my_sprintf) +static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); +static +#else +extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); +#endif + +#define my_sprintf DPPP_(my_my_sprintf) +#define Perl_my_sprintf DPPP_(my_my_sprintf) + +#if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL) + +int +DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...) +{ + va_list args; + va_start(args, pat); + vsprintf(buffer, pat, args); + va_end(args); + return strlen(buffer); +} + +#endif +#endif + +#ifdef NO_XSLOCKS +# ifdef dJMPENV +# define dXCPT dJMPENV; int rEtV = 0 +# define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) +# define XCPT_TRY_END JMPENV_POP; +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW JMPENV_JUMP(rEtV) +# else +# define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 +# define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) +# define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW Siglongjmp(top_env, rEtV) +# endif +#endif + +#if !defined(my_strlcat) +#if defined(NEED_my_strlcat) +static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); +static +#else +extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); +#endif + +#define my_strlcat DPPP_(my_my_strlcat) +#define Perl_my_strlcat DPPP_(my_my_strlcat) + +#if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) + +Size_t +DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size) +{ + Size_t used, length, copy; + + used = strlen(dst); + length = strlen(src); + if (size > 0 && used < size - 1) { + copy = (length >= size - used) ? size - used - 1 : length; + memcpy(dst + used, src, copy); + dst[used + copy] = '\0'; + } + return used + length; +} +#endif +#endif + +#if !defined(my_strlcpy) +#if defined(NEED_my_strlcpy) +static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); +static +#else +extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); +#endif + +#define my_strlcpy DPPP_(my_my_strlcpy) +#define Perl_my_strlcpy DPPP_(my_my_strlcpy) + +#if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) + +Size_t +DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size) +{ + Size_t length, copy; + + length = strlen(src); + if (size > 0) { + copy = (length >= size) ? size - 1 : length; + memcpy(dst, src, copy); + dst[copy] = '\0'; + } + return length; +} + +#endif +#endif +#ifndef PERL_PV_ESCAPE_QUOTE +# define PERL_PV_ESCAPE_QUOTE 0x0001 +#endif + +#ifndef PERL_PV_PRETTY_QUOTE +# define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE +#endif + +#ifndef PERL_PV_PRETTY_ELLIPSES +# define PERL_PV_PRETTY_ELLIPSES 0x0002 +#endif + +#ifndef PERL_PV_PRETTY_LTGT +# define PERL_PV_PRETTY_LTGT 0x0004 +#endif + +#ifndef PERL_PV_ESCAPE_FIRSTCHAR +# define PERL_PV_ESCAPE_FIRSTCHAR 0x0008 +#endif + +#ifndef PERL_PV_ESCAPE_UNI +# define PERL_PV_ESCAPE_UNI 0x0100 +#endif + +#ifndef PERL_PV_ESCAPE_UNI_DETECT +# define PERL_PV_ESCAPE_UNI_DETECT 0x0200 +#endif + +#ifndef PERL_PV_ESCAPE_ALL +# define PERL_PV_ESCAPE_ALL 0x1000 +#endif + +#ifndef PERL_PV_ESCAPE_NOBACKSLASH +# define PERL_PV_ESCAPE_NOBACKSLASH 0x2000 +#endif + +#ifndef PERL_PV_ESCAPE_NOCLEAR +# define PERL_PV_ESCAPE_NOCLEAR 0x4000 +#endif + +#ifndef PERL_PV_ESCAPE_RE +# define PERL_PV_ESCAPE_RE 0x8000 +#endif + +#ifndef PERL_PV_PRETTY_NOCLEAR +# define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR +#endif +#ifndef PERL_PV_PRETTY_DUMP +# define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE +#endif + +#ifndef PERL_PV_PRETTY_REGPROP +# define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE +#endif + +/* Hint: pv_escape + * Note that unicode functionality is only backported to + * those perl versions that support it. For older perl + * versions, the implementation will fall back to bytes. + */ + +#ifndef pv_escape +#if defined(NEED_pv_escape) +static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); +static +#else +extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); +#endif + +#ifdef pv_escape +# undef pv_escape +#endif +#define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f) +#define Perl_pv_escape DPPP_(my_pv_escape) + +#if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL) + +char * +DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str, + const STRLEN count, const STRLEN max, + STRLEN * const escaped, const U32 flags) +{ + const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\'; + const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc; + char octbuf[32] = "%123456789ABCDF"; + STRLEN wrote = 0; + STRLEN chsize = 0; + STRLEN readsize = 1; +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0; +#endif + const char *pv = str; + const char * const end = pv + count; + octbuf[0] = esc; + + if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) + sv_setpvs(dsv, ""); + +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) + isuni = 1; +#endif + + for (; pv < end && (!max || wrote < max) ; pv += readsize) { + const UV u = +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + isuni ? utf8_to_uvchr((U8*)pv, &readsize) : +#endif + (U8)*pv; + const U8 c = (U8)u & 0xFF; + + if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) { + if (flags & PERL_PV_ESCAPE_FIRSTCHAR) + chsize = my_snprintf(octbuf, sizeof octbuf, + "%"UVxf, u); + else + chsize = my_snprintf(octbuf, sizeof octbuf, + "%cx{%"UVxf"}", esc, u); + } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { + chsize = 1; + } else { + if (c == dq || c == esc || !isPRINT(c)) { + chsize = 2; + switch (c) { + case '\\' : /* fallthrough */ + case '%' : if (c == esc) + octbuf[1] = esc; + else + chsize = 1; + break; + case '\v' : octbuf[1] = 'v'; break; + case '\t' : octbuf[1] = 't'; break; + case '\r' : octbuf[1] = 'r'; break; + case '\n' : octbuf[1] = 'n'; break; + case '\f' : octbuf[1] = 'f'; break; + case '"' : if (dq == '"') + octbuf[1] = '"'; + else + chsize = 1; + break; + default: chsize = my_snprintf(octbuf, sizeof octbuf, + pv < end && isDIGIT((U8)*(pv+readsize)) + ? "%c%03o" : "%c%o", esc, c); + } + } else { + chsize = 1; + } + } + if (max && wrote + chsize > max) { + break; + } else if (chsize > 1) { + sv_catpvn(dsv, octbuf, chsize); + wrote += chsize; + } else { + char tmp[2]; + my_snprintf(tmp, sizeof tmp, "%c", c); + sv_catpvn(dsv, tmp, 1); + wrote++; + } + if (flags & PERL_PV_ESCAPE_FIRSTCHAR) + break; + } + if (escaped != NULL) + *escaped= pv - str; + return SvPVX(dsv); +} + +#endif +#endif + +#ifndef pv_pretty +#if defined(NEED_pv_pretty) +static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); +static +#else +extern char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); +#endif + +#ifdef pv_pretty +# undef pv_pretty +#endif +#define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g) +#define Perl_pv_pretty DPPP_(my_pv_pretty) + +#if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL) + +char * +DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count, + const STRLEN max, char const * const start_color, char const * const end_color, + const U32 flags) +{ + const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; + STRLEN escaped; + + if (!(flags & PERL_PV_PRETTY_NOCLEAR)) + sv_setpvs(dsv, ""); + + if (dq == '"') + sv_catpvs(dsv, "\""); + else if (flags & PERL_PV_PRETTY_LTGT) + sv_catpvs(dsv, "<"); + + if (start_color != NULL) + sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color)); + + pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR); + + if (end_color != NULL) + sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color)); + + if (dq == '"') + sv_catpvs(dsv, "\""); + else if (flags & PERL_PV_PRETTY_LTGT) + sv_catpvs(dsv, ">"); + + if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count) + sv_catpvs(dsv, "..."); + + return SvPVX(dsv); +} + +#endif +#endif + +#ifndef pv_display +#if defined(NEED_pv_display) +static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); +static +#else +extern char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); +#endif + +#ifdef pv_display +# undef pv_display +#endif +#define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e) +#define Perl_pv_display DPPP_(my_pv_display) + +#if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL) + +char * +DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) +{ + pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); + if (len > cur && pv[cur] == '\0') + sv_catpvs(dsv, "\\0"); + return SvPVX(dsv); +} + +#endif +#endif + +#endif /* _P_P_PORTABILITY_H_ */ + +/* End of File ppport.h */ diff --git a/cpanfile b/cpanfile new file mode 100644 index 0000000..a9605f6 --- /dev/null +++ b/cpanfile @@ -0,0 +1,59 @@ +requires "Attribute::Handlers" => "0.79"; +requires "Carp" => "0"; +requires "Exporter" => "0"; +requires "Module::Implementation" => "0"; +requires "Scalar::Util" => "1.10"; +requires "XSLoader" => "0"; +requires "attributes" => "0"; +requires "perl" => "5.008001"; +requires "strict" => "0"; +requires "vars" => "0"; +requires "warnings" => "0"; + +on 'build' => sub { + requires "Module::Build" => "0.28"; +}; + +on 'test' => sub { + requires "Devel::Peek" => "0"; + requires "ExtUtils::MakeMaker" => "0"; + requires "File::Spec" => "0"; + requires "File::Temp" => "0"; + requires "Test::Fatal" => "0"; + requires "Test::More" => "0.96"; + requires "Test::Requires" => "0"; + requires "Tie::Array" => "0"; + requires "Tie::Hash" => "0"; + requires "base" => "0"; + requires "lib" => "0"; + requires "overload" => "0"; +}; + +on 'test' => sub { + recommends "CPAN::Meta" => "2.120900"; +}; + +on 'configure' => sub { + requires "Module::Build" => "0.28"; +}; + +on 'develop' => sub { + requires "File::Spec" => "0"; + requires "IO::Handle" => "0"; + requires "IPC::Open3" => "0"; + requires "Perl::Critic" => "1.123"; + requires "Perl::Tidy" => "20140711"; + requires "Pod::Coverage::TrustPod" => "0"; + requires "Readonly" => "1.03"; + requires "Scalar::Util" => "1.20"; + requires "Test::CPAN::Changes" => "0.19"; + requires "Test::EOL" => "0"; + requires "Test::LeakTrace" => "0.15"; + requires "Test::More" => "0.96"; + requires "Test::NoTabs" => "0"; + requires "Test::Pod" => "1.41"; + requires "Test::Pod::Coverage" => "1.08"; + requires "Test::Spelling" => "0.12"; + requires "Test::Synopsis" => "0"; + requires "Test::Taint" => "0.02"; +}; diff --git a/dist.ini b/dist.ini new file mode 100644 index 0000000..44baaa8 --- /dev/null +++ b/dist.ini @@ -0,0 +1,47 @@ +name = Params-Validate +author = Dave Rolsky <autarch@urth.org> +author = Ilya Martynov <ilya@martynov.org> +license = Artistic_2_0 +copyright_holder = Dave Rolsky and Ilya Martynov +copyright_year = 2001 + +[@DROLSKY] +dist = Params-Validate +next_release_width = 7 +pod_coverage_trustme = Params::Validate => qr/^(?:UNKNOWN|set_options|validate(?:_pos|_with)?|validation_options)$/ +pod_coverage_skip = Params::Validate::Constants +pod_coverage_skip = Params::Validate::PP +pod_coverage_skip = Params::Validate::XS +pod_coverage_skip = Params::ValidatePP +pod_coverage_skip = Params::ValidateXS +prereqs_skip = ClassCan +prereqs_skip = ClassISA +prereqs_skip = Tie::StdArray +prereqs_skip = Tie::StdHash +stopwords = API +stopwords = CPAN +stopwords = GLOBREF +stopwords = OO +stopwords = PayPal +stopwords = SCALARREF +stopwords = ValidatePos +stopwords = baz +stopwords = onwards +stopwords = pre +stopwords = runtime +-remove = MakeMaker +-remove = Test::TidyAll +-remove = Test::Version + +[Prereqs / DevelopRequires] +Readonly = 1.03 +Scalar::Util = 1.20 +Test::LeakTrace = 0.15 +Test::More = 0.96 +Test::Taint = 0.02 + +; authordep Dist::Zilla::Plugin::ModuleBuild::XSOrPP +[=inc::MyModuleBuild] + +[PurePerlTests] +env_var = PV_TEST_PERL diff --git a/inc/MyModuleBuild.pm b/inc/MyModuleBuild.pm new file mode 100644 index 0000000..5252844 --- /dev/null +++ b/inc/MyModuleBuild.pm @@ -0,0 +1,23 @@ +package inc::MyModuleBuild; + +use strict; +use warnings; + +use Moose; + +extends 'Dist::Zilla::Plugin::ModuleBuild::XSOrPP'; + +around module_build_args => sub { + my $orig = shift; + my $self = shift; + + my $args = $self->$orig(@_); + + $args->{c_source} = 'c'; + + return $args; +}; + +__PACKAGE__->meta()->make_immutable(); + +1; diff --git a/lib/Attribute/Params/Validate.pm b/lib/Attribute/Params/Validate.pm new file mode 100644 index 0000000..f72c16a --- /dev/null +++ b/lib/Attribute/Params/Validate.pm @@ -0,0 +1,208 @@ +package Attribute::Params::Validate; + +use strict; +use warnings; + +our $VERSION = '1.20'; + +use attributes; + +use Attribute::Handlers 0.79; + +# this will all be re-exported +use Params::Validate qw(:all); + +require Exporter; + +our @ISA = qw(Exporter); + +my %tags = ( + types => [ + qw( SCALAR ARRAYREF HASHREF CODEREF GLOB GLOBREF SCALARREF HANDLE UNDEF OBJECT ) + ], +); + +our %EXPORT_TAGS = ( + 'all' => [ qw( validation_options ), map { @{ $tags{$_} } } keys %tags ], + %tags, +); +our @EXPORT_OK = ( @{ $EXPORT_TAGS{all} }, 'validation_options' ); + + +sub UNIVERSAL::Validate : ATTR(CODE, INIT) { + _wrap_sub( 'named', @_ ); +} + +sub UNIVERSAL::ValidatePos : ATTR(CODE, INIT) { + _wrap_sub( 'positional', @_ ); +} + +sub _wrap_sub { + my ( $type, $package, $symbol, $referent, $attr, $params ) = @_; + + my @p = ref $params ? @{$params} : $params; + + my $subname = $package . '::' . *{$symbol}{NAME}; + + my %attributes = map { $_ => 1 } attributes::get($referent); + my $is_method = $attributes{method}; + + { + no warnings 'redefine'; + no strict 'refs'; + + # An unholy mixture of closure and eval. This is done so that + # the code to automatically create the relevant scalars from + # the hash of params can create the scalars in the proper + # place lexically. + + my $code = <<"EOF"; +sub +{ + package $package; +EOF + + $code .= " my \$object = shift;\n" if $is_method; + + if ( $type eq 'named' ) { + $params = {@p}; + $code .= " Params::Validate::validate(\@_, \$params);\n"; + } + else { + $code .= " Params::Validate::validate_pos(\@_, \@p);\n"; + } + + $code .= " unshift \@_, \$object if \$object;\n" if $is_method; + + $code .= <<"EOF"; + \$referent->(\@_); +} +EOF + + my $sub = eval $code; + die $@ if $@; + + *{$subname} = $sub; + } +} + +1; + +# ABSTRACT: Define validation through subroutine attributes + +__END__ + +=pod + +=head1 NAME + +Attribute::Params::Validate - Define validation through subroutine attributes + +=head1 VERSION + +version 1.20 + +=head1 SYNOPSIS + + use Attribute::Params::Validate qw(:all); + + # takes named params (hash or hashref) + # foo is mandatory, bar is optional + sub foo : Validate( foo => 1, bar => 0 ) + { + # insert code here + } + + # takes positional params + # first two are mandatory, third is optional + sub bar : ValidatePos( 1, 1, 0 ) + { + # insert code here + } + + # for some reason Perl insists that the entire attribute be on one line + sub foo2 : Validate( foo => { type => ARRAYREF }, bar => { can => [ 'print', 'flush', 'frobnicate' ] }, baz => { type => SCALAR, callbacks => { 'numbers only' => sub { shift() =~ /^\d+$/ }, 'less than 90' => sub { shift() < 90 } } } ) + { + # insert code here + } + + # note that this is marked as a method. This is very important! + sub baz : Validate( foo => { type => ARRAYREF }, bar => { isa => 'Frobnicator' } ) method + { + # insert code here + } + +=head1 DESCRIPTION + +The Attribute::Params::Validate module allows you to validate method +or function call parameters just like Params::Validate does. However, +this module allows you to specify your validation spec as an +attribute, rather than by calling the C<validate> routine. + +Please see Params::Validate for more information on how you can +specify what validation is performed. + +=head2 EXPORT + +This module exports everything that Params::Validate does except for +the C<validate> and C<validate_pos> subroutines. + +=head2 ATTRIBUTES + +=over 4 + +=item * Validate + +This attribute corresponds to the C<validate> subroutine in +Params::Validate. + +=item * ValidatePos + +This attribute corresponds to the C<validate_pos> subroutine in +Params::Validate. + +=back + +=head2 OO + +If you are using this module to mark B<methods> for validation, as +opposed to subroutines, it is crucial that you mark these methods with +the C<:method> attribute, as well as the C<Validate> or C<ValidatePos> +attribute. + +If you do not do this, then the object or class used in the method +call will be passed to the validation routines, which is probably not +what you want. + +=head2 CAVEATS + +You B<must> put all the arguments to the C<Validate> or C<ValidatePos> +attribute on a single line, or Perl will complain. + +=head1 SEE ALSO + +Params::Validate + +=head1 AUTHORS + +=over 4 + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Ilya Martynov <ilya@martynov.org> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is Copyright (c) 2001 - 2015 by Dave Rolsky and Ilya Martynov. + +This is free software, licensed under: + + The Artistic License 2.0 (GPL Compatible) + +=cut diff --git a/lib/Params/Validate.pm b/lib/Params/Validate.pm new file mode 100644 index 0000000..7a5ff01 --- /dev/null +++ b/lib/Params/Validate.pm @@ -0,0 +1,900 @@ +package Params::Validate; + +use 5.008001; + +use strict; +use warnings; + +our $VERSION = '1.20'; + +use Exporter; +use Module::Implementation; +use Params::Validate::Constants; + +use vars qw( $NO_VALIDATION %OPTIONS $options ); + +our @ISA = 'Exporter'; + +my @types = qw( + SCALAR + ARRAYREF + HASHREF + CODEREF + GLOB + GLOBREF + SCALARREF + HANDLE + BOOLEAN + UNDEF + OBJECT +); + +our %EXPORT_TAGS = ( + 'all' => [ + qw( validate validate_pos validation_options validate_with ), + @types + ], + types => \@types, +); + +our @EXPORT_OK = ( @{ $EXPORT_TAGS{all} }, 'set_options' ); +our @EXPORT = qw( validate validate_pos ); + +$NO_VALIDATION = $ENV{PERL_NO_VALIDATION}; + +{ + my $loader = Module::Implementation::build_loader_sub( + implementations => [ 'XS', 'PP' ], + symbols => [ + qw( + validate + validate_pos + validate_with + validation_options + set_options + ), + ], + ); + + $ENV{PARAMS_VALIDATE_IMPLEMENTATION} = 'PP' if $ENV{PV_TEST_PERL}; + + $loader->(); +} + +1; + +# ABSTRACT: Validate method/function parameters + +__END__ + +=pod + +=head1 NAME + +Params::Validate - Validate method/function parameters + +=head1 VERSION + +version 1.20 + +=head1 SYNOPSIS + + use Params::Validate qw(:all); + + # takes named params (hash or hashref) + sub foo { + validate( + @_, { + foo => 1, # mandatory + bar => 0, # optional + } + ); + } + + # takes positional params + sub bar { + # first two are mandatory, third is optional + validate_pos( @_, 1, 1, 0 ); + } + + sub foo2 { + validate( + @_, { + foo => + # specify a type + { type => ARRAYREF }, + bar => + # specify an interface + { can => [ 'print', 'flush', 'frobnicate' ] }, + baz => { + type => SCALAR, # a scalar ... + # ... that is a plain integer ... + regex => qr/^\d+$/, + callbacks => { # ... and smaller than 90 + 'less than 90' => sub { shift() < 90 }, + }, + } + } + ); + } + + sub callback_with_custom_error { + validate( + @_, + { + foo => callbacks => { + 'is an integer' => sub { + return 1 if $_[0] =~ /^-?[1-9][0-9]*$/; + die "$_[0] is not a valid integer value"; + }, + } + } + ); + } + + sub with_defaults { + my %p = validate( + @_, { + # required + foo => 1, + # $p{bar} will be 99 if bar is not given. bar is now + # optional. + bar => { default => 99 } + } + ); + } + + sub pos_with_defaults { + my @p = validate_pos( @_, 1, { default => 99 } ); + } + + sub sets_options_on_call { + my %p = validate_with( + params => \@_, + spec => { foo => { type => SCALAR, default => 2 } }, + normalize_keys => sub { $_[0] =~ s/^-//; lc $_[0] }, + ); + } + +=head1 DESCRIPTION + +The Params::Validate module allows you to validate method or function +call parameters to an arbitrary level of specificity. At the simplest +level, it is capable of validating the required parameters were given +and that no unspecified additional parameters were passed in. + +It is also capable of determining that a parameter is of a specific +type, that it is an object of a certain class hierarchy, that it +possesses certain methods, or applying validation callbacks to +arguments. + +=head2 EXPORT + +The module always exports the C<validate()> and C<validate_pos()> +functions. + +It also has an additional function available for export, +C<validate_with>, which can be used to validate any type of +parameters, and set various options on a per-invocation basis. + +In addition, it can export the following constants, which are used as +part of the type checking. These are C<SCALAR>, C<ARRAYREF>, +C<HASHREF>, C<CODEREF>, C<GLOB>, C<GLOBREF>, and C<SCALARREF>, +C<UNDEF>, C<OBJECT>, C<BOOLEAN>, and C<HANDLE>. These are explained +in the section on L<Type Validation|Params::Validate/Type Validation>. + +The constants are available via the export tag C<:types>. There is +also an C<:all> tag which includes all of the constants as well as the +C<validation_options()> function. + +=encoding UTF-8 + +=head1 PARAMETER VALIDATION + +The validation mechanisms provided by this module can handle both +named or positional parameters. For the most part, the same features +are available for each. The biggest difference is the way that the +validation specification is given to the relevant subroutine. The +other difference is in the error messages produced when validation +checks fail. + +When handling named parameters, the module will accept either a hash +or a hash reference. + +Subroutines expecting named parameters should call the C<validate()> +subroutine like this: + + validate( + @_, { + parameter1 => validation spec, + parameter2 => validation spec, + ... + } + ); + +Subroutines expecting positional parameters should call the +C<validate_pos()> subroutine like this: + + validate_pos( @_, { validation spec }, { validation spec } ); + +=head2 Mandatory/Optional Parameters + +If you just want to specify that some parameters are mandatory and +others are optional, this can be done very simply. + +For a subroutine expecting named parameters, you would do this: + + validate( @_, { foo => 1, bar => 1, baz => 0 } ); + +This says that the "foo" and "bar" parameters are mandatory and that +the "baz" parameter is optional. The presence of any other +parameters will cause an error. + +For a subroutine expecting positional parameters, you would do this: + + validate_pos( @_, 1, 1, 0, 0 ); + +This says that you expect at least 2 and no more than 4 parameters. +If you have a subroutine that has a minimum number of parameters but +can take any maximum number, you can do this: + + validate_pos( @_, 1, 1, (0) x (@_ - 2) ); + +This will always be valid as long as at least two parameters are +given. A similar construct could be used for the more complex +validation parameters described further on. + +Please note that this: + + validate_pos( @_, 1, 1, 0, 1, 1 ); + +makes absolutely no sense, so don't do it. Any zeros must come at the +end of the validation specification. + +In addition, if you specify that a parameter can have a default, then +it is considered optional. + +=head2 Type Validation + +This module supports the following simple types, which can be +L<exported as constants|/EXPORT>: + +=over 4 + +=item * SCALAR + +A scalar which is not a reference, such as C<10> or C<'hello'>. A +parameter that is undefined is B<not> treated as a scalar. If you +want to allow undefined values, you will have to specify C<SCALAR | +UNDEF>. + +=item * ARRAYREF + +An array reference such as C<[1, 2, 3]> or C<\@foo>. + +=item * HASHREF + +A hash reference such as C<< { a => 1, b => 2 } >> or C<\%bar>. + +=item * CODEREF + +A subroutine reference such as C<\&foo_sub> or C<sub { print "hello" }>. + +=item * GLOB + +This one is a bit tricky. A glob would be something like C<*FOO>, but +not C<\*FOO>, which is a glob reference. It should be noted that this +trick: + + my $fh = do { local *FH; }; + +makes C<$fh> a glob, not a glob reference. On the other hand, the +return value from C<Symbol::gensym> is a glob reference. Either can +be used as a file or directory handle. + +=item * GLOBREF + +A glob reference such as C<\*FOO>. See the L<GLOB|GLOB> entry above +for more details. + +=item * SCALARREF + +A reference to a scalar such as C<\$x>. + +=item * UNDEF + +An undefined value + +=item * OBJECT + +A blessed reference. + +=item * BOOLEAN + +This is a special option, and is just a shortcut for C<UNDEF | SCALAR>. + +=item * HANDLE + +This option is also special, and is just a shortcut for C<GLOB | +GLOBREF>. However, it seems likely that most people interested in +either globs or glob references are likely to really be interested in +whether the parameter in question could be a valid file or directory +handle. + +=back + +To specify that a parameter must be of a given type when using named +parameters, do this: + + validate( + @_, { + foo => { type => SCALAR }, + bar => { type => HASHREF } + } + ); + +If a parameter can be of more than one type, just use the bitwise or +(C<|>) operator to combine them. + + validate( @_, { foo => { type => GLOB | GLOBREF } ); + +For positional parameters, this can be specified as follows: + + validate_pos( @_, { type => SCALAR | ARRAYREF }, { type => CODEREF } ); + +=head2 Interface Validation + +To specify that a parameter is expected to have a certain set of +methods, we can do the following: + + validate( + @_, { + foo => + # just has to be able to ->bar + { can => 'bar' } + } + ); + + ... or ... + + validate( + @_, { + foo => + # must be able to ->bar and ->print + { can => [qw( bar print )] } + } + ); + +=head2 Class Validation + +A word of warning. When constructing your external interfaces, it is +probably better to specify what methods you expect an object to +have rather than what class it should be of (or a child of). This +will make your API much more flexible. + +With that said, if you want to validate that an incoming parameter +belongs to a class (or child class) or classes, do: + + validate( + @_, + { foo => { isa => 'My::Frobnicator' } } + ); + + ... or ... + + validate( + @_, + # must be both, not either! + { foo => { isa => [qw( My::Frobnicator IO::Handle )] } } + ); + +=head2 Regex Validation + +If you want to specify that a given parameter must match a specific +regular expression, this can be done with "regex" spec key. For +example: + + validate( + @_, + { foo => { regex => qr/^\d+$/ } } + ); + +The value of the "regex" key may be either a string or a pre-compiled +regex created via C<qr>. + +If the value being checked against a regex is undefined, the regex is +explicitly checked against the empty string ('') instead, in order to +avoid "Use of uninitialized value" warnings. + +The C<Regexp::Common> module on CPAN is an excellent source of regular +expressions suitable for validating input. + +=head2 Callback Validation + +If none of the above are enough, it is possible to pass in one or more +callbacks to validate the parameter. The callback will be given the +B<value> of the parameter as its first argument. Its second argument +will be all the parameters, as a reference to either a hash or array. +Callbacks are specified as hash reference. The key is an id for the +callback (used in error messages) and the value is a subroutine +reference, such as: + + validate( + @_, + { + foo => { + callbacks => { + 'smaller than a breadbox' => sub { shift() < $breadbox }, + 'green or blue' => sub { + return 1 if $_[0] eq 'green' || $_[0] eq 'blue'; + die "$_[0] is not green or blue!"; + } + } + } + } + ); + + validate( + @_, { + foo => { + callbacks => { + 'bigger than baz' => sub { $_[0] > $_[1]->{baz} } + } + } + } + ); + +The callback should return a true value if the value is valid. If not, it can +return false or die. If you return false, a generic error message will be +thrown by C<Params::Validate>. + +If your callback dies instead you can provide a custom error message. If the +callback dies with a plain string, this string will be appended to an +exception message generated by C<Params::Validate>. If the callback dies with +a reference (blessed or not), then this will be rethrown as-is by +C<Params::Validate>. + +=head2 Untainting + +If you want values untainted, set the "untaint" key in a spec hashref +to a true value, like this: + + my %p = validate( + @_, { + foo => { type => SCALAR, untaint => 1 }, + bar => { type => ARRAYREF } + } + ); + +This will untaint the "foo" parameter if the parameters are valid. + +Note that untainting is only done if I<all parameters> are valid. +Also, only the return values are untainted, not the original values +passed into the validation function. + +Asking for untainting of a reference value will not do anything, as +C<Params::Validate> will only attempt to untaint the reference itself. + +=head2 Mandatory/Optional Revisited + +If you want to specify something such as type or interface, plus the +fact that a parameter can be optional, do this: + + validate( + @_, { + foo => { type => SCALAR }, + bar => { type => ARRAYREF, optional => 1 } + } + ); + +or this for positional parameters: + + validate_pos( + @_, + { type => SCALAR }, + { type => ARRAYREF, optional => 1 } + ); + +By default, parameters are assumed to be mandatory unless specified as +optional. + +=head2 Dependencies + +It also possible to specify that a given optional parameter depends on +the presence of one or more other optional parameters. + + validate( + @_, { + cc_number => { + type => SCALAR, + optional => 1, + depends => [ 'cc_expiration', 'cc_holder_name' ], + }, + cc_expiration => { type => SCALAR, optional => 1 }, + cc_holder_name => { type => SCALAR, optional => 1 }, + } + ); + +In this case, "cc_number", "cc_expiration", and "cc_holder_name" are +all optional. However, if "cc_number" is provided, then +"cc_expiration" and "cc_holder_name" must be provided as well. + +This allows you to group together sets of parameters that all must be +provided together. + +The C<validate_pos()> version of dependencies is slightly different, +in that you can only depend on one other parameter. Also, if for +example, the second parameter 2 depends on the fourth parameter, then +it implies a dependency on the third parameter as well. This is +because if the fourth parameter is required, then the user must also +provide a third parameter so that there can be four parameters in +total. + +C<Params::Validate> will die if you try to depend on a parameter not +declared as part of your parameter specification. + +=head2 Specifying defaults + +If the C<validate()> or C<validate_pos()> functions are called in a list +context, they will return a hash or containing the original parameters plus +defaults as indicated by the validation spec. + +If the function is not called in a list context, providing a default +in the validation spec still indicates that the parameter is optional. + +The hash or array returned from the function will always be a copy of +the original parameters, in order to leave C<@_> untouched for the +calling function. + +Simple examples of defaults would be: + + my %p = validate( @_, { foo => 1, bar => { default => 99 } } ); + + my @p = validate_pos( @_, 1, { default => 99 } ); + +In scalar context, a hash reference or array reference will be +returned, as appropriate. + +=head1 USAGE NOTES + +=head2 Validation failure + +By default, when validation fails C<Params::Validate> calls +C<Carp::confess()>. This can be overridden by setting the C<on_fail> +option, which is described in the L<"GLOBAL" OPTIONS|"GLOBAL" OPTIONS> +section. + +=head2 Method calls + +When using this module to validate the parameters passed to a method +call, you will probably want to remove the class/object from the +parameter list B<before> calling C<validate()> or C<validate_pos()>. +If your method expects named parameters, then this is necessary for +the C<validate()> function to actually work, otherwise C<@_> will not +be usable as a hash, because it will first have your object (or +class) B<followed> by a set of keys and values. + +Thus the idiomatic usage of C<validate()> in a method call will look +something like this: + + sub method { + my $self = shift; + + my %params = validate( + @_, { + foo => 1, + bar => { type => ARRAYREF }, + } + ); + } + +=head2 Speeding Up Validation + +In most cases, the validation spec will remain the same for each call to a +subroutine. In that case, you can speed up validation by defining the +validation spec just once, rather than on each call to the subroutine: + + my %spec = ( ... ); + sub foo { + my %params = validate( @_, \%spec ); + } + +You can also use the C<state> feature to do this: + + use feature 'state'; + + sub foo { + state $spec = { ... }; + my %params = validate( @_, $spec ); + } + +=head1 "GLOBAL" OPTIONS + +Because the API for the C<validate()> and C<validate_pos()> functions does not +make it possible to specify any options other than the validation spec, it is +possible to set some options as pseudo-'globals'. These allow you to specify +such things as whether or not the validation of named parameters should be +case sensitive, for one example. + +These options are called pseudo-'globals' because these settings are +B<only applied to calls originating from the package that set the +options>. + +In other words, if I am in package C<Foo> and I call +C<validation_options()>, those options are only in effect when I call +C<validate()> from package C<Foo>. + +While this is quite different from how most other modules operate, I +feel that this is necessary in able to make it possible for one +module/application to use Params::Validate while still using other +modules that also use Params::Validate, perhaps with different +options set. + +The downside to this is that if you are writing an app with a standard +calling style for all functions, and your app has ten modules, B<each +module must include a call to C<validation_options()>>. You could of +course write a module that all your modules use which uses various +trickery to do this when imported. + +=head2 Options + +=over 4 + +=item * normalize_keys => $callback + +This option is only relevant when dealing with named parameters. + +This callback will be used to transform the hash keys of both the +parameters and the parameter spec when C<validate()> or +C<validate_with()> are called. + +Any alterations made by this callback will be reflected in the +parameter hash that is returned by the validation function. For +example: + + sub foo { + return validate_with( + params => \@_, + spec => { foo => { type => SCALAR } }, + normalize_keys => + sub { my $k = shift; $k =~ s/^-//; return uc $k }, + ); + + } + + %p = foo( foo => 20 ); + + # $p{FOO} is now 20 + + %p = foo( -fOo => 50 ); + + # $p{FOO} is now 50 + +The callback must return a defined value. + +If a callback is given then the deprecated "ignore_case" and +"strip_leading" options are ignored. + +=item * allow_extra => $boolean + +If true, then the validation routine will allow extra parameters not +named in the validation specification. In the case of positional +parameters, this allows an unlimited number of maximum parameters +(though a minimum may still be set). Defaults to false. + +=item * on_fail => $callback + +If given, this callback will be called whenever a validation check +fails. It will be called with a single parameter, which will be a +string describing the failure. This is useful if you wish to have +this module throw exceptions as objects rather than as strings, for +example. + +This callback is expected to C<die()> internally. If it does not, the +validation will proceed onwards, with unpredictable results. + +The default is to simply use the Carp module's C<confess()> function. + +=item * stack_skip => $number + +This tells Params::Validate how many stack frames to skip when finding +a subroutine name to use in error messages. By default, it looks one +frame back, at the immediate caller to C<validate()> or +C<validate_pos()>. If this option is set, then the given number of +frames are skipped instead. + +=item * ignore_case => $boolean + +DEPRECATED + +This is only relevant when dealing with named parameters. If it is +true, then the validation code will ignore the case of parameter +names. Defaults to false. + +=item * strip_leading => $characters + +DEPRECATED + +This too is only relevant when dealing with named parameters. If this +is given then any parameters starting with these characters will be +considered equivalent to parameters without them entirely. For +example, if this is specified as '-', then C<-foo> and C<foo> would be +considered identical. + +=back + +=head1 PER-INVOCATION OPTIONS + +The C<validate_with()> function can be used to set the options listed +above on a per-invocation basis. For example: + + my %p = validate_with( + params => \@_, + spec => { + foo => { type => SCALAR }, + bar => { default => 10 } + }, + allow_extra => 1, + ); + +In addition to the options listed above, it is also possible to set +the option "called", which should be a string. This string will be +used in any error messages caused by a failure to meet the validation +spec. + +This subroutine will validate named parameters as a hash if the "spec" +parameter is a hash reference. If it is an array reference, the +parameters are assumed to be positional. + + my %p = validate_with( + params => \@_, + spec => { + foo => { type => SCALAR }, + bar => { default => 10 } + }, + allow_extra => 1, + called => 'The Quux::Baz class constructor', + ); + + my @p = validate_with( + params => \@_, + spec => [ + { type => SCALAR }, + { default => 10 } + ], + allow_extra => 1, + called => 'The Quux::Baz class constructor', + ); + +=head1 DISABLING VALIDATION + +If the environment variable C<PERL_NO_VALIDATION> is set to something +true, then validation is turned off. This may be useful if you only +want to use this module during development but don't want the speed +hit during production. + +The only error that will be caught will be when an odd number of +parameters are passed into a function/method that expects a hash. + +If you want to selectively turn validation on and off at runtime, you +can directly set the C<$Params::Validate::NO_VALIDATION> global +variable. It is B<strongly> recommended that you B<localize> any +changes to this variable, because other modules you are using may +expect validation to be on when they execute. For example: + + { + local $Params::Validate::NO_VALIDATION = 1; + + # no error + foo( bar => 2 ); + } + + # error + foo( bar => 2 ); + + sub foo { + my %p = validate( @_, { foo => 1 } ); + ...; + } + +But if you want to shoot yourself in the foot and just turn it off, go +ahead! + +=head1 TAINT MODE + +The XS implementation of this module has some problems Under taint mode with +version of Perl before 5.14. If validation I<fails>, then instead of getting +the expected error message you'll get a message like "Insecure dependency in +eval_sv". This can be worked around by either untainting the arguments +yourself, using the pure Perl implementation, or upgrading your Perl. + +=head1 LIMITATIONS + +Right now there is no way (short of a callback) to specify that +something must be of one of a list of classes, or that it must possess +one of a list of methods. If this is desired, it can be added in the +future. + +Ideally, there would be only one validation function. If someone +figures out how to do this, please let me know. + +=head1 SUPPORT + +Please submit bugs and patches to the CPAN RT system at +http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Params%3A%3AValidate or +via email at bug-params-validate@rt.cpan.org. + +Support questions can be sent to Dave at autarch@urth.org. + +=head1 DONATIONS + +If you'd like to thank me for the work I've done on this module, +please consider making a "donation" to me via PayPal. I spend a lot of +free time creating free software, and would appreciate any support +you'd care to offer. + +Please note that B<I am not suggesting that you must do this> in order +for me to continue working on this particular software. I will +continue to do so, inasmuch as I have in the past, for as long as it +interests me. + +Similarly, a donation made in this way will probably not make me work +on this software much more, unless I get so many donations that I can +consider working on free software full time, which seems unlikely at +best. + +To donate, log into PayPal and send money to autarch@urth.org or use +the button on this page: +L<http://www.urth.org/~autarch/fs-donation.html> + +=head1 AUTHORS + +=over 4 + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Ilya Martynov <ilya@martynov.org> + +=back + +=head1 CONTRIBUTORS + +=for stopwords Ivan Bessarabov J.R. Mash Noel Maddy Olivier Mengué Vincent Pit + +=over 4 + +=item * + +Ivan Bessarabov <ivan@bessarabov.ru> + +=item * + +J.R. Mash <jmash.code@gmail.com> + +=item * + +Noel Maddy <zhtwnpanta@gmail.com> + +=item * + +Olivier Mengué <dolmen@cpan.org> + +=item * + +Vincent Pit <perl@profvince.com> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is Copyright (c) 2001 - 2015 by Dave Rolsky and Ilya Martynov. + +This is free software, licensed under: + + The Artistic License 2.0 (GPL Compatible) + +=cut diff --git a/lib/Params/Validate/Constants.pm b/lib/Params/Validate/Constants.pm new file mode 100644 index 0000000..6204282 --- /dev/null +++ b/lib/Params/Validate/Constants.pm @@ -0,0 +1,39 @@ +package Params::Validate::Constants; + +use strict; +use warnings; + +our $VERSION = '1.20'; + +our @ISA = 'Exporter'; + +our @EXPORT = qw( + SCALAR + ARRAYREF + HASHREF + CODEREF + GLOB + GLOBREF + SCALARREF + HANDLE + BOOLEAN + UNDEF + OBJECT + UNKNOWN +); + +sub SCALAR () { 1 } +sub ARRAYREF () { 2 } +sub HASHREF () { 4 } +sub CODEREF () { 8 } +sub GLOB () { 16 } +sub GLOBREF () { 32 } +sub SCALARREF () { 64 } +sub UNKNOWN () { 128 } +sub UNDEF () { 256 } +sub OBJECT () { 512 } + +sub HANDLE () { 16 | 32 } +sub BOOLEAN () { 1 | 256 } + +1; diff --git a/lib/Params/Validate/PP.pm b/lib/Params/Validate/PP.pm new file mode 100644 index 0000000..e766475 --- /dev/null +++ b/lib/Params/Validate/PP.pm @@ -0,0 +1,735 @@ +package Params::Validate::PP; + +use strict; +use warnings; + +our $VERSION = '1.20'; + +use Params::Validate::Constants; +use Scalar::Util 1.10 (); + +our $options; + +# Various internals notes (for me and any future readers of this +# monstrosity): +# +# - A lot of the weirdness is _intentional_, because it optimizes for +# the _success_ case. It does not really matter how slow the code is +# after it enters a path that leads to reporting failure. But the +# "success" path should be as fast as possible. +# +# -- We only calculate $called as needed for this reason, even though it +# means copying code all over. +# +# - All the validation routines need to be careful never to alter the +# references that are passed. +# +# -- The code assumes that _most_ callers will not be using the +# skip_leading or ignore_case features. In order to not alter the +# references passed in, we copy them wholesale when normalizing them +# to make these features work. This is slower but lets us be faster +# when not using them. + +# Matt Sergeant came up with this prototype, which slickly takes the +# first array (which should be the caller's @_), and makes it a +# reference. Everything after is the parameters for validation. +sub validate_pos (\@@) { + return if $Params::Validate::NO_VALIDATION && !defined wantarray; + + my $p = shift; + + my @specs = @_; + + my @p = @$p; + if ($Params::Validate::NO_VALIDATION) { + + # if the spec is bigger that's where we can start adding + # defaults + for ( my $x = $#p + 1; $x <= $#specs; $x++ ) { + $p[$x] = $specs[$x]->{default} + if ref $specs[$x] && exists $specs[$x]->{default}; + } + + return wantarray ? @p : \@p; + } + + # I'm too lazy to pass these around all over the place. + local $options ||= _get_options( ( caller(0) )[0] ) + unless defined $options; + + my $min = 0; + + while (1) { + last + unless ( + ref $specs[$min] + ? !( exists $specs[$min]->{default} || $specs[$min]->{optional} ) + : $specs[$min] + ); + + $min++; + } + + my $max = scalar @specs; + + my $actual = scalar @p; + unless ( $actual >= $min + && ( $options->{allow_extra} || $actual <= $max ) ) { + my $minmax = ( + $options->{allow_extra} + ? "at least $min" + : ( $min != $max ? "$min - $max" : $max ) + ); + + my $val = $options->{allow_extra} ? $min : $max; + $minmax .= $val != 1 ? ' were' : ' was'; + + my $called = _get_called(); + + $options->{on_fail}->( "$actual parameter" + . ( $actual != 1 ? 's' : '' ) . " " + . ( $actual != 1 ? 'were' : 'was' ) + . " passed to $called but $minmax expected\n" ); + } + + my $bigger = $#p > $#specs ? $#p : $#specs; + foreach ( 0 .. $bigger ) { + my $spec = $specs[$_]; + + next unless ref $spec; + + if ( $_ <= $#p ) { + _validate_one_param( + $p[$_], \@p, $spec, + 'Parameter #' . ( $_ + 1 ) . ' (%s)' + ); + } + + $p[$_] = $spec->{default} if $_ > $#p && exists $spec->{default}; + } + + _validate_pos_depends( \@p, \@specs ); + + foreach ( + grep { + defined $p[$_] + && !ref $p[$_] + && ref $specs[$_] + && $specs[$_]{untaint} + } 0 .. $bigger + ) { + ( $p[$_] ) = $p[$_] =~ /(.+)/; + } + + return wantarray ? @p : \@p; +} + +sub _validate_pos_depends { + my ( $p, $specs ) = @_; + + for my $p_idx ( 0 .. $#$p ) { + my $spec = $specs->[$p_idx]; + + next + unless $spec + && UNIVERSAL::isa( $spec, 'HASH' ) + && exists $spec->{depends}; + + my $depends = $spec->{depends}; + + if ( ref $depends ) { + require Carp; + local $Carp::CarpLevel = 2; + Carp::croak( + "Arguments to 'depends' for validate_pos() must be a scalar"); + } + + my $p_size = scalar @$p; + if ( $p_size < $depends - 1 ) { + my $error + = ( "Parameter #" + . ( $p_idx + 1 ) + . " depends on parameter #" + . $depends + . ", which was not given" ); + + $options->{on_fail}->($error); + } + } + return 1; +} + +sub _validate_named_depends { + my ( $p, $specs ) = @_; + + foreach my $pname ( keys %$p ) { + my $spec = $specs->{$pname}; + + next + unless $spec + && UNIVERSAL::isa( $spec, 'HASH' ) + && $spec->{depends}; + + unless ( UNIVERSAL::isa( $spec->{depends}, 'ARRAY' ) + || !ref $spec->{depends} ) { + require Carp; + local $Carp::CarpLevel = 2; + Carp::croak( + "Arguments to 'depends' must be a scalar or arrayref"); + } + + foreach my $depends_name ( + ref $spec->{depends} + ? @{ $spec->{depends} } + : $spec->{depends} + ) { + unless ( exists $p->{$depends_name} ) { + my $error + = ( "Parameter '$pname' depends on parameter '" + . $depends_name + . "', which was not given" ); + + $options->{on_fail}->($error); + } + } + } +} + +sub validate (\@$) { + return if $Params::Validate::NO_VALIDATION && !defined wantarray; + + my $p = $_[0]; + + my $specs = $_[1]; + local $options = _get_options( ( caller(0) )[0] ) unless defined $options; + + if ( ref $p eq 'ARRAY' ) { + + # we were called as validate( @_, ... ) where @_ has a + # single element, a hash reference + if ( ref $p->[0] ) { + $p = { %{ $p->[0] } }; + } + elsif ( @$p % 2 ) { + my $called = _get_called(); + + $options->{on_fail} + ->( "Odd number of parameters in call to $called " + . "when named parameters were expected\n" ); + } + else { + $p = {@$p}; + } + } + + if ( $options->{normalize_keys} ) { + $specs = _normalize_callback( $specs, $options->{normalize_keys} ); + $p = _normalize_callback( $p, $options->{normalize_keys} ); + } + elsif ( $options->{ignore_case} || $options->{strip_leading} ) { + $specs = _normalize_named($specs); + $p = _normalize_named($p); + } + + if ($Params::Validate::NO_VALIDATION) { + return ( + wantarray + ? ( + + # this is a hash containing just the defaults + ( + map { $_ => $specs->{$_}->{default} } + grep { + ref $specs->{$_} + && exists $specs->{$_}->{default} + } + keys %$specs + ), + ( + ref $p eq 'ARRAY' + ? ( + ref $p->[0] + ? %{ $p->[0] } + : @$p + ) + : %$p + ) + ) + : do { + my $ref = ( + ref $p eq 'ARRAY' + ? ( + ref $p->[0] + ? $p->[0] + : {@$p} + ) + : $p + ); + + foreach ( + grep { + ref $specs->{$_} + && exists $specs->{$_}->{default} + } + keys %$specs + ) { + $ref->{$_} = $specs->{$_}->{default} + unless exists $ref->{$_}; + } + + return $ref; + } + ); + } + + _validate_named_depends( $p, $specs ); + + unless ( $options->{allow_extra} ) { + if ( my @unmentioned = grep { !exists $specs->{$_} } keys %$p ) { + my $called = _get_called(); + + $options->{on_fail}->( "The following parameter" + . ( @unmentioned > 1 ? 's were' : ' was' ) + . " passed in the call to $called but " + . ( @unmentioned > 1 ? 'were' : 'was' ) + . " not listed in the validation options: @unmentioned\n" + ); + } + } + + my @missing; + + # the iterator needs to be reset in case the same hashref is being + # passed to validate() on successive calls, because we may not go + # through all the hash's elements + keys %$specs; +OUTER: + while ( my ( $key, $spec ) = each %$specs ) { + if ( + !exists $p->{$key} + && ( + ref $spec + ? !( + do { + + # we want to short circuit the loop here if we + # can assign a default, because there's no need + # check anything else at all. + if ( exists $spec->{default} ) { + $p->{$key} = $spec->{default}; + next OUTER; + } + } + || do { + + # Similarly, an optional parameter that is + # missing needs no additional processing. + next OUTER if $spec->{optional}; + } + ) + : $spec + ) + ) { + push @missing, $key; + } + + # Can't validate a non hashref spec beyond the presence or + # absence of the parameter. + elsif ( ref $spec ) { + my $value = defined $p->{$key} ? qq|"$p->{$key}"| : 'undef'; + _validate_one_param( + $p->{$key}, $p, $spec, + qq{The '$key' parameter (%s)} + ); + } + } + + if (@missing) { + my $called = _get_called(); + + my $missing = join ', ', map {"'$_'"} @missing; + $options->{on_fail}->( "Mandatory parameter" + . ( @missing > 1 ? 's' : '' ) + . " $missing missing in call to $called\n" ); + } + + # do untainting after we know everything passed + foreach my $key ( + grep { + defined $p->{$_} + && !ref $p->{$_} + && ref $specs->{$_} + && $specs->{$_}{untaint} + } + keys %$p + ) { + ( $p->{$key} ) = $p->{$key} =~ /(.+)/; + } + + return wantarray ? %$p : $p; +} + +sub validate_with { + return if $Params::Validate::NO_VALIDATION && !defined wantarray; + + my %p = @_; + + local $options = _get_options( ( caller(0) )[0], %p ); + + unless ($Params::Validate::NO_VALIDATION) { + unless ( exists $options->{called} ) { + $options->{called} = ( caller( $options->{stack_skip} ) )[3]; + } + + } + + if ( UNIVERSAL::isa( $p{spec}, 'ARRAY' ) ) { + return validate_pos( @{ $p{params} }, @{ $p{spec} } ); + } + else { + + # intentionally ignore the prototype because this contains + # either an array or hash reference, and validate() will + # handle either one properly + return &validate( $p{params}, $p{spec} ); + } +} + +sub _normalize_callback { + my ( $p, $func ) = @_; + + my %new; + + foreach my $key ( keys %$p ) { + my $new_key = $func->($key); + + unless ( defined $new_key ) { + die + "The normalize_keys callback did not return a defined value when normalizing the key '$key'"; + } + + if ( exists $new{$new_key} ) { + die + "The normalize_keys callback returned a key that already exists, '$new_key', when normalizing the key '$key'"; + } + + $new{$new_key} = $p->{$key}; + } + + return \%new; +} + +sub _normalize_named { + + # intentional copy so we don't destroy original + my %h = ( ref $_[0] ) =~ /ARRAY/ ? @{ $_[0] } : %{ $_[0] }; + + if ( $options->{ignore_case} ) { + $h{ lc $_ } = delete $h{$_} for keys %h; + } + + if ( $options->{strip_leading} ) { + foreach my $key ( keys %h ) { + my $new; + ( $new = $key ) =~ s/^\Q$options->{strip_leading}\E//; + $h{$new} = delete $h{$key}; + } + } + + return \%h; +} + +my %Valid = map { $_ => 1 } + qw( callbacks can default depends isa optional regex type untaint ); + +sub _validate_one_param { + my ( $value, $params, $spec, $id ) = @_; + + # for my $key ( keys %{$spec} ) { + # unless ( $Valid{$key} ) { + # $options->{on_fail} + # ->(qq{"$key" is not an allowed validation spec key}); + # } + # } + + if ( exists $spec->{type} ) { + unless ( defined $spec->{type} + && Scalar::Util::looks_like_number( $spec->{type} ) + && $spec->{type} > 0 ) { + my $msg + = "$id has a type specification which is not a number. It is "; + if ( defined $spec->{type} ) { + $msg .= "a string - $spec->{type}"; + } + else { + $msg .= "undef"; + } + + $msg + .= ".\n Use the constants exported by Params::Validate to declare types."; + + $options->{on_fail}->( sprintf( $msg, _stringify($value) ) ); + } + + unless ( _get_type($value) & $spec->{type} ) { + my $type = _get_type($value); + + my @is = _typemask_to_strings($type); + my @allowed = _typemask_to_strings( $spec->{type} ); + my $article = $is[0] =~ /^[aeiou]/i ? 'an' : 'a'; + + my $called = _get_called(1); + + $options->{on_fail}->( + sprintf( + "$id to $called was $article '@is', which " + . "is not one of the allowed types: @allowed\n", + _stringify($value) + ) + ); + } + } + + # short-circuit for common case + return + unless ( $spec->{isa} + || $spec->{can} + || $spec->{callbacks} + || $spec->{regex} ); + + if ( exists $spec->{isa} ) { + foreach ( ref $spec->{isa} ? @{ $spec->{isa} } : $spec->{isa} ) { + unless ( + do { + local $@ = q{}; + eval { $value->isa($_) }; + } + ) { + my $is = ref $value ? ref $value : 'plain scalar'; + my $article1 = $_ =~ /^[aeiou]/i ? 'an' : 'a'; + my $article2 = $is =~ /^[aeiou]/i ? 'an' : 'a'; + + my $called = _get_called(1); + + $options->{on_fail}->( + sprintf( + "$id to $called was not $article1 '$_' " + . "(it is $article2 $is)\n", _stringify($value) + ) + ); + } + } + } + + if ( exists $spec->{can} ) { + foreach ( ref $spec->{can} ? @{ $spec->{can} } : $spec->{can} ) { + unless ( + do { + local $@ = q{}; + eval { $value->can($_) }; + } + ) { + my $called = _get_called(1); + + $options->{on_fail}->( + sprintf( + "$id to $called does not have the method: '$_'\n", + _stringify($value) + ) + ); + } + } + } + + if ( $spec->{callbacks} ) { + unless ( UNIVERSAL::isa( $spec->{callbacks}, 'HASH' ) ) { + my $called = _get_called(1); + + $options->{on_fail}->( + "'callbacks' validation parameter for $called must be a hash reference\n" + ); + } + + foreach ( keys %{ $spec->{callbacks} } ) { + unless ( UNIVERSAL::isa( $spec->{callbacks}{$_}, 'CODE' ) ) { + my $called = _get_called(1); + + $options->{on_fail}->( + "callback '$_' for $called is not a subroutine reference\n" + ); + } + + my $ok; + my $e = do { + local $@ = q{}; + local $SIG{__DIE__}; + $ok = eval { $spec->{callbacks}{$_}->( $value, $params ) }; + $@; + }; + + if ( !$ok ) { + my $called = _get_called(1); + + if ( ref $e ) { + $options->{on_fail}->($e); + } + else { + my $msg = "$id to $called did not pass the '$_' callback"; + $msg .= ": $e" if length $e; + $msg .= "\n"; + $options->{on_fail}->( sprintf( $msg, _stringify($value) ) ); + } + } + } + } + + if ( exists $spec->{regex} ) { + unless ( ( defined $value ? $value : '' ) =~ /$spec->{regex}/ ) { + my $called = _get_called(1); + + $options->{on_fail}->( + sprintf( + "$id to $called did not pass regex check\n", + _stringify($value) + ) + ); + } + } +} + +{ + # if it UNIVERSAL::isa the string on the left then its the type on + # the right + my %isas = ( + 'ARRAY' => ARRAYREF, + 'HASH' => HASHREF, + 'CODE' => CODEREF, + 'GLOB' => GLOBREF, + 'SCALAR' => SCALARREF, + 'REGEXP' => SCALARREF, + ); + my %simple_refs = map { $_ => 1 } keys %isas; + + sub _get_type { + return UNDEF unless defined $_[0]; + + my $ref = ref $_[0]; + unless ($ref) { + + # catches things like: my $fh = do { local *FH; }; + return GLOB if UNIVERSAL::isa( \$_[0], 'GLOB' ); + return SCALAR; + } + + return $isas{$ref} if $simple_refs{$ref}; + + foreach ( keys %isas ) { + return $isas{$_} | OBJECT if UNIVERSAL::isa( $_[0], $_ ); + } + + # I really hope this never happens. + return UNKNOWN; + } +} + +{ + my %type_to_string = ( + SCALAR() => 'scalar', + ARRAYREF() => 'arrayref', + HASHREF() => 'hashref', + CODEREF() => 'coderef', + GLOB() => 'glob', + GLOBREF() => 'globref', + SCALARREF() => 'scalarref', + UNDEF() => 'undef', + OBJECT() => 'object', + UNKNOWN() => 'unknown', + ); + + sub _typemask_to_strings { + my $mask = shift; + + my @types; + foreach ( + SCALAR, ARRAYREF, HASHREF, CODEREF, GLOB, GLOBREF, + SCALARREF, UNDEF, OBJECT, UNKNOWN + ) { + push @types, $type_to_string{$_} if $mask & $_; + } + return @types ? @types : ('unknown'); + } +} + +{ + my %defaults = ( + ignore_case => 0, + strip_leading => 0, + allow_extra => 0, + on_fail => sub { + require Carp; + Carp::confess( $_[0] ); + }, + stack_skip => 1, + normalize_keys => undef, + ); + + *set_options = \&validation_options; + + sub validation_options { + my %opts = @_; + + my $caller = caller; + + foreach ( keys %defaults ) { + $opts{$_} = $defaults{$_} unless exists $opts{$_}; + } + + $Params::Validate::OPTIONS{$caller} = \%opts; + } + + sub _get_options { + my $caller = shift; + + if (@_) { + + return ( + $Params::Validate::OPTIONS{$caller} + ? { + %{ $Params::Validate::OPTIONS{$caller} }, + @_ + } + : { %defaults, @_ } + ); + } + else { + return ( + exists $Params::Validate::OPTIONS{$caller} + ? $Params::Validate::OPTIONS{$caller} + : \%defaults + ); + } + } +} + +sub _get_called { + my $extra_skip = $_[0] || 0; + + # always add one more for this sub + $extra_skip++; + + my $called = ( + exists $options->{called} + ? $options->{called} + : ( caller( $options->{stack_skip} + $extra_skip ) )[3] + ); + + $called = 'N/A' unless defined $called; + + return $called; +} + +sub _stringify { + return defined $_[0] ? qq{"$_[0]"} : 'undef'; +} + +1; diff --git a/lib/Params/Validate/XS.pm b/lib/Params/Validate/XS.pm new file mode 100644 index 0000000..256131d --- /dev/null +++ b/lib/Params/Validate/XS.pm @@ -0,0 +1,51 @@ +package Params::Validate::XS; + +use strict; +use warnings; + +our $VERSION = '1.20'; + +use Carp; + +my $default_fail = sub { + Carp::confess( $_[0] ); +}; + +{ + my %defaults = ( + ignore_case => 0, + strip_leading => 0, + allow_extra => 0, + on_fail => $default_fail, + stack_skip => 1, + normalize_keys => undef, + ); + + *set_options = \&validation_options; + + sub validation_options { + my %opts = @_; + + my $caller = caller; + + foreach ( keys %defaults ) { + $opts{$_} = $defaults{$_} unless exists $opts{$_}; + } + + $Params::Validate::OPTIONS{$caller} = \%opts; + } + + use XSLoader; + XSLoader::load( + __PACKAGE__, + exists $Params::Validate::XS::{VERSION} + ? ${ $Params::Validate::XS::{VERSION} } + : (), + ); +} + +sub _check_regex_from_xs { + return ( defined $_[0] ? $_[0] : '' ) =~ /$_[1]/ ? 1 : 0; +} + +1; diff --git a/lib/Params/Validate/XS.xs b/lib/Params/Validate/XS.xs new file mode 100644 index 0000000..109145a --- /dev/null +++ b/lib/Params/Validate/XS.xs @@ -0,0 +1,1811 @@ +/* Copyright (c) 2000-2012 Dave Rolsky and Ilya Martynov */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include "ppport.h" + +#if (defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L)) +#define INLINE inline +#else +#define INLINE +#endif + +/* type constants */ +#define SCALAR 1 +#define ARRAYREF 2 +#define HASHREF 4 +#define CODEREF 8 +#define GLOB 16 +#define GLOBREF 32 +#define SCALARREF 64 +#define UNKNOWN 128 +#define UNDEF 256 +#define OBJECT 512 + +#define HANDLE (GLOB | GLOBREF) +#define BOOLEAN (SCALAR | UNDEF) + +/* return data macros */ +#define RETURN_ARRAY(ret) \ + STMT_START \ + { \ + I32 i; \ + switch(GIMME_V) \ + { \ + case G_VOID: \ + return; \ + case G_ARRAY: \ + EXTEND(SP, av_len(ret) + 1); \ + for(i = 0; i <= av_len(ret); i++) \ + { \ + PUSHs(*av_fetch(ret, i, 1)); \ + } \ + break; \ + case G_SCALAR: \ + XPUSHs(sv_2mortal(newRV_inc((SV*) ret))); \ + break; \ + } \ + } STMT_END \ + +#define RETURN_HASH(ret) \ + STMT_START \ + { \ + HE* he; \ + I32 keys; \ + switch(GIMME_V) \ + { \ + case G_VOID: \ + return; \ + case G_ARRAY: \ + keys = hv_iterinit(ret); \ + EXTEND(SP, keys * 2); \ + while ((he = hv_iternext(ret))) \ + { \ + PUSHs(HeSVKEY_force(he)); \ + PUSHs(HeVAL(he)); \ + } \ + break; \ + case G_SCALAR: \ + XPUSHs(sv_2mortal(newRV_inc((SV*) ret))); \ + break; \ + } \ + } STMT_END + + +static SV *module; +void peek(SV *thing) +{ + if (NULL == module) { + module = newSVpv("Devel::Peek", 0); + load_module(PERL_LOADMOD_NOIMPORT, module, NULL); + } + + { + dSP; + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(thing); + PUTBACK; + + (void)call_pv("Devel::Peek::Dump", G_VOID); + + SPAGAIN; + + PUTBACK; + FREETMPS; + LEAVE; + } +} + +INLINE static bool +no_validation() { + SV* no_v; + + no_v = get_sv("Params::Validate::NO_VALIDATION", 0); + if (! no_v) + croak("Cannot retrieve $Params::Validate::NO_VALIDATION\n"); + + return SvTRUE(no_v); +} + +/* return type string that corresponds to typemask */ +INLINE static SV* +typemask_to_string(IV mask) { + SV* buffer; + IV empty = 1; + + buffer = sv_2mortal(newSVpv("", 0)); + + if (mask & SCALAR) { + sv_catpv(buffer, "scalar"); + empty = 0; + } + if (mask & ARRAYREF) { + sv_catpv(buffer, empty ? "arrayref" : " arrayref"); + empty = 0; + } + if (mask & HASHREF) { + sv_catpv(buffer, empty ? "hashref" : " hashref"); + empty = 0; + } + if (mask & CODEREF) { + sv_catpv(buffer, empty ? "coderef" : " coderef"); + empty = 0; + } + if (mask & GLOB) { + sv_catpv(buffer, empty ? "glob" : " glob"); + empty = 0; + } + if (mask & GLOBREF) { + sv_catpv(buffer, empty ? "globref" : " globref"); + empty = 0; + } + if (mask & SCALARREF) { + sv_catpv(buffer, empty ? "scalarref" : " scalarref"); + empty = 0; + } + if (mask & UNDEF) { + sv_catpv(buffer, empty ? "undef" : " undef"); + empty = 0; + } + if (mask & OBJECT) { + sv_catpv(buffer, empty ? "object" : " object"); + empty = 0; + } + if (mask & UNKNOWN) { + sv_catpv(buffer, empty ? "unknown" : " unknown"); + empty = 0; + } + + return buffer; +} + +/* compute numberic datatype for variable */ +INLINE static IV +get_type(SV* sv) { + IV type = 0; + + if (SvTYPE(sv) == SVt_PVGV) { + return GLOB; + } + if (!SvOK(sv)) { + return UNDEF; + } + if (!SvROK(sv)) { + return SCALAR; + } + + switch (SvTYPE(SvRV(sv))) { + case SVt_NULL: + case SVt_IV: + case SVt_NV: + case SVt_PV: + #if PERL_VERSION <= 10 + case SVt_RV: + #endif + case SVt_PVMG: + case SVt_PVIV: + case SVt_PVNV: + #if PERL_VERSION <= 8 + case SVt_PVBM: + #elif PERL_VERSION >= 11 + case SVt_REGEXP: + #endif + type = SCALARREF; + break; + case SVt_PVAV: + type = ARRAYREF; + break; + case SVt_PVHV: + type = HASHREF; + break; + case SVt_PVCV: + type = CODEREF; + break; + case SVt_PVGV: + type = GLOBREF; + break; + /* Perl 5.10 has a bunch of new types that I don't think will ever + actually show up here (I hope), but not handling them makes the + C compiler cranky. */ + default: + type = UNKNOWN; + break; + } + + if (type) { + if (sv_isobject(sv)) return type | OBJECT; + return type; + } + + /* Getting here should not be possible */ + return UNKNOWN; +} + +/* get an article for given string */ +INLINE static const char* +article(SV* string) { + STRLEN len; + char* rawstr; + + rawstr = SvPV(string, len); + if (len) { + switch(rawstr[0]) { + case 'a': + case 'e': + case 'i': + case 'o': + case 'u': + return "an"; + } + } + + return "a"; +} + +char * +string_representation(SV* value) { + if(SvOK(value)) { + return (void *)form("\"%s\"", SvPV_nolen(value)); + } + else { + return (void *)"undef"; + } +} + +/* raises exception either using user-defined callback or using + built-in method */ +static void +validation_failure(SV* message, HV* options) { + SV** temp; + SV* on_fail; + + if ((temp = hv_fetch(options, "on_fail", 7, 0))) { + SvGETMAGIC(*temp); + on_fail = *temp; + } + else { + on_fail = NULL; + } + + { + dSP; + ENTER; + SAVETMPS; + PUSHMARK(SP); + mXPUSHs(message); + PUTBACK; + + /* use user defined callback if available */ + if (on_fail) { + call_sv(on_fail, G_DISCARD); + } + else { + /* by default resort to Carp::confess for error reporting */ + call_pv("Carp::confess", G_DISCARD); + } + + /* We shouldn't get here if the thing we just called dies, but it + doesn't hurt to be careful. */ + SPAGAIN; + PUTBACK; + FREETMPS; + LEAVE; + } + + return; +} + +/* get called subroutine fully qualified name */ +static SV* +get_caller(HV* options) { + SV** temp; + + if ((temp = hv_fetch(options, "called", 6, 0))) { + SvGETMAGIC(*temp); + SvREFCNT_inc(*temp); + return *temp; + } + else { + IV frame; + SV *caller; +#if PERL_VERSION >= 14 + const PERL_CONTEXT *cx; + GV *cvgv; +# else + SV *buffer; +#endif + + if ((temp = hv_fetch(options, "stack_skip", 10, 0))) { + SvGETMAGIC(*temp); + frame = SvIV(*temp); + } + else { + frame = 1; + } + +#if PERL_VERSION >= 14 + if (frame > 0) { + frame--; + } + + cx = caller_cx(frame, NULL); + + if (cx) { + switch (CxTYPE(cx)) { + case CXt_EVAL: + caller = newSVpv("\"eval\"", 6); + break; + case CXt_SUB: + cvgv = CvGV(cx->blk_sub.cv); + caller = newSV(0); + if (cvgv && isGV(cvgv)) { + gv_efullname4(caller, cvgv, NULL, 1); + } + break; + default: + caller = newSVpv("(unknown)", 9); + break; + } + } + else { + caller = newSVpv("(unknown)", 9); + } +#else + buffer = sv_2mortal(newSVpvf("(caller(%d))[3]", (int) frame)); + + caller = eval_pv(SvPV_nolen(buffer), 1); + if (SvTYPE(caller) == SVt_NULL) { + sv_setpv(caller, "(unknown"); + } + + /* This will be decremented by the code that asked for this value, but + we need to do this here because the return value of caller() is + mortal and has a refcnt of 1. */ + SvREFCNT_inc(caller); +#endif + + return caller; + } +} + +/* $value->isa alike validation */ +static IV +validate_isa(SV* value, SV* package, char* id, HV* options) { + IV ok = 1; + + if (! value) { + return 0; + } + + SvGETMAGIC(value); + if (SvOK(value) && (sv_isobject(value) || (SvPOK(value) && ! looks_like_number(value)))) { + dSP; + + SV* ret; + IV count; + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + EXTEND(SP, 2); + PUSHs(value); + PUSHs(package); + PUTBACK; + + count = call_method("isa", G_SCALAR); + + if (! count) + croak("Calling isa did not return a value"); + + SPAGAIN; + + ret = POPs; + SvGETMAGIC(ret); + + ok = SvTRUE(ret); + + PUTBACK; + FREETMPS; + LEAVE; + } + else { + ok = 0; + } + + if (! ok) { + SV *caller = get_caller(options); + SV* buffer = newSVpvf(id, string_representation(value)); + sv_catpv(buffer, " to "); + sv_catsv(buffer, caller); + SvREFCNT_dec(caller); + sv_catpv(buffer, " was not "); + sv_catpv(buffer, article(package)); + sv_catpv(buffer, " '"); + sv_catsv(buffer, package); + sv_catpv(buffer, "' (it is "); + if ( SvOK(value) ) { + sv_catpv(buffer, article(value)); + sv_catpv(buffer, " "); + sv_catsv(buffer, value); + } + else { + sv_catpv(buffer, "undef"); + } + sv_catpv(buffer, ")\n"); + validation_failure(buffer, options); + } + + return 1; +} + +static IV +validate_can(SV* value, SV* method, char* id, HV* options) { + IV ok = 1; + + if (! value) { + return 0; + } + + SvGETMAGIC(value); + if (SvOK(value) && (sv_isobject(value) || (SvPOK(value) && ! looks_like_number(value)))) { + dSP; + + SV* ret; + IV count; + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + EXTEND(SP, 2); + PUSHs(value); + PUSHs(method); + PUTBACK; + + count = call_method("can", G_SCALAR); + + if (! count) + croak("Calling can did not return a value"); + + SPAGAIN; + + ret = POPs; + SvGETMAGIC(ret); + + ok = SvTRUE(ret); + + PUTBACK; + FREETMPS; + LEAVE; + } + else { + ok = 0; + } + + if (! ok) { + SV* buffer = newSVpvf(id, string_representation(value)); + SV *caller = get_caller(options); + sv_catpv(buffer, " to "); + sv_catsv(buffer, caller); + SvREFCNT_dec(caller); + sv_catpv(buffer, " does not have the method: '"); + sv_catsv(buffer, method); + sv_catpv(buffer, "'\n"); + validation_failure(buffer, options); + } + + return 1; +} + +/* validates specific parameter using supplied parameter specification */ +static IV +validate_one_param(SV* value, SV* params, HV* spec, char* id, HV* options, IV* untaint) { + SV** temp; + IV i; + + /* + HE* he; + hv_iterinit(spec); + + while (he = hv_iternext(spec)) { + STRLEN len; + char* key = HePV(he, len); + int ok = 0; + int j; + for ( j = 0; j < VALID_KEY_COUNT; j++ ) { + if ( strcmp( key, valid_keys[j] ) == 0) { + ok = 1; + break; + } + } + + if ( ! ok ) { + SV* buffer = sv_2mortal(newSVpv("\"",0)); + sv_catpv( buffer, key ); + sv_catpv( buffer, "\" is not an allowed validation spec key\n"); + validation_failure(buffer, options); + } + } + */ + + /* check type */ + if ((temp = hv_fetch(spec, "type", 4, 0))) { + IV type; + + if ( ! ( SvOK(*temp) + && looks_like_number(*temp) + && SvIV(*temp) > 0 ) ) { + + SV* buffer = newSVpvf(id, string_representation(value)); + sv_catpv( buffer, " has a type specification which is not a number. It is "); + if ( SvOK(*temp) ) { + sv_catpv( buffer, "a string - " ); + sv_catsv( buffer, *temp ); + } + else { + sv_catpv( buffer, "undef"); + } + sv_catpv( buffer, ".\n Use the constants exported by Params::Validate to declare types." ); + + validation_failure(buffer, options); + } + + SvGETMAGIC(*temp); + type = get_type(value); + if (! (type & SvIV(*temp))) { + SV* buffer = newSVpvf(id, string_representation(value)); + SV *caller = get_caller(options); + SV* is; + SV* allowed; + + sv_catpv(buffer, " to "); + sv_catsv(buffer, caller); + SvREFCNT_dec(caller); + sv_catpv(buffer, " was "); + is = typemask_to_string(type); + allowed = typemask_to_string(SvIV(*temp)); + sv_catpv(buffer, article(is)); + sv_catpv(buffer, " '"); + sv_catsv(buffer, is); + sv_catpv(buffer, "', which is not one of the allowed types: "); + sv_catsv(buffer, allowed); + sv_catpv(buffer, "\n"); + + validation_failure(buffer, options); + } + } + + /* check isa */ + if ((temp = hv_fetch(spec, "isa", 3, 0))) { + SvGETMAGIC(*temp); + + if (SvROK(*temp) && SvTYPE(SvRV(*temp)) == SVt_PVAV) { + AV* array = (AV*) SvRV(*temp); + + for(i = 0; i <= av_len(array); i++) { + SV* package; + + package = *av_fetch(array, i, 1); + if (! package) { + return 0; + } + + SvGETMAGIC(package); + if (! validate_isa(value, package, id, options)) { + return 0; + } + } + } + else { + if (! validate_isa(value, *temp, id, options)) { + return 0; + } + } + } + + /* check can */ + if ((temp = hv_fetch(spec, "can", 3, 0))) { + SvGETMAGIC(*temp); + if (SvROK(*temp) && SvTYPE(SvRV(*temp)) == SVt_PVAV) { + AV* array = (AV*) SvRV(*temp); + + for (i = 0; i <= av_len(array); i++) { + SV* method; + + method = *av_fetch(array, i, 1); + if (! method) { + return 0; + } + + SvGETMAGIC(method); + + if (! validate_can(value, method, id, options)) { + return 0; + } + } + } + else { + if (! validate_can(value, *temp, id, options)) { + return 0; + } + } + } + + /* let callbacks to do their tests */ + if ((temp = hv_fetch(spec, "callbacks", 9, 0))) { + HE* he; + + SvGETMAGIC(*temp); + if (!(SvROK(*temp) && SvTYPE(SvRV(*temp)) == SVt_PVHV)) { + SV* buffer = newSVpv("'callbacks' validation parameter for '", 0); + SV *caller = get_caller(options); + + sv_catsv(buffer, caller); + SvREFCNT_dec(caller); + sv_catpv(buffer, " must be a hash reference\n"); + validation_failure(buffer, options); + } + + hv_iterinit((HV*) SvRV(*temp)); + while ((he = hv_iternext((HV*) SvRV(*temp)))) { + SV* ret; + IV ok; + IV count; + SV *err; + + if (!(SvROK(HeVAL(he)) && SvTYPE(SvRV(HeVAL(he))) == SVt_PVCV)) { + SV* buffer = newSVpv("callback '", 0); + SV *caller = get_caller(options); + + sv_catsv(buffer, HeSVKEY_force(he)); + sv_catpv(buffer, "' for "); + sv_catsv(buffer, caller); + SvREFCNT_dec(caller); + sv_catpv(buffer, " is not a subroutine reference\n"); + validation_failure(buffer, options); + } + + { + dSP; + ENTER; + SAVETMPS; + + PUSHMARK(SP); + EXTEND(SP, 2); + PUSHs(value); + mPUSHs(newRV_inc(params)); + PUTBACK; + + /* local $@ = q{}; */ + save_scalar(PL_errgv); + sv_setpv(ERRSV, ""); + + count = call_sv(SvRV(HeVAL(he)), G_EVAL|G_SCALAR); + + SPAGAIN; + + if (!count) { + croak("Validation callback did not return anything"); + } + + ret = POPs; + SvGETMAGIC(ret); + ok = SvTRUE(ret); + + err = newSV(0); + SvSetSV_nosteal(err, ERRSV); + + PUTBACK; + FREETMPS; + LEAVE; + + if (! ok) { + if (SvROK(err)) { + validation_failure(err, options); + } + else { + SV* buffer = newSVpvf(id, string_representation(value)); + SV *caller = get_caller(options); + + sv_catpv(buffer, " to "); + sv_catsv(buffer, caller); + SvREFCNT_dec(caller); + sv_catpv(buffer, " did not pass the '"); + sv_catsv(buffer, HeSVKEY_force(he)); + sv_catpv(buffer, "' callback"); + if (SvLEN(err) > 0) { + sv_catpv(buffer, ": "); + sv_catsv(buffer, err); + } + sv_catpv(buffer, "\n"); + validation_failure(buffer, options); + } + } + else { + SvREFCNT_dec(err); + } + } + } + } + + if ((temp = hv_fetch(spec, "regex", 5, 0))) { + dSP; + + IV has_regex = 0; + IV ok; + + SvGETMAGIC(*temp); + if (SvPOK(*temp)) { + has_regex = 1; + } + else if (SvROK(*temp)) { + SV* svp; + + svp = (SV*)SvRV(*temp); + + #if PERL_VERSION <= 10 + if (SvMAGICAL(svp) && mg_find(svp, PERL_MAGIC_qr)) { + has_regex = 1; + } + #else + if (SvTYPE(svp) == SVt_REGEXP) { + has_regex = 1; + } + #endif + } + + if (!has_regex) { + SV* buffer = newSVpv("'regex' validation parameter for '", 0); + SV *caller = get_caller(options); + + sv_catsv(buffer, caller); + SvREFCNT_dec(caller); + sv_catpv(buffer, " must be a string or qr// regex\n"); + validation_failure(buffer, options); + } + + PUSHMARK(SP); + EXTEND(SP, 2); + PUSHs(value); + PUSHs(*temp); + PUTBACK; + call_pv("Params::Validate::XS::_check_regex_from_xs", G_SCALAR); + SPAGAIN; + ok = POPi; + PUTBACK; + + if (!ok) { + SV* buffer = newSVpvf(id, string_representation(value)); + SV *caller = get_caller(options); + + sv_catpv(buffer, " to "); + sv_catsv(buffer, caller); + SvREFCNT_dec(caller); + sv_catpv(buffer, " did not pass regex check\n"); + validation_failure(buffer, options); + } + } + + if ((temp = hv_fetch(spec, "untaint", 7, 0))) { + if (SvTRUE(*temp)) { + *untaint = 1; + } + } + + return 1; +} + +/* merges one hash into another (not deep copy) */ +static void +merge_hashes(HV* in, HV* out) { + HE* he; + + hv_iterinit(in); + while ((he = hv_iternext(in))) { + if (!hv_store_ent(out, HeSVKEY_force(he), + SvREFCNT_inc(HeVAL(he)), HeHASH(he))) { + SvREFCNT_dec(HeVAL(he)); + croak("Cannot add new key to hash"); + } + } +} + +/* convert array to hash */ +static IV +convert_array2hash(AV* in, HV* options, HV* out) { + IV i; + I32 len; + + len = av_len(in); + if (len > -1 && len % 2 != 1) { + SV* buffer = newSVpv("Odd number of parameters in call to ", 0); + SV *caller = get_caller(options); + + sv_catsv(buffer, caller); + SvREFCNT_dec(caller); + sv_catpv(buffer, " when named parameters were expected\n"); + + validation_failure(buffer, options); + } + + for (i = 0; i <= av_len(in); i += 2) { + SV* key; + SV* value; + + key = *av_fetch(in, i, 1); + if (! key) { + continue; + } + + SvGETMAGIC(key); + + /* We need to make a copy because if the array was @_, then the + values in the array are marked as readonly, which causes + problems when the hash being made gets returned to the + caller. */ + value = sv_2mortal( newSVsv( *av_fetch(in, i + 1, 1) ) ); + + if (value) { + SvGETMAGIC(value); + } + + if (! hv_store_ent(out, key, SvREFCNT_inc(value), 0)) { + SvREFCNT_dec(value); + croak("Cannot add new key to hash"); + } + } + + return 1; +} + +/* get current Params::Validate options */ +static HV* +get_options(HV* options) { + HV* OPTIONS; + HV* ret; + HE *he; + HV *stash; + SV* pkg; + SV *pkg_options; + + ret = (HV*) sv_2mortal((SV*) newHV()); + + /* get package specific options */ + stash = CopSTASH(PL_curcop); + pkg = sv_2mortal(newSVpv(HvNAME(stash), 0)); + + OPTIONS = get_hv("Params::Validate::OPTIONS", 1); + if ((he = hv_fetch_ent(OPTIONS, pkg, 0, 0))) { + pkg_options = HeVAL(he); + SvGETMAGIC(pkg_options); + if (SvROK(pkg_options) && SvTYPE(SvRV(pkg_options)) == SVt_PVHV) { + if (options) { + merge_hashes((HV*) SvRV(pkg_options), ret); + } + else { + return (HV*) SvRV(pkg_options); + } + } + } + if (options) { + merge_hashes(options, ret); + } + + return ret; +} + +static SV* +normalize_one_key(SV* key, SV* normalize_func, SV* strip_leading, IV ignore_case) { + SV* copy; + STRLEN len_sl; + STRLEN len; + char *rawstr_sl; + char *rawstr; + + copy = sv_2mortal(newSVsv(key)); + + /* if normalize_func is provided, ignore the other options */ + if (normalize_func) { + dSP; + + SV* normalized; + + PUSHMARK(SP); + XPUSHs(copy); + PUTBACK; + if (! call_sv(SvRV(normalize_func), G_SCALAR)) { + croak("The normalize_keys callback did not return anything"); + } + SPAGAIN; + normalized = POPs; + PUTBACK; + + if (! SvOK(normalized)) { + croak("The normalize_keys callback did not return a defined value when normalizing the key '%s'", SvPV_nolen(copy)); + } + + return normalized; + } + else if (ignore_case || strip_leading) { + if (ignore_case) { + STRLEN i; + + rawstr = SvPV(copy, len); + for (i = 0; i < len; i++) { + /* should this account for UTF8 strings? */ + *(rawstr + i) = toLOWER(*(rawstr + i)); + } + } + + if (strip_leading) { + rawstr_sl = SvPV(strip_leading, len_sl); + rawstr = SvPV(copy, len); + + if (len > len_sl && strnEQ(rawstr_sl, rawstr, len_sl)) { + copy = sv_2mortal(newSVpvn(rawstr + len_sl, len - len_sl)); + } + } + } + + return copy; +} + +static HV* +normalize_hash_keys(HV* p, SV* normalize_func, SV* strip_leading, IV ignore_case) { + SV* normalized; + HE* he; + HV* norm_p; + + if (!normalize_func && !ignore_case && !strip_leading) { + return p; + } + + norm_p = (HV*) sv_2mortal((SV*) newHV()); + hv_iterinit(p); + while ((he = hv_iternext(p))) { + normalized = + normalize_one_key(HeSVKEY_force(he), normalize_func, strip_leading, ignore_case); + + if (hv_fetch_ent(norm_p, normalized, 0, 0)) { + croak("The normalize_keys callback returned a key that already exists, '%s', when normalizing the key '%s'", + SvPV_nolen(normalized), SvPV_nolen(HeSVKEY_force(he))); + } + + if (! hv_store_ent(norm_p, normalized, SvREFCNT_inc(HeVAL(he)), 0)) { + SvREFCNT_dec(HeVAL(he)); + croak("Cannot add new key to hash"); + } + } + return norm_p; +} + +static IV +validate_pos_depends(AV* p, AV* specs, HV* options) { + IV p_idx; + SV** depends; + SV** p_spec; + + for (p_idx = 0; p_idx <= av_len(p); p_idx++) { + p_spec = av_fetch(specs, p_idx, 0); + + if (p_spec != NULL && SvROK(*p_spec) && + SvTYPE(SvRV(*p_spec)) == SVt_PVHV) { + + depends = hv_fetch((HV*) SvRV(*p_spec), "depends", 7, 0); + + if (! depends) { + return 1; + } + + if (SvROK(*depends)) { + croak("Arguments to 'depends' for validate_pos() must be a scalar"); + } + + if (av_len(p) < SvIV(*depends) -1) { + SV *buffer = + newSVpvf("Parameter #%d depends on parameter #%d, which was not given", + (int) p_idx + 1, + (int) SvIV(*depends)); + + validation_failure(buffer, options); + } + } + } + + return 1; +} + +static IV +validate_named_depends(HV* p, HV* specs, HV* options) { + HE* he; + HE* he1; + SV* buffer; + SV** depends_value; + AV* depends_list; + SV* depend_name; + SV* temp; + I32 d_idx; + + /* the basic idea here is to iterate through the parameters + * (which we assumed to have already gone through validation + * via validate_one_param()), and the check to see if that + * parameter contains a "depends" spec. If it does, we'll + * check if that parameter specified by depends exists in p + */ + hv_iterinit(p); + while ((he = hv_iternext(p))) { + he1 = hv_fetch_ent(specs, HeSVKEY_force(he), 0, HeHASH(he)); + + if (he1 && SvROK(HeVAL(he1)) && + SvTYPE(SvRV(HeVAL(he1))) == SVt_PVHV) { + + if (hv_exists((HV*) SvRV(HeVAL(he1)), "depends", 7)) { + + depends_value = hv_fetch((HV*) SvRV(HeVAL(he1)), "depends", 7, 0); + + if (! depends_value) { + return 1; + } + + if (! SvROK(*depends_value)) { + depends_list = (AV*) sv_2mortal((SV*) newAV()); + temp = sv_2mortal(newSVsv(*depends_value)); + av_push(depends_list,SvREFCNT_inc(temp)); + } + else if (SvTYPE(SvRV(*depends_value)) == SVt_PVAV) { + depends_list = (AV*) SvRV(*depends_value); + } + else { + croak("Arguments to 'depends' must be a scalar or arrayref"); + } + + for (d_idx =0; d_idx <= av_len(depends_list); d_idx++) { + + depend_name = *av_fetch(depends_list, d_idx, 0); + + /* first check if the parameter to which this + * depends on was given to us + */ + if (!hv_exists(p, SvPV_nolen(depend_name), + SvCUR(depend_name))) { + /* oh-oh, the parameter that this parameter + * depends on is not available. Let's first check + * if this is even valid in the spec (i.e., the + * spec actually contains a spec for such parameter) + */ + if (!hv_exists(specs, SvPV_nolen(depend_name), + SvCUR(depend_name))) { + + buffer = + sv_2mortal(newSVpv("Following parameter specified in depends for '", 0)); + + sv_catsv(buffer, HeSVKEY_force(he1)); + sv_catpv(buffer, "' does not exist in spec: "); + sv_catsv(buffer, depend_name); + + croak("%s", SvPV_nolen(buffer)); + } + /* if we got here, the spec was correct. we just + * need to issue a regular validation failure + */ + buffer = newSVpv( "Parameter '", 0); + sv_catsv(buffer, HeSVKEY_force(he1)); + sv_catpv(buffer, "' depends on parameter '"); + sv_catsv(buffer, depend_name); + sv_catpv(buffer, "', which was not given"); + validation_failure(buffer, options); + } + } + } + } + } + return 1; +} + +void +apply_defaults(HV *ret, HV *p, HV *specs, AV *missing) { + HE* he; + SV** temp; + + hv_iterinit(specs); + while ((he = hv_iternext(specs))) { + HV* spec; + SV* val; + + val = HeVAL(he); + + /* get extended param spec if available */ + if (val && SvROK(val) && SvTYPE(SvRV(val)) == SVt_PVHV) { + spec = (HV*) SvRV(val); + } + else { + spec = NULL; + } + + /* test for parameter existence */ + if (hv_exists_ent(p, HeSVKEY_force(he), HeHASH(he))) { + continue; + } + + /* parameter may not be defined but we may have default */ + if (spec && (temp = hv_fetch(spec, "default", 7, 0))) { + SV* value; + + SvGETMAGIC(*temp); + value = sv_2mortal(newSVsv(*temp)); + + /* make sure that parameter is put into return hash */ + if (GIMME_V != G_VOID) { + if (!hv_store_ent(ret, HeSVKEY_force(he), + SvREFCNT_inc(value), HeHASH(he))) { + SvREFCNT_dec(value); + croak("Cannot add new key to hash"); + } + } + + continue; + } + + /* find if missing parameter is mandatory */ + if (! no_validation()) { + SV** temp; + + if (spec) { + if ((temp = hv_fetch(spec, "optional", 8, 0))) { + SvGETMAGIC(*temp); + + if (SvTRUE(*temp)) continue; + } + } + else if (!SvTRUE(HeVAL(he))) { + continue; + } + av_push(missing, SvREFCNT_inc(HeSVKEY_force(he))); + } + } +} + +static IV +validate(HV* p, HV* specs, HV* options, HV* ret) { + AV* missing; + AV* unmentioned; + HE* he; + HE* he1; + SV* hv; + SV* hv1; + IV ignore_case = 0; + SV* strip_leading = NULL; + IV allow_extra = 0; + SV** temp; + SV* normalize_func = NULL; + AV* untaint_keys = (AV*) sv_2mortal((SV*) newAV()); + IV i; + + if ((temp = hv_fetch(options, "ignore_case", 11, 0))) { + SvGETMAGIC(*temp); + ignore_case = SvTRUE(*temp); + } + + if ((temp = hv_fetch(options, "strip_leading", 13, 0))) { + SvGETMAGIC(*temp); + if (SvOK(*temp)) strip_leading = *temp; + } + + if ((temp = hv_fetch(options, "normalize_keys", 14, 0))) { + SvGETMAGIC(*temp); + if(SvROK(*temp) && SvTYPE(SvRV(*temp)) == SVt_PVCV) { + normalize_func = *temp; + } + } + + if (normalize_func || ignore_case || strip_leading) { + p = normalize_hash_keys(p, normalize_func, strip_leading, ignore_case); + specs = normalize_hash_keys(specs, normalize_func, strip_leading, ignore_case); + } + + /* short-circuit everything else when no_validation is true */ + if (no_validation()) { + if (GIMME_V != G_VOID) { + while ((he = hv_iternext(p))) { + hv = HeVAL(he); + if (! hv) { + continue; + } + + SvGETMAGIC(hv); + + /* put the parameter into return hash */ + if (!hv_store_ent(ret, HeSVKEY_force(he), SvREFCNT_inc(hv), + HeHASH(he))) { + SvREFCNT_dec(hv); + croak("Cannot add new key to hash"); + } + } + apply_defaults(ret, p, specs, NULL); + } + + return 1; + } + + if ((temp = hv_fetch(options, "allow_extra", 11, 0))) { + SvGETMAGIC(*temp); + allow_extra = SvTRUE(*temp); + } + + /* find extra parameters and validate good parameters */ + unmentioned = (AV*) sv_2mortal((SV*) newAV()); + + hv_iterinit(p); + while ((he = hv_iternext(p))) { + hv = HeVAL(he); + if (! hv) { + continue; + } + + SvGETMAGIC(hv); + + /* put the parameter into return hash */ + if (GIMME_V != G_VOID) { + if (!hv_store_ent(ret, HeSVKEY_force(he), SvREFCNT_inc(hv), + HeHASH(he))) { + SvREFCNT_dec(hv); + croak("Cannot add new key to hash"); + } + } + + /* check if this parameter is defined in spec and if it is + then validate it using spec */ + he1 = hv_fetch_ent(specs, HeSVKEY_force(he), 0, HeHASH(he)); + if(he1) { + hv1 = HeVAL(he1); + if (SvROK(hv1) && SvTYPE(SvRV(hv1)) == SVt_PVHV) { + char* buffer; + HV* spec; + IV untaint = 0; + + spec = (HV*) SvRV(hv1); + buffer = form("The '%s' parameter (%%s)", HePV(he, PL_na)); + + if (! validate_one_param(hv, (SV*) p, spec, buffer, options, &untaint)) + return 0; + + /* The value stored here is meaningless, we're just tracking + keys to untaint later */ + if (untaint) { + av_push(untaint_keys, SvREFCNT_inc(HeSVKEY_force(he1))); + } + } + } + else if (! allow_extra) { + av_push(unmentioned, SvREFCNT_inc(HeSVKEY_force(he))); + } + + if (av_len(unmentioned) > -1) { + SV* buffer = newSVpv("The following parameter", 0); + SV *caller = get_caller(options); + + if (av_len(unmentioned) != 0) { + sv_catpv(buffer, "s were "); + } + else { + sv_catpv(buffer, " was "); + } + sv_catpv(buffer, "passed in the call to "); + sv_catsv(buffer, caller); + SvREFCNT_dec(caller); + sv_catpv(buffer, " but "); + if (av_len(unmentioned) != 0) { + sv_catpv(buffer, "were "); + } + else { + sv_catpv(buffer, "was "); + } + sv_catpv(buffer, "not listed in the validation options: "); + for(i = 0; i <= av_len(unmentioned); i++) { + sv_catsv(buffer, *av_fetch(unmentioned, i, 1)); + if (i < av_len(unmentioned)) { + sv_catpv(buffer, " "); + } + } + sv_catpv(buffer, "\n"); + + validation_failure(buffer, options); + } + } + + validate_named_depends(p, specs, options); + + /* find missing parameters */ + missing = (AV*) sv_2mortal((SV*) newAV()); + + apply_defaults(ret, p, specs, missing); + + if (av_len(missing) > -1) { + SV* buffer = newSVpv("Mandatory parameter", 0); + SV *caller = get_caller(options); + + if (av_len(missing) > 0) { + sv_catpv(buffer, "s "); + } + else { + sv_catpv(buffer, " "); + } + + for(i = 0; i <= av_len(missing); i++) { + sv_catpvf(buffer, "'%s'", + SvPV_nolen(*av_fetch(missing, i, 0))); + if (i < av_len(missing)) { + sv_catpv(buffer, ", "); + } + } + sv_catpv(buffer, " missing in call to "); + sv_catsv(buffer, caller); + SvREFCNT_dec(caller); + sv_catpv(buffer, "\n"); + + validation_failure(buffer, options); + } + + if (GIMME_V != G_VOID) { + for (i = 0; i <= av_len(untaint_keys); i++) { + SvTAINTED_off(HeVAL(hv_fetch_ent(p, *av_fetch(untaint_keys, i, 0), 0, 0))); + } + } + + return 1; +} + +static SV* +validate_pos_failure(IV pnum, IV min, IV max, HV* options) { + SV* buffer; + SV** temp; + IV allow_extra; + + if ((temp = hv_fetch(options, "allow_extra", 11, 0))) { + SvGETMAGIC(*temp); + allow_extra = SvTRUE(*temp); + } + else { + allow_extra = 0; + } + + buffer = newSViv(pnum + 1); + if (pnum != 0) { + sv_catpv(buffer, " parameters were passed to "); + } + else { + sv_catpv(buffer, " parameter was passed to "); + } + sv_catsv(buffer, get_caller(options)); + sv_catpv(buffer, " but "); + if (!allow_extra) { + if (min != max) { + sv_catpvf(buffer, "%d - %d", (int) min + 1, (int) max + 1); + } + else { + sv_catpvf(buffer, "%d", (int) max + 1); + } + } + else { + sv_catpvf(buffer, "at least %d", (int) min + 1); + } + if ((allow_extra ? min : max) != 0) { + sv_catpv(buffer, " were expected\n"); + } + else { + sv_catpv(buffer, " was expected\n"); + } + + return buffer; +} + +/* Given a single parameter spec and a corresponding complex spec form + of it (which must be false if the spec is not complex), return true + says that the parameter is options. */ +static bool +spec_says_optional(SV* spec, IV complex_spec) { + SV** temp; + + if (complex_spec) { + if ((temp = hv_fetch((HV*) SvRV(spec), "optional", 8, 0))) { + SvGETMAGIC(*temp); + if (!SvTRUE(*temp)) + return FALSE; + } + else { + return FALSE; + } + } + else { + if (SvTRUE(spec)) { + return FALSE; + } + } + return TRUE; +} + +static IV +validate_pos(AV* p, AV* specs, HV* options, AV* ret) { + char* buffer; + SV* value; + SV* spec = NULL; + SV** temp; + IV i; + IV complex_spec = 0; + IV allow_extra; + /* Index of highest-indexed required parameter known so far, or -1 + if no required parameters are known yet. */ + IV min = -1; + AV* untaint_indexes = (AV*) sv_2mortal((SV*) newAV()); + + if (no_validation()) { + IV spec_count = av_len(specs); + IV p_count = av_len(p); + IV max = spec_count > p_count ? spec_count : p_count; + + if (GIMME_V == G_VOID) { + return 1; + } + + for (i = 0; i <= max; i++) { + if (i <= spec_count) { + spec = *av_fetch(specs, i, 1); + if (spec) { + SvGETMAGIC(spec); + } + complex_spec = (SvROK(spec) && SvTYPE(SvRV(spec)) == SVt_PVHV); + } + + if (i <= av_len(p)) { + value = *av_fetch(p, i, 1); + SvGETMAGIC(value); + av_push(ret, SvREFCNT_inc(value)); + } else if (complex_spec && + (temp = hv_fetch((HV*) SvRV(spec), "default", 7, 0))) { + SvGETMAGIC(*temp); + av_push(ret, SvREFCNT_inc(*temp)); + } + } + return 1; + } + + /* iterate through all parameters and validate them */ + for (i = 0; i <= av_len(specs); i++) { + spec = *av_fetch(specs, i, 1); + if (! spec) { + continue; + } + SvGETMAGIC(spec); + complex_spec = (SvROK(spec) && SvTYPE(SvRV(spec)) == SVt_PVHV); + + /* Unless the current spec refers to an optional argument, update + our notion of the index of the highest-idexed required + parameter. */ + if (! spec_says_optional(spec, complex_spec) ) { + min = i; + } + + if (i <= av_len(p)) { + value = *av_fetch(p, i, 1); + SvGETMAGIC(value); + + if (complex_spec) { + IV untaint = 0; + + buffer = form("Parameter #%d (%%s)", (int)i + 1); + + if (! validate_one_param(value, (SV*) p, (HV*) SvRV(spec), buffer, options, &untaint)) { + return 0; + } + + if (untaint) { + av_push(untaint_indexes, newSViv(i)); + } + } + + if (GIMME_V != G_VOID) { + av_push(ret, SvREFCNT_inc(value)); + } + + } else if (complex_spec && + (temp = hv_fetch((HV*) SvRV(spec), "default", 7, 0))) { + SvGETMAGIC(*temp); + + if (GIMME_V != G_VOID) { + av_store(ret, i, SvREFCNT_inc(*temp)); + } + + } + else { + if (i == min) { + /* We don't have as many arguments as the arg spec requires. */ + SV* buffer; + + /* Look forward through remaining argument specifications to + find the last non-optional one, so we can correctly report the + number of arguments required. */ + for (i++ ; i <= av_len(specs); i++) { + spec = *av_fetch(specs, i, 1); + if (! spec) { + continue; + } + + SvGETMAGIC(spec); + complex_spec = (SvROK(spec) && SvTYPE(SvRV(spec)) == SVt_PVHV); + if (! spec_says_optional(spec, complex_spec)) { + min = i; + } + if (min != i) + break; + } + + buffer = validate_pos_failure(av_len(p), min, av_len(specs), options); + + validation_failure(buffer, options); + } + } + } + + validate_pos_depends(p, specs, options); + + /* test for extra parameters */ + if (av_len(p) > av_len(specs)) { + if ((temp = hv_fetch(options, "allow_extra", 11, 0))) { + SvGETMAGIC(*temp); + allow_extra = SvTRUE(*temp); + } + else { + allow_extra = 0; + } + if (allow_extra) { + /* put all additional parameters into return array */ + if (GIMME_V != G_VOID) { + for(i = av_len(specs) + 1; i <= av_len(p); i++) { + value = *av_fetch(p, i, 1); + if (value) { + SvGETMAGIC(value); + av_push(ret, SvREFCNT_inc(value)); + } + else { + av_push(ret, &PL_sv_undef); + } + } + } + } + else { + SV* buffer = validate_pos_failure(av_len(p), min, av_len(specs), options); + validation_failure(buffer, options); + } + } + + if (GIMME_V != G_VOID) { + for (i = 0; i <= av_len(untaint_indexes); i++) { + SvTAINTED_off(*av_fetch(p, SvIV(*av_fetch(untaint_indexes, i, 0)), 0)); + } + } + + return 1; +} + +MODULE = Params::Validate::XS PACKAGE = Params::Validate::XS + +void +validate(p, specs) + SV* p + SV* specs + + PROTOTYPE: \@$ + + PPCODE: + + HV* ret = NULL; + AV* pa; + HV* ph; + HV* options; + + if (no_validation() && GIMME_V == G_VOID) { + XSRETURN(0); + } + + SvGETMAGIC(p); + if (! (SvROK(p) && SvTYPE(SvRV(p)) == SVt_PVAV)) { + croak("Expecting array reference as first parameter"); + } + + SvGETMAGIC(specs); + if (! (SvROK(specs) && SvTYPE(SvRV(specs)) == SVt_PVHV)) { + croak("Expecting hash reference as second parameter"); + } + + pa = (AV*) SvRV(p); + ph = NULL; + if (av_len(pa) == 0) { + /* we were called as validate( @_, ... ) where @_ has a + single element, a hash reference */ + SV* value; + + value = *av_fetch(pa, 0, 1); + if (value) { + SvGETMAGIC(value); + if (SvROK(value) && SvTYPE(SvRV(value)) == SVt_PVHV) { + ph = (HV*) SvRV(value); + } + } + } + + options = get_options(NULL); + + if (! ph) { + ph = (HV*) sv_2mortal((SV*) newHV()); + + if (! convert_array2hash(pa, options, ph) ) { + XSRETURN(0); + } + } + if (GIMME_V != G_VOID) { + ret = (HV*) sv_2mortal((SV*) newHV()); + } + if (! validate(ph, (HV*) SvRV(specs), options, ret)) { + XSRETURN(0); + } + RETURN_HASH(ret); + +void +validate_pos(p, ...) +SV* p + + PROTOTYPE: \@@ + + PPCODE: + + AV* specs; + AV* ret = NULL; + IV i; + + if (no_validation() && GIMME_V == G_VOID) { + XSRETURN(0); + } + + SvGETMAGIC(p); + if (!SvROK(p) || !(SvTYPE(SvRV(p)) == SVt_PVAV)) { + croak("Expecting array reference as first parameter"); + } + + specs = (AV*) sv_2mortal((SV*) newAV()); + av_extend(specs, items); + for(i = 1; i < items; i++) { + if (!av_store(specs, i - 1, SvREFCNT_inc(ST(i)))) { + SvREFCNT_dec(ST(i)); + croak("Cannot store value in array"); + } + } + + if (GIMME_V != G_VOID) { + ret = (AV*) sv_2mortal((SV*) newAV()); + } + + if (! validate_pos((AV*) SvRV(p), specs, get_options(NULL), ret)) { + XSRETURN(0); + } + + RETURN_ARRAY(ret); + +void +validate_with(...) + + PPCODE: + + HV* p; + SV* params; + SV* spec; + IV i; + + if (no_validation() && GIMME_V == G_VOID) XSRETURN(0); + + /* put input list into hash */ + p = (HV*) sv_2mortal((SV*) newHV()); + for(i = 0; i < items; i += 2) { + SV* key; + SV* value; + + key = ST(i); + if (i + 1 < items) { + value = ST(i + 1); + } + else { + value = &PL_sv_undef; + } + if (! hv_store_ent(p, key, SvREFCNT_inc(value), 0)) { + SvREFCNT_dec(value); + croak("Cannot add new key to hash"); + } + } + + params = *hv_fetch(p, "params", 6, 1); + SvGETMAGIC(params); + spec = *hv_fetch(p, "spec", 4, 1); + SvGETMAGIC(spec); + + if (SvROK(spec) && SvTYPE(SvRV(spec)) == SVt_PVAV) { + if (SvROK(params) && SvTYPE(SvRV(params)) == SVt_PVAV) { + AV* ret = NULL; + + if (GIMME_V != G_VOID) { + ret = (AV*) sv_2mortal((SV*) newAV()); + } + + PUTBACK; + + if (! validate_pos((AV*) SvRV(params), (AV*) SvRV(spec), get_options(p), ret)) { + SPAGAIN; + XSRETURN(0); + } + + SPAGAIN; + RETURN_ARRAY(ret); + } + else { + croak("Expecting array reference in 'params'"); + } + } + else if (SvROK(spec) && SvTYPE(SvRV(spec)) == SVt_PVHV) { + HV* hv; + HV* ret = NULL; + HV* options; + + options = get_options(p); + + if (SvROK(params) && SvTYPE(SvRV(params)) == SVt_PVHV) { + hv = (HV*) SvRV(params); + } + else if (SvROK(params) && SvTYPE(SvRV(params)) == SVt_PVAV) { + I32 hv_set = 0; + + /* Check to see if we have a one element array + containing a hash reference */ + if (av_len((AV*) SvRV(params)) == 0) { + SV** first_elem; + + first_elem = av_fetch((AV*) SvRV(params), 0, 0); + + if (first_elem && SvROK(*first_elem) && + SvTYPE(SvRV(*first_elem)) == SVt_PVHV) { + + hv = (HV*) SvRV(*first_elem); + hv_set = 1; + } + } + + if (! hv_set) { + hv = (HV*) sv_2mortal((SV*) newHV()); + + if (! convert_array2hash((AV*) SvRV(params), options, hv)) + XSRETURN(0); + } + } + else { + croak("Expecting array or hash reference in 'params'"); + } + + if (GIMME_V != G_VOID) { + ret = (HV*) sv_2mortal((SV*) newHV()); + } + + PUTBACK; + + if (! validate(hv, (HV*) SvRV(spec), options, ret)) { + SPAGAIN; + XSRETURN(0); + } + + SPAGAIN; + RETURN_HASH(ret); + } + else { + croak("Expecting array or hash reference in 'spec'"); + } diff --git a/lib/Params/ValidatePP.pm b/lib/Params/ValidatePP.pm new file mode 100644 index 0000000..9740cc9 --- /dev/null +++ b/lib/Params/ValidatePP.pm @@ -0,0 +1,9 @@ +package # hide from PAUSE + Params::Validate; + +our $VERSION = '1.20'; + +BEGIN { $ENV{PARAMS_VALIDATE_IMPLEMENTATION} = 'PP' } +use Params::Validate; + +1; diff --git a/lib/Params/ValidateXS.pm b/lib/Params/ValidateXS.pm new file mode 100644 index 0000000..4f07801 --- /dev/null +++ b/lib/Params/ValidateXS.pm @@ -0,0 +1,9 @@ +package # hide from PAUSE + Params::Validate; + +our $VERSION = '1.20'; + +BEGIN { $ENV{PARAMS_VALIDATE_IMPLEMENTATION} = 'XS' } +use Params::Validate; + +1; diff --git a/perlcriticrc b/perlcriticrc new file mode 100644 index 0000000..1ab0851 --- /dev/null +++ b/perlcriticrc @@ -0,0 +1,58 @@ +severity = 3 +verbose = 11 +theme = core + pbp + bugs + maintenance + cosmetic + complexity + security + tests + moose + +exclude = Subroutines::ProhibitCallsToUndeclaredSubs + +[BuiltinFunctions::ProhibitStringySplit] +severity = 3 + +[CodeLayout::RequireTrailingCommas] +severity = 3 + +[ControlStructures::ProhibitCStyleForLoops] +severity = 3 + +[InputOutput::RequireCheckedSyscalls] +functions = :builtins +exclude_functions = sleep +severity = 3 + +[RegularExpressions::ProhibitComplexRegexes] +max_characters = 200 + +[RegularExpressions::ProhibitUnusualDelimiters] +severity = 3 + +[Subroutines::ProhibitUnusedPrivateSubroutines] +private_name_regex = _(?!build)\w+ + +[TestingAndDebugging::ProhibitNoWarnings] +allow = redefine + +[ValuesAndExpressions::ProhibitEmptyQuotes] +severity = 3 + +[ValuesAndExpressions::ProhibitInterpolationOfLiterals] +severity = 3 + +[ValuesAndExpressions::RequireUpperCaseHeredocTerminator] +severity = 3 + +[Variables::ProhibitPackageVars] +add_packages = Carp Test::Builder + +[-Subroutines::RequireFinalReturn] + +[-ErrorHandling::RequireCarping] + +# No need for /xsm everywhere +[-RegularExpressions::RequireDotMatchAnything] +[-RegularExpressions::RequireExtendedFormatting] +[-RegularExpressions::RequireLineBoundaryMatching] + +# http://stackoverflow.com/questions/2275317/why-does-perlcritic-dislike-using-shift-to-populate-subroutine-variables +[-Subroutines::RequireArgUnpacking] + +# "use v5.14" is more readable than "use 5.014" +[-ValuesAndExpressions::ProhibitVersionStrings] diff --git a/perltidyrc b/perltidyrc new file mode 100644 index 0000000..8fb8d2a --- /dev/null +++ b/perltidyrc @@ -0,0 +1,21 @@ +-l=78 +-i=4 +-ci=4 +-se +-b +-bar +-boc +-vt=0 +-vtc=0 +-cti=0 +-pt=1 +-bt=1 +-sbt=1 +-bbt=1 +-nolq +-npro +-nsfs +--blank-lines-before-packages=0 +--opening-hash-brace-right +--no-outdent-long-comments +-wbb="% + - * / x != == >= <= =~ !~ < > | & >= < = **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x=" diff --git a/t/00-report-prereqs.dd b/t/00-report-prereqs.dd new file mode 100644 index 0000000..449ef3c --- /dev/null +++ b/t/00-report-prereqs.dd @@ -0,0 +1,70 @@ +do { my $x = { + 'build' => { + 'requires' => { + 'Module::Build' => '0.28' + } + }, + 'configure' => { + 'requires' => { + 'Module::Build' => '0.28' + } + }, + 'develop' => { + 'requires' => { + 'File::Spec' => '0', + 'IO::Handle' => '0', + 'IPC::Open3' => '0', + 'Perl::Critic' => '1.123', + 'Perl::Tidy' => '20140711', + 'Pod::Coverage::TrustPod' => '0', + 'Readonly' => '1.03', + 'Scalar::Util' => '1.20', + 'Test::CPAN::Changes' => '0.19', + 'Test::EOL' => '0', + 'Test::LeakTrace' => '0.15', + 'Test::More' => '0.96', + 'Test::NoTabs' => '0', + 'Test::Pod' => '1.41', + 'Test::Pod::Coverage' => '1.08', + 'Test::Spelling' => '0.12', + 'Test::Synopsis' => '0', + 'Test::Taint' => '0.02' + } + }, + 'runtime' => { + 'requires' => { + 'Attribute::Handlers' => '0.79', + 'Carp' => '0', + 'Exporter' => '0', + 'Module::Implementation' => '0', + 'Scalar::Util' => '1.10', + 'XSLoader' => '0', + 'attributes' => '0', + 'perl' => '5.008001', + 'strict' => '0', + 'vars' => '0', + 'warnings' => '0' + } + }, + 'test' => { + 'recommends' => { + 'CPAN::Meta' => '2.120900' + }, + 'requires' => { + 'Devel::Peek' => '0', + 'ExtUtils::MakeMaker' => '0', + 'File::Spec' => '0', + 'File::Temp' => '0', + 'Test::Fatal' => '0', + 'Test::More' => '0.96', + 'Test::Requires' => '0', + 'Tie::Array' => '0', + 'Tie::Hash' => '0', + 'base' => '0', + 'lib' => '0', + 'overload' => '0' + } + } + }; + $x; + }
\ No newline at end of file diff --git a/t/00-report-prereqs.t b/t/00-report-prereqs.t new file mode 100644 index 0000000..d8d15ba --- /dev/null +++ b/t/00-report-prereqs.t @@ -0,0 +1,183 @@ +#!perl + +use strict; +use warnings; + +# This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.021 + +use Test::More tests => 1; + +use ExtUtils::MakeMaker; +use File::Spec; + +# from $version::LAX +my $lax_version_re = + qr/(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )? + | + (?:\.[0-9]+) (?:_[0-9]+)? + ) | (?: + v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )? + | + (?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)? + ) + )/x; + +# hide optional CPAN::Meta modules from prereq scanner +# and check if they are available +my $cpan_meta = "CPAN::Meta"; +my $cpan_meta_pre = "CPAN::Meta::Prereqs"; +my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic + +# Verify requirements? +my $DO_VERIFY_PREREQS = 1; + +sub _max { + my $max = shift; + $max = ( $_ > $max ) ? $_ : $max for @_; + return $max; +} + +sub _merge_prereqs { + my ($collector, $prereqs) = @_; + + # CPAN::Meta::Prereqs object + if (ref $collector eq $cpan_meta_pre) { + return $collector->with_merged_prereqs( + CPAN::Meta::Prereqs->new( $prereqs ) + ); + } + + # Raw hashrefs + for my $phase ( keys %$prereqs ) { + for my $type ( keys %{ $prereqs->{$phase} } ) { + for my $module ( keys %{ $prereqs->{$phase}{$type} } ) { + $collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module}; + } + } + } + + return $collector; +} + +my @include = qw( + +); + +my @exclude = qw( + +); + +# Add static prereqs to the included modules list +my $static_prereqs = do 't/00-report-prereqs.dd'; + +# Merge all prereqs (either with ::Prereqs or a hashref) +my $full_prereqs = _merge_prereqs( + ( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ), + $static_prereqs +); + +# Add dynamic prereqs to the included modules list (if we can) +my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; +if ( $source && $HAS_CPAN_META ) { + if ( my $meta = eval { CPAN::Meta->load_file($source) } ) { + $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs); + } +} +else { + $source = 'static metadata'; +} + +my @full_reports; +my @dep_errors; +my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs; + +# Add static includes into a fake section +for my $mod (@include) { + $req_hash->{other}{modules}{$mod} = 0; +} + +for my $phase ( qw(configure build test runtime develop other) ) { + next unless $req_hash->{$phase}; + next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING}); + + for my $type ( qw(requires recommends suggests conflicts modules) ) { + next unless $req_hash->{$phase}{$type}; + + my $title = ucfirst($phase).' '.ucfirst($type); + my @reports = [qw/Module Want Have/]; + + for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) { + next if $mod eq 'perl'; + next if grep { $_ eq $mod } @exclude; + + my $file = $mod; + $file =~ s{::}{/}g; + $file .= ".pm"; + my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; + + my $want = $req_hash->{$phase}{$type}{$mod}; + $want = "undef" unless defined $want; + $want = "any" if !$want && $want == 0; + + my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required"; + + if ($prefix) { + my $have = MM->parse_version( File::Spec->catfile($prefix, $file) ); + $have = "undef" unless defined $have; + push @reports, [$mod, $want, $have]; + + if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) { + if ( $have !~ /\A$lax_version_re\z/ ) { + push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)"; + } + elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) { + push @dep_errors, "$mod version '$have' is not in required range '$want'"; + } + } + } + else { + push @reports, [$mod, $want, "missing"]; + + if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) { + push @dep_errors, "$mod is not installed ($req_string)"; + } + } + } + + if ( @reports ) { + push @full_reports, "=== $title ===\n\n"; + + my $ml = _max( map { length $_->[0] } @reports ); + my $wl = _max( map { length $_->[1] } @reports ); + my $hl = _max( map { length $_->[2] } @reports ); + + if ($type eq 'modules') { + splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl]; + push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports; + } + else { + splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl]; + push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports; + } + + push @full_reports, "\n"; + } + } +} + +if ( @full_reports ) { + diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports; +} + +if ( @dep_errors ) { + diag join("\n", + "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n", + "The following REQUIRED prerequisites were not satisfied:\n", + @dep_errors, + "\n" + ); +} + +pass; + +# vim: ts=4 sts=4 sw=4 et: diff --git a/t/01-validate.t b/t/01-validate.t new file mode 100644 index 0000000..32c2122 --- /dev/null +++ b/t/01-validate.t @@ -0,0 +1,8 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests::Standard; +PVTests::Standard::run_tests(); diff --git a/t/02-noop.t b/t/02-noop.t new file mode 100644 index 0000000..fd3bccb --- /dev/null +++ b/t/02-noop.t @@ -0,0 +1,11 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +BEGIN { $ENV{PERL_NO_VALIDATION} = 1 } + +use PVTests::Standard; +PVTests::Standard::run_tests(); + diff --git a/t/03-attribute.t b/t/03-attribute.t new file mode 100644 index 0000000..6bb1b72 --- /dev/null +++ b/t/03-attribute.t @@ -0,0 +1,101 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests; +use Test::More; + +use Attribute::Params::Validate; +use Params::Validate qw(:all); + +sub foo : Validate( c => { type => SCALAR } ) { + my %data = @_; + return $data{c}; +} + +sub bar : Validate( c => { type => SCALAR } ) method { + my $self = shift; + my %data = @_; + return $data{c}; +} + +sub baz : + Validate( foo => { type => ARRAYREF, callbacks => { '5 elements' => sub { @{shift()} == 5 } } } ) +{ + my %data = @_; + return $data{foo}->[0]; +} + +sub buz : ValidatePos( 1 ) { + return $_[0]; +} + +sub quux : ValidatePos( { type => SCALAR }, 1 ) { + return $_[0]; +} + +my $res = eval { foo( c => 1 ) }; +is( + $@, q{}, + "Call foo with a scalar" +); + +is( + $res, 1, + 'Check return value from foo( c => 1 )' +); + +eval { foo( c => [] ) }; + +like( + $@, qr/The 'c' parameter .* was an 'arrayref'/, + 'Check exception thrown from foo( c => [] )' +); + +$res = eval { main->bar( c => 1 ) }; +is( + $@, q{}, + 'Call bar with a scalar' +); + +is( + $res, 1, + 'Check return value from bar( c => 1 )' +); + +eval { baz( foo => [ 1, 2, 3, 4 ] ) }; + +like( + $@, qr/The 'foo' parameter .* did not pass the '5 elements' callback/, + 'Check exception thrown from baz( foo => [1,2,3,4] )' +); + +$res = eval { baz( foo => [ 5, 4, 3, 2, 1 ] ) }; + +is( + $@, q{}, + 'Call baz( foo => [5,4,3,2,1] )' +); + +is( + $res, 5, + 'Check return value from baz( foo => [5,4,3,2,1] )' +); + +eval { buz( [], 1 ) }; + +like( + $@, qr/2 parameters were passed to .* but 1 was expected/, + 'Check exception thrown from quux( [], 1 )' +); + +$res = eval { quux( 1, [] ) }; + +is( + $@, q{}, + 'Call quux' +); + +done_testing(); diff --git a/t/04-defaults.t b/t/04-defaults.t new file mode 100644 index 0000000..49e8259 --- /dev/null +++ b/t/04-defaults.t @@ -0,0 +1,8 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests::Defaults; +PVTests::Defaults::run_tests(); diff --git a/t/05-noop_default.t b/t/05-noop_default.t new file mode 100644 index 0000000..cc50768 --- /dev/null +++ b/t/05-noop_default.t @@ -0,0 +1,10 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +BEGIN { $ENV{PERL_NO_VALIDATION} = 1 } + +use PVTests::Defaults; +PVTests::Defaults::run_tests(); diff --git a/t/06-options.t b/t/06-options.t new file mode 100644 index 0000000..ad167c0 --- /dev/null +++ b/t/06-options.t @@ -0,0 +1,39 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests; +use Test::More; + +use Params::Validate qw(:all); + +validation_options( stack_skip => 2 ); + +sub foo { + my %p = validate( @_, { bar => 1 } ); +} + +sub bar { foo(@_) } + +sub baz { bar(@_) } + +eval { baz() }; + +like( $@, qr/mandatory.*missing.*call to main::bar/i ); + +validation_options( stack_skip => 3 ); + +eval { baz() }; +like( $@, qr/mandatory.*missing.*call to main::baz/i ); + +validation_options( on_fail => sub { die bless { hash => 'ref' }, 'Dead' } ); + +eval { baz() }; + +my $e = $@; +is( $e->{hash}, 'ref' ); +ok( eval { $e->isa('Dead'); 1; } ); + +done_testing(); diff --git a/t/07-with.t b/t/07-with.t new file mode 100644 index 0000000..85e0658 --- /dev/null +++ b/t/07-with.t @@ -0,0 +1,8 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests::With; +PVTests::With::run_tests(); diff --git a/t/08-noop_with.t b/t/08-noop_with.t new file mode 100644 index 0000000..886254a --- /dev/null +++ b/t/08-noop_with.t @@ -0,0 +1,10 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +BEGIN { $ENV{PERL_NO_VALIDATION} = 1 } + +use PVTests::With; +PVTests::With::run_tests(); diff --git a/t/09-regex.t b/t/09-regex.t new file mode 100644 index 0000000..dae8558 --- /dev/null +++ b/t/09-regex.t @@ -0,0 +1,8 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests::Regex; +PVTests::Regex::run_tests(); diff --git a/t/10-noop_regex.t b/t/10-noop_regex.t new file mode 100644 index 0000000..89b1148 --- /dev/null +++ b/t/10-noop_regex.t @@ -0,0 +1,10 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +BEGIN { $ENV{PERL_NO_VALIDATION} = 1 } + +use PVTests::Regex; +PVTests::Regex::run_tests(); diff --git a/t/11-cb.t b/t/11-cb.t new file mode 100644 index 0000000..12e7a0b --- /dev/null +++ b/t/11-cb.t @@ -0,0 +1,8 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests::Callbacks; +PVTests::Callbacks::run_tests(); diff --git a/t/12-noop_cb.t b/t/12-noop_cb.t new file mode 100644 index 0000000..777cf01 --- /dev/null +++ b/t/12-noop_cb.t @@ -0,0 +1,10 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +BEGIN { $ENV{PERL_NO_VALIDATION} = 1 } + +use PVTests::Callbacks; +PVTests::Callbacks::run_tests(); diff --git a/t/13-taint.t b/t/13-taint.t new file mode 100644 index 0000000..5d60f1d --- /dev/null +++ b/t/13-taint.t @@ -0,0 +1,10 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +eval { "$0$^X" && kill 0; 1 }; + +use PVTests::Standard; +PVTests::Standard::run_tests(); diff --git a/t/14-no_validate.t b/t/14-no_validate.t new file mode 100644 index 0000000..07aa215 --- /dev/null +++ b/t/14-no_validate.t @@ -0,0 +1,28 @@ +use strict; +use warnings; + +use lib './t'; + +use Params::Validate qw(validate); + +use Test::More; +plan tests => $] == 5.006 ? 2 : 3; + +eval { foo() }; +like( $@, qr/parameter 'foo'/ ); + +{ + local $Params::Validate::NO_VALIDATION = 1; + + eval { foo() }; + is( $@, q{} ); +} + +unless ( $] == 5.006 ) { + eval { foo() }; + like( $@, qr/parameter 'foo'/ ); +} + +sub foo { + validate( @_, { foo => 1 } ); +} diff --git a/t/15-case.t b/t/15-case.t new file mode 100644 index 0000000..ff02112 --- /dev/null +++ b/t/15-case.t @@ -0,0 +1,98 @@ +use strict; +use warnings; + +use Test::More; + +use Params::Validate qw(validate validate_with); + +my @testset; + +# Generate test cases ... +BEGIN { + my @lower_case_args = ( foo => 1 ); + my @upper_case_args = ( FOO => 1 ); + my @mixed_case_args = ( FoO => 1 ); + + my %lower_case_spec = ( foo => 1 ); + my %upper_case_spec = ( FOO => 1 ); + my %mixed_case_spec = ( FoO => 1 ); + + my %arglist = ( + lower => \@lower_case_args, + upper => \@upper_case_args, + mixed => \@mixed_case_args + ); + + my %speclist = ( + lower => \%lower_case_spec, + upper => \%upper_case_spec, + mixed => \%mixed_case_spec + ); + + # XXX - make subs such that user gets to see the error message + # when a test fails + my $ok_sub = sub { + if ($@) { + print STDERR $@; + } + !$@; + }; + + my $nok_sub = sub { + my $ok = ( $@ =~ /not listed in the validation options/ ); + unless ($ok) { + print STDERR $@; + } + $ok; + }; + + # generate testcases on the fly (I'm too lazy) + for my $ignore_case (qw( 0 1 )) { + for my $args ( keys %arglist ) { + for my $spec ( keys %speclist ) { + push @testset, { + params => $arglist{$args}, + spec => $speclist{$spec}, + expect => ( + $ignore_case ? $ok_sub + : $args eq $spec ? $ok_sub + : $nok_sub + ), + ignore_case => $ignore_case + }; + } + } + } +} + +plan tests => ( scalar @testset ) * 2; + +{ + + # XXX - "called" will be all messed up, but what the heck + foreach my $case (@testset) { + my %args = eval { + validate_with( + params => $case->{params}, + spec => $case->{spec}, + ignore_case => $case->{ignore_case} + ); + }; + + ok( $case->{expect}->(%args) ); + } + + # XXX - make sure that it works from validation_options() as well + foreach my $case (@testset) { + Params::Validate::validation_options( + ignore_case => $case->{ignore_case} ); + + my %args = eval { + my @args = @{ $case->{params} }; + validate( @args, $case->{spec} ); + }; + + ok( $case->{expect}->(%args) ); + } +} + diff --git a/t/16-normalize.t b/t/16-normalize.t new file mode 100644 index 0000000..1765312 --- /dev/null +++ b/t/16-normalize.t @@ -0,0 +1,71 @@ +use strict; +use warnings; + +use Params::Validate qw(validate validate_with); +use Test::More; + +my $ucfirst_normalizer = sub { return ucfirst lc $_[0] }; + +sub sub1 { + my %args = validate_with( + params => \@_, + spec => { PaRaMkEy => 1 }, + normalize_keys => $ucfirst_normalizer + ); + + return $args{Paramkey}; +} + +sub sub2 { + + # verify that normalize_callback surpresses ignore_case + my %args = validate_with( + params => \@_, + spec => { PaRaMkEy => 1 }, + normalize_keys => $ucfirst_normalizer, + ignore_case => 1 + ); + + return $args{Paramkey}; +} + +sub sub3 { + + # verify that normalize_callback surpresses strip_leading + my %args = validate_with( + params => \@_, + spec => { -PaRaMkEy => 1 }, + normalize_keys => $ucfirst_normalizer, + strip_leading => '-' + ); + + return $args{-paramkey}; +} + +sub sub4 { + my %args = validate_with( + params => \@_, + spec => { foo => 1 }, + normalize_keys => sub {undef} + ); +} + +sub sub5 { + my %args = validate_with( + params => \@_, + spec => { foo => 1 }, + normalize_keys => sub { return 'a' }, + ); +} + +ok( eval { sub1( pArAmKeY => 1 ) } ); +ok( eval { sub2( pArAmKeY => 1 ) } ); +ok( eval { sub3( -pArAmKeY => 1 ) } ); + +eval { sub4( foo => 5 ) }; +like( $@, qr/normalize_keys.+a defined value/ ); + +eval { sub5( foo => 5, bar => 5 ) }; +like( $@, qr/normalize_keys.+already exists/ ); + +done_testing(); diff --git a/t/17-callbacks.t b/t/17-callbacks.t new file mode 100644 index 0000000..e06a867 --- /dev/null +++ b/t/17-callbacks.t @@ -0,0 +1,78 @@ +use strict; +use warnings; + +use Params::Validate qw(validate validate_pos SCALAR); +use Test::More; + +{ + my @p = ( foo => 1, bar => 2 ); + + eval { + validate( + @p, { + foo => { + type => SCALAR, + callbacks => { + 'bigger than bar' => sub { $_[0] > $_[1]->{bar} } + }, + }, + bar => { type => SCALAR }, + } + ); + }; + + like( $@, qr/bigger than bar/ ); + + $p[1] = 3; + eval { + validate( + @p, { + foo => { + type => SCALAR, + callbacks => { + 'bigger than bar' => sub { $_[0] > $_[1]->{bar} } + }, + }, + bar => { type => SCALAR }, + } + ); + }; + + is( $@, q{} ); +} + +{ + my @p = ( 1, 2, 3 ); + eval { + validate_pos( + @p, { + type => SCALAR, + callbacks => { + 'bigger than [1]' => sub { $_[0] > $_[1]->[1] } + } + }, + { type => SCALAR }, + { type => SCALAR }, + ); + }; + + like( $@, qr/bigger than \[1\]/ ); + + $p[0] = 5; + eval { + validate_pos( + @p, { + type => SCALAR, + callbacks => { + 'bigger than [1]' => sub { $_[0] > $_[1]->[1] } + } + }, + { type => SCALAR }, + { type => SCALAR }, + ); + }; + + is( $@, q{} ); +} + +done_testing(); diff --git a/t/18-depends.t b/t/18-depends.t new file mode 100644 index 0000000..a94d3bf --- /dev/null +++ b/t/18-depends.t @@ -0,0 +1,168 @@ +use strict; +use warnings; + +use Params::Validate qw(validate validate_pos); +use Test::More; + +{ + my %spec = ( + foo => { optional => 1, depends => 'bar' }, + bar => { optional => 1 }, + ); + + my @args = ( bar => 1 ); + + eval { validate( @args, \%spec ) }; + + is( $@, q{}, "validate() single depends(1): no depends, positive" ); + + @args = ( foo => 1, bar => 1 ); + eval { validate( @args, \%spec ) }; + + is( $@, q{}, "validate() single depends(2): with depends, positive" ); + + @args = ( foo => 1 ); + eval { validate( @args, \%spec ) }; + + ok( $@, "validate() single depends(3.a): with depends, negative" ); + like( + $@, + qr(^Parameter 'foo' depends on parameter 'bar', which was not given), + "validate() single depends(3.b): check error string" + ); +} + +{ + my %spec = ( + foo => { optional => 1, depends => [qw(bar baz)] }, + bar => { optional => 1 }, + baz => { optional => 1 }, + ); + + # positive, no depends (single, multiple) + my @args = ( bar => 1 ); + eval { validate( @args, \%spec ) }; + is( + $@, q{}, + "validate() multiple depends(1): no depends, single arg, positive" + ); + + @args = ( bar => 1, baz => 1 ); + eval { validate( @args, \%spec ) }; + + is( + $@, q{}, + "validate() multiple depends(2): no depends, multiple arg, positive" + ); + + @args = ( foo => 1, bar => 1, baz => 1 ); + eval { validate( @args, \%spec ) }; + + is( $@, q{}, "validate() multiple depends(3): with depends, positive" ); + + @args = ( foo => 1, bar => 1 ); + eval { validate( @args, \%spec ) }; + + ok( + $@, + "validate() multiple depends(4.a): with depends, negative, multiple missing" + ); + like( + $@, + qr(^Parameter 'foo' depends on parameter 'baz', which was not given), + "validate() multiple depends (4.b): check error string" + ); + + @args = ( foo => 1 ); + eval { validate( @args, \%spec ) }; + + ok( + $@, + "validate() multiple depends(5.a): with depends, negative, multiple missing" + ); + like( + $@, + qr(^Parameter 'foo' depends on parameter '(bar|baz)', which was not given), + "validate() multiple depends (5.b): check error string" + ); +} + +{ + + # bad depends + my %spec = ( + foo => { optional => 1, depends => { 'bar' => 1 } }, + bar => { optional => 1 }, + ); + + my @args = ( foo => 1 ); + eval { validate( @args, \%spec ) }; + + ok( $@, "validate() bad depends spec (1.a): depends is a hashref" ); + like( + $@, + qr(^Arguments to 'depends' must be a scalar or arrayref), + "validate() bad depends spec (1.a): check error string" + ); +} + +{ + my @spec = ( { optional => 1 } ); + + my @args = qw(1); + eval { validate_pos( @args, @spec ) }; + + is( $@, q{}, "validate_pos() no depends, positive" ); +} + +{ + my @spec = ( { optional => 1, depends => 2 }, { optional => 1 } ); + + my @args = qw(1 1); + eval { validate_pos( @args, @spec ) }; + + is( + $@, q{}, + "validate_pos() single depends (1): with depends, positive" + ); +} + +{ + my @spec = ( + { optional => 1, depends => 4 }, + { optional => 1 }, { optional => 1 }, + { optional => 1 } + ); + + my @args = qw(1 0); + eval { validate_pos( @args, @spec ) }; + + ok( $@, "validate_pos() single depends (2.a): with depends, negative" ); + like( + $@, + qr(^Parameter #1 depends on parameter #4, which was not given), + "validate_pos() single depends (2.b): check error" + ); +} + +{ + my @spec = ( + { optional => 1, depends => [ 2, 3 ] }, + { optional => 1 }, + 0 + ); + my @args = qw(1); + eval { validate_pos( @args, @spec ) }; + + ok( + $@, + "validate_pos() multiple depends (1.a): with depends, bad args negative" + ); + like( + $@, + qr{^Arguments to 'depends' for validate_pos\(\) must be a scalar}, + "validate_pos() multiple depends (1.b): check error" + ); +} + +done_testing(); diff --git a/t/19-untaint.t b/t/19-untaint.t new file mode 100644 index 0000000..fb3f08c --- /dev/null +++ b/t/19-untaint.t @@ -0,0 +1,87 @@ +#!/usr/bin/perl -T + +use strict; +use warnings; + +use Test::Requires { + 'Test::Taint' => 0.02, +}; + +use Params::Validate qw(validate validate_pos); +use Test::More; + +taint_checking_ok('These tests are meaningless unless we are in taint mode.'); + +{ + my $value = 7; + taint($value); + + tainted_ok( $value, 'make sure $value is tainted' ); + + my @p = ( value => $value ); + my %p = validate( + @p, { + value => { + regex => qr/^\d+$/, + untaint => 1, + }, + }, + ); + + untainted_ok( $p{value}, 'value is untainted after validation' ); +} + +{ + my $value = 'foo'; + + taint($value); + + tainted_ok( $value, 'make sure $value is tainted' ); + + my @p = ($value); + my ($new_value) = validate_pos( + @p, { + regex => qr/foo/, + untaint => 1, + }, + ); + + untainted_ok( $new_value, 'value is untainted after validation' ); +} + +{ + my $value = 7; + taint($value); + + tainted_ok( $value, 'make sure $value is tainted' ); + + my @p = ( value => $value ); + my %p = validate( + @p, { + value => { + regex => qr/^\d+$/, + }, + }, + ); + + tainted_ok( $p{value}, 'value is still tainted after validation' ); +} + +{ + my $value = 'foo'; + + taint($value); + + tainted_ok( $value, 'make sure $value is tainted' ); + + my @p = ($value); + my ($new_value) = validate_pos( + @p, { + regex => qr/foo/, + }, + ); + + tainted_ok( $new_value, 'value is still tainted after validation' ); +} + +done_testing(); diff --git a/t/21-can.t b/t/21-can.t new file mode 100644 index 0000000..5230c44 --- /dev/null +++ b/t/21-can.t @@ -0,0 +1,95 @@ +use strict; +use warnings; + +use Params::Validate qw(validate); +use Test::More; + +{ + my @p = ( foo => 'ClassCan' ); + + eval { validate( @p, { foo => { can => 'cancan' } }, ); }; + + is( $@, q{} ); + + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + + like( $@, qr/does not have the method: 'thingy'/ ); +} + +{ + my @p = ( foo => undef ); + eval { validate( @p, { foo => { can => 'baz' } }, ); }; + + like( $@, qr/does not have the method: 'baz'/ ); +} + +{ + my $object = bless {}, 'ClassCan'; + my @p = ( foo => $object ); + + eval { validate( @p, { foo => { can => 'cancan' } }, ); }; + + is( $@, q{} ); + + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + + like( $@, qr/does not have the method: 'thingy'/ ); +} + +{ + my @p = ( foo => 'SubClass' ); + + eval { validate( @p, { foo => { can => 'cancan' } }, ); }; + + is( $@, q{}, 'SubClass->can(cancan)' ); + + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + + like( $@, qr/does not have the method: 'thingy'/ ); +} + +{ + my $object = bless {}, 'SubClass'; + my @p = ( foo => $object ); + + eval { validate( @p, { foo => { can => 'cancan' } }, ); }; + + is( $@, q{}, 'SubClass object->can(cancan)' ); + + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + + like( $@, qr/does not have the method: 'thingy'/ ); +} + +{ + my @p = ( foo => {} ); + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + like( $@, qr/does not have the method: 'thingy'/, 'unblessed ref ->can' ); + + @p = ( foo => 27 ); + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + like( $@, qr/does not have the method: 'thingy'/, 'number can' ); + + @p = ( foo => 'A String' ); + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + like( $@, qr/does not have the method: 'thingy'/, 'string can' ); + + @p = ( foo => undef ); + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + like( $@, qr/does not have the method: 'thingy'/, 'undef can' ); +} + +done_testing(); + +package ClassCan; + +sub can { + return 1 if $_[1] eq 'cancan'; + return 0; +} + +sub thingy {1} + +package SubClass; + +use base 'ClassCan'; diff --git a/t/22-overload-can-bug.t b/t/22-overload-can-bug.t new file mode 100644 index 0000000..44d81e8 --- /dev/null +++ b/t/22-overload-can-bug.t @@ -0,0 +1,37 @@ +use strict; +use warnings; + +use Params::Validate qw(validate); +use Test::More; + +{ + package Overloaded; + + use overload 'bool' => sub {0}; + + sub new { bless {} } + + sub foo {1} +} + +my $ovl = Overloaded->new; + +{ + eval { + my @p = ( object => $ovl ); + validate( @p, { object => { isa => 'Overloaded' } } ); + }; + + is( $@, q{}, 'overloaded object->isa' ); +} + +{ + eval { + my @p = ( object => $ovl ); + validate( @p, { object => { can => 'foo' } } ); + }; + + is( $@, q{}, 'overloaded object->foo' ); +} + +done_testing(); diff --git a/t/23-readonly.t b/t/23-readonly.t new file mode 100644 index 0000000..a8b7ced --- /dev/null +++ b/t/23-readonly.t @@ -0,0 +1,39 @@ +use strict; +use warnings; + +use Test::Requires { + Readonly => '1.03', + 'Scalar::Util' => '1.20', +}; + +use Params::Validate qw(validate validate_pos SCALAR); +use Test::More; + +plan skip_all => 'These tests fail with Readonly 1.50 for some reason' + if Readonly::->VERSION() =~ /^v?1.5/; + +{ + Readonly my $spec => { foo => 1 }; + my @p = ( foo => 'hello' ); + + eval { validate( @p, $spec ) }; + is( $@, q{}, 'validate() call succeeded with Readonly spec hashref' ); +} + +{ + Readonly my $spec => { type => SCALAR }; + my @p = 'hello'; + + eval { validate_pos( @p, $spec ) }; + is( $@, q{}, 'validate_pos() call succeeded with Readonly spec hashref' ); +} + +{ + Readonly my %spec => ( foo => { type => SCALAR } ); + my @p = ( foo => 'hello' ); + + eval { validate( @p, \%spec ) }; + is( $@, q{}, 'validate() call succeeded with Readonly spec hash' ); +} + +done_testing(); diff --git a/t/24-tied.t b/t/24-tied.t new file mode 100644 index 0000000..85b6825 --- /dev/null +++ b/t/24-tied.t @@ -0,0 +1,121 @@ +use strict; +use warnings; + +use Params::Validate qw(validate validate_pos SCALAR); +use Test::More; + +{ + package Tie::SimpleArray; + use Tie::Array; + use base 'Tie::StdArray'; +} + +{ + + package Tie::SimpleHash; + use Tie::Hash; + use base 'Tie::StdHash'; +} + +{ + tie my @p, 'Tie::SimpleArray'; + + my %spec = ( foo => 1 ); + push @p, ( foo => 'hello' ); + + eval { validate( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate() call succeeded with tied params array and regular hashref spec' + ); +} + +SKIP: +{ + skip 'Params::Validate segfaults with tied hash for spec', 1; + + my @p; + tie my %spec, 'Tie::SimpleHash'; + + $spec{foo} = 1; + push @p, ( foo => 'hello' ); + + eval { validate( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate() call succeeded with regular params array and tied hashref spec' + ); +} + +SKIP: +{ + skip 'Params::Validate segfaults with tied hash for spec', 1; + + tie my @p, 'Tie::SimpleArray'; + tie my %spec, 'Tie::SimpleHash'; + + $spec{foo} = 1; + push @p, ( foo => 'hello' ); + + eval { validate( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate() call succeeded with tied params array and tied hashref spec' + ); +} + +{ + tie my @p, 'Tie::SimpleArray'; + my %spec; + + $spec{type} = SCALAR; + push @p, 'hello'; + + eval { validate_pos( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate_pos() call succeeded with tied params array and regular hashref spec' + ); +} + +SKIP: +{ + skip 'Params::Validate segfaults with tied hash for spec', 1; + + my @p; + tie my %spec, 'Tie::SimpleHash'; + + $spec{type} = SCALAR; + push @p, 'hello'; + + eval { validate_pos( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate_pos() call succeeded with regular params array and tied hashref spec' + ); +} + +SKIP: +{ + skip 'Params::Validate segfaults with tied hash for spec', 1; + + tie my @p, 'Tie::SimpleArray'; + tie my %spec, 'Tie::SimpleHash'; + + $spec{type} = SCALAR; + push @p, 'hello'; + + eval { validate_pos( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate_pos() call succeeded with tied params array and tied hashref spec' + ); +} + +done_testing(); diff --git a/t/25-undef-regex.t b/t/25-undef-regex.t new file mode 100644 index 0000000..64fe996 --- /dev/null +++ b/t/25-undef-regex.t @@ -0,0 +1,17 @@ +use strict; +use warnings; + +use Params::Validate qw(validate); +use Test::More; + +{ + my @w; + local $SIG{__WARN__} = sub { push @w, @_ }; + + my @p = ( foo => undef ); + eval { validate( @p, { foo => { regex => qr/^bar/ } } ) }; + ok( $@, 'validation failed' ); + ok( !@w, 'no warnings' ); +} + +done_testing(); diff --git a/t/26-isa.t b/t/26-isa.t new file mode 100644 index 0000000..cd38c06 --- /dev/null +++ b/t/26-isa.t @@ -0,0 +1,89 @@ +use strict; +use warnings; + +use Params::Validate qw(validate); +use Test::More; + +{ + my @p = ( foo => 'ClassISA' ); + + eval { validate( @p, { foo => { isa => 'FooBar' } }, ); }; + + is( $@, q{}, 'no error checking if ClassISA->isa(FooBar)' ); + + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + + like( $@, qr/was not a 'Thingy'/ ); +} + +{ + my @p = ( foo => undef ); + eval { validate( @p, { foo => { isa => 'FooBar' } }, ); }; + + like( $@, qr/was not a 'FooBar'/ ); +} + +{ + my @p = ( foo => 'SubClass' ); + + eval { validate( @p, { foo => { isa => 'ClassISA' } }, ); }; + + is( $@, q{}, 'SubClass->isa(ClassISA)' ); + + eval { validate( @p, { foo => { isa => 'FooBar' } }, ); }; + + is( $@, q{}, 'SubClass->isa(FooBar)' ); + + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + + like( $@, qr/was not a 'Thingy'/ ); +} + +{ + my @p = ( foo => bless {}, 'SubClass' ); + + eval { validate( @p, { foo => { isa => 'ClassISA' } }, ); }; + + is( $@, q{}, 'SubClass->isa(ClassISA)' ); + + eval { validate( @p, { foo => { isa => 'FooBar' } }, ); }; + + is( $@, q{}, 'SubClass->isa(FooBar)' ); + + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + + like( $@, qr/was not a 'Thingy'/ ); +} + +{ + my @p = ( foo => {} ); + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + like( $@, qr/was not a 'Thingy'/, 'unblessed ref ->isa' ); + + @p = ( foo => 27 ); + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + like( $@, qr/was not a 'Thingy'/, 'number isa' ); + + @p = ( foo => 'A String' ); + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + like( $@, qr/was not a 'Thingy'/, 'string isa' ); + + @p = ( foo => undef ); + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + like( $@, qr/was not a 'Thingy'/, 'undef isa' ); +} + +done_testing(); + +package ClassISA; + +sub isa { + return 1 if $_[1] eq 'FooBar'; + return $_[0]->SUPER::isa( $_[1] ); +} + +sub thingy {1} + +package SubClass; + +use base 'ClassISA'; diff --git a/t/27-string-as-type.t b/t/27-string-as-type.t new file mode 100644 index 0000000..45795cd --- /dev/null +++ b/t/27-string-as-type.t @@ -0,0 +1,30 @@ +use strict; +use warnings; + +use Params::Validate qw(validate); +use Test::More; + +{ + my @p = ( foo => 1 ); + + eval { validate( @p, { foo => { type => 'SCALAR' } }, ); }; + + like( + $@, + qr/\QThe 'foo' parameter ("1") has a type specification which is not a number. It is a string - SCALAR/ + ); +} + +{ + my @p = ( foo => 1 ); + + eval { validate( @p, { foo => { type => undef } }, ); }; + + like( + $@, + qr/\QThe 'foo' parameter ("1") has a type specification which is not a number. It is undef/ + ); + +} + +done_testing(); diff --git a/t/28-readonly-return.t b/t/28-readonly-return.t new file mode 100644 index 0000000..37fc042 --- /dev/null +++ b/t/28-readonly-return.t @@ -0,0 +1,93 @@ +use strict; +use warnings; +use Test::More; + +use Devel::Peek qw( SvREFCNT ); +use File::Temp qw( tempfile ); +use Params::Validate qw( validate SCALAR HANDLE ); + +{ + my $fh = tempfile(); + my @p = ( + foo => 1, + bar => $fh, + ); + + my $ref = val1(@p); + + eval { $ref->{foo} = 2 }; + ok( !$@, 'returned hashref values are not read only' ); + is( $ref->{foo}, 2, 'double check that setting value worked' ); + is( $fh, $ref->{bar}, 'filehandle is not copied during validation' ); +} + +{ + + package ScopeTest; + + my $live = 0; + + sub new { $live++; bless {}, shift } + sub DESTROY { $live-- } + + sub Live {$live} +} + +{ + my @p = ( foo => ScopeTest->new() ); + + is( + ScopeTest->Live(), 1, + 'one live object' + ); + + my $ref = val2(@p); + + isa_ok( $ref->{foo}, 'ScopeTest' ); + + @p = (); + + is( + ScopeTest->Live(), 1, + 'still one live object' + ); + + ok( + defined $ref->{foo}, + 'foo key stays in scope after original version goes out of scope' + ); + is( + SvREFCNT( $ref->{foo} ), 1, + 'ref count for reference is 1' + ); + + undef $ref->{foo}; + + is( + ScopeTest->Live(), 0, + 'no live objects' + ); +} + +sub val1 { + my $ref = validate( + @_, { + foo => { type => SCALAR }, + bar => { type => HANDLE, optional => 1 }, + }, + ); + + return $ref; +} + +sub val2 { + my $ref = validate( + @_, { + foo => 1, + }, + ); + + return $ref; +} + +done_testing(); diff --git a/t/29-taint-mode.t b/t/29-taint-mode.t new file mode 100644 index 0000000..9db983f --- /dev/null +++ b/t/29-taint-mode.t @@ -0,0 +1,53 @@ +#!perl -T + +use strict; +use warnings; + +use Test::Requires { + 'Test::Taint' => 0.02, +}; + +use Test::Fatal; +use Test::More; + +use Params::Validate qw( validate validate_pos ARRAYREF ); + +taint_checking_ok('These tests are meaningless unless we are in taint mode.'); + +sub test1 { + my $def = $0; + tainted_ok( $def, 'make sure $def is tainted' ); + + # The spec is irrelevant, all that matters is that there's a + # tainted scalar as the default + my %p = validate( @_, { foo => { default => $def } } ); +} + +{ + is( + exception { test1() }, + undef, + 'no taint error when we validate with tainted default value' + ); +} + +sub test2 { + return validate_pos( @_, { regex => qr/^b/ } ); +} + +SKIP: +{ + skip 'This test only passes on Perl 5.14+', 1 + unless $] >= 5.014; + + my @p = 'cat'; + taint(@p); + + like( + exception { test2(@p) }, + qr/\QParameter #1 ("cat") to main::test2 did not pass regex check/, + 'no taint error when we validate with tainted value values being validated' + ); +} + +done_testing(); diff --git a/t/30-hashref-alteration.t b/t/30-hashref-alteration.t new file mode 100644 index 0000000..116353f --- /dev/null +++ b/t/30-hashref-alteration.t @@ -0,0 +1,51 @@ +use strict; +use warnings; +use Test::More; + +use Params::Validate qw( validate SCALAR ); + +{ + my $p = { foo => 1 }; + + val($p); + + is_deeply( + $p, { foo => 1 }, + 'validate does not alter hashref passed to val' + ); + + val2($p); + + is_deeply( + $p, { foo => 1 }, + 'validate does not alter hashref passed to val, even with defaults being supplied' + ); +} + +sub val { + validate( + @_, { + foo => { optional => 1 }, + bar => { optional => 1 }, + baz => { optional => 1 }, + buz => { optional => 1 }, + }, + ); + + return; +} + +sub val2 { + validate( + @_, { + foo => { optional => 1 }, + bar => { default => 42 }, + baz => { optional => 1 }, + buz => { optional => 1 }, + }, + ); + + return; +} + +done_testing(); diff --git a/t/31-incorrect-spelling.t b/t/31-incorrect-spelling.t new file mode 100644 index 0000000..66cad86 --- /dev/null +++ b/t/31-incorrect-spelling.t @@ -0,0 +1,61 @@ +#!/usr/bin/perl -w + +use strict; +use warnings; + +use Test::More; + +use Params::Validate qw( validate validate_pos SCALAR ); + +plan skip_all => 'Spec validation is disabled for now'; + +{ + my @p = ( foo => 1, bar => 2 ); + + eval { + validate( + @p, { + foo => { + type => SCALAR, + callbucks => { + 'one' => sub {1} + }, + }, + bar => { type => SCALAR }, + } + ); + }; + + like( $@, qr/is not an allowed validation spec key/ ); + + eval { + validate( + @p, { + foo => { + hype => SCALAR, + callbacks => { + 'one' => sub {1} + }, + }, + bar => { type => SCALAR }, + } + ); + }; + + like( $@, qr/is not an allowed validation spec key/ ); + eval { + validate( + @p, { + foo => { + type => SCALAR, + regexp => qr/^\d+$/, + }, + bar => { type => SCALAR }, + } + ); + }; + + like( $@, qr/is not an allowed validation spec key/ ); +} + +done_testing(); diff --git a/t/32-regex-as-value.t b/t/32-regex-as-value.t new file mode 100644 index 0000000..bbd0640 --- /dev/null +++ b/t/32-regex-as-value.t @@ -0,0 +1,37 @@ +use strict; +use warnings; + +use Params::Validate qw( validate SCALAR SCALARREF ); + +use Test::More; +use Test::Fatal; + +is( + exception { v( foo => qr/foo/ ) }, + undef, + 'no exception with regex object' +); + +is( + exception { v( foo => 'foo' ) }, + undef, + 'no exception with plain scalar' +); + +my $foo = 'foo'; +is( + exception { v( foo => \$foo ) }, + undef, + 'no exception with scalar ref' +); + +done_testing(); + +sub v { + validate( + @_, { + foo => { type => SCALAR | SCALARREF }, + }, + ); + return; +} diff --git a/t/33-keep-errsv.t b/t/33-keep-errsv.t new file mode 100644 index 0000000..8c0324e --- /dev/null +++ b/t/33-keep-errsv.t @@ -0,0 +1,23 @@ +use strict; +use warnings; + +use Params::Validate qw( validate SCALAR ); + +use Test::More; + +{ + $@ = 'foo'; + v( bar => 42 ); + + is( + $@, + 'foo', + 'calling validate() does not clobber' + ); +} + +done_testing(); + +sub v { + validate( @_, { bar => { type => SCALAR } } ); +} diff --git a/t/34-recursive-validation.t b/t/34-recursive-validation.t new file mode 100644 index 0000000..fbf26e6 --- /dev/null +++ b/t/34-recursive-validation.t @@ -0,0 +1,54 @@ +use strict; +use warnings; + +use Test::Fatal; +use Test::More; + +{ + package Foo; + + use Params::Validate qw( validate SCALAR ); + + Params::Validate::validation_options( allow_extra => 1 ); + + sub test_foo { + my %p = validate( @_, { arg1 => { type => SCALAR } } ); + print "test foo\n"; + } +} + +{ + package Bar; + + use Params::Validate qw( validate SCALAR ); + Params::Validate::validation_options( allow_extra => 0 ); + + sub test_bar { + + # catch die signal + local $SIG{__DIE__} = sub { + + # we died from within Params::Validate (because of wrong_Arg) we + # call Foo::test_foo with OK args, but it'll die, because + # Params::Validate::PP::options is still set to the options of the + # Bar package, and so it won't retreive the one from Foo. + Foo::test_foo( arg1 => 1, extra_arg => 2 ); + }; + + # this will die because the arg received is 'wrong_arg' + my %p = validate( @_, { arg1 => { type => SCALAR } } ); + } +} + +{ + # This bug only manifests with the pure Perl code because of its use of local + # to remember the per-package options. + local $TODO = 'Not sure how to fix this one'; + unlike( + exception { Bar::test_bar( bad_arg => 2 ) }, + qr/was passed in the call to Foo::test_foo/, + 'no exception from Foo::test_foo when when calling validate() from within a __DIE__ handler' + ); +} + +done_testing(); diff --git a/t/35-default-xs-bug.t b/t/35-default-xs-bug.t new file mode 100644 index 0000000..7867db5 --- /dev/null +++ b/t/35-default-xs-bug.t @@ -0,0 +1,21 @@ +use strict; +use warnings; + +use Test::More 0.88; + +use Params::Validate qw( :all ); + +default_test(); + +done_testing(); + +sub default_test { + my ( $first, $second ) = validate_pos( + @_, + { type => SCALAR, optional => 1 }, + { type => SCALAR, optional => 1, default => 'must be second one' }, + ); + + is( $first, undef, '01 no default for first' ); + is( $second, 'must be second one', '01 default for second' ); +} diff --git a/t/36-large-arrays.t b/t/36-large-arrays.t new file mode 100644 index 0000000..7014e0d --- /dev/null +++ b/t/36-large-arrays.t @@ -0,0 +1,42 @@ +use strict; +use warnings; + +use Test::Fatal; +use Test::More; + +{ + package Foo; + + use Params::Validate qw( validate ARRAYREF ); + + sub v1 { + my %p = validate( + @_, { + array => { + callbacks => { + 'checking array contents' => sub { + for my $x ( @{ $_[0] } ) { + return 0 unless defined $x && !ref $x; + } + return 1; + }, + } + } + } + ); + return $p{array}; + } +} + +{ + for my $size ( 100, 1_000, 100_000 ) { + my @array = ('x') x $size; + is_deeply( + Foo::v1( array => \@array ), + \@array, + "validate() handles $size element array correctly" + ); + } +} + +done_testing(); diff --git a/t/37-exports.t b/t/37-exports.t new file mode 100644 index 0000000..4715090 --- /dev/null +++ b/t/37-exports.t @@ -0,0 +1,52 @@ +use strict; +use warnings; + +use Test::More; +use Params::Validate (); + +my @types = qw( + SCALAR + ARRAYREF + HASHREF + CODEREF + GLOB + GLOBREF + SCALARREF + HANDLE + BOOLEAN + UNDEF + OBJECT +); + +my @subs = qw( + validate + validate_pos + validation_options + validate_with +); + +is_deeply( + [ sort @Params::Validate::EXPORT_OK ], + [ sort @types, @subs, 'set_options' ], + '@EXPORT_OK' +); + +is_deeply( + [ sort keys %Params::Validate::EXPORT_TAGS ], + [qw( all types )], + 'keys %EXPORT_TAGS' +); + +is_deeply( + [ sort @{ $Params::Validate::EXPORT_TAGS{all} } ], + [ sort @types, @subs ], + '$EXPORT_TAGS{all}', +); + +is_deeply( + [ sort @{ $Params::Validate::EXPORT_TAGS{types} } ], + [ sort @types ], + '$EXPORT_TAGS{types}', +); + +done_testing(); diff --git a/t/38-callback-message.t b/t/38-callback-message.t new file mode 100644 index 0000000..c330d58 --- /dev/null +++ b/t/38-callback-message.t @@ -0,0 +1,113 @@ +use strict; +use warnings; + +use Test::More; +use Params::Validate qw( validate ); + +{ + my $e = _test_args( + pos_int => 42, + string => 'foo', + ); + is( + $e, + q{}, + 'no error with good args' + ); +} + +{ + my $e = _test_args( + pos_int => 42, + string => [], + ); + like( + $e, + qr/The 'string' parameter \("ARRAY\(.+\)"\) to main::validate1 did not pass the 'string' callback: ARRAY\(.+\) is not a string/, + 'got error for bad string' + ); +} + +{ + my $e = _test_args( + pos_int => 0, + string => 'foo', + ); + like( + $e, + qr/\QThe 'pos_int' parameter ("0") to main::validate1 did not pass the 'pos_int' callback: 0 is not a positive integer/, + 'got error for bad pos int (0)' + ); +} + +{ + my $e = _test_args( + pos_int => 'bar', + string => 'foo', + ); + like( + $e, + qr/\QThe 'pos_int' parameter ("bar") to main::validate1 did not pass the 'pos_int' callback: bar is not a positive integer/, + 'got error for bad pos int (bar)' + ); +} + +{ + my $e = do { + local $@; + eval { validate2( string => [] ); }; + $@; + }; + + is_deeply( + $e, + { error => 'not a string' }, + 'ref thrown by callback is preserved, not stringified' + ); +} + +sub _test_args { + local $@; + eval { validate1(@_) }; + return $@; +} + +sub validate1 { + validate( + @_, { + pos_int => { + callbacks => { + pos_int => sub { + $_[0] =~ /^[1-9][0-9]*$/ + or die "$_[0] is not a positive integer\n"; + }, + }, + }, + string => { + callbacks => { + string => sub { + ( defined $_[0] && !ref $_[0] && length $_[0] ) + or die "$_[0] is not a string\n"; + }, + }, + }, + } + ); +} + +sub validate2 { + validate( + @_, { + string => { + callbacks => { + string => sub { + ( defined $_[0] && !ref $_[0] && length $_[0] ) + or die { error => 'not a string' }; + }, + }, + }, + } + ); +} + +done_testing(); diff --git a/t/author-00-compile.t b/t/author-00-compile.t new file mode 100644 index 0000000..e2a109f --- /dev/null +++ b/t/author-00-compile.t @@ -0,0 +1,68 @@ + +BEGIN { + unless ($ENV{AUTHOR_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for testing by the author'); + } +} + +use 5.006; +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::Compile 2.053 + +use Test::More; + +plan tests => 8; + +my @module_files = ( + 'Attribute/Params/Validate.pm', + 'Params/Validate.pm', + 'Params/Validate/Constants.pm', + 'Params/Validate/PP.pm', + 'Params/Validate/XS.pm', + 'Params/ValidatePP.pm', + 'Params/ValidateXS.pm' +); + + + +# no fake home requested + +my $inc_switch = -d 'blib' ? '-Mblib' : '-Ilib'; + +use File::Spec; +use IPC::Open3; +use IO::Handle; + +open my $stdin, '<', File::Spec->devnull or die "can't open devnull: $!"; + +my @warnings; +for my $lib (@module_files) +{ + # see L<perlfaq8/How can I capture STDERR from an external command?> + my $stderr = IO::Handle->new; + + my $pid = open3($stdin, '>&STDERR', $stderr, $^X, $inc_switch, '-e', "require q[$lib]"); + binmode $stderr, ':crlf' if $^O eq 'MSWin32'; + my @_warnings = <$stderr>; + waitpid($pid, 0); + is($?, 0, "$lib loaded ok"); + + shift @_warnings if @_warnings and $_warnings[0] =~ /^Using .*\bblib/ + and not eval { blib->VERSION('1.01') }; + + if (@_warnings) + { + warn @_warnings; + push @warnings, @_warnings; + } +} + + + +is(scalar(@warnings), 0, 'no warnings found') + or diag 'got warnings: ', ( Test::More->can('explain') ? Test::More::explain(\@warnings) : join("\n", '', @warnings) ); + + diff --git a/t/author-eol.t b/t/author-eol.t new file mode 100644 index 0000000..a7eade1 --- /dev/null +++ b/t/author-eol.t @@ -0,0 +1,126 @@ + +BEGIN { + unless ($ENV{AUTHOR_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for testing by the author'); + } +} + +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::EOL 0.18 + +use Test::More 0.88; +use Test::EOL; + +my @files = ( + 'lib/Attribute/Params/Validate.pm', + 'lib/Params/Validate.pm', + 'lib/Params/Validate/Constants.pm', + 'lib/Params/Validate/PP.pm', + 'lib/Params/Validate/XS.pm', + 'lib/Params/ValidatePP.pm', + 'lib/Params/ValidateXS.pm', + 't/00-report-prereqs.dd', + 't/00-report-prereqs.t', + 't/01-validate.t', + 't/02-noop.t', + 't/03-attribute.t', + 't/04-defaults.t', + 't/05-noop_default.t', + 't/06-options.t', + 't/07-with.t', + 't/08-noop_with.t', + 't/09-regex.t', + 't/10-noop_regex.t', + 't/11-cb.t', + 't/12-noop_cb.t', + 't/13-taint.t', + 't/14-no_validate.t', + 't/15-case.t', + 't/16-normalize.t', + 't/17-callbacks.t', + 't/18-depends.t', + 't/19-untaint.t', + 't/21-can.t', + 't/22-overload-can-bug.t', + 't/23-readonly.t', + 't/24-tied.t', + 't/25-undef-regex.t', + 't/26-isa.t', + 't/27-string-as-type.t', + 't/28-readonly-return.t', + 't/29-taint-mode.t', + 't/30-hashref-alteration.t', + 't/31-incorrect-spelling.t', + 't/32-regex-as-value.t', + 't/33-keep-errsv.t', + 't/34-recursive-validation.t', + 't/35-default-xs-bug.t', + 't/36-large-arrays.t', + 't/37-exports.t', + 't/38-callback-message.t', + 't/author-00-compile.t', + 't/author-eol.t', + 't/author-no-tabs.t', + 't/author-pod-spell.t', + 't/lib/PVTests.pm', + 't/lib/PVTests/Callbacks.pm', + 't/lib/PVTests/Defaults.pm', + 't/lib/PVTests/Regex.pm', + 't/lib/PVTests/Standard.pm', + 't/lib/PVTests/With.pm', + 't/release-cpan-changes.t', + 't/release-memory-leak.t', + 't/release-pod-coverage.t', + 't/release-pod-linkcheck.t', + 't/release-pod-no404s.t', + 't/release-pod-syntax.t', + 't/release-portability.t', + 't/release-pp-01-validate.t', + 't/release-pp-02-noop.t', + 't/release-pp-03-attribute.t', + 't/release-pp-04-defaults.t', + 't/release-pp-05-noop_default.t', + 't/release-pp-06-options.t', + 't/release-pp-07-with.t', + 't/release-pp-08-noop_with.t', + 't/release-pp-09-regex.t', + 't/release-pp-10-noop_regex.t', + 't/release-pp-11-cb.t', + 't/release-pp-12-noop_cb.t', + 't/release-pp-13-taint.t', + 't/release-pp-14-no_validate.t', + 't/release-pp-15-case.t', + 't/release-pp-16-normalize.t', + 't/release-pp-17-callbacks.t', + 't/release-pp-18-depends.t', + 't/release-pp-19-untaint.t', + 't/release-pp-21-can.t', + 't/release-pp-22-overload-can-bug.t', + 't/release-pp-23-readonly.t', + 't/release-pp-24-tied.t', + 't/release-pp-25-undef-regex.t', + 't/release-pp-26-isa.t', + 't/release-pp-27-string-as-type.t', + 't/release-pp-28-readonly-return.t', + 't/release-pp-29-taint-mode.t', + 't/release-pp-30-hashref-alteration.t', + 't/release-pp-31-incorrect-spelling.t', + 't/release-pp-32-regex-as-value.t', + 't/release-pp-33-keep-errsv.t', + 't/release-pp-34-recursive-validation.t', + 't/release-pp-35-default-xs-bug.t', + 't/release-pp-36-large-arrays.t', + 't/release-pp-37-exports.t', + 't/release-pp-38-callback-message.t', + 't/release-pp-is-loaded.t', + 't/release-synopsis.t', + 't/release-xs-is-loaded.t', + 't/release-xs-segfault.t', + 't/release-xs-stack-realloc.t' +); + +eol_unix_ok($_, { trailing_whitespace => 1 }) foreach @files; +done_testing; diff --git a/t/author-no-tabs.t b/t/author-no-tabs.t new file mode 100644 index 0000000..dfaba7c --- /dev/null +++ b/t/author-no-tabs.t @@ -0,0 +1,126 @@ + +BEGIN { + unless ($ENV{AUTHOR_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for testing by the author'); + } +} + +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::NoTabs 0.15 + +use Test::More 0.88; +use Test::NoTabs; + +my @files = ( + 'lib/Attribute/Params/Validate.pm', + 'lib/Params/Validate.pm', + 'lib/Params/Validate/Constants.pm', + 'lib/Params/Validate/PP.pm', + 'lib/Params/Validate/XS.pm', + 'lib/Params/ValidatePP.pm', + 'lib/Params/ValidateXS.pm', + 't/00-report-prereqs.dd', + 't/00-report-prereqs.t', + 't/01-validate.t', + 't/02-noop.t', + 't/03-attribute.t', + 't/04-defaults.t', + 't/05-noop_default.t', + 't/06-options.t', + 't/07-with.t', + 't/08-noop_with.t', + 't/09-regex.t', + 't/10-noop_regex.t', + 't/11-cb.t', + 't/12-noop_cb.t', + 't/13-taint.t', + 't/14-no_validate.t', + 't/15-case.t', + 't/16-normalize.t', + 't/17-callbacks.t', + 't/18-depends.t', + 't/19-untaint.t', + 't/21-can.t', + 't/22-overload-can-bug.t', + 't/23-readonly.t', + 't/24-tied.t', + 't/25-undef-regex.t', + 't/26-isa.t', + 't/27-string-as-type.t', + 't/28-readonly-return.t', + 't/29-taint-mode.t', + 't/30-hashref-alteration.t', + 't/31-incorrect-spelling.t', + 't/32-regex-as-value.t', + 't/33-keep-errsv.t', + 't/34-recursive-validation.t', + 't/35-default-xs-bug.t', + 't/36-large-arrays.t', + 't/37-exports.t', + 't/38-callback-message.t', + 't/author-00-compile.t', + 't/author-eol.t', + 't/author-no-tabs.t', + 't/author-pod-spell.t', + 't/lib/PVTests.pm', + 't/lib/PVTests/Callbacks.pm', + 't/lib/PVTests/Defaults.pm', + 't/lib/PVTests/Regex.pm', + 't/lib/PVTests/Standard.pm', + 't/lib/PVTests/With.pm', + 't/release-cpan-changes.t', + 't/release-memory-leak.t', + 't/release-pod-coverage.t', + 't/release-pod-linkcheck.t', + 't/release-pod-no404s.t', + 't/release-pod-syntax.t', + 't/release-portability.t', + 't/release-pp-01-validate.t', + 't/release-pp-02-noop.t', + 't/release-pp-03-attribute.t', + 't/release-pp-04-defaults.t', + 't/release-pp-05-noop_default.t', + 't/release-pp-06-options.t', + 't/release-pp-07-with.t', + 't/release-pp-08-noop_with.t', + 't/release-pp-09-regex.t', + 't/release-pp-10-noop_regex.t', + 't/release-pp-11-cb.t', + 't/release-pp-12-noop_cb.t', + 't/release-pp-13-taint.t', + 't/release-pp-14-no_validate.t', + 't/release-pp-15-case.t', + 't/release-pp-16-normalize.t', + 't/release-pp-17-callbacks.t', + 't/release-pp-18-depends.t', + 't/release-pp-19-untaint.t', + 't/release-pp-21-can.t', + 't/release-pp-22-overload-can-bug.t', + 't/release-pp-23-readonly.t', + 't/release-pp-24-tied.t', + 't/release-pp-25-undef-regex.t', + 't/release-pp-26-isa.t', + 't/release-pp-27-string-as-type.t', + 't/release-pp-28-readonly-return.t', + 't/release-pp-29-taint-mode.t', + 't/release-pp-30-hashref-alteration.t', + 't/release-pp-31-incorrect-spelling.t', + 't/release-pp-32-regex-as-value.t', + 't/release-pp-33-keep-errsv.t', + 't/release-pp-34-recursive-validation.t', + 't/release-pp-35-default-xs-bug.t', + 't/release-pp-36-large-arrays.t', + 't/release-pp-37-exports.t', + 't/release-pp-38-callback-message.t', + 't/release-pp-is-loaded.t', + 't/release-synopsis.t', + 't/release-xs-is-loaded.t', + 't/release-xs-segfault.t', + 't/release-xs-stack-realloc.t' +); + +notabs_ok($_) foreach @files; +done_testing; diff --git a/t/author-pod-spell.t b/t/author-pod-spell.t new file mode 100644 index 0000000..f9c5646 --- /dev/null +++ b/t/author-pod-spell.t @@ -0,0 +1,64 @@ + +BEGIN { + unless ($ENV{AUTHOR_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for testing by the author'); + } +} + +use strict; +use warnings; +use Test::More; + +# generated by Dist::Zilla::Plugin::Test::PodSpelling 2.006009 +use Test::Spelling 0.12; +use Pod::Wordlist; + + +add_stopwords(<DATA>); +all_pod_files_spelling_ok( qw( bin lib ) ); +__DATA__ +DROLSKY +DROLSKY's +Rolsky +Rolsky's +API +CPAN +GLOBREF +OO +PayPal +SCALARREF +ValidatePos +baz +onwards +pre +runtime +Dave +autarch +Ilya +Martynov +ilya +and +Ivan +Bessarabov +ivan +Mash +jmash +Noel +Maddy +zhtwnpanta +Olivier +Mengué +dolmen +Vincent +Pit +perl +lib +Attribute +Params +Validate +Constants +PP +XS +ValidatePP +ValidateXS diff --git a/t/lib/PVTests.pm b/t/lib/PVTests.pm new file mode 100644 index 0000000..0d1b54b --- /dev/null +++ b/t/lib/PVTests.pm @@ -0,0 +1,8 @@ +package PVTests; + +use strict; +use warnings; + +use Test::More; + +1; diff --git a/t/lib/PVTests/Callbacks.pm b/t/lib/PVTests/Callbacks.pm new file mode 100644 index 0000000..c45b4fb --- /dev/null +++ b/t/lib/PVTests/Callbacks.pm @@ -0,0 +1,82 @@ +package PVTests::Callbacks; + +use strict; +use warnings; + +use Params::Validate qw(:all); + +use PVTests; +use Test::More; + +sub run_tests { + my %allowed = ( foo => 1, baz => 1 ); + eval { + my @a = ( foo => 'foo' ); + validate( + @a, { + foo => { + callbacks => { + is_allowed => sub { $allowed{ lc $_[0] } } + }, + } + } + ); + }; + is( $@, q{} ); + + eval { + my @a = ( foo => 'aksjgakl' ); + + validate( + @a, { + foo => { + callbacks => { + is_allowed => sub { $allowed{ lc $_[0] } } + }, + } + } + ); + }; + + if ( $ENV{PERL_NO_VALIDATION} ) { + is( $@, q{} ); + } + else { + like( $@, qr/is_allowed/ ); + } + + # duplicates code from Lingua::ZH::CCDICT that revealad bug fixed in + # 0.56. + eval { Foo->new( storage => 'InMemory', file => 'something' ); }; + is( $@, q{} ); + + done_testing(); +} + +package Foo; + +use Params::Validate qw(:all); + +my %storage = map { lc $_ => $_ } (qw( InMemory XML BerkeleyDB )); + +sub new { + my $class = shift; + + local $^W = 1; + + my %p = validate_with( + params => \@_, + spec => { + storage => { + callbacks => { + 'is a valid storage type' => sub { $storage{ lc $_[0] } } + }, + }, + }, + allow_extra => 1, + ); + + return 1; +} + +1; diff --git a/t/lib/PVTests/Defaults.pm b/t/lib/PVTests/Defaults.pm new file mode 100644 index 0000000..5d22099 --- /dev/null +++ b/t/lib/PVTests/Defaults.pm @@ -0,0 +1,166 @@ +package PVTests::Defaults; + +use strict; +use warnings; + +use Params::Validate qw(:all); + +use PVTests; +use Test::More; + +sub run_tests { + { + my %def = eval { foo() }; + + is( + $@, q{}, + 'No error calling foo()' + ); + + is( + $def{a}, 1, + q|Parameter 'a' was not altered| + ); + + is( + $def{b}, 2, + q|Parameter 'b' was not altered| + ); + + is( + $def{c}, 42, + q|Correct default assigned for parameter 'c'| + ); + + is( + $def{d}, 0, + q|Correct default assigned for parameter 'd'| + ); + } + + { + my $def = eval { foo() }; + + is( + $@, q{}, + 'No error calling foo()' + ); + + is( + $def->{a}, 1, + q|Parameter 'a' was not altered| + ); + + is( + $def->{b}, 2, + q|Parameter 'b' was not altered| + ); + + is( + $def->{c}, 42, + q|Correct default assigned for parameter 'c'| + ); + + is( + $def->{d}, 0, + q|Correct default assigned for parameter 'd'| + ); + } + + { + my @def = eval { bar() }; + + is( + $@, q{}, + 'No error calling bar()' + ); + + is( + $def[0], 1, + '1st parameter was not altered' + ); + + is( + $def[1], 2, + '2nd parameter was not altered' + ); + + is( + $def[2], 42, + 'Correct default assigned for 3rd parameter' + ); + + is( + $def[3], 0, + 'Correct default assigned for 4th parameter' + ); + } + + { + my $def = eval { bar() }; + + is( + $@, q{}, + 'No error calling bar()' + ); + + is( + $def->[0], 1, + '1st parameter was not altered' + ); + + is( + $def->[1], 2, + '2nd parameter was not altered' + ); + + is( + $def->[2], 42, + 'Correct default assigned for 3rd parameter' + ); + + is( + $def->[3], 0, + 'Correct default assigned for 4th parameter' + ); + } + + { + my $spec = { foobar => { default => [] } }; + my $test1 = validate_with( params => [], spec => $spec ); + $test1->{foobar} = ['x']; + + my $test2 = validate_with( params => [], spec => $spec ); + $test2->{foobar} = ['y']; + + is( + $test1->{foobar}[0], 'x', + 'defaults pointing to a reference return a copy of that reference' + ); + } + + done_testing(); +} + +sub foo { + my @params = ( a => 1, b => 2 ); + return validate( + @params, { + a => 1, + b => { default => 99 }, + c => { optional => 1, default => 42 }, + d => { default => 0 }, + } + ); +} + +sub bar { + my @params = ( 1, 2 ); + + return validate_pos( + @params, 1, { default => 99 }, { default => 42 }, + { default => 0 } + ); +} + +1; diff --git a/t/lib/PVTests/Regex.pm b/t/lib/PVTests/Regex.pm new file mode 100644 index 0000000..3075427 --- /dev/null +++ b/t/lib/PVTests/Regex.pm @@ -0,0 +1,85 @@ +package PVTests::Regex; + +use strict; +use warnings; + +use Params::Validate qw(:all); + +use PVTests; +use Test::More; + +sub run_tests { + plan tests => 7; + + eval { + my @a = ( foo => 'bar' ); + validate( @a, { foo => { regex => '^bar$' } } ); + }; + is( $@, q{} ); + + eval { + my @a = ( foo => 'bar' ); + validate( @a, { foo => { regex => qr/^bar$/ } } ); + }; + is( $@, q{} ); + + eval { + my @a = ( foo => 'baz' ); + validate( @a, { foo => { regex => '^bar$' } } ); + }; + + if ( $ENV{PERL_NO_VALIDATION} ) { + is( $@, q{} ); + } + else { + like( $@, qr/'foo'.+did not pass regex check/ ); + } + + eval { + my @a = ( foo => 'baz' ); + validate( @a, { foo => { regex => qr/^bar$/ } } ); + }; + + if ( $ENV{PERL_NO_VALIDATION} ) { + is( $@, q{} ); + } + else { + like( $@, qr/'foo'.+did not pass regex check/ ); + } + + eval { + my @a = ( foo => 'baz', bar => 'quux' ); + validate( + @a, { + foo => { regex => qr/^baz$/ }, + bar => { regex => 'uqqx' }, + } + ); + }; + + if ( $ENV{PERL_NO_VALIDATION} ) { + is( $@, q{} ); + } + else { + like( $@, qr/'bar'.+did not pass regex check/ ); + } + + eval { + my @a = ( foo => 'baz', bar => 'quux' ); + validate( + @a, { + foo => { regex => qr/^baz$/ }, + bar => { regex => qr/^(?:not this|quux)$/ }, + } + ); + }; + is( $@, q{} ); + + eval { + my @a = ( foo => undef ); + validate( @a, { foo => { regex => qr/^$|^bubba$/ } } ); + }; + is( $@, q{} ); +} + +1; diff --git a/t/lib/PVTests/Standard.pm b/t/lib/PVTests/Standard.pm new file mode 100644 index 0000000..0c82ed4 --- /dev/null +++ b/t/lib/PVTests/Standard.pm @@ -0,0 +1,956 @@ +package PVTests::Standard; + +use strict; +use warnings; + +use Params::Validate qw(:all); + +use PVTests; +use Test::More 0.88; + +my $String = 'foo'; + +my ( $v1, $v2, $v3, $v4 ); +my $Foo = bless \$v1, 'Foo'; +my $Bar = bless \$v2, 'Bar'; +my $Baz = bless \$v3, 'Baz'; +my $Quux = bless \$v4, 'Quux'; + +my @Tests = ( + { + sub => 'sub1', + p => [ foo => 'a', bar => 'b' ], + expect => q{}, + }, + + { + sub => 'sub1', + p => [ foo => 'a' ], + expect => qr|^Mandatory parameter 'bar' missing|, + }, + + { + sub => 'sub1', + p => [], + expect => qr|^Mandatory parameters .* missing|, + }, + + { + sub => 'sub1', + p => [ foo => 'a', bar => 'b', baz => 'c' ], + expect => qr|^The following parameter .* baz|, + }, + + { + sub => 'sub2', + p => [ foo => 'a', bar => 'b', baz => 'c' ], + expect => q{}, + }, + + { + sub => 'sub2', + p => [ foo => 'a', bar => 'b' ], + expect => q{}, + }, + + { + sub => 'sub2a', + p => [ foo => 'a', bar => 'b' ], + expect => q{}, + }, + + { + sub => 'sub2a', + p => [ foo => 'a' ], + expect => q{}, + }, + + # simple types + { + sub => 'sub3', + p => [ + foo => 'a', + bar => [ 1, 2, 3 ], + baz => { a => 1 }, + quux => 'yadda', + brax => {qw( a b c d )}, + ], + expect => q{}, + }, + + { + sub => 'sub3', + p => [ + foo => ['a'], + bar => [ 1, 2, 3 ], + baz => { a => 1 }, + quux => 'yadda', + brax => {qw( a b c d )}, + ], + expect => + qr|^The 'foo' parameter \("ARRAY\(0x[a-f0-9]+\)"\) to [\w:]+sub3 was an 'arrayref'.* types: scalar|, + }, + + { + sub => 'sub3', + p => [ + foo => 'foobar', + bar => [ 1, 2, 3 ], + baz => { a => 1 }, + quux => 'yadda', + brax => [qw( a b c d )], + ], + expect => + qr|^The 'brax' parameter \("ARRAY\(0x[a-f0-9]+\)"\) to [\w:]+sub3 was an 'arrayref'.* types: scalar hash|, + }, + + { + sub => 'sub3', + p => [ + foo => 'foobar', + bar => { 1, 2, 3, 4 }, + baz => { a => 1 }, + quux => 'yadda', + brax => 'a', + ], + expect => + qr|^The 'bar' parameter \("HASH\(0x[a-f0-9]+\)"\) to [\w:]+sub3 was a 'hashref'.* types: arrayref|, + }, + + # more unusual types + { + sub => 'sub4', + p => [ + foo => \$String, + bar => do { local *FH; *FH; }, + baz => \*BAZZY, + quux => sub {'a coderef'}, + ], + expect => q{}, + }, + + { + sub => 'sub4', + p => [ + foo => \$String, + bar => \*BARRY, + baz => \*BAZZY, + quux => sub {'a coderef'}, + ], + expect => + qr|^The 'bar' parameter \("GLOB\(0x[a-f0-9]+\)"\) to [\w:]+sub4 was a 'globref'.* types: glob|, + }, + + { + sub => 'sub4', + p => [ + foo => \$String, + bar => *GLOBBY, + baz => do { local *FH; *FH; }, + quux => sub {'a coderef'}, + ], + expect => + qr|^The 'baz' parameter \((?:"\*[\w:]+FH"\|GLOB)\) to [\w:]+sub4 was a 'glob'.* types: globref|, + }, + + { + sub => 'sub4', + p => [ + foo => $String, + bar => do { local *FH; *FH; }, + baz => \*BAZZY, + quux => sub {'a coderef'}, + ], + expect => + qr|^The 'foo' parameter \("foo"\) to [\w:]+sub4 was a 'scalar'.* types: scalarref|, + }, + + { + sub => 'sub4', + p => [ + foo => \$String, + bar => do { local *FH; *FH; }, + baz => \*BAZZY, + quux => \*CODEREF, + ], + expect => + qr|^The 'quux' parameter \("GLOB\(0x[a-f0-9]+\)"\) to [\w:]+sub4 was a 'globref'.* types: coderef|, + }, + + # test HANDLE type + { + sub => 'sub4a', + p => [ foo => \*HANDLE ], + expect => q{}, + }, + + { + sub => 'sub4a', + p => [ foo => *HANDLE ], + expect => q{}, + }, + + { + sub => 'sub4a', + p => [ foo => ['not a handle'] ], + expect => + qr|^The 'foo' parameter \("ARRAY\(0x[a-f0-9]+\)"\) to [\w:]+sub4a was an 'arrayref'.* types: glob globref|, + }, + + # test BOOLEAN type + { + sub => 'sub4b', + p => [ foo => undef ], + expect => q{}, + }, + + { + sub => 'sub4b', + p => [ foo => 124125 ], + expect => q{}, + }, + + # isa + { + sub => 'sub5', + p => [ foo => $Foo ], + expect => q{}, + }, { + sub => 'sub5', + p => [ foo => $Bar ], + expect => q{}, + }, { + sub => 'sub5', + p => [ foo => $Baz ], + expect => q{}, + }, + + { + sub => 'sub6', + p => [ foo => $Foo ], + expect => + qr|^The 'foo' parameter \("Foo=SCALAR\(0x[a-f0-9]+\)"\) to [\w:]+sub6 was not a 'Bar'|, + }, { + sub => 'sub6', + p => [ foo => $Bar ], + expect => q{}, + }, { + sub => 'sub7', + p => [ foo => $Baz ], + expect => q{}, + }, + + { + sub => 'sub7', + p => [ foo => $Foo ], + expect => + qr|^The 'foo' parameter \("Foo=SCALAR\(0x[a-f0-9]+\)"\) to [\w:]+sub7 was not a 'Baz'|, + }, { + sub => 'sub7', + p => [ foo => $Bar ], + expect => + qr|^The 'foo' parameter \("Bar=SCALAR\(0x[a-f0-9]+\)"\) to [\w:]+sub7 was not a 'Baz'|, + }, { + sub => 'sub7', + p => [ foo => $Baz ], + expect => q{}, + }, + + { + sub => 'sub8', + p => [ foo => $Foo ], + expect => + qr|^The 'foo' parameter \("Foo=SCALAR\(0x[a-f0-9]+\)"\) to [\w:]+sub8 was not a 'Yadda'|, + }, + + { + sub => 'sub8', + p => [ foo => $Quux ], + expect => q{}, + }, + + # can + { + sub => 'sub9', + p => [ foo => $Foo ], + expect => q{}, + }, { + sub => 'sub9', + p => [ foo => $Quux ], + expect => q{}, + }, + + { + sub => 'sub9a', + p => [ foo => $Foo ], + expect => + qr|^The 'foo' parameter \("Foo=SCALAR\(0x[a-f0-9]+\)"\) to [\w:]+sub9a does not have the method: 'barify'|, + }, { + sub => 'sub9a', + p => [ foo => $Bar ], + expect => q{}, + }, + + { + sub => 'sub9b', + p => [ foo => $Baz ], + expect => + qr|^The 'foo' parameter \("Baz=SCALAR\(0x[a-f0-9]+\)"\) to [\w:]+sub9b does not have the method: 'yaddaify'|, + }, { + sub => 'sub9b', + p => [ foo => $Quux ], + expect => + qr|^The 'foo' parameter \("Quux=SCALAR\(0x[a-f0-9]+\)"\) to [\w:]+sub9b does not have the method: 'barify'|, + }, + + { + sub => 'sub9c', + p => [ foo => $Bar ], + expect => + qr|^The 'foo' parameter \("Bar=SCALAR\(0x[a-f0-9]+\)"\) to [\w:]+sub9c does not have the method: 'yaddaify'|, + }, + + { + sub => 'sub9c', + p => [ foo => $Quux ], + expect => q{}, + }, + + # callbacks + { + sub => 'sub10', + p => [ foo => 1 ], + expect => q{}, + }, + + { + sub => 'sub10', + p => [ foo => 19 ], + expect => q{}, + }, + + { + sub => 'sub10', + p => [ foo => 20 ], + expect => + qr|^The 'foo' parameter \("20"\) to [\w:]+sub10 did not pass the 'less than 20' callback|, + }, + + { + sub => 'sub11', + p => [ foo => 1 ], + expect => q{}, + }, { + sub => 'sub11', + p => [ foo => 20 ], + expect => + qr|^The 'foo' parameter \("20"\) to [\w:]+sub11 did not pass the 'less than 20' callback|, + }, + + { + sub => 'sub11', + p => [ foo => 0 ], + expect => + qr|^The 'foo' parameter \("0"\) to [\w:]+sub11 did not pass the 'more than 0' callback|, + }, + + # mix n' match + { + sub => 'sub12', + p => [ foo => 1 ], + expect => + qr|^The 'foo' parameter \("1"\) to [\w:]+sub12 was a 'scalar'.* types: arrayref|, + }, + + { + sub => 'sub12', + p => [ foo => [ 1, 2, 3 ] ], + expect => + qr|^The 'foo' parameter \("ARRAY\(0x[a-f0-9]+\)"\) to [\w:]+sub12 did not pass the '5 elements' callback|, + }, + + { + sub => 'sub12', + p => [ foo => [ 1, 2, 3, 4, 5 ] ], + expect => q{}, + }, + + # positional - 1 + { + sub => 'sub13', + p => ['a'], + expect => qr|^1 parameter was passed to .* but 2 were expected|, + }, + + { + sub => 'sub13', + p => [ 'a', [ 1, 2, 3 ] ], + expect => + qr|^Parameter #2 \("ARRAY\(0x[a-f0-9]+\)"\) to .* did not pass the '5 elements' callback|, + }, + + # positional - 2 + { + sub => 'sub14', + p => [ 'a', [ 1, 2, 3 ], $Foo ], + expect => + qr|^Parameter #3 \("Foo=SCALAR\(0x[a-f0-9]+\)"\) to .* was not a 'Bar'|, + }, + + { + sub => 'sub14', + p => [ 'a', [ 1, 2, 3 ], $Bar ], + expect => q{}, + }, + + # hashref named params + { + sub => 'sub15', + p => [ { foo => 1, bar => { a => 1 } } ], + expect => + qr|^The 'bar' parameter \("HASH\(0x[a-f0-9]+\)"\) to .* was a 'hashref'.* types: arrayref|, + }, + + { + sub => 'sub15', + p => [ { foo => 1 } ], + expect => qr|^Mandatory parameter 'bar' missing|, + }, + + # positional - 3 + { + sub => 'sub16', + p => [ 1, 2, 3 ], + expect => qr|^3 parameters were passed .* but 1 - 2 were expected|, + }, + + { + sub => 'sub16', + p => [ 1, 2 ], + expect => q{}, + }, + + { + sub => 'sub16', + p => [1], + expect => q{}, + }, + + { + sub => 'sub16', + p => [], + expect => qr|^0 parameters were passed .* but 1 - 2 were expected|, + }, + + # positional - 4 + { + sub => 'sub17', + p => [ 1, 2, 3 ], + expect => qr|^3 parameters were passed .* but 1 - 2 were expected|, + }, + + { + sub => 'sub17', + p => [ 1, 2 ], + expect => q{}, + }, + + { + sub => 'sub17', + p => [1], + expect => q{}, + }, + + { + sub => 'sub17', + p => [], + expect => qr|^0 parameters were passed .* but 1 - 2 were expected|, + }, + + # positional - too few arguments supplied + { + sub => 'sub17a', + p => [], + expect => qr|^0 parameters were passed .* but 3 - 4 were expected|, + }, + + { + sub => 'sub17a', + p => [ 1, 2 ], + expect => qr|^2 parameters were passed .* but 3 - 4 were expected|, + }, + + { + sub => 'sub17b', + p => [], + expect => qr|^0 parameters were passed .* but 3 - 4 were expected|, + }, + + { + sub => 'sub17b', + p => [ 42, 2 ], + expect => qr|^2 parameters were passed .* but 3 - 4 were expected|, + }, + + # validation options - ignore case + { + sub => 'Foo::sub18', + p => [ FOO => 1 ], + options => { ignore_case => 1 }, + expect => q{}, + }, + + { + sub => 'sub18', + p => [ FOO => 1 ], + expect => qr|^The following parameter .* FOO|, + }, + + # validation options - strip leading + { + sub => 'Foo::sub18', + p => [ -foo => 1 ], + options => { strip_leading => '-' }, + expect => q{}, + }, + + { + sub => 'sub18', + p => [ -foo => 1 ], + expect => qr|^The following parameter .* -foo|, + }, + + # validation options - allow extra + { + sub => 'Foo::sub18', + p => [ foo => 1, bar => 1 ], + options => { allow_extra => 1 }, + expect => q{}, + return => { foo => 1, bar => 1 }, + }, + + { + sub => 'sub18', + p => [ foo => 1, bar => 1 ], + expect => qr|^The following parameter .* bar|, + }, + + { + sub => 'Foo::sub19', + p => [ 1, 2 ], + options => { allow_extra => 1 }, + expect => q{}, + return => [ 1, 2 ], + }, + + { + sub => 'sub19', + p => [ 1, 2 ], + expect => qr|^2 parameters were passed .* but 1.*|, + }, + + # validation options - on fail + { + sub => 'Foo::sub18', + p => [ bar => 1 ], + options => { + on_fail => sub { die "ERROR WAS: $_[0]" } + }, + expect => qr|^ERROR WAS: The following parameter .* bar|, + }, + + { + sub => 'sub18', + p => [ bar => 1 ], + expect => qr|^The following parameter .* bar|, + }, + + { + sub => 'sub20', + p => [ foo => undef ], + expect => qr|^The 'foo' parameter \(undef\) to .* was an 'undef'.*|, + }, + + { + sub => 'sub21', + p => [ foo => undef ], + expect => q{}, + }, + + { + sub => 'sub22', + p => [ foo => [1] ], + expect => + qr|^The 'foo' parameter \("ARRAY\(0x[a-f0-9]+\)"\) to .* was an 'arrayref'.*|, + }, + + { + sub => 'sub22', + p => [ foo => bless [1], 'object' ], + expect => q{}, + }, + + { + sub => 'sub22a', + p => [], + expect => q{}, + }, { + sub => 'sub22a', + p => [ foo => [1] ], + expect => + qr|^The 'foo' parameter \("ARRAY\(0x[a-f0-9]+\)"\) to .* was an 'arrayref'.*|, + }, { + sub => 'sub22a', + p => [ foo => bless [1], 'object' ], + expect => q{}, + }, + + { + sub => 'sub23', + p => ['1 element'], + expect => q{}, + }, + + { + sub => 'sub24', + p => [], + expect => q{}, + }, { + sub => 'sub24', + p => ['1 element'], + expect => qr|^Parameter #1 \("1 element"\) to .* was a 'scalar'.*|, + }, + + { + sub => 'sub24', + p => [ bless [1], 'object' ], + expect => q{}, + }, + + { + sub => 'sub25', + p => [1], + expect => qr|^Odd number|, + always_errors => 1, + }, + + # optional glob + { + sub => 'sub26', + p => [ + foo => 1, bar => do { local *BAR; *BAR } + ], + expect => q{}, + }, +); + +sub run_tests { + my $count = scalar @Tests; + $count++ for grep { $_->{return} } @Tests; + + for my $test (@Tests) { + if ( $test->{options} ) { + + package Foo; + validation_options( %{ $test->{options} } ); + } + + my $sub = $test->{sub}; + my @r = eval "$sub( \@{ \$test->{p} } )"; + + if ( + $test->{expect} + && ( $test->{always_errors} + || !$ENV{PERL_NO_VALIDATION} ) + ) { + like( $@, $test->{expect}, "expect error with $sub" ); + } + else { + is( $@, q{}, "no error with $sub" ); + } + + next unless $test->{return}; + + if ( eval { %{ $test->{return} } } ) { + my %r = @r; + is_deeply( + \%r, $test->{return}, + "check return value for $sub - hash" + ); + } + else { + is_deeply( + \@r, $test->{return}, + "check return value for $sub - array" + ); + } + } + + done_testing(); +} + +sub sub1 { + validate( @_, { foo => 1, bar => 1 } ); +} + +sub sub2 { + validate( @_, { foo => 1, bar => 1, baz => 0 } ); +} + +sub sub2a { + validate( @_, { foo => 1, bar => { optional => 1 } } ); +} + +sub sub3 { + validate( + @_, { + foo => { type => SCALAR }, + bar => + { type => ARRAYREF }, + baz => + { type => HASHREF }, + quux => + { type => SCALAR | ARRAYREF }, + brax => + { type => SCALAR | HASHREF }, + } + ); +} + +sub sub4 { + validate( + @_, { + foo => { type => SCALARREF }, + bar => + { type => GLOB }, + baz => + { type => GLOBREF }, + quux => + { type => CODEREF }, + } + ); +} + +sub sub4a { + validate( @_, { foo => { type => HANDLE } } ); +} + +sub sub4b { + validate( @_, { foo => { type => BOOLEAN } } ); +} + +sub sub5 { + validate( @_, { foo => { isa => 'Foo' } } ); +} + +sub sub6 { + validate( @_, { foo => { isa => 'Bar' } } ); +} + +sub sub7 { + validate( @_, { foo => { isa => 'Baz' } } ); +} + +sub sub8 { + validate( @_, { foo => { isa => [ 'Foo', 'Yadda' ] } } ); +} + +sub sub9 { + validate( @_, { foo => { can => 'fooify' } } ); +} + +sub sub9a { + validate( @_, { foo => { can => [ 'fooify', 'barify' ] } } ); +} + +sub sub9b { + validate( @_, { foo => { can => [ 'barify', 'yaddaify' ] } } ); +} + +sub sub9c { + validate( @_, { foo => { can => [ 'fooify', 'yaddaify' ] } } ); +} + +sub sub10 { + validate( + @_, { + foo => { + callbacks => { + 'less than 20' => sub { shift() < 20 } + } + } + } + ); +} + +sub sub11 { + validate( + @_, { + foo => { + callbacks => { + 'less than 20' => sub { shift() < 20 }, + 'more than 0' => sub { shift() > 0 }, + } + } + } + ); +} + +sub sub12 { + validate( + @_, { + foo => { + type => ARRAYREF, + callbacks => { + '5 elements' => sub { @{ shift() } == 5 } + } + } + } + ); +} + +sub sub13 { + validate_pos( + @_, + { type => SCALAR }, + { + type => ARRAYREF, + callbacks => { + '5 elements' => sub { @{ shift() } == 5 } + } + } + ); +} + +sub sub14 { + validate_pos( + @_, + { type => SCALAR }, + { type => ARRAYREF }, + { isa => 'Bar' }, + ); +} + +sub sub15 { + validate( + @_, { + foo => 1, + bar => { type => ARRAYREF } + } + ); +} + +sub sub16 { + validate_pos( @_, 1, 0 ); +} + +sub sub17 { + validate_pos( @_, { type => SCALAR }, { type => SCALAR, optional => 1 } ); +} + +{ + + package Foo; + use Params::Validate; + + sub sub18 { + validate( @_, { foo => 1 } ); + } + + sub sub19 { + validate_pos( @_, 1 ); + } +} + +sub sub17a { + validate_pos( @_, 1, 1, 1, 0 ); +} + +sub sub17b { + validate_pos( + @_, { + callbacks => { + 'less than 43' => sub { shift() < 43 } + } + }, + { type => SCALAR }, + 1, + { optional => 1 } + ); +} + +sub sub18 { + validate( @_, { foo => 1 } ); +} + +sub sub19 { + validate_pos( @_, 1 ); +} + +sub sub20 { + validate( @_, { foo => { type => SCALAR } } ); +} + +sub sub21 { + validate( @_, { foo => { type => UNDEF | SCALAR } } ); +} + +sub sub22 { + validate( @_, { foo => { type => OBJECT } } ); +} + +sub sub22a { + validate( @_, { foo => { type => OBJECT, optional => 1 } } ); +} + +sub sub23 { + validate_pos( @_, 1 ); +} + +sub sub24 { + validate_pos( @_, { type => OBJECT, optional => 1 } ); +} + +sub sub25 { + validate( @_, { foo => 1 } ); +} + +sub sub26 { + validate( + @_, { + foo => { type => SCALAR }, + bar => + { type => HANDLE, optional => 1 }, + }, + ); +} + +package Foo; + +use Params::Validate qw(:all); + +sub fooify {1} + +package Bar; + +@Bar::ISA = ('Foo'); + +sub barify {1} + +package Baz; + +@Baz::ISA = ('Bar'); + +sub bazify {1} + +package Yadda; + +sub yaddaify {1} + +package Quux; + +@Quux::ISA = ( 'Foo', 'Yadda' ); + +sub quuxify {1} + +1; diff --git a/t/lib/PVTests/With.pm b/t/lib/PVTests/With.pm new file mode 100644 index 0000000..e7ef350 --- /dev/null +++ b/t/lib/PVTests/With.pm @@ -0,0 +1,125 @@ +package PVTests::With; + +use strict; +use warnings; + +use Params::Validate qw(:all); + +use PVTests; +use Test::More; + +sub run_tests { + eval { validate_with( params => ['foo'], spec => [SCALAR], ); }; + is( $@, q{} ); + + eval { + validate_with( + params => { + foo => 5, + bar => {} + }, + spec => { + foo => SCALAR, + bar => HASHREF + }, + ); + }; + is( $@, q{} ); + + eval { + validate_with( + params => [], + spec => [SCALAR], + called => 'Yo::Mama', + ); + }; + if ( $ENV{PERL_NO_VALIDATION} ) { + is( $@, q{} ); + } + else { + like( $@, qr/Yo::Mama/ ); + } + + { + my %p; + eval { + %p = validate_with( + params => [], + spec => { + a => { default => 3 }, + b => { default => 'x' } + }, + ); + }; + + ok( exists $p{a} ); + is( $p{a}, 3 ); + ok( exists $p{b} ); + is( $p{b}, 'x' ); + } + + { + my @p; + eval { + @p = validate_with( + params => [], + spec => [ + { default => 3 }, + { default => 'x' } + ], + ); + }; + + is( $p[0], 3 ); + is( $p[1], 'x' ); + } + + { + + package Testing::X; + use Params::Validate qw(:all); + validation_options( allow_extra => 1 ); + + eval { + validate_with( + params => [ a => 1, b => 2, c => 3 ], + spec => { a => 1, b => 1 }, + ); + }; + PVTests::With::is( $@, q{} ); + + eval { + validate_with( + params => [ a => 1, b => 2, c => 3 ], + spec => { a => 1, b => 1 }, + allow_extra => 0, + ); + }; + if ( $ENV{PERL_NO_VALIDATION} ) { + PVTests::With::is( $@, q{} ); + } + else { + PVTests::With::like( $@, qr/was not listed/ ); + } + } + + { + + # Bug 2791 on rt.cpan.org + my %p; + eval { + my @p = { foo => 1 }; + %p = validate_with( + params => \@p, + spec => { foo => 1 }, + ); + }; + + is( $@, q{} ); + is( $p{foo}, 1 ); + } + + done_testing(); +} + +1; diff --git a/t/release-cpan-changes.t b/t/release-cpan-changes.t new file mode 100644 index 0000000..214650f --- /dev/null +++ b/t/release-cpan-changes.t @@ -0,0 +1,19 @@ +#!perl + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + + +use strict; +use warnings; + +use Test::More 0.96 tests => 2; +use_ok('Test::CPAN::Changes'); +subtest 'changes_ok' => sub { + changes_file_ok('Changes'); +}; +done_testing(); diff --git a/t/release-memory-leak.t b/t/release-memory-leak.t new file mode 100644 index 0000000..0543aab --- /dev/null +++ b/t/release-memory-leak.t @@ -0,0 +1,105 @@ + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + +use strict; +use warnings; + +use Test::More; + +BEGIN { + plan skip_all => q{Test::LeakTrace doesn't install with blead (as of 5.21.8)} + if $] >= 5.021008; +} + +use Test::LeakTrace qw( no_leaks_ok ); + +use Params::Validate qw( validate ); + +subtest( + 'callback with default error' => sub { + no_leaks_ok( sub { val1( foo => 42 ); }, 'validation passes' ); + local $TODO = 'Not sure if all the leaks are in Carp or not'; + no_leaks_ok( + sub { + eval { val1( foo => 'forty two' ) }; + }, + 'validation fails' + ); + }, +); + +subtest( + 'callback that dies with string' => sub { + no_leaks_ok( sub { val2( foo => 42 ); }, 'validation passes' ); + local $TODO = 'Not sure if all the leaks are in Carp or not'; + no_leaks_ok( + sub { + eval { val2( foo => 'forty two' ) }; + }, + 'validation fails' + ); + }, +); + +subtest( + 'callback that dies with object' => sub { + no_leaks_ok( sub { val3( foo => 42 ); }, 'validation passes' ); + no_leaks_ok( + sub { + eval { val3( foo => 'forty two' ) }; + }, + 'validation fails' + ); + }, +); + +done_testing(); + +sub val1 { + validate( + @_, + { + foo => { + callbacks => { + 'is int' => sub { $_[0] =~ /^[0-9]+$/ } + } + }, + }, + ); +} + +sub val2 { + validate( + @_, + { + foo => { + callbacks => { + 'is int' => sub { + $_[0] =~ /^[0-9]+$/ or die "$_[0] is not an integer"; + } + } + }, + }, + ); +} + +sub val3 { + validate( + @_, + { + foo => { + callbacks => { + 'is int' => sub { + $_[0] =~ /^[0-9]+$/ + or die { error => "$_[0] is not an integer" }; + } + } + }, + }, + ); +} diff --git a/t/release-pod-coverage.t b/t/release-pod-coverage.t new file mode 100644 index 0000000..48d555f --- /dev/null +++ b/t/release-pod-coverage.t @@ -0,0 +1,56 @@ +#!perl + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + +# This file was automatically generated by Dist::Zilla::Plugin::Test::Pod::Coverage::Configurable. + +use Test::Pod::Coverage 1.08; +use Test::More 0.88; + +BEGIN { + if ( $] <= 5.008008 ) { + plan skip_all => 'These tests require Pod::Coverage::TrustPod, which only works with Perl 5.8.9+'; + } +} +use Pod::Coverage::TrustPod; + +my %skip = map { $_ => 1 } qw( Params::Validate::Constants Params::Validate::PP Params::Validate::XS Params::ValidatePP Params::ValidateXS ); + +my @modules; +for my $module ( all_modules() ) { + next if $skip{$module}; + + push @modules, $module; +} + +plan skip_all => 'All the modules we found were excluded from POD coverage test.' + unless @modules; + +plan tests => scalar @modules; + +my %trustme = ( + 'Params::Validate' => [ + qr/^(?:UNKNOWN|set_options|validate(?:_pos|_with)?|validation_options)$/ + ] + ); + +my @also_private; + +for my $module ( sort @modules ) { + pod_coverage_ok( + $module, + { + coverage_class => 'Pod::Coverage::TrustPod', + also_private => \@also_private, + trustme => $trustme{$module} || [], + }, + "pod coverage for $module" + ); +} + +done_testing(); diff --git a/t/release-pod-linkcheck.t b/t/release-pod-linkcheck.t new file mode 100644 index 0000000..654cf06 --- /dev/null +++ b/t/release-pod-linkcheck.t @@ -0,0 +1,28 @@ +#!perl + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + + +use strict; +use warnings; +use Test::More; + +foreach my $env_skip ( qw( + SKIP_POD_LINKCHECK +) ){ + plan skip_all => "\$ENV{$env_skip} is set, skipping" + if $ENV{$env_skip}; +} + +eval "use Test::Pod::LinkCheck"; +if ( $@ ) { + plan skip_all => 'Test::Pod::LinkCheck required for testing POD'; +} +else { + Test::Pod::LinkCheck->new->all_pod_ok; +} diff --git a/t/release-pod-no404s.t b/t/release-pod-no404s.t new file mode 100644 index 0000000..da185ec --- /dev/null +++ b/t/release-pod-no404s.t @@ -0,0 +1,29 @@ +#!perl + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + + +use strict; +use warnings; +use Test::More; + +foreach my $env_skip ( qw( + SKIP_POD_NO404S + AUTOMATED_TESTING +) ){ + plan skip_all => "\$ENV{$env_skip} is set, skipping" + if $ENV{$env_skip}; +} + +eval "use Test::Pod::No404s"; +if ( $@ ) { + plan skip_all => 'Test::Pod::No404s required for testing POD'; +} +else { + all_pod_files_ok(); +} diff --git a/t/release-pod-syntax.t b/t/release-pod-syntax.t new file mode 100644 index 0000000..cdd6a6c --- /dev/null +++ b/t/release-pod-syntax.t @@ -0,0 +1,14 @@ +#!perl + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + +# This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests. +use Test::More; +use Test::Pod 1.41; + +all_pod_files_ok(); diff --git a/t/release-portability.t b/t/release-portability.t new file mode 100644 index 0000000..ad285b4 --- /dev/null +++ b/t/release-portability.t @@ -0,0 +1,20 @@ +#!perl + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + + +use strict; +use warnings; + +use Test::More; + +eval 'use Test::Portability::Files'; +plan skip_all => 'Test::Portability::Files required for testing portability' + if $@; + +run_tests(); diff --git a/t/release-pp-01-validate.t b/t/release-pp-01-validate.t new file mode 100644 index 0000000..da6a1fd --- /dev/null +++ b/t/release-pp-01-validate.t @@ -0,0 +1,21 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests::Standard; +PVTests::Standard::run_tests(); + diff --git a/t/release-pp-02-noop.t b/t/release-pp-02-noop.t new file mode 100644 index 0000000..bcac392 --- /dev/null +++ b/t/release-pp-02-noop.t @@ -0,0 +1,24 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +BEGIN { $ENV{PERL_NO_VALIDATION} = 1 } + +use PVTests::Standard; +PVTests::Standard::run_tests(); + + diff --git a/t/release-pp-03-attribute.t b/t/release-pp-03-attribute.t new file mode 100644 index 0000000..9c6a208 --- /dev/null +++ b/t/release-pp-03-attribute.t @@ -0,0 +1,114 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests; +use Test::More; + +use Attribute::Params::Validate; +use Params::Validate qw(:all); + +sub foo : Validate( c => { type => SCALAR } ) { + my %data = @_; + return $data{c}; +} + +sub bar : Validate( c => { type => SCALAR } ) method { + my $self = shift; + my %data = @_; + return $data{c}; +} + +sub baz : + Validate( foo => { type => ARRAYREF, callbacks => { '5 elements' => sub { @{shift()} == 5 } } } ) +{ + my %data = @_; + return $data{foo}->[0]; +} + +sub buz : ValidatePos( 1 ) { + return $_[0]; +} + +sub quux : ValidatePos( { type => SCALAR }, 1 ) { + return $_[0]; +} + +my $res = eval { foo( c => 1 ) }; +is( + $@, q{}, + "Call foo with a scalar" +); + +is( + $res, 1, + 'Check return value from foo( c => 1 )' +); + +eval { foo( c => [] ) }; + +like( + $@, qr/The 'c' parameter .* was an 'arrayref'/, + 'Check exception thrown from foo( c => [] )' +); + +$res = eval { main->bar( c => 1 ) }; +is( + $@, q{}, + 'Call bar with a scalar' +); + +is( + $res, 1, + 'Check return value from bar( c => 1 )' +); + +eval { baz( foo => [ 1, 2, 3, 4 ] ) }; + +like( + $@, qr/The 'foo' parameter .* did not pass the '5 elements' callback/, + 'Check exception thrown from baz( foo => [1,2,3,4] )' +); + +$res = eval { baz( foo => [ 5, 4, 3, 2, 1 ] ) }; + +is( + $@, q{}, + 'Call baz( foo => [5,4,3,2,1] )' +); + +is( + $res, 5, + 'Check return value from baz( foo => [5,4,3,2,1] )' +); + +eval { buz( [], 1 ) }; + +like( + $@, qr/2 parameters were passed to .* but 1 was expected/, + 'Check exception thrown from quux( [], 1 )' +); + +$res = eval { quux( 1, [] ) }; + +is( + $@, q{}, + 'Call quux' +); + +done_testing(); + diff --git a/t/release-pp-04-defaults.t b/t/release-pp-04-defaults.t new file mode 100644 index 0000000..8ed39d4 --- /dev/null +++ b/t/release-pp-04-defaults.t @@ -0,0 +1,21 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests::Defaults; +PVTests::Defaults::run_tests(); + diff --git a/t/release-pp-05-noop_default.t b/t/release-pp-05-noop_default.t new file mode 100644 index 0000000..82b2c00 --- /dev/null +++ b/t/release-pp-05-noop_default.t @@ -0,0 +1,23 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +BEGIN { $ENV{PERL_NO_VALIDATION} = 1 } + +use PVTests::Defaults; +PVTests::Defaults::run_tests(); + diff --git a/t/release-pp-06-options.t b/t/release-pp-06-options.t new file mode 100644 index 0000000..a18c245 --- /dev/null +++ b/t/release-pp-06-options.t @@ -0,0 +1,52 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests; +use Test::More; + +use Params::Validate qw(:all); + +validation_options( stack_skip => 2 ); + +sub foo { + my %p = validate( @_, { bar => 1 } ); +} + +sub bar { foo(@_) } + +sub baz { bar(@_) } + +eval { baz() }; + +like( $@, qr/mandatory.*missing.*call to main::bar/i ); + +validation_options( stack_skip => 3 ); + +eval { baz() }; +like( $@, qr/mandatory.*missing.*call to main::baz/i ); + +validation_options( on_fail => sub { die bless { hash => 'ref' }, 'Dead' } ); + +eval { baz() }; + +my $e = $@; +is( $e->{hash}, 'ref' ); +ok( eval { $e->isa('Dead'); 1; } ); + +done_testing(); + diff --git a/t/release-pp-07-with.t b/t/release-pp-07-with.t new file mode 100644 index 0000000..1b3bdf0 --- /dev/null +++ b/t/release-pp-07-with.t @@ -0,0 +1,21 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests::With; +PVTests::With::run_tests(); + diff --git a/t/release-pp-08-noop_with.t b/t/release-pp-08-noop_with.t new file mode 100644 index 0000000..7705999 --- /dev/null +++ b/t/release-pp-08-noop_with.t @@ -0,0 +1,23 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +BEGIN { $ENV{PERL_NO_VALIDATION} = 1 } + +use PVTests::With; +PVTests::With::run_tests(); + diff --git a/t/release-pp-09-regex.t b/t/release-pp-09-regex.t new file mode 100644 index 0000000..ddaed55 --- /dev/null +++ b/t/release-pp-09-regex.t @@ -0,0 +1,21 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests::Regex; +PVTests::Regex::run_tests(); + diff --git a/t/release-pp-10-noop_regex.t b/t/release-pp-10-noop_regex.t new file mode 100644 index 0000000..b7f8e2b --- /dev/null +++ b/t/release-pp-10-noop_regex.t @@ -0,0 +1,23 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +BEGIN { $ENV{PERL_NO_VALIDATION} = 1 } + +use PVTests::Regex; +PVTests::Regex::run_tests(); + diff --git a/t/release-pp-11-cb.t b/t/release-pp-11-cb.t new file mode 100644 index 0000000..a8b9d41 --- /dev/null +++ b/t/release-pp-11-cb.t @@ -0,0 +1,21 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +use PVTests::Callbacks; +PVTests::Callbacks::run_tests(); + diff --git a/t/release-pp-12-noop_cb.t b/t/release-pp-12-noop_cb.t new file mode 100644 index 0000000..62a6fbb --- /dev/null +++ b/t/release-pp-12-noop_cb.t @@ -0,0 +1,23 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +BEGIN { $ENV{PERL_NO_VALIDATION} = 1 } + +use PVTests::Callbacks; +PVTests::Callbacks::run_tests(); + diff --git a/t/release-pp-13-taint.t b/t/release-pp-13-taint.t new file mode 100644 index 0000000..659addd --- /dev/null +++ b/t/release-pp-13-taint.t @@ -0,0 +1,23 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir( 't', 'lib' ); + +eval { "$0$^X" && kill 0; 1 }; + +use PVTests::Standard; +PVTests::Standard::run_tests(); + diff --git a/t/release-pp-14-no_validate.t b/t/release-pp-14-no_validate.t new file mode 100644 index 0000000..3549bbf --- /dev/null +++ b/t/release-pp-14-no_validate.t @@ -0,0 +1,41 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use lib './t'; + +use Params::Validate qw(validate); + +use Test::More; +plan tests => $] == 5.006 ? 2 : 3; + +eval { foo() }; +like( $@, qr/parameter 'foo'/ ); + +{ + local $Params::Validate::NO_VALIDATION = 1; + + eval { foo() }; + is( $@, q{} ); +} + +unless ( $] == 5.006 ) { + eval { foo() }; + like( $@, qr/parameter 'foo'/ ); +} + +sub foo { + validate( @_, { foo => 1 } ); +} + diff --git a/t/release-pp-15-case.t b/t/release-pp-15-case.t new file mode 100644 index 0000000..7c5bd04 --- /dev/null +++ b/t/release-pp-15-case.t @@ -0,0 +1,111 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Test::More; + +use Params::Validate qw(validate validate_with); + +my @testset; + +# Generate test cases ... +BEGIN { + my @lower_case_args = ( foo => 1 ); + my @upper_case_args = ( FOO => 1 ); + my @mixed_case_args = ( FoO => 1 ); + + my %lower_case_spec = ( foo => 1 ); + my %upper_case_spec = ( FOO => 1 ); + my %mixed_case_spec = ( FoO => 1 ); + + my %arglist = ( + lower => \@lower_case_args, + upper => \@upper_case_args, + mixed => \@mixed_case_args + ); + + my %speclist = ( + lower => \%lower_case_spec, + upper => \%upper_case_spec, + mixed => \%mixed_case_spec + ); + + # XXX - make subs such that user gets to see the error message + # when a test fails + my $ok_sub = sub { + if ($@) { + print STDERR $@; + } + !$@; + }; + + my $nok_sub = sub { + my $ok = ( $@ =~ /not listed in the validation options/ ); + unless ($ok) { + print STDERR $@; + } + $ok; + }; + + # generate testcases on the fly (I'm too lazy) + for my $ignore_case (qw( 0 1 )) { + for my $args ( keys %arglist ) { + for my $spec ( keys %speclist ) { + push @testset, { + params => $arglist{$args}, + spec => $speclist{$spec}, + expect => ( + $ignore_case ? $ok_sub + : $args eq $spec ? $ok_sub + : $nok_sub + ), + ignore_case => $ignore_case + }; + } + } + } +} + +plan tests => ( scalar @testset ) * 2; + +{ + + # XXX - "called" will be all messed up, but what the heck + foreach my $case (@testset) { + my %args = eval { + validate_with( + params => $case->{params}, + spec => $case->{spec}, + ignore_case => $case->{ignore_case} + ); + }; + + ok( $case->{expect}->(%args) ); + } + + # XXX - make sure that it works from validation_options() as well + foreach my $case (@testset) { + Params::Validate::validation_options( + ignore_case => $case->{ignore_case} ); + + my %args = eval { + my @args = @{ $case->{params} }; + validate( @args, $case->{spec} ); + }; + + ok( $case->{expect}->(%args) ); + } +} + + diff --git a/t/release-pp-16-normalize.t b/t/release-pp-16-normalize.t new file mode 100644 index 0000000..de2a994 --- /dev/null +++ b/t/release-pp-16-normalize.t @@ -0,0 +1,84 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Params::Validate qw(validate validate_with); +use Test::More; + +my $ucfirst_normalizer = sub { return ucfirst lc $_[0] }; + +sub sub1 { + my %args = validate_with( + params => \@_, + spec => { PaRaMkEy => 1 }, + normalize_keys => $ucfirst_normalizer + ); + + return $args{Paramkey}; +} + +sub sub2 { + + # verify that normalize_callback surpresses ignore_case + my %args = validate_with( + params => \@_, + spec => { PaRaMkEy => 1 }, + normalize_keys => $ucfirst_normalizer, + ignore_case => 1 + ); + + return $args{Paramkey}; +} + +sub sub3 { + + # verify that normalize_callback surpresses strip_leading + my %args = validate_with( + params => \@_, + spec => { -PaRaMkEy => 1 }, + normalize_keys => $ucfirst_normalizer, + strip_leading => '-' + ); + + return $args{-paramkey}; +} + +sub sub4 { + my %args = validate_with( + params => \@_, + spec => { foo => 1 }, + normalize_keys => sub {undef} + ); +} + +sub sub5 { + my %args = validate_with( + params => \@_, + spec => { foo => 1 }, + normalize_keys => sub { return 'a' }, + ); +} + +ok( eval { sub1( pArAmKeY => 1 ) } ); +ok( eval { sub2( pArAmKeY => 1 ) } ); +ok( eval { sub3( -pArAmKeY => 1 ) } ); + +eval { sub4( foo => 5 ) }; +like( $@, qr/normalize_keys.+a defined value/ ); + +eval { sub5( foo => 5, bar => 5 ) }; +like( $@, qr/normalize_keys.+already exists/ ); + +done_testing(); + diff --git a/t/release-pp-17-callbacks.t b/t/release-pp-17-callbacks.t new file mode 100644 index 0000000..6fdaa86 --- /dev/null +++ b/t/release-pp-17-callbacks.t @@ -0,0 +1,91 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Params::Validate qw(validate validate_pos SCALAR); +use Test::More; + +{ + my @p = ( foo => 1, bar => 2 ); + + eval { + validate( + @p, { + foo => { + type => SCALAR, + callbacks => { + 'bigger than bar' => sub { $_[0] > $_[1]->{bar} } + }, + }, + bar => { type => SCALAR }, + } + ); + }; + + like( $@, qr/bigger than bar/ ); + + $p[1] = 3; + eval { + validate( + @p, { + foo => { + type => SCALAR, + callbacks => { + 'bigger than bar' => sub { $_[0] > $_[1]->{bar} } + }, + }, + bar => { type => SCALAR }, + } + ); + }; + + is( $@, q{} ); +} + +{ + my @p = ( 1, 2, 3 ); + eval { + validate_pos( + @p, { + type => SCALAR, + callbacks => { + 'bigger than [1]' => sub { $_[0] > $_[1]->[1] } + } + }, + { type => SCALAR }, + { type => SCALAR }, + ); + }; + + like( $@, qr/bigger than \[1\]/ ); + + $p[0] = 5; + eval { + validate_pos( + @p, { + type => SCALAR, + callbacks => { + 'bigger than [1]' => sub { $_[0] > $_[1]->[1] } + } + }, + { type => SCALAR }, + { type => SCALAR }, + ); + }; + + is( $@, q{} ); +} + +done_testing(); + diff --git a/t/release-pp-18-depends.t b/t/release-pp-18-depends.t new file mode 100644 index 0000000..c1f31b6 --- /dev/null +++ b/t/release-pp-18-depends.t @@ -0,0 +1,181 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Params::Validate qw(validate validate_pos); +use Test::More; + +{ + my %spec = ( + foo => { optional => 1, depends => 'bar' }, + bar => { optional => 1 }, + ); + + my @args = ( bar => 1 ); + + eval { validate( @args, \%spec ) }; + + is( $@, q{}, "validate() single depends(1): no depends, positive" ); + + @args = ( foo => 1, bar => 1 ); + eval { validate( @args, \%spec ) }; + + is( $@, q{}, "validate() single depends(2): with depends, positive" ); + + @args = ( foo => 1 ); + eval { validate( @args, \%spec ) }; + + ok( $@, "validate() single depends(3.a): with depends, negative" ); + like( + $@, + qr(^Parameter 'foo' depends on parameter 'bar', which was not given), + "validate() single depends(3.b): check error string" + ); +} + +{ + my %spec = ( + foo => { optional => 1, depends => [qw(bar baz)] }, + bar => { optional => 1 }, + baz => { optional => 1 }, + ); + + # positive, no depends (single, multiple) + my @args = ( bar => 1 ); + eval { validate( @args, \%spec ) }; + is( + $@, q{}, + "validate() multiple depends(1): no depends, single arg, positive" + ); + + @args = ( bar => 1, baz => 1 ); + eval { validate( @args, \%spec ) }; + + is( + $@, q{}, + "validate() multiple depends(2): no depends, multiple arg, positive" + ); + + @args = ( foo => 1, bar => 1, baz => 1 ); + eval { validate( @args, \%spec ) }; + + is( $@, q{}, "validate() multiple depends(3): with depends, positive" ); + + @args = ( foo => 1, bar => 1 ); + eval { validate( @args, \%spec ) }; + + ok( + $@, + "validate() multiple depends(4.a): with depends, negative, multiple missing" + ); + like( + $@, + qr(^Parameter 'foo' depends on parameter 'baz', which was not given), + "validate() multiple depends (4.b): check error string" + ); + + @args = ( foo => 1 ); + eval { validate( @args, \%spec ) }; + + ok( + $@, + "validate() multiple depends(5.a): with depends, negative, multiple missing" + ); + like( + $@, + qr(^Parameter 'foo' depends on parameter '(bar|baz)', which was not given), + "validate() multiple depends (5.b): check error string" + ); +} + +{ + + # bad depends + my %spec = ( + foo => { optional => 1, depends => { 'bar' => 1 } }, + bar => { optional => 1 }, + ); + + my @args = ( foo => 1 ); + eval { validate( @args, \%spec ) }; + + ok( $@, "validate() bad depends spec (1.a): depends is a hashref" ); + like( + $@, + qr(^Arguments to 'depends' must be a scalar or arrayref), + "validate() bad depends spec (1.a): check error string" + ); +} + +{ + my @spec = ( { optional => 1 } ); + + my @args = qw(1); + eval { validate_pos( @args, @spec ) }; + + is( $@, q{}, "validate_pos() no depends, positive" ); +} + +{ + my @spec = ( { optional => 1, depends => 2 }, { optional => 1 } ); + + my @args = qw(1 1); + eval { validate_pos( @args, @spec ) }; + + is( + $@, q{}, + "validate_pos() single depends (1): with depends, positive" + ); +} + +{ + my @spec = ( + { optional => 1, depends => 4 }, + { optional => 1 }, { optional => 1 }, + { optional => 1 } + ); + + my @args = qw(1 0); + eval { validate_pos( @args, @spec ) }; + + ok( $@, "validate_pos() single depends (2.a): with depends, negative" ); + like( + $@, + qr(^Parameter #1 depends on parameter #4, which was not given), + "validate_pos() single depends (2.b): check error" + ); +} + +{ + my @spec = ( + { optional => 1, depends => [ 2, 3 ] }, + { optional => 1 }, + 0 + ); + my @args = qw(1); + eval { validate_pos( @args, @spec ) }; + + ok( + $@, + "validate_pos() multiple depends (1.a): with depends, bad args negative" + ); + like( + $@, + qr{^Arguments to 'depends' for validate_pos\(\) must be a scalar}, + "validate_pos() multiple depends (1.b): check error" + ); +} + +done_testing(); + diff --git a/t/release-pp-19-untaint.t b/t/release-pp-19-untaint.t new file mode 100644 index 0000000..42ee82d --- /dev/null +++ b/t/release-pp-19-untaint.t @@ -0,0 +1,99 @@ +#!/usr/bin/perl -T + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + + +use strict; +use warnings; + +use Test::Requires { + 'Test::Taint' => 0.02, +}; + +use Params::Validate qw(validate validate_pos); +use Test::More; + +taint_checking_ok('These tests are meaningless unless we are in taint mode.'); + +{ + my $value = 7; + taint($value); + + tainted_ok( $value, 'make sure $value is tainted' ); + + my @p = ( value => $value ); + my %p = validate( + @p, { + value => { + regex => qr/^\d+$/, + untaint => 1, + }, + }, + ); + + untainted_ok( $p{value}, 'value is untainted after validation' ); +} + +{ + my $value = 'foo'; + + taint($value); + + tainted_ok( $value, 'make sure $value is tainted' ); + + my @p = ($value); + my ($new_value) = validate_pos( + @p, { + regex => qr/foo/, + untaint => 1, + }, + ); + + untainted_ok( $new_value, 'value is untainted after validation' ); +} + +{ + my $value = 7; + taint($value); + + tainted_ok( $value, 'make sure $value is tainted' ); + + my @p = ( value => $value ); + my %p = validate( + @p, { + value => { + regex => qr/^\d+$/, + }, + }, + ); + + tainted_ok( $p{value}, 'value is still tainted after validation' ); +} + +{ + my $value = 'foo'; + + taint($value); + + tainted_ok( $value, 'make sure $value is tainted' ); + + my @p = ($value); + my ($new_value) = validate_pos( + @p, { + regex => qr/foo/, + }, + ); + + tainted_ok( $new_value, 'value is still tainted after validation' ); +} + +done_testing(); + diff --git a/t/release-pp-21-can.t b/t/release-pp-21-can.t new file mode 100644 index 0000000..2c81979 --- /dev/null +++ b/t/release-pp-21-can.t @@ -0,0 +1,108 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Params::Validate qw(validate); +use Test::More; + +{ + my @p = ( foo => 'ClassCan' ); + + eval { validate( @p, { foo => { can => 'cancan' } }, ); }; + + is( $@, q{} ); + + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + + like( $@, qr/does not have the method: 'thingy'/ ); +} + +{ + my @p = ( foo => undef ); + eval { validate( @p, { foo => { can => 'baz' } }, ); }; + + like( $@, qr/does not have the method: 'baz'/ ); +} + +{ + my $object = bless {}, 'ClassCan'; + my @p = ( foo => $object ); + + eval { validate( @p, { foo => { can => 'cancan' } }, ); }; + + is( $@, q{} ); + + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + + like( $@, qr/does not have the method: 'thingy'/ ); +} + +{ + my @p = ( foo => 'SubClass' ); + + eval { validate( @p, { foo => { can => 'cancan' } }, ); }; + + is( $@, q{}, 'SubClass->can(cancan)' ); + + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + + like( $@, qr/does not have the method: 'thingy'/ ); +} + +{ + my $object = bless {}, 'SubClass'; + my @p = ( foo => $object ); + + eval { validate( @p, { foo => { can => 'cancan' } }, ); }; + + is( $@, q{}, 'SubClass object->can(cancan)' ); + + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + + like( $@, qr/does not have the method: 'thingy'/ ); +} + +{ + my @p = ( foo => {} ); + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + like( $@, qr/does not have the method: 'thingy'/, 'unblessed ref ->can' ); + + @p = ( foo => 27 ); + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + like( $@, qr/does not have the method: 'thingy'/, 'number can' ); + + @p = ( foo => 'A String' ); + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + like( $@, qr/does not have the method: 'thingy'/, 'string can' ); + + @p = ( foo => undef ); + eval { validate( @p, { foo => { can => 'thingy' } }, ); }; + like( $@, qr/does not have the method: 'thingy'/, 'undef can' ); +} + +done_testing(); + +package ClassCan; + +sub can { + return 1 if $_[1] eq 'cancan'; + return 0; +} + +sub thingy {1} + +package SubClass; + +use base 'ClassCan'; + diff --git a/t/release-pp-22-overload-can-bug.t b/t/release-pp-22-overload-can-bug.t new file mode 100644 index 0000000..44acf60 --- /dev/null +++ b/t/release-pp-22-overload-can-bug.t @@ -0,0 +1,50 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Params::Validate qw(validate); +use Test::More; + +{ + package Overloaded; + + use overload 'bool' => sub {0}; + + sub new { bless {} } + + sub foo {1} +} + +my $ovl = Overloaded->new; + +{ + eval { + my @p = ( object => $ovl ); + validate( @p, { object => { isa => 'Overloaded' } } ); + }; + + is( $@, q{}, 'overloaded object->isa' ); +} + +{ + eval { + my @p = ( object => $ovl ); + validate( @p, { object => { can => 'foo' } } ); + }; + + is( $@, q{}, 'overloaded object->foo' ); +} + +done_testing(); + diff --git a/t/release-pp-23-readonly.t b/t/release-pp-23-readonly.t new file mode 100644 index 0000000..8c4a521 --- /dev/null +++ b/t/release-pp-23-readonly.t @@ -0,0 +1,52 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Test::Requires { + Readonly => '1.03', + 'Scalar::Util' => '1.20', +}; + +use Params::Validate qw(validate validate_pos SCALAR); +use Test::More; + +plan skip_all => 'These tests fail with Readonly 1.50 for some reason' + if Readonly::->VERSION() =~ /^v?1.5/; + +{ + Readonly my $spec => { foo => 1 }; + my @p = ( foo => 'hello' ); + + eval { validate( @p, $spec ) }; + is( $@, q{}, 'validate() call succeeded with Readonly spec hashref' ); +} + +{ + Readonly my $spec => { type => SCALAR }; + my @p = 'hello'; + + eval { validate_pos( @p, $spec ) }; + is( $@, q{}, 'validate_pos() call succeeded with Readonly spec hashref' ); +} + +{ + Readonly my %spec => ( foo => { type => SCALAR } ); + my @p = ( foo => 'hello' ); + + eval { validate( @p, \%spec ) }; + is( $@, q{}, 'validate() call succeeded with Readonly spec hash' ); +} + +done_testing(); + diff --git a/t/release-pp-24-tied.t b/t/release-pp-24-tied.t new file mode 100644 index 0000000..2522b60 --- /dev/null +++ b/t/release-pp-24-tied.t @@ -0,0 +1,134 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Params::Validate qw(validate validate_pos SCALAR); +use Test::More; + +{ + package Tie::SimpleArray; + use Tie::Array; + use base 'Tie::StdArray'; +} + +{ + + package Tie::SimpleHash; + use Tie::Hash; + use base 'Tie::StdHash'; +} + +{ + tie my @p, 'Tie::SimpleArray'; + + my %spec = ( foo => 1 ); + push @p, ( foo => 'hello' ); + + eval { validate( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate() call succeeded with tied params array and regular hashref spec' + ); +} + +SKIP: +{ + skip 'Params::Validate segfaults with tied hash for spec', 1; + + my @p; + tie my %spec, 'Tie::SimpleHash'; + + $spec{foo} = 1; + push @p, ( foo => 'hello' ); + + eval { validate( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate() call succeeded with regular params array and tied hashref spec' + ); +} + +SKIP: +{ + skip 'Params::Validate segfaults with tied hash for spec', 1; + + tie my @p, 'Tie::SimpleArray'; + tie my %spec, 'Tie::SimpleHash'; + + $spec{foo} = 1; + push @p, ( foo => 'hello' ); + + eval { validate( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate() call succeeded with tied params array and tied hashref spec' + ); +} + +{ + tie my @p, 'Tie::SimpleArray'; + my %spec; + + $spec{type} = SCALAR; + push @p, 'hello'; + + eval { validate_pos( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate_pos() call succeeded with tied params array and regular hashref spec' + ); +} + +SKIP: +{ + skip 'Params::Validate segfaults with tied hash for spec', 1; + + my @p; + tie my %spec, 'Tie::SimpleHash'; + + $spec{type} = SCALAR; + push @p, 'hello'; + + eval { validate_pos( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate_pos() call succeeded with regular params array and tied hashref spec' + ); +} + +SKIP: +{ + skip 'Params::Validate segfaults with tied hash for spec', 1; + + tie my @p, 'Tie::SimpleArray'; + tie my %spec, 'Tie::SimpleHash'; + + $spec{type} = SCALAR; + push @p, 'hello'; + + eval { validate_pos( @p, \%spec ) }; + warn $@ if $@; + is( + $@, q{}, + 'validate_pos() call succeeded with tied params array and tied hashref spec' + ); +} + +done_testing(); + diff --git a/t/release-pp-25-undef-regex.t b/t/release-pp-25-undef-regex.t new file mode 100644 index 0000000..7f20da4 --- /dev/null +++ b/t/release-pp-25-undef-regex.t @@ -0,0 +1,30 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Params::Validate qw(validate); +use Test::More; + +{ + my @w; + local $SIG{__WARN__} = sub { push @w, @_ }; + + my @p = ( foo => undef ); + eval { validate( @p, { foo => { regex => qr/^bar/ } } ) }; + ok( $@, 'validation failed' ); + ok( !@w, 'no warnings' ); +} + +done_testing(); + diff --git a/t/release-pp-26-isa.t b/t/release-pp-26-isa.t new file mode 100644 index 0000000..f95fdd5 --- /dev/null +++ b/t/release-pp-26-isa.t @@ -0,0 +1,102 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Params::Validate qw(validate); +use Test::More; + +{ + my @p = ( foo => 'ClassISA' ); + + eval { validate( @p, { foo => { isa => 'FooBar' } }, ); }; + + is( $@, q{}, 'no error checking if ClassISA->isa(FooBar)' ); + + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + + like( $@, qr/was not a 'Thingy'/ ); +} + +{ + my @p = ( foo => undef ); + eval { validate( @p, { foo => { isa => 'FooBar' } }, ); }; + + like( $@, qr/was not a 'FooBar'/ ); +} + +{ + my @p = ( foo => 'SubClass' ); + + eval { validate( @p, { foo => { isa => 'ClassISA' } }, ); }; + + is( $@, q{}, 'SubClass->isa(ClassISA)' ); + + eval { validate( @p, { foo => { isa => 'FooBar' } }, ); }; + + is( $@, q{}, 'SubClass->isa(FooBar)' ); + + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + + like( $@, qr/was not a 'Thingy'/ ); +} + +{ + my @p = ( foo => bless {}, 'SubClass' ); + + eval { validate( @p, { foo => { isa => 'ClassISA' } }, ); }; + + is( $@, q{}, 'SubClass->isa(ClassISA)' ); + + eval { validate( @p, { foo => { isa => 'FooBar' } }, ); }; + + is( $@, q{}, 'SubClass->isa(FooBar)' ); + + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + + like( $@, qr/was not a 'Thingy'/ ); +} + +{ + my @p = ( foo => {} ); + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + like( $@, qr/was not a 'Thingy'/, 'unblessed ref ->isa' ); + + @p = ( foo => 27 ); + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + like( $@, qr/was not a 'Thingy'/, 'number isa' ); + + @p = ( foo => 'A String' ); + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + like( $@, qr/was not a 'Thingy'/, 'string isa' ); + + @p = ( foo => undef ); + eval { validate( @p, { foo => { isa => 'Thingy' } }, ); }; + like( $@, qr/was not a 'Thingy'/, 'undef isa' ); +} + +done_testing(); + +package ClassISA; + +sub isa { + return 1 if $_[1] eq 'FooBar'; + return $_[0]->SUPER::isa( $_[1] ); +} + +sub thingy {1} + +package SubClass; + +use base 'ClassISA'; + diff --git a/t/release-pp-27-string-as-type.t b/t/release-pp-27-string-as-type.t new file mode 100644 index 0000000..bb19f37 --- /dev/null +++ b/t/release-pp-27-string-as-type.t @@ -0,0 +1,43 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Params::Validate qw(validate); +use Test::More; + +{ + my @p = ( foo => 1 ); + + eval { validate( @p, { foo => { type => 'SCALAR' } }, ); }; + + like( + $@, + qr/\QThe 'foo' parameter ("1") has a type specification which is not a number. It is a string - SCALAR/ + ); +} + +{ + my @p = ( foo => 1 ); + + eval { validate( @p, { foo => { type => undef } }, ); }; + + like( + $@, + qr/\QThe 'foo' parameter ("1") has a type specification which is not a number. It is undef/ + ); + +} + +done_testing(); + diff --git a/t/release-pp-28-readonly-return.t b/t/release-pp-28-readonly-return.t new file mode 100644 index 0000000..1dedca0 --- /dev/null +++ b/t/release-pp-28-readonly-return.t @@ -0,0 +1,106 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; +use Test::More; + +use Devel::Peek qw( SvREFCNT ); +use File::Temp qw( tempfile ); +use Params::Validate qw( validate SCALAR HANDLE ); + +{ + my $fh = tempfile(); + my @p = ( + foo => 1, + bar => $fh, + ); + + my $ref = val1(@p); + + eval { $ref->{foo} = 2 }; + ok( !$@, 'returned hashref values are not read only' ); + is( $ref->{foo}, 2, 'double check that setting value worked' ); + is( $fh, $ref->{bar}, 'filehandle is not copied during validation' ); +} + +{ + + package ScopeTest; + + my $live = 0; + + sub new { $live++; bless {}, shift } + sub DESTROY { $live-- } + + sub Live {$live} +} + +{ + my @p = ( foo => ScopeTest->new() ); + + is( + ScopeTest->Live(), 1, + 'one live object' + ); + + my $ref = val2(@p); + + isa_ok( $ref->{foo}, 'ScopeTest' ); + + @p = (); + + is( + ScopeTest->Live(), 1, + 'still one live object' + ); + + ok( + defined $ref->{foo}, + 'foo key stays in scope after original version goes out of scope' + ); + is( + SvREFCNT( $ref->{foo} ), 1, + 'ref count for reference is 1' + ); + + undef $ref->{foo}; + + is( + ScopeTest->Live(), 0, + 'no live objects' + ); +} + +sub val1 { + my $ref = validate( + @_, { + foo => { type => SCALAR }, + bar => { type => HANDLE, optional => 1 }, + }, + ); + + return $ref; +} + +sub val2 { + my $ref = validate( + @_, { + foo => 1, + }, + ); + + return $ref; +} + +done_testing(); + diff --git a/t/release-pp-29-taint-mode.t b/t/release-pp-29-taint-mode.t new file mode 100644 index 0000000..6e8b60d --- /dev/null +++ b/t/release-pp-29-taint-mode.t @@ -0,0 +1,65 @@ +#!perl -T + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + + +use strict; +use warnings; + +use Test::Requires { + 'Test::Taint' => 0.02, +}; + +use Test::Fatal; +use Test::More; + +use Params::Validate qw( validate validate_pos ARRAYREF ); + +taint_checking_ok('These tests are meaningless unless we are in taint mode.'); + +sub test1 { + my $def = $0; + tainted_ok( $def, 'make sure $def is tainted' ); + + # The spec is irrelevant, all that matters is that there's a + # tainted scalar as the default + my %p = validate( @_, { foo => { default => $def } } ); +} + +{ + is( + exception { test1() }, + undef, + 'no taint error when we validate with tainted default value' + ); +} + +sub test2 { + return validate_pos( @_, { regex => qr/^b/ } ); +} + +SKIP: +{ + skip 'This test only passes on Perl 5.14+', 1 + unless $] >= 5.014; + + my @p = 'cat'; + taint(@p); + + like( + exception { test2(@p) }, + qr/\QParameter #1 ("cat") to main::test2 did not pass regex check/, + 'no taint error when we validate with tainted value values being validated' + ); +} + +done_testing(); + diff --git a/t/release-pp-30-hashref-alteration.t b/t/release-pp-30-hashref-alteration.t new file mode 100644 index 0000000..d1571cb --- /dev/null +++ b/t/release-pp-30-hashref-alteration.t @@ -0,0 +1,64 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; +use Test::More; + +use Params::Validate qw( validate SCALAR ); + +{ + my $p = { foo => 1 }; + + val($p); + + is_deeply( + $p, { foo => 1 }, + 'validate does not alter hashref passed to val' + ); + + val2($p); + + is_deeply( + $p, { foo => 1 }, + 'validate does not alter hashref passed to val, even with defaults being supplied' + ); +} + +sub val { + validate( + @_, { + foo => { optional => 1 }, + bar => { optional => 1 }, + baz => { optional => 1 }, + buz => { optional => 1 }, + }, + ); + + return; +} + +sub val2 { + validate( + @_, { + foo => { optional => 1 }, + bar => { default => 42 }, + baz => { optional => 1 }, + buz => { optional => 1 }, + }, + ); + + return; +} + +done_testing(); + diff --git a/t/release-pp-31-incorrect-spelling.t b/t/release-pp-31-incorrect-spelling.t new file mode 100644 index 0000000..98f32c2 --- /dev/null +++ b/t/release-pp-31-incorrect-spelling.t @@ -0,0 +1,73 @@ +#!/usr/bin/perl -w + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + + +use strict; +use warnings; + +use Test::More; + +use Params::Validate qw( validate validate_pos SCALAR ); + +plan skip_all => 'Spec validation is disabled for now'; + +{ + my @p = ( foo => 1, bar => 2 ); + + eval { + validate( + @p, { + foo => { + type => SCALAR, + callbucks => { + 'one' => sub {1} + }, + }, + bar => { type => SCALAR }, + } + ); + }; + + like( $@, qr/is not an allowed validation spec key/ ); + + eval { + validate( + @p, { + foo => { + hype => SCALAR, + callbacks => { + 'one' => sub {1} + }, + }, + bar => { type => SCALAR }, + } + ); + }; + + like( $@, qr/is not an allowed validation spec key/ ); + eval { + validate( + @p, { + foo => { + type => SCALAR, + regexp => qr/^\d+$/, + }, + bar => { type => SCALAR }, + } + ); + }; + + like( $@, qr/is not an allowed validation spec key/ ); +} + +done_testing(); + diff --git a/t/release-pp-32-regex-as-value.t b/t/release-pp-32-regex-as-value.t new file mode 100644 index 0000000..4eb0d05 --- /dev/null +++ b/t/release-pp-32-regex-as-value.t @@ -0,0 +1,50 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Params::Validate qw( validate SCALAR SCALARREF ); + +use Test::More; +use Test::Fatal; + +is( + exception { v( foo => qr/foo/ ) }, + undef, + 'no exception with regex object' +); + +is( + exception { v( foo => 'foo' ) }, + undef, + 'no exception with plain scalar' +); + +my $foo = 'foo'; +is( + exception { v( foo => \$foo ) }, + undef, + 'no exception with scalar ref' +); + +done_testing(); + +sub v { + validate( + @_, { + foo => { type => SCALAR | SCALARREF }, + }, + ); + return; +} + diff --git a/t/release-pp-33-keep-errsv.t b/t/release-pp-33-keep-errsv.t new file mode 100644 index 0000000..24f3ded --- /dev/null +++ b/t/release-pp-33-keep-errsv.t @@ -0,0 +1,36 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Params::Validate qw( validate SCALAR ); + +use Test::More; + +{ + $@ = 'foo'; + v( bar => 42 ); + + is( + $@, + 'foo', + 'calling validate() does not clobber' + ); +} + +done_testing(); + +sub v { + validate( @_, { bar => { type => SCALAR } } ); +} + diff --git a/t/release-pp-34-recursive-validation.t b/t/release-pp-34-recursive-validation.t new file mode 100644 index 0000000..9dc6194 --- /dev/null +++ b/t/release-pp-34-recursive-validation.t @@ -0,0 +1,67 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Test::Fatal; +use Test::More; + +{ + package Foo; + + use Params::Validate qw( validate SCALAR ); + + Params::Validate::validation_options( allow_extra => 1 ); + + sub test_foo { + my %p = validate( @_, { arg1 => { type => SCALAR } } ); + print "test foo\n"; + } +} + +{ + package Bar; + + use Params::Validate qw( validate SCALAR ); + Params::Validate::validation_options( allow_extra => 0 ); + + sub test_bar { + + # catch die signal + local $SIG{__DIE__} = sub { + + # we died from within Params::Validate (because of wrong_Arg) we + # call Foo::test_foo with OK args, but it'll die, because + # Params::Validate::PP::options is still set to the options of the + # Bar package, and so it won't retreive the one from Foo. + Foo::test_foo( arg1 => 1, extra_arg => 2 ); + }; + + # this will die because the arg received is 'wrong_arg' + my %p = validate( @_, { arg1 => { type => SCALAR } } ); + } +} + +{ + # This bug only manifests with the pure Perl code because of its use of local + # to remember the per-package options. + local $TODO = 'Not sure how to fix this one'; + unlike( + exception { Bar::test_bar( bad_arg => 2 ) }, + qr/was passed in the call to Foo::test_foo/, + 'no exception from Foo::test_foo when when calling validate() from within a __DIE__ handler' + ); +} + +done_testing(); + diff --git a/t/release-pp-35-default-xs-bug.t b/t/release-pp-35-default-xs-bug.t new file mode 100644 index 0000000..feec141 --- /dev/null +++ b/t/release-pp-35-default-xs-bug.t @@ -0,0 +1,34 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Test::More 0.88; + +use Params::Validate qw( :all ); + +default_test(); + +done_testing(); + +sub default_test { + my ( $first, $second ) = validate_pos( + @_, + { type => SCALAR, optional => 1 }, + { type => SCALAR, optional => 1, default => 'must be second one' }, + ); + + is( $first, undef, '01 no default for first' ); + is( $second, 'must be second one', '01 default for second' ); +} + diff --git a/t/release-pp-36-large-arrays.t b/t/release-pp-36-large-arrays.t new file mode 100644 index 0000000..6301d91 --- /dev/null +++ b/t/release-pp-36-large-arrays.t @@ -0,0 +1,55 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Test::Fatal; +use Test::More; + +{ + package Foo; + + use Params::Validate qw( validate ARRAYREF ); + + sub v1 { + my %p = validate( + @_, { + array => { + callbacks => { + 'checking array contents' => sub { + for my $x ( @{ $_[0] } ) { + return 0 unless defined $x && !ref $x; + } + return 1; + }, + } + } + } + ); + return $p{array}; + } +} + +{ + for my $size ( 100, 1_000, 100_000 ) { + my @array = ('x') x $size; + is_deeply( + Foo::v1( array => \@array ), + \@array, + "validate() handles $size element array correctly" + ); + } +} + +done_testing(); + diff --git a/t/release-pp-37-exports.t b/t/release-pp-37-exports.t new file mode 100644 index 0000000..607aefc --- /dev/null +++ b/t/release-pp-37-exports.t @@ -0,0 +1,65 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Test::More; +use Params::Validate (); + +my @types = qw( + SCALAR + ARRAYREF + HASHREF + CODEREF + GLOB + GLOBREF + SCALARREF + HANDLE + BOOLEAN + UNDEF + OBJECT +); + +my @subs = qw( + validate + validate_pos + validation_options + validate_with +); + +is_deeply( + [ sort @Params::Validate::EXPORT_OK ], + [ sort @types, @subs, 'set_options' ], + '@EXPORT_OK' +); + +is_deeply( + [ sort keys %Params::Validate::EXPORT_TAGS ], + [qw( all types )], + 'keys %EXPORT_TAGS' +); + +is_deeply( + [ sort @{ $Params::Validate::EXPORT_TAGS{all} } ], + [ sort @types, @subs ], + '$EXPORT_TAGS{all}', +); + +is_deeply( + [ sort @{ $Params::Validate::EXPORT_TAGS{types} } ], + [ sort @types ], + '$EXPORT_TAGS{types}', +); + +done_testing(); + diff --git a/t/release-pp-38-callback-message.t b/t/release-pp-38-callback-message.t new file mode 100644 index 0000000..8e1f2c2 --- /dev/null +++ b/t/release-pp-38-callback-message.t @@ -0,0 +1,126 @@ + + +use Test::More; + +BEGIN { + unless ( $ENV{RELEASE_TESTING} ) { + plan skip_all => 'these tests are for release testing'; + } + + $ENV{PV_TEST_PERL} = 1; +} + +use strict; +use warnings; + +use Test::More; +use Params::Validate qw( validate ); + +{ + my $e = _test_args( + pos_int => 42, + string => 'foo', + ); + is( + $e, + q{}, + 'no error with good args' + ); +} + +{ + my $e = _test_args( + pos_int => 42, + string => [], + ); + like( + $e, + qr/The 'string' parameter \("ARRAY\(.+\)"\) to main::validate1 did not pass the 'string' callback: ARRAY\(.+\) is not a string/, + 'got error for bad string' + ); +} + +{ + my $e = _test_args( + pos_int => 0, + string => 'foo', + ); + like( + $e, + qr/\QThe 'pos_int' parameter ("0") to main::validate1 did not pass the 'pos_int' callback: 0 is not a positive integer/, + 'got error for bad pos int (0)' + ); +} + +{ + my $e = _test_args( + pos_int => 'bar', + string => 'foo', + ); + like( + $e, + qr/\QThe 'pos_int' parameter ("bar") to main::validate1 did not pass the 'pos_int' callback: bar is not a positive integer/, + 'got error for bad pos int (bar)' + ); +} + +{ + my $e = do { + local $@; + eval { validate2( string => [] ); }; + $@; + }; + + is_deeply( + $e, + { error => 'not a string' }, + 'ref thrown by callback is preserved, not stringified' + ); +} + +sub _test_args { + local $@; + eval { validate1(@_) }; + return $@; +} + +sub validate1 { + validate( + @_, { + pos_int => { + callbacks => { + pos_int => sub { + $_[0] =~ /^[1-9][0-9]*$/ + or die "$_[0] is not a positive integer\n"; + }, + }, + }, + string => { + callbacks => { + string => sub { + ( defined $_[0] && !ref $_[0] && length $_[0] ) + or die "$_[0] is not a string\n"; + }, + }, + }, + } + ); +} + +sub validate2 { + validate( + @_, { + string => { + callbacks => { + string => sub { + ( defined $_[0] && !ref $_[0] && length $_[0] ) + or die { error => 'not a string' }; + }, + }, + }, + } + ); +} + +done_testing(); + diff --git a/t/release-pp-is-loaded.t b/t/release-pp-is-loaded.t new file mode 100644 index 0000000..1736ced --- /dev/null +++ b/t/release-pp-is-loaded.t @@ -0,0 +1,28 @@ + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + +use strict; +use warnings; + +use Test::More; + +BEGIN { + $ENV{PV_TEST_PERL} = 1; + $ENV{PV_WARN_FAILED_IMPLEMENTATION} = 1; +} + +use Module::Implementation 0.04 (); +use Params::Validate; + +is( + Module::Implementation::implementation_for('Params::Validate'), + 'PP', + 'PP implementation is loaded when env var is set' +); + +done_testing(); diff --git a/t/release-synopsis.t b/t/release-synopsis.t new file mode 100644 index 0000000..2d9b8ee --- /dev/null +++ b/t/release-synopsis.t @@ -0,0 +1,13 @@ +#!perl + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + + +use Test::Synopsis; + +all_synopsis_ok(); diff --git a/t/release-xs-is-loaded.t b/t/release-xs-is-loaded.t new file mode 100644 index 0000000..bebb130 --- /dev/null +++ b/t/release-xs-is-loaded.t @@ -0,0 +1,25 @@ + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + +use strict; +use warnings; + +use Test::More; + +BEGIN { $ENV{PV_WARN_FAILED_IMPLEMENTATION} = 1 } + +use Module::Implementation 0.04 (); +use Params::Validate; + +is( + Module::Implementation::implementation_for('Params::Validate'), + 'XS', + 'XS implementation is loaded by default' +); + +done_testing(); diff --git a/t/release-xs-segfault.t b/t/release-xs-segfault.t new file mode 100644 index 0000000..892ab2c --- /dev/null +++ b/t/release-xs-segfault.t @@ -0,0 +1,34 @@ + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + +use strict; +use warnings; + +use Test::More; + +BEGIN { + $ENV{PARAMS_VALIDATE_IMPLEMENTATION} = 'XS'; + $ENV{PV_WARN_FAILED_IMPLEMENTATION} = 1; +} + +use Params::Validate qw( validate SCALAR ); + +eval { foo( { a => 1 } ) }; + +ok(1, 'did not segfault'); + +done_testing(); + +sub foo { + validate( + @_, + { + a => { type => SCALAR, depends => ['%s%s%s'] }, + } + ); +} diff --git a/t/release-xs-stack-realloc.t b/t/release-xs-stack-realloc.t new file mode 100644 index 0000000..3441157 --- /dev/null +++ b/t/release-xs-stack-realloc.t @@ -0,0 +1,60 @@ + +BEGIN { + unless ($ENV{RELEASE_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + +use strict; +use warnings; + +use Test::More; + +BEGIN { + $ENV{PARAMS_VALIDATE_IMPLEMENTATION} = 'XS'; + $ENV{PV_WARN_FAILED_IMPLEMENTATION} = 1; +} + +use Params::Validate qw( validate_with ); + +my $alloc_size; +for my $i ( 0 .. 15 ) { + $alloc_size = 2**$i; + test_array_spec(undef); +} + +ok( 1, 'array validation succeeded with stack realloc' ); + +for my $i ( 0 .. 15 ) { + $alloc_size = 2**$i; + test_hash_spec( a => undef ); +} + +ok( 1, 'hash validation succeeded with stack realloc' ); + +done_testing(); + +sub grow_stack { + my @stuff = (1) x $alloc_size; + + # "validation" always succeeds - we just need the stack to grow inside a + # callback to trigger the bug. + return 1; +} + +sub test_array_spec { + my @args = validate_with( + params => \@_, + spec => [ { callbacks => { grow_stack => \&grow_stack } } ], + ); +} + +sub test_hash_spec { + my %args = validate_with( + params => \@_, + spec => { + a => { callbacks => { grow_stack => \&grow_stack } }, + }, + ); +} diff --git a/tidyall.ini b/tidyall.ini new file mode 100644 index 0000000..f346233 --- /dev/null +++ b/tidyall.ini @@ -0,0 +1,19 @@ +[PerlTidy] +select = **/*.{pl,pm,t,psgi} +ignore = t/00-* +ignore = t/author-* +ignore = t/release-* +ignore = blib/**/* +ignore = .build/**/* +ignore = Params-Validate-*/**/* +argv = --profile=$ROOT/perltidyrc + +[PerlCritic] +select = **/*.{pl,pm,t,psgi} +ignore = t/00-* +ignore = t/author-* +ignore = t/release-* +ignore = blib/**/* +ignore = .build/**/* +ignore = Params-Validate-*/**/* +argv = --profile $ROOT/perlcriticrc --program-extensions .pl --program-extensions .t --program-extensions .psgi diff --git a/weaver.ini b/weaver.ini new file mode 100644 index 0000000..90c76a6 --- /dev/null +++ b/weaver.ini @@ -0,0 +1,17 @@ +[@CorePrep] + +[Name] +[Version] + +[Region / prelude] + +[Generic / SYNOPSIS] +[Generic / DESCRIPTION] + +[Leftovers] + +[Region / postlude] + +[Authors] +[Contributors] +[Legal] |