From 8c167fd9e566437299bc51ef3946ff13ed3a5005 Mon Sep 17 00:00:00 2001 From: Chris 'BinGOs' Williams Date: Thu, 16 Jan 2014 15:49:51 +0000 Subject: [PATCH] Update Scalar-List-utils to CPAN version 1.36 [DELTA] 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) --- Porting/Maintainers.pl | 2 +- cpan/Scalar-List-Utils/ListUtil.xs | 52 ++++++ cpan/Scalar-List-Utils/lib/List/Util.pm | 235 ++++++++++++------------ cpan/Scalar-List-Utils/lib/List/Util/XS.pm | 2 +- cpan/Scalar-List-Utils/lib/Scalar/Util.pm | 284 +++++++++++++++-------------- cpan/Scalar-List-Utils/t/max.t | 2 +- cpan/Scalar-List-Utils/t/min.t | 2 +- cpan/Scalar-List-Utils/t/product.t | 2 +- cpan/Scalar-List-Utils/t/refaddr.t | 2 +- cpan/Scalar-List-Utils/t/sum.t | 2 +- cpan/Scalar-List-Utils/t/weak.t | 265 ++++++++++++--------------- 11 files changed, 446 insertions(+), 404 deletions(-) diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index bdbf9be..8acfb0e 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -976,7 +976,7 @@ use File::Glob qw(:case); }, 'Scalar-List-Utils' => { - 'DISTRIBUTION' => 'PEVANS/Scalar-List-Utils-1.35.tar.gz', + 'DISTRIBUTION' => 'PEVANS/Scalar-List-Utils-1.36.tar.gz', 'FILES' => q[cpan/Scalar-List-Utils], }, diff --git a/cpan/Scalar-List-Utils/ListUtil.xs b/cpan/Scalar-List-Utils/ListUtil.xs index 96c6d2b..af869ce 100644 --- a/cpan/Scalar-List-Utils/ListUtil.xs +++ b/cpan/Scalar-List-Utils/ListUtil.xs @@ -62,6 +62,22 @@ 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 + +#if PERL_VERSION < 12 +static void Perl_ck_warner(pTHX_ U32 err, const char* pat, ...) +{ + if (Perl_ckwarn(aTHX_ err)) { + va_list args; + va_start(args, pat); + vwarner(err, pat, &args); + va_end(args); + } +} +#endif + MODULE=List::Util PACKAGE=List::Util void @@ -922,6 +938,42 @@ 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)) { + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "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_clear(sv); + 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: $ diff --git a/cpan/Scalar-List-Utils/lib/List/Util.pm b/cpan/Scalar-List-Utils/lib/List/Util.pm index 452dd29..429ad3e 100644 --- a/cpan/Scalar-List-Utils/lib/List/Util.pm +++ b/cpan/Scalar-List-Utils/lib/List/Util.pm @@ -1,5 +1,3 @@ -# List::Util.pm -# # Copyright (c) 1997-2009 Graham Barr . 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.36"; our $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -50,10 +48,10 @@ List::Util - A selection of general-utility list subroutines =head1 DESCRIPTION -C 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 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 does not export any subroutines. @@ -65,22 +63,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 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 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. If C<@list> is empty then +C is returned. If C<@list> only contains one element then that element +is returned and C is not executed. -The following examples all demonstrate how C 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 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 +97,21 @@ 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 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 produce an identity value, then make +sure that you always pass that identity value as the first argument to prevent C being returned $foo = reduce { $a + $b } 0, @values; # sum with 0 identity value -The remaining list-reduction functions are all specialisations of this -generic idea. +The remaining list-reduction functions are all specialisations of this generic +idea. -=head2 any BLOCK LIST +=head2 $b = any { BLOCK } @list -Similar to C in that it evaluates BLOCK setting C<$_> to each element -of LIST in turn. C 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 in that it evaluates C setting C<$_> to each element +of C<@list> in turn. C returns true if any element makes the C +return a true value. If C never returns true or C<@list> was empty then +it returns false. Many cases of using C in a conditional can be written using C instead, as it can short-circuit after the first true result. @@ -122,164 +120,170 @@ instead, as it can short-circuit after the first true result. # at least one string has more than 10 characters } -=head2 all BLOCK LIST +=head2 $b = all { BLOCK } @list -Similar to C, except that it requires all elements of the LIST to make -the BLOCK return true. If any element returns false, then it returns true. If -the BLOCK never returns false or the LIST was empty then it returns true. +Similar to C, except that it requires all elements of the C<@list> to make +the C return true. If any element returns false, then it returns false. +If the C never returns false or the C<@list> was empty then it returns +true. -=head2 none BLOCK LIST +=head2 $b = none { BLOCK } @list -=head2 notall BLOCK LIST +=head2 $b = notall { BLOCK } @list Similar to C and C, but with the return sense inverted. C -returns true if no value in the LIST causes the BLOCK to return true, and -C returns true if not all of the values do. +returns true only if no value in the LIST causes the BLOCK to return true, and +C returns true only if not all of the values do. -=head2 first BLOCK LIST +=head2 $val = first { BLOCK } @list -Similar to C in that it evaluates BLOCK setting C<$_> to each element -of LIST in turn. C returns the first element where the result from -BLOCK is a true value. If BLOCK never returns true or LIST was empty then -C is returned. +Similar to C in that it evaluates C setting C<$_> to each element +of C<@list> in turn. C returns the first element where the result from +C is a true value. If C never returns true or C<@list> was empty +then C is returned. $foo = first { defined($_) } @list # first defined value in @list $foo = first { $_ > $value } @list # first value in @list which # is greater than $value -=head2 max LIST +=head2 $num = max @list -Returns the entry in the list with the highest numerical value. If the -list is empty then C is returned. +Returns the entry in the list with the highest numerical value. If the list is +empty then C is returned. $foo = max 1..10 # 10 $foo = max 3,9,12 # 12 $foo = max @bar, @baz # whatever -=head2 maxstr LIST +=head2 $str = maxstr @list -Similar to C, but treats all the entries in the list as strings -and returns the highest string as defined by the C operator. -If the list is empty then C is returned. +Similar to C, but treats all the entries in the list as strings and +returns the highest string as defined by the C operator. If the list is +empty then C is returned. $foo = maxstr 'A'..'Z' # 'Z' $foo = maxstr "hello","world" # "world" $foo = maxstr @bar, @baz # whatever -=head2 min LIST +=head2 $num = min @list -Similar to C but returns the entry in the list with the lowest -numerical value. If the list is empty then C is returned. +Similar to C but returns the entry in the list with the lowest numerical +value. If the list is empty then C is returned. $foo = min 1..10 # 1 $foo = min 3,9,12 # 3 $foo = min @bar, @baz # whatever -=head2 minstr LIST +=head2 $str = minstr @list -Similar to C, but treats all the entries in the list as strings -and returns the lowest string as defined by the C operator. -If the list is empty then C is returned. +Similar to C, but treats all the entries in the list as strings and +returns the lowest string as defined by the C operator. If the list is +empty then C is returned. $foo = minstr 'A'..'Z' # 'A' $foo = minstr "hello","world" # "hello" $foo = minstr @bar, @baz # whatever -=head2 product LIST +=head2 $num = product @list -Returns the product of all the elements in LIST. If LIST is empty then C<1> is -returned. +Returns the numerical product of all the elements in C<@list>. If C<@list> is +empty then C<1> is returned. $foo = product 1..10 # 3628800 $foo = product 3,9,12 # 324 -=head2 sum LIST +=head2 $num_or_undef = sum @list -Returns the sum of all the elements in LIST. If LIST is empty then -C is returned. +Returns the numerical sum of all the elements in C<@list>. For backwards +compatibility, if C<@list> is empty then C is returned. $foo = sum 1..10 # 55 $foo = sum 3,9,12 # 24 $foo = sum @bar, @baz # whatever -=head2 sum0 LIST +=head2 $num = sum0 @list -Similar to C, except this returns 0 when given an empty list, rather -than C. +Similar to C, except this returns 0 when given an empty list, rather than +C. =cut =head1 KEY/VALUE PAIR LIST FUNCTIONS -The following set of functions, all inspired by L, 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, consume an +even-sized list of pairs. The pairs may be key/value associations from a hash, +or just a list of values. The functions will all preserve the original ordering +of the pairs, and will not be confused by multiple pairs having the same "key" +value - nor even do they require that the first of each pair be a plain string. =cut -=head2 pairgrep BLOCK KVLIST +=head2 @kvlist = pairgrep { BLOCK } @kvlist + +=head2 $count = pairgrep { BLOCK } @kvlist Similar to perl's C 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 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 returned true in list context, or the count of the B 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, C 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 aliasing C<$_> to list elements, C 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 BLOCK KVLIST +=head2 ( $key, $val ) = pairfirst { BLOCK } @kvlist + +=head2 $found = pairfirst { BLOCK } @kvlist Similar to the C function, but interprets the given list as an -even-sized list of pairs. It invokes the BLOCK multiple times, in scalar +even-sized list of pairs. It invokes the C 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 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, C 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 aliasing C<$_> to list elements, C aliases C<$a> and +C<$b> to elements of the given list. Any modifications of it by the code block +will be visible to the caller. + +=head2 @list = pairmap { BLOCK } @kvlist -=head2 pairmap BLOCK KVLIST +=head2 $count = pairmap { BLOCK } @kvlist Similar to perl's C 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 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 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, C 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 aliasing C<$_> to list elements, C 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 pairs KVLIST +=head2 @pairs = pairs @kvlist -A convenient shortcut to operating on even-sized lists of pairs, this -function returns a list of ARRAY references, each containing two items from -the given list. It is a more efficient version of +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 - pairmap { [ $a, $b ] } KVLIST + @pairs = pairmap { [ $a, $b ] } @kvlist It is most convenient to use in a C loop, for example: @@ -288,21 +292,21 @@ It is most convenient to use in a C loop, for example: ... } -=head2 pairkeys KVLIST +=head2 @keys = pairkeys @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 +A convenient shortcut to operating on even-sized lists of pairs, this function +returns a list of the the first values of each of the pairs in the given list. +It is a more efficient version of - pairmap { $a } KVLIST + @keys = pairmap { $a } @kvlist -=head2 pairvalues KVLIST +=head2 @values = pairvalues @kvlist -A convenient shortcut to operating on even-sized lists of pairs, this -function returns a list of the the second values of each of the pairs in -the given list. It is a more efficient version of +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 +314,9 @@ the given list. It is a more efficient version of =cut -=head2 shuffle LIST +=head2 @values = shuffle @values -Returns the elements of LIST in a random order +Returns the values of the input in a random order @cards = shuffle 0..51 # 0..51 in a random order @@ -320,9 +324,8 @@ 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. +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. =head1 SUGGESTED ADDITIONS diff --git a/cpan/Scalar-List-Utils/lib/List/Util/XS.pm b/cpan/Scalar-List-Utils/lib/List/Util/XS.pm index 0625a0a..15f581d 100644 --- a/cpan/Scalar-List-Utils/lib/List/Util/XS.pm +++ b/cpan/Scalar-List-Utils/lib/List/Util/XS.pm @@ -2,7 +2,7 @@ package List::Util::XS; use strict; use List::Util; -our $VERSION = "1.35"; # FIXUP +our $VERSION = "1.36"; # FIXUP $VERSION = eval $VERSION; # FIXUP 1; diff --git a/cpan/Scalar-List-Utils/lib/Scalar/Util.pm b/cpan/Scalar-List-Utils/lib/Scalar/Util.pm index edcaf1c..6b97719 100644 --- a/cpan/Scalar-List-Utils/lib/Scalar/Util.pm +++ b/cpan/Scalar-List-Utils/lib/Scalar/Util.pm @@ -1,5 +1,3 @@ -# Scalar::Util.pm -# # Copyright (c) 1997-2007 Graham Barr . All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. @@ -14,21 +12,11 @@ require List::Util; # List::Util loads the XS our @ISA = qw(Exporter); our @EXPORT_OK = qw( - blessed - dualvar - isdual - isvstring - isweak - looks_like_number - openhandle - readonly - refaddr - reftype - set_prototype - tainted - weaken + blessed refaddr reftype weaken unweaken isweak + + dualvar isdual isvstring looks_like_number openhandle readonly set_prototype tainted ); -our $VERSION = "1.35"; +our $VERSION = "1.36"; $VERSION = eval $VERSION; our @EXPORT_FAIL; @@ -74,58 +62,158 @@ Scalar::Util - A selection of general-utility scalar subroutines =head1 DESCRIPTION -C 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 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 does not export any subroutines. + +=cut + +=head1 FUNCTIONS FOR REFERENCES -By default C does not export any subroutines. The -subroutines defined are +The following functions all perform some useful activity on reference values. -=head2 blessed EXPR +=head2 $pkg = blessed( $ref ) -If EXPR evaluates to a blessed reference the name of the package -that it is blessed into is returned. Otherwise C is returned. +If C<$ref> is a blessed reference the name of the package that it is blessed +into is returned. Otherwise C 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) because the package name C<"0"> is defined yet -false. +C) because the package name C<"0"> is defined yet false. + +=head2 $addr = refaddr( $ref ) + +If C<$ref> is reference the internal memory address of the referenced value is +returned as a plain integer. Otherwise C is returned. + + $addr = refaddr "string"; # undef + $addr = refaddr \$var; # eg 12345678 + $addr = refaddr []; # eg 23456784 + + $obj = bless {}, "Foo"; + $addr = refaddr $obj; # eg 88123488 + +=head2 $type = reftype( $ref ) + +If C<$ref> is a reference the basic Perl type of the variable referenced is +returned as a plain string (such as C or C). Otherwise C +is returned. + + $type = reftype "string"; # undef + $type = reftype \$var; # SCALAR + $type = reftype []; # ARRAY + + $obj = bless {}, "Foo"; + $type = reftype $obj; # HASH + +=head2 weaken( REF ) + +The lvalue C 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, for instance +when grepping through a list of weakened references to objects that may have +been destroyed already: + + @object = grep { defined } @object; + +This will indeed remove all references to destroyed objects, but the remaining +references to objects will be strong, causing the remaining objects to never be +destroyed because there is now always a strong reference to them in the @object +array. + +=head2 unweaken( REF ) + +The lvalue C 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. + +This function is slightly neater and more convenient than the +otherwise-equivalent code + + my $tmp = $REF; + undef $REF; + $REF = $tmp; + +(because in particular, simply assigning a weak reference back to itself does +not work to unweaken it; C<$REF = $REF> does not work). + +=head2 $weak = isweak( $ref ) + +Returns true if C<$ref> is a weak reference. + + $ref = \$foo; + $weak = isweak($ref); # false + weaken($ref); + $weak = isweak($ref); # true -=head2 dualvar NUM, STRING +B: Copying a weak reference creates a normal, strong, reference. + + $copy = $ref; + $weak = isweak($copy); # false -Returns a scalar that has the value NUM in a numeric context and the -value STRING in a string context. +=head1 OTHER FUNCTIONS + +=head2 $var = dualvar( $num, $string ) + +Returns a scalar that has the value C<$num> in a numeric context and the value +C<$string> in a string context. $foo = dualvar 10, "Hello"; $num = $foo + 2; # 12 $str = $foo . " world"; # Hello world -=head2 isdual EXPR +=head2 $dual = isdual( $var ) -If EXPR is a scalar that is a dualvar, the result is true. +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 +224,52 @@ You can capture its numeric and string content using: $err = dualvar $!, $!; $dual = isdual($err); # true -=head2 isvstring EXPR +=head2 $vstring = isvstring( $var ) -If EXPR is a scalar which was coded as a vstring the result is true. +If C<$var> is a scalar which was coded as a vstring the result is true. $vs = v49.46.48; $fmt = isvstring($vs) ? "%vd" : "%s"; #true printf($fmt,$vs); -=head2 looks_like_number EXPR +=head2 $isnum = looks_like_number( $var ) -Returns true if perl thinks EXPR is a number. See +Returns true if perl thinks C<$var> is a number. See L. -=head2 openhandle FH +=head2 $fh = openhandle( $fh ) -Returns FH if FH may be used as a filehandle and is open, or FH is a tied -handle. Otherwise C is returned. +Returns C<$fh> itself if C<$fh> may be used as a filehandle and is open, or is +is a tied handle. Otherwise C is returned. $fh = openhandle(*STDIN); # \*STDIN $fh = openhandle(\*STDIN); # \*STDIN $fh = openhandle(*NOTOPEN); # undef $fh = openhandle("scalar"); # undef -=head2 readonly SCALAR +=head2 $ro = readonly( $var ) -Returns true if SCALAR is readonly. +Returns true if C<$var> is readonly. sub foo { readonly($_[0]) } $readonly = foo($bar); # false $readonly = foo(0); # true -=head2 refaddr EXPR - -If EXPR evaluates to a reference the internal memory address of -the referenced value is returned. Otherwise C is returned. - - $addr = refaddr "string"; # undef - $addr = refaddr \$var; # eg 12345678 - $addr = refaddr []; # eg 23456784 - - $obj = bless {}, "Foo"; - $addr = refaddr $obj; # eg 88123488 - -=head2 reftype EXPR +=head2 $code = set_prototype( $code, $prototype ) -If EXPR evaluates to a reference the type of the variable referenced -is returned. Otherwise C 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. Returns the C<$code> reference itself. set_prototype \&foo, '$$'; -=head2 tainted EXPR +=head2 $t = tainted( $var ) -Return true if the result of EXPR is tainted +Return true if C<$var> is tainted. $taint = tainted("constant"); # false $taint = tainted($ENV{PWD}); # true if running under -T -=head2 weaken REF - -REF will be turned into a weak reference. This means that it will not -hold a reference count on the object it references. Also when the reference -count on that object reaches zero, REF will be set to undef. - -This is useful for keeping copies of references , but you don't want to -prevent the object being DESTROY-ed at its usual time. - - { - my $var; - $ref = \$var; - weaken($ref); # Make $ref a weak reference - } - # $ref is now undef - -Note that if you take a copy of a scalar with a weakened reference, -the copy will be a strong reference. - - my $var; - my $foo = \$var; - weaken($foo); # Make $foo a weak reference - my $bar = $foo; # $bar is now a strong reference - -This may be less obvious in other situations, such as C, 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: Copying a weak reference creates a normal, strong, reference. - - $copy = $ref; - $weak = isweak($copy); # false - =head1 DIAGNOSTICS Module use may give one of the following errors during import. @@ -263,8 +278,8 @@ Module use may give one of the following errors during import. =item Weak references are not implemented in the version of perl -The version of perl that you are using does not implement weak references, to use -C or C you will need to use a newer release of perl. +The version of perl that you are using does not implement weak references, to +use C or C you will need to use a newer release of perl. =item Vstrings are not implemented in the version of perl @@ -273,9 +288,10 @@ C you will need to use a newer release of perl. =item C is only available with the XS version of Scalar::Util -C 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 contains both perl and C implementations of many of its +functions so that those without access to a C compiler may still use it. +However some of the functions are only available when a C compiler was +available to compile the XS version of the extension. At present that list is: weaken, isweak, dualvar, isvstring, set_prototype diff --git a/cpan/Scalar-List-Utils/t/max.t b/cpan/Scalar-List-Utils/t/max.t index 9607015..f12e00c 100644 --- a/cpan/Scalar-List-Utils/t/max.t +++ b/cpan/Scalar-List-Utils/t/max.t @@ -50,7 +50,7 @@ is($v, 3, 'overload'); use overload '""' => sub { ${$_[0]} }, - '+0' => sub { ${$_[0]} }, + '0+' => sub { ${$_[0]} }, '>' => sub { ${$_[0]} > ${$_[1]} }, fallback => 1; sub new { diff --git a/cpan/Scalar-List-Utils/t/min.t b/cpan/Scalar-List-Utils/t/min.t index 8d5be5e..795fdca 100644 --- a/cpan/Scalar-List-Utils/t/min.t +++ b/cpan/Scalar-List-Utils/t/min.t @@ -49,7 +49,7 @@ is($v, 1, 'overload'); use overload '""' => sub { ${$_[0]} }, - '+0' => sub { ${$_[0]} }, + '0+' => sub { ${$_[0]} }, '<' => sub { ${$_[0]} < ${$_[1]} }, fallback => 1; sub new { diff --git a/cpan/Scalar-List-Utils/t/product.t b/cpan/Scalar-List-Utils/t/product.t index bed20cf..9f1aa56 100644 --- a/cpan/Scalar-List-Utils/t/product.t +++ b/cpan/Scalar-List-Utils/t/product.t @@ -49,7 +49,7 @@ is($v, 8, 'overload'); use overload '""' => sub { ${$_[0]} }, - '+0' => sub { ${$_[0]} }, + '0+' => sub { ${$_[0]} }, fallback => 1; sub new { my $class = shift; diff --git a/cpan/Scalar-List-Utils/t/refaddr.t b/cpan/Scalar-List-Utils/t/refaddr.t index 35ad40f..cc93834 100644 --- a/cpan/Scalar-List-Utils/t/refaddr.t +++ b/cpan/Scalar-List-Utils/t/refaddr.t @@ -73,7 +73,7 @@ package FooBar; use overload '0+' => sub { 10 }, '+' => sub { 10 + $_[1] }, - '"' => sub { "10" }; + '""' => sub { "10" }; package MyTie; diff --git a/cpan/Scalar-List-Utils/t/sum.t b/cpan/Scalar-List-Utils/t/sum.t index 3615b4a..a0e5c1e 100644 --- a/cpan/Scalar-List-Utils/t/sum.t +++ b/cpan/Scalar-List-Utils/t/sum.t @@ -49,7 +49,7 @@ is($v, 6, 'overload'); use overload '""' => sub { ${$_[0]} }, - '+0' => sub { ${$_[0]} }, + '0+' => sub { ${$_[0]} }, fallback => 1; sub new { my $class = shift; diff --git a/cpan/Scalar-List-Utils/t/weak.t b/cpan/Scalar-List-Utils/t/weak.t index f014113..266640a 100644 --- a/cpan/Scalar-List-Utils/t/weak.t +++ b/cpan/Scalar-List-Utils/t/weak.t @@ -17,192 +17,163 @@ BEGIN { use Scalar::Util (); use Test::More ((grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) and !$ENV{PERL_CORE}) ? (skip_all => 'weaken requires XS version') - : (tests => 22); + : (tests => 27); -if (0) { - require Devel::Peek; - Devel::Peek->import('Dump'); -} -else { - *Dump = sub {}; -} - -Scalar::Util->import(qw(weaken isweak)); - -if(1) { - -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) ); + 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}} ++; } -- 2.7.4