From: Graham Barr Date: Fri, 14 Feb 2003 19:26:23 +0000 (+0000) Subject: Update to Scalar-List-Utils 1.11 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=97605c5162d70498fbc6c6addf1e17e758cec438;p=p5sagit%2Fp5-mst-13.2.git Update to Scalar-List-Utils 1.11 p4raw-id: //depot/perl@18702 --- diff --git a/MANIFEST b/MANIFEST index 385cbba..64de081 100644 --- a/MANIFEST +++ b/MANIFEST @@ -486,6 +486,7 @@ ext/List/Util/t/maxstr.t List::Util ext/List/Util/t/min.t List::Util ext/List/Util/t/minstr.t List::Util ext/List/Util/t/openhan.t Scalar::Util +ext/List/Util/t/proto.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 diff --git a/ext/List/Util/ChangeLog b/ext/List/Util/ChangeLog index e03b31c..3157e92 100644 --- a/ext/List/Util/ChangeLog +++ b/ext/List/Util/ChangeLog @@ -1,3 +1,32 @@ +Change 770 on 2003/02/14 by (Graham Barr) + + Release 1.11 + +Change 769 on 2003/02/14 by (Graham Barr) + + Add t/proto.t to MANIFEST + +Change 768 on 2003/02/14 by (Graham Barr) + + Add set_prototype from Rafael Garcia-Suarez + +Change 767 on 2003/02/14 by (Graham Barr) + + Fix t/isvstring.t so it does not cause perl5.004 to segv + because of the exit from within BEGIN + +Change 766 on 2003/02/14 by (Graham Barr) + + Change how patchlevel.h is included and check we got what we wanted (from Jarkko) + +Change 765 on 2003/02/14 by (Graham Barr) + + Add -DPERL_EXT to DEFINEs, requested by Jarkko for 5.8.1 + +Change 764 on 2003/02/04 by (Graham Barr) + + Release 1.10 + Change 763 on 2003/02/04 by (Graham Barr) Fix linking error for older perls @@ -36,7 +65,7 @@ Change 756 on 2002/11/03 by (Graham Barr) 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 arguments to NVs + Fix sum/min/max so that they don't upgrade their arguments to NVs if they are IV or UV Change 750 on 2002/10/14 by (Graham Barr) diff --git a/ext/List/Util/Util.xs b/ext/List/Util/Util.xs index 3212feb..412fa3f 100644 --- a/ext/List/Util/Util.xs +++ b/ext/List/Util/Util.xs @@ -8,7 +8,10 @@ #include #ifndef PERL_VERSION -# include "patchlevel.h" +# include +# if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL))) +# include +# endif # define PERL_REVISION 5 # define PERL_VERSION PATCHLEVEL # define PERL_SUBVERSION SUBVERSION @@ -478,6 +481,35 @@ CODE: OUTPUT: RETVAL +SV* +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 */ + STRLEN len; + char *ptr = SvPV(proto, len); + sv_setpvn(sv, ptr, len); + } + else { + /* delete the prototype */ + SvPOK_off(sv); + } + } + else { + croak("set_prototype: not a reference"); + } + XSRETURN(1); +} BOOT: { diff --git a/ext/List/Util/lib/List/Util.pm b/ext/List/Util/lib/List/Util.pm index 872bb2d..09beda6 100644 --- a/ext/List/Util/lib/List/Util.pm +++ b/ext/List/Util/lib/List/Util.pm @@ -11,7 +11,7 @@ require DynaLoader; our @ISA = qw(Exporter DynaLoader); our @EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle); -our $VERSION = "1.10_00"; +our $VERSION = "1.11_00"; our $XS_VERSION = $VERSION; $VERSION = eval $VERSION; diff --git a/ext/List/Util/lib/Scalar/Util.pm b/ext/List/Util/lib/Scalar/Util.pm index 4de463d..ca60dfd 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 refaddr isvstring looks_like_number); +our @EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype); 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 refaddr reftype tainted weaken isvstring looks_like_number); + use Scalar::Util qw(blessed dualvar isweak readonly refaddr reftype tainted weaken isvstring looks_like_number set_prototype); =head1 DESCRIPTION @@ -143,6 +143,13 @@ is returned. Otherwise C is returned. $obj = bless {}, "Foo"; $type = reftype $obj; # HASH +=item set_prototype CODEREF, PROTOTYPE + +Sets the prototype of the given function, or deletes it if PROTOTYPE is +undef. Returns the CODEREF. + + set_prototype \&foo, '$$'; + =item tainted EXPR Return true if the result of EXPR is tainted diff --git a/ext/List/Util/t/isvstring.t b/ext/List/Util/t/isvstring.t index bd70b63..1f679ca 100644 --- a/ext/List/Util/t/isvstring.t +++ b/ext/List/Util/t/isvstring.t @@ -11,15 +11,16 @@ BEGIN { exit 0; } } - $|=1; - require Scalar::Util; - if (grep { /isvstring/ } @Scalar::Util::EXPORT_FAIL) { - print("1..0\n"); - exit 0; - } } -use Scalar::Util qw(isvstring); +$|=1; +require Scalar::Util; +if (grep { /isvstring/ } @Scalar::Util::EXPORT_FAIL) { + print("1..0\n"); + exit 0; +} + +Scalar::Util->import(qw[isvstring]); print "1..4\n"; diff --git a/ext/List/Util/t/proto.t b/ext/List/Util/t/proto.t new file mode 100644 index 0000000..91541cb --- /dev/null +++ b/ext/List/Util/t/proto.t @@ -0,0 +1,75 @@ +#!./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; + } + } +} + +BEGIN { + require Scalar::Util; + + if (grep { /set_prototype/ } @Scalar::Util::EXPORT_FAIL) { + print "1..0\n"; + $skip=1; + } +} + +eval <<'EOT' unless $skip; +use Scalar::Util qw(set_prototype); + +print "1..13\n"; +$test = 0; + +sub proto_is ($$) { + $proto = prototype shift; + $expected = shift; + if (defined $expected) { + print "# Got $proto, expected $expected\nnot " if $expected ne $proto; + } + else { + print "# Got $proto, expected undef\nnot " if defined $proto; + } + print "ok ", ++$test, "\n"; +} + +sub f { } +proto_is 'f' => undef; +$r = set_prototype(\&f,'$'); +proto_is 'f' => '$'; +print "not " unless ref $r eq "CODE" and $r == \&f; +print "ok ", ++$test, " - return value\n"; +set_prototype(\&f,undef); +proto_is 'f' => undef; +set_prototype(\&f,''); +proto_is 'f' => ''; + +sub g (@) { } +proto_is 'g' => '@'; +set_prototype(\&g,undef); +proto_is 'g' => undef; + +sub non_existent; +proto_is 'non_existent' => undef; +set_prototype(\&non_existent,'$$$'); +proto_is 'non_existent' => '$$$'; + +sub forward_decl ($$$$); +proto_is 'forward_decl' => '$$$$'; +set_prototype(\&forward_decl,'\%'); +proto_is 'forward_decl' => '\%'; + +eval { &set_prototype( 'f', '' ); }; +print "not " unless $@ =~ /^set_prototype: not a reference/; +print "ok ", ++$test, " - error msg\n"; +eval { &set_prototype( \'f', '' ); }; +print "not " unless $@ =~ /^set_prototype: not a subroutine reference/; +print "ok ", ++$test, " - error msg\n"; +EOT