Update to Scalar-List-Utils 1.11

p4raw-id: //depot/perl@18702

6 files changed, 156 insertions, 12 deletions

diff --git a/ext/List/Util/ChangeLog b/ext/List/Util/ChangeLog
index e03b31c7ee..3157e92086 100644
--- a/ext/List/Util/ChangeLog
+++ b/ext/List/Util/ChangeLog
@@ -1,3 +1,32 @@
+Change 770 on 2003/02/14 by <gbarr@pobox.com> (Graham Barr)
+
+	Release 1.11
+
+Change 769 on 2003/02/14 by <gbarr@pobox.com> (Graham Barr)
+
+	Add t/proto.t to MANIFEST
+
+Change 768 on 2003/02/14 by <gbarr@pobox.com> (Graham Barr)
+
+	Add set_prototype from Rafael Garcia-Suarez
+
+Change 767 on 2003/02/14 by <gbarr@pobox.com> (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 <gbarr@pobox.com> (Graham Barr)
+
+	Change how patchlevel.h is included and check we got what we wanted (from Jarkko)
+
+Change 765 on 2003/02/14 by <gbarr@pobox.com> (Graham Barr)
+
+	Add -DPERL_EXT to DEFINEs, requested by Jarkko for 5.8.1
+
+Change 764 on 2003/02/04 by <gbarr@pobox.com> (Graham Barr)
+
+	Release 1.10
+
 Change 763 on 2003/02/04 by <gbarr@pobox.com> (Graham Barr)
 
 	Fix linking error for older perls
@@ -36,7 +65,7 @@ Change 756 on 2002/11/03 by <gbarr@pobox.com> (Graham Barr)
 Change 751 on 2002/10/18 by <gbarr@pobox.com> (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 <gbarr@pobox.com> (Graham Barr)
diff --git a/ext/List/Util/Util.xs b/ext/List/Util/Util.xs
index 3212feb848..412fa3f8c0 100644
--- a/ext/List/Util/Util.xs
+++ b/ext/List/Util/Util.xs
@@ -8,7 +8,10 @@
 #include <XSUB.h>
 
 #ifndef PERL_VERSION
-#    include "patchlevel.h"
+#    include <patchlevel.h>
+#    if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL)))
+#        include <could_not_find_Perl_patchlevel.h>
+#    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 872bb2dbcf..09beda67ef 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 4de463d092..ca60dfd3e1 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<undef> 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 bd70b63ebf..1f679ca0ef 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 0000000000..91541cb5e7
--- /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