diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | pod/perldelta.pod | 10 | ||||
| -rw-r--r-- | t/lib/universal.t | 25 | ||||
| -rw-r--r-- | universal.c | 20 |
4 files changed, 53 insertions, 3 deletions
@@ -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 4c3451403f..cb83c8c761 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 0000000000..d8c088920b --- /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 65935018f8..6df104eb13 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))); |