Import Upstream version 1.63
This commit is contained in:
denghao
commit
026e00b6f6
|
|
@ -0,0 +1,732 @@
|
|||
1.63 -- 2022-08-08
|
||||
[BUGFIXES]
|
||||
* Fix off-by-one in stack handling of head() / tail() (RT143905)
|
||||
* Fix documentation copy-paste error about builtin::reftype
|
||||
* Ensure exotic_names.t will work on EBCDIC platforms
|
||||
* Add basic Github CI workflow
|
||||
|
||||
1.62 -- 2022-03-17
|
||||
[CHANGES]
|
||||
* Prepare for perl 5.35.10 release:
|
||||
+ Skip the tainted tests if your perl was built without taint
|
||||
support
|
||||
+ Document the existence of the `builtin::` equivalents for
|
||||
several Scalar::Util functions
|
||||
|
||||
1.61 -- 2022-02-16
|
||||
[BUGFIXES]
|
||||
* Fix some more signed comparison warnings (Perl5 #19429)
|
||||
|
||||
1.60 -- 2021-10-08
|
||||
[BUGFIXES]
|
||||
* Quiet some -Wsign-compare warnings by using `int` instead of `UV`
|
||||
(RT136985)
|
||||
* Quiet a -Wmaybe-uninitialized warning by ensuring a variable is
|
||||
always initialised, because the compiler can't always determine this
|
||||
is safe (RT139356)
|
||||
* Avoid SIGFPE in product(-1, ...) (RT139601)
|
||||
|
||||
1.59 -- 2021-09-12
|
||||
[CHANGES]
|
||||
* Removed Scalar::Util::isbool() as the API design for older perls
|
||||
isn't quite clear, and it doesn't do anything useful on any
|
||||
currently-released perl version
|
||||
* Tidy up the unnecessary bits of @EXPORT_FAIL
|
||||
* Use the new G_LIST constant rather than G_ARRAY
|
||||
|
||||
1.58 -- 2021-09-12
|
||||
(bad release because I forgot to `git push`)
|
||||
|
||||
1.57 -- 2021-09-11
|
||||
[CHANGES]
|
||||
* Added Scalar::Util::isbool() to track new core-supported boolean
|
||||
value nature on scalars
|
||||
* Fix various typoes in docs, code comments, etc...
|
||||
* Removed code conditional on whether SvWEAKREF is supported, as
|
||||
every perl since v5.6 supports it
|
||||
|
||||
[BUGFIXES]
|
||||
* Fix segfaults when an undefined subroutine is passed to
|
||||
block-taking subs (thanks ilmari)
|
||||
* Correct refcount handling on hv_store_ent to PL_DBsub in
|
||||
set_subname() (thanks nwc10)
|
||||
* Don't rely on Scalar::Util functions when unit-testing List::Util
|
||||
ones (thanks haarg)
|
||||
|
||||
1.56 -- 2021-03-30
|
||||
[CHANGES]
|
||||
* Added `List::Util::zip`, `List::Util::mesh` and related functions
|
||||
(RT129479)
|
||||
* Updated embedded ppport.h for Devel::PPPort v3.62
|
||||
|
||||
1.55 -- 2020-04-09
|
||||
[CHANGES]
|
||||
* Added List::Util::uniqint
|
||||
* Improvements to List::Util::uniqnum handling of floating-point
|
||||
values on odd platform configurations (thanks sisyphus)
|
||||
* Improvements to $RAND-based unit tests
|
||||
|
||||
1.54 -- 2020-02-02 15:47
|
||||
[CHANGES]
|
||||
* Added List::Util::reductions (RT128237)
|
||||
* Added List::Util::sample (RT131535)
|
||||
* Recognise $List::Util::RAND as a source of randomness for sampling
|
||||
functions (RT131536)
|
||||
|
||||
[BUGFIXES]
|
||||
* Document the difference between ref() and reftype() on precompiled
|
||||
qr// regexps (RT127963)
|
||||
* Various improvements to List::Util::uniqnum() to handle stringified
|
||||
Inf and NaN, negative zero
|
||||
* Detect platform NV size and number of digits required to calculate
|
||||
uniqueness
|
||||
|
||||
1.53 -- 2019-10-24 10:41:12
|
||||
[BUGFIXES]
|
||||
* Handle Unicode package names in Scalar::Util::blessed (GH #81)
|
||||
|
||||
1.52 -- 2019-08-17 19:08:18
|
||||
[BUGFIXES]
|
||||
* Fix uniqnum() on large stringified integers on long- and
|
||||
quad-double perls (thanks ilmari)
|
||||
|
||||
1.51 -- 2019-08-08 14:31:32
|
||||
[CHANGES]
|
||||
* Add TO_JSON to List::Util::_Pair (thanks ilmari)
|
||||
* Various minor docs fixes
|
||||
|
||||
[BUGFIXES]
|
||||
* Don't segfault in subname() on deleted stashes (thanks ilmari)
|
||||
* Fix uniqnum for large floats and numeric strings (thanks ilmari)
|
||||
|
||||
1.50 -- 2018-02-20 19:13:27
|
||||
[CHANGES]
|
||||
* Added head() and tail() functions (thanks preaction)
|
||||
* Support binary and Unicode in symbol names for set_subname()
|
||||
|
||||
[BUGFIXES]
|
||||
* Fix building with C++ and C89 compilers
|
||||
* Fix uniq() test for old Test::More
|
||||
* Fix example get_code_info for unnamed subs (RT#116962)
|
||||
* Fixes for symbol names containing ' characters
|
||||
* Don't leak SVs from sum0/product1 when called with zero args
|
||||
(RT#124017)
|
||||
* Use sv_rvunweaken() in Scalar::Util::unweaken() (thanks ilmari)
|
||||
* Misc. fixes for perl 5.6
|
||||
|
||||
1.49 -- 2017-09-08 12:25:54
|
||||
[CHANGES]
|
||||
* Fixes for unit tests to pass on perl 5.6.2
|
||||
* Fix typo in documentation
|
||||
|
||||
1.48 -- 2017/06/23 17:29:42
|
||||
[CHANGES]
|
||||
* Note in documentation that outer function's @_ can be accessed in
|
||||
some blocks, but ought not be (thanks wchristian)
|
||||
|
||||
[BUGFIXES]
|
||||
* Ensure pairmap extends its stack correctly (thanks davem)
|
||||
* Fix name of List::Util::unpairs in its error messages
|
||||
|
||||
1.47 -- 2016/12/22 18:54:45
|
||||
[CHANGES]
|
||||
* Make XS code ppport.h-free when in core
|
||||
|
||||
[BUGFIXES]
|
||||
* Fix compliling on C++11
|
||||
* Perform taint checks using $^X instead of some %ENV key because of
|
||||
the Test::Simple vars (RT119169)
|
||||
|
||||
1.46 -- 2016/09/28 23:17:07
|
||||
[CHANGES]
|
||||
* Remember to add unpairs and uniq to SYNOPSIS
|
||||
* Document the behaviour of uniqnum() on NaN
|
||||
|
||||
[BUGFIXES]
|
||||
* C89 fixes
|
||||
* Various internal bugfixes backported from perl core
|
||||
|
||||
1.45 -- 2016/03/25 16:09:40
|
||||
[CHANGES]
|
||||
* Renamed existing uniq() to uniqstr()
|
||||
* Canonicalise undef to {empty string,zero} in uniq{str,num}()
|
||||
* Add a new uniq() with more DWIMish semantics around undef
|
||||
|
||||
[BUGFIXES]
|
||||
* Fix uses of GET magic by the uniq*() family of functions. GET magic
|
||||
is now always invoked exactly once if it exists.
|
||||
|
||||
1.44 -- 2016/03/17 23:08:46
|
||||
[CHANGES]
|
||||
* Added List::Util::uniq() and uniqnum()
|
||||
(with thanks to randir and ilmari for assistance writing code and
|
||||
tests)
|
||||
|
||||
1.43 -- 2016/02/08 15:05:23
|
||||
[CHANGES]
|
||||
* Updated documentation
|
||||
* Added MIN_PERL_VERSION to Makefile.PL
|
||||
* Added "use warnings" to all tests
|
||||
* Added MANIEST.SKIP patterns for common editor backup/swapfiles
|
||||
* Test product(0,0) (RT105415)
|
||||
|
||||
[BUGFIXES]
|
||||
* Fix build on non-C99 compilers
|
||||
* Avoid divide-by-zero exception if product()'s accumulator is IV zero
|
||||
(RT105415)
|
||||
* Possible fix for SvTEMP issues in first and any/all/none/notall
|
||||
(RT96343)
|
||||
|
||||
1.42 -- 2015/04/32 01:25:55
|
||||
[CHANGES]
|
||||
* Added List::Util::unpairs() - the inverse of pairs()
|
||||
* Documentation to pre-warn users about the possible behaviour in a
|
||||
later version where the pair* higher-order functionals are no longer
|
||||
transparent to $_
|
||||
|
||||
[BUGFIXES]
|
||||
* Silence some warnings at test time
|
||||
* Ensure that the List::Util we're loading the XS via is a sufficient
|
||||
version when Scalar::Util or Sub::Util load it (RT100863)
|
||||
|
||||
1.41 -- 2014/09/05 15:49:50
|
||||
[BUGFIXES]
|
||||
* Avoid pre-C99 declaration after statements (RT98624)
|
||||
* Fix use of GetMagic in List::Util::reduce (RT63211)
|
||||
|
||||
1.40 -- 2014/08/30 11:36:36
|
||||
[CHANGES]
|
||||
* Added entire new module, Sub::Util to contain functions related
|
||||
to CODE refs
|
||||
* Added subname inspired by Sub::Identify
|
||||
* Added set_subname copied and renamed from Sub::Name
|
||||
* Also moved set_prototype into Sub::Name, with back-compat wrapper
|
||||
in Scalar::Util
|
||||
* Added prototype wrapper of CODE::prototype, for completeness
|
||||
* Nicer module documentation format, allows neater use of L</...>
|
||||
|
||||
[THANKS]
|
||||
* This change was written at the YAPC::EU 2014 Hackathon hosted by
|
||||
Liz Mattijsen and Wendy van Dijk; much thanks to them for being its
|
||||
catalyst.
|
||||
|
||||
1.39 -- 2014/06/05 15:54:59
|
||||
[CHANGES]
|
||||
* Have pairs() return blessed objects that recognise ->key and
|
||||
->value as well as being two-element ARRAYs
|
||||
* Booleanise the result of looks_like_number() so as not to
|
||||
accidentally leak abstraction (RT94806)
|
||||
* Document the version each function was added in (RT96220)
|
||||
|
||||
[BUGFIXES]
|
||||
* Try to preserve UV precision in sum() where possible (RT95902)
|
||||
* Document known lexical capture in pairmap bug RT95409
|
||||
* SvGETMAGIC() in set_prototype() (RT72080)
|
||||
|
||||
1.38 -- 2014/01/22 15:33:24
|
||||
[BUGFIXES]
|
||||
* Avoid Perl_ckwarn() in unweaken() because it's missing on older
|
||||
perls; ckWARN() like the rest of the code (RT92363)
|
||||
|
||||
1.37 -- 2014/01/21 14:44:34
|
||||
[BUGFIXES]
|
||||
* Fix unweaken() for perls < 5.14; need to use sv_setsv() to undef
|
||||
rather than sv_clear() (RT92226)
|
||||
|
||||
1.36 -- 2014/01/16 15:40:47
|
||||
[CHANGES]
|
||||
* Added Scalar::Util::unweaken()
|
||||
* Various documentation changes/updates
|
||||
|
||||
[BUGFIXES]
|
||||
* Correct uses of overload operators in unit tests (RT91969)
|
||||
|
||||
1.35 -- Sat Oct 19 01:35 UTC 2013
|
||||
|
||||
* Added List::Util::product()
|
||||
* Ensure that List::Util::{any,all,none,notall} return PL_sv_{yes,no}
|
||||
* Implement reduce() and first() even in the absence of MULTICALL
|
||||
|
||||
1.34 -- Wed Oct 16 13:04 UTC 2013
|
||||
|
||||
* Avoid C99/C++-style comments in XS code
|
||||
* Fix dualvar tests for perl 5.6; fix skip() test counts in dualvar.t
|
||||
* Neater documentation examples of other functions that can be built using
|
||||
reduce
|
||||
|
||||
1.33 -- Sun Oct 13 01:35 UTC 2013
|
||||
|
||||
* Added any, all, none, notall list reduction functions
|
||||
(inspired by List::MoreUtils)
|
||||
|
||||
1.32 -- Sun Aug 31 23:48 UTC 2013
|
||||
|
||||
* Skip pairmap()'s MULTICALL implementation 5.8.9 / 5.10.0 as it doesn't
|
||||
work (RT87857)
|
||||
* Comment on the fact that package "0" is defined but false (RT88201)
|
||||
* TODO test in t/readonly.t now passes since 5.19.3 (RT88223)
|
||||
|
||||
1.31 -- Wed Aug 14 20:38 UTC 2013
|
||||
|
||||
* Bugfix pairmap to return list length in scalar context
|
||||
* Added "Odd number of elements" warnings to all pair* functions
|
||||
|
||||
1.30 -- Mon Aug 05 13:09 UTC 2013
|
||||
|
||||
* Added pairfirst
|
||||
* Added MULTICALL implementations to pairmap/pairgrep/pairfirst
|
||||
* Fix declaration-after-code for C99-challenged compilers
|
||||
* Documentation updates to List::Util
|
||||
|
||||
1.29 -- Thu Aug 01 13:40 UTC 2013
|
||||
|
||||
* Bugfix to pairmap/pairgrep when stack moves beneath them during operation
|
||||
|
||||
1.28 -- Thu Aug 01 12:19 UTC 2013
|
||||
-- BROKEN; do not use. See 1.29
|
||||
|
||||
* Added pairgrep, pairmap, pairs (inspired by List::Pairwise)
|
||||
* Added pairkeys and pairvalues
|
||||
|
||||
1.26_001 -- Sun Dec 23 15:58
|
||||
|
||||
* Fix multicall refcount bug RT#80646
|
||||
|
||||
1.26 -- Sun Dec 16 19:39
|
||||
|
||||
* Merge patch from JDHEDDEN - Add Scalar::Util::isdual() RT#76150
|
||||
|
||||
1.25_01 -- Wed Nov 21 09:47
|
||||
|
||||
* Fix a hash order dependency bug t/tainted.t
|
||||
(Currently this is a core only version to fix perl5 smokes)
|
||||
|
||||
1.25 -- Sat Mar 24 13:10:13 UTC 2012
|
||||
|
||||
* Restore back-compat. to perl 5.6 (thanks to Zefram)
|
||||
|
||||
1.24 -- Thu Mar 22 18:10:10 UTC 2012
|
||||
|
||||
* Update to 1.24 release version (no other changes since 1.23_04).
|
||||
|
||||
1.23_04 -- Sat Mar 10 00:16:16 UTC 2012
|
||||
|
||||
* RT#72700 Fix off-by-two on string literal length
|
||||
|
||||
1.23_03 -- Tue Sep 14 10:09:59 CDT 2010
|
||||
|
||||
* Min perl version supported for build is not 5.008
|
||||
* Dropped the pure-Perl implementation of both Scalar::- and List::Util.
|
||||
* RT#61118 Fix assumption in sum() that once magic, always magic
|
||||
|
||||
1.23_02 -- Tue Mar 30 11:09:15 CDT 2010
|
||||
|
||||
* Fix first() and reduce() to check the callback first; &first(1) is now illigal. [gfx]
|
||||
* Fix reduce() to allow XSUB callbacks [gfx]
|
||||
* Fix first() to allow XSUB callbacks [gfx]
|
||||
* Resolve RT #55763: tainted() doesn't do SvGETMAGIC(sv) [gfx]
|
||||
* define CvISXSUB so older perl versions will still compile
|
||||
|
||||
1.23_01 -- Mon Mar 22 08:24:11 CDT 2010
|
||||
|
||||
* Add failing tests; SVt_RV is not directly SvROK [gfx]
|
||||
* Implement openhandle() in XS (with extra tests) [gfx]
|
||||
* Modernize *.pm [gfx]
|
||||
* Modernize ListUtil.xs [gfx]
|
||||
* Add ppport.h [gfx]
|
||||
* Fix an overloading issue on sum(), and add tests for overloading [gfx]
|
||||
* Small tweaks for minstr()/maxstr() [gfx]
|
||||
* Optimize dualvar() [gfx]
|
||||
* Use sv_copypv() instead of SvPV() and sv_setpv() [gfx]
|
||||
* avoid non-portable warnings
|
||||
|
||||
1.23 -- Wed Mar 10 20:50:00 CST 2010
|
||||
|
||||
* Add a test file to ensure 'GETMAGIC' called once [gfx]
|
||||
* "GETMAGIC" should be called only once [gfx]
|
||||
* Use PERL_NO_GET_CONTEXT for efficiency (see perlguts) [gfx]
|
||||
* Don't care about dVAR. ExtUtils::ParseXS deals with it. [gfx]
|
||||
* t/p_max.t, t/p_min.t fail on perl5.8.1. [tokuhirom]
|
||||
* avoid non-portable warnings
|
||||
* Fix PP::reftype in edge cases [gfx]
|
||||
|
||||
1.22 -- Sat Nov 14 09:26:15 CST 2009
|
||||
|
||||
* silence a compiler warning about an unreferenced local variable [Steve Hay]
|
||||
* RT#51484 Preserve utf8 flag of string passed to dualvar()
|
||||
* RT#51454 Check first argument to first/reduce is a code reference
|
||||
* RT#50528 [PATCH] p_tainted.t fix for VMS [Craig A. Berry]
|
||||
* RT#48550 fix pure perl looks_like_number not to match non-ascii digits
|
||||
|
||||
1.21 -- Mon May 18 10:32:14 CDT 2009
|
||||
|
||||
* Change build system for perl-only install not to need to modify blib
|
||||
* When building inside perl, tests for weaken should be always run (Alexandr Ciornii)
|
||||
|
||||
1.20 -- Wed May 13 16:42:53 CDT 2009
|
||||
|
||||
*** NOTE***
|
||||
This distribution now requires perl 5.6 or greater
|
||||
|
||||
Bug Fixes
|
||||
* Fixed stack pop issue in POP_MULTICALL
|
||||
* Fixed error reporting in import when XS not compiled
|
||||
* Check first argument to reduce is a CODE reference to avoid segfault
|
||||
* Handle overloaded and tied values
|
||||
* Fix tainted test to run on Win32
|
||||
|
||||
Enhancements
|
||||
* Added List::Util::XS so authors can depend on XS version
|
||||
* Removed need for dummy methods in UNIVERSAL for perl-only code
|
||||
|
||||
|
||||
1.19 -- Sun Dec 10 09:58:03 CST 2006
|
||||
|
||||
Bug Fixes
|
||||
* Fix invalid conversion from `const char*' to `char*' warnings
|
||||
* Avoid Makefile error when building on Win32
|
||||
* Fix undefined symbol error for perl < 5.9.0
|
||||
* Fix hardcoded "/" in a filepath that causes p_tainted.t to fail on VMS
|
||||
|
||||
Documentation
|
||||
* Document that reduce calls BLOCK in a scalar context
|
||||
* Add SEE ALSO sections to docs
|
||||
|
||||
Enhancements
|
||||
* A new regression test for readonly, taking a reference to a constant passed to a sub
|
||||
|
||||
1.18 -- Fri Nov 25 09:30:29 CST 2005
|
||||
|
||||
Bug Fixes
|
||||
* Fix pure-perl version of refaddr to avoid blessing an un-blessed reference
|
||||
* Fix memory leak in first() and reduce()
|
||||
* Pure perl version of looks_like_number now matches XS version for
|
||||
references and undef. It will now return undef
|
||||
|
||||
Enhancements
|
||||
* Support for using XSLoader instead of DynaLoader
|
||||
* Use new multicall API
|
||||
|
||||
1.17 -- Mon May 23 08:55:26 CDT 2005
|
||||
|
||||
Bug Fixes
|
||||
* Update XS code to declare PERL_UNUSED_DECL conditionally
|
||||
|
||||
1.16 -- Fri May 20 10:22:49 CDT 2005
|
||||
|
||||
Bug Fixes
|
||||
* Change to refaddr.t test to avoid false errors on some 64 bit platforms
|
||||
* Fix all perl only tests to work when in the core build environment
|
||||
* Fix looks like number test to work for 5.8.5 and above
|
||||
|
||||
1.15 -- Fri May 13 11:01:15 CDT 2005
|
||||
|
||||
Bug Fixes
|
||||
* Fixed memory leak in first()
|
||||
|
||||
Enhancements
|
||||
* Converted tests to use Test::More
|
||||
* Improved test coverage
|
||||
* Changed Makefile.PL to use Module::Install
|
||||
* Refactor use of Sv..X() macros to be Sv.._set()
|
||||
* Changes from Jarkko for Symbian port of Perl
|
||||
* Documentation updates to weaken()
|
||||
|
||||
1.14 -- Sat May 22 08:01:19 BST 2004
|
||||
|
||||
Bug Fixes
|
||||
* Fixed memory leak in reduce()
|
||||
* Added tests to check passing a reference to a constant to weaken() in perl >= 5.008003
|
||||
* Fixed looks_like_number(undef) to return false for perl >= 5.009002
|
||||
* Fixed bug in refaddr() when passed a tied variable
|
||||
|
||||
Switch to svn repository at http://svn.mutatus.co.uk/wsvn/Scalar-List-Utils/trunk/
|
||||
Old perforce revision log below
|
||||
|
||||
Change 827 on 2003/09/25 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Release 1.13
|
||||
|
||||
Change 826 on 2003/09/25 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Fix NV casting issue with some compilers
|
||||
|
||||
Change 825 on 2003/08/14 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Release 1.12
|
||||
|
||||
Change 824 on 2003/08/14 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Don't directly use the SV returned as $a in the next iteration,
|
||||
take a copy instead. Fixes problem if the code block result was from
|
||||
an eval or sub call
|
||||
|
||||
Change 823 on 2003/08/14 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Install into the 'perl' installdirs for >= 5.008
|
||||
|
||||
Change 822 on 2003/08/14 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Fix test for EBCDIC portability
|
||||
|
||||
Change 771 on 2003/03/03 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Get path for make from $Config
|
||||
|
||||
Change 770 on 2003/02/14 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Release 1.11
|
||||
|
||||
Change 769 on 2003/02/14 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Add t/proto.t to MANIFEST
|
||||
|
||||
Change 768 on 2003/02/14 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Add set_prototype from Rafael Garcia-Suarez
|
||||
|
||||
Change 767 on 2003/02/14 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Fix t/isvstring.t so it does not cause perl5.004 to segv
|
||||
because of the exit from within BEGIN
|
||||
|
||||
Change 766 on 2003/02/14 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Change how patchlevel.h is included and check we got what we wanted (from Jarkko)
|
||||
|
||||
Change 765 on 2003/02/14 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Add -DPERL_EXT to DEFINEs, requested by Jarkko for 5.8.1
|
||||
|
||||
Change 764 on 2003/02/04 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Release 1.10
|
||||
|
||||
Change 763 on 2003/02/04 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Fix linking error for older perls
|
||||
|
||||
Change 762 on 2003/02/04 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Make lln tests and perl implementation mimic changes to looks_like_number
|
||||
in different perl versions
|
||||
|
||||
Change 761 on 2003/02/04 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Add looks_like_number
|
||||
|
||||
Change 760 on 2003/02/04 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Ensure PERL_DL_NONLAZY is false so we don't catch link errors during
|
||||
bootstrap and then test the perl only version
|
||||
|
||||
Change 759 on 2002/12/12 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Release 1.09
|
||||
|
||||
Change 758 on 2002/12/12 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Use UV to return refaddr
|
||||
|
||||
Change 757 on 2002/11/03 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Add XS_VERSION
|
||||
|
||||
Change 756 on 2002/11/03 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Use PAD_* macros in 5.9
|
||||
Reuse our own target when calling pp_rand in shuffle() so we dont need to create a fake pad
|
||||
|
||||
Change 751 on 2002/10/18 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Fix context so that sub for reduce/first is always in a scalar context
|
||||
Fix sum/min/max so that they don't upgrade their arguments to NVs
|
||||
if they are IV or UV
|
||||
|
||||
Change 750 on 2002/10/14 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Add isvstring()
|
||||
|
||||
Change 745 on 2002/09/23 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Scalar::Util
|
||||
- Add refaddr()
|
||||
|
||||
Change 722 on 2002/04/29 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Release 1.0701
|
||||
|
||||
Change 721 on 2002/04/29 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Add comment to README about failing tests on perl5.6.0
|
||||
|
||||
Change 714 on 2002/03/18 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Release 1.07
|
||||
|
||||
Change 713 on 2002/03/18 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Add Scalar::Util::openhandle()
|
||||
|
||||
Change 647 on 2001/09/18 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Release 1.06
|
||||
|
||||
Change 645 on 2001/09/07 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Some platforms require the main executable to export symbols
|
||||
needed by modules. In 5.7.2 and prior releases of perl
|
||||
Perl_cxinc was not exported so we need to duplicate its
|
||||
functionality
|
||||
|
||||
Change 644 on 2001/09/07 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Generate a typemap for NV for all perl version up to and
|
||||
including 5.006
|
||||
|
||||
Change 643 on 2001/09/07 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Document problems known with specific versions of perl
|
||||
|
||||
Change 642 on 2001/09/05 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Release 1.05
|
||||
|
||||
Change 641 on 2001/09/05 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Fix shuffle() to compile with threaded perl
|
||||
|
||||
Change 640 on 2001/09/05 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Release 1.04
|
||||
|
||||
Change 639 on 2001/09/05 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Fix context type (caused a core on Tru64)
|
||||
Call pp_rand via *(PL_ppaddr[OP_RAND])
|
||||
|
||||
Change 638 on 2001/09/05 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Documentation updates
|
||||
|
||||
Change 637 on 2001/09/03 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Release 1.03
|
||||
|
||||
Change 636 on 2001/09/03 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
More changes to help merging with core dist
|
||||
|
||||
Change 635 on 2001/09/03 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Added List::Util::shuffle() similar to that described in
|
||||
the perl FAQ except it returns a shuffled list instead of
|
||||
modifying an array passed by reference
|
||||
|
||||
Change 632 on 2001/09/03 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Handle tied variables passed for the number to dualvar()
|
||||
Preserve number type (IV/UV/NV) in dualvar()
|
||||
|
||||
Change 631 on 2001/08/31 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Handle eval{} inside of the code blocks for first and reduce
|
||||
|
||||
Change 629 on 2001/08/22 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
perl5.004 does not like exit from within a BEGIN, it core dumps
|
||||
|
||||
Change 628 on 2001/08/22 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Fix stack problem in first() and reduce()
|
||||
Align with core dist
|
||||
|
||||
Change 483 on 2000/04/10 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Release 1.02
|
||||
|
||||
Change 482 on 2000/04/10 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Check for SvMAGICAL on argument for reftype and blessed
|
||||
|
||||
Change 366 on 2000/03/03 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Release 1.01
|
||||
|
||||
Change 365 on 2000/03/03 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
- Added auto-detection for a compiler and install the perl version
|
||||
if not found
|
||||
- Better perl implemenation of reftype, should be thread-safe now
|
||||
|
||||
Change 364 on 2000/03/03 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
- Added some examples of simple subs that have been requested
|
||||
but not added
|
||||
- Updated copyright dates
|
||||
|
||||
Change 344 on 1999/11/10 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
- Better testcase for reftype
|
||||
|
||||
Change 343 on 1999/11/10 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
- Modules are now called List::Util & Scalar::Util
|
||||
- Supports non-XS install
|
||||
- perl version of reftype now returns "REF" when it should
|
||||
|
||||
Change 311 on 1999/06/01 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Updated README
|
||||
|
||||
Change 275 on 1999/03/22 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Removed forall as it is very broken
|
||||
|
||||
Change 274 on 1999/03/22 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Added List::Util::forall
|
||||
|
||||
Change 273 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Added weaken and isweak to Ref::Util
|
||||
|
||||
Change 272 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Add new .pm files to repository
|
||||
|
||||
Change 271 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
- Split into three packages Ref::Util, List::Util and Scalar::DualVar
|
||||
- readonly and clock were removed in favor of other modules
|
||||
|
||||
Change 270 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Rename package
|
||||
|
||||
Change 269 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
- Added reftype
|
||||
- improved reduce by not doing a sub call
|
||||
- reduce now uses $a and $b
|
||||
- now compiles with 5.005_5x
|
||||
|
||||
Change 178 on 1998/07/26 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Modified XS code so it will compile with 5.004 and 5.005
|
||||
|
||||
Change 115 on 1998/02/21 by <gbarr@pobox.com> (Graham Barr)
|
||||
|
||||
Fri Feb 20 1998 Graham Barr <gbarr@pobox.com>
|
||||
|
||||
t/min.t, t/max.t
|
||||
- Change sor to do a numerical sort
|
||||
|
||||
Fri Dec 19 1997 Graham Barr <gbarr@pobox.com>
|
||||
|
||||
- Added readonly()
|
||||
|
||||
Wed Nov 19 1997 Graham Barr <gbarr@pobox.com>
|
||||
|
||||
- Initial release
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,51 @@
|
|||
Changes
|
||||
lib/List/Util.pm
|
||||
lib/List/Util/XS.pm
|
||||
lib/Scalar/Util.pm
|
||||
lib/Sub/Util.pm
|
||||
ListUtil.xs
|
||||
Makefile.PL
|
||||
MANIFEST This list of files
|
||||
multicall.h
|
||||
ppport.h
|
||||
README
|
||||
t/00version.t
|
||||
t/any-all.t
|
||||
t/blessed.t
|
||||
t/dualvar.t
|
||||
t/exotic_names.t
|
||||
t/first.t
|
||||
t/getmagic-once.t
|
||||
t/head-tail.t
|
||||
t/isvstring.t
|
||||
t/lln.t
|
||||
t/max.t
|
||||
t/maxstr.t
|
||||
t/mesh.t
|
||||
t/min.t
|
||||
t/minstr.t
|
||||
t/openhan.t
|
||||
t/pair.t
|
||||
t/product.t
|
||||
t/prototype.t
|
||||
t/readonly.t
|
||||
t/reduce.t
|
||||
t/reductions.t
|
||||
t/refaddr.t
|
||||
t/reftype.t
|
||||
t/rt-96343.t
|
||||
t/sample.t
|
||||
t/scalarutil-proto.t
|
||||
t/shuffle.t
|
||||
t/stack-corruption.t
|
||||
t/subname.t
|
||||
t/sum.t
|
||||
t/sum0.t
|
||||
t/tainted.t
|
||||
t/undefined-block.t
|
||||
t/uniq.t
|
||||
t/uniqnum.t
|
||||
t/weak.t
|
||||
t/zip.t
|
||||
META.yml Module YAML meta-data (added by MakeMaker)
|
||||
META.json Module JSON meta-data (added by MakeMaker)
|
||||
|
|
@ -0,0 +1,58 @@
|
|||
{
|
||||
"abstract" : "Common Scalar and List utility subroutines",
|
||||
"author" : [
|
||||
"Graham Barr <gbarr@cpan.org>"
|
||||
],
|
||||
"dynamic_config" : 0,
|
||||
"generated_by" : "ExtUtils::MakeMaker version 7.64, CPAN::Meta::Converter version 2.150010",
|
||||
"license" : [
|
||||
"perl_5"
|
||||
],
|
||||
"meta-spec" : {
|
||||
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
|
||||
"version" : 2
|
||||
},
|
||||
"name" : "Scalar-List-Utils",
|
||||
"no_index" : {
|
||||
"directory" : [
|
||||
"t",
|
||||
"inc"
|
||||
]
|
||||
},
|
||||
"prereqs" : {
|
||||
"build" : {
|
||||
"requires" : {
|
||||
"ExtUtils::MakeMaker" : "0"
|
||||
}
|
||||
},
|
||||
"configure" : {
|
||||
"requires" : {
|
||||
"ExtUtils::MakeMaker" : "0"
|
||||
}
|
||||
},
|
||||
"runtime" : {
|
||||
"requires" : {
|
||||
"perl" : "5.006"
|
||||
}
|
||||
},
|
||||
"test" : {
|
||||
"requires" : {
|
||||
"Test::More" : "0"
|
||||
}
|
||||
}
|
||||
},
|
||||
"release_status" : "stable",
|
||||
"resources" : {
|
||||
"bugtracker" : {
|
||||
"mailto" : "bug-Scalar-List-Utils@rt.cpan.org",
|
||||
"web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Scalar-List-Utils"
|
||||
},
|
||||
"repository" : {
|
||||
"type" : "git",
|
||||
"url" : "https://github.com/Scalar-List-Utils/Scalar-List-Utils.git",
|
||||
"web" : "https://github.com/Scalar-List-Utils/Scalar-List-Utils"
|
||||
}
|
||||
},
|
||||
"version" : "1.63",
|
||||
"x_serialization_backend" : "JSON::PP version 4.07"
|
||||
}
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
---
|
||||
abstract: 'Common Scalar and List utility subroutines'
|
||||
author:
|
||||
- 'Graham Barr <gbarr@cpan.org>'
|
||||
build_requires:
|
||||
ExtUtils::MakeMaker: '0'
|
||||
Test::More: '0'
|
||||
configure_requires:
|
||||
ExtUtils::MakeMaker: '0'
|
||||
dynamic_config: 0
|
||||
generated_by: 'ExtUtils::MakeMaker version 7.64, CPAN::Meta::Converter version 2.150010'
|
||||
license: perl
|
||||
meta-spec:
|
||||
url: http://module-build.sourceforge.net/META-spec-v1.4.html
|
||||
version: '1.4'
|
||||
name: Scalar-List-Utils
|
||||
no_index:
|
||||
directory:
|
||||
- t
|
||||
- inc
|
||||
requires:
|
||||
perl: '5.006'
|
||||
resources:
|
||||
bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Scalar-List-Utils
|
||||
repository: https://github.com/Scalar-List-Utils/Scalar-List-Utils.git
|
||||
version: '1.63'
|
||||
x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
|
||||
|
|
@ -0,0 +1,74 @@
|
|||
# -*- perl -*-
|
||||
BEGIN { require 5.006; }
|
||||
use strict;
|
||||
use warnings;
|
||||
use Config;
|
||||
use File::Spec;
|
||||
use ExtUtils::MakeMaker;
|
||||
my $PERL_CORE = grep { $_ eq 'PERL_CORE=1' } @ARGV;
|
||||
my $defines = $ENV{PERL_CORE} ? q[-DPERL_EXT] : q[-DPERL_EXT -DUSE_PPPORT_H];
|
||||
|
||||
my %params = (
|
||||
NAME => q[List::Util],
|
||||
ABSTRACT => q[Common Scalar and List utility subroutines],
|
||||
AUTHOR => q[Graham Barr <gbarr@cpan.org>],
|
||||
DEFINE => $defines,
|
||||
DISTNAME => q[Scalar-List-Utils],
|
||||
VERSION_FROM => 'lib/List/Util.pm',
|
||||
|
||||
# We go through the ListUtil.xs trickery to foil platforms
|
||||
# that have the feature combination of
|
||||
# (1) static builds
|
||||
# (2) allowing only one object by the same name in the static library
|
||||
# (3) the object name matching being case-blind
|
||||
# This means that we can't have the top-level util.o
|
||||
# and the extension-level Util.o in the same build.
|
||||
# One such platform is the POSIX-BC BS2000 EBCDIC mainframe platform.
|
||||
XS => {'ListUtil.xs' => 'ListUtil.c'},
|
||||
OBJECT => 'ListUtil$(OBJ_EXT)',
|
||||
( $PERL_CORE
|
||||
? ()
|
||||
: (
|
||||
INSTALLDIRS => ($] < 5.011 ? q[perl] : q[site]),
|
||||
TEST_REQUIRES => {
|
||||
'Test::More' => 0,
|
||||
},
|
||||
(eval { ExtUtils::MakeMaker->VERSION(6.31) } ? (LICENSE => 'perl') : ()),
|
||||
(eval { ExtUtils::MakeMaker->VERSION(6.48) } ? (MIN_PERL_VERSION => '5.006') : ()),
|
||||
( eval { ExtUtils::MakeMaker->VERSION(6.46) } ? (
|
||||
META_MERGE => {
|
||||
'meta-spec' => { version => 2 },
|
||||
dynamic_config => 0,
|
||||
resources => { ##
|
||||
repository => {
|
||||
url => 'https://github.com/Scalar-List-Utils/Scalar-List-Utils.git',
|
||||
web => 'https://github.com/Scalar-List-Utils/Scalar-List-Utils',
|
||||
type => 'git',
|
||||
},
|
||||
bugtracker => {
|
||||
mailto => 'bug-Scalar-List-Utils@rt.cpan.org',
|
||||
web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Scalar-List-Utils',
|
||||
},
|
||||
},
|
||||
}
|
||||
)
|
||||
: ()
|
||||
),
|
||||
)
|
||||
),
|
||||
);
|
||||
|
||||
if ($params{TEST_REQUIRES} and !eval { ExtUtils::MakeMaker->VERSION(6.64) }) {
|
||||
$params{BUILD_REQUIRES} = {
|
||||
%{$params{BUILD_REQUIRES} || {}},
|
||||
%{delete $params{TEST_REQUIRES}},
|
||||
};
|
||||
}
|
||||
if ($params{BUILD_REQUIRES} and !eval { ExtUtils::MakeMaker->VERSION(6.5503) }) {
|
||||
$params{PREREQ_PM} = {
|
||||
%{$params{PREREQ_PM} || {}},
|
||||
%{delete $params{BUILD_REQUIRES}},
|
||||
};
|
||||
}
|
||||
|
||||
WriteMakefile(%params);
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
This distribution is a replacement for the builtin distribution.
|
||||
|
||||
This package contains a selection of subroutines that people have
|
||||
expressed would be nice to have in the perl core, but the usage would not
|
||||
really be high enough to warrant the use of a keyword, and the size so
|
||||
small such that being individual extensions would be wasteful.
|
||||
|
||||
After unpacking the distribution, to install this module type
|
||||
|
||||
perl Makefile.PL
|
||||
make
|
||||
make test
|
||||
make install
|
||||
|
||||
KNOWN BUGS
|
||||
|
||||
There is a bug in perl5.6.0 with UV's that are >= 1<<31. This will
|
||||
show up as tests 8 and 9 of dualvar.t failing
|
||||
|
||||
|
||||
Copyright (c) 1997-2006 Graham Barr <gbarr@pobox.com>. All rights reserved.
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
|
@ -0,0 +1,836 @@
|
|||
# Copyright (c) 1997-2009 Graham Barr <gbarr@pobox.com>. All rights reserved.
|
||||
# This program is free software; you can redistribute it and/or
|
||||
# modify it under the same terms as Perl itself.
|
||||
#
|
||||
# Maintained since 2013 by Paul Evans <leonerd@leonerd.org.uk>
|
||||
|
||||
package List::Util;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
require Exporter;
|
||||
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(
|
||||
all any first min max minstr maxstr none notall product reduce reductions sum sum0
|
||||
sample shuffle uniq uniqint uniqnum uniqstr zip zip_longest zip_shortest mesh mesh_longest mesh_shortest
|
||||
head tail pairs unpairs pairkeys pairvalues pairmap pairgrep pairfirst
|
||||
);
|
||||
our $VERSION = "1.63";
|
||||
our $XS_VERSION = $VERSION;
|
||||
$VERSION =~ tr/_//d;
|
||||
|
||||
require XSLoader;
|
||||
XSLoader::load('List::Util', $XS_VERSION);
|
||||
|
||||
# Used by shuffle()
|
||||
our $RAND;
|
||||
|
||||
sub import
|
||||
{
|
||||
my $pkg = caller;
|
||||
|
||||
# (RT88848) Touch the caller's $a and $b, to avoid the warning of
|
||||
# Name "main::a" used only once: possible typo" warning
|
||||
no strict 'refs';
|
||||
${"${pkg}::a"} = ${"${pkg}::a"};
|
||||
${"${pkg}::b"} = ${"${pkg}::b"};
|
||||
|
||||
goto &Exporter::import;
|
||||
}
|
||||
|
||||
# For objects returned by pairs()
|
||||
sub List::Util::_Pair::key { shift->[0] }
|
||||
sub List::Util::_Pair::value { shift->[1] }
|
||||
sub List::Util::_Pair::TO_JSON { [ @{+shift} ] }
|
||||
|
||||
=head1 NAME
|
||||
|
||||
List::Util - A selection of general-utility list subroutines
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use List::Util qw(
|
||||
reduce any all none notall first reductions
|
||||
|
||||
max maxstr min minstr product sum sum0
|
||||
|
||||
pairs unpairs pairkeys pairvalues pairfirst pairgrep pairmap
|
||||
|
||||
shuffle uniq uniqint uniqnum uniqstr zip mesh
|
||||
);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
C<List::Util> contains a selection of subroutines that people have expressed
|
||||
would be nice to have in the perl core, but the usage would not really be high
|
||||
enough to warrant the use of a keyword, and the size so small such that being
|
||||
individual extensions would be wasteful.
|
||||
|
||||
By default C<List::Util> does not export any subroutines.
|
||||
|
||||
=cut
|
||||
|
||||
=head1 LIST-REDUCTION FUNCTIONS
|
||||
|
||||
The following set of functions all apply a given block of code to a list of
|
||||
values.
|
||||
|
||||
=cut
|
||||
|
||||
=head2 reduce
|
||||
|
||||
$result = reduce { BLOCK } @list
|
||||
|
||||
Reduces C<@list> by calling C<BLOCK> in a scalar context multiple times,
|
||||
setting C<$a> and C<$b> each time. The first call will be with C<$a> and C<$b>
|
||||
set to the first two elements of the list, subsequent calls will be done by
|
||||
setting C<$a> to the result of the previous call and C<$b> to the next element
|
||||
in the list.
|
||||
|
||||
Returns the result of the last call to the C<BLOCK>. If C<@list> is empty then
|
||||
C<undef> is returned. If C<@list> only contains one element then that element
|
||||
is returned and C<BLOCK> is not executed.
|
||||
|
||||
The following examples all demonstrate how C<reduce> could be used to implement
|
||||
the other list-reduction functions in this module. (They are not in fact
|
||||
implemented like this, but instead in a more efficient manner in individual C
|
||||
functions).
|
||||
|
||||
$foo = reduce { defined($a) ? $a :
|
||||
$code->(local $_ = $b) ? $b :
|
||||
undef } undef, @list # first
|
||||
|
||||
$foo = reduce { $a > $b ? $a : $b } 1..10 # max
|
||||
$foo = reduce { $a gt $b ? $a : $b } 'A'..'Z' # maxstr
|
||||
$foo = reduce { $a < $b ? $a : $b } 1..10 # min
|
||||
$foo = reduce { $a lt $b ? $a : $b } 'aa'..'zz' # minstr
|
||||
$foo = reduce { $a + $b } 1 .. 10 # sum
|
||||
$foo = reduce { $a . $b } @bar # concat
|
||||
|
||||
$foo = reduce { $a || $code->(local $_ = $b) } 0, @bar # any
|
||||
$foo = reduce { $a && $code->(local $_ = $b) } 1, @bar # all
|
||||
$foo = reduce { $a && !$code->(local $_ = $b) } 1, @bar # none
|
||||
$foo = reduce { $a || !$code->(local $_ = $b) } 0, @bar # notall
|
||||
# Note that these implementations do not fully short-circuit
|
||||
|
||||
If your algorithm requires that C<reduce> produce an identity value, then make
|
||||
sure that you always pass that identity value as the first argument to prevent
|
||||
C<undef> being returned
|
||||
|
||||
$foo = reduce { $a + $b } 0, @values; # sum with 0 identity value
|
||||
|
||||
The above example code blocks also suggest how to use C<reduce> to build a
|
||||
more efficient combined version of one of these basic functions and a C<map>
|
||||
block. For example, to find the total length of all the strings in a list,
|
||||
we could use
|
||||
|
||||
$total = sum map { length } @strings;
|
||||
|
||||
However, this produces a list of temporary integer values as long as the
|
||||
original list of strings, only to reduce it down to a single value again. We
|
||||
can compute the same result more efficiently by using C<reduce> with a code
|
||||
block that accumulates lengths by writing this instead as:
|
||||
|
||||
$total = reduce { $a + length $b } 0, @strings
|
||||
|
||||
The other scalar-returning list reduction functions are all specialisations of
|
||||
this generic idea.
|
||||
|
||||
=head2 reductions
|
||||
|
||||
@results = reductions { BLOCK } @list
|
||||
|
||||
I<Since version 1.54.>
|
||||
|
||||
Similar to C<reduce> except that it also returns the intermediate values along
|
||||
with the final result. As before, C<$a> is set to the first element of the
|
||||
given list, and the C<BLOCK> is then called once for remaining item in the
|
||||
list set into C<$b>, with the result being captured for return as well as
|
||||
becoming the new value for C<$a>.
|
||||
|
||||
The returned list will begin with the initial value for C<$a>, followed by
|
||||
each return value from the block in order. The final value of the result will
|
||||
be identical to what the C<reduce> function would have returned given the same
|
||||
block and list.
|
||||
|
||||
reduce { "$a-$b" } "a".."d" # "a-b-c-d"
|
||||
reductions { "$a-$b" } "a".."d" # "a", "a-b", "a-b-c", "a-b-c-d"
|
||||
|
||||
=head2 any
|
||||
|
||||
my $bool = any { BLOCK } @list;
|
||||
|
||||
I<Since version 1.33.>
|
||||
|
||||
Similar to C<grep> in that it evaluates C<BLOCK> setting C<$_> to each element
|
||||
of C<@list> in turn. C<any> returns true if any element makes the C<BLOCK>
|
||||
return a true value. If C<BLOCK> never returns true or C<@list> was empty then
|
||||
it returns false.
|
||||
|
||||
Many cases of using C<grep> in a conditional can be written using C<any>
|
||||
instead, as it can short-circuit after the first true result.
|
||||
|
||||
if( any { length > 10 } @strings ) {
|
||||
# at least one string has more than 10 characters
|
||||
}
|
||||
|
||||
Note: Due to XS issues the block passed may be able to access the outer @_
|
||||
directly. This is not intentional and will break under debugger.
|
||||
|
||||
=head2 all
|
||||
|
||||
my $bool = all { BLOCK } @list;
|
||||
|
||||
I<Since version 1.33.>
|
||||
|
||||
Similar to L</any>, except that it requires all elements of the C<@list> to
|
||||
make the C<BLOCK> return true. If any element returns false, then it returns
|
||||
false. If the C<BLOCK> never returns false or the C<@list> was empty then it
|
||||
returns true.
|
||||
|
||||
Note: Due to XS issues the block passed may be able to access the outer @_
|
||||
directly. This is not intentional and will break under debugger.
|
||||
|
||||
=head2 none
|
||||
|
||||
=head2 notall
|
||||
|
||||
my $bool = none { BLOCK } @list;
|
||||
|
||||
my $bool = notall { BLOCK } @list;
|
||||
|
||||
I<Since version 1.33.>
|
||||
|
||||
Similar to L</any> and L</all>, but with the return sense inverted. C<none>
|
||||
returns true only if no value in the C<@list> causes the C<BLOCK> to return
|
||||
true, and C<notall> returns true only if not all of the values do.
|
||||
|
||||
Note: Due to XS issues the block passed may be able to access the outer @_
|
||||
directly. This is not intentional and will break under debugger.
|
||||
|
||||
=head2 first
|
||||
|
||||
my $val = first { BLOCK } @list;
|
||||
|
||||
Similar to C<grep> in that it evaluates C<BLOCK> setting C<$_> to each element
|
||||
of C<@list> in turn. C<first> returns the first element where the result from
|
||||
C<BLOCK> is a true value. If C<BLOCK> never returns true or C<@list> was empty
|
||||
then C<undef> is returned.
|
||||
|
||||
$foo = first { defined($_) } @list # first defined value in @list
|
||||
$foo = first { $_ > $value } @list # first value in @list which
|
||||
# is greater than $value
|
||||
|
||||
=head2 max
|
||||
|
||||
my $num = max @list;
|
||||
|
||||
Returns the entry in the list with the highest numerical value. If the list is
|
||||
empty then C<undef> is returned.
|
||||
|
||||
$foo = max 1..10 # 10
|
||||
$foo = max 3,9,12 # 12
|
||||
$foo = max @bar, @baz # whatever
|
||||
|
||||
=head2 maxstr
|
||||
|
||||
my $str = maxstr @list;
|
||||
|
||||
Similar to L</max>, but treats all the entries in the list as strings and
|
||||
returns the highest string as defined by the C<gt> operator. If the list is
|
||||
empty then C<undef> is returned.
|
||||
|
||||
$foo = maxstr 'A'..'Z' # 'Z'
|
||||
$foo = maxstr "hello","world" # "world"
|
||||
$foo = maxstr @bar, @baz # whatever
|
||||
|
||||
=head2 min
|
||||
|
||||
my $num = min @list;
|
||||
|
||||
Similar to L</max> but returns the entry in the list with the lowest numerical
|
||||
value. If the list is empty then C<undef> is returned.
|
||||
|
||||
$foo = min 1..10 # 1
|
||||
$foo = min 3,9,12 # 3
|
||||
$foo = min @bar, @baz # whatever
|
||||
|
||||
=head2 minstr
|
||||
|
||||
my $str = minstr @list;
|
||||
|
||||
Similar to L</min>, but treats all the entries in the list as strings and
|
||||
returns the lowest string as defined by the C<lt> operator. If the list is
|
||||
empty then C<undef> is returned.
|
||||
|
||||
$foo = minstr 'A'..'Z' # 'A'
|
||||
$foo = minstr "hello","world" # "hello"
|
||||
$foo = minstr @bar, @baz # whatever
|
||||
|
||||
=head2 product
|
||||
|
||||
my $num = product @list;
|
||||
|
||||
I<Since version 1.35.>
|
||||
|
||||
Returns the numerical product of all the elements in C<@list>. If C<@list> is
|
||||
empty then C<1> is returned.
|
||||
|
||||
$foo = product 1..10 # 3628800
|
||||
$foo = product 3,9,12 # 324
|
||||
|
||||
=head2 sum
|
||||
|
||||
my $num_or_undef = sum @list;
|
||||
|
||||
Returns the numerical sum of all the elements in C<@list>. For backwards
|
||||
compatibility, if C<@list> is empty then C<undef> is returned.
|
||||
|
||||
$foo = sum 1..10 # 55
|
||||
$foo = sum 3,9,12 # 24
|
||||
$foo = sum @bar, @baz # whatever
|
||||
|
||||
=head2 sum0
|
||||
|
||||
my $num = sum0 @list;
|
||||
|
||||
I<Since version 1.26.>
|
||||
|
||||
Similar to L</sum>, except this returns 0 when given an empty list, rather
|
||||
than C<undef>.
|
||||
|
||||
=cut
|
||||
|
||||
=head1 KEY/VALUE PAIR LIST FUNCTIONS
|
||||
|
||||
The following set of functions, all inspired by L<List::Pairwise>, consume an
|
||||
even-sized list of pairs. The pairs may be key/value associations from a hash,
|
||||
or just a list of values. The functions will all preserve the original ordering
|
||||
of the pairs, and will not be confused by multiple pairs having the same "key"
|
||||
value - nor even do they require that the first of each pair be a plain string.
|
||||
|
||||
B<NOTE>: At the time of writing, the following C<pair*> functions that take a
|
||||
block do not modify the value of C<$_> within the block, and instead operate
|
||||
using the C<$a> and C<$b> globals instead. This has turned out to be a poor
|
||||
design, as it precludes the ability to provide a C<pairsort> function. Better
|
||||
would be to pass pair-like objects as 2-element array references in C<$_>, in
|
||||
a style similar to the return value of the C<pairs> function. At some future
|
||||
version this behaviour may be added.
|
||||
|
||||
Until then, users are alerted B<NOT> to rely on the value of C<$_> remaining
|
||||
unmodified between the outside and the inside of the control block. In
|
||||
particular, the following example is B<UNSAFE>:
|
||||
|
||||
my @kvlist = ...
|
||||
|
||||
foreach (qw( some keys here )) {
|
||||
my @items = pairgrep { $a eq $_ } @kvlist;
|
||||
...
|
||||
}
|
||||
|
||||
Instead, write this using a lexical variable:
|
||||
|
||||
foreach my $key (qw( some keys here )) {
|
||||
my @items = pairgrep { $a eq $key } @kvlist;
|
||||
...
|
||||
}
|
||||
|
||||
=cut
|
||||
|
||||
=head2 pairs
|
||||
|
||||
my @pairs = pairs @kvlist;
|
||||
|
||||
I<Since version 1.29.>
|
||||
|
||||
A convenient shortcut to operating on even-sized lists of pairs, this function
|
||||
returns a list of C<ARRAY> references, each containing two items from the
|
||||
given list. It is a more efficient version of
|
||||
|
||||
@pairs = pairmap { [ $a, $b ] } @kvlist
|
||||
|
||||
It is most convenient to use in a C<foreach> loop, for example:
|
||||
|
||||
foreach my $pair ( pairs @kvlist ) {
|
||||
my ( $key, $value ) = @$pair;
|
||||
...
|
||||
}
|
||||
|
||||
Since version C<1.39> these C<ARRAY> references are blessed objects,
|
||||
recognising the two methods C<key> and C<value>. The following code is
|
||||
equivalent:
|
||||
|
||||
foreach my $pair ( pairs @kvlist ) {
|
||||
my $key = $pair->key;
|
||||
my $value = $pair->value;
|
||||
...
|
||||
}
|
||||
|
||||
Since version C<1.51> they also have a C<TO_JSON> method to ease
|
||||
serialisation.
|
||||
|
||||
=head2 unpairs
|
||||
|
||||
my @kvlist = unpairs @pairs
|
||||
|
||||
I<Since version 1.42.>
|
||||
|
||||
The inverse function to C<pairs>; this function takes a list of C<ARRAY>
|
||||
references containing two elements each, and returns a flattened list of the
|
||||
two values from each of the pairs, in order. This is notionally equivalent to
|
||||
|
||||
my @kvlist = map { @{$_}[0,1] } @pairs
|
||||
|
||||
except that it is implemented more efficiently internally. Specifically, for
|
||||
any input item it will extract exactly two values for the output list; using
|
||||
C<undef> if the input array references are short.
|
||||
|
||||
Between C<pairs> and C<unpairs>, a higher-order list function can be used to
|
||||
operate on the pairs as single scalars; such as the following near-equivalents
|
||||
of the other C<pair*> higher-order functions:
|
||||
|
||||
@kvlist = unpairs grep { FUNC } pairs @kvlist
|
||||
# Like pairgrep, but takes $_ instead of $a and $b
|
||||
|
||||
@kvlist = unpairs map { FUNC } pairs @kvlist
|
||||
# Like pairmap, but takes $_ instead of $a and $b
|
||||
|
||||
Note however that these versions will not behave as nicely in scalar context.
|
||||
|
||||
Finally, this technique can be used to implement a sort on a keyvalue pair
|
||||
list; e.g.:
|
||||
|
||||
@kvlist = unpairs sort { $a->key cmp $b->key } pairs @kvlist
|
||||
|
||||
=head2 pairkeys
|
||||
|
||||
my @keys = pairkeys @kvlist;
|
||||
|
||||
I<Since version 1.29.>
|
||||
|
||||
A convenient shortcut to operating on even-sized lists of pairs, this function
|
||||
returns a list of the the first values of each of the pairs in the given list.
|
||||
It is a more efficient version of
|
||||
|
||||
@keys = pairmap { $a } @kvlist
|
||||
|
||||
=head2 pairvalues
|
||||
|
||||
my @values = pairvalues @kvlist;
|
||||
|
||||
I<Since version 1.29.>
|
||||
|
||||
A convenient shortcut to operating on even-sized lists of pairs, this function
|
||||
returns a list of the the second values of each of the pairs in the given list.
|
||||
It is a more efficient version of
|
||||
|
||||
@values = pairmap { $b } @kvlist
|
||||
|
||||
=head2 pairgrep
|
||||
|
||||
my @kvlist = pairgrep { BLOCK } @kvlist;
|
||||
|
||||
my $count = pairgrep { BLOCK } @kvlist;
|
||||
|
||||
I<Since version 1.29.>
|
||||
|
||||
Similar to perl's C<grep> keyword, but interprets the given list as an
|
||||
even-sized list of pairs. It invokes the C<BLOCK> multiple times, in scalar
|
||||
context, with C<$a> and C<$b> set to successive pairs of values from the
|
||||
C<@kvlist>.
|
||||
|
||||
Returns an even-sized list of those pairs for which the C<BLOCK> returned true
|
||||
in list context, or the count of the B<number of pairs> in scalar context.
|
||||
(Note, therefore, in scalar context that it returns a number half the size of
|
||||
the count of items it would have returned in list context).
|
||||
|
||||
@subset = pairgrep { $a =~ m/^[[:upper:]]+$/ } @kvlist
|
||||
|
||||
As with C<grep> aliasing C<$_> to list elements, C<pairgrep> aliases C<$a> and
|
||||
C<$b> to elements of the given list. Any modifications of it by the code block
|
||||
will be visible to the caller.
|
||||
|
||||
=head2 pairfirst
|
||||
|
||||
my ( $key, $val ) = pairfirst { BLOCK } @kvlist;
|
||||
|
||||
my $found = pairfirst { BLOCK } @kvlist;
|
||||
|
||||
I<Since version 1.30.>
|
||||
|
||||
Similar to the L</first> function, but interprets the given list as an
|
||||
even-sized list of pairs. It invokes the C<BLOCK> multiple times, in scalar
|
||||
context, with C<$a> and C<$b> set to successive pairs of values from the
|
||||
C<@kvlist>.
|
||||
|
||||
Returns the first pair of values from the list for which the C<BLOCK> returned
|
||||
true in list context, or an empty list of no such pair was found. In scalar
|
||||
context it returns a simple boolean value, rather than either the key or the
|
||||
value found.
|
||||
|
||||
( $key, $value ) = pairfirst { $a =~ m/^[[:upper:]]+$/ } @kvlist
|
||||
|
||||
As with C<grep> aliasing C<$_> to list elements, C<pairfirst> aliases C<$a> and
|
||||
C<$b> to elements of the given list. Any modifications of it by the code block
|
||||
will be visible to the caller.
|
||||
|
||||
=head2 pairmap
|
||||
|
||||
my @list = pairmap { BLOCK } @kvlist;
|
||||
|
||||
my $count = pairmap { BLOCK } @kvlist;
|
||||
|
||||
I<Since version 1.29.>
|
||||
|
||||
Similar to perl's C<map> keyword, but interprets the given list as an
|
||||
even-sized list of pairs. It invokes the C<BLOCK> multiple times, in list
|
||||
context, with C<$a> and C<$b> set to successive pairs of values from the
|
||||
C<@kvlist>.
|
||||
|
||||
Returns the concatenation of all the values returned by the C<BLOCK> in list
|
||||
context, or the count of the number of items that would have been returned in
|
||||
scalar context.
|
||||
|
||||
@result = pairmap { "The key $a has value $b" } @kvlist
|
||||
|
||||
As with C<map> aliasing C<$_> to list elements, C<pairmap> aliases C<$a> and
|
||||
C<$b> to elements of the given list. Any modifications of it by the code block
|
||||
will be visible to the caller.
|
||||
|
||||
See L</KNOWN BUGS> for a known-bug with C<pairmap>, and a workaround.
|
||||
|
||||
=cut
|
||||
|
||||
=head1 OTHER FUNCTIONS
|
||||
|
||||
=cut
|
||||
|
||||
=head2 shuffle
|
||||
|
||||
my @values = shuffle @values;
|
||||
|
||||
Returns the values of the input in a random order
|
||||
|
||||
@cards = shuffle 0..51 # 0..51 in a random order
|
||||
|
||||
This function is affected by the C<$RAND> variable.
|
||||
|
||||
=cut
|
||||
|
||||
=head2 sample
|
||||
|
||||
my @items = sample $count, @values
|
||||
|
||||
I<Since version 1.54.>
|
||||
|
||||
Randomly select the given number of elements from the input list. Any given
|
||||
position in the input list will be selected at most once.
|
||||
|
||||
If there are fewer than C<$count> items in the list then the function will
|
||||
return once all of them have been randomly selected; effectively the function
|
||||
behaves similarly to L</shuffle>.
|
||||
|
||||
This function is affected by the C<$RAND> variable.
|
||||
|
||||
=head2 uniq
|
||||
|
||||
my @subset = uniq @values
|
||||
|
||||
I<Since version 1.45.>
|
||||
|
||||
Filters a list of values to remove subsequent duplicates, as judged by a
|
||||
DWIM-ish string equality or C<undef> test. Preserves the order of unique
|
||||
elements, and retains the first value of any duplicate set.
|
||||
|
||||
my $count = uniq @values
|
||||
|
||||
In scalar context, returns the number of elements that would have been
|
||||
returned as a list.
|
||||
|
||||
The C<undef> value is treated by this function as distinct from the empty
|
||||
string, and no warning will be produced. It is left as-is in the returned
|
||||
list. Subsequent C<undef> values are still considered identical to the first,
|
||||
and will be removed.
|
||||
|
||||
=head2 uniqint
|
||||
|
||||
my @subset = uniqint @values
|
||||
|
||||
I<Since version 1.55.>
|
||||
|
||||
Filters a list of values to remove subsequent duplicates, as judged by an
|
||||
integer numerical equality test. Preserves the order of unique elements, and
|
||||
retains the first value of any duplicate set. Values in the returned list will
|
||||
be coerced into integers.
|
||||
|
||||
my $count = uniqint @values
|
||||
|
||||
In scalar context, returns the number of elements that would have been
|
||||
returned as a list.
|
||||
|
||||
Note that C<undef> is treated much as other numerical operations treat it; it
|
||||
compares equal to zero but additionally produces a warning if such warnings
|
||||
are enabled (C<use warnings 'uninitialized';>). In addition, an C<undef> in
|
||||
the returned list is coerced into a numerical zero, so that the entire list of
|
||||
values returned by C<uniqint> are well-behaved as integers.
|
||||
|
||||
=head2 uniqnum
|
||||
|
||||
my @subset = uniqnum @values
|
||||
|
||||
I<Since version 1.44.>
|
||||
|
||||
Filters a list of values to remove subsequent duplicates, as judged by a
|
||||
numerical equality test. Preserves the order of unique elements, and retains
|
||||
the first value of any duplicate set.
|
||||
|
||||
my $count = uniqnum @values
|
||||
|
||||
In scalar context, returns the number of elements that would have been
|
||||
returned as a list.
|
||||
|
||||
Note that C<undef> is treated much as other numerical operations treat it; it
|
||||
compares equal to zero but additionally produces a warning if such warnings
|
||||
are enabled (C<use warnings 'uninitialized';>). In addition, an C<undef> in
|
||||
the returned list is coerced into a numerical zero, so that the entire list of
|
||||
values returned by C<uniqnum> are well-behaved as numbers.
|
||||
|
||||
Note also that multiple IEEE C<NaN> values are treated as duplicates of
|
||||
each other, regardless of any differences in their payloads, and despite
|
||||
the fact that C<< 0+'NaN' == 0+'NaN' >> yields false.
|
||||
|
||||
=head2 uniqstr
|
||||
|
||||
my @subset = uniqstr @values
|
||||
|
||||
I<Since version 1.45.>
|
||||
|
||||
Filters a list of values to remove subsequent duplicates, as judged by a
|
||||
string equality test. Preserves the order of unique elements, and retains the
|
||||
first value of any duplicate set.
|
||||
|
||||
my $count = uniqstr @values
|
||||
|
||||
In scalar context, returns the number of elements that would have been
|
||||
returned as a list.
|
||||
|
||||
Note that C<undef> is treated much as other string operations treat it; it
|
||||
compares equal to the empty string but additionally produces a warning if such
|
||||
warnings are enabled (C<use warnings 'uninitialized';>). In addition, an
|
||||
C<undef> in the returned list is coerced into an empty string, so that the
|
||||
entire list of values returned by C<uniqstr> are well-behaved as strings.
|
||||
|
||||
=cut
|
||||
|
||||
=head2 head
|
||||
|
||||
my @values = head $size, @list;
|
||||
|
||||
I<Since version 1.50.>
|
||||
|
||||
Returns the first C<$size> elements from C<@list>. If C<$size> is negative, returns
|
||||
all but the last C<$size> elements from C<@list>.
|
||||
|
||||
@result = head 2, qw( foo bar baz );
|
||||
# foo, bar
|
||||
|
||||
@result = head -2, qw( foo bar baz );
|
||||
# foo
|
||||
|
||||
=head2 tail
|
||||
|
||||
my @values = tail $size, @list;
|
||||
|
||||
I<Since version 1.50.>
|
||||
|
||||
Returns the last C<$size> elements from C<@list>. If C<$size> is negative, returns
|
||||
all but the first C<$size> elements from C<@list>.
|
||||
|
||||
@result = tail 2, qw( foo bar baz );
|
||||
# bar, baz
|
||||
|
||||
@result = tail -2, qw( foo bar baz );
|
||||
# baz
|
||||
|
||||
=head2 zip
|
||||
|
||||
my @result = zip [1..3], ['a'..'c'];
|
||||
# [1, 'a'], [2, 'b'], [3, 'c']
|
||||
|
||||
I<Since version 1.56.>
|
||||
|
||||
Returns a list of array references, composed of elements from the given list
|
||||
of array references. Each array in the returned list is composed of elements
|
||||
at that corresponding position from each of the given input arrays. If any
|
||||
input arrays run out of elements before others, then C<undef> will be inserted
|
||||
into the result to fill in the gaps.
|
||||
|
||||
The C<zip> function is particularly handy for iterating over multiple arrays
|
||||
at the same time with a C<foreach> loop, taking one element from each:
|
||||
|
||||
foreach ( zip \@xs, \@ys, \@zs ) {
|
||||
my ($x, $y, $z) = @$_;
|
||||
...
|
||||
}
|
||||
|
||||
B<NOTE> to users of L<List::MoreUtils>: This function does not behave the same
|
||||
as C<List::MoreUtils::zip>, but is actually a non-prototyped equivalent to
|
||||
C<List::MoreUtils::zip_unflatten>. This function does not apply a prototype,
|
||||
so make sure to invoke it with references to arrays.
|
||||
|
||||
For a function similar to the C<zip> function from C<List::MoreUtils>, see
|
||||
L<mesh>.
|
||||
|
||||
my @result = zip_shortest ...
|
||||
|
||||
A variation of the function that differs in how it behaves when given input
|
||||
arrays of differing lengths. C<zip_shortest> will stop as soon as any one of
|
||||
the input arrays run out of elements, discarding any remaining unused values
|
||||
from the others.
|
||||
|
||||
my @result = zip_longest ...
|
||||
|
||||
C<zip_longest> is an alias to the C<zip> function, provided simply to be
|
||||
explicit about that behaviour as compared to C<zip_shortest>.
|
||||
|
||||
=head2 mesh
|
||||
|
||||
my @result = mesh [1..3], ['a'..'c'];
|
||||
# (1, 'a', 2, 'b', 3, 'c')
|
||||
|
||||
I<Since version 1.56.>
|
||||
|
||||
Returns a list of items collected from elements of the given list of array
|
||||
references. Each section of items in the returned list is composed of elements
|
||||
at the corresponding position from each of the given input arrays. If any
|
||||
input arrays run out of elements before others, then C<undef> will be inserted
|
||||
into the result to fill in the gaps.
|
||||
|
||||
This is similar to L<zip>, except that all of the ranges in the result are
|
||||
returned in one long flattened list, instead of being bundled into separate
|
||||
arrays.
|
||||
|
||||
Because it returns a flat list of items, the C<mesh> function is particularly
|
||||
useful for building a hash out of two separate arrays of keys and values:
|
||||
|
||||
my %hash = mesh \@keys, \@values;
|
||||
|
||||
my $href = { mesh \@keys, \@values };
|
||||
|
||||
B<NOTE> to users of L<List::MoreUtils>: This function is a non-prototyped
|
||||
equivalent to C<List::MoreUtils::mesh> or C<List::MoreUtils::zip> (themselves
|
||||
aliases of each other). This function does not apply a prototype, so make sure
|
||||
to invoke it with references to arrays.
|
||||
|
||||
my @result = mesh_shortest ...
|
||||
|
||||
my @result = mesh_longest ...
|
||||
|
||||
These variations are similar to those of L<zip>, in that they differ in
|
||||
behaviour when one of the input lists runs out of elements before the others.
|
||||
|
||||
=head1 CONFIGURATION VARIABLES
|
||||
|
||||
=head2 $RAND
|
||||
|
||||
local $List::Util::RAND = sub { ... };
|
||||
|
||||
I<Since version 1.54.>
|
||||
|
||||
This package variable is used by code which needs to generate random numbers
|
||||
(such as the L</shuffle> and L</sample> functions). If set to a CODE reference
|
||||
it provides an alternative to perl's builtin C<rand()> function. When a new
|
||||
random number is needed this function will be invoked with no arguments and is
|
||||
expected to return a floating-point value, of which only the fractional part
|
||||
will be used.
|
||||
|
||||
=head1 KNOWN BUGS
|
||||
|
||||
=head2 RT #95409
|
||||
|
||||
L<https://rt.cpan.org/Ticket/Display.html?id=95409>
|
||||
|
||||
If the block of code given to L</pairmap> contains lexical variables that are
|
||||
captured by a returned closure, and the closure is executed after the block
|
||||
has been re-used for the next iteration, these lexicals will not see the
|
||||
correct values. For example:
|
||||
|
||||
my @subs = pairmap {
|
||||
my $var = "$a is $b";
|
||||
sub { print "$var\n" };
|
||||
} one => 1, two => 2, three => 3;
|
||||
|
||||
$_->() for @subs;
|
||||
|
||||
Will incorrectly print
|
||||
|
||||
three is 3
|
||||
three is 3
|
||||
three is 3
|
||||
|
||||
This is due to the performance optimisation of using C<MULTICALL> for the code
|
||||
block, which means that fresh SVs do not get allocated for each call to the
|
||||
block. Instead, the same SV is re-assigned for each iteration, and all the
|
||||
closures will share the value seen on the final iteration.
|
||||
|
||||
To work around this bug, surround the code with a second set of braces. This
|
||||
creates an inner block that defeats the C<MULTICALL> logic, and does get fresh
|
||||
SVs allocated each time:
|
||||
|
||||
my @subs = pairmap {
|
||||
{
|
||||
my $var = "$a is $b";
|
||||
sub { print "$var\n"; }
|
||||
}
|
||||
} one => 1, two => 2, three => 3;
|
||||
|
||||
This bug only affects closures that are generated by the block but used
|
||||
afterwards. Lexical variables that are only used during the lifetime of the
|
||||
block's execution will take their individual values for each invocation, as
|
||||
normal.
|
||||
|
||||
=head2 uniqnum() on oversized bignums
|
||||
|
||||
Due to the way that C<uniqnum()> compares numbers, it cannot distinguish
|
||||
differences between bignums (especially bigints) that are too large to fit in
|
||||
the native platform types. For example,
|
||||
|
||||
my $x = Math::BigInt->new( "1" x 100 );
|
||||
my $y = $x + 1;
|
||||
|
||||
say for uniqnum( $x, $y );
|
||||
|
||||
Will print just the value of C<$x>, believing that C<$y> is a numerically-
|
||||
equivalent value. This bug does not affect C<uniqstr()>, which will correctly
|
||||
observe that the two values stringify to different strings.
|
||||
|
||||
=head1 SUGGESTED ADDITIONS
|
||||
|
||||
The following are additions that have been requested, but I have been reluctant
|
||||
to add due to them being very simple to implement in perl
|
||||
|
||||
# How many elements are true
|
||||
|
||||
sub true { scalar grep { $_ } @_ }
|
||||
|
||||
# How many elements are false
|
||||
|
||||
sub false { scalar grep { !$_ } @_ }
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Scalar::Util>, L<List::MoreUtils>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 1997-2007 Graham Barr <gbarr@pobox.com>. All rights reserved.
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
Recent additions and current maintenance by
|
||||
Paul Evans, <leonerd@leonerd.org.uk>.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
package List::Util::XS;
|
||||
use strict;
|
||||
use warnings;
|
||||
use List::Util;
|
||||
|
||||
our $VERSION = "1.63"; # FIXUP
|
||||
$VERSION =~ tr/_//d; # FIXUP
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
List::Util::XS - Indicate if List::Util was compiled with a C compiler
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use List::Util::XS 1.20;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
C<List::Util::XS> can be used as a dependency to ensure List::Util was
|
||||
installed using a C compiler and that the XS version is installed.
|
||||
|
||||
During installation C<$List::Util::XS::VERSION> will be set to
|
||||
C<undef> if the XS was not compiled.
|
||||
|
||||
Starting with release 1.23_03, Scalar-List-Util is B<always> using
|
||||
the XS implementation, but for backwards compatibility, we still
|
||||
ship the C<List::Util::XS> module which just loads C<List::Util>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Scalar::Util>, L<List::Util>, L<List::MoreUtils>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2008 Graham Barr <gbarr@pobox.com>. All rights reserved.
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
|
@ -0,0 +1,377 @@
|
|||
# Copyright (c) 1997-2007 Graham Barr <gbarr@pobox.com>. All rights reserved.
|
||||
# This program is free software; you can redistribute it and/or
|
||||
# modify it under the same terms as Perl itself.
|
||||
#
|
||||
# Maintained since 2013 by Paul Evans <leonerd@leonerd.org.uk>
|
||||
|
||||
package Scalar::Util;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
require Exporter;
|
||||
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(
|
||||
blessed refaddr reftype weaken unweaken isweak
|
||||
|
||||
dualvar isdual isvstring looks_like_number openhandle readonly set_prototype
|
||||
tainted
|
||||
);
|
||||
our $VERSION = "1.63";
|
||||
$VERSION =~ tr/_//d;
|
||||
|
||||
require List::Util; # List::Util loads the XS
|
||||
List::Util->VERSION( $VERSION ); # Ensure we got the right XS version (RT#100863)
|
||||
|
||||
# populating @EXPORT_FAIL is done in the XS code
|
||||
sub export_fail {
|
||||
if (grep { /^isvstring$/ } @_ ) {
|
||||
require Carp;
|
||||
Carp::croak("Vstrings are not implemented in this version of perl");
|
||||
}
|
||||
|
||||
@_;
|
||||
}
|
||||
|
||||
# set_prototype has been moved to Sub::Util with a different interface
|
||||
sub set_prototype(&$)
|
||||
{
|
||||
my ( $code, $proto ) = @_;
|
||||
return Sub::Util::set_prototype( $proto, $code );
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Scalar::Util - A selection of general-utility scalar subroutines
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Scalar::Util qw(blessed dualvar isdual readonly refaddr reftype
|
||||
tainted weaken isweak isvstring looks_like_number
|
||||
set_prototype);
|
||||
# and other useful utils appearing below
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
C<Scalar::Util> contains a selection of subroutines that people have expressed
|
||||
would be nice to have in the perl core, but the usage would not really be high
|
||||
enough to warrant the use of a keyword, and the size would be so small that
|
||||
being individual extensions would be wasteful.
|
||||
|
||||
By default C<Scalar::Util> does not export any subroutines.
|
||||
|
||||
=head2 Core Perl C<builtin> Functions
|
||||
|
||||
Many functions in this module have served as the inspiration for a new
|
||||
experimental facility in recent versions of Perl. From various development
|
||||
versions, starting at 5.35.7, equivalent functions to many of these utilities
|
||||
are available in the C<builtin::> package.
|
||||
|
||||
use Scalar::Util qw(blessed);
|
||||
|
||||
$class = blessed $obj;
|
||||
|
||||
$class = builtin::blessed $obj; # equivalent
|
||||
|
||||
For more information, see the documentation on L<builtin>.
|
||||
|
||||
=cut
|
||||
|
||||
=head1 FUNCTIONS FOR REFERENCES
|
||||
|
||||
The following functions all perform some useful activity on reference values.
|
||||
|
||||
=head2 blessed
|
||||
|
||||
my $pkg = blessed( $ref );
|
||||
|
||||
If C<$ref> is a blessed reference, the name of the package that it is blessed
|
||||
into is returned. Otherwise C<undef> is returned.
|
||||
|
||||
$scalar = "foo";
|
||||
$class = blessed $scalar; # undef
|
||||
|
||||
$ref = [];
|
||||
$class = blessed $ref; # undef
|
||||
|
||||
$obj = bless [], "Foo";
|
||||
$class = blessed $obj; # "Foo"
|
||||
|
||||
Take care when using this function simply as a truth test (such as in
|
||||
C<if(blessed $ref)...>) because the package name C<"0"> is defined yet false.
|
||||
|
||||
I<Since Perl version 5.35.7> an equivalent function is available as
|
||||
C<builtin::blessed>.
|
||||
|
||||
=head2 refaddr
|
||||
|
||||
my $addr = refaddr( $ref );
|
||||
|
||||
If C<$ref> is reference, the internal memory address of the referenced value is
|
||||
returned as a plain integer. Otherwise C<undef> is returned.
|
||||
|
||||
$addr = refaddr "string"; # undef
|
||||
$addr = refaddr \$var; # eg 12345678
|
||||
$addr = refaddr []; # eg 23456784
|
||||
|
||||
$obj = bless {}, "Foo";
|
||||
$addr = refaddr $obj; # eg 88123488
|
||||
|
||||
I<Since Perl version 5.35.7> an equivalent function is available as
|
||||
C<builtin::refaddr>.
|
||||
|
||||
=head2 reftype
|
||||
|
||||
my $type = reftype( $ref );
|
||||
|
||||
If C<$ref> is a reference, the basic Perl type of the variable referenced is
|
||||
returned as a plain string (such as C<ARRAY> or C<HASH>). Otherwise C<undef>
|
||||
is returned.
|
||||
|
||||
$type = reftype "string"; # undef
|
||||
$type = reftype \$var; # SCALAR
|
||||
$type = reftype []; # ARRAY
|
||||
|
||||
$obj = bless {}, "Foo";
|
||||
$type = reftype $obj; # HASH
|
||||
|
||||
Note that for internal reasons, all precompiled regexps (C<qr/.../>) are
|
||||
blessed references; thus C<ref()> returns the package name string C<"Regexp">
|
||||
on these but C<reftype()> will return the underlying C structure type of
|
||||
C<"REGEXP"> in all capitals.
|
||||
|
||||
I<Since Perl version 5.35.7> an equivalent function is available as
|
||||
C<builtin::reftype>.
|
||||
|
||||
=head2 weaken
|
||||
|
||||
weaken( $ref );
|
||||
|
||||
The lvalue C<$ref> will be turned into a weak reference. This means that it
|
||||
will not hold a reference count on the object it references. Also, when the
|
||||
reference count on that object reaches zero, the reference will be set to
|
||||
undef. This function mutates the lvalue passed as its argument and returns no
|
||||
value.
|
||||
|
||||
This is useful for keeping copies of references, but you don't want to prevent
|
||||
the object being DESTROY-ed at its usual time.
|
||||
|
||||
{
|
||||
my $var;
|
||||
$ref = \$var;
|
||||
weaken($ref); # Make $ref a weak reference
|
||||
}
|
||||
# $ref is now undef
|
||||
|
||||
Note that if you take a copy of a scalar with a weakened reference, the copy
|
||||
will be a strong reference.
|
||||
|
||||
my $var;
|
||||
my $foo = \$var;
|
||||
weaken($foo); # Make $foo a weak reference
|
||||
my $bar = $foo; # $bar is now a strong reference
|
||||
|
||||
This may be less obvious in other situations, such as C<grep()>, for instance
|
||||
when grepping through a list of weakened references to objects that may have
|
||||
been destroyed already:
|
||||
|
||||
@object = grep { defined } @object;
|
||||
|
||||
This will indeed remove all references to destroyed objects, but the remaining
|
||||
references to objects will be strong, causing the remaining objects to never be
|
||||
destroyed because there is now always a strong reference to them in the @object
|
||||
array.
|
||||
|
||||
I<Since Perl version 5.35.7> an equivalent function is available as
|
||||
C<builtin::weaken>.
|
||||
|
||||
=head2 unweaken
|
||||
|
||||
unweaken( $ref );
|
||||
|
||||
I<Since version 1.36.>
|
||||
|
||||
The lvalue C<REF> will be turned from a weak reference back into a normal
|
||||
(strong) reference again. This function mutates the lvalue passed as its
|
||||
argument and returns no value. This undoes the action performed by
|
||||
L</weaken>.
|
||||
|
||||
This function is slightly neater and more convenient than the
|
||||
otherwise-equivalent code
|
||||
|
||||
my $tmp = $REF;
|
||||
undef $REF;
|
||||
$REF = $tmp;
|
||||
|
||||
(because in particular, simply assigning a weak reference back to itself does
|
||||
not work to unweaken it; C<$REF = $REF> does not work).
|
||||
|
||||
I<Since Perl version 5.35.7> an equivalent function is available as
|
||||
C<builtin::unweaken>.
|
||||
|
||||
=head2 isweak
|
||||
|
||||
my $weak = isweak( $ref );
|
||||
|
||||
Returns true if C<$ref> is a weak reference.
|
||||
|
||||
$ref = \$foo;
|
||||
$weak = isweak($ref); # false
|
||||
weaken($ref);
|
||||
$weak = isweak($ref); # true
|
||||
|
||||
B<NOTE>: Copying a weak reference creates a normal, strong, reference.
|
||||
|
||||
$copy = $ref;
|
||||
$weak = isweak($copy); # false
|
||||
|
||||
I<Since Perl version 5.35.7> an equivalent function is available as
|
||||
C<builtin::is_weak>.
|
||||
|
||||
=head1 OTHER FUNCTIONS
|
||||
|
||||
=head2 dualvar
|
||||
|
||||
my $var = dualvar( $num, $string );
|
||||
|
||||
Returns a scalar that has the value C<$num> in a numeric context and the value
|
||||
C<$string> in a string context.
|
||||
|
||||
$foo = dualvar 10, "Hello";
|
||||
$num = $foo + 2; # 12
|
||||
$str = $foo . " world"; # Hello world
|
||||
|
||||
=head2 isdual
|
||||
|
||||
my $dual = isdual( $var );
|
||||
|
||||
I<Since version 1.26.>
|
||||
|
||||
If C<$var> is a scalar that has both numeric and string values, the result is
|
||||
true.
|
||||
|
||||
$foo = dualvar 86, "Nix";
|
||||
$dual = isdual($foo); # true
|
||||
|
||||
Note that a scalar can be made to have both string and numeric content through
|
||||
standard operations:
|
||||
|
||||
$foo = "10";
|
||||
$dual = isdual($foo); # false
|
||||
$bar = $foo + 0;
|
||||
$dual = isdual($foo); # true
|
||||
|
||||
The C<$!> variable is commonly dual-valued, though it is also magical in other
|
||||
ways:
|
||||
|
||||
$! = 1;
|
||||
$dual = isdual($!); # true
|
||||
print("$!\n"); # "Operation not permitted"
|
||||
|
||||
B<CAUTION>: This function is not as useful as it may seem. Dualvars are not a
|
||||
distinct concept in Perl, but a standard internal construct of all scalar
|
||||
values. Almost any value could be considered as a dualvar by this function
|
||||
through the course of normal operations.
|
||||
|
||||
=head2 isvstring
|
||||
|
||||
my $vstring = isvstring( $var );
|
||||
|
||||
If C<$var> is a scalar which was coded as a vstring, the result is true.
|
||||
|
||||
$vs = v49.46.48;
|
||||
$fmt = isvstring($vs) ? "%vd" : "%s"; #true
|
||||
printf($fmt,$vs);
|
||||
|
||||
=head2 looks_like_number
|
||||
|
||||
my $isnum = looks_like_number( $var );
|
||||
|
||||
Returns true if perl thinks C<$var> is a number. See
|
||||
L<perlapi/looks_like_number>.
|
||||
|
||||
=head2 openhandle
|
||||
|
||||
my $fh = openhandle( $fh );
|
||||
|
||||
Returns C<$fh> itself, if C<$fh> may be used as a filehandle and is open, or if
|
||||
it is a tied handle. Otherwise C<undef> is returned.
|
||||
|
||||
$fh = openhandle(*STDIN); # \*STDIN
|
||||
$fh = openhandle(\*STDIN); # \*STDIN
|
||||
$fh = openhandle(*NOTOPEN); # undef
|
||||
$fh = openhandle("scalar"); # undef
|
||||
|
||||
=head2 readonly
|
||||
|
||||
my $ro = readonly( $var );
|
||||
|
||||
Returns true if C<$var> is readonly.
|
||||
|
||||
sub foo { readonly($_[0]) }
|
||||
|
||||
$readonly = foo($bar); # false
|
||||
$readonly = foo(0); # true
|
||||
|
||||
=head2 set_prototype
|
||||
|
||||
my $code = set_prototype( $code, $prototype );
|
||||
|
||||
Sets the prototype of the function given by the C<$code> reference, or deletes
|
||||
it if C<$prototype> is C<undef>. Returns the C<$code> reference itself.
|
||||
|
||||
set_prototype \&foo, '$$';
|
||||
|
||||
=head2 tainted
|
||||
|
||||
my $t = tainted( $var );
|
||||
|
||||
Return true if C<$var> is tainted.
|
||||
|
||||
$taint = tainted("constant"); # false
|
||||
$taint = tainted($ENV{PWD}); # true if running under -T
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
Module use may give one of the following errors during import.
|
||||
|
||||
=over
|
||||
|
||||
=item Vstrings are not implemented in this version of perl
|
||||
|
||||
The version of perl that you are using does not implement Vstrings, to use
|
||||
L</isvstring> you will need to use a newer release of perl.
|
||||
|
||||
=back
|
||||
|
||||
=head1 KNOWN BUGS
|
||||
|
||||
There is a bug in perl5.6.0 with UV's that are >= 1<<31. This will
|
||||
show up as tests 8 and 9 of dualvar.t failing
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<List::Util>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 1997-2007 Graham Barr <gbarr@pobox.com>. All rights reserved.
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
Additionally L</weaken> and L</isweak> which are
|
||||
|
||||
Copyright (c) 1999 Tuomas J. Lukka <lukka@iki.fi>. All rights reserved.
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the same terms as perl itself.
|
||||
|
||||
Copyright (C) 2004, 2008 Matthijs van Duin. All rights reserved.
|
||||
Copyright (C) 2014 cPanel Inc. All rights reserved.
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
|
@ -0,0 +1,153 @@
|
|||
# Copyright (c) 2014 Paul Evans <leonerd@leonerd.org.uk>. All rights reserved.
|
||||
# This program is free software; you can redistribute it and/or
|
||||
# modify it under the same terms as Perl itself.
|
||||
|
||||
package Sub::Util;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
require Exporter;
|
||||
|
||||
our @ISA = qw( Exporter );
|
||||
our @EXPORT_OK = qw(
|
||||
prototype set_prototype
|
||||
subname set_subname
|
||||
);
|
||||
|
||||
our $VERSION = "1.63";
|
||||
$VERSION =~ tr/_//d;
|
||||
|
||||
require List::Util; # as it has the XS
|
||||
List::Util->VERSION( $VERSION ); # Ensure we got the right XS version (RT#100863)
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Sub::Util - A selection of utility subroutines for subs and CODE references
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Sub::Util qw( prototype set_prototype subname set_subname );
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
C<Sub::Util> contains a selection of utility subroutines that are useful for
|
||||
operating on subs and CODE references.
|
||||
|
||||
The rationale for inclusion in this module is that the function performs some
|
||||
work for which an XS implementation is essential because it cannot be
|
||||
implemented in Pure Perl, and which is sufficiently-widely used across CPAN
|
||||
that its popularity warrants inclusion in a core module, which this is.
|
||||
|
||||
=cut
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=cut
|
||||
|
||||
=head2 prototype
|
||||
|
||||
my $proto = prototype( $code )
|
||||
|
||||
I<Since version 1.40.>
|
||||
|
||||
Returns the prototype of the given C<$code> reference, if it has one, as a
|
||||
string. This is the same as the C<CORE::prototype> operator; it is included
|
||||
here simply for symmetry and completeness with the other functions.
|
||||
|
||||
=cut
|
||||
|
||||
sub prototype
|
||||
{
|
||||
my ( $code ) = @_;
|
||||
return CORE::prototype( $code );
|
||||
}
|
||||
|
||||
=head2 set_prototype
|
||||
|
||||
my $code = set_prototype $prototype, $code;
|
||||
|
||||
I<Since version 1.40.>
|
||||
|
||||
Sets the prototype of the function given by the C<$code> reference, or deletes
|
||||
it if C<$prototype> is C<undef>. Returns the C<$code> reference itself.
|
||||
|
||||
I<Caution>: This function takes arguments in a different order to the previous
|
||||
copy of the code from C<Scalar::Util>. This is to match the order of
|
||||
C<set_subname>, and other potential additions in this file. This order has
|
||||
been chosen as it allows a neat and simple chaining of other
|
||||
C<Sub::Util::set_*> functions as might become available, such as:
|
||||
|
||||
my $code =
|
||||
set_subname name_here =>
|
||||
set_prototype '&@' =>
|
||||
set_attribute ':lvalue' =>
|
||||
sub { ...... };
|
||||
|
||||
=cut
|
||||
|
||||
=head2 subname
|
||||
|
||||
my $name = subname( $code )
|
||||
|
||||
I<Since version 1.40.>
|
||||
|
||||
Returns the name of the given C<$code> reference, if it has one. Normal named
|
||||
subs will give a fully-qualified name consisting of the package and the
|
||||
localname separated by C<::>. Anonymous code references will give C<__ANON__>
|
||||
as the localname. If the package the code was compiled in has been deleted
|
||||
(e.g. using C<delete_package> from L<Symbol>), C<__ANON__> will be returned as
|
||||
the package name. If a name has been set using L</set_subname>, this name will be
|
||||
returned instead.
|
||||
|
||||
This function was inspired by C<sub_fullname> from L<Sub::Identify>. The
|
||||
remaining functions that C<Sub::Identify> implements can easily be emulated
|
||||
using regexp operations, such as
|
||||
|
||||
sub get_code_info { return (subname $_[0]) =~ m/^(.+)::(.*?)$/ }
|
||||
sub sub_name { return (get_code_info $_[0])[0] }
|
||||
sub stash_name { return (get_code_info $_[0])[1] }
|
||||
|
||||
I<Users of Sub::Name beware>: This function is B<not> the same as
|
||||
C<Sub::Name::subname>; it returns the existing name of the sub rather than
|
||||
changing it. To set or change a name, see instead L</set_subname>.
|
||||
|
||||
=cut
|
||||
|
||||
=head2 set_subname
|
||||
|
||||
my $code = set_subname $name, $code;
|
||||
|
||||
I<Since version 1.40.>
|
||||
|
||||
Sets the name of the function given by the C<$code> reference. Returns the
|
||||
C<$code> reference itself. If the C<$name> is unqualified, the package of the
|
||||
caller is used to qualify it.
|
||||
|
||||
This is useful for applying names to anonymous CODE references so that stack
|
||||
traces and similar situations, to give a useful name rather than having the
|
||||
default of C<__ANON__>. Note that this name is only used for this situation;
|
||||
the C<set_subname> will not install it into the symbol table; you will have to
|
||||
do that yourself if required.
|
||||
|
||||
However, since the name is not used by perl except as the return value of
|
||||
C<caller>, for stack traces or similar, there is no actual requirement that
|
||||
the name be syntactically valid as a perl function name. This could be used to
|
||||
attach extra information that could be useful in debugging stack traces.
|
||||
|
||||
This function was copied from C<Sub::Name::subname> and renamed to the naming
|
||||
convention of this module.
|
||||
|
||||
=cut
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
The general structure of this module was written by Paul Evans
|
||||
<leonerd@leonerd.org.uk>.
|
||||
|
||||
The XS implementation of L</set_subname> was copied from L<Sub::Name> by
|
||||
Matthijs van Duin <xmath@cpan.org>
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,166 @@
|
|||
/* multicall.h (version 1.0)
|
||||
*
|
||||
* Implements a poor-man's MULTICALL interface for old versions
|
||||
* of perl that don't offer a proper one. Intended to be compatible
|
||||
* with 5.6.0 and later.
|
||||
*
|
||||
*/
|
||||
|
||||
#ifdef dMULTICALL
|
||||
#define REAL_MULTICALL
|
||||
#else
|
||||
#undef REAL_MULTICALL
|
||||
|
||||
/* In versions of perl where MULTICALL is not defined (i.e. prior
|
||||
* to 5.9.4), Perl_pad_push is not exported either. It also has
|
||||
* an extra argument in older versions; certainly in the 5.8 series.
|
||||
* So we redefine it here.
|
||||
*/
|
||||
|
||||
#ifndef AVf_REIFY
|
||||
# ifdef SVpav_REIFY
|
||||
# define AVf_REIFY SVpav_REIFY
|
||||
# else
|
||||
# error Neither AVf_REIFY nor SVpav_REIFY is defined
|
||||
# endif
|
||||
#endif
|
||||
|
||||
#ifndef AvFLAGS
|
||||
# define AvFLAGS SvFLAGS
|
||||
#endif
|
||||
|
||||
static void
|
||||
multicall_pad_push(pTHX_ AV *padlist, int depth)
|
||||
{
|
||||
if (depth <= AvFILLp(padlist))
|
||||
return;
|
||||
|
||||
{
|
||||
SV** const svp = AvARRAY(padlist);
|
||||
AV* const newpad = newAV();
|
||||
SV** const oldpad = AvARRAY(svp[depth-1]);
|
||||
I32 ix = AvFILLp((AV*)svp[1]);
|
||||
const I32 names_fill = AvFILLp((AV*)svp[0]);
|
||||
SV** const names = AvARRAY(svp[0]);
|
||||
AV *av;
|
||||
|
||||
for ( ;ix > 0; ix--) {
|
||||
if (names_fill >= ix && names[ix] != &PL_sv_undef) {
|
||||
const char sigil = SvPVX(names[ix])[0];
|
||||
if ((SvFLAGS(names[ix]) & SVf_FAKE) || sigil == '&') {
|
||||
/* outer lexical or anon code */
|
||||
av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
|
||||
}
|
||||
else { /* our own lexical */
|
||||
SV *sv;
|
||||
if (sigil == '@')
|
||||
sv = (SV*)newAV();
|
||||
else if (sigil == '%')
|
||||
sv = (SV*)newHV();
|
||||
else
|
||||
sv = NEWSV(0, 0);
|
||||
av_store(newpad, ix, sv);
|
||||
SvPADMY_on(sv);
|
||||
}
|
||||
}
|
||||
else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
|
||||
av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
|
||||
}
|
||||
else {
|
||||
/* save temporaries on recursion? */
|
||||
SV * const sv = NEWSV(0, 0);
|
||||
av_store(newpad, ix, sv);
|
||||
SvPADTMP_on(sv);
|
||||
}
|
||||
}
|
||||
av = newAV();
|
||||
av_extend(av, 0);
|
||||
av_store(newpad, 0, (SV*)av);
|
||||
AvFLAGS(av) = AVf_REIFY;
|
||||
|
||||
av_store(padlist, depth, (SV*)newpad);
|
||||
AvFILLp(padlist) = depth;
|
||||
}
|
||||
}
|
||||
|
||||
#define dMULTICALL \
|
||||
SV **newsp; /* set by POPBLOCK */ \
|
||||
PERL_CONTEXT *cx; \
|
||||
CV *multicall_cv; \
|
||||
OP *multicall_cop; \
|
||||
bool multicall_oldcatch; \
|
||||
U8 hasargs = 0
|
||||
|
||||
/* Between 5.9.1 and 5.9.2 the retstack was removed, and the
|
||||
return op is now stored on the cxstack. */
|
||||
#define HAS_RETSTACK (\
|
||||
PERL_REVISION < 5 || \
|
||||
(PERL_REVISION == 5 && PERL_VERSION < 9) || \
|
||||
(PERL_REVISION == 5 && PERL_VERSION == 9 && PERL_SUBVERSION < 2) \
|
||||
)
|
||||
|
||||
|
||||
/* PUSHSUB is defined so differently on different versions of perl
|
||||
* that it's easier to define our own version than code for all the
|
||||
* different possibilities.
|
||||
*/
|
||||
#if HAS_RETSTACK
|
||||
# define PUSHSUB_RETSTACK(cx)
|
||||
#else
|
||||
# define PUSHSUB_RETSTACK(cx) cx->blk_sub.retop = Nullop;
|
||||
#endif
|
||||
#define MULTICALL_PUSHSUB(cx, the_cv) \
|
||||
cx->blk_sub.cv = the_cv; \
|
||||
cx->blk_sub.olddepth = CvDEPTH(the_cv); \
|
||||
cx->blk_sub.hasargs = hasargs; \
|
||||
cx->blk_sub.lval = PL_op->op_private & \
|
||||
(OPpLVAL_INTRO|OPpENTERSUB_INARGS); \
|
||||
PUSHSUB_RETSTACK(cx) \
|
||||
if (!CvDEPTH(the_cv)) { \
|
||||
(void)SvREFCNT_inc(the_cv); \
|
||||
(void)SvREFCNT_inc(the_cv); \
|
||||
SAVEFREESV(the_cv); \
|
||||
}
|
||||
|
||||
#define PUSH_MULTICALL(the_cv) \
|
||||
STMT_START { \
|
||||
CV *_nOnclAshIngNamE_ = the_cv; \
|
||||
AV* padlist = CvPADLIST(_nOnclAshIngNamE_); \
|
||||
multicall_cv = _nOnclAshIngNamE_; \
|
||||
ENTER; \
|
||||
multicall_oldcatch = CATCH_GET; \
|
||||
SAVESPTR(CvROOT(multicall_cv)->op_ppaddr); \
|
||||
CvROOT(multicall_cv)->op_ppaddr = PL_ppaddr[OP_NULL]; \
|
||||
SAVETMPS; SAVEVPTR(PL_op); \
|
||||
CATCH_SET(TRUE); \
|
||||
PUSHSTACKi(PERLSI_SORT); \
|
||||
PUSHBLOCK(cx, CXt_SUB, PL_stack_sp); \
|
||||
MULTICALL_PUSHSUB(cx, multicall_cv); \
|
||||
if (++CvDEPTH(multicall_cv) >= 2) { \
|
||||
PERL_STACK_OVERFLOW_CHECK(); \
|
||||
multicall_pad_push(aTHX_ padlist, CvDEPTH(multicall_cv)); \
|
||||
} \
|
||||
SAVECOMPPAD(); \
|
||||
PL_comppad = (AV*) (AvARRAY(padlist)[CvDEPTH(multicall_cv)]); \
|
||||
PL_curpad = AvARRAY(PL_comppad); \
|
||||
multicall_cop = CvSTART(multicall_cv); \
|
||||
} STMT_END
|
||||
|
||||
#define MULTICALL \
|
||||
STMT_START { \
|
||||
PL_op = multicall_cop; \
|
||||
CALLRUNOPS(aTHX); \
|
||||
} STMT_END
|
||||
|
||||
#define POP_MULTICALL \
|
||||
STMT_START { \
|
||||
CvDEPTH(multicall_cv)--; \
|
||||
LEAVESUB(multicall_cv); \
|
||||
POPBLOCK(cx,PL_curpm); \
|
||||
POPSTACK; \
|
||||
CATCH_SET(multicall_oldcatch); \
|
||||
LEAVE; \
|
||||
SPAGAIN; \
|
||||
} STMT_END
|
||||
|
||||
#endif
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Scalar::Util ();
|
||||
use List::Util ();
|
||||
use List::Util::XS ();
|
||||
use Sub::Util ();
|
||||
use Test::More tests => 4;
|
||||
|
||||
is( $Scalar::Util::VERSION, $List::Util::VERSION, "VERSION mismatch between Scalar/List");
|
||||
my $has_xs = eval { Scalar::Util->import('dualvar'); 1 };
|
||||
my $xs_version = $has_xs ? $List::Util::VERSION : undef;
|
||||
is( $List::Util::XS::VERSION, $xs_version, "VERSION mismatch between LU::XS and LU");
|
||||
is( $Sub::Util::VERSION, $Scalar::Util::VERSION, "VERSION mistmatch between Sub/Scalar");
|
||||
is( $Sub::Util::VERSION, $List::Util::VERSION, "VERSION mistmatch between Sub/List");
|
||||
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use List::Util qw(any all notall none);
|
||||
use Test::More tests => 12;
|
||||
|
||||
ok( (any { $_ == 1 } 1, 2, 3), 'any true' );
|
||||
ok( !(any { $_ == 1 } 2, 3, 4), 'any false' );
|
||||
ok( !(any { 1 }), 'any empty list' );
|
||||
|
||||
ok( (all { $_ == 1 } 1, 1, 1), 'all true' );
|
||||
ok( !(all { $_ == 1 } 1, 2, 3), 'all false' );
|
||||
ok( (all { 1 }), 'all empty list' );
|
||||
|
||||
ok( (notall { $_ == 1 } 1, 2, 3), 'notall true' );
|
||||
ok( !(notall { $_ == 1 } 1, 1, 1), 'notall false' );
|
||||
ok( !(notall { 1 }), 'notall empty list' );
|
||||
|
||||
ok( (none { $_ == 1 } 2, 3, 4), 'none true' );
|
||||
ok( !(none { $_ == 1 } 1, 2, 3), 'none false' );
|
||||
ok( (none { 1 }), 'none empty list' );
|
||||
|
|
@ -0,0 +1,56 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 12;
|
||||
use Scalar::Util qw(blessed);
|
||||
|
||||
my $t;
|
||||
|
||||
ok(!defined blessed(undef), 'undef is not blessed');
|
||||
ok(!defined blessed(1), 'Numbers are not blessed');
|
||||
ok(!defined blessed('A'), 'Strings are not blessed');
|
||||
ok(!defined blessed({}), 'Unblessed HASH-ref');
|
||||
ok(!defined blessed([]), 'Unblessed ARRAY-ref');
|
||||
ok(!defined blessed(\$t), 'Unblessed SCALAR-ref');
|
||||
|
||||
my $x;
|
||||
|
||||
$x = bless [], "ABC";
|
||||
is(blessed($x), "ABC", 'blessed ARRAY-ref');
|
||||
|
||||
$x = bless {}, "DEF";
|
||||
is(blessed($x), "DEF", 'blessed HASH-ref');
|
||||
|
||||
$x = bless {}, "0";
|
||||
cmp_ok(blessed($x), "eq", "0", 'blessed HASH-ref');
|
||||
|
||||
{
|
||||
my $blessed = do {
|
||||
my $depth;
|
||||
no warnings 'redefine';
|
||||
local *UNIVERSAL::can = sub { die "Burp!" if ++$depth > 2; blessed(shift) };
|
||||
$x = bless {}, "DEF";
|
||||
blessed($x);
|
||||
};
|
||||
is($blessed, "DEF", 'recursion of UNIVERSAL::can');
|
||||
}
|
||||
|
||||
{
|
||||
package Broken;
|
||||
sub isa { die };
|
||||
sub can { die };
|
||||
|
||||
my $obj = bless [], __PACKAGE__;
|
||||
::is( ::blessed($obj), __PACKAGE__, "blessed on broken isa() and can()" );
|
||||
}
|
||||
|
||||
SKIP: {
|
||||
# Unicode package names only supported in perl 5.16 onwards
|
||||
skip "Unicode package names are not supported", 1 if $] < 5.016;
|
||||
|
||||
my $utf8_pack= "X\x{100}";
|
||||
my $obj= bless {}, $utf8_pack;
|
||||
::is( ::blessed($obj), $utf8_pack, "blessed preserves utf8ness for utf8 class names" );
|
||||
}
|
||||
|
|
@ -0,0 +1,128 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Scalar::Util qw(dualvar isdual);
|
||||
use Test::More tests => 41;
|
||||
use Config;
|
||||
|
||||
my $var;
|
||||
$var = dualvar( 2.2,"string");
|
||||
|
||||
ok( isdual($var), 'Is a dualvar');
|
||||
ok( $var == 2.2, 'Numeric value');
|
||||
ok( $var eq "string", 'String value');
|
||||
|
||||
my $var2 = $var;
|
||||
|
||||
ok( isdual($var2), 'Is a dualvar');
|
||||
ok( $var2 == 2.2, 'copy Numeric value');
|
||||
ok( $var2 eq "string", 'copy String value');
|
||||
|
||||
$var++;
|
||||
|
||||
ok( ! isdual($var), 'No longer dualvar');
|
||||
ok( $var == 3.2, 'inc Numeric value');
|
||||
ok( $var ne "string", 'inc String value');
|
||||
|
||||
my $numstr = "10.2";
|
||||
my $numtmp = int($numstr); # use $numstr as an int
|
||||
|
||||
$var = dualvar($numstr, "");
|
||||
|
||||
ok( isdual($var), 'Is a dualvar');
|
||||
ok( $var == $numstr, 'NV');
|
||||
|
||||
SKIP: {
|
||||
skip("dualvar with UV value known to fail with $]",3) if $] < 5.006_001;
|
||||
my $bits = ($Config{'use64bitint'}) ? 63 : 31;
|
||||
$var = dualvar(1<<$bits, "");
|
||||
ok( isdual($var), 'Is a dualvar');
|
||||
ok( $var == (1<<$bits), 'UV 1');
|
||||
ok( $var > 0, 'UV 2');
|
||||
}
|
||||
|
||||
# Create a dualvar "the old fashioned way"
|
||||
$var = "10";
|
||||
ok( ! isdual($var), 'Not a dualvar');
|
||||
my $foo = $var + 0;
|
||||
ok( isdual($var), 'Is a dualvar');
|
||||
|
||||
{
|
||||
package Tied;
|
||||
|
||||
sub TIESCALAR { bless {} }
|
||||
sub FETCH { 7.5 }
|
||||
}
|
||||
|
||||
tie my $tied, 'Tied';
|
||||
$var = dualvar($tied, "ok");
|
||||
ok(isdual($var), 'Is a dualvar');
|
||||
ok($var == 7.5, 'Tied num');
|
||||
ok($var eq 'ok', 'Tied str');
|
||||
|
||||
|
||||
SKIP: {
|
||||
skip("need utf8::is_utf8",2) unless defined &utf8::is_utf8;
|
||||
ok(!!utf8::is_utf8(dualvar(1,chr(400))), 'utf8');
|
||||
ok( !utf8::is_utf8(dualvar(1,"abc")), 'not utf8');
|
||||
}
|
||||
|
||||
BEGIN {
|
||||
if($Config{'useithreads'}) {
|
||||
require threads; import threads;
|
||||
require threads::shared; import threads::shared;
|
||||
require constant; import constant HAVE_THREADS => 1;
|
||||
}
|
||||
else {
|
||||
require constant; import constant HAVE_THREADS => 0;
|
||||
}
|
||||
}
|
||||
|
||||
SKIP: {
|
||||
skip("Perl not compiled with 'useithreads'",20) unless HAVE_THREADS;
|
||||
skip("Requires threads::shared v1.42 or later",20) unless ($threads::shared::VERSION >= 1.42);
|
||||
|
||||
my $siv;
|
||||
share($siv);
|
||||
$siv = dualvar(42, 'Fourty-Two');
|
||||
|
||||
my $snv;
|
||||
share($snv);
|
||||
$snv = dualvar(3.14, 'PI');
|
||||
|
||||
my $suv;
|
||||
share($suv);
|
||||
my $bits = ($Config{'use64bitint'}) ? 63 : 31;
|
||||
$suv = dualvar(1<<$bits, 'Large unsigned int');
|
||||
|
||||
ok($siv == 42, 'Shared IV number preserved');
|
||||
ok($siv eq 'Fourty-Two', 'Shared string preserved');
|
||||
ok(isdual($siv), 'Is a dualvar');
|
||||
ok($snv == 3.14, 'Shared NV number preserved');
|
||||
ok($snv eq 'PI', 'Shared string preserved');
|
||||
ok(isdual($snv), 'Is a dualvar');
|
||||
ok($suv == (1<<$bits), 'Shared UV number preserved');
|
||||
ok($suv > 0, 'Shared UV number preserved');
|
||||
ok($suv eq 'Large unsigned int', 'Shared string preserved');
|
||||
ok(isdual($suv), 'Is a dualvar');
|
||||
|
||||
my @ary;
|
||||
share(@ary);
|
||||
$ary[0] = $siv;
|
||||
$ary[1] = $snv;
|
||||
$ary[2] = $suv;
|
||||
|
||||
ok($ary[0] == 42, 'Shared IV number preserved');
|
||||
ok($ary[0] eq 'Fourty-Two', 'Shared string preserved');
|
||||
ok(isdual($ary[0]), 'Is a dualvar');
|
||||
ok($ary[1] == 3.14, 'Shared NV number preserved');
|
||||
ok($ary[1] eq 'PI', 'Shared string preserved');
|
||||
ok(isdual($ary[1]), 'Is a dualvar');
|
||||
ok($ary[2] == (1<<$bits), 'Shared UV number preserved');
|
||||
ok($ary[2] > 0, 'Shared UV number preserved');
|
||||
ok($ary[2] eq 'Large unsigned int', 'Shared string preserved');
|
||||
ok(isdual($ary[2]), 'Is a dualvar');
|
||||
}
|
||||
|
||||
|
|
@ -0,0 +1,122 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More;
|
||||
use B 'svref_2object';
|
||||
BEGIN { $^P |= 0x210 }
|
||||
|
||||
# This is a mess. The stash can supposedly handle Unicode but the behavior
|
||||
# is literally undefined before 5.16 (with crashes beyond the basic plane),
|
||||
# and remains unclear past 5.16 with evalbytes and feature unicode_eval
|
||||
# In any case - Sub::Name needs to *somehow* work with this, so we will do
|
||||
# a heuristic with ambiguous eval and looking for octets in the stash
|
||||
use if $] >= 5.016, feature => 'unicode_eval';
|
||||
|
||||
if ($] >= 5.008) {
|
||||
my $builder = Test::More->builder;
|
||||
binmode $builder->output, ":encoding(utf8)";
|
||||
binmode $builder->failure_output, ":encoding(utf8)";
|
||||
binmode $builder->todo_output, ":encoding(utf8)";
|
||||
}
|
||||
|
||||
sub compile_named_sub {
|
||||
my ( $fullname, $body ) = @_;
|
||||
my $sub = eval "sub $fullname { $body }" . '\\&{$fullname}';
|
||||
return $sub if $sub;
|
||||
my $e = $@;
|
||||
require Carp;
|
||||
Carp::croak $e;
|
||||
}
|
||||
|
||||
sub caller3_ok {
|
||||
my ( $sub, $expected, $type, $ord ) = @_;
|
||||
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
||||
|
||||
my $for_what = sprintf "when it contains \\x%s ( %s )", (
|
||||
( ($ord > 255)
|
||||
? sprintf "{%X}", $ord
|
||||
: sprintf "%02X", $ord
|
||||
),
|
||||
(
|
||||
$ord > 255 ? unpack('H*', pack 'C0U', $ord )
|
||||
: (chr $ord =~ /[[:print:]]/) ? sprintf "%c", $ord
|
||||
: sprintf '\%o', $ord
|
||||
),
|
||||
);
|
||||
|
||||
$expected =~ s/'/::/g;
|
||||
|
||||
# this is apparently how things worked before 5.16
|
||||
utf8::encode($expected) if $] < 5.016 and $ord > 255;
|
||||
|
||||
my $stash_name = join '::', map { $_->STASH->NAME, $_->NAME } svref_2object($sub)->GV;
|
||||
|
||||
is $stash_name, $expected, "stash name for $type is correct $for_what";
|
||||
is $sub->(), $expected, "caller() in $type returns correct name $for_what";
|
||||
SKIP: {
|
||||
skip '%DB::sub not populated when enabled at runtime', 1
|
||||
unless keys %DB::sub;
|
||||
my ($prefix) = $expected =~ /^(.*?test::[^:]+::)/;
|
||||
my ($db_found) = grep /^$prefix/, keys %DB::sub;
|
||||
is $db_found, $expected, "%DB::sub entry for $type is correct $for_what";
|
||||
}
|
||||
}
|
||||
|
||||
#######################################################################
|
||||
|
||||
use Sub::Util 'set_subname';
|
||||
|
||||
my @ordinal = ( 1 .. 255 );
|
||||
|
||||
# 5.14 is the first perl to start properly handling \0 in identifiers
|
||||
unshift @ordinal, 0
|
||||
unless $] < 5.014;
|
||||
|
||||
# Unicode in 5.6 is not sane (crashes etc)
|
||||
push @ordinal,
|
||||
0x100, # LATIN CAPITAL LETTER A WITH MACRON
|
||||
0x498, # CYRILLIC CAPITAL LETTER ZE WITH DESCENDER
|
||||
0x2122, # TRADE MARK SIGN
|
||||
0x1f4a9, # PILE OF POO
|
||||
unless $] < 5.008;
|
||||
|
||||
plan tests => @ordinal * 2 * 3;
|
||||
|
||||
my $legal_ident_char = "A-Z_a-z0-9'";
|
||||
$legal_ident_char .= join '', map chr, 0x100, 0x498
|
||||
unless $] < 5.008;
|
||||
|
||||
my $uniq = 'A000';
|
||||
for my $ord (@ordinal) {
|
||||
my $sub;
|
||||
$uniq++;
|
||||
my $pkg = sprintf 'test::%s::SOME_%c_STASH', $uniq, $ord;
|
||||
my $subname = sprintf 'SOME_%s_%c_NAME', $uniq, $ord;
|
||||
my $fullname = join '::', $pkg, $subname;
|
||||
|
||||
$sub = set_subname $fullname => sub { (caller(0))[3] };
|
||||
caller3_ok $sub, $fullname, 'renamed closure', $ord;
|
||||
|
||||
# test that we can *always* compile at least within the correct package
|
||||
my $expected;
|
||||
if ( chr($ord) =~ m/^[$legal_ident_char]$/o ) { # compile directly
|
||||
$expected = "native::$fullname";
|
||||
$sub = compile_named_sub $expected => '(caller(0))[3]';
|
||||
}
|
||||
else { # not a legal identifier but at least test the package name by aliasing
|
||||
$expected = "aliased::native::$fullname";
|
||||
{
|
||||
no strict 'refs';
|
||||
*palatable:: = *{"aliased::native::${pkg}::"};
|
||||
# now palatable:: literally means aliased::native::${pkg}::
|
||||
my $encoded_sub = $subname;
|
||||
utf8::encode($encoded_sub) if "$]" < 5.016 and $ord > 255;
|
||||
${"palatable::$encoded_sub"} = 1;
|
||||
${"palatable::"}{"sub"} = ${"palatable::"}{$encoded_sub};
|
||||
# and palatable::sub means aliased::native::${pkg}::${subname}
|
||||
}
|
||||
$sub = compile_named_sub 'palatable::sub' => '(caller(0))[3]';
|
||||
}
|
||||
caller3_ok $sub, $expected, 'natively compiled sub', $ord;
|
||||
}
|
||||
|
|
@ -0,0 +1,125 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use List::Util qw(first);
|
||||
use Test::More;
|
||||
plan tests => 24;
|
||||
my $v;
|
||||
|
||||
ok(defined &first, 'defined');
|
||||
|
||||
$v = first { 8 == ($_ - 1) } 9,4,5,6;
|
||||
is($v, 9, 'one more than 8');
|
||||
|
||||
$v = first { 0 } 1,2,3,4;
|
||||
is($v, undef, 'none match');
|
||||
|
||||
$v = first { 0 };
|
||||
is($v, undef, 'no args');
|
||||
|
||||
$v = first { $_->[1] le "e" and "e" le $_->[2] }
|
||||
[qw(a b c)], [qw(d e f)], [qw(g h i)];
|
||||
is_deeply($v, [qw(d e f)], 'reference args');
|
||||
|
||||
# Check that eval{} inside the block works correctly
|
||||
my $i = 0;
|
||||
$v = first { eval { die }; ($i == 5, $i = $_)[0] } 0,1,2,3,4,5,5;
|
||||
is($v, 5, 'use of eval');
|
||||
|
||||
$v = eval { first { die if $_ } 0,0,1 };
|
||||
is($v, undef, 'use of die');
|
||||
|
||||
sub foobar { first { !defined(wantarray) || wantarray } "not ","not ","not " }
|
||||
|
||||
($v) = foobar();
|
||||
is($v, undef, 'wantarray');
|
||||
|
||||
# Can we leave the sub with 'return'?
|
||||
$v = first {return ($_>6)} 2,4,6,12;
|
||||
is($v, 12, 'return');
|
||||
|
||||
# ... even in a loop?
|
||||
$v = first {while(1) {return ($_>6)} } 2,4,6,12;
|
||||
is($v, 12, 'return from loop');
|
||||
|
||||
# Does it work from another package?
|
||||
{ package Foo;
|
||||
::is(List::Util::first(sub{$_>4},(1..4,24)), 24, 'other package');
|
||||
}
|
||||
|
||||
# Can we undefine a first sub while it's running?
|
||||
sub self_immolate {undef &self_immolate; 1}
|
||||
eval { $v = first \&self_immolate, 1,2; };
|
||||
like($@, qr/^Can't undef active subroutine/, "undef active sub");
|
||||
|
||||
# Redefining an active sub should not fail, but whether the
|
||||
# redefinition takes effect immediately depends on whether we're
|
||||
# running the Perl or XS implementation.
|
||||
|
||||
sub self_updating {
|
||||
no warnings 'redefine';
|
||||
*self_updating = sub{1};
|
||||
1
|
||||
}
|
||||
eval { $v = first \&self_updating, 1,2; };
|
||||
is($@, '', 'redefine self');
|
||||
|
||||
{ my $failed = 0;
|
||||
|
||||
sub rec { my $n = shift;
|
||||
if (!defined($n)) { # No arg means we're being called by first()
|
||||
return 1; }
|
||||
if ($n<5) { rec($n+1); }
|
||||
else { $v = first \&rec, 1,2; }
|
||||
$failed = 1 if !defined $n;
|
||||
}
|
||||
|
||||
rec(1);
|
||||
ok(!$failed, 'from active sub');
|
||||
}
|
||||
|
||||
# Calling a sub from first should leave its refcount unchanged.
|
||||
SKIP: {
|
||||
skip("No Internals::SvREFCNT", 1) if !defined &Internals::SvREFCNT;
|
||||
sub huge {$_>1E6}
|
||||
my $refcnt = &Internals::SvREFCNT(\&huge);
|
||||
$v = first \&huge, 1..6;
|
||||
is(&Internals::SvREFCNT(\&huge), $refcnt, "Refcount unchanged");
|
||||
}
|
||||
|
||||
# These tests are only relevant for the real multicall implementation. The
|
||||
# pseudo-multicall implementation behaves differently.
|
||||
SKIP: {
|
||||
$List::Util::REAL_MULTICALL ||= 0; # Avoid use only once
|
||||
skip("Poor man's MULTICALL can't cope", 2)
|
||||
if !$List::Util::REAL_MULTICALL;
|
||||
|
||||
# Can we goto a label from the 'first' sub?
|
||||
eval {()=first{goto foo} 1,2; foo: 1};
|
||||
like($@, qr/^Can't "goto" out of a pseudo block/, "goto label");
|
||||
|
||||
# Can we goto a subroutine?
|
||||
eval {()=first{goto sub{}} 1,2;};
|
||||
like($@, qr/^Can't goto subroutine from a sort sub/, "goto sub");
|
||||
}
|
||||
|
||||
use constant XSUBC_TRUE => 1;
|
||||
use constant XSUBC_FALSE => 0;
|
||||
|
||||
is first(\&XSUBC_TRUE, 42, 1, 2, 3), 42, 'XSUB callbacks';
|
||||
is first(\&XSUBC_FALSE, 42, 1, 2, 3), undef, 'XSUB callbacks';
|
||||
|
||||
|
||||
eval { &first(1) };
|
||||
ok($@ =~ /^Not a subroutine reference/, 'check for code reference');
|
||||
eval { &first(1,2) };
|
||||
ok($@ =~ /^Not a subroutine reference/, 'check for code reference');
|
||||
eval { &first(qw(a b)) };
|
||||
ok($@ =~ /^Not a subroutine reference/, 'check for code reference');
|
||||
eval { &first([],1,2,3) };
|
||||
ok($@ =~ /^Not a subroutine reference/, 'check for code reference');
|
||||
eval { &first(+{},1,2,3) };
|
||||
ok($@ =~ /^Not a subroutine reference/, 'check for code reference');
|
||||
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Scalar::Util qw(blessed reftype refaddr);
|
||||
use Test::More tests => 6;
|
||||
|
||||
my $getmagic_count;
|
||||
|
||||
{
|
||||
package T;
|
||||
use Tie::Scalar;
|
||||
use base qw(Tie::StdScalar);
|
||||
|
||||
sub FETCH {
|
||||
$getmagic_count++;
|
||||
my($self) = @_;
|
||||
return $self->SUPER::FETCH;
|
||||
}
|
||||
}
|
||||
|
||||
tie my $var, 'T';
|
||||
|
||||
$var = bless {};
|
||||
|
||||
$getmagic_count = 0;
|
||||
ok blessed($var);
|
||||
is $getmagic_count, 1, 'blessed';
|
||||
|
||||
$getmagic_count = 0;
|
||||
ok reftype($var);
|
||||
is $getmagic_count, 1, 'reftype';
|
||||
|
||||
$getmagic_count = 0;
|
||||
ok refaddr($var);
|
||||
is $getmagic_count, 1, 'refaddr';
|
||||
|
|
@ -0,0 +1,97 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use List::Util qw(head tail);
|
||||
use Test::More;
|
||||
plan tests => 42;
|
||||
|
||||
my @ary;
|
||||
|
||||
ok(defined &head, 'defined');
|
||||
ok(defined &tail, 'defined');
|
||||
|
||||
@ary = head 1, ( 4, 5, 6 );
|
||||
is( scalar @ary, 1 );
|
||||
is( $ary[0], 4 );
|
||||
|
||||
@ary = head 2, ( 4, 5, 6 );
|
||||
is( scalar @ary, 2 );
|
||||
is( $ary[0], 4 );
|
||||
is( $ary[1], 5 );
|
||||
|
||||
@ary = head -1, ( 4, 5, 6 );
|
||||
is( scalar @ary, 2 );
|
||||
is( $ary[0], 4 );
|
||||
is( $ary[1], 5 );
|
||||
|
||||
@ary = head -2, ( 4, 5, 6 );
|
||||
is( scalar @ary, 1 );
|
||||
is( $ary[0], 4 );
|
||||
|
||||
@ary = head 999, ( 4, 5, 6 );
|
||||
is( scalar @ary, 3 );
|
||||
is( $ary[0], 4 );
|
||||
is( $ary[1], 5 );
|
||||
is( $ary[2], 6 );
|
||||
|
||||
@ary = head 0, ( 4, 5, 6 );
|
||||
is( scalar @ary, 0 );
|
||||
|
||||
@ary = head 0;
|
||||
is( scalar @ary, 0 );
|
||||
|
||||
@ary = head 5;
|
||||
is( scalar @ary, 0 );
|
||||
|
||||
@ary = head -3, ( 4, 5, 6 );
|
||||
is( scalar @ary, 0 );
|
||||
|
||||
@ary = head -999, ( 4, 5, 6 );
|
||||
is( scalar @ary, 0 );
|
||||
|
||||
eval '@ary = head';
|
||||
like( $@, qr{^Not enough arguments for List::Util::head} );
|
||||
|
||||
@ary = head 4, ( 4, 5, 6 );
|
||||
is( scalar @ary, 3 );
|
||||
is( $ary[0], 4 );
|
||||
is( $ary[1], 5 );
|
||||
is( $ary[2], 6 );
|
||||
|
||||
@ary = tail 1, ( 4, 5, 6 );
|
||||
is( scalar @ary, 1 );
|
||||
is( $ary[0], 6 );
|
||||
|
||||
@ary = tail 2, ( 4, 5, 6 );
|
||||
is( scalar @ary, 2 );
|
||||
is( $ary[0], 5 );
|
||||
is( $ary[1], 6 );
|
||||
|
||||
@ary = tail -1, ( 4, 5, 6 );
|
||||
is( scalar @ary, 2 );
|
||||
is( $ary[0], 5 );
|
||||
is( $ary[1], 6 );
|
||||
|
||||
@ary = tail -2, ( 4, 5, 6 );
|
||||
is( scalar @ary, 1 );
|
||||
is( $ary[0], 6 );
|
||||
|
||||
@ary = tail 0, ( 4, 5, 6 );
|
||||
is( scalar @ary, 0 );
|
||||
|
||||
@ary = tail 0;
|
||||
is( scalar @ary, 0 );
|
||||
|
||||
@ary = tail 5;
|
||||
is( scalar @ary, 0 );
|
||||
|
||||
@ary = tail -3;
|
||||
is( scalar @ary, 0 );
|
||||
|
||||
@ary = tail -999;
|
||||
is( scalar @ary, 0 );
|
||||
|
||||
eval '@ary = tail';
|
||||
like( $@, qr{^Not enough arguments for List::Util::tail} );
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
$|=1;
|
||||
use Scalar::Util ();
|
||||
use Test::More (grep { /isvstring/ } @Scalar::Util::EXPORT_FAIL)
|
||||
? (skip_all => 'isvstring is not supported on this perl version')
|
||||
: (tests => 3);
|
||||
|
||||
use Scalar::Util qw(isvstring);
|
||||
|
||||
my $vs = ord("A") == 193 ? 241.75.240 : 49.46.48;
|
||||
|
||||
ok( $vs == "1.0", 'dotted num');
|
||||
ok( isvstring($vs), 'isvstring');
|
||||
|
||||
my $sv = "1.0";
|
||||
ok( !isvstring($sv), 'not isvstring');
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 19;
|
||||
use Scalar::Util qw(looks_like_number);
|
||||
|
||||
foreach my $num (qw(1 -1 +1 1.0 +1.0 -1.0 -1.0e-12)) {
|
||||
ok(looks_like_number($num), "'$num'");
|
||||
}
|
||||
|
||||
is(!!looks_like_number("Inf"), $] >= 5.006001, 'Inf');
|
||||
is(!!looks_like_number("Infinity"), $] >= 5.008, 'Infinity');
|
||||
is(!!looks_like_number("NaN"), $] >= 5.008, 'NaN');
|
||||
is(!!looks_like_number("foo"), '', 'foo');
|
||||
is(!!looks_like_number(undef), '', 'undef');
|
||||
is(!!looks_like_number({}), '', 'HASH Ref');
|
||||
is(!!looks_like_number([]), '', 'ARRAY Ref');
|
||||
|
||||
use Math::BigInt;
|
||||
my $bi = Math::BigInt->new('1234567890');
|
||||
is(!!looks_like_number($bi), 1, 'Math::BigInt');
|
||||
is(!!looks_like_number("$bi"), 1, 'Stringified Math::BigInt');
|
||||
|
||||
{ package Foo;
|
||||
sub TIEHASH { bless {} }
|
||||
sub FETCH { $_[1] }
|
||||
}
|
||||
my %foo;
|
||||
tie %foo, 'Foo';
|
||||
is(!!looks_like_number($foo{'abc'}), '', 'Tied');
|
||||
is(!!looks_like_number($foo{'123'}), 1, 'Tied');
|
||||
|
||||
is(!!looks_like_number("\x{1815}"), '', 'MONGOLIAN DIGIT FIVE');
|
||||
|
||||
# We should copy some of perl core tests like t/base/num.t here
|
||||
|
|
@ -0,0 +1,65 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 10;
|
||||
use List::Util qw(max);
|
||||
|
||||
my $v;
|
||||
|
||||
ok(defined &max, 'defined');
|
||||
|
||||
$v = max(1);
|
||||
is($v, 1, 'single arg');
|
||||
|
||||
$v = max (1,2);
|
||||
is($v, 2, '2-arg ordered');
|
||||
|
||||
$v = max(2,1);
|
||||
is($v, 2, '2-arg reverse ordered');
|
||||
|
||||
my @a = map { rand() } 1 .. 20;
|
||||
my @b = sort { $a <=> $b } @a;
|
||||
$v = max(@a);
|
||||
is($v, $b[-1], '20-arg random order');
|
||||
|
||||
my $one = Foo->new(1);
|
||||
my $two = Foo->new(2);
|
||||
my $thr = Foo->new(3);
|
||||
|
||||
$v = max($one,$two,$thr);
|
||||
is($v, 3, 'overload');
|
||||
|
||||
$v = max($thr,$two,$one);
|
||||
is($v, 3, 'overload');
|
||||
|
||||
|
||||
{ package Foo;
|
||||
|
||||
use overload
|
||||
'""' => sub { ${$_[0]} },
|
||||
'0+' => sub { ${$_[0]} },
|
||||
'>' => sub { ${$_[0]} > ${$_[1]} },
|
||||
fallback => 1;
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $value = shift;
|
||||
bless \$value, $class;
|
||||
}
|
||||
}
|
||||
|
||||
use Math::BigInt;
|
||||
|
||||
my $v1 = Math::BigInt->new(2) ** Math::BigInt->new(65);
|
||||
my $v2 = $v1 - 1;
|
||||
my $v3 = $v2 - 1;
|
||||
$v = max($v1,$v2,$v1,$v3,$v1);
|
||||
is($v, $v1, 'bigint');
|
||||
|
||||
$v = max($v1, 1, 2, 3);
|
||||
is($v, $v1, 'bigint and normal int');
|
||||
|
||||
$v = max(1, 2, $v1, 3);
|
||||
is($v, $v1, 'bigint and normal int');
|
||||
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 5;
|
||||
use List::Util qw(maxstr);
|
||||
|
||||
my $v;
|
||||
|
||||
ok(defined &maxstr, 'defined');
|
||||
|
||||
$v = maxstr('a');
|
||||
is($v, 'a', 'single arg');
|
||||
|
||||
$v = maxstr('a','b');
|
||||
is($v, 'b', '2-arg ordered');
|
||||
|
||||
$v = maxstr('B','A');
|
||||
is($v, 'B', '2-arg reverse ordered');
|
||||
|
||||
my @a = map { pack("u", pack("C*",map { int(rand(256))} (0..int(rand(10) + 2)))) } 0 .. 20;
|
||||
my @b = sort { $a cmp $b } @a;
|
||||
$v = maxstr(@a);
|
||||
is($v, $b[-1], 'random ordered');
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 7;
|
||||
use List::Util qw(mesh mesh_longest mesh_shortest);
|
||||
|
||||
is_deeply( [mesh ()], [],
|
||||
'mesh empty returns empty');
|
||||
|
||||
is_deeply( [mesh ['a'..'c']], [ 'a', 'b', 'c' ],
|
||||
'mesh of one list returns the list' );
|
||||
|
||||
is_deeply( [mesh ['one', 'two'], [1, 2]], [ one => 1, two => 2 ],
|
||||
'mesh of two lists returns a list of two pairs' );
|
||||
|
||||
# Unequal length arrays
|
||||
|
||||
is_deeply( [mesh_longest ['x', 'y', 'z'], ['X', 'Y']], [ 'x', 'X', 'y', 'Y', 'z', undef ],
|
||||
'mesh_longest extends short lists with undef' );
|
||||
|
||||
is_deeply( [mesh_shortest ['x', 'y', 'z'], ['X', 'Y']], [ 'x', 'X', 'y', 'Y' ],
|
||||
'mesh_shortest stops after shortest list' );
|
||||
|
||||
# Non arrayref arguments throw exception
|
||||
ok( !defined eval { mesh 1, 2, 3 },
|
||||
'non-reference argument throws exception' );
|
||||
|
||||
ok( !defined eval { mesh +{ one => 1 } },
|
||||
'reference to non array throws exception' );
|
||||
|
|
@ -0,0 +1,82 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 22;
|
||||
use List::Util qw(min);
|
||||
|
||||
my $v;
|
||||
|
||||
ok(defined &min, 'defined');
|
||||
|
||||
$v = min(9);
|
||||
is($v, 9, 'single arg');
|
||||
|
||||
$v = min (1,2);
|
||||
is($v, 1, '2-arg ordered');
|
||||
|
||||
$v = min(2,1);
|
||||
is($v, 1, '2-arg reverse ordered');
|
||||
|
||||
my @a = map { rand() } 1 .. 20;
|
||||
my @b = sort { $a <=> $b } @a;
|
||||
$v = min(@a);
|
||||
is($v, $b[0], '20-arg random order');
|
||||
|
||||
my $one = Foo->new(1);
|
||||
my $two = Foo->new(2);
|
||||
my $thr = Foo->new(3);
|
||||
|
||||
$v = min($one,$two,$thr);
|
||||
is($v, 1, 'overload');
|
||||
|
||||
$v = min($thr,$two,$one);
|
||||
is($v, 1, 'overload');
|
||||
|
||||
{ package Foo;
|
||||
|
||||
use overload
|
||||
'""' => sub { ${$_[0]} },
|
||||
'0+' => sub { ${$_[0]} },
|
||||
'<' => sub { ${$_[0]} < ${$_[1]} },
|
||||
fallback => 1;
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $value = shift;
|
||||
bless \$value, $class;
|
||||
}
|
||||
}
|
||||
|
||||
use Math::BigInt;
|
||||
|
||||
my $v1 = Math::BigInt->new(2) ** Math::BigInt->new(65);
|
||||
my $v2 = $v1 - 1;
|
||||
my $v3 = $v2 - 1;
|
||||
$v = min($v1,$v2,$v1,$v3,$v1);
|
||||
is($v, $v3, 'bigint');
|
||||
|
||||
$v = min($v1, 1, 2, 3);
|
||||
is($v, 1, 'bigint and normal int');
|
||||
|
||||
$v = min(1, 2, $v1, 3);
|
||||
is($v, 1, 'bigint and normal int');
|
||||
|
||||
{
|
||||
# test that min/max and sum call GETMAGIC properly
|
||||
# note, in my tests how this fails depends on exactly
|
||||
# which List::Util subs are called and in what order.
|
||||
my @list;
|
||||
for my $size (10, 20, 10, 30) {
|
||||
@list = ( 1 ) x $size;
|
||||
|
||||
my $sum= List::Util::sum( 0, $#list );
|
||||
ok( $sum == $size-1, "sum(\$#list, 0) == $size-1");
|
||||
|
||||
my $min= List::Util::min( 15, $#list );
|
||||
ok( $min <= 15, "min(15,$size)" );
|
||||
|
||||
my $max= List::Util::max( 0, $#list );
|
||||
ok( $max == $size-1, "max(\$#list, 0) == $size-1");
|
||||
}
|
||||
}
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 5;
|
||||
use List::Util qw(minstr);
|
||||
|
||||
my $v;
|
||||
|
||||
ok(defined &minstr, 'defined');
|
||||
|
||||
$v = minstr('a');
|
||||
is($v, 'a', 'single arg');
|
||||
|
||||
$v = minstr('a','b');
|
||||
is($v, 'a', '2-arg ordered');
|
||||
|
||||
$v = minstr('B','A');
|
||||
is($v, 'A', '2-arg reverse ordered');
|
||||
|
||||
my @a = map { pack("u", pack("C*",map { int(rand(256))} (0..int(rand(10) + 2)))) } 0 .. 20;
|
||||
my @b = sort { $a cmp $b } @a;
|
||||
$v = minstr(@a);
|
||||
is($v, $b[0], 'random ordered');
|
||||
|
|
@ -0,0 +1,89 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 21;
|
||||
use Scalar::Util qw(openhandle);
|
||||
|
||||
ok(defined &openhandle, 'defined');
|
||||
|
||||
{
|
||||
my $fh = \*STDERR;
|
||||
is(openhandle($fh), $fh, 'STDERR');
|
||||
|
||||
is(fileno(openhandle(*STDERR)), fileno(STDERR), 'fileno(STDERR)');
|
||||
}
|
||||
|
||||
{
|
||||
use vars qw(*CLOSED);
|
||||
is(openhandle(*CLOSED), undef, 'closed');
|
||||
}
|
||||
|
||||
SKIP: {
|
||||
skip "3-arg open only on 5.6 or later", 1 if $]<5.006;
|
||||
|
||||
open my $fh, "<", $0;
|
||||
skip "could not open $0 for reading: $!", 2 unless $fh;
|
||||
is(openhandle($fh), $fh, "works with indirect filehandles");
|
||||
close($fh);
|
||||
is(openhandle($fh), undef, "works with indirect filehandles");
|
||||
}
|
||||
|
||||
SKIP: {
|
||||
skip "in-memory files only on 5.8 or later", 2 if $]<5.008;
|
||||
|
||||
open my $fh, "<", \"in-memory file";
|
||||
skip "could not open in-memory file: $!", 2 unless $fh;
|
||||
is(openhandle($fh), $fh, "works with in-memory files");
|
||||
close($fh);
|
||||
is(openhandle($fh), undef, "works with in-memory files");
|
||||
}
|
||||
|
||||
ok(openhandle(\*DATA), "works for \*DATA");
|
||||
ok(openhandle(*DATA), "works for *DATA");
|
||||
ok(openhandle(*DATA{IO}), "works for *DATA{IO}");
|
||||
|
||||
{
|
||||
require IO::Handle;
|
||||
my $fh = IO::Handle->new_from_fd(fileno(*STDERR), 'w');
|
||||
skip "new_from_fd(fileno(*STDERR)) failed", 2 unless $fh;
|
||||
ok(openhandle($fh), "works for IO::Handle objects");
|
||||
|
||||
ok(!openhandle(IO::Handle->new), "unopened IO::Handle");
|
||||
}
|
||||
|
||||
{
|
||||
require IO::File;
|
||||
my $fh = IO::File->new;
|
||||
$fh->open("< $0")
|
||||
or skip "could not open $0: $!", 3;
|
||||
ok(openhandle($fh), "works for IO::File objects");
|
||||
close($fh);
|
||||
ok(!openhandle($fh), "works for IO::File objects");
|
||||
|
||||
ok(!openhandle(IO::File->new), "unopened IO::File" );
|
||||
}
|
||||
|
||||
SKIP: {
|
||||
skip( "Tied handles only on 5.8 or later", 2) if $]<5.008;
|
||||
|
||||
use vars qw(*H);
|
||||
|
||||
package My::Tie;
|
||||
require Tie::Handle;
|
||||
@My::Tie::ISA = qw(Tie::Handle);
|
||||
sub TIEHANDLE { bless {} }
|
||||
|
||||
package main;
|
||||
tie *H, 'My::Tie';
|
||||
ok(openhandle(*H), "tied handles are always ok");
|
||||
ok(openhandle(\*H), "tied handle refs are always ok");
|
||||
}
|
||||
|
||||
ok !openhandle(undef), "undef is not a filehandle";
|
||||
ok !openhandle("STDIN"), "strings are not filehandles";
|
||||
ok !openhandle(0), "integers are not filehandles";
|
||||
|
||||
|
||||
__DATA__
|
||||
|
|
@ -0,0 +1,143 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 29;
|
||||
use List::Util qw(pairgrep pairfirst pairmap pairs unpairs pairkeys pairvalues);
|
||||
|
||||
no warnings 'misc'; # avoid "Odd number of elements" warnings most of the time
|
||||
|
||||
is_deeply( [ pairgrep { $b % 2 } one => 1, two => 2, three => 3 ],
|
||||
[ one => 1, three => 3 ],
|
||||
'pairgrep list' );
|
||||
|
||||
is( scalar( pairgrep { $b & 2 } one => 1, two => 2, three => 3 ),
|
||||
2,
|
||||
'pairgrep scalar' );
|
||||
|
||||
is_deeply( [ pairgrep { $a } 0 => "zero", 1 => "one", 2 ],
|
||||
[ 1 => "one", 2 => undef ],
|
||||
'pairgrep pads with undef' );
|
||||
|
||||
{
|
||||
use warnings 'misc';
|
||||
my $warnings = "";
|
||||
local $SIG{__WARN__} = sub { $warnings .= $_[0] };
|
||||
|
||||
pairgrep { } one => 1, two => 2;
|
||||
is( $warnings, "", 'even-sized list yields no warnings from pairgrep' );
|
||||
|
||||
pairgrep { } one => 1, two =>;
|
||||
like( $warnings, qr/^Odd number of elements in pairgrep at /,
|
||||
'odd-sized list yields warning from pairgrep' );
|
||||
}
|
||||
|
||||
{
|
||||
my @kvlist = ( one => 1, two => 2 );
|
||||
pairgrep { $b++ } @kvlist;
|
||||
is_deeply( \@kvlist, [ one => 2, two => 3 ], 'pairgrep aliases elements' );
|
||||
}
|
||||
|
||||
is_deeply( [ pairfirst { length $a == 5 } one => 1, two => 2, three => 3 ],
|
||||
[ three => 3 ],
|
||||
'pairfirst list' );
|
||||
|
||||
is_deeply( [ pairfirst { length $a == 4 } one => 1, two => 2, three => 3 ],
|
||||
[],
|
||||
'pairfirst list empty' );
|
||||
|
||||
is( scalar( pairfirst { length $a == 5 } one => 1, two => 2, three => 3 ),
|
||||
1,
|
||||
'pairfirst scalar true' );
|
||||
|
||||
ok( !scalar( pairfirst { length $a == 4 } one => 1, two => 2, three => 3 ),
|
||||
'pairfirst scalar false' );
|
||||
|
||||
is_deeply( [ pairmap { uc $a => $b } one => 1, two => 2, three => 3 ],
|
||||
[ ONE => 1, TWO => 2, THREE => 3 ],
|
||||
'pairmap list' );
|
||||
|
||||
is( scalar( pairmap { qw( a b c ) } one => 1, two => 2 ),
|
||||
6,
|
||||
'pairmap scalar' );
|
||||
|
||||
is_deeply( [ pairmap { $a => @$b } one => [1,1,1], two => [2,2,2], three => [3,3,3] ],
|
||||
[ one => 1, 1, 1, two => 2, 2, 2, three => 3, 3, 3 ],
|
||||
'pairmap list returning >2 items' );
|
||||
|
||||
is_deeply( [ pairmap { $b } one => 1, two => 2, three => ],
|
||||
[ 1, 2, undef ],
|
||||
'pairmap pads with undef' );
|
||||
|
||||
{
|
||||
my @kvlist = ( one => 1, two => 2 );
|
||||
pairmap { $b++ } @kvlist;
|
||||
is_deeply( \@kvlist, [ one => 2, two => 3 ], 'pairmap aliases elements' );
|
||||
}
|
||||
|
||||
# Calculating a 1000-element list should hopefully cause the stack to move
|
||||
# underneath pairmap
|
||||
is_deeply( [ pairmap { my @l = (1) x 1000; "$a=$b" } one => 1, two => 2, three => 3 ],
|
||||
[ "one=1", "two=2", "three=3" ],
|
||||
'pairmap copes with stack movement' );
|
||||
|
||||
{
|
||||
# do the pairmap and is_deeply as two separate statements to avoid
|
||||
# the stack being extended before pairmap is called
|
||||
my @a = pairmap { $a .. $b }
|
||||
1 => 3, 4 => 4, 5 => 6, 7 => 1998, 1999 => 2000;
|
||||
my @exp; push @exp, $_ for 1..2000;
|
||||
is_deeply( \@a, \@exp,
|
||||
'pairmap result has more elements than input' );
|
||||
}
|
||||
|
||||
is_deeply( [ pairs one => 1, two => 2, three => 3 ],
|
||||
[ [ one => 1 ], [ two => 2 ], [ three => 3 ] ],
|
||||
'pairs' );
|
||||
|
||||
is_deeply( [ pairs one => 1, two => ],
|
||||
[ [ one => 1 ], [ two => undef ] ],
|
||||
'pairs pads with undef' );
|
||||
|
||||
{
|
||||
my @p = pairs one => 1, two => 2;
|
||||
is( $p[0]->key, "one", 'pairs ->key' );
|
||||
is( $p[0]->value, 1, 'pairs ->value' );
|
||||
is_deeply( $p[0]->TO_JSON,
|
||||
[ one => 1 ],
|
||||
'pairs ->TO_JSON' );
|
||||
is( ref($p[0]->TO_JSON), 'ARRAY', 'pairs ->TO_JSON is not blessed' );
|
||||
}
|
||||
|
||||
is_deeply( [ unpairs [ four => 4 ], [ five => 5 ], [ six => 6 ] ],
|
||||
[ four => 4, five => 5, six => 6 ],
|
||||
'unpairs' );
|
||||
|
||||
is_deeply( [ unpairs [ four => 4 ], [ five => ] ],
|
||||
[ four => 4, five => undef ],
|
||||
'unpairs with short item fills in undef' );
|
||||
|
||||
is_deeply( [ unpairs [ four => 4 ], [ five => 5, 5 ] ],
|
||||
[ four => 4, five => 5 ],
|
||||
'unpairs with long item truncates' );
|
||||
|
||||
is_deeply( [ pairkeys one => 1, two => 2 ],
|
||||
[qw( one two )],
|
||||
'pairkeys' );
|
||||
|
||||
is_deeply( [ pairvalues one => 1, two => 2 ],
|
||||
[ 1, 2 ],
|
||||
'pairvalues' );
|
||||
|
||||
# pairmap within pairmap
|
||||
{
|
||||
my @kvlist = (
|
||||
o1 => [ iA => 'A', iB => 'B' ],
|
||||
o2 => [ iC => 'C', iD => 'D' ],
|
||||
);
|
||||
|
||||
is_deeply( [ pairmap { pairmap { $b } @$b } @kvlist ],
|
||||
[ 'A', 'B', 'C', 'D', ],
|
||||
'pairmap within pairmap' );
|
||||
}
|
||||
|
|
@ -0,0 +1,135 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 27;
|
||||
|
||||
use Config;
|
||||
use List::Util qw(product);
|
||||
|
||||
my $v = product;
|
||||
is( $v, 1, 'no args');
|
||||
|
||||
$v = product(9);
|
||||
is( $v, 9, 'one arg');
|
||||
|
||||
$v = product(1,2,3,4);
|
||||
is( $v, 24, '4 args');
|
||||
|
||||
$v = product(-1);
|
||||
is( $v, -1, 'one -1');
|
||||
|
||||
$v = product(0, 1, 2);
|
||||
is( $v, 0, 'first factor zero' );
|
||||
|
||||
$v = product(0, 1);
|
||||
is( $v, 0, '0 * 1');
|
||||
|
||||
$v = product(1, 0);
|
||||
is( $v, 0, '1 * 0');
|
||||
|
||||
$v = product(0, 0);
|
||||
is( $v, 0, 'two 0');
|
||||
|
||||
# RT139601 cornercases
|
||||
{
|
||||
# Numify the result because some older perl versions see "-0" as a string
|
||||
is( 0+product(-1.0, 0), 0, 'product(-1.0, 0)' );
|
||||
is( 0+product(-1, 0), 0, 'product(-1, 0)' );
|
||||
}
|
||||
|
||||
my $x = -3;
|
||||
|
||||
$v = product($x, 3);
|
||||
is( $v, -9, 'variable arg');
|
||||
|
||||
$v = product(-3.5,3);
|
||||
is( $v, -10.5, 'real numbers');
|
||||
|
||||
my $one = Foo->new(1);
|
||||
my $two = Foo->new(2);
|
||||
my $four = Foo->new(4);
|
||||
|
||||
$v = product($one,$two,$four);
|
||||
is($v, 8, 'overload');
|
||||
|
||||
|
||||
{ package Foo;
|
||||
|
||||
use overload
|
||||
'""' => sub { ${$_[0]} },
|
||||
'0+' => sub { ${$_[0]} },
|
||||
fallback => 1;
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $value = shift;
|
||||
bless \$value, $class;
|
||||
}
|
||||
}
|
||||
|
||||
use Math::BigInt;
|
||||
my $v1 = Math::BigInt->new(2) ** Math::BigInt->new(65);
|
||||
my $v2 = $v1 - 1;
|
||||
$v = product($v1,$v2);
|
||||
is($v, $v1 * $v2, 'bigint');
|
||||
|
||||
$v = product(42, $v1);
|
||||
is($v, $v1 * 42, 'bigint + builtin int');
|
||||
|
||||
$v = product(42, $v1, 2);
|
||||
is($v, $v1 * 42 * 2, 'bigint + builtin int');
|
||||
|
||||
{ package example;
|
||||
|
||||
use overload
|
||||
'0+' => sub { $_[0][0] },
|
||||
'""' => sub { my $r = "$_[0][0]"; $r = "+$r" unless $r =~ m/^\-/; $r .= " [$_[0][1]]"; $r },
|
||||
fallback => 1;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
|
||||
my $this = bless [@_], $class;
|
||||
|
||||
return $this;
|
||||
}
|
||||
}
|
||||
|
||||
{
|
||||
my $e1 = example->new(7, "test");
|
||||
my $t = product($e1, 7, 7);
|
||||
is($t, 343, 'overload returning non-overload');
|
||||
$t = product(8, $e1, 8);
|
||||
is($t, 448, 'overload returning non-overload');
|
||||
$t = product(9, 9, $e1);
|
||||
is($t, 567, 'overload returning non-overload');
|
||||
}
|
||||
|
||||
SKIP: {
|
||||
skip "IV is not at least 64bit", 8 unless $Config{ivsize} >= 8;
|
||||
|
||||
my $t;
|
||||
my $min = -(1<<31);
|
||||
my $max = (1<<31)-1;
|
||||
|
||||
$t = product($min, $min);
|
||||
is($t, 1<<62, 'min * min');
|
||||
$t = product($min, $max);
|
||||
is($t, (1<<31) - (1<<62), 'min * max');
|
||||
$t = product($max, $min);
|
||||
is($t, (1<<31) - (1<<62), 'max * min');
|
||||
|
||||
$t = product($max, $max);
|
||||
is($t, 4611686014132420609, 'max * max'); # (1<<62)-(1<<32)+1), but Perl 5.6 does not compute constant correctly
|
||||
|
||||
$t = product($min*8, $min);
|
||||
cmp_ok($t, '>', (1<<61), 'min*8*min'); # may be an NV
|
||||
$t = product($min*8, $max);
|
||||
cmp_ok($t, '<', -(1<<61), 'min*8*max'); # may be an NV
|
||||
$t = product($max, $min*8);
|
||||
cmp_ok($t, '<', -(1<<61), 'min*max*8'); # may be an NV
|
||||
$t = product($max, $max*8);
|
||||
cmp_ok($t, '>', (1<<61), 'max*max*8'); # may be an NV
|
||||
|
||||
}
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Sub::Util qw( prototype set_prototype );
|
||||
use Test::More tests => 13;
|
||||
|
||||
sub f { }
|
||||
is( prototype('f'), undef, 'no prototype');
|
||||
is( CORE::prototype('f'), undef, 'no prototype from CORE');
|
||||
|
||||
my $r = set_prototype('$', \&f);
|
||||
is( prototype('f'), '$', 'prototype');
|
||||
is( CORE::prototype('f'), '$', 'prototype from CORE');
|
||||
is( $r, \&f, 'return value');
|
||||
|
||||
set_prototype(undef, \&f);
|
||||
is( prototype('f'), undef, 'remove prototype');
|
||||
|
||||
set_prototype('', \&f);
|
||||
is( prototype('f'), '', 'empty prototype');
|
||||
|
||||
sub g (@) { }
|
||||
is( prototype('g'), '@', '@ prototype');
|
||||
|
||||
set_prototype(undef, \&g);
|
||||
is( prototype('g'), undef, 'remove prototype');
|
||||
|
||||
sub stub;
|
||||
is( prototype('stub'), undef, 'non existing sub');
|
||||
|
||||
set_prototype('$$$', \&stub);
|
||||
is( prototype('stub'), '$$$', 'change non existing sub');
|
||||
|
||||
sub f_decl ($$$$);
|
||||
is( prototype('f_decl'), '$$$$', 'forward declaration');
|
||||
|
||||
set_prototype('\%', \&f_decl);
|
||||
is( prototype('f_decl'), '\%', 'change forward declaration');
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Scalar::Util qw(readonly);
|
||||
use Test::More tests => 11;
|
||||
|
||||
ok( readonly(1), 'number constant');
|
||||
|
||||
my $var = 2;
|
||||
|
||||
ok( !readonly($var), 'number variable');
|
||||
is( $var, 2, 'no change to number variable');
|
||||
|
||||
ok( readonly("fred"), 'string constant');
|
||||
|
||||
$var = "fred";
|
||||
|
||||
ok( !readonly($var), 'string variable');
|
||||
is( $var, 'fred', 'no change to string variable');
|
||||
|
||||
$var = \2;
|
||||
|
||||
ok( !readonly($var), 'reference to constant');
|
||||
ok( readonly($$var), 'de-reference to constant');
|
||||
|
||||
ok( !readonly(*STDOUT), 'glob');
|
||||
|
||||
sub try
|
||||
{
|
||||
my $v = \$_[0];
|
||||
return readonly $$v;
|
||||
}
|
||||
|
||||
$var = 123;
|
||||
{
|
||||
# This used not to work with ithreads, but seems to be working since 5.19.3
|
||||
local $TODO = ( $Config::Config{useithreads} && $] < 5.019003 ) ?
|
||||
"doesn't work with threads" : undef;
|
||||
ok( try ("abc"), 'reference a constant in a sub');
|
||||
}
|
||||
ok( !try ($var), 'reference a non-constant in a sub');
|
||||
|
|
@ -0,0 +1,167 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use List::Util qw(reduce min);
|
||||
use Test::More;
|
||||
plan tests => 33;
|
||||
|
||||
my $v = reduce {};
|
||||
|
||||
is( $v, undef, 'no args');
|
||||
|
||||
$v = reduce { $a / $b } 756,3,7,4;
|
||||
is( $v, 9, '4-arg divide');
|
||||
|
||||
$v = reduce { $a / $b } 6;
|
||||
is( $v, 6, 'one arg');
|
||||
|
||||
my @a = map { rand } 0 .. 20;
|
||||
$v = reduce { $a < $b ? $a : $b } @a;
|
||||
is( $v, min(@a), 'min');
|
||||
|
||||
@a = map { pack("C", int(rand(256))) } 0 .. 20;
|
||||
$v = reduce { $a . $b } @a;
|
||||
is( $v, join("",@a), 'concat');
|
||||
|
||||
sub add {
|
||||
my($aa, $bb) = @_;
|
||||
return $aa + $bb;
|
||||
}
|
||||
|
||||
$v = reduce { my $t="$a $b\n"; 0+add($a, $b) } 3, 2, 1;
|
||||
is( $v, 6, 'call sub');
|
||||
|
||||
# Check that eval{} inside the block works correctly
|
||||
$v = reduce { eval { die }; $a + $b } 0,1,2,3,4;
|
||||
is( $v, 10, 'use eval{}');
|
||||
|
||||
$v = !defined eval { reduce { die if $b > 2; $a + $b } 0,1,2,3,4 };
|
||||
ok($v, 'die');
|
||||
|
||||
sub foobar { reduce { (defined(wantarray) && !wantarray) ? $a+1 : 0 } 0,1,2,3 }
|
||||
($v) = foobar();
|
||||
is( $v, 3, 'scalar context');
|
||||
|
||||
sub add2 { $a + $b }
|
||||
|
||||
$v = reduce \&add2, 1,2,3;
|
||||
is( $v, 6, 'sub reference');
|
||||
|
||||
$v = reduce { add2() } 3,4,5;
|
||||
is( $v, 12, 'call sub');
|
||||
|
||||
|
||||
$v = reduce { eval "$a + $b" } 1,2,3;
|
||||
is( $v, 6, 'eval string');
|
||||
|
||||
$a = 8; $b = 9;
|
||||
$v = reduce { $a * $b } 1,2,3;
|
||||
is( $a, 8, 'restore $a');
|
||||
is( $b, 9, 'restore $b');
|
||||
|
||||
# Can we leave the sub with 'return'?
|
||||
$v = reduce {return $a+$b} 2,4,6;
|
||||
is($v, 12, 'return');
|
||||
|
||||
# ... even in a loop?
|
||||
$v = reduce {while(1) {return $a+$b} } 2,4,6;
|
||||
is($v, 12, 'return from loop');
|
||||
|
||||
# Does it work from another package?
|
||||
{ package Foo;
|
||||
$a = $b;
|
||||
::is((List::Util::reduce {$a*$b} (1..4)), 24, 'other package');
|
||||
}
|
||||
|
||||
# Can we undefine a reduce sub while it's running?
|
||||
sub self_immolate {undef &self_immolate; 1}
|
||||
eval { $v = reduce \&self_immolate, 1,2; };
|
||||
like($@, qr/^Can't undef active subroutine/, "undef active sub");
|
||||
|
||||
# Redefining an active sub should not fail, but whether the
|
||||
# redefinition takes effect immediately depends on whether we're
|
||||
# running the Perl or XS implementation.
|
||||
|
||||
sub self_updating {
|
||||
no warnings 'redefine';
|
||||
*self_updating = sub{1};
|
||||
1
|
||||
}
|
||||
eval { $v = reduce \&self_updating, 1,2; };
|
||||
is($@, '', 'redefine self');
|
||||
|
||||
{ my $failed = 0;
|
||||
|
||||
sub rec { my $n = shift;
|
||||
if (!defined($n)) { # No arg means we're being called by reduce()
|
||||
return 1; }
|
||||
if ($n<5) { rec($n+1); }
|
||||
else { $v = reduce \&rec, 1,2; }
|
||||
$failed = 1 if !defined $n;
|
||||
}
|
||||
|
||||
rec(1);
|
||||
ok(!$failed, 'from active sub');
|
||||
}
|
||||
|
||||
# Calling a sub from reduce should leave its refcount unchanged.
|
||||
SKIP: {
|
||||
skip("No Internals::SvREFCNT", 1) if !defined &Internals::SvREFCNT;
|
||||
sub mult {$a*$b}
|
||||
my $refcnt = &Internals::SvREFCNT(\&mult);
|
||||
$v = reduce \&mult, 1..6;
|
||||
is(&Internals::SvREFCNT(\&mult), $refcnt, "Refcount unchanged");
|
||||
}
|
||||
|
||||
{
|
||||
my $ok = 'failed';
|
||||
local $SIG{__DIE__} = sub { $ok = $_[0] =~ /Not a (subroutine|CODE) reference/ ? '' : $_[0] };
|
||||
eval { &reduce('foo',1,2) };
|
||||
is($ok, '', 'Not a subroutine reference');
|
||||
$ok = 'failed';
|
||||
eval { &reduce({},1,2) };
|
||||
is($ok, '', 'Not a subroutine reference');
|
||||
}
|
||||
|
||||
# These tests are only relevant for the real multicall implementation. The
|
||||
# pseudo-multicall implementation behaves differently.
|
||||
SKIP: {
|
||||
$List::Util::REAL_MULTICALL ||= 0; # Avoid use only once
|
||||
skip("Poor man's MULTICALL can't cope", 2)
|
||||
if !$List::Util::REAL_MULTICALL;
|
||||
|
||||
# Can we goto a label from the reduction sub?
|
||||
eval {()=reduce{goto foo} 1,2; foo: 1};
|
||||
like($@, qr/^Can't "goto" out of a pseudo block/, "goto label");
|
||||
|
||||
# Can we goto a subroutine?
|
||||
eval {()=reduce{goto sub{}} 1,2;};
|
||||
like($@, qr/^Can't goto subroutine from a sort sub/, "goto sub");
|
||||
}
|
||||
|
||||
{
|
||||
my @ret = reduce { $a + $b } 1 .. 5;
|
||||
is_deeply( \@ret, [ 15 ], 'reduce in list context yields only final answer' );
|
||||
}
|
||||
|
||||
# XSUB callback
|
||||
use constant XSUBC => 42;
|
||||
|
||||
is reduce(\&XSUBC, 1, 2, 3), 42, "xsub callbacks";
|
||||
|
||||
eval { &reduce(1) };
|
||||
ok($@ =~ /^Not a subroutine reference/, 'check for code reference');
|
||||
eval { &reduce(1,2) };
|
||||
ok($@ =~ /^Not a subroutine reference/, 'check for code reference');
|
||||
eval { &reduce(qw(a b)) };
|
||||
ok($@ =~ /^Not a subroutine reference/, 'check for code reference');
|
||||
eval { &reduce([],1,2,3) };
|
||||
ok($@ =~ /^Not a subroutine reference/, 'check for code reference');
|
||||
eval { &reduce(+{},1,2,3) };
|
||||
ok($@ =~ /^Not a subroutine reference/, 'check for code reference');
|
||||
|
||||
my @names = ("a\x{100}c", "d\x{101}efgh", 'ijk');
|
||||
my $longest = reduce { length($a) > length($b) ? $a : $b } @names;
|
||||
is( length($longest), 6, 'missing SMG rt#121992');
|
||||
|
|
@ -0,0 +1,51 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 7;
|
||||
|
||||
use List::Util qw( reductions );
|
||||
|
||||
is_deeply( [ reductions { } ], [],
|
||||
'empty list'
|
||||
);
|
||||
|
||||
is_deeply(
|
||||
[ reductions { $a + $b } 1 .. 5 ],
|
||||
[ 1, 3, 6, 10, 15 ],
|
||||
'sum 1..5'
|
||||
);
|
||||
|
||||
# We don't guarantee what this will return but it definitely shouldn't crash
|
||||
{
|
||||
my $ret = reductions { $a + $b } 1 .. 3;
|
||||
pass( 'reductions in scalar context does not crash' );
|
||||
}
|
||||
|
||||
my $destroyed_count;
|
||||
sub Guardian::DESTROY { $destroyed_count++ }
|
||||
|
||||
{
|
||||
undef $destroyed_count;
|
||||
|
||||
my @ret = reductions { $b } map { bless [], "Guardian" } 1 .. 5;
|
||||
|
||||
ok( !$destroyed_count, 'nothing destroyed yet' );
|
||||
|
||||
@ret = ();
|
||||
|
||||
is( $destroyed_count, 5, 'all the items were destroyed' );
|
||||
}
|
||||
|
||||
{
|
||||
undef $destroyed_count;
|
||||
|
||||
ok( !defined eval {
|
||||
reductions { die "stop" if $b == 4; bless [], "Guardian" } 1 .. 4;
|
||||
1
|
||||
}, 'die in BLOCK is propagated'
|
||||
);
|
||||
|
||||
is( $destroyed_count, 2, 'intermediate temporaries are destroyed after exception' );
|
||||
}
|
||||
|
|
@ -0,0 +1,106 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 32;
|
||||
|
||||
use Scalar::Util qw(refaddr);
|
||||
use vars qw(*F);
|
||||
use Symbol qw(gensym);
|
||||
|
||||
# Ensure we do not trigger and tied methods
|
||||
tie *F, 'MyTie';
|
||||
|
||||
my $i = 1;
|
||||
foreach my $v (undef, 10, 'string') {
|
||||
is(refaddr($v), undef, "not " . (defined($v) ? "'$v'" : "undef"));
|
||||
}
|
||||
|
||||
my $t;
|
||||
foreach my $r ({}, \$t, [], \*F, sub {}) {
|
||||
my $n = "$r";
|
||||
$n =~ /0x(\w+)/;
|
||||
my $addr = do { no warnings; hex $1 };
|
||||
my $before = ref($r);
|
||||
is( refaddr($r), $addr, $n);
|
||||
is( ref($r), $before, $n);
|
||||
|
||||
my $obj = bless $r, 'FooBar';
|
||||
is( refaddr($r), $addr, "blessed with overload $n");
|
||||
is( ref($r), 'FooBar', $n);
|
||||
}
|
||||
|
||||
{
|
||||
my $z = '77';
|
||||
my $y = \$z;
|
||||
my $a = '78';
|
||||
my $b = \$a;
|
||||
tie my %x, 'Hash3', {};
|
||||
$x{$y} = 22;
|
||||
$x{$b} = 23;
|
||||
my $xy = $x{$y};
|
||||
my $xb = $x{$b};
|
||||
ok(ref($x{$y}));
|
||||
ok(ref($x{$b}));
|
||||
ok(refaddr($xy) == refaddr($y));
|
||||
ok(refaddr($xb) == refaddr($b));
|
||||
ok(refaddr($x{$y}));
|
||||
ok(refaddr($x{$b}));
|
||||
}
|
||||
{
|
||||
my $z = bless {}, '0';
|
||||
ok(refaddr($z));
|
||||
{
|
||||
no strict 'refs';
|
||||
@{"0::ISA"} = qw(FooBar);
|
||||
}
|
||||
my $a = {};
|
||||
my $r = refaddr($a);
|
||||
$z = bless $a, '0';
|
||||
ok(refaddr($z) > 10);
|
||||
is(refaddr($z),$r,"foo");
|
||||
}
|
||||
|
||||
package FooBar;
|
||||
|
||||
use overload
|
||||
'0+' => sub { 10 },
|
||||
'+' => sub { 10 + $_[1] },
|
||||
'""' => sub { "10" };
|
||||
|
||||
package MyTie;
|
||||
|
||||
sub TIEHANDLE { bless {} }
|
||||
sub DESTROY {}
|
||||
|
||||
sub AUTOLOAD {
|
||||
our $AUTOLOAD;
|
||||
warn "$AUTOLOAD called";
|
||||
exit 1; # May be in an eval
|
||||
}
|
||||
|
||||
package Hash3;
|
||||
|
||||
use Scalar::Util qw(refaddr);
|
||||
|
||||
sub TIEHASH
|
||||
{
|
||||
my $pkg = shift;
|
||||
return bless [ @_ ], $pkg;
|
||||
}
|
||||
sub FETCH
|
||||
{
|
||||
my $self = shift;
|
||||
my $key = shift;
|
||||
my ($underlying) = @$self;
|
||||
return $underlying->{refaddr($key)};
|
||||
}
|
||||
sub STORE
|
||||
{
|
||||
my $self = shift;
|
||||
my $key = shift;
|
||||
my $value = shift;
|
||||
my ($underlying) = @$self;
|
||||
return ($underlying->{refaddr($key)} = $key);
|
||||
}
|
||||
|
|
@ -0,0 +1,57 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 32;
|
||||
|
||||
use Scalar::Util qw(reftype);
|
||||
use vars qw(*F);
|
||||
use Symbol qw(gensym);
|
||||
|
||||
# Ensure we do not trigger and tied methods
|
||||
tie *F, 'MyTie';
|
||||
my $RE = $] < 5.011 ? 'SCALAR' : 'REGEXP';
|
||||
|
||||
my $s = []; # SvTYPE($s) is SVt_RV, and SvROK($s) is true
|
||||
$s = undef; # SvTYPE($s) is SVt_RV, but SvROK($s) is false
|
||||
|
||||
my $t;
|
||||
my @test = (
|
||||
[ undef, 1, 'number' ],
|
||||
[ undef, 'A', 'string' ],
|
||||
[ HASH => {}, 'HASH ref' ],
|
||||
[ ARRAY => [], 'ARRAY ref' ],
|
||||
[ SCALAR => \$t, 'SCALAR ref' ],
|
||||
[ SCALAR => \$s, 'SCALAR ref (but SVt_RV)' ],
|
||||
[ REF => \(\$t), 'REF ref' ],
|
||||
[ GLOB => \*F, 'tied GLOB ref' ],
|
||||
[ GLOB => gensym, 'GLOB ref' ],
|
||||
[ CODE => sub {}, 'CODE ref' ],
|
||||
[ IO => *STDIN{IO}, 'IO ref' ],
|
||||
[ $RE => qr/x/, 'REGEEXP' ],
|
||||
);
|
||||
|
||||
foreach my $test (@test) {
|
||||
my($type,$what, $n) = @$test;
|
||||
|
||||
is( reftype($what), $type, $n);
|
||||
next unless ref($what);
|
||||
|
||||
bless $what, "ABC";
|
||||
is( reftype($what), $type, $n);
|
||||
|
||||
bless $what, "0";
|
||||
is( reftype($what), $type, $n);
|
||||
}
|
||||
|
||||
package MyTie;
|
||||
|
||||
sub TIEHANDLE { bless {} }
|
||||
sub DESTROY {}
|
||||
|
||||
sub AUTOLOAD {
|
||||
our $AUTOLOAD;
|
||||
warn "$AUTOLOAD called";
|
||||
exit 1; # May be in an eval
|
||||
}
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 2;
|
||||
|
||||
{
|
||||
use List::Util qw( first );
|
||||
|
||||
my $hash = {
|
||||
'HellO WorlD' => 1,
|
||||
};
|
||||
|
||||
is( ( first { 'hello world' eq lc($_) } keys %$hash ), "HellO WorlD",
|
||||
'first (lc$_) perserves value' );
|
||||
}
|
||||
|
||||
{
|
||||
use List::Util qw( any );
|
||||
|
||||
my $hash = {
|
||||
'HellO WorlD' => 1,
|
||||
};
|
||||
|
||||
my $var;
|
||||
|
||||
no warnings 'void';
|
||||
any { lc($_); $var = $_; } keys %$hash;
|
||||
|
||||
is( $var, 'HellO WorlD',
|
||||
'any (lc$_) leaves value undisturbed' );
|
||||
}
|
||||
|
|
@ -0,0 +1,73 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 9;
|
||||
|
||||
use List::Util qw(sample);
|
||||
|
||||
{
|
||||
my @items = sample 3, 1 .. 10;
|
||||
is( scalar @items, 3, 'returns correct count when plentiful' );
|
||||
|
||||
@items = sample 10, 1 .. 10;
|
||||
is( scalar @items, 10, 'returns correct count when exact' );
|
||||
|
||||
@items = sample 20, 1 .. 10;
|
||||
is( scalar @items, 10, 'returns correct count when short' );
|
||||
}
|
||||
|
||||
{
|
||||
my @items = sample 5, 1 .. 5;
|
||||
is_deeply( [ sort { $a <=> $b } @items ], [ 1 .. 5 ],
|
||||
'returns a permutation of the input list when exact' );
|
||||
}
|
||||
|
||||
{
|
||||
# These two seeds happen to give different results for me, but there is the
|
||||
# smallest 1-in-2**48 chance that they happen to agree on some platform. If
|
||||
# so then pick a different seed value.
|
||||
|
||||
srand 1234;
|
||||
my $x = join "", sample 3, 'a'..'z';
|
||||
|
||||
srand 5678;
|
||||
my $y = join "", sample 3, 'a'..'z';
|
||||
|
||||
isnt( $x, $y, 'returns different result on different random seed' );
|
||||
|
||||
srand;
|
||||
}
|
||||
|
||||
{
|
||||
my @nums = ( 1..5 );
|
||||
sample 5, @nums;
|
||||
|
||||
is_deeply( \@nums, [ 1..5 ],
|
||||
'sample does not mutate passed array'
|
||||
);
|
||||
}
|
||||
|
||||
{
|
||||
my $destroyed_count;
|
||||
sub Guardian::DESTROY { $destroyed_count++ }
|
||||
|
||||
my @ret = sample 3, map { bless [], "Guardian" } 1 .. 10;
|
||||
|
||||
is( $destroyed_count, 7, 'the 7 unselected items were destroyed' );
|
||||
|
||||
@ret = ();
|
||||
|
||||
is( $destroyed_count, 10, 'all the items were destroyed' );
|
||||
}
|
||||
|
||||
{
|
||||
local $List::Util::RAND = sub { 4/10 };
|
||||
|
||||
is(
|
||||
join( "", sample 5, 'A'..'Z' ),
|
||||
join( "", sample 5, 'A'..'Z' ),
|
||||
'rigged rand() yields predictable output'
|
||||
);
|
||||
}
|
||||
|
|
@ -0,0 +1,70 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Scalar::Util ();
|
||||
use Test::More (grep { /set_prototype/ } @Scalar::Util::EXPORT_FAIL)
|
||||
? (skip_all => 'set_prototype requires XS version')
|
||||
: (tests => 14);
|
||||
|
||||
Scalar::Util->import('set_prototype');
|
||||
|
||||
sub f { }
|
||||
is( prototype('f'), undef, 'no prototype');
|
||||
|
||||
my $r = set_prototype(\&f,'$');
|
||||
is( prototype('f'), '$', 'set prototype');
|
||||
is( $r, \&f, 'return value');
|
||||
|
||||
set_prototype(\&f,undef);
|
||||
is( prototype('f'), undef, 'remove prototype');
|
||||
|
||||
set_prototype(\&f,'');
|
||||
is( prototype('f'), '', 'empty prototype');
|
||||
|
||||
sub g (@) { }
|
||||
is( prototype('g'), '@', '@ prototype');
|
||||
|
||||
set_prototype(\&g,undef);
|
||||
is( prototype('g'), undef, 'remove prototype');
|
||||
|
||||
sub stub;
|
||||
is( prototype('stub'), undef, 'non existing sub');
|
||||
|
||||
set_prototype(\&stub,'$$$');
|
||||
is( prototype('stub'), '$$$', 'change non existing sub');
|
||||
|
||||
sub f_decl ($$$$);
|
||||
is( prototype('f_decl'), '$$$$', 'forward declaration');
|
||||
|
||||
set_prototype(\&f_decl,'\%');
|
||||
is( prototype('f_decl'), '\%', 'change forward declaration');
|
||||
|
||||
eval { &set_prototype( 'f', '' ); };
|
||||
print "not " unless
|
||||
ok($@ =~ /^set_prototype: not a reference/, 'not a reference');
|
||||
|
||||
eval { &set_prototype( \'f', '' ); };
|
||||
ok($@ =~ /^set_prototype: not a subroutine reference/, 'not a sub reference');
|
||||
|
||||
# RT 72080
|
||||
|
||||
{
|
||||
package TiedCV;
|
||||
sub TIESCALAR {
|
||||
my $class = shift;
|
||||
return bless {@_}, $class;
|
||||
}
|
||||
sub FETCH {
|
||||
return \&my_subr;
|
||||
}
|
||||
sub my_subr {
|
||||
}
|
||||
}
|
||||
|
||||
my $cv;
|
||||
tie $cv, 'TiedCV';
|
||||
|
||||
&Scalar::Util::set_prototype($cv, '$$');
|
||||
is( prototype($cv), '$$', 'set_prototype() on tied CV ref' );
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 7;
|
||||
|
||||
use List::Util qw(shuffle);
|
||||
|
||||
my @r;
|
||||
|
||||
@r = shuffle();
|
||||
ok( !@r, 'no args');
|
||||
|
||||
@r = shuffle(9);
|
||||
is( 0+@r, 1, '1 in 1 out');
|
||||
is( $r[0], 9, 'one arg');
|
||||
|
||||
my @in = 1..100;
|
||||
@r = shuffle(@in);
|
||||
is( 0+@r, 0+@in, 'arg count');
|
||||
|
||||
isnt( "@r", "@in", 'result different to args');
|
||||
|
||||
my @s = sort { $a <=> $b } @r;
|
||||
is( "@in", "@s", 'values');
|
||||
|
||||
{
|
||||
local $List::Util::RAND = sub { 4/10 }; # chosen by a fair die
|
||||
|
||||
@r = shuffle(1..10);
|
||||
is_deeply(
|
||||
[ shuffle(1..10) ],
|
||||
[ shuffle(1..10) ],
|
||||
'rigged rand() yields predictable output'
|
||||
);
|
||||
}
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
#!./perl
|
||||
|
||||
BEGIN {
|
||||
if ($] eq "5.008009" or $] eq "5.010000" or $] le "5.006002") {
|
||||
print "1..0 # Skip: known to fail on $]\n";
|
||||
exit 0;
|
||||
}
|
||||
}
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use List::Util qw(reduce);
|
||||
use Test::More tests => 1;
|
||||
|
||||
my $ret = "original";
|
||||
$ret = $ret . broken();
|
||||
is($ret, "originalreturn");
|
||||
|
||||
sub broken {
|
||||
reduce { return "bogus"; } qw/some thing/;
|
||||
return "return";
|
||||
}
|
||||
|
|
@ -0,0 +1,96 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
|
||||
BEGIN { $^P |= 0x210 }
|
||||
|
||||
use Test::More tests => 21;
|
||||
|
||||
use B::Deparse;
|
||||
use Sub::Util qw( subname set_subname );
|
||||
use Symbol qw( delete_package ) ;
|
||||
|
||||
{
|
||||
sub localfunc {}
|
||||
sub fully::qualified::func {}
|
||||
|
||||
is(subname(\&subname), "Sub::Util::subname",
|
||||
'subname of \&subname');
|
||||
is(subname(\&localfunc), "main::localfunc",
|
||||
'subname of \&localfunc');
|
||||
is(subname(\&fully::qualified::func), "fully::qualified::func",
|
||||
'subname of \&fully::qualfied::func');
|
||||
|
||||
# Because of the $^P debug flag, we'll get [file:line] as well
|
||||
like(subname(sub {}), qr/^main::__ANON__\[.+:\d+\]$/, 'subname of anon sub');
|
||||
|
||||
ok(!eval { subname([]) }, 'subname [] dies');
|
||||
}
|
||||
|
||||
my $x = set_subname foo => sub { (caller 0)[3] };
|
||||
my $line = __LINE__ - 1;
|
||||
my $file = __FILE__;
|
||||
my $anon = $DB::sub{"main::__ANON__[${file}:${line}]"};
|
||||
|
||||
is($x->(), "main::foo");
|
||||
|
||||
{
|
||||
package Blork;
|
||||
|
||||
use Sub::Util qw( set_subname );
|
||||
|
||||
set_subname " Bar!", $x;
|
||||
::is($x->(), "Blork:: Bar!");
|
||||
|
||||
set_subname "Foo::Bar::Baz", $x;
|
||||
::is($x->(), "Foo::Bar::Baz");
|
||||
|
||||
set_subname "set_subname (dynamic $_)", \&set_subname for 1 .. 3;
|
||||
|
||||
for (4 .. 5) {
|
||||
set_subname "Dynamic $_", $x;
|
||||
::is($x->(), "Blork::Dynamic $_");
|
||||
}
|
||||
|
||||
::is($DB::sub{"main::foo"}, $anon);
|
||||
|
||||
for (4 .. 5) {
|
||||
::is($DB::sub{"Blork::Dynamic $_"}, $anon);
|
||||
}
|
||||
|
||||
for ("Blork:: Bar!", "Foo::Bar::Baz") {
|
||||
::is($DB::sub{$_}, $anon);
|
||||
}
|
||||
}
|
||||
|
||||
# RT42725
|
||||
{
|
||||
my $source = eval {
|
||||
B::Deparse->new->coderef2text(set_subname foo => sub{ @_ });
|
||||
};
|
||||
|
||||
ok !$@;
|
||||
|
||||
like $source, qr/\@\_/;
|
||||
}
|
||||
|
||||
# subname of set_subname
|
||||
{
|
||||
is(subname(set_subname "my-scary-name-here", sub {}), "main::my-scary-name-here",
|
||||
'subname of set_subname');
|
||||
}
|
||||
|
||||
# this used to segfault
|
||||
|
||||
{
|
||||
sub ToDelete::foo {}
|
||||
|
||||
my $foo = \&ToDelete::foo;
|
||||
|
||||
delete_package 'ToDelete';
|
||||
|
||||
is( subname($foo), "$]" >= 5.010 ? '__ANON__::foo' : 'ToDelete::foo', 'subname in deleted package' );
|
||||
ok( set_subname('NewPackage::foo', $foo), 'rename from deleted package' );
|
||||
is( subname($foo), 'NewPackage::foo', 'subname after rename' );
|
||||
}
|
||||
|
||||
# vim: ft=perl
|
||||
|
|
@ -0,0 +1,113 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 18;
|
||||
|
||||
use Config;
|
||||
use List::Util qw(sum);
|
||||
|
||||
my $v = sum;
|
||||
is( $v, undef, 'no args');
|
||||
|
||||
$v = sum(9);
|
||||
is( $v, 9, 'one arg');
|
||||
|
||||
$v = sum(1,2,3,4);
|
||||
is( $v, 10, '4 args');
|
||||
|
||||
$v = sum(-1);
|
||||
is( $v, -1, 'one -1');
|
||||
|
||||
my $x = -3;
|
||||
|
||||
$v = sum($x, 3);
|
||||
is( $v, 0, 'variable arg');
|
||||
|
||||
$v = sum(-3.5,3);
|
||||
is( $v, -0.5, 'real numbers');
|
||||
|
||||
$v = sum(3,-3.5);
|
||||
is( $v, -0.5, 'initial integer, then real');
|
||||
|
||||
my $one = Foo->new(1);
|
||||
my $two = Foo->new(2);
|
||||
my $thr = Foo->new(3);
|
||||
|
||||
$v = sum($one,$two,$thr);
|
||||
is($v, 6, 'overload');
|
||||
|
||||
|
||||
{ package Foo;
|
||||
|
||||
use overload
|
||||
'""' => sub { ${$_[0]} },
|
||||
'0+' => sub { ${$_[0]} },
|
||||
fallback => 1;
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $value = shift;
|
||||
bless \$value, $class;
|
||||
}
|
||||
}
|
||||
|
||||
use Math::BigInt;
|
||||
my $v1 = Math::BigInt->new(2) ** Math::BigInt->new(65);
|
||||
my $v2 = $v1 - 1;
|
||||
$v = sum($v1,$v2);
|
||||
is($v, $v1 + $v2, 'bigint');
|
||||
|
||||
$v = sum(42, $v1);
|
||||
is($v, $v1 + 42, 'bigint + builtin int');
|
||||
|
||||
$v = sum(42, $v1, 2);
|
||||
is($v, $v1 + 42 + 2, 'bigint + builtin int');
|
||||
|
||||
{ package example;
|
||||
|
||||
use overload
|
||||
'0+' => sub { $_[0][0] },
|
||||
'""' => sub { my $r = "$_[0][0]"; $r = "+$r" unless $r =~ m/^\-/; $r .= " [$_[0][1]]"; $r },
|
||||
fallback => 1;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
|
||||
my $this = bless [@_], $class;
|
||||
|
||||
return $this;
|
||||
}
|
||||
}
|
||||
|
||||
{
|
||||
my $e1 = example->new(7, "test");
|
||||
my $t = sum($e1, 7, 7);
|
||||
is($t, 21, 'overload returning non-overload');
|
||||
$t = sum(8, $e1, 8);
|
||||
is($t, 23, 'overload returning non-overload');
|
||||
$t = sum(9, 9, $e1);
|
||||
is($t, 25, 'overload returning non-overload');
|
||||
}
|
||||
|
||||
SKIP: {
|
||||
skip "IV is not at least 64bit", 4 unless $Config{ivsize} >= 8;
|
||||
|
||||
# Sum using NV will only preserve 53 bits of integer precision
|
||||
my $t = sum(1152921504606846976, 1); # 1<<60, but Perl 5.6 does not compute constant correctly
|
||||
cmp_ok($t, 'gt', 1152921504606846976, 'sum uses IV where it can'); # string comparison because Perl 5.6 does not compare it numerically correctly
|
||||
|
||||
SKIP: {
|
||||
skip "known to fail on $]", 1 if $] le "5.006002";
|
||||
$t = sum(1<<60, 1);
|
||||
cmp_ok($t, '>', 1<<60, 'sum uses IV where it can');
|
||||
}
|
||||
|
||||
my $min = -(1<<63);
|
||||
my $max = 9223372036854775807; # (1<<63)-1, but Perl 5.6 does not compute constant correctly
|
||||
|
||||
$t = sum($min, $max);
|
||||
is($t, -1, 'min + max');
|
||||
$t = sum($max, $min);
|
||||
is($t, -1, 'max + min');
|
||||
}
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 3;
|
||||
|
||||
use List::Util qw( sum0 );
|
||||
|
||||
my $v = sum0;
|
||||
is( $v, 0, 'no args' );
|
||||
|
||||
$v = sum0(9);
|
||||
is( $v, 9, 'one arg' );
|
||||
|
||||
$v = sum0(1,2,3,4);
|
||||
is( $v, 10, '4 args');
|
||||
|
|
@ -0,0 +1,36 @@
|
|||
#!./perl -T
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Config;
|
||||
use Test::More;
|
||||
use Scalar::Util qw(tainted);
|
||||
|
||||
if (exists($Config{taint_support}) && not $Config{taint_support}) {
|
||||
plan skip_all => "your perl was built without taint support";
|
||||
}
|
||||
else {
|
||||
plan tests => 5;
|
||||
}
|
||||
|
||||
|
||||
ok( !tainted(1), 'constant number');
|
||||
|
||||
my $var = 2;
|
||||
|
||||
ok( !tainted($var), 'known variable');
|
||||
|
||||
ok( tainted($^X), 'interpreter variable');
|
||||
|
||||
$var = $^X;
|
||||
ok( tainted($var), 'copy of interpreter variable');
|
||||
|
||||
{
|
||||
package Tainted;
|
||||
sub TIESCALAR { bless {} }
|
||||
sub FETCH { $^X }
|
||||
}
|
||||
|
||||
tie my $tiedvar, 'Tainted';
|
||||
ok( tainted($tiedvar), 'for magic variables');
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
my @subs;
|
||||
BEGIN { @subs = qw(reduce first none all any notall pairfirst pairgrep pairmap) };
|
||||
use List::Util @subs;
|
||||
use Test::More;
|
||||
plan tests => @subs * 2;
|
||||
|
||||
for my $sub (@subs) {
|
||||
eval { no strict 'refs'; no warnings 'uninitialized'; &{$sub}(undef, 1, 2) };
|
||||
like($@, qr{^Not a subroutine reference}, "$sub(undef, ...) croaks");
|
||||
|
||||
eval { no strict 'refs'; &{$sub}(\&undefined, 1, 2) };
|
||||
like($@, qr{^Undefined subroutine in $sub}, "$sub(\&undefined, ...) croaks");
|
||||
}
|
||||
|
|
@ -0,0 +1,219 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Config; # to determine ivsize
|
||||
use Test::More tests => 31;
|
||||
use List::Util qw( uniqstr uniqint uniq );
|
||||
|
||||
use Tie::Array;
|
||||
|
||||
is_deeply( [ uniqstr ],
|
||||
[],
|
||||
'uniqstr of empty list' );
|
||||
|
||||
is_deeply( [ uniqstr qw( abc ) ],
|
||||
[qw( abc )],
|
||||
'uniqstr of singleton list' );
|
||||
|
||||
is_deeply( [ uniqstr qw( x x x ) ],
|
||||
[qw( x )],
|
||||
'uniqstr of repeated-element list' );
|
||||
|
||||
is_deeply( [ uniqstr qw( a b a c ) ],
|
||||
[qw( a b c )],
|
||||
'uniqstr removes subsequent duplicates' );
|
||||
|
||||
is_deeply( [ uniqstr qw( 1 1.0 1E0 ) ],
|
||||
[qw( 1 1.0 1E0 )],
|
||||
'uniqstr compares strings' );
|
||||
|
||||
{
|
||||
my $warnings = "";
|
||||
local $SIG{__WARN__} = sub { $warnings .= join "", @_ };
|
||||
|
||||
is_deeply( [ uniqstr "", undef ],
|
||||
[ "" ],
|
||||
'uniqstr considers undef and empty-string equivalent' );
|
||||
|
||||
ok( length $warnings, 'uniqstr on undef yields a warning' );
|
||||
|
||||
is_deeply( [ uniqstr undef ],
|
||||
[ "" ],
|
||||
'uniqstr on undef coerces to empty-string' );
|
||||
}
|
||||
|
||||
SKIP: {
|
||||
skip 'Perl 5.007003 with utf8::encode is required', 3 if $] lt "5.007003";
|
||||
my $warnings = "";
|
||||
local $SIG{__WARN__} = sub { $warnings .= join "", @_ };
|
||||
|
||||
my $cafe = "cafe\x{301}";
|
||||
|
||||
is_deeply( [ uniqstr $cafe ],
|
||||
[ $cafe ],
|
||||
'uniqstr is happy with Unicode strings' );
|
||||
|
||||
SKIP: {
|
||||
skip "utf8::encode not available", 1
|
||||
unless defined &utf8::encode;
|
||||
utf8::encode( my $cafebytes = $cafe );
|
||||
|
||||
is_deeply( [ uniqstr $cafe, $cafebytes ],
|
||||
[ $cafe, $cafebytes ],
|
||||
'uniqstr does not squash bytewise-equal but differently-encoded strings' );
|
||||
}
|
||||
|
||||
is( $warnings, "", 'No warnings are printed when handling Unicode strings' );
|
||||
}
|
||||
|
||||
is_deeply( [ uniqint ],
|
||||
[],
|
||||
'uniqint of empty list' );
|
||||
|
||||
is_deeply( [ uniqint 5, 5 ],
|
||||
[ 5 ],
|
||||
'uniqint of repeated-element list' );
|
||||
|
||||
is_deeply( [ uniqint 1, 2, 1, 3 ],
|
||||
[ 1, 2, 3 ],
|
||||
'uniqint removes subsequent duplicates' );
|
||||
|
||||
is_deeply( [ uniqint 6.1, 6.2, 6.3 ],
|
||||
[ 6 ],
|
||||
'uniqint compares as and returns integers' );
|
||||
|
||||
{
|
||||
my $warnings = "";
|
||||
local $SIG{__WARN__} = sub { $warnings .= join "", @_ };
|
||||
|
||||
is_deeply( [ uniqint 0, undef ],
|
||||
[ 0 ],
|
||||
'uniqint considers undef and zero equivalent' );
|
||||
|
||||
ok( length $warnings, 'uniqint on undef yields a warning' );
|
||||
|
||||
is_deeply( [ uniqint undef ],
|
||||
[ 0 ],
|
||||
'uniqint on undef coerces to zero' );
|
||||
}
|
||||
|
||||
SKIP: {
|
||||
skip('UVs are not reliable on this perl version', 2) unless $] ge "5.008000";
|
||||
|
||||
my $maxbits = $Config{ivsize} * 8 - 1;
|
||||
|
||||
# An integer guaranteed to be a UV
|
||||
my $uv = 1 << $maxbits;
|
||||
is_deeply( [ uniqint $uv, $uv + 1 ],
|
||||
[ $uv, $uv + 1 ],
|
||||
'uniqint copes with UVs' );
|
||||
|
||||
my $nvuv = 2 ** $maxbits;
|
||||
is_deeply( [ uniqint $nvuv, 0 ],
|
||||
[ int($nvuv), 0 ],
|
||||
'uniqint copes with NVUV dualvars' );
|
||||
}
|
||||
|
||||
is_deeply( [ uniq () ],
|
||||
[],
|
||||
'uniq of empty list' );
|
||||
|
||||
{
|
||||
my $warnings = "";
|
||||
local $SIG{__WARN__} = sub { $warnings .= join "", @_ };
|
||||
|
||||
is_deeply( [ uniq "", undef ],
|
||||
[ "", undef ],
|
||||
'uniq distintinguishes empty-string from undef' );
|
||||
|
||||
is_deeply( [ uniq undef, undef ],
|
||||
[ undef ],
|
||||
'uniq considers duplicate undefs as identical' );
|
||||
|
||||
ok( !length $warnings, 'uniq on undef does not warn' );
|
||||
}
|
||||
|
||||
is( scalar( uniqstr qw( a b c d a b e ) ), 5, 'uniqstr() in scalar context' );
|
||||
|
||||
{
|
||||
package Stringify;
|
||||
|
||||
use overload '""' => sub { return $_[0]->{str} };
|
||||
|
||||
sub new { bless { str => $_[1] }, $_[0] }
|
||||
|
||||
package main;
|
||||
|
||||
my @strs = map { Stringify->new( $_ ) } qw( foo foo bar );
|
||||
|
||||
is_deeply( [ map "$_", uniqstr @strs ],
|
||||
[ map "$_", $strs[0], $strs[2] ],
|
||||
'uniqstr respects stringify overload' );
|
||||
}
|
||||
|
||||
SKIP: {
|
||||
skip('int overload requires perl version 5.8.0', 1) unless $] ge "5.008000";
|
||||
|
||||
package Googol;
|
||||
|
||||
use overload '""' => sub { "1" . ( "0"x100 ) },
|
||||
'int' => sub { $_[0] },
|
||||
fallback => 1;
|
||||
|
||||
sub new { bless {}, $_[0] }
|
||||
|
||||
package main;
|
||||
|
||||
is_deeply( [ uniqint( Googol->new, Googol->new ) ],
|
||||
[ "1" . ( "0"x100 ) ],
|
||||
'uniqint respects int overload' );
|
||||
}
|
||||
|
||||
{
|
||||
package DestroyNotifier;
|
||||
|
||||
use overload '""' => sub { "SAME" };
|
||||
|
||||
sub new { bless { var => $_[1] }, $_[0] }
|
||||
|
||||
sub DESTROY { ${ $_[0]->{var} }++ }
|
||||
|
||||
package main;
|
||||
|
||||
my @destroyed = (0) x 3;
|
||||
my @notifiers = map { DestroyNotifier->new( \$destroyed[$_] ) } 0 .. 2;
|
||||
|
||||
my @uniqstr = uniqstr @notifiers;
|
||||
undef @notifiers;
|
||||
|
||||
is_deeply( \@destroyed, [ 0, 1, 1 ],
|
||||
'values filtered by uniqstr() are destroyed' );
|
||||
|
||||
undef @uniqstr;
|
||||
is_deeply( \@destroyed, [ 1, 1, 1 ],
|
||||
'all values destroyed' );
|
||||
}
|
||||
|
||||
{
|
||||
"a a b" =~ m/(.) (.) (.)/;
|
||||
is_deeply( [ uniqstr $1, $2, $3 ],
|
||||
[qw( a b )],
|
||||
'uniqstr handles magic' );
|
||||
}
|
||||
|
||||
{
|
||||
my @array;
|
||||
tie @array, 'Tie::StdArray';
|
||||
@array = (
|
||||
( map { ( 1 .. 10 ) } 0 .. 1 ),
|
||||
( map { ( 'a' .. 'z' ) } 0 .. 1 )
|
||||
);
|
||||
|
||||
my @u = uniq @array;
|
||||
is_deeply(
|
||||
\@u,
|
||||
[ 1 .. 10, 'a' .. 'z' ],
|
||||
'uniq uniquifies mixed numbers and strings correctly in a tied array'
|
||||
);
|
||||
}
|
||||
|
|
@ -0,0 +1,329 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Config; # to determine nvsize
|
||||
use Test::More tests => 23;
|
||||
use List::Util qw( uniqnum );
|
||||
|
||||
is_deeply( [ uniqnum qw( 1 1.0 1E0 2 3 ) ],
|
||||
[ 1, 2, 3 ],
|
||||
'uniqnum compares numbers' );
|
||||
|
||||
is_deeply( [ uniqnum qw( 1 1.1 1.2 1.3 ) ],
|
||||
[ 1, 1.1, 1.2, 1.3 ],
|
||||
'uniqnum distinguishes floats' );
|
||||
|
||||
{
|
||||
my @nums = map $_+0.1, 1e7..1e7+5;
|
||||
is_deeply( [ uniqnum @nums ],
|
||||
[ @nums ],
|
||||
'uniqnum distinguishes large floats' );
|
||||
|
||||
my @strings = map "$_", @nums;
|
||||
is_deeply( [ uniqnum @strings ],
|
||||
[ @strings ],
|
||||
'uniqnum distinguishes large floats (stringified)' );
|
||||
}
|
||||
|
||||
my ($uniq_count1, $uniq_count2, $equiv);
|
||||
|
||||
if($Config{nvsize} == 8) {
|
||||
# NV is either 'double' or 8-byte 'long double'
|
||||
|
||||
# The 2 values should be unequal - but just in case perl is buggy:
|
||||
$equiv = 1 if 1.4142135623730951 == 1.4142135623730954;
|
||||
|
||||
$uniq_count1 = uniqnum (1.4142135623730951,
|
||||
1.4142135623730954 );
|
||||
|
||||
$uniq_count2 = uniqnum('1.4142135623730951',
|
||||
'1.4142135623730954' );
|
||||
}
|
||||
|
||||
elsif(length(sqrt(2)) > 25) {
|
||||
# NV is either IEEE 'long double' or '__float128' or doubledouble
|
||||
|
||||
if(1 + (2 ** -1074) != 1) {
|
||||
# NV is doubledouble
|
||||
|
||||
# The 2 values should be unequal - but just in case perl is buggy:
|
||||
$equiv = 1 if 1 + (2 ** -1074) == 1 + (2 ** - 1073);
|
||||
|
||||
$uniq_count1 = uniqnum (1 + (2 ** -1074),
|
||||
1 + (2 ** -1073) );
|
||||
# The 2 values should be unequal - but just in case perl is buggy:
|
||||
$equiv = 1 if 4.0564819207303340847894502572035e31 == 4.0564819207303340847894502572034e31;
|
||||
|
||||
$uniq_count2 = uniqnum('4.0564819207303340847894502572035e31',
|
||||
'4.0564819207303340847894502572034e31' );
|
||||
}
|
||||
|
||||
else {
|
||||
# NV is either IEEE 'long double' or '__float128'
|
||||
|
||||
# The 2 values should be unequal - but just in case perl is buggy:
|
||||
$equiv = 1 if 1005.10228292019306452029161597769015 == 1005.1022829201930645202916159776901;
|
||||
|
||||
$uniq_count1 = uniqnum (1005.10228292019306452029161597769015,
|
||||
1005.1022829201930645202916159776901 );
|
||||
|
||||
$uniq_count2 = uniqnum('1005.10228292019306452029161597769015',
|
||||
'1005.1022829201930645202916159776901' );
|
||||
}
|
||||
}
|
||||
|
||||
else {
|
||||
# NV is extended precision 'long double'
|
||||
|
||||
# The 2 values should be unequal - but just in case perl is buggy:
|
||||
$equiv = 1 if 10.770329614269008063 == 10.7703296142690080625;
|
||||
|
||||
$uniq_count1 = uniqnum (10.770329614269008063,
|
||||
10.7703296142690080625 );
|
||||
|
||||
$uniq_count2 = uniqnum('10.770329614269008063',
|
||||
'10.7703296142690080625' );
|
||||
}
|
||||
|
||||
if($equiv) {
|
||||
is($uniq_count1, 1, 'uniqnum preserves uniqueness of high precision floats');
|
||||
is($uniq_count2, 1, 'uniqnum preserves uniqueness of high precision floats (stringified)');
|
||||
}
|
||||
|
||||
else {
|
||||
is($uniq_count1, 2, 'uniqnum preserves uniqueness of high precision floats');
|
||||
is($uniq_count2, 2, 'uniqnum preserves uniqueness of high precision floats (stringified)');
|
||||
}
|
||||
|
||||
SKIP: {
|
||||
skip ('test not relevant for this perl configuration', 1) unless $Config{nvsize} == 8
|
||||
&& $Config{ivsize} == 8;
|
||||
|
||||
my @in = (~0, ~0 - 1, 18446744073709551614.0, 18014398509481985, 1.8014398509481985e16);
|
||||
my(@correct);
|
||||
|
||||
# On perl-5.6.2 (and perhaps other old versions), ~0 - 1 is assigned to an NV.
|
||||
# This affects the outcome of the following test, so we need to first determine
|
||||
# whether ~0 - 1 is an NV or a UV:
|
||||
|
||||
if("$in[1]" eq "1.84467440737096e+19") {
|
||||
|
||||
# It's an NV and $in[2] is a duplicate of $in[1]
|
||||
@correct = (~0, ~0 - 1, 18014398509481985, 1.8014398509481985e16);
|
||||
}
|
||||
else {
|
||||
|
||||
# No duplicates in @in
|
||||
@correct = @in;
|
||||
}
|
||||
|
||||
is_deeply( [ uniqnum @in ],
|
||||
[ @correct ],
|
||||
'uniqnum correctly compares UV/IVs that overflow NVs' );
|
||||
}
|
||||
|
||||
my $ls = 31; # maximum left shift for 32-bit unity
|
||||
|
||||
if( $Config{ivsize} == 8 ) {
|
||||
$ls = 63; # maximum left shift for 64-bit unity
|
||||
}
|
||||
|
||||
# Populate @in with UV-NV pairs of equivalent values.
|
||||
# Each of these values is exactly representable as
|
||||
# either a UV or an NV.
|
||||
|
||||
my @in = (1 << $ls, 2 ** $ls,
|
||||
1 << ($ls - 3), 2 ** ($ls - 3),
|
||||
5 << ($ls - 3), 5 * (2 ** ($ls - 3)));
|
||||
|
||||
my @correct = (1 << $ls, 1 << ($ls - 3), 5 << ($ls -3));
|
||||
|
||||
if( $Config{ivsize} == 8 && $Config{nvsize} == 8 ) {
|
||||
|
||||
# Add some more UV-NV pairs of equivalent values.
|
||||
# Each of these values is exactly representable
|
||||
# as either a UV or an NV.
|
||||
|
||||
push @in, ( 9007199254740991, 9.007199254740991e+15,
|
||||
9007199254740992, 9.007199254740992e+15,
|
||||
9223372036854774784, 9.223372036854774784e+18,
|
||||
18446744073709549568, 1.8446744073709549568e+19,
|
||||
18446744073709139968, 1.8446744073709139968e+19,
|
||||
100000000000262144, 1.00000000000262144e+17,
|
||||
100000000001310720, 1.0000000000131072e+17,
|
||||
144115188075593728, 1.44115188075593728e+17,
|
||||
-9007199254740991, -9.007199254740991e+15,
|
||||
-9007199254740992, -9.007199254740992e+15,
|
||||
-9223372036854774784, -9.223372036854774784e+18,
|
||||
-18446744073709549568, -1.8446744073709549568e+19,
|
||||
-18446744073709139968, -1.8446744073709139968e+19,
|
||||
-100000000000262144, -1.00000000000262144e+17,
|
||||
-100000000001310720, -1.0000000000131072e+17,
|
||||
-144115188075593728, -1.44115188075593728e+17 );
|
||||
|
||||
push @correct, ( 9007199254740991,
|
||||
9007199254740992,
|
||||
9223372036854774784,
|
||||
18446744073709549568,
|
||||
18446744073709139968,
|
||||
100000000000262144,
|
||||
100000000001310720,
|
||||
144115188075593728,
|
||||
-9007199254740991,
|
||||
-9007199254740992,
|
||||
-9223372036854774784,
|
||||
-18446744073709549568,
|
||||
-18446744073709139968,
|
||||
-100000000000262144,
|
||||
-100000000001310720,
|
||||
-144115188075593728 );
|
||||
}
|
||||
|
||||
# uniqnum should discard each of the NVs as being a
|
||||
# duplicate of the preceding UV.
|
||||
|
||||
is_deeply( [ uniqnum @in],
|
||||
[ @correct],
|
||||
'uniqnum correctly compares UV/IVs that don\'t overflow NVs' );
|
||||
|
||||
# Hard to know for sure what an Inf is going to be. Lets make one
|
||||
my $Inf = 0 + 1E1000;
|
||||
my $NaN;
|
||||
$Inf **= 1000 while ( $NaN = $Inf - $Inf ) == $NaN;
|
||||
|
||||
is_deeply( [ uniqnum 0, 1, 12345, $Inf, -$Inf, $NaN, 0, $Inf, $NaN ],
|
||||
[ 0, 1, 12345, $Inf, -$Inf, $NaN ],
|
||||
'uniqnum preserves the special values of +-Inf and Nan' );
|
||||
|
||||
SKIP: {
|
||||
my $maxuint = ~0;
|
||||
my $maxint = ~0 >> 1;
|
||||
my $minint = -(~0 >> 1) - 1;
|
||||
|
||||
my @nums = ($maxuint, $maxuint-1, -1, $maxint, $minint, 1 );
|
||||
|
||||
{
|
||||
use warnings FATAL => 'numeric';
|
||||
if (eval {
|
||||
"$Inf" + 0 == $Inf
|
||||
}) {
|
||||
push @nums, $Inf;
|
||||
}
|
||||
if (eval {
|
||||
my $nanish = "$NaN" + 0;
|
||||
$nanish != 0 && !$nanish != $NaN;
|
||||
}) {
|
||||
push @nums, $NaN;
|
||||
}
|
||||
}
|
||||
|
||||
is_deeply( [ uniqnum @nums, 1.0 ],
|
||||
[ @nums ],
|
||||
'uniqnum preserves uniqueness of full integer range' );
|
||||
|
||||
my @strs = map "$_", @nums;
|
||||
|
||||
if($maxuint !~ /\A[0-9]+\z/) {
|
||||
skip( "Perl $] doesn't stringify UV_MAX right ($maxuint)", 1 );
|
||||
}
|
||||
|
||||
is_deeply( [ uniqnum @strs, "1.0" ],
|
||||
[ @strs ],
|
||||
'uniqnum preserves uniqueness of full integer range (stringified)' );
|
||||
}
|
||||
|
||||
{
|
||||
my @nums = (6.82132005170133e-38, 62345678);
|
||||
is_deeply( [ uniqnum @nums ], [ @nums ],
|
||||
'uniqnum keeps uniqueness of numbers that stringify to the same byte pattern as a float'
|
||||
);
|
||||
}
|
||||
|
||||
{
|
||||
my $warnings = "";
|
||||
local $SIG{__WARN__} = sub { $warnings .= join "", @_ };
|
||||
|
||||
is_deeply( [ uniqnum 0, undef ],
|
||||
[ 0 ],
|
||||
'uniqnum considers undef and zero equivalent' );
|
||||
|
||||
ok( length $warnings, 'uniqnum on undef yields a warning' );
|
||||
|
||||
is_deeply( [ uniqnum undef ],
|
||||
[ 0 ],
|
||||
'uniqnum on undef coerces to zero' );
|
||||
}
|
||||
|
||||
is_deeply( [uniqnum 0, -0.0 ],
|
||||
[0],
|
||||
'uniqnum handles negative zero');
|
||||
|
||||
SKIP: {
|
||||
skip ('test not relevant for this perl configuration', 4) unless $Config{ivsize} == 8;
|
||||
|
||||
# 1e17 is the number beyond which "%.20g" formatting fails on some
|
||||
# 64-bit int perls.
|
||||
# The following 2 tests check that the nearest values (both above
|
||||
# and below that tipping point) are being handled correctly.
|
||||
|
||||
# 99999999999999984 is the largest 64-bit integer less than 1e17
|
||||
# that can be expressed exactly as a double
|
||||
|
||||
is_deeply( [ uniqnum (99999999999999984, 99999999999999984.0) ],
|
||||
[ (99999999999999984) ],
|
||||
'uniqnum recognizes 99999999999999984 and 99999999999999984.0 as the same' );
|
||||
|
||||
is_deeply( [ uniqnum (-99999999999999984, -99999999999999984.0) ],
|
||||
[ (-99999999999999984) ],
|
||||
'uniqnum recognizes -99999999999999984 and -99999999999999984.0 as the same' );
|
||||
|
||||
# 100000000000000016 is the smallest positive 64-bit integer greater than 1e17
|
||||
# that can be expressed exactly as a double
|
||||
|
||||
is_deeply( [ uniqnum (100000000000000016, 100000000000000016.0) ],
|
||||
[ (100000000000000016) ],
|
||||
'uniqnum recognizes 100000000000000016 and 100000000000000016.0 as the same' );
|
||||
|
||||
is_deeply( [ uniqnum (-100000000000000016, -100000000000000016.0) ],
|
||||
[ (-100000000000000016) ],
|
||||
'uniqnum recognizes -100000000000000016 and -100000000000000016.0 as the same' );
|
||||
}
|
||||
|
||||
# uniqnum not confused by IV'ified floats
|
||||
SKIP: {
|
||||
# This fails on 5.6 and isn't fixable without breaking a lot of other tests
|
||||
skip 'This perl version gets confused by IVNV dualvars', 1 if $] lt '5.008000';
|
||||
my @nums = ( 2.1, 2.2, 2.3 );
|
||||
my $dummy = sprintf "%d", $_ for @nums;
|
||||
|
||||
# All @nums now have both NOK and IOK but IV=2 in each case
|
||||
is( scalar( uniqnum @nums ), 3, 'uniqnum not confused by dual IV+NV' );
|
||||
}
|
||||
|
||||
{
|
||||
package Numify;
|
||||
|
||||
use overload '0+' => sub { return $_[0]->{num} };
|
||||
|
||||
sub new { bless { num => $_[1] }, $_[0] }
|
||||
|
||||
package main;
|
||||
use Scalar::Util qw( refaddr );
|
||||
|
||||
my @nums = map { Numify->new( $_ ) } qw( 2 2 5 );
|
||||
|
||||
# is_deeply wants to use eq overloading
|
||||
my @ret = uniqnum @nums;
|
||||
ok( scalar @ret == 2 &&
|
||||
refaddr $ret[0] == refaddr $nums[0] &&
|
||||
refaddr $ret[1] == refaddr $nums[2],
|
||||
'uniqnum respects numify overload' );
|
||||
}
|
||||
|
||||
{
|
||||
"1 1 2" =~ m/(.) (.) (.)/;
|
||||
is_deeply( [ uniqnum $1, $2, $3 ],
|
||||
[ 1, 2 ],
|
||||
'uniqnum handles magic' );
|
||||
}
|
||||
|
|
@ -0,0 +1,167 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Config;
|
||||
|
||||
use Scalar::Util qw(weaken unweaken isweak);
|
||||
use Test::More tests => 28;
|
||||
|
||||
# two references, one is weakened, the other is then undef'ed.
|
||||
{
|
||||
my ($y,$z);
|
||||
|
||||
{
|
||||
my $x = "foo";
|
||||
$y = \$x;
|
||||
$z = \$x;
|
||||
}
|
||||
|
||||
ok(ref($y) and ref($z));
|
||||
|
||||
weaken($y);
|
||||
ok(ref($y) and ref($z));
|
||||
|
||||
undef($z);
|
||||
ok(not(defined($y) and defined($z)));
|
||||
|
||||
undef($y);
|
||||
ok(not(defined($y) and defined($z)));
|
||||
}
|
||||
|
||||
# one reference, which is weakened
|
||||
{
|
||||
my $y;
|
||||
|
||||
{
|
||||
my $x = "foo";
|
||||
$y = \$x;
|
||||
}
|
||||
|
||||
ok(ref($y));
|
||||
|
||||
weaken($y);
|
||||
ok(not defined $y);
|
||||
}
|
||||
|
||||
my $flag;
|
||||
|
||||
# a circular structure
|
||||
{
|
||||
$flag = 0;
|
||||
|
||||
{
|
||||
my $y = bless {}, 'Dest';
|
||||
$y->{Self} = $y;
|
||||
$y->{Flag} = \$flag;
|
||||
|
||||
weaken($y->{Self});
|
||||
ok( ref($y) );
|
||||
}
|
||||
|
||||
ok( $flag == 1 );
|
||||
undef $flag;
|
||||
}
|
||||
|
||||
# a more complicated circular structure
|
||||
{
|
||||
$flag = 0;
|
||||
|
||||
{
|
||||
my $y = bless {}, 'Dest';
|
||||
my $x = bless {}, 'Dest';
|
||||
$x->{Ref} = $y;
|
||||
$y->{Ref} = $x;
|
||||
$x->{Flag} = \$flag;
|
||||
$y->{Flag} = \$flag;
|
||||
|
||||
weaken($x->{Ref});
|
||||
}
|
||||
ok( $flag == 2 );
|
||||
}
|
||||
|
||||
# deleting a weakref before the other one
|
||||
{
|
||||
my ($y,$z);
|
||||
{
|
||||
my $x = "foo";
|
||||
$y = \$x;
|
||||
$z = \$x;
|
||||
}
|
||||
|
||||
weaken($y);
|
||||
undef($y);
|
||||
|
||||
ok(not defined $y);
|
||||
ok(ref($z) );
|
||||
}
|
||||
|
||||
# isweakref
|
||||
{
|
||||
$a = 5;
|
||||
ok(!isweak($a));
|
||||
$b = \$a;
|
||||
ok(!isweak($b));
|
||||
weaken($b);
|
||||
ok(isweak($b));
|
||||
$b = \$a;
|
||||
ok(!isweak($b));
|
||||
|
||||
my $x = {};
|
||||
weaken($x->{Y} = \$a);
|
||||
ok(isweak($x->{Y}));
|
||||
ok(!isweak($x->{Z}));
|
||||
}
|
||||
|
||||
# unweaken
|
||||
{
|
||||
my ($y,$z);
|
||||
{
|
||||
my $x = "foo";
|
||||
$y = \$x;
|
||||
$z = \$x;
|
||||
}
|
||||
|
||||
weaken($y);
|
||||
|
||||
ok(isweak($y), '$y is weak after weaken()');
|
||||
is($$y, "foo", '$y points at \"foo" after weaken()');
|
||||
|
||||
unweaken($y);
|
||||
|
||||
is(ref $y, "SCALAR", '$y is still a SCALAR ref after unweaken()');
|
||||
ok(!isweak($y), '$y is not weak after unweaken()');
|
||||
is($$y, "foo", '$y points at \"foo" after unweaken()');
|
||||
|
||||
undef $z;
|
||||
ok(defined $y, '$y still defined after undef $z');
|
||||
}
|
||||
|
||||
# test weaken on a read only ref
|
||||
SKIP: {
|
||||
# Doesn't work for older perls, see bug [perl #24506]
|
||||
skip("Test does not work with perl < 5.8.3", 5) if $] < 5.008003;
|
||||
|
||||
# in a MAD build, constants have refcnt 2, not 1
|
||||
skip("Test does not work with MAD", 5) if exists $Config{mad};
|
||||
|
||||
$a = eval '\"hello"';
|
||||
ok(ref($a)) or print "# didn't get a ref from eval\n";
|
||||
|
||||
$b = $a;
|
||||
eval { weaken($b) };
|
||||
# we didn't die
|
||||
is($@, "");
|
||||
ok(isweak($b));
|
||||
is($$b, "hello");
|
||||
|
||||
$a="";
|
||||
ok(not $b) or diag("b did not go away");
|
||||
}
|
||||
|
||||
package Dest;
|
||||
|
||||
sub DESTROY {
|
||||
${$_[0]{Flag}} ++;
|
||||
}
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
#!./perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::More tests => 7;
|
||||
use List::Util qw(zip zip_longest zip_shortest);
|
||||
|
||||
is_deeply( [zip ()], [],
|
||||
'zip empty returns empty');
|
||||
|
||||
is_deeply( [zip ['a'..'c']], [ ['a'], ['b'], ['c'] ],
|
||||
'zip of one list returns a list of singleton lists' );
|
||||
|
||||
is_deeply( [zip ['one', 'two'], [1, 2]], [ [one => 1], [two => 2] ],
|
||||
'zip of two lists returns a list of pair lists' );
|
||||
|
||||
# Unequal length arrays
|
||||
|
||||
is_deeply( [zip_longest ['x', 'y', 'z'], ['X', 'Y']], [ ['x', 'X'], ['y', 'Y'], ['z', undef] ],
|
||||
'zip_longest extends short lists with undef' );
|
||||
|
||||
is_deeply( [zip_shortest ['x', 'y', 'z'], ['X', 'Y']], [ ['x', 'X'], ['y', 'Y'] ],
|
||||
'zip_shortest stops after shortest list' );
|
||||
|
||||
# Non arrayref arguments throw exception
|
||||
ok( !defined eval { zip 1, 2, 3 },
|
||||
'non-reference argument throws exception' );
|
||||
|
||||
ok( !defined eval { zip +{ one => 1 } },
|
||||
'reference to non array throws exception' );
|
||||
Loading…
Reference in New Issue