cpan/Scalar-List-Utils/lib/List/Util.pm List::Util
cpan/Scalar-List-Utils/lib/List/Util/XS.pm List::Util
cpan/Scalar-List-Utils/lib/Scalar/Util.pm Scalar::Util
+cpan/Scalar-List-Utils/lib/Sub/Util.pm
cpan/Scalar-List-Utils/ListUtil.xs Util extension
cpan/Scalar-List-Utils/Makefile.PL Util extension
cpan/Scalar-List-Utils/multicall.h Util extension
cpan/Scalar-List-Utils/t/openhan.t Scalar::Util
cpan/Scalar-List-Utils/t/pair.t
cpan/Scalar-List-Utils/t/product.t List::Util
-cpan/Scalar-List-Utils/t/proto.t Scalar::Util
+cpan/Scalar-List-Utils/t/prototype.t
cpan/Scalar-List-Utils/t/readonly.t Scalar::Util
cpan/Scalar-List-Utils/t/reduce.t List::Util
cpan/Scalar-List-Utils/t/refaddr.t Scalar::Util
cpan/Scalar-List-Utils/t/reftype.t Scalar::Util
+cpan/Scalar-List-Utils/t/scalarutil-proto.t
cpan/Scalar-List-Utils/t/shuffle.t List::Util
cpan/Scalar-List-Utils/t/stack-corruption.t List::Util
+cpan/Scalar-List-Utils/t/subname.t
cpan/Scalar-List-Utils/t/sum0.t
cpan/Scalar-List-Utils/t/sum.t List::Util
cpan/Scalar-List-Utils/t/tainted.t Scalar::Util
-rmdir lib/TAP/Parser/Scheduler lib/TAP/Parser/Result
-rmdir lib/TAP/Parser/Iterator lib/TAP/Parser lib/TAP/Harness
-rmdir lib/TAP/Formatter/File lib/TAP/Formatter/Console
- -rmdir lib/TAP/Formatter lib/TAP lib/Sys/Syslog lib/Sys lib/Search
- -rmdir lib/Scalar lib/Pod/Text lib/Pod/Simple lib/Pod/Perldoc
- -rmdir lib/PerlIO/via lib/PerlIO lib/Perl lib/Parse/CPAN lib/Parse
- -rmdir lib/Params lib/Net/FTP lib/Module/Load lib/Module/CoreList
- -rmdir lib/Module lib/Memoize lib/Math/BigInt lib/Math/BigFloat
- -rmdir lib/Math lib/MIME lib/Locale/Maketext lib/Locale/Codes
- -rmdir lib/Locale lib/List/Util lib/List lib/JSON/PP lib/JSON lib/IPC
- -rmdir lib/IO/Uncompress/Adapter lib/IO/Uncompress lib/IO/Socket
- -rmdir lib/IO/Compress/Zlib lib/IO/Compress/Zip lib/IO/Compress/Gzip
- -rmdir lib/IO/Compress/Base lib/IO/Compress/Adapter lib/IO/Compress
- -rmdir lib/IO lib/I18N/LangTags lib/I18N lib/Hash/Util lib/Hash
- -rmdir lib/HTTP lib/Filter/Util lib/Filter lib/File/Spec
- -rmdir lib/ExtUtils/Typemaps lib/ExtUtils/ParseXS
- -rmdir lib/ExtUtils/MakeMaker lib/ExtUtils/Liblist
- -rmdir lib/ExtUtils/Constant lib/ExtUtils/Command
+ -rmdir lib/TAP/Formatter lib/TAP lib/Sys/Syslog lib/Sys lib/Sub
+ -rmdir lib/Search lib/Scalar lib/Pod/Text lib/Pod/Simple
+ -rmdir lib/Pod/Perldoc lib/PerlIO/via lib/PerlIO lib/Perl
+ -rmdir lib/Parse/CPAN lib/Parse lib/Params lib/Net/FTP lib/Module/Load
+ -rmdir lib/Module/CoreList lib/Module lib/Memoize lib/Math/BigInt
+ -rmdir lib/Math/BigFloat lib/Math lib/MIME lib/Locale/Maketext
+ -rmdir lib/Locale/Codes lib/Locale lib/List/Util lib/List lib/JSON/PP
+ -rmdir lib/JSON lib/IPC lib/IO/Uncompress/Adapter lib/IO/Uncompress
+ -rmdir lib/IO/Socket lib/IO/Compress/Zlib lib/IO/Compress/Zip
+ -rmdir lib/IO/Compress/Gzip lib/IO/Compress/Base
+ -rmdir lib/IO/Compress/Adapter lib/IO/Compress lib/IO
+ -rmdir lib/I18N/LangTags lib/I18N lib/Hash/Util lib/Hash lib/HTTP
+ -rmdir lib/Filter/Util lib/Filter lib/File/Spec lib/ExtUtils/Typemaps
+ -rmdir lib/ExtUtils/ParseXS lib/ExtUtils/MakeMaker
+ -rmdir lib/ExtUtils/Liblist lib/ExtUtils/Constant lib/ExtUtils/Command
-rmdir lib/ExtUtils/CBuilder/Platform/Windows
-rmdir lib/ExtUtils/CBuilder/Platform lib/ExtUtils/CBuilder
-rmdir lib/Exporter lib/Encode/Unicode lib/Encode/MIME/Header
},
'Scalar-List-Utils' => {
- 'DISTRIBUTION' => 'PEVANS/Scalar-List-Utils-1.39.tar.gz',
+ 'DISTRIBUTION' => 'PEVANS/Scalar-List-Utils-1.40.tar.gz',
'FILES' => q[cpan/Scalar-List-Utils],
},
return ACC_NV;
}
+/* Magic for set_subname */
+static MGVTBL subname_vtbl;
+
MODULE=List::Util PACKAGE=List::Util
void
retsv = TARG;
switch(accum) {
+ case ACC_SV: /* nothing to do */
+ break;
case ACC_IV:
sv_setiv(retsv, retiv);
break;
croak("vstrings are not implemented in this release of perl");
#endif
-int
+SV *
looks_like_number(sv)
SV *sv
PROTOTYPE: $
}
#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:
-{
- SvGETMAGIC(subref);
- 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:
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);
+
+ 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);
+
+ SV** 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);
all any first min max minstr maxstr none notall product reduce sum sum0 shuffle
pairmap pairgrep pairfirst pairs pairkeys pairvalues
);
-our $VERSION = "1.39";
+our $VERSION = "1.40";
our $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
The remaining list-reduction functions are all specialisations of this generic
idea.
-=head2 $b = any { BLOCK } @list
+=head2 any
+
+ my $bool = any { BLOCK } @list;
I<Since version 1.33.>
# at least one string has more than 10 characters
}
-=head2 $b = all { BLOCK } @list
+=head2 all
+
+ my $bool = all { BLOCK } @list;
I<Since version 1.33.>
-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.
+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.
+
+=head2 none
-=head2 $b = none { BLOCK } @list
+=head2 notall
-=head2 $b = notall { BLOCK } @list
+ my $bool = none { BLOCK } @list;
+
+ my $bool = 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 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.
+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
-=head2 $val = first { BLOCK } @list
+ 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
$foo = first { $_ > $value } @list # first value in @list which
# is greater than $value
-=head2 $num = max @list
+=head2 max
+
+ my $num = max @list;
Returns the entry in the list with the highest numerical value. If the list is
empty then C<undef> is returned.
$foo = max 3,9,12 # 12
$foo = max @bar, @baz # whatever
-=head2 $str = maxstr @list
+=head2 maxstr
+
+ my $str = maxstr @list;
-Similar to C<max>, but treats all the entries in the list as strings and
+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 "hello","world" # "world"
$foo = maxstr @bar, @baz # whatever
-=head2 $num = min @list
+=head2 min
+
+ my $num = min @list;
-Similar to C<max> but returns the entry in the list with the lowest numerical
+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 $str = minstr @list
+=head2 minstr
-Similar to C<min>, but treats all the entries in the list as strings and
+ 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 "hello","world" # "hello"
$foo = minstr @bar, @baz # whatever
-=head2 $num = product @list
+=head2 product
+
+ my $num = product @list;
I<Since version 1.35.>
$foo = product 1..10 # 3628800
$foo = product 3,9,12 # 324
-=head2 $num_or_undef = sum @list
+=head2 sum
+
+ my $num_or_undef = sum @list;
Returns the numerical sum of all the elements in C<@list>. For backwards
compatibility, if C<@list> is empty then C<undef> is returned.
$foo = sum 3,9,12 # 24
$foo = sum @bar, @baz # whatever
-=head2 $num = sum0 @list
+=head2 sum0
+
+ my $num = sum0 @list;
I<Since version 1.26.>
-Similar to C<sum>, except this returns 0 when given an empty list, rather than
-C<undef>.
+Similar to L</sum>, except this returns 0 when given an empty list, rather
+than C<undef>.
=cut
=cut
-=head2 @kvlist = pairgrep { BLOCK } @kvlist
+=head2 pairgrep
+
+ my @kvlist = pairgrep { BLOCK } @kvlist;
-=head2 $count = pairgrep { BLOCK } @kvlist
+ my $count = pairgrep { BLOCK } @kvlist;
I<Since version 1.29.>
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
-=head2 $found = pairfirst { BLOCK } @kvlist
+ my ( $key, $val ) = pairfirst { BLOCK } @kvlist;
+
+ my $found = pairfirst { BLOCK } @kvlist;
I<Since version 1.30.>
-Similar to the C<first> function, but interprets the given list as an
+Similar to the L</first> function, but interprets the given list as an
even-sized list of pairs. It invokes the C<BLOCK> multiple times, in scalar
context, with C<$a> and C<$b> set to successive pairs of values from the
C<@kvlist>.
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
+
+ my @list = pairmap { BLOCK } @kvlist;
-=head2 $count = pairmap { BLOCK } @kvlist
+ my $count = pairmap { BLOCK } @kvlist;
I<Since version 1.29.>
See L</KNOWN BUGS> for a known-bug with C<pairmap>, and a workaround.
-=head2 @pairs = pairs @kvlist
+=head2 pairs
+
+ my @pairs = pairs @kvlist;
I<Since version 1.29.>
...
}
-=head2 @keys = pairkeys @kvlist
+=head2 pairkeys
+
+ my @keys = pairkeys @kvlist;
I<Since version 1.29.>
@keys = pairmap { $a } @kvlist
-=head2 @values = pairvalues @kvlist
+=head2 pairvalues
+
+ my @values = pairvalues @kvlist;
I<Since version 1.29.>
=cut
-=head2 @values = shuffle @values
+=head2 shuffle
+
+ my @values = shuffle @values;
Returns the values of the input in a random order
L<https://rt.cpan.org/Ticket/Display.html?id=95409>
-If the block of code given to C<pairmap> contains lexical variables that are
+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:
use strict;
use List::Util;
-our $VERSION = "1.39"; # FIXUP
+our $VERSION = "1.40"; # FIXUP
$VERSION = eval $VERSION; # FIXUP
1;
our @EXPORT_OK = qw(
blessed refaddr reftype weaken unweaken isweak
- dualvar isdual isvstring looks_like_number openhandle readonly set_prototype tainted
+ dualvar isdual isvstring looks_like_number openhandle readonly set_prototype
+ tainted
);
-our $VERSION = "1.39";
+our $VERSION = "1.40";
$VERSION = eval $VERSION;
our @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__
The following functions all perform some useful activity on reference values.
-=head2 $pkg = blessed( $ref )
+=head2 blessed
+
+ my $pkg = blessed( $ref );
If C<$ref> is a blessed reference the name of the package that it is blessed
into is returned. Otherwise C<undef> is returned.
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.
-=head2 $addr = refaddr( $ref )
+=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.
$obj = bless {}, "Foo";
$addr = refaddr $obj; # eg 88123488
-=head2 $type = reftype( $ref )
+=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>
$obj = bless {}, "Foo";
$type = reftype $obj; # HASH
-=head2 weaken( REF )
+=head2 weaken
-The lvalue C<REF> will be turned into a weak reference. This means that it
+ 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
destroyed because there is now always a strong reference to them in the @object
array.
-=head2 unweaken( REF )
+=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
-C<weaken()>.
+L</weaken>.
This function is slightly neater and more convenient than the
otherwise-equivalent code
(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 )
+=head2 isweak
+
+ my $weak = isweak( $ref );
Returns true if C<$ref> is a weak reference.
=head1 OTHER FUNCTIONS
-=head2 $var = dualvar( $num, $string )
+=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.
$num = $foo + 2; # 12
$str = $foo . " world"; # Hello world
-=head2 $dual = isdual( $var )
+=head2 isdual
+
+ my $dual = isdual( $var );
I<Since version 1.26.>
$err = dualvar $!, $!;
$dual = isdual($err); # true
-=head2 $vstring = isvstring( $var )
+=head2 isvstring
+
+ my $vstring = isvstring( $var );
If C<$var> is a scalar which was coded as a vstring the result is true.
$fmt = isvstring($vs) ? "%vd" : "%s"; #true
printf($fmt,$vs);
-=head2 $isnum = looks_like_number( $var )
+=head2 looks_like_number
+
+ my $isnum = looks_like_number( $var );
Returns true if perl thinks C<$var> is a number. See
L<perlapi/looks_like_number>.
-=head2 $fh = openhandle( $fh )
+=head2 openhandle
+
+ 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(*NOTOPEN); # undef
$fh = openhandle("scalar"); # undef
-=head2 $ro = readonly( $var )
+=head2 readonly
+
+ my $ro = readonly( $var );
Returns true if C<$var> is readonly.
$readonly = foo($bar); # false
$readonly = foo(0); # true
-=head2 $code = set_prototype( $code, $prototype )
+=head2 set_prototype
+
+ my $code = set_prototype( $code, $prototype );
Sets the prototype of the function given by the C<$code> reference, or deletes
it if C<$prototype> is C<undef>. Returns the C<$code> reference itself.
set_prototype \&foo, '$$';
-=head2 $t = tainted( $var )
+=head2 tainted
+
+ my $t = tainted( $var );
Return true if C<$var> is tainted.
=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.
+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
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
--- /dev/null
+# 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.40";
+$VERSION = eval $VERSION;
+
+=head1 NAME
+
+Sub::Util - A selection of utility subroutines for subs and CODE references
+
+=head1 SYNOPSIS
+
+ use Sub::Util qw( 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 )
+
+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;
--- /dev/null
+#!./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');
--- /dev/null
+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
/SelfLoader.pm
/Socket.pm
/Storable.pm
+/Sub/
/Sys/
/TAP/
/Term/
ext/dynaloader/dynaloader.pm Verbatim line length including indents exceeds 79 by 1
ext/file-find/lib/file/find.pm Verbatim line length including indents exceeds 79 by 1
ext/file-glob/glob.pm Verbatim line length including indents exceeds 79 by 15
+ext/hash-util-fieldhash/lib/hash/util/fieldhash.pm Apparent broken link 1
ext/hash-util/lib/hash/util.pm Verbatim line length including indents exceeds 79 by 2
ext/pod-html/testdir/perlpodspec-copy.pod Verbatim line length including indents exceeds 79 by 8
ext/pod-html/testdir/perlvar-copy.pod ? Should you be using L<...> instead of 3
-if exist $(LIBDIR)\Pod\Text rmdir /s /q $(LIBDIR)\Pod\Text
-if exist $(LIBDIR)\Scalar rmdir /s /q $(LIBDIR)\Scalar
-if exist $(LIBDIR)\Search rmdir /s /q $(LIBDIR)\Search
+ -if exist $(LIBDIR)\Sub rmdir /s /q $(LIBDIR)\Sub
-if exist $(LIBDIR)\Sys rmdir /s /q $(LIBDIR)\Sys
-if exist $(LIBDIR)\TAP rmdir /s /q $(LIBDIR)\TAP
-if exist $(LIBDIR)\Term rmdir /s /q $(LIBDIR)\Term
-if exist $(LIBDIR)\Pod\Text rmdir /s /q $(LIBDIR)\Pod\Text
-if exist $(LIBDIR)\Scalar rmdir /s /q $(LIBDIR)\Scalar
-if exist $(LIBDIR)\Search rmdir /s /q $(LIBDIR)\Search
+ -if exist $(LIBDIR)\Sub rmdir /s /q $(LIBDIR)\Sub
-if exist $(LIBDIR)\Sys rmdir /s /q $(LIBDIR)\Sys
-if exist $(LIBDIR)\TAP rmdir /s /q $(LIBDIR)\TAP
-if exist $(LIBDIR)\Term rmdir /s /q $(LIBDIR)\Term
https://perl5.git.perl.org / perl5.git / commitdiff