From 60f3865b55c4d6a10a2e3a9a3b1d496422e83c3e Mon Sep 17 00:00:00 2001 From: Graham Barr Date: Sun, 3 Nov 2002 10:11:18 +0000 Subject: [PATCH] Update to Scalar-List-Utils 1.08 p4raw-id: //depot/perl@18076 --- MANIFEST | 2 ++ ext/List/Util/ChangeLog | 36 +++++++++++++++++++++ ext/List/Util/README | 8 ++++- ext/List/Util/Util.xs | 68 +++++++++++++++++++++++++++++++++++----- ext/List/Util/lib/List/Util.pm | 8 ++--- ext/List/Util/lib/Scalar/Util.pm | 24 ++++++++++++-- ext/List/Util/t/first.t | 9 +++++- ext/List/Util/t/isvstring.t | 41 ++++++++++++++++++++++++ ext/List/Util/t/reduce.t | 8 ++++- ext/List/Util/t/refaddr.t | 54 +++++++++++++++++++++++++++++++ 10 files changed, 242 insertions(+), 16 deletions(-) create mode 100644 ext/List/Util/t/isvstring.t create mode 100755 ext/List/Util/t/refaddr.t diff --git a/MANIFEST b/MANIFEST index ffa3329..adde27a 100644 --- a/MANIFEST +++ b/MANIFEST @@ -477,6 +477,7 @@ ext/List/Util/README Util extension ext/List/Util/t/blessed.t Scalar::Util ext/List/Util/t/dualvar.t Scalar::Util ext/List/Util/t/first.t List::Util +ext/List/Util/t/isvstring.t Scalar::Util ext/List/Util/t/max.t List::Util ext/List/Util/t/maxstr.t List::Util ext/List/Util/t/min.t List::Util @@ -484,6 +485,7 @@ ext/List/Util/t/minstr.t List::Util ext/List/Util/t/openhan.t Scalar::Util ext/List/Util/t/readonly.t Scalar::Util ext/List/Util/t/reduce.t List::Util +ext/List/Util/t/refaddr.t Scalar::Util ext/List/Util/t/reftype.t Scalar::Util ext/List/Util/t/shuffle.t List::Util ext/List/Util/t/sum.t List::Util diff --git a/ext/List/Util/ChangeLog b/ext/List/Util/ChangeLog index 934643a..89e33e9 100644 --- a/ext/List/Util/ChangeLog +++ b/ext/List/Util/ChangeLog @@ -1,3 +1,39 @@ +Change 757 on 2002/11/03 by (Graham Barr) + + Add XS_VERSION + +Change 756 on 2002/11/03 by (Graham Barr) + + Use PAD_* macros in 5.9 + Reuse our own target when calling pp_rand in shuffle() so we dont need to create a fake pad + +Change 751 on 2002/10/18 by (Graham Barr) + + Fix context so that sub for reduce/first is always in a scalar context + Fix sum/min/max so that they dont upgrade thier argumetns to NVs + if they are IV or UV + +Change 750 on 2002/10/14 by (Graham Barr) + + Add isvstring() + +Change 745 on 2002/09/23 by (Graham Barr) + + Scalar::Util + - Add refaddr() + +Change 722 on 2002/04/29 by (Graham Barr) + + Release 1.0701 + +Change 721 on 2002/04/29 by (Graham Barr) + + Add comment to README about failing tests on perl5.6.0 + +Change 714 on 2002/03/18 by (Graham Barr) + + Release 1.07 + Change 713 on 2002/03/18 by (Graham Barr) Add Scalar::Util::openhandle() diff --git a/ext/List/Util/README b/ext/List/Util/README index 2e5aba9..e384354 100644 --- a/ext/List/Util/README +++ b/ext/List/Util/README @@ -27,6 +27,12 @@ This distribution provides dualvar shuffle -Copyright (c) 1997-2001 Graham Barr . All rights reserved. +KNOWN BUGS + +There is a bug in perl5.6.0 with UV's that are >= 1<<31. This will +show up as tests 8 and 9 of dualvar.t failing + + +Copyright (c) 1997-2002 Graham Barr . All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/ext/List/Util/Util.xs b/ext/List/Util/Util.xs index c26c484..0b080c5 100644 --- a/ext/List/Util/Util.xs +++ b/ext/List/Util/Util.xs @@ -43,6 +43,12 @@ my_cxinc(pTHX) # define NV double #endif +#ifdef SVf_IVisUV +# define slu_sv_value(sv) (NV)(SvIOK(sv) ? SvIOK_UV(sv) ? SvUVX(sv) : SvIVX(sv) : SvNV(sv)) +#else +# define slu_sv_value(sv) (NV)(SvIOK(sv) ? SvIVX(sv) : SvNV(sv)) +#endif + #ifndef Drand01 # define Drand01() ((rand() & 0x7FFF) / (double) ((unsigned long)1 << 15)) #endif @@ -90,6 +96,10 @@ sv_tainted(SV *sv) # endif #endif +#ifndef PTR2IV +# define PTR2IV(ptr) (IV)(ptr) +#endif + MODULE=List::Util PACKAGE=List::Util void @@ -107,10 +117,10 @@ CODE: XSRETURN_UNDEF; } retsv = ST(0); - retval = SvNV(retsv); + retval = slu_sv_value(retsv); for(index = 1 ; index < items ; index++) { SV *stacksv = ST(index); - NV val = SvNV(stacksv); + NV val = slu_sv_value(stacksv); if(val < retval ? !ix : ix) { retsv = stacksv; retval = val; @@ -127,13 +137,16 @@ sum(...) PROTOTYPE: @ CODE: { + SV *sv; int index; if(!items) { XSRETURN_UNDEF; } - RETVAL = SvNV(ST(0)); + sv = ST(0); + RETVAL = slu_sv_value(sv); for(index = 1 ; index < items ; index++) { - RETVAL += SvNV(ST(index)); + sv = ST(index); + RETVAL += slu_sv_value(sv); } } OUTPUT: @@ -199,6 +212,7 @@ CODE: PERL_CONTEXT *cx; SV** newsp; I32 gimme = G_SCALAR; + I32 hasargs = 0; bool oldcatch = CATCH_GET; if(items <= 1) { @@ -222,7 +236,10 @@ CODE: SAVESPTR(PL_op); ret = ST(1); CATCH_SET(TRUE); - PUSHBLOCK(cx, CXt_NULL, SP); + PUSHBLOCK(cx, CXt_SUB, SP); + PUSHSUB(cx); + if (!CvDEPTH(cv)) + (void)SvREFCNT_inc(cv); for(index = 2 ; index < items ; index++) { GvSV(agv) = ret; GvSV(bgv) = ST(index); @@ -250,6 +267,7 @@ CODE: PERL_CONTEXT *cx; SV** newsp; I32 gimme = G_SCALAR; + I32 hasargs = 0; bool oldcatch = CATCH_GET; if(items <= 1) { @@ -269,7 +287,11 @@ CODE: SAVETMPS; SAVESPTR(PL_op); CATCH_SET(TRUE); - PUSHBLOCK(cx, CXt_NULL, SP); + PUSHBLOCK(cx, CXt_SUB, SP); + PUSHSUB(cx); + if (!CvDEPTH(cv)) + (void)SvREFCNT_inc(cv); + for(index = 1 ; index < items ; index++) { GvSV(PL_defgv) = ST(index); PL_op = reducecop; @@ -380,6 +402,20 @@ CODE: OUTPUT: RETVAL +IV +refaddr(sv) + SV * sv +PROTOTYPE: $ +CODE: +{ + if(!SvROK(sv)) { + XSRETURN_UNDEF; + } + RETVAL = PTR2IV(SvRV(sv)); +} +OUTPUT: + RETVAL + void weaken(sv) SV *sv @@ -421,16 +457,34 @@ CODE: OUTPUT: RETVAL +void +isvstring(sv) + SV *sv +PROTOTYPE: $ +CODE: +#ifdef SvVOK + ST(0) = boolSV(SvVOK(sv)); + XSRETURN(1); +#else + croak("vstrings are not implemented in this release of perl"); +#endif + + BOOT: { -#ifndef SvWEAKREF +#if !defined(SvWEAKREF) || !defined(SvVOK) HV *stash = gv_stashpvn("Scalar::Util", 12, TRUE); GV *vargv = *(GV**)hv_fetch(stash, "EXPORT_FAIL", 11, TRUE); AV *varav; if (SvTYPE(vargv) != SVt_PVGV) gv_init(vargv, stash, "Scalar::Util", 12, TRUE); varav = GvAVn(vargv); +#endif +#ifndef SvWEAKREF av_push(varav, newSVpv("weaken",6)); av_push(varav, newSVpv("isweak",6)); #endif +#ifndef SvVOK + av_push(varav, newSVpv("isvstring",9)); +#endif } diff --git a/ext/List/Util/lib/List/Util.pm b/ext/List/Util/lib/List/Util.pm index 7686ffe..8975b10 100644 --- a/ext/List/Util/lib/List/Util.pm +++ b/ext/List/Util/lib/List/Util.pm @@ -9,11 +9,11 @@ package List::Util; require Exporter; require DynaLoader; -our @ISA = qw(Exporter DynaLoader); -our @EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle); -our $VERSION = "1.07_00"; +our @ISA = qw(Exporter DynaLoader); +our @EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle); +our $VERSION = "1.08_00"; our $XS_VERSION = $VERSION; -$VERSION = eval $VERSION; +$VERSION = eval $VERSION; bootstrap List::Util $XS_VERSION; diff --git a/ext/List/Util/lib/Scalar/Util.pm b/ext/List/Util/lib/Scalar/Util.pm index e518a4c..fd881ad 100644 --- a/ext/List/Util/lib/Scalar/Util.pm +++ b/ext/List/Util/lib/Scalar/Util.pm @@ -10,7 +10,7 @@ require Exporter; require List::Util; # List::Util loads the XS our @ISA = qw(Exporter); -our @EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle); +our @EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring); our $VERSION = $List::Util::VERSION; sub openhandle ($) { @@ -41,7 +41,7 @@ Scalar::Util - A selection of general-utility scalar subroutines =head1 SYNOPSIS - use Scalar::Util qw(blessed dualvar isweak readonly reftype tainted weaken); + use Scalar::Util qw(blessed dualvar isweak readonly refaddr reftype tainted weaken); =head1 DESCRIPTION @@ -78,6 +78,14 @@ value STRING in a string context. $num = $foo + 2; # 12 $str = $foo . " world"; # Hello world +=item isvstring EXPR + +If EXPR 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); + =item isweak EXPR If EXPR is a scalar which is a weak reference the result is true. @@ -106,6 +114,18 @@ Returns true if SCALAR is readonly. $readonly = foo($bar); # false $readonly = foo(0); # true +=item 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 + =item reftype EXPR If EXPR evaluates to a reference the type of the variable referenced diff --git a/ext/List/Util/t/first.t b/ext/List/Util/t/first.t index ee22780..d6a919d 100755 --- a/ext/List/Util/t/first.t +++ b/ext/List/Util/t/first.t @@ -15,7 +15,7 @@ BEGIN { use List::Util qw(first); -print "1..7\n"; +print "1..8\n"; print "not " unless defined &first; print "ok 1\n"; @@ -41,3 +41,10 @@ print "ok 6\n"; print "not " if defined eval { first { die if $_ } 0,0,1 }; print "ok 7\n"; + +($x) = foobar(); +$x = '' unless defined $x; +print "${x}ok 8\n"; + +sub foobar { first { !defined(wantarray) || wantarray } "not ","not ","not " } + diff --git a/ext/List/Util/t/isvstring.t b/ext/List/Util/t/isvstring.t new file mode 100644 index 0000000..bd70b63 --- /dev/null +++ b/ext/List/Util/t/isvstring.t @@ -0,0 +1,41 @@ +#!./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; + } + } + $|=1; + require Scalar::Util; + if (grep { /isvstring/ } @Scalar::Util::EXPORT_FAIL) { + print("1..0\n"); + exit 0; + } +} + +use Scalar::Util qw(isvstring); + +print "1..4\n"; + +print "ok 1\n"; + +$vs = 49.46.48; + +print "not " unless $vs == "1.0"; +print "ok 2\n"; + +print "not " unless isvstring($vs); +print "ok 3\n"; + +$sv = "1.0"; +print "not " if isvstring($sv); +print "ok 4\n"; + + + diff --git a/ext/List/Util/t/reduce.t b/ext/List/Util/t/reduce.t index 2721d15..4af711d 100755 --- a/ext/List/Util/t/reduce.t +++ b/ext/List/Util/t/reduce.t @@ -16,7 +16,7 @@ BEGIN { use List::Util qw(reduce min); -print "1..8\n"; +print "1..9\n"; print "not " if defined reduce {}; print "ok 1\n"; @@ -50,3 +50,9 @@ print "ok 7\n"; print "not " if defined eval { reduce { die if $b > 2; $a + $b } 0,1,2,3,4 }; print "ok 8\n"; + +($x) = foobar(); +print "${x}ok 9\n"; + +sub foobar { reduce { (defined(wantarray) && !wantarray) ? '' : 'not ' } 0,1,2,3 } + diff --git a/ext/List/Util/t/refaddr.t b/ext/List/Util/t/refaddr.t new file mode 100755 index 0000000..efb962c --- /dev/null +++ b/ext/List/Util/t/refaddr.t @@ -0,0 +1,54 @@ +#!./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 qw(refaddr); +use vars qw($t $y $x *F $v $r); +use Symbol qw(gensym); + +# Ensure we do not trigger and tied methods +tie *F, 'MyTie'; + +print "1..13\n"; + +my $i = 1; +foreach $v (undef, 10, 'string') { + print "not " if defined refaddr($v); + print "ok ",$i++,"\n"; +} + +foreach $r ({}, \$t, [], \*F, sub {}) { + my $addr = $r + 0; + print "not " unless refaddr($r) == $addr; + print "ok ",$i++,"\n"; + my $obj = bless $r, 'FooBar'; + print "not " unless refaddr($r) == $addr; + print "ok ",$i++,"\n"; +} + +package FooBar; + +use overload '0+' => sub { 10 }, + '+' => sub { 10 + $_[1] }; + +package MyTie; + +sub TIEHANDLE { bless {} } +sub DESTROY {} + +sub AUTOLOAD { + warn "$AUTOLOAD called"; + exit 1; # May be in an eval +} -- 2.7.4