[perl.git] branch blead, updated. v5.13.4-209-g80b6a94

[Nicholas Clark]

In perl.git, the branch blead has been updated

<http://perl5.git.perl.org/perl.git/commitdiff/80b6a949dbabd822cf5e1cf2ece76164d772f0b9?hp=3d8e05a034fc6625a503b87c8ac336d4d84fb338>

- Log -----------------------------------------------------------------
commit 80b6a949dbabd822cf5e1cf2ece76164d772f0b9
Author: Ævar Arnfjörð Bjarmason <a...@cpan.org>
Date:   Sat Sep 11 09:58:02 2010 +0000

    segfault on &Internals::* due to missing SvROK()
    
    Change the &Internals::* functions that use references in their
    prototypes to check if the argument is SvROK() before calling SvRV().
    
    If the function is called as Internals::FOO() perl does this check for
    us, but prototypes are bypassed on &Internals::FOO() so we still have
    to check this manually.
    
    This fixes [perl #77776], this bug was present in 5.10.x, 5.12.x, and
    probably all earlier perl versions that had these functions, but I
    haven't tested that.
    
    I'm adding a new test file (t/lib/universal.t) to test universal.c
    functions as part of this patch. The testing for Internal::* in t/ was
    and is very sparse, but before universal.t there was no obvious place
    to put these tests.
    
    Signed-off-by: Ævar Arnfjörð Bjarmason <a...@cpan.org>
-----------------------------------------------------------------------

Summary of changes:
 MANIFEST          |    1 +
 pod/perldelta.pod |   10 ++++++++++
 t/lib/universal.t |   25 +++++++++++++++++++++++++
 universal.c       |   20 +++++++++++++++++---
 4 files changed, 53 insertions(+), 3 deletions(-)
 create mode 100644 t/lib/universal.t

diff --git a/MANIFEST b/MANIFEST
index 7900589..e05d019 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4412,6 +4412,7 @@ t/lib/strict/vars         Tests of "use strict 'vars'" 
for strict.t
 t/lib/subs/subs                        Tests of "use subs"
 t/lib/test_use_14937.pm                A test pragma for t/comp/use.t
 t/lib/test_use.pm              A test pragma for t/comp/use.t
+t/lib/universal.t              Tests for functions in universal.c
 t/lib/warnings/1global         Tests of global warnings for warnings.t
 t/lib/warnings/2use            Tests for "use warnings" for warnings.t
 t/lib/warnings/3both           Tests for interaction of $^W and "use warnings"
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 4c34514..cb83c8c 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -543,6 +543,16 @@ fixed [perl #21469]. This means the following code will no 
longer crash:
         *x = *y;
     }
 
+=item *
+
+Perl would segfault if the undocumented C<Internals> functions that
+used reference prototypes were called with the C<&foo()> syntax,
+e.g. C<&Internals::SvREADONLY(undef)> [perl #77776].
+
+These functions now call C<SvROK> on their arguments before
+dereferencing them with C<SvRV>, and we test for this case in
+F<t/lib/universal.t>.
+
 =back
 
 =head1 Known Problems
diff --git a/t/lib/universal.t b/t/lib/universal.t
new file mode 100644
index 0000000..d8c0889
--- /dev/null
+++ b/t/lib/universal.t
@@ -0,0 +1,25 @@
+#!./perl
+
+# Test the Internal::* functions and other tibits in universal.c
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require './test.pl';
+    plan( tests => 4 );
+}
+
+for my $arg ('', 'q[]', qw( 1 undef )) {
+    fresh_perl_is(<<"----", <<'====', "Internals::* functions check their 
argument under func() AND &func() [perl #77776]");
+sub tryit { eval shift or warn \$@ }
+tryit "&Internals::SvREADONLY($arg)";
+tryit "&Internals::SvREFCNT($arg)";
+tryit "&Internals::hv_clear_placeholders($arg)";
+tryit "&Internals::HvREHASH($arg)";
+----
+Usage: Internals::SvREADONLY(SCALAR[, ON]) at (eval 1) line 1.
+Usage: Internals::SvREFCNT(SCALAR[, REFCOUNT]) at (eval 2) line 1.
+Usage: Internals::hv_clear_placeholders(hv) at (eval 3) line 1.
+Internals::HvREHASH $hashref at (eval 4) line 1.
+====
+}
diff --git a/universal.c b/universal.c
index 6593501..6df104e 100644
--- a/universal.c
+++ b/universal.c
@@ -794,9 +794,16 @@ XS(XS_Internals_SvREADONLY)        /* This is dangerous 
stuff. */
 {
     dVAR;
     dXSARGS;
-    SV * const sv = SvRV(ST(0));
+    SV * const svz = ST(0);
+    SV * sv;
     PERL_UNUSED_ARG(cv);
 
+    /* [perl #77776] - called as &foo() not foo() */
+    if (!SvROK(svz))
+        croak_xs_usage(cv, "SCALAR[, ON]");
+
+    sv = SvRV(svz);
+
     if (items == 1) {
         if (SvREADONLY(sv))
             XSRETURN_YES;
@@ -821,9 +828,16 @@ XS(XS_Internals_SvREFCNT)  /* This is dangerous stuff. */
 {
     dVAR;
     dXSARGS;
-    SV * const sv = SvRV(ST(0));
+    SV * const svz = ST(0);
+    SV * sv;
     PERL_UNUSED_ARG(cv);
 
+    /* [perl #77776] - called as &foo() not foo() */
+    if (!SvROK(svz))
+        croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
+
+    sv = SvRV(svz);
+
     if (items == 1)
         XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
     else if (items == 2) {
@@ -839,7 +853,7 @@ XS(XS_Internals_hv_clear_placehold)
     dVAR;
     dXSARGS;
 
-    if (items != 1)
+    if (items != 1 || !SvROK(ST(0)))
        croak_xs_usage(cv, "hv");
     else {
        HV * const hv = MUTABLE_HV(SvRV(ST(0)));

--
Perl5 Master Repository