[libscalar-list-utils-perl] 01/06: Imported Upstream version 1.39
gregor herrmann
gregoa at debian.org
Fri Aug 15 18:50:13 UTC 2014
This is an automated email from the git hooks/post-receive script.
gregoa pushed a commit to branch master
in repository libscalar-list-utils-perl.
commit cbba5f7abbc5320e588c7c75c661a85f7ecc0d3c
Author: gregor herrmann <gregoa at debian.org>
Date: Fri Aug 15 20:04:20 2014 +0200
Imported Upstream version 1.39
---
Changes | 31 +++++
ListUtil.xs | 161 ++++++++++++++++++++-----
META.json | 4 +-
META.yml | 4 +-
MYMETA.json | 4 +-
MYMETA.yml | 4 +-
lib/List/Util.pm | 316 +++++++++++++++++++++++++++++++------------------
lib/List/Util/XS.pm | 2 +-
lib/Scalar/Util.pm | 288 +++++++++++++++++++++++---------------------
t/00version.t | 14 +--
t/any-all.t | 14 +--
t/blessed.t | 19 +--
t/dualvar.t | 17 +--
t/first.t | 20 ++--
t/getmagic-once.t | 14 +--
t/isvstring.t | 18 +--
t/lln.t | 17 +--
t/max.t | 17 +--
t/maxstr.t | 15 +--
t/min.t | 17 +--
t/minstr.t | 15 +--
t/multicall-refcount.t | 21 ----
t/openhan.t | 14 +--
t/pair.t | 22 +++-
t/product.t | 18 +--
t/proto.t | 39 +++---
t/readonly.t | 14 +--
t/reduce.t | 23 ++--
t/refaddr.t | 30 ++---
t/reftype.t | 22 ++--
t/shuffle.t | 14 +--
t/stack-corruption.t | 13 +-
t/sum.t | 32 ++---
t/sum0.t | 2 +
t/tainted.t | 17 +--
t/weak.t | 279 +++++++++++++++++++------------------------
36 files changed, 789 insertions(+), 782 deletions(-)
diff --git a/Changes b/Changes
index 47a58c5..b631f0f 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,34 @@
+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()
diff --git a/ListUtil.xs b/ListUtil.xs
index 96c6d2b..e6a2eaa 100644
--- a/ListUtil.xs
+++ b/ListUtil.xs
@@ -62,6 +62,26 @@ my_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
# define PERL_HAS_BAD_MULTICALL_REFCOUNT
#endif
+#if PERL_VERSION < 14
+# define croak_no_modify() croak("%s", PL_no_modify)
+#endif
+
+enum slu_accum {
+ ACC_IV,
+ ACC_NV,
+ ACC_SV,
+};
+
+static enum slu_accum accum_type(SV *sv) {
+ if(SvAMAGIC(sv))
+ return ACC_SV;
+
+ if(SvIOK(sv) && !SvNOK(sv) && !SvUOK(sv))
+ return ACC_IV;
+
+ return ACC_NV;
+}
+
MODULE=List::Util PACKAGE=List::Util
void
@@ -125,11 +145,13 @@ CODE:
{
dXSTARG;
SV *sv;
+ IV retiv = 0;
+ NV retnv = 0.0;
SV *retsv = NULL;
int index;
- NV retval = 0;
- int magic;
+ enum slu_accum accum;
int is_product = (ix == 2);
+ SV *tmpsv;
if(!items)
switch(ix) {
@@ -139,52 +161,88 @@ CODE:
}
sv = ST(0);
- magic = SvAMAGIC(sv);
- if(magic) {
+ switch((accum = accum_type(sv))) {
+ case ACC_SV:
retsv = TARG;
sv_setsv(retsv, sv);
- }
- else {
- retval = slu_sv_value(sv);
+ break;
+ case ACC_IV:
+ retiv = SvIV(sv);
+ break;
+ case ACC_NV:
+ retnv = slu_sv_value(sv);
+ break;
}
for(index = 1 ; index < items ; index++) {
sv = ST(index);
- if(!magic && SvAMAGIC(sv)){
- magic = TRUE;
+ if(accum < ACC_SV && SvAMAGIC(sv)){
if(!retsv)
retsv = TARG;
- sv_setnv(retsv,retval);
+ sv_setnv(retsv, accum == ACC_NV ? retnv : retiv);
+ accum = ACC_SV;
}
- if(magic) {
- SV *const tmpsv = amagic_call(retsv, sv,
+ switch(accum) {
+ case ACC_SV:
+ tmpsv = amagic_call(retsv, sv,
is_product ? mult_amg : add_amg,
SvAMAGIC(retsv) ? AMGf_assign : 0);
if(tmpsv) {
- magic = SvAMAGIC(tmpsv);
- if(!magic) {
- retval = slu_sv_value(tmpsv);
- }
- else {
+ switch((accum = accum_type(tmpsv))) {
+ case ACC_SV:
retsv = tmpsv;
+ break;
+ case ACC_IV:
+ retiv = SvIV(tmpsv);
+ break;
+ case ACC_NV:
+ retnv = slu_sv_value(tmpsv);
+ break;
}
}
else {
/* fall back to default */
- magic = FALSE;
- is_product ? (retval = SvNV(retsv) * SvNV(sv))
- : (retval = SvNV(retsv) + SvNV(sv));
+ accum = ACC_NV;
+ is_product ? (retnv = SvNV(retsv) * SvNV(sv))
+ : (retnv = SvNV(retsv) + SvNV(sv));
}
- }
- else {
- is_product ? (retval *= slu_sv_value(sv))
- : (retval += slu_sv_value(sv));
+ break;
+ case ACC_IV:
+ if(is_product) {
+ if(!SvNOK(sv) && SvIOK(sv) && (SvIV(sv) < IV_MAX / retiv)) {
+ retiv *= SvIV(sv);
+ break;
+ }
+ /* else fallthrough */
+ }
+ else {
+ if(!SvNOK(sv) && SvIOK(sv) && (SvIV(sv) < IV_MAX - retiv)) {
+ retiv += SvIV(sv);
+ break;
+ }
+ /* else fallthrough */
+ }
+
+ /* fallthrough to NV now */
+ retnv = retiv;
+ accum = ACC_NV;
+ case ACC_NV:
+ is_product ? (retnv *= slu_sv_value(sv))
+ : (retnv += slu_sv_value(sv));
+ break;
}
}
- if(!magic) {
- if(!retsv)
- retsv = TARG;
- sv_setnv(retsv,retval);
+
+ if(!retsv)
+ retsv = TARG;
+
+ switch(accum) {
+ case ACC_IV:
+ sv_setiv(retsv, retiv);
+ break;
+ case ACC_NV:
+ sv_setnv(retsv, retnv);
+ break;
}
ST(0) = retsv;
@@ -711,6 +769,7 @@ PPCODE:
{
int argi = 0;
int reti = 0;
+ HV *pairstash = get_hv("List::Util::_Pair::", GV_ADD);
if(items % 2 && ckWARN(WARN_MISC))
warn("Odd number of elements in pairs");
@@ -724,7 +783,9 @@ PPCODE:
av_push(av, newSVsv(a));
av_push(av, newSVsv(b));
- ST(reti++) = sv_2mortal(newRV_noinc((SV *)av));
+ ST(reti) = sv_2mortal(newRV_noinc((SV *)av));
+ sv_bless(ST(reti), pairstash);
+ reti++;
}
}
@@ -922,6 +983,43 @@ CODE:
#endif
void
+unweaken(sv)
+ SV *sv
+PROTOTYPE: $
+INIT:
+ SV *tsv;
+CODE:
+#ifdef SvWEAKREF
+ /* This code stolen from core's sv_rvweaken() and modified */
+ if (!SvOK(sv))
+ return;
+ if (!SvROK(sv))
+ croak("Can't unweaken a nonreference");
+ else if (!SvWEAKREF(sv)) {
+ if(ckWARN(WARN_MISC))
+ warn("Reference is not weak");
+ return;
+ }
+ else if (SvREADONLY(sv)) croak_no_modify();
+
+ tsv = SvRV(sv);
+#if PERL_VERSION >= 14
+ SvWEAKREF_off(sv); SvROK_on(sv);
+ SvREFCNT_inc_NN(tsv);
+ Perl_sv_del_backref(aTHX_ tsv, sv);
+#else
+ /* Lacking sv_del_backref() the best we can do is clear the old (weak) ref
+ * then set a new strong one
+ */
+ sv_setsv(sv, &PL_sv_undef);
+ SvRV_set(sv, SvREFCNT_inc_NN(tsv));
+ SvROK_on(sv);
+#endif
+#else
+ croak("weak references are not implemented in this release of perl");
+#endif
+
+void
isweak(sv)
SV *sv
PROTOTYPE: $
@@ -978,13 +1076,13 @@ CODE:
}
#if PERL_BCDVERSION < 0x5008005
if(SvPOK(sv) || SvPOKp(sv)) {
- RETVAL = looks_like_number(sv);
+ RETVAL = !!looks_like_number(sv);
}
else {
RETVAL = SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
}
#else
- RETVAL = looks_like_number(sv);
+ RETVAL = !!looks_like_number(sv);
#endif
OUTPUT:
RETVAL
@@ -996,6 +1094,7 @@ set_prototype(subref, proto)
PROTOTYPE: &$
CODE:
{
+ SvGETMAGIC(subref);
if(SvROK(subref)) {
SV *sv = SvRV(subref);
if(SvTYPE(sv) != SVt_PVCV) {
diff --git a/META.json b/META.json
index aed2305..680f46c 100644
--- a/META.json
+++ b/META.json
@@ -4,7 +4,7 @@
"Graham Barr <gbarr at cpan.org>"
],
"dynamic_config" : 1,
- "generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.132661",
+ "generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.132830",
"license" : [
"perl_5"
],
@@ -42,5 +42,5 @@
"url" : "https://github.com/Scalar-List-Utils/Scalar-List-Utils"
}
},
- "version" : "1.35"
+ "version" : "1.39"
}
diff --git a/META.yml b/META.yml
index e9cc9d3..4e314eb 100644
--- a/META.yml
+++ b/META.yml
@@ -7,7 +7,7 @@ build_requires:
configure_requires:
ExtUtils::MakeMaker: 0
dynamic_config: 1
-generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.132661'
+generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.132830'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -21,4 +21,4 @@ requires:
Test::More: 0
resources:
repository: https://github.com/Scalar-List-Utils/Scalar-List-Utils
-version: 1.35
+version: 1.39
diff --git a/MYMETA.json b/MYMETA.json
index e8f1585..518a97b 100644
--- a/MYMETA.json
+++ b/MYMETA.json
@@ -4,7 +4,7 @@
"Graham Barr <gbarr at cpan.org>"
],
"dynamic_config" : 0,
- "generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.132661",
+ "generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.132830",
"license" : [
"perl_5"
],
@@ -42,5 +42,5 @@
"url" : "https://github.com/Scalar-List-Utils/Scalar-List-Utils"
}
},
- "version" : "1.35"
+ "version" : "1.39"
}
diff --git a/MYMETA.yml b/MYMETA.yml
index c68949c..91e0215 100644
--- a/MYMETA.yml
+++ b/MYMETA.yml
@@ -7,7 +7,7 @@ build_requires:
configure_requires:
ExtUtils::MakeMaker: 0
dynamic_config: 0
-generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.132661'
+generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.132830'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -21,4 +21,4 @@ requires:
Test::More: 0
resources:
repository: https://github.com/Scalar-List-Utils/Scalar-List-Utils
-version: 1.35
+version: 1.39
diff --git a/lib/List/Util.pm b/lib/List/Util.pm
index 452dd29..c99bcd4 100644
--- a/lib/List/Util.pm
+++ b/lib/List/Util.pm
@@ -1,5 +1,3 @@
-# List::Util.pm
-#
# Copyright (c) 1997-2009 Graham Barr <gbarr at 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.
@@ -16,7 +14,7 @@ our @EXPORT_OK = qw(
all any first min max minstr maxstr none notall product reduce sum sum0 shuffle
pairmap pairgrep pairfirst pairs pairkeys pairvalues
);
-our $VERSION = "1.35";
+our $VERSION = "1.39";
our $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
@@ -36,6 +34,10 @@ sub import
goto &Exporter::import;
}
+# For objects returned by pairs()
+sub List::Util::_Pair::key { shift->[0] }
+sub List::Util::_Pair::value { shift->[1] }
+
1;
__END__
@@ -50,10 +52,10 @@ List::Util - A selection of general-utility list subroutines
=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.
+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.
@@ -65,22 +67,22 @@ The following set of functions all reduce a list down to a single value.
=cut
-=head2 reduce BLOCK LIST
+=head2 $result = reduce { BLOCK } @list
-Reduces LIST by calling 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.
+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 BLOCK. If LIST is empty then
-C<undef> is returned. If LIST only contains one element then that
-element is returned and BLOCK is not executed.
+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).
+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 :
@@ -99,21 +101,23 @@ manner in individual C functions).
$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
+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 remaining list-reduction functions are all specialisations of this
-generic idea.
+The remaining list-reduction functions are all specialisations of this generic
+idea.
-=head2 any BLOCK LIST
+=head2 $b = any { BLOCK } @list
-Similar to C<grep> in that it evaluates BLOCK setting C<$_> to each element
-of LIST in turn. C<any> returns true if any element makes the BLOCK return a
-true value. If BLOCK never returns true or LIST was empty then it returns
-false.
+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.
@@ -122,187 +126,224 @@ instead, as it can short-circuit after the first true result.
# at least one string has more than 10 characters
}
-=head2 all BLOCK LIST
+=head2 $b = all { BLOCK } @list
+
+I<Since version 1.33.>
-Similar to C<any>, except that it requires all elements of the LIST to make
-the BLOCK return true. If any element returns false, then it returns true. If
-the BLOCK never returns false or the LIST was empty then it returns true.
+Similar to C<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.
-=head2 none BLOCK LIST
+=head2 $b = none { BLOCK } @list
-=head2 notall BLOCK LIST
+=head2 $b = notall { BLOCK } @list
+
+I<Since version 1.33.>
Similar to C<any> and C<all>, but with the return sense inverted. C<none>
-returns true if no value in the LIST causes the BLOCK to return true, and
-C<notall> returns true if not all of the values do.
+returns true only if no value in the LIST causes the BLOCK to return true, and
+C<notall> returns true only if not all of the values do.
-=head2 first BLOCK LIST
+=head2 $val = first { BLOCK } @list
-Similar to C<grep> in that it evaluates BLOCK setting C<$_> to each element
-of LIST in turn. C<first> returns the first element where the result from
-BLOCK is a true value. If BLOCK never returns true or LIST was empty then
-C<undef> is returned.
+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 LIST
+=head2 $num = max @list
-Returns the entry in the list with the highest numerical value. If the
-list is empty then C<undef> is returned.
+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 LIST
+=head2 $str = maxstr @list
-Similar to C<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.
+Similar to C<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 LIST
+=head2 $num = min @list
-Similar to C<max> but returns the entry in the list with the lowest
-numerical value. If the list is empty then C<undef> is returned.
+Similar to C<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 LIST
+=head2 $str = minstr @list
-Similar to C<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.
+Similar to C<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 LIST
+=head2 $num = product @list
+
+I<Since version 1.35.>
-Returns the product of all the elements in LIST. If LIST is empty then C<1> is
-returned.
+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 LIST
+=head2 $num_or_undef = sum @list
-Returns the sum of all the elements in LIST. If LIST is empty then
-C<undef> is returned.
+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 LIST
+=head2 $num = sum0 @list
-Similar to C<sum>, except this returns 0 when given an empty list, rather
-than C<undef>.
+I<Since version 1.26.>
+
+Similar to C<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.
+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.
=cut
-=head2 pairgrep BLOCK KVLIST
+=head2 @kvlist = pairgrep { BLOCK } @kvlist
+
+=head2 $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 BLOCK multiple times, in scalar
+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
-KVLIST.
+C<@kvlist>.
-Returns an even-sized list of those pairs for which the BLOCK returned true
+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).
+(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
-Similar to C<grep>, 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.
+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 ( $key, $val ) = pairfirst { BLOCK } @kvlist
-=head2 pairfirst BLOCK KVLIST
+=head2 $found = pairfirst { BLOCK } @kvlist
+
+I<Since version 1.30.>
Similar to the C<first> function, but interprets the given list as an
-even-sized list of pairs. It invokes the BLOCK multiple times, in scalar
+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
-KVLIST.
+C<@kvlist>.
-Returns the first pair of values from the list for which the BLOCK returned
+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
-Similar to C<grep>, 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.
+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 @list = pairmap { BLOCK } @kvlist
-=head2 pairmap BLOCK KVLIST
+=head2 $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 BLOCK multiple times, in list
+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
-KVLIST.
+C<@kvlist>.
-Returns the concatenation of all the values returned by the BLOCK in list
-context, or the count of the number of items that would have been returned
-in scalar context.
+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
-Similar to C<map>, 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.
+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.
-=head2 pairs KVLIST
+=head2 @pairs = pairs @kvlist
-A convenient shortcut to operating on even-sized lists of pairs, this
-function returns a list of ARRAY references, each containing two items from
-the given list. It is a more efficient version of
+I<Since version 1.29.>
- pairmap { [ $a, $b ] } KVLIST
+A convenient shortcut to operating on even-sized lists of pairs, this function
+returns a list of 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 ( pairs @KVLIST ) {
- my ( $key, $value ) = @$_;
+ foreach my $pair ( pairs @KVLIST ) {
+ my ( $key, $value ) = @$pair;
+ ...
+ }
+
+Since version C<1.39> these 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;
...
}
-=head2 pairkeys KVLIST
+=head2 @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
+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
- pairmap { $a } KVLIST
+ @keys = pairmap { $a } @kvlist
-=head2 pairvalues KVLIST
+=head2 @values = pairvalues @kvlist
-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
+I<Since version 1.29.>
- pairmap { $b } KVLIST
+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
=cut
@@ -310,9 +351,9 @@ the given list. It is a more efficient version of
=cut
-=head2 shuffle LIST
+=head2 @values = shuffle @values
-Returns the elements of LIST in a random order
+Returns the values of the input in a random order
@cards = shuffle 0..51 # 0..51 in a random order
@@ -320,9 +361,48 @@ Returns the elements of LIST in a random order
=head1 KNOWN BUGS
-With perl versions prior to 5.005 there are some cases where reduce
-will return an incorrect result. This will show up as test 7 of
-reduce.t failing.
+=head2 RT #95409
+
+L<https://rt.cpan.org/Ticket/Display.html?id=95409>
+
+If the block of code given to C<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.
=head1 SUGGESTED ADDITIONS
diff --git a/lib/List/Util/XS.pm b/lib/List/Util/XS.pm
index 0625a0a..e605d88 100644
--- a/lib/List/Util/XS.pm
+++ b/lib/List/Util/XS.pm
@@ -2,7 +2,7 @@ package List::Util::XS;
use strict;
use List::Util;
-our $VERSION = "1.35"; # FIXUP
+our $VERSION = "1.39"; # FIXUP
$VERSION = eval $VERSION; # FIXUP
1;
diff --git a/lib/Scalar/Util.pm b/lib/Scalar/Util.pm
index edcaf1c..06d3660 100644
--- a/lib/Scalar/Util.pm
+++ b/lib/Scalar/Util.pm
@@ -1,5 +1,3 @@
-# Scalar::Util.pm
-#
# Copyright (c) 1997-2007 Graham Barr <gbarr at 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.
@@ -14,21 +12,11 @@ require List::Util; # List::Util loads the XS
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
- blessed
- dualvar
- isdual
- isvstring
- isweak
- looks_like_number
- openhandle
- readonly
- refaddr
- reftype
- set_prototype
- tainted
- weaken
+ blessed refaddr reftype weaken unweaken isweak
+
+ dualvar isdual isvstring looks_like_number openhandle readonly set_prototype tainted
);
-our $VERSION = "1.35";
+our $VERSION = "1.39";
$VERSION = eval $VERSION;
our @EXPORT_FAIL;
@@ -74,58 +62,162 @@ Scalar::Util - A selection of general-utility scalar subroutines
=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
-so small such that being individual extensions would be wasteful.
+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 so small such that being
+individual extensions would be wasteful.
+
+By default C<Scalar::Util> does not export any subroutines.
+
+=cut
+
+=head1 FUNCTIONS FOR REFERENCES
-By default C<Scalar::Util> does not export any subroutines. The
-subroutines defined are
+The following functions all perform some useful activity on reference values.
-=head2 blessed EXPR
+=head2 $pkg = blessed( $ref )
-If EXPR evaluates to a blessed reference the name of the package
-that it is blessed into is returned. Otherwise C<undef> is returned.
+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
+ $scalar = "foo";
+ $class = blessed $scalar; # undef
- $ref = [];
- $class = blessed $ref; # undef
+ $ref = [];
+ $class = blessed $ref; # undef
- $obj = bless [], "Foo";
- $class = blessed $obj; # "Foo"
+ $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.
+C<if(blessed $ref)...>) because the package name C<"0"> is defined yet false.
+
+=head2 $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
+
+=head2 $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
+
+=head2 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.
+
+=head2 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
+C<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).
+
+=head2 $weak = isweak( $ref )
+
+Returns true if C<$ref> is a weak reference.
+
+ $ref = \$foo;
+ $weak = isweak($ref); # false
+ weaken($ref);
+ $weak = isweak($ref); # true
-=head2 dualvar NUM, STRING
+B<NOTE>: Copying a weak reference creates a normal, strong, reference.
+
+ $copy = $ref;
+ $weak = isweak($copy); # false
-Returns a scalar that has the value NUM in a numeric context and the
-value STRING in a string context.
+=head1 OTHER FUNCTIONS
+
+=head2 $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 EXPR
+=head2 $dual = isdual( $var )
-If EXPR is a scalar that is a dualvar, the result is true.
+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 numeric operations:
+Note that a scalar can be made to have both string and numeric content through
+numeric operations:
$foo = "10";
$dual = isdual($foo); # false
$bar = $foo + 0;
$dual = isdual($foo); # true
-Note that although C<$!> appears to be dual-valued variable, it is
-actually implemented using a tied scalar:
+Note that although C<$!> appears to be dual-valued variable, it is actually
+implemented using a tied scalar:
$! = 1;
print("$!\n"); # "Operation not permitted"
@@ -136,125 +228,52 @@ You can capture its numeric and string content using:
$err = dualvar $!, $!;
$dual = isdual($err); # true
-=head2 isvstring EXPR
+=head2 $vstring = isvstring( $var )
-If EXPR is a scalar which was coded as a vstring the result is true.
+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 EXPR
+=head2 $isnum = looks_like_number( $var )
-Returns true if perl thinks EXPR is a number. See
+Returns true if perl thinks C<$var> is a number. See
L<perlapi/looks_like_number>.
-=head2 openhandle FH
+=head2 $fh = openhandle( $fh )
-Returns FH if FH may be used as a filehandle and is open, or FH is a tied
-handle. Otherwise C<undef> is returned.
+Returns C<$fh> itself if C<$fh> may be used as a filehandle and is open, or is
+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 SCALAR
+=head2 $ro = readonly( $var )
-Returns true if SCALAR is readonly.
+Returns true if C<$var> is readonly.
sub foo { readonly($_[0]) }
$readonly = foo($bar); # false
$readonly = foo(0); # true
-=head2 refaddr EXPR
-
-If EXPR evaluates to a reference the internal memory address of
-the referenced value is returned. 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
-
-=head2 reftype EXPR
+=head2 $code = set_prototype( $code, $prototype )
-If EXPR evaluates to a reference the type of the variable referenced
-is returned. Otherwise C<undef> is returned.
-
- $type = reftype "string"; # undef
- $type = reftype \$var; # SCALAR
- $type = reftype []; # ARRAY
-
- $obj = bless {}, "Foo";
- $type = reftype $obj; # HASH
-
-=head2 set_prototype CODEREF, PROTOTYPE
-
-Sets the prototype of the given function, or deletes it if PROTOTYPE is
-undef. Returns the CODEREF.
+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 EXPR
+=head2 $t = tainted( $var )
-Return true if the result of EXPR is tainted
+Return true if C<$var> is tainted.
$taint = tainted("constant"); # false
$taint = tainted($ENV{PWD}); # true if running under -T
-=head2 weaken REF
-
-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, REF will be set to undef.
-
-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
- at object array.
-
-=head2 isweak EXPR
-
-If EXPR is a scalar which is a weak reference the result is true.
-
- $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
-
=head1 DIAGNOSTICS
Module use may give one of the following errors during import.
@@ -263,8 +282,8 @@ Module use may give one of the following errors during import.
=item Weak references are not implemented in the version of perl
-The version of perl that you are using does not implement weak references, to use
-C<isweak> or C<weaken> you will need to use a newer release of perl.
+The version of perl that you are using does not implement weak references, to
+use C<isweak> or C<weaken> you will need to use a newer release of perl.
=item Vstrings are not implemented in the version of perl
@@ -273,9 +292,10 @@ C<isvstring> you will need to use a newer release of perl.
=item C<NAME> is only available with the XS version of Scalar::Util
-C<Scalar::Util> contains both perl and C implementations of many of its functions
-so that those without access to a C compiler may still use it. However some of the functions
-are only available when a C compiler was available to compile the XS version of the extension.
+C<Scalar::Util> contains both perl and C implementations of many of its
+functions so that those without access to a C compiler may still use it.
+However some of the functions are only available when a C compiler was
+available to compile the XS version of the extension.
At present that list is: weaken, isweak, dualvar, isvstring, set_prototype
diff --git a/t/00version.t b/t/00version.t
index d475de4..b04bd33 100644
--- a/t/00version.t
+++ b/t/00version.t
@@ -1,17 +1,7 @@
#!./perl
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
-}
+use strict;
+use warnings;
use Scalar::Util ();
use List::Util ();
diff --git a/t/any-all.t b/t/any-all.t
index 6fbf89a..f1626c2 100644
--- a/t/any-all.t
+++ b/t/any-all.t
@@ -1,17 +1,7 @@
#!./perl
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
-}
+use strict;
+use warnings;
use List::Util qw(any all notall none);
use Test::More tests => 12;
diff --git a/t/blessed.t b/t/blessed.t
index ae292b9..21d3a9a 100644
--- a/t/blessed.t
+++ b/t/blessed.t
@@ -1,21 +1,12 @@
#!./perl
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
-}
+use strict;
+use warnings;
use Test::More tests => 11;
use Scalar::Util qw(blessed);
-use vars qw($t $x);
+
+my $t;
ok(!defined blessed(undef), 'undef is not blessed');
ok(!defined blessed(1), 'Numbers are not blessed');
@@ -24,6 +15,8 @@ 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');
diff --git a/t/dualvar.t b/t/dualvar.t
index 0943c75..08dff11 100644
--- a/t/dualvar.t
+++ b/t/dualvar.t
@@ -1,17 +1,7 @@
#!./perl
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
-}
+use strict;
+use warnings;
use Scalar::Util ();
use Test::More (grep { /dualvar/ } @Scalar::Util::EXPORT_FAIL)
@@ -22,13 +12,14 @@ use Config;
Scalar::Util->import('dualvar');
Scalar::Util->import('isdual');
+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');
-$var2 = $var;
+my $var2 = $var;
ok( isdual($var2), 'Is a dualvar');
ok( $var2 == 2.2, 'copy Numeric value');
diff --git a/t/first.t b/t/first.t
index 497cdd5..ba7726a 100644
--- a/t/first.t
+++ b/t/first.t
@@ -1,17 +1,7 @@
#!./perl
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
-}
+use strict;
+use warnings;
use List::Util qw(first);
use Test::More;
@@ -68,7 +58,11 @@ like($@, qr/^Can't undef active subroutine/, "undef active sub");
# redefinition takes effect immediately depends on whether we're
# running the Perl or XS implementation.
-sub self_updating { local $^W; *self_updating = sub{1} ;1}
+sub self_updating {
+ no warnings 'redefine';
+ *self_updating = sub{1};
+ 1
+}
eval { $v = first \&self_updating, 1,2; };
is($@, '', 'redefine self');
diff --git a/t/getmagic-once.t b/t/getmagic-once.t
index 00b3490..431033c 100755
--- a/t/getmagic-once.t
+++ b/t/getmagic-once.t
@@ -1,18 +1,8 @@
#!./perl
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
-}
use strict;
+use warnings;
+
use Scalar::Util qw(blessed reftype refaddr);
use Test::More tests => 6;
diff --git a/t/isvstring.t b/t/isvstring.t
index 860113e..9d345aa 100644
--- a/t/isvstring.t
+++ b/t/isvstring.t
@@ -1,17 +1,7 @@
#!./perl
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
-}
+use strict;
+use warnings;
$|=1;
use Scalar::Util ();
@@ -21,12 +11,12 @@ use Test::More (grep { /isvstring/ } @Scalar::Util::EXPORT_FAIL)
Scalar::Util->import(qw[isvstring]);
-$vs = ord("A") == 193 ? 241.75.240 : 49.46.48;
+my $vs = ord("A") == 193 ? 241.75.240 : 49.46.48;
ok( $vs == "1.0", 'dotted num');
ok( isvstring($vs), 'isvstring');
-$sv = "1.0";
+my $sv = "1.0";
ok( !isvstring($sv), 'not isvstring');
diff --git a/t/lln.t b/t/lln.t
index 1499cdb..df9ea3a 100644
--- a/t/lln.t
+++ b/t/lln.t
@@ -1,19 +1,8 @@
-#!/usr/bin/perl -w
-
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
-}
+#!./perl
use strict;
+use warnings;
+
use Test::More tests => 19;
use Scalar::Util qw(looks_like_number);
diff --git a/t/max.t b/t/max.t
index 9607015..adb222b 100644
--- a/t/max.t
+++ b/t/max.t
@@ -1,19 +1,8 @@
#!./perl
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
-}
-
use strict;
+use warnings;
+
use Test::More tests => 10;
use List::Util qw(max);
@@ -50,7 +39,7 @@ is($v, 3, 'overload');
use overload
'""' => sub { ${$_[0]} },
- '+0' => sub { ${$_[0]} },
+ '0+' => sub { ${$_[0]} },
'>' => sub { ${$_[0]} > ${$_[1]} },
fallback => 1;
sub new {
diff --git a/t/maxstr.t b/t/maxstr.t
index 11d98ff..ac135a1 100644
--- a/t/maxstr.t
+++ b/t/maxstr.t
@@ -1,19 +1,8 @@
#!./perl
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
-}
-
use strict;
+use warnings;
+
use Test::More tests => 5;
use List::Util qw(maxstr);
diff --git a/t/min.t b/t/min.t
index 8d5be5e..a7dfb10 100644
--- a/t/min.t
+++ b/t/min.t
@@ -1,19 +1,8 @@
#!./perl
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
-}
-
use strict;
+use warnings;
+
use Test::More tests => 10;
use List::Util qw(min);
@@ -49,7 +38,7 @@ is($v, 1, 'overload');
use overload
'""' => sub { ${$_[0]} },
- '+0' => sub { ${$_[0]} },
+ '0+' => sub { ${$_[0]} },
'<' => sub { ${$_[0]} < ${$_[1]} },
fallback => 1;
sub new {
diff --git a/t/minstr.t b/t/minstr.t
index 021b309..ee6f2b7 100644
--- a/t/minstr.t
+++ b/t/minstr.t
@@ -1,19 +1,8 @@
#!./perl
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
-}
-
use strict;
+use warnings;
+
use Test::More tests => 5;
use List::Util qw(minstr);
diff --git a/t/multicall-refcount.t b/t/multicall-refcount.t
deleted file mode 100644
index 1d6fb59..0000000
--- a/t/multicall-refcount.t
+++ /dev/null
@@ -1,21 +0,0 @@
-use Test::More tests => 1;
-
-use List::Util 'first';
-
-our $comparison;
-
-sub foo {
- if( $comparison ) {
- return 1;
- }
- else {
- local $comparison = 1;
- first \&foo, 1,2,3;
- }
-}
-
-for(1,2){
- foo();
-}
-
-ok( "Didn't crash calling recursively" );
diff --git a/t/openhan.t b/t/openhan.t
index e0dffb6..89bdba4 100644
--- a/t/openhan.t
+++ b/t/openhan.t
@@ -1,19 +1,7 @@
#!./perl
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
-}
-
use strict;
+use warnings;
use Test::More tests => 21;
use Scalar::Util qw(openhandle);
diff --git a/t/pair.t b/t/pair.t
index 46e0534..fab05dd 100644
--- a/t/pair.t
+++ b/t/pair.t
@@ -1,7 +1,9 @@
#!./perl
use strict;
-use Test::More tests => 20;
+use warnings;
+
+use Test::More tests => 23;
use List::Util qw(pairgrep pairfirst pairmap pairs pairkeys pairvalues);
no warnings 'misc'; # avoid "Odd number of elements" warnings most of the time
@@ -88,6 +90,12 @@ 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( [ pairkeys one => 1, two => 2 ],
[qw( one two )],
'pairkeys' );
@@ -95,3 +103,15 @@ is_deeply( [ pairkeys one => 1, two => 2 ],
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' );
+}
diff --git a/t/product.t b/t/product.t
index bed20cf..c397f82 100644
--- a/t/product.t
+++ b/t/product.t
@@ -1,17 +1,7 @@
#!./perl
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
-}
+use strict;
+use warnings;
use Test::More tests => 13;
@@ -49,7 +39,7 @@ is($v, 8, 'overload');
use overload
'""' => sub { ${$_[0]} },
- '+0' => sub { ${$_[0]} },
+ '0+' => sub { ${$_[0]} },
fallback => 1;
sub new {
my $class = shift;
@@ -88,7 +78,7 @@ is($v, $v1 * 42 * 2, 'bigint + builtin int');
{
my $e1 = example->new(7, "test");
- $t = product($e1, 7, 7);
+ 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');
diff --git a/t/proto.t b/t/proto.t
index 50e401b..e9b653a 100644
--- a/t/proto.t
+++ b/t/proto.t
@@ -1,29 +1,19 @@
#!./perl
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
-}
+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 => 13);
+ : (tests => 14);
Scalar::Util->import('set_prototype');
sub f { }
is( prototype('f'), undef, 'no prototype');
-$r = set_prototype(\&f,'$');
+my $r = set_prototype(\&f,'$');
is( prototype('f'), '$', 'set prototype');
is( $r, \&f, 'return value');
@@ -57,3 +47,24 @@ 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' );
diff --git a/t/readonly.t b/t/readonly.t
index 91385fd..c8e19ff 100644
--- a/t/readonly.t
+++ b/t/readonly.t
@@ -1,17 +1,7 @@
#!./perl
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
-}
+use strict;
+use warnings;
use Scalar::Util qw(readonly);
use Test::More tests => 11;
diff --git a/t/reduce.t b/t/reduce.t
index 4468ab8..b8acbe7 100644
--- a/t/reduce.t
+++ b/t/reduce.t
@@ -1,18 +1,7 @@
#!./perl
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
-}
-
+use strict;
+use warnings;
use List::Util qw(reduce min);
use Test::More;
@@ -28,7 +17,7 @@ is( $v, 9, '4-arg divide');
$v = reduce { $a / $b } 6;
is( $v, 6, 'one arg');
- at a = map { rand } 0 .. 20;
+my @a = map { rand } 0 .. 20;
$v = reduce { $a < $b ? $a : $b } @a;
is( $v, min(@a), 'min');
@@ -95,7 +84,11 @@ like($@, qr/^Can't undef active subroutine/, "undef active sub");
# redefinition takes effect immediately depends on whether we're
# running the Perl or XS implementation.
-sub self_updating { local $^W; *self_updating = sub{1} ;1 }
+sub self_updating {
+ no warnings 'redefine';
+ *self_updating = sub{1};
+ 1
+}
eval { $v = reduce \&self_updating, 1,2; };
is($@, '', 'redefine self');
diff --git a/t/refaddr.t b/t/refaddr.t
index 35ad40f..c208943 100644
--- a/t/refaddr.t
+++ b/t/refaddr.t
@@ -1,34 +1,24 @@
#!./perl
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
-}
-
+use strict;
+use warnings;
use Test::More tests => 32;
use Scalar::Util qw(refaddr);
-use vars qw($t $y $x *F $v $r);
+use vars qw(*F);
use Symbol qw(gensym);
# Ensure we do not trigger and tied methods
tie *F, 'MyTie';
my $i = 1;
-foreach $v (undef, 10, 'string') {
+foreach my $v (undef, 10, 'string') {
is(refaddr($v), undef, "not " . (defined($v) ? "'$v'" : "undef"));
}
-foreach $r ({}, \$t, [], \*F, sub {}) {
+my $t;
+foreach my $r ({}, \$t, [], \*F, sub {}) {
my $n = "$r";
$n =~ /0x(\w+)/;
my $addr = do { local $^W; hex $1 };
@@ -61,7 +51,10 @@ foreach $r ({}, \$t, [], \*F, sub {}) {
{
my $z = bless {}, '0';
ok(refaddr($z));
- @{"0::ISA"} = qw(FooBar);
+ {
+ no strict 'refs';
+ @{"0::ISA"} = qw(FooBar);
+ }
my $a = {};
my $r = refaddr($a);
$z = bless $a, '0';
@@ -73,7 +66,7 @@ package FooBar;
use overload '0+' => sub { 10 },
'+' => sub { 10 + $_[1] },
- '"' => sub { "10" };
+ '""' => sub { "10" };
package MyTie;
@@ -81,6 +74,7 @@ sub TIEHANDLE { bless {} }
sub DESTROY {}
sub AUTOLOAD {
+ our $AUTOLOAD;
warn "$AUTOLOAD called";
exit 1; # May be in an eval
}
diff --git a/t/reftype.t b/t/reftype.t
index 31a5d3b..a40e414 100644
--- a/t/reftype.t
+++ b/t/reftype.t
@@ -1,22 +1,12 @@
#!./perl
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
-}
+use strict;
+use warnings;
use Test::More tests => 32;
use Scalar::Util qw(reftype);
-use vars qw($t $y $x *F);
+use vars qw(*F);
use Symbol qw(gensym);
# Ensure we do not trigger and tied methods
@@ -26,7 +16,8 @@ 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
- at test = (
+my $t;
+my @test = (
[ undef, 1, 'number' ],
[ undef, 'A', 'string' ],
[ HASH => {}, 'HASH ref' ],
@@ -41,7 +32,7 @@ $s = undef; # SvTYPE($s) is SVt_RV, but SvROK($s) is false
[ $RE => qr/x/, 'REGEEXP' ],
);
-foreach $test (@test) {
+foreach my $test (@test) {
my($type,$what, $n) = @$test;
is( reftype($what), $type, $n);
@@ -60,6 +51,7 @@ sub TIEHANDLE { bless {} }
sub DESTROY {}
sub AUTOLOAD {
+ our $AUTOLOAD;
warn "$AUTOLOAD called";
exit 1; # May be in an eval
}
diff --git a/t/shuffle.t b/t/shuffle.t
index d3fbd6c..dff9637 100644
--- a/t/shuffle.t
+++ b/t/shuffle.t
@@ -1,17 +1,7 @@
#!./perl
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
-}
+use strict;
+use warnings;
use Test::More tests => 6;
diff --git a/t/stack-corruption.t b/t/stack-corruption.t
index dff5af0..03f141a 100644
--- a/t/stack-corruption.t
+++ b/t/stack-corruption.t
@@ -1,22 +1,15 @@
#!./perl
BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
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;
diff --git a/t/sum.t b/t/sum.t
index 3615b4a..7a12813 100644
--- a/t/sum.t
+++ b/t/sum.t
@@ -1,20 +1,11 @@
#!./perl
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
-}
+use strict;
+use warnings;
-use Test::More tests => 13;
+use Test::More tests => 15;
+use Config;
use List::Util qw(sum);
my $v = sum;
@@ -37,6 +28,9 @@ 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);
@@ -49,7 +43,7 @@ is($v, 6, 'overload');
use overload
'""' => sub { ${$_[0]} },
- '+0' => sub { ${$_[0]} },
+ '0+' => sub { ${$_[0]} },
fallback => 1;
sub new {
my $class = shift;
@@ -88,10 +82,18 @@ is($v, $v1 + 42 + 2, 'bigint + builtin int');
{
my $e1 = example->new(7, "test");
- $t = sum($e1, 7, 7);
+ 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", 1 unless $Config{ivsize} >= 8;
+
+ # Sum using NV will only preserve 53 bits of integer precision
+ my $t = sum(1<<60, 1);
+ cmp_ok($t, '>', 1<<60, 'sum uses IV where it can');
+}
diff --git a/t/sum0.t b/t/sum0.t
index e76f8a7..6b08741 100644
--- a/t/sum0.t
+++ b/t/sum0.t
@@ -1,3 +1,5 @@
+#!./perl
+
use strict;
use warnings;
diff --git a/t/tainted.t b/t/tainted.t
index 8666117..e483dfd 100644
--- a/t/tainted.t
+++ b/t/tainted.t
@@ -1,20 +1,7 @@
#!./perl -T
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
- elsif(!grep {/blib/} @INC) {
- unshift(@INC, qw(./inc ./blib/arch ./blib/lib));
- }
-}
+use strict;
+use warnings;
use Test::More tests => 5;
diff --git a/t/weak.t b/t/weak.t
index f014113..86ded97 100644
--- a/t/weak.t
+++ b/t/weak.t
@@ -1,208 +1,171 @@
#!./perl
use strict;
+use warnings;
+
use Config;
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
-}
use Scalar::Util ();
use Test::More ((grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) and !$ENV{PERL_CORE})
? (skip_all => 'weaken requires XS version')
- : (tests => 22);
-
-if (0) {
- require Devel::Peek;
- Devel::Peek->import('Dump');
-}
-else {
- *Dump = sub {};
-}
-
-Scalar::Util->import(qw(weaken isweak));
-
-if(1) {
+ : (tests => 28);
-my ($y,$z);
-
-#
-# Case 1: two references, one is weakened, the other is then undef'ed.
-#
+Scalar::Util->import(qw(weaken unweaken isweak));
+# two references, one is weakened, the other is then undef'ed.
{
- my $x = "foo";
- $y = \$x;
- $z = \$x;
-}
-print "# START\n";
-Dump($y); Dump($z);
+ my ($y,$z);
-ok( ref($y) and ref($z));
+ {
+ my $x = "foo";
+ $y = \$x;
+ $z = \$x;
+ }
-print "# WEAK:\n";
-weaken($y);
-Dump($y); Dump($z);
+ ok(ref($y) and ref($z));
-ok( ref($y) and ref($z));
+ weaken($y);
+ ok(ref($y) and ref($z));
-print "# UNDZ:\n";
-undef($z);
-Dump($y); Dump($z);
+ undef($z);
+ ok(not(defined($y) and defined($z)));
-ok( not (defined($y) and defined($z)) );
-
-print "# UNDY:\n";
-undef($y);
-Dump($y); Dump($z);
+ undef($y);
+ ok(not(defined($y) and defined($z)));
+}
-ok( not (defined($y) and defined($z)) );
+# one reference, which is weakened
+{
+ my $y;
-print "# FIN:\n";
-Dump($y); Dump($z);
+ {
+ my $x = "foo";
+ $y = \$x;
+ }
+ ok(ref($y));
-#
-# Case 2: one reference, which is weakened
-#
+ weaken($y);
+ ok(not defined $y);
+}
-print "# CASE 2:\n";
+my $flag;
+# a circular structure
{
- my $x = "foo";
- $y = \$x;
-}
+ $flag = 0;
-ok( ref($y) );
-print "# BW: \n";
-Dump($y);
-weaken($y);
-print "# AW: \n";
-Dump($y);
-ok( not defined $y );
+ {
+ my $y = bless {}, 'Dest';
+ $y->{Self} = $y;
+ $y->{Flag} = \$flag;
-print "# EXITBLOCK\n";
-}
+ weaken($y->{Self});
+ ok( ref($y) );
+ }
-#
-# Case 3: a circular structure
-#
+ ok( $flag == 1 );
+ undef $flag;
+}
-my $flag = 0;
+# a more complicated circular structure
{
- my $y = bless {}, 'Dest';
- Dump($y);
- print "# 1: $y\n";
- $y->{Self} = $y;
- Dump($y);
- print "# 2: $y\n";
- $y->{Flag} = \$flag;
- print "# 3: $y\n";
- weaken($y->{Self});
- print "# WKED\n";
- ok( ref($y) );
- print "# VALS: HASH ",$y," SELF ",\$y->{Self}," Y ",\$y,
- " FLAG: ",\$y->{Flag},"\n";
- print "# VPRINT\n";
+ $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 );
}
-print "# OUT $flag\n";
-ok( $flag == 1 );
-
-print "# AFTER\n";
-
-undef $flag;
-print "# FLAGU\n";
-
-#
-# Case 4: a more complicated circular structure
-#
-
-$flag = 0;
+# deleting a weakref before the other one
{
- my $y = bless {}, 'Dest';
- my $x = bless {}, 'Dest';
- $x->{Ref} = $y;
- $y->{Ref} = $x;
- $x->{Flag} = \$flag;
- $y->{Flag} = \$flag;
- weaken($x->{Ref});
+ my ($y,$z);
+ {
+ my $x = "foo";
+ $y = \$x;
+ $z = \$x;
+ }
+
+ weaken($y);
+ undef($y);
+
+ ok(not defined $y);
+ ok(ref($z) );
}
-ok( $flag == 2 );
-
-#
-# Case 5: deleting a weakref before the other one
-#
-my ($y,$z);
+# isweakref
{
- my $x = "foo";
- $y = \$x;
- $z = \$x;
+ $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}));
}
-print "# CASE5\n";
-Dump($y);
+# 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()');
-weaken($y);
-Dump($y);
-undef($y);
+ unweaken($y);
-ok( not defined $y);
-ok( ref($z) );
+ 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');
+}
-#
-# Case 6: test isweakref
-#
+# 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;
-$a = 5;
-ok(!isweak($a));
-$b = \$a;
-ok(!isweak($b));
-weaken($b);
-ok(isweak($b));
-$b = \$a;
-ok(!isweak($b));
+ # in a MAD build, constants have refcnt 2, not 1
+ skip("Test does not work with MAD", 5) if exists $Config{mad};
-my $x = {};
-weaken($x->{Y} = \$a);
-ok(isweak($x->{Y}));
-ok(!isweak($x->{Z}));
+ $a = eval '\"hello"';
+ ok(ref($a)) or print "# didn't get a ref from eval\n";
-#
-# Case 7: test weaken on a read only ref
-#
+ $b = $a;
+ eval { weaken($b) };
+ # we didn't die
+ is($@, "");
+ ok(isweak($b));
+ is($$b, "hello");
-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
- ok($@ eq "") or print "# died with $@\n";
- ok(isweak($b));
- ok($$b eq "hello") or print "# b is '$$b'\n";
- $a="";
- ok(not $b) or print "# b didn't go away\n";
+ $a="";
+ ok(not $b) or diag("b did not go away");
}
package Dest;
sub DESTROY {
- print "# INCFLAG\n";
- ${$_[0]{Flag}} ++;
+ ${$_[0]{Flag}} ++;
}
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libscalar-list-utils-perl.git
More information about the Pkg-perl-cvs-commits
mailing list