Update to Scalar-List-Utils 1.11

p4raw-id: //depot/perl@18702

diff --git a/MANIFEST b/MANIFEST
index 385cbba..64de081 100644 (file)
--- 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 (file)
--- 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 3212feb..412fa3f 100644 (file)
--- 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 872bb2d..09beda6 100644 (file)
--- 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 (file)
--- 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 bd70b63..1f679ca 100644 (file)
--- 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 (file)
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