@@ -1,3 +1,55 @@
+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()
@@ -62,6 +62,29 @@ 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;
+}
+
+/* Magic for set_subname */
+static MGVTBL subname_vtbl;
+
MODULE=List::Util PACKAGE=List::Util
void
@@ -125,11 +148,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 +164,90 @@ 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_SV: /* nothing to do */
+ break;
+ case ACC_IV:
+ sv_setiv(retsv, retiv);
+ break;
+ case ACC_NV:
+ sv_setnv(retsv, retnv);
+ break;
}
ST(0) = retsv;
@@ -258,7 +321,7 @@ CODE:
SAVESPTR(GvSV(agv));
SAVESPTR(GvSV(bgv));
GvSV(agv) = ret;
- SvSetSV(ret, args[1]);
+ SvSetMagicSV(ret, args[1]);
#ifdef dMULTICALL
if(!CvISXSUB(cv)) {
dMULTICALL;
@@ -268,7 +331,7 @@ CODE:
for(index = 2 ; index < items ; index++) {
GvSV(bgv) = args[index];
MULTICALL;
- SvSetSV(ret, *PL_stack_sp);
+ SvSetMagicSV(ret, *PL_stack_sp);
}
# ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
if(CvDEPTH(multicall_cv) > 1)
@@ -286,7 +349,7 @@ CODE:
PUSHMARK(SP);
call_sv((SV*)cv, G_SCALAR);
- SvSetSV(ret, *PL_stack_sp);
+ SvSetMagicSV(ret, *PL_stack_sp);
}
}
@@ -711,6 +774,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 +788,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 +988,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: $
@@ -966,7 +1069,7 @@ CODE:
croak("vstrings are not implemented in this release of perl");
#endif
-int
+SV *
looks_like_number(sv)
SV *sv
PROTOTYPE: $
@@ -978,46 +1081,18 @@ CODE:
}
#if PERL_BCDVERSION < 0x5008005
if(SvPOK(sv) || SvPOKp(sv)) {
- RETVAL = looks_like_number(sv);
+ RETVAL = looks_like_number(sv) ? &PL_sv_yes : &PL_sv_no;
}
else {
- RETVAL = SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
+ RETVAL = (SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK)) ? &PL_sv_yes : &PL_sv_no;
}
#else
- RETVAL = looks_like_number(sv);
+ RETVAL = looks_like_number(sv) ? &PL_sv_yes : &PL_sv_no;
#endif
OUTPUT:
RETVAL
void
-set_prototype(subref, proto)
- SV *subref
- SV *proto
-PROTOTYPE: &$
-CODE:
-{
- if(SvROK(subref)) {
- SV *sv = SvRV(subref);
- if(SvTYPE(sv) != SVt_PVCV) {
- /* not a subroutine reference */
- croak("set_prototype: not a subroutine reference");
- }
- if(SvPOK(proto)) {
- /* set the prototype */
- sv_copypv(sv, proto);
- }
- else {
- /* delete the prototype */
- SvPOK_off(sv);
- }
- }
- else {
- croak("set_prototype: not a reference");
- }
- XSRETURN(1);
-}
-
-void
openhandle(SV *sv)
PROTOTYPE: $
CODE:
@@ -1046,6 +1121,164 @@ CODE:
XSRETURN_UNDEF;
}
+MODULE=List::Util PACKAGE=Sub::Util
+
+void
+set_prototype(proto, code)
+ SV *proto
+ SV *code
+PREINIT:
+ SV *cv; /* not CV * */
+PPCODE:
+ SvGETMAGIC(code);
+ if(!SvROK(code))
+ croak("set_prototype: not a reference");
+
+ cv = SvRV(code);
+ if(SvTYPE(cv) != SVt_PVCV)
+ croak("set_prototype: not a subroutine reference");
+
+ if(SvPOK(proto)) {
+ /* set the prototype */
+ sv_copypv(cv, proto);
+ }
+ else {
+ /* delete the prototype */
+ SvPOK_off(cv);
+ }
+
+ PUSHs(code);
+ XSRETURN(1);
+
+void
+set_subname(name, sub)
+ char *name
+ SV *sub
+PREINIT:
+ CV *cv = NULL;
+ GV *gv;
+ HV *stash = CopSTASH(PL_curcop);
+ char *s, *end = NULL;
+ MAGIC *mg;
+PPCODE:
+ if (!SvROK(sub) && SvGMAGICAL(sub))
+ mg_get(sub);
+ if (SvROK(sub))
+ cv = (CV *) SvRV(sub);
+ else if (SvTYPE(sub) == SVt_PVGV)
+ cv = GvCVu(sub);
+ else if (!SvOK(sub))
+ croak(PL_no_usym, "a subroutine");
+ else if (PL_op->op_private & HINT_STRICT_REFS)
+ croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use",
+ SvPV_nolen(sub), "a subroutine");
+ else if ((gv = gv_fetchpv(SvPV_nolen(sub), FALSE, SVt_PVCV)))
+ cv = GvCVu(gv);
+ if (!cv)
+ croak("Undefined subroutine %s", SvPV_nolen(sub));
+ if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
+ croak("Not a subroutine reference");
+ for (s = name; *s++; ) {
+ if (*s == ':' && s[-1] == ':')
+ end = ++s;
+ else if (*s && s[-1] == '\'')
+ end = s;
+ }
+ s--;
+ if (end) {
+ char *namepv = savepvn(name, end - name);
+ stash = GvHV(gv_fetchpv(namepv, TRUE, SVt_PVHV));
+ Safefree(namepv);
+ name = end;
+ }
+
+ /* under debugger, provide information about sub location */
+ if (PL_DBsub && CvGV(cv)) {
+ HV *hv = GvHV(PL_DBsub);
+
+ char *new_pkg = HvNAME(stash);
+
+ char *old_name = GvNAME( CvGV(cv) );
+ char *old_pkg = HvNAME( GvSTASH(CvGV(cv)) );
+
+ int old_len = strlen(old_name) + strlen(old_pkg);
+ int new_len = strlen(name) + strlen(new_pkg);
+
+ SV **old_data;
+ char *full_name;
+
+ Newxz(full_name, (old_len > new_len ? old_len : new_len) + 3, char);
+
+ strcat(full_name, old_pkg);
+ strcat(full_name, "::");
+ strcat(full_name, old_name);
+
+ old_data = hv_fetch(hv, full_name, strlen(full_name), 0);
+
+ if (old_data) {
+ strcpy(full_name, new_pkg);
+ strcat(full_name, "::");
+ strcat(full_name, name);
+
+ SvREFCNT_inc(*old_data);
+ if (!hv_store(hv, full_name, strlen(full_name), *old_data, 0))
+ SvREFCNT_dec(*old_data);
+ }
+ Safefree(full_name);
+ }
+
+ gv = (GV *) newSV(0);
+ gv_init(gv, stash, name, s - name, TRUE);
+
+ /*
+ * set_subname needs to create a GV to store the name. The CvGV field of a
+ * CV is not refcounted, so perl wouldn't know to SvREFCNT_dec() this GV if
+ * it destroys the containing CV. We use a MAGIC with an empty vtable
+ * simply for the side-effect of using MGf_REFCOUNTED to store the
+ * actually-counted reference to the GV.
+ */
+ mg = SvMAGIC(cv);
+ while (mg && mg->mg_virtual != &subname_vtbl)
+ mg = mg->mg_moremagic;
+ if (!mg) {
+ Newxz(mg, 1, MAGIC);
+ mg->mg_moremagic = SvMAGIC(cv);
+ mg->mg_type = PERL_MAGIC_ext;
+ mg->mg_virtual = &subname_vtbl;
+ SvMAGIC_set(cv, mg);
+ }
+ if (mg->mg_flags & MGf_REFCOUNTED)
+ SvREFCNT_dec(mg->mg_obj);
+ mg->mg_flags |= MGf_REFCOUNTED;
+ mg->mg_obj = (SV *) gv;
+ SvRMAGICAL_on(cv);
+ CvANON_off(cv);
+#ifndef CvGV_set
+ CvGV(cv) = gv;
+#else
+ CvGV_set(cv, gv);
+#endif
+ PUSHs(sub);
+
+void
+subname(code)
+ SV *code
+PREINIT:
+ CV *cv;
+ GV *gv;
+PPCODE:
+ if (!SvROK(code) && SvGMAGICAL(code))
+ mg_get(code);
+
+ if(!SvROK(code) || SvTYPE(cv = (CV *)SvRV(code)) != SVt_PVCV)
+ croak("Not a subroutine reference");
+
+ if(!(gv = CvGV(cv)))
+ XSRETURN(0);
+
+ mPUSHs(newSVpvf("%s::%s", HvNAME(GvSTASH(gv)), GvNAME(gv)));
+ XSRETURN(1);
+
BOOT:
{
HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE);
@@ -2,6 +2,7 @@ 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
@@ -22,17 +23,18 @@ t/max.t
t/maxstr.t
t/min.t
t/minstr.t
-t/multicall-refcount.t
t/openhan.t
t/pair.t
t/product.t
-t/proto.t
+t/prototype.t
t/readonly.t
t/reduce.t
t/refaddr.t
t/reftype.t
+t/scalarutil-proto.t
t/shuffle.t
t/stack-corruption.t
+t/subname.t
t/sum.t
t/sum0.t
t/tainted.t
@@ -4,7 +4,7 @@
"Graham Barr <gbarr@cpan.org>"
],
"dynamic_config" : 1,
- "generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.132661",
+ "generated_by" : "ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.142060",
"license" : [
"perl_5"
],
@@ -42,5 +42,5 @@
"url" : "https://github.com/Scalar-List-Utils/Scalar-List-Utils"
}
},
- "version" : "1.35"
+ "version" : "1.41"
}
@@ -3,22 +3,22 @@ abstract: 'Common Scalar and List utility subroutines'
author:
- 'Graham Barr <gbarr@cpan.org>'
build_requires:
- ExtUtils::MakeMaker: 0
+ ExtUtils::MakeMaker: '0'
configure_requires:
- ExtUtils::MakeMaker: 0
+ 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.98, CPAN::Meta::Converter version 2.142060'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
- version: 1.4
+ version: '1.4'
name: Scalar-List-Utils
no_index:
directory:
- t
- inc
requires:
- Test::More: 0
+ Test::More: '0'
resources:
repository: https://github.com/Scalar-List-Utils/Scalar-List-Utils
-version: 1.35
+version: '1.41'
@@ -4,7 +4,7 @@
"Graham Barr <gbarr@cpan.org>"
],
"dynamic_config" : 0,
- "generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.132661",
+ "generated_by" : "ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.142060",
"license" : [
"perl_5"
],
@@ -42,5 +42,5 @@
"url" : "https://github.com/Scalar-List-Utils/Scalar-List-Utils"
}
},
- "version" : "1.35"
+ "version" : "1.41"
}
@@ -3,22 +3,22 @@ abstract: 'Common Scalar and List utility subroutines'
author:
- 'Graham Barr <gbarr@cpan.org>'
build_requires:
- ExtUtils::MakeMaker: 0
+ ExtUtils::MakeMaker: '0'
configure_requires:
- ExtUtils::MakeMaker: 0
+ 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.98, CPAN::Meta::Converter version 2.142060'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
- version: 1.4
+ version: '1.4'
name: Scalar-List-Utils
no_index:
directory:
- t
- inc
requires:
- Test::More: 0
+ Test::More: '0'
resources:
repository: https://github.com/Scalar-List-Utils/Scalar-List-Utils
-version: 1.35
+version: '1.41'
@@ -2,7 +2,7 @@ package List::Util::XS;
use strict;
use List::Util;
-our $VERSION = "1.35"; # FIXUP
+our $VERSION = "1.41"; # FIXUP
$VERSION = eval $VERSION; # FIXUP
1;
@@ -1,5 +1,3 @@
-# List::Util.pm
-#
# 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.
@@ -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.41";
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,25 @@ 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
+
+ my $bool = any { BLOCK } @list;
-=head2 any BLOCK LIST
+I<Since version 1.33.>
-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.
+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 +128,258 @@ 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 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.
-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.
+=head2 none
-=head2 none BLOCK LIST
+=head2 notall
-=head2 notall BLOCK LIST
+ my $bool = none { BLOCK } @list;
-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.
+ my $bool = notall { BLOCK } @list;
-=head2 first BLOCK LIST
+I<Since version 1.33.>
-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 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.
+
+=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 LIST
+=head2 max
-Returns the entry in the list with the highest numerical value. If the
-list is empty then C<undef> is returned.
+ 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 LIST
+=head2 maxstr
+
+ my $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 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 LIST
+=head2 min
+
+ my $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 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 LIST
+=head2 minstr
-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.
+ 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 LIST
+=head2 product
+
+ my $num = product @list;
-Returns the product of all the elements in LIST. If LIST is empty then C<1> is
-returned.
+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 LIST
+=head2 sum
+
+ my $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 sum0
-Similar to C<sum>, except this returns 0 when given an empty list, rather
+ 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.
+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 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 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 pairfirst
-=head2 pairfirst BLOCK KVLIST
+ my ( $key, $val ) = pairfirst { BLOCK } @kvlist;
-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
+ 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
-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 pairmap
-=head2 pairmap BLOCK KVLIST
+ 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 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
-=head2 pairs KVLIST
+ my @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;
...
}
-=head2 pairkeys KVLIST
+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
+
+ 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
-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
+=head2 pairvalues
- pairmap { $a } KVLIST
+ my @values = pairvalues @kvlist;
-=head2 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
+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
- pairmap { $b } KVLIST
+ @values = pairmap { $b } @kvlist
=cut
@@ -310,9 +387,11 @@ the given list. It is a more efficient version of
=cut
-=head2 shuffle LIST
+=head2 shuffle
-Returns the elements of LIST in a random order
+ my @values = shuffle @values;
+
+Returns the values of the input in a random order
@cards = shuffle 0..51 # 0..51 in a random order
@@ -320,9 +399,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 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.
=head1 SUGGESTED ADDITIONS
@@ -1,5 +1,3 @@
-# Scalar::Util.pm
-#
# 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.
@@ -14,21 +12,12 @@ 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
+ blessed refaddr reftype weaken unweaken isweak
+
+ dualvar isdual isvstring looks_like_number openhandle readonly set_prototype
tainted
- weaken
);
-our $VERSION = "1.35";
+our $VERSION = "1.41";
$VERSION = eval $VERSION;
our @EXPORT_FAIL;
@@ -57,6 +46,13 @@ sub export_fail {
@_;
}
+# 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__
@@ -74,58 +70,178 @@ 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
+
+The following functions all perform some useful activity on reference values.
-By default C<Scalar::Util> does not export any subroutines. The
-subroutines defined are
+=head2 blessed
-=head2 blessed EXPR
+ my $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 dualvar NUM, STRING
+=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
-Returns a scalar that has the value NUM in a numeric context and the
-value STRING in a string context.
+=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
+
+=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.
+
+=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).
+
+=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
+
+=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 EXPR
+=head2 isdual
+
+ my $dual = isdual( $var );
+
+I<Since version 1.26.>
-If EXPR is a scalar that is a dualvar, the result is true.
+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 +252,64 @@ You can capture its numeric and string content using:
$err = dualvar $!, $!;
$dual = isdual($err); # true
-=head2 isvstring EXPR
+=head2 isvstring
-If EXPR is a scalar which was coded as a vstring the result is true.
+ 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 EXPR
+=head2 looks_like_number
+
+ my $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 openhandle
-Returns FH if FH may be used as a filehandle and is open, or FH is a tied
-handle. Otherwise C<undef> is returned.
+ my $fh = openhandle( $fh );
+
+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 readonly
+
+ my $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 set_prototype
-=head2 reftype EXPR
+ my $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 tainted
-Return true if the result of EXPR is 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
-=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
-@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,19 +318,20 @@ 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 L</isweak> or L</weaken> you will need to use a newer release of perl.
=item Vstrings are not implemented in the version of perl
The version of perl that you are using does not implement Vstrings, to use
-C<isvstring> you will need to use a newer release of perl.
+L</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
@@ -296,10 +352,15 @@ 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.
-Except weaken and isweak which are
+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,149 @@
+# 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;
+require List::Util; # as it has the XS
+
+our @ISA = qw( Exporter );
+our @EXPORT_OK = qw(
+ prototype set_prototype
+ subname set_subname
+);
+
+our $VERSION = "1.41";
+$VERSION = eval $VERSION;
+
+=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 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;
@@ -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 ();
@@ -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;
@@ -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');
@@ -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');
@@ -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');
@@ -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;
@@ -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');
@@ -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);
@@ -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 {
@@ -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);
@@ -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 {
@@ -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);
@@ -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" );
@@ -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);
@@ -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' );
+}
@@ -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');
@@ -1,59 +0,0 @@
-#!./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 Scalar::Util ();
-use Test::More (grep { /set_prototype/ } @Scalar::Util::EXPORT_FAIL)
- ? (skip_all => 'set_prototype requires XS version')
- : (tests => 13);
-
-Scalar::Util->import('set_prototype');
-
-sub f { }
-is( prototype('f'), undef, 'no prototype');
-
-$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');
@@ -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');
@@ -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;
@@ -1,22 +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 List::Util qw(reduce min);
use Test::More;
-plan tests => 29 + ($::PERL_ONLY ? 0 : 2);
+plan tests => 30 + ($::PERL_ONLY ? 0 : 2);
my $v = reduce {};
@@ -28,7 +17,7 @@ is( $v, 9, '4-arg divide');
$v = reduce { $a / $b } 6;
is( $v, 6, 'one arg');
-@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');
@@ -167,3 +160,6 @@ 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');
@@ -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
}
@@ -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
-@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
}
@@ -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' );
@@ -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;
@@ -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;
@@ -0,0 +1,81 @@
+use strict;
+use warnings;
+
+BEGIN { $^P |= 0x210 }
+
+use Test::More tests => 18;
+
+use B::Deparse;
+use Sub::Util qw( subname set_subname );
+
+{
+ 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');
+}
+
+# vim: ft=perl
@@ -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');
+}
@@ -1,3 +1,5 @@
+#!./perl
+
use strict;
use warnings;
@@ -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;
@@ -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}} ++;
}