5.10.x 5.12.x segfault on &Internals::SvREADONLY(undef) #10619
Labels
Comments
From zzgrim@gmail.com]$ perl -e'&Internals::SvREADONLY(undef)' ]$ /opt/p5122/bin/perl -e'&Internals::SvREADONLY( undef )' ]$ gdb debugperl Program exited with code 0377. ignited by Josh "evil code" ben Jore :) perls used: custom 5.10.1 nothreads All output: Segmentation fault Perl Info |
From @avarOn Fri, Sep 10, 2010 at 15:49, zgrim <perlbug-followup@perl.org> wrote:
Thanks for the report. I've fixed this with the attached patch http://github.com/avar/perl/compare/mirrors:blead...perl-77776 All of these functions could segfault due to this bug: &Internals::SvREADONLY($arg); The fix was just to call SvROK() before doing SvRV(). This patch is a canditate for backporting down to 5.10, 5.12, and |
From @avar0001-perl-77776-segfault-on-Internals-due-to-missing-SvRO.patchFrom 8ef38feeefce1971f6b75cc3077cf127c640bea4 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?=C3=86var=20Arnfj=C3=B6r=C3=B0=20Bjarmason?= <avar@cpan.org>
Date: Sat, 11 Sep 2010 09:58:02 +0000
Subject: [PATCH] [perl #77776] segfault on &Internals::* due to missing SvROK()
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
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 <avar@cpan.org>
---
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)));
--
1.7.2.3.313.gcd15
|
|
The RT System itself - Status changed from 'new' to 'open' |
From @nwc10On Sat, Sep 11, 2010 at 10:50:17AM +0000, Ævar Arnfjörð Bjarmason wrote:
Thanks, applied as 80b6a94
Realistically, I think that's "5.12, and if anyone cares 5.10 or earlier", Nicholas Clark |
|
@iabyn - Status changed from 'open' to 'resolved' |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Migrated from rt.perl.org#77776 (status was 'resolved')
Searchable as RT77776$
The text was updated successfully, but these errors were encountered: