In perl.git, the branch blead has been updated
<https://perl5.git.perl.org/perl.git/commitdiff/a385812b685b3164e706880a72ee60c9cc9573e4?hp=125cf574559a697ab2dd31760c79d7c98f3479c4>
- Log -----------------------------------------------------------------
commit a385812b685b3164e706880a72ee60c9cc9573e4
Author: Father Chrysostomos <spr...@cpan.org>
Date: Tue Oct 31 10:16:59 2017 -0700
Make get_cv cope with subrefs
When called with GV_NOADD_NOINIT, get_cv will fail an assertion if the
thingy in the stash is not a GV.
While calling with GV_NOADD_NOINIT is a strange thing to do, neverthe-
less Cpanel::JSON::XS does it with "Encode::decode", which is not an
unreasonable thing to do if it is known that the sub already exists.
This commit makes get_cv take sub refs into account, so that, when we
reënable the optimisation reverted by 9bceb75b8d9, Cpanel::JSON::XS
will continue to work with bleadperl.
(Currently, the optimisation only applies to the main package, which
is why I am able to test this now.)
commit 7cfe4f5255a555764f03a74312f9b7736c4142ec
Author: Father Chrysostomos <spr...@cpan.org>
Date: Mon Oct 30 21:49:04 2017 -0700
Basic tests for get_cvn_flags
-----------------------------------------------------------------------
Summary of changes:
MANIFEST | 1 +
ext/XS-APItest/APItest.xs | 22 ++++++++++++++++++++++
ext/XS-APItest/Makefile.PL | 1 +
ext/XS-APItest/t/get.t | 22 ++++++++++++++++++++++
perl.c | 3 +++
5 files changed, 49 insertions(+)
create mode 100644 ext/XS-APItest/t/get.t
diff --git a/MANIFEST b/MANIFEST
index e71a13a461..cfa1ecdf93 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4295,6 +4295,7 @@ ext/XS-APItest/t/eval-filter.t Simple source
filter/eval test
ext/XS-APItest/t/exception.t XS::APItest extension
ext/XS-APItest/t/extend.t test EXTEND() macro
ext/XS-APItest/t/fetch_pad_names.t Tests for UTF8 names in pad
+ext/XS-APItest/t/get.t test get_sv et al.
ext/XS-APItest/t/gotosub.t XS::APItest: tests goto &xsub and hints
ext/XS-APItest/t/grok.t XS::APItest: tests for grok* functions
ext/XS-APItest/t/gv_autoload4.t XS::APItest: tests for gv_autoload4()
and variants
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 9eafb0adf2..c2100d165e 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -4277,6 +4277,28 @@ string_without_null(SV *sv)
OUTPUT:
RETVAL
+CV *
+get_cv(SV *sv)
+ CODE:
+ {
+ STRLEN len;
+ const char *s = SvPV(sv, len);
+ RETVAL = get_cvn_flags(s, len, 0);
+ }
+ OUTPUT:
+ RETVAL
+
+CV *
+get_cv_flags(SV *sv, UV flags)
+ CODE:
+ {
+ STRLEN len;
+ const char *s = SvPV(sv, len);
+ RETVAL = get_cvn_flags(s, len, flags);
+ }
+ OUTPUT:
+ RETVAL
+
MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
int
diff --git a/ext/XS-APItest/Makefile.PL b/ext/XS-APItest/Makefile.PL
index 24078a6f8c..d79ba1150e 100644
--- a/ext/XS-APItest/Makefile.PL
+++ b/ext/XS-APItest/Makefile.PL
@@ -24,6 +24,7 @@ my @names = (qw(HV_DELETE HV_DISABLE_UVAR_XKEY
HV_FETCH_ISSTORE
HV_FETCH_ISEXISTS HV_FETCH_LVALUE HV_FETCH_JUST_SV
G_SCALAR G_ARRAY G_VOID G_DISCARD G_EVAL G_NOARGS
G_KEEPERR G_NODEBUG G_METHOD G_FAKINGEVAL
+ GV_NOADD_NOINIT
IS_NUMBER_IN_UV IS_NUMBER_GREATER_THAN_UV_MAX
IS_NUMBER_NOT_INT IS_NUMBER_NEG IS_NUMBER_INFINITY
IS_NUMBER_NAN IS_NUMBER_TRAILING PERL_SCAN_TRAILING
diff --git a/ext/XS-APItest/t/get.t b/ext/XS-APItest/t/get.t
new file mode 100644
index 0000000000..2264d664f9
--- /dev/null
+++ b/ext/XS-APItest/t/get.t
@@ -0,0 +1,22 @@
+
+# Tests for the get_*v functions.
+
+use Test::More tests => 5;
+use XS::APItest;
+
+# XXX So far we only test get_cv.
+
+is get_cv("utf8::encode"), \&utf8::encode, 'get_cv(utf8::encode)';
+
+sub foo { " ooof" } # should be stored in the stash as a subref
+die "Test has been sabotaged: sub foo{} should not create a full glob"
+ unless ref $::{foo} eq 'CODE';
+
+my $subref = get_cv("foo");
+is ref $subref, "CODE", 'got a coderef from get_cv("globless sub")';
+is &$subref, " ooof", 'got the right sub';
+
+sub bar { "burr" }
+$subref = get_cv_flags("bar",GV_NOADD_NOINIT);
+is ref $subref, "CODE", 'got a coderef from get_cv with GV_NOADD_NOINIT';
+is &$subref, "burr", 'got the right sub';
diff --git a/perl.c b/perl.c
index 96eaa98b03..7f27694c09 100644
--- a/perl.c
+++ b/perl.c
@@ -2704,6 +2704,9 @@ Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len,
I32 flags)
PERL_ARGS_ASSERT_GET_CVN_FLAGS;
+ if (gv && UNLIKELY(SvROK(gv)) && SvTYPE(SvRV((SV *)gv)) == SVt_PVCV)
+ return SvRV((SV *)gv);
+
/* XXX this is probably not what they think they're getting.
* It has the same effect as "sub name;", i.e. just a forward
* declaration! */
--
Perl5 Master Repository
