In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/f9d9e965c852a57faea33a539ecd03a6e825af47?hp=bdab7676902d2f95f6fad47110f6e94e386db556>
- Log ----------------------------------------------------------------- commit f9d9e965c852a57faea33a539ecd03a6e825af47 Merge: bdab767 0bddbad Author: Father Chrysostomos <[email protected]> Date: Mon Sep 15 06:20:16 2014 -0700 [Merge] CVs without GVs Subroutines in packages no longer need typeglobs to live in. Concep- tually the typeglobs still exist, and will be reified as necessary. (This was already the case with constant subs, which could be stored in the stash as refs to constants, but now the stash can have sub refs, too.) Currently this optimisation is undone if a sub is exported or used as a method. Also, it does not apply to XSUBs. Here is the full list of notable changes: Internal: ⢠CvGV now reifies the GV if necessary. ⢠Lexical subs now have notional GVs, which are likewise rei- fied by CvGV. ⢠The new CVf_LEXICAL flag indicates that the package name should be dropped in error messages. XS API: ⢠New cv_name function ⢠New cv_set_call_checker_flags function Perl-visible changes: ⢠New B::safename function commit 0bddbad8d6598bec770281158952e178308f32eb Author: Father Chrysostomos <[email protected]> Date: Fri Sep 12 20:26:04 2014 -0700 concise-xs.t needs to know about B::safename M ext/B/t/concise-xs.t commit 1329031158bcd564f9c83e2ce5d084aa25310199 Author: Father Chrysostomos <[email protected]> Date: Fri Sep 12 14:14:07 2014 -0700 Tweak Peek.t again M ext/Devel-Peek/t/Peek.t commit e4555ecffb7d38bbad515b6666701652c73c5b85 Author: Father Chrysostomos <[email protected]> Date: Fri Sep 12 13:40:41 2014 -0700 dump.c: Missing comma from CVf_HASEVAL output M dump.c commit 32cc5cd1d98ec14e48cb7c6e723e2594347829e0 Author: Father Chrysostomos <[email protected]> Date: Fri Sep 12 13:38:23 2014 -0700 Teach Deparse about coderefs in stashes M lib/B/Deparse.pm commit 37206f25c5c545166f0d111a6b4a5e14e67b4beb Author: Father Chrysostomos <[email protected]> Date: Fri Sep 12 13:33:55 2014 -0700 Increase $B::VERSION to 1.51 M ext/B/B.pm commit d9cd2aeb7b33caa219261e376454031099e9177b Author: Father Chrysostomos <[email protected]> Date: Fri Sep 12 13:33:29 2014 -0700 Add safename() func to B M ext/B/B.pm M ext/B/t/b.t commit 86d1adfc2a39353ec873ce65fe73a77f17ecb3a2 Author: Father Chrysostomos <[email protected]> Date: Thu Sep 11 23:53:36 2014 -0700 Remove no-longer-used op.c:S_gv_ename M embed.fnc M embed.h M op.c M proto.h commit a65cc145b2ce31d135006c2fb8e7b89e0843f3b4 Author: Father Chrysostomos <[email protected]> Date: Thu Sep 11 23:52:41 2014 -0700 Teach ck_entersub_args_proto about non-GV names Now ck_subr no longer needs to vivify GVs: $ ./miniperl -e 'sub foo{} BEGIN { warn $::{foo} } foo(); BEGIN { warn $::{foo} }' CODE(0x7fc98282ad98) at -e line 1. CODE(0x7fc98282ad98) at -e line 1. Previously it was like this: $ ./miniperl -e 'sub foo{} BEGIN { warn $::{foo} } foo(); BEGIN { warn $::{foo} }' CODE(0x7f8ef082ad98) at -e line 1. *main::foo at -e line 1. M op.c M t/op/symbolcache.t commit 230b3caa7e7f84ecf3fa68999603884d4b196166 Author: Father Chrysostomos <[email protected]> Date: Thu Sep 11 23:44:45 2014 -0700 Inline op.c:too_many_arguments_sv into its only caller Iâm about to change this code anyway, and itâs easier in one spot. M embed.fnc M embed.h M op.c M proto.h commit 340798a07b98f692683344a419aab640629e38fb Author: Father Chrysostomos <[email protected]> Date: Thu Sep 11 23:42:45 2014 -0700 Inline op.c:too_few_arguments_sv into its only caller Iâm about to change this code anyway, and itâs easier in one spot. M embed.fnc M embed.h M op.c M proto.h commit 82487b590d480a4f4ce255ee8b668770ae4f2920 Author: Father Chrysostomos <[email protected]> Date: Thu Sep 11 22:49:44 2014 -0700 Teach dump.c about CVf_LEXICAL M dump.c commit bf9a4d2d5d7f2ccc6d7551b2e0fda513d75dcf3b Author: Father Chrysostomos <[email protected]> Date: Thu Sep 11 22:49:18 2014 -0700 Teach dump.c about CVf_NAMED I should have added this in perl 5.18. M dump.c commit 9c98a81fd30898ed03895d1368f4f9f2761b69da Author: Father Chrysostomos <[email protected]> Date: Thu Sep 11 17:59:11 2014 -0700 op.c:ck_subr: reify GVs based on call checker Instead of faking up a GV to pass to the call checker if we have a lexical sub, just get the GV from CvGV (since that will reify the GV, even for lexical subs), unless the call checker has not specifically requested GVs. For now, we assume the default call checker cannot handle non-GV sub names, as indeed it cannot. An imminent commit will rectify that. The code in scope.c was getting the name hek from the proto CV (stowed in magic on the pad name) if the CV in the pad had lost it. Now, the proto CV can lose it at compile time via CvGV, so that does not work anymore. Instead, just get it from the GV. M op.c M op.h M scope.c commit 4bc93fb921ea9f73602571ed903edcead3956e66 Author: Father Chrysostomos <[email protected]> Date: Thu Sep 11 22:53:42 2014 -0700 Use cv_name in pp_hot.c:sub_crush_depth The next commit will allow lexical subs with GVs to reach this code path, so use cv_name, since it knows how to handle those. M pp_hot.c commit aa38f4b16ec84f790a5473b0ff1ffe264bd93f5a Author: Father Chrysostomos <[email protected]> Date: Thu Sep 11 13:37:15 2014 -0700 Add cv_set_call_checker_flags This is like cv_set_call_checker, except that it allows the caller to decide whether the call checker needs a GV. Currently the GV flag is recorded, but ck_subr does not do anything with it yet. M cv.h M embed.fnc M embed.h M mg.h M op.c M proto.h commit f3fb6cf3d92d50cd60f36e1c193c0f3d45bcfd75 Author: Father Chrysostomos <[email protected]> Date: Wed Sep 10 22:06:10 2014 -0700 pad.c: Avoid struct name followed by colon Some old clang++ versions have trouble with this. See ticket #112786. M pad.c commit 7a275a2e9dcc2d1464646a838539b7bd06343743 Author: Father Chrysostomos <[email protected]> Date: Wed Sep 10 22:01:15 2014 -0700 pad.c:cv_name: Reword docs for future extensibility M pad.c commit e52eb89d6b6e33611c38ec4ef278fd23c7109640 Author: Father Chrysostomos <[email protected]> Date: Wed Sep 10 20:29:19 2014 -0700 Avoid reifying GVs in rv2cv \&foo no longer reifies GVs in the stash: $ ./miniperl -e 'sub foo{} warn $::{foo}; \&foo; warn $::{foo}' CODE(0x7fab6282ad98) at -e line 1. CODE(0x7fab6282ad98) at -e line 1. Sub calls still reify them though, because of the way ck_subr cur- rently works. Constant proxies are still upgraded to full GVs for now, just to mini- mise the churn per patch. This makes it possible for OP_GVs to point to things other than GVs, and these things are stored in the pad under threads. Hence, pad_tidy could turn on PADTMP, and then IS_PADGV becomes true when it is upgraded to a glob, so refgen will fail assertions. There is actually no need to turn on PADTMP in pad_tidy, since it will already be on for op targets. (We need to get rid of IS_PADGV one of these days. It doesnât actually do anything.) M op.c M pad.c commit 00efeabe1829ee5b5c8a75bc7f7989900f19af24 Author: Father Chrysostomos <[email protected]> Date: Wed Sep 10 14:23:53 2014 -0700 op.c: ck_rvconst: Inline the noexpand var It is only used once now, and its name is about to become confusing, as GV_NOEXPAND will be used for all CVs. M op.c commit 1fb13e7a6f97db1b5afb30b345fac02fb356ddda Author: Father Chrysostomos <[email protected]> Date: Sat Sep 6 22:59:36 2014 -0700 Increase $Attribute::Handlers::VERSION to 0.97 M dist/Attribute-Handlers/lib/Attribute/Handlers.pm commit 02bd0dfcaf2882e9b8d96975db16fb4bdcdcbacf Author: Father Chrysostomos <[email protected]> Date: Sat Sep 6 16:22:53 2014 -0700 Tweak Peek.t beab08741 introduced XSUB constants, but the code it added to newATTRSUB does not set CvSTASH if there is already a CV stub. It does set it if there is no sub there at all (because it goes through newCONSTSUB). Recent changes have made constant declarations like âsub foo(){}â put just a constant reference in the stash if possible, the way con- stant.pm does. When this gets upgraded to a typeglob, the CV is rei- fied via newCONSTSUB, so it gets a CvSTASH pointer. CvSTASH on a constant sub really makes no difference in practice. Itâs mostly cosmetic. This exercises the two code paths with the oldest perl installa- tion I have: $ /opt/bin/perl5.8.8 -MDevel::Peek -e 'BEGIN{\&foo} sub foo(){3} Dump \&foo' SV = RV(0x9baa18) at 0x98d580 REFCNT = 1 FLAGS = (TEMP,ROK) RV = 0x9b7398 SV = PVCV(0x9b4810) at 0x9b7398 REFCNT = 2 FLAGS = (POK,pPOK,CONST) IV = 0 NV = 0 PROTOTYPE = "" COMP_STASH = 0x98d4a8 "main" <---------- ROOT = 0x0 XSUB = 0x5bb44 XSUBANY = 10018864 GVGV::GV = 0x98df7c "main" :: "foo" FILE = "-e" DEPTH = 0 FLAGS = 0x200 OUTSIDE_SEQ = 96 PADLIST = 0x98e228 PADNAME = 0x98e24c(0x0) PAD = 0x98e264(0x22d560) OUTSIDE = 0x98df34 (UNIQUE) $ /opt/bin/perl5.8.8 -MDevel::Peek -e 'sub foo(){3} Dump \&foo' SV = RV(0xc11018) at 0xbe3b80 REFCNT = 1 FLAGS = (TEMP,ROK) RV = 0xbe4570 SV = PVCV(0xc0ae10) at 0xbe4570 REFCNT = 2 FLAGS = (POK,pPOK,CONST) IV = 0 NV = 0 PROTOTYPE = "" COMP_STASH = 0x0 <-------------------------- ROOT = 0x0 XSUB = 0x5bb44 XSUBANY = 12469628 GVGV::GV = 0xbe3c40 "main" :: "foo" FILE = "-e" DEPTH = 0 FLAGS = 0x200 OUTSIDE_SEQ = 0 PADLIST = 0x0 OUTSIDE = 0x0 (null) M ext/Devel-Peek/t/Peek.t commit 7a11f5c382a3ea35768e2f50d7dbeaed6adc2398 Author: Father Chrysostomos <[email protected]> Date: Sat Sep 6 13:09:05 2014 -0700 Fix-ups for Attribute::Handlers It was making unreliable assumptions about the contents of stashes. M dist/Attribute-Handlers/lib/Attribute/Handlers.pm commit 44b2d6d61b5b1b85de1be347091e97d57de8ae0c Author: Father Chrysostomos <[email protected]> Date: Sun Aug 31 18:05:49 2014 -0700 sv.h: Expand comment about potential SVf_UTF8 conflict M sv.h commit 2eaf799e74b14dc77b90d5484a3fd4ceac12b46a Author: Father Chrysostomos <[email protected]> Date: Sun Aug 31 20:13:21 2014 -0700 Avoid creating GVs when subs are declared This patch changes âsub foo {...}â declarations to store subroutine references in the stash, to save memory. Typeglobs still notionally exist. Accessing CvGV(cv) will reify them. Hence, currently the savings are lost when a sub call is compiled. $ ./miniperl -e 'sub foo{} BEGIN { warn $::{foo} } foo(); BEGIN { warn $::{foo} }' CODE(0x7f8ef082ad98) at -e line 1. *main::foo at -e line 1. This optimisation is skipped if the subroutine declaration contains a package separator. Concerning the changes in caller.t, this code: sub foo { print +(caller(0))[3],"\n" } my $fooref = delete $::{foo}; $fooref -> (); used to crash in 5.7.3 or thereabouts. It was fixed by 16658 (aka 07b8c804e8) to produce â(unknown)â instead. Then in 5.13.3 it was changed (by 803f274) to produce âmain::__ANON__â instead. So the tests are really checking that we donât get a crash. I think it is acceptable that it has now changed to âmain::fooâ. M embed.fnc M gv.c M op.c M pp.c M proto.h M t/op/caller.t M t/op/gv.t M t/uni/gv.t M t/uni/parser.t M toke.c M universal.c commit c831c5ee90b91c179042ccda588910ba60808970 Author: Father Chrysostomos <[email protected]> Date: Sat Sep 6 22:51:15 2014 -0700 Remove bogus gv-handling code from toke.c This code was added by 211a4342c, which was actually restoring some code that f74617600 removed. Its purpose was to expand a proxy to a real GV after we found out that we really are going to compile a sub call op. This code is actually unreachable at present (sub call lookup via rv2cv ops expands stub declarations, but not references to constants; references to constants are not compiled to sub calls), which is a good thing, because (1) it does not take UTF8 names into account and (2) it does not work with rv2cv hooks or our subs, because it assumes that the value of PL_tokenbuf is normative and can be used to reify a glob. M toke.c commit ae77754ae288180ef1b6bab63dd49fa724d9fddd Author: Father Chrysostomos <[email protected]> Date: Thu Aug 28 18:26:36 2014 -0700 For lexical subs, reify CvGV from CvSTASH and CvNAME_HEK From now on, the presence of a name hek implies a GV. Any access to CvGV will cause that implicit GV to be reified. M cv.h M embed.fnc M ext/B/t/b.t M gv.c M inline.h M op.c M pp_hot.c M proto.h M universal.c commit e38faec93a3dca999da366b2f1cec7a005c2b41b Author: Father Chrysostomos <[email protected]> Date: Thu Aug 28 17:40:23 2014 -0700 Increase $XS::APItest::VERSION to 0.64 M ext/XS-APItest/APItest.pm commit b5e03f43ef11bfbfbf1988690d634411c7f586de Author: Father Chrysostomos <[email protected]> Date: Thu Aug 28 17:39:48 2014 -0700 Test cv_name M MANIFEST M ext/XS-APItest/APItest.xs A ext/XS-APItest/t/cv_name.t commit fb094047d23498c516e24d2b3b3d8fbe138b39c6 Author: Father Chrysostomos <[email protected]> Date: Thu Aug 28 16:03:22 2014 -0700 pad.c: Document cv_name M pad.c commit f34d8cddb66ff0384d68d9388041c9a299f2bb09 Author: Father Chrysostomos <[email protected]> Date: Thu Aug 28 15:59:05 2014 -0700 sv_cathek This macro, intended for internal use, simplifies the code in a couple of places. M pad.c M sv.h M util.c commit c5569a55d25985ac28c100b33e16111ca928c1f9 Author: Father Chrysostomos <[email protected]> Date: Thu Aug 28 15:56:30 2014 -0700 cv_name An API function for getting the name of a CV. Docs to follow. M embed.fnc M embed.h M pad.c M proto.h commit f3feca7af46a3153748b8e8b033fc84562b4b9f3 Author: Father Chrysostomos <[email protected]> Date: Thu Aug 28 17:37:55 2014 -0700 Turn on CVf_LEXICAL for lexical subs This flag will signify that lexical subs should not have package names associated with them in error messages, etc. M gv.c M op.c M pad.c M scope.c commit 5bb151a5298022b008a5ed5db02fc631824f2670 Author: Father Chrysostomos <[email protected]> Date: Thu Aug 28 12:55:56 2014 -0700 Add CVf_LEXICAL flag Lexical subs will use this instead of CvNAMED to indicate that the name should not include the package. M cv.h ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + cv.h | 17 +- dist/Attribute-Handlers/lib/Attribute/Handlers.pm | 12 +- dump.c | 4 +- embed.fnc | 10 +- embed.h | 5 +- ext/B/B.pm | 17 +- ext/B/t/b.t | 6 +- ext/B/t/concise-xs.t | 2 +- ext/Devel-Peek/t/Peek.t | 14 +- ext/XS-APItest/APItest.pm | 2 +- ext/XS-APItest/APItest.xs | 7 + ext/XS-APItest/t/cv_name.t | 29 ++ gv.c | 53 +++- inline.h | 8 + lib/B/Deparse.pm | 17 +- mg.h | 1 + op.c | 358 ++++++++++++++++------ op.h | 5 +- pad.c | 54 +++- pp.c | 4 +- pp_hot.c | 21 +- proto.h | 38 ++- scope.c | 24 +- sv.h | 9 +- t/op/caller.t | 4 +- t/op/gv.t | 5 +- t/op/symbolcache.t | 2 +- t/uni/gv.t | 4 +- t/uni/parser.t | 5 +- toke.c | 21 +- universal.c | 8 +- util.c | 5 +- 33 files changed, 540 insertions(+), 232 deletions(-) create mode 100644 ext/XS-APItest/t/cv_name.t diff --git a/MANIFEST b/MANIFEST index eb29a94..34573fd 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3794,6 +3794,7 @@ ext/XS-APItest/t/coplabel.t test cop_*_label ext/XS-APItest/t/copstash.t test alloccopstash ext/XS-APItest/t/copyhints.t test hv_copy_hints_hv() API ext/XS-APItest/t/customop.t XS::APItest: tests for custom ops +ext/XS-APItest/t/cv_name.t test cv_name 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/fetch_pad_names.t Tests for UTF8 names in pad diff --git a/cv.h b/cv.h index 36afba7..c1f4456 100644 --- a/cv.h +++ b/cv.h @@ -49,8 +49,9 @@ See L<perlguts/Autoloading with XSUBs>. #define CvROOT(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_root_u.xcv_root #define CvXSUB(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_root_u.xcv_xsub #define CvXSUBANY(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_start_u.xcv_xsubany -#define CvGV(sv) S_CvGV((const CV *)(sv)) +#define CvGV(sv) S_CvGV(aTHX_ (CV *)(sv)) #define CvGV_set(cv,gv) Perl_cvgv_set(aTHX_ cv, gv) +#define CvHASGV(cv) cBOOL(SvANY(cv)->xcv_gv_u.xcv_gv) #define CvFILE(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_file #ifdef USE_ITHREADS # define CvFILE_set_from_cop(sv, cop) \ @@ -104,6 +105,7 @@ See L<perlguts/Autoloading with XSUBs>. #define CVf_AUTOLOAD 0x2000 /* SvPVX contains AUTOLOADed sub name */ #define CVf_HASEVAL 0x4000 /* contains string eval */ #define CVf_NAMED 0x8000 /* Has a name HEK */ +#define CVf_LEXICAL 0x10000 /* Omit package from name */ /* This symbol for optimised communication between toke.c and op.c: */ #define CVf_BUILTIN_ATTRS (CVf_METHOD|CVf_LVALUE) @@ -185,16 +187,13 @@ See L<perlguts/Autoloading with XSUBs>. #define CvNAMED_on(cv) (CvFLAGS(cv) |= CVf_NAMED) #define CvNAMED_off(cv) (CvFLAGS(cv) &= ~CVf_NAMED) +#define CvLEXICAL(cv) (CvFLAGS(cv) & CVf_LEXICAL) +#define CvLEXICAL_on(cv) (CvFLAGS(cv) |= CVf_LEXICAL) +#define CvLEXICAL_off(cv) (CvFLAGS(cv) &= ~CVf_LEXICAL) + /* Flags for newXS_flags */ #define XS_DYNAMIC_FILENAME 0x01 /* The filename isn't static */ -PERL_STATIC_INLINE GV * -S_CvGV(const CV *sv) -{ - return CvNAMED(sv) - ? 0 - : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv; -} PERL_STATIC_INLINE HEK * CvNAME_HEK(CV *sv) { @@ -269,6 +268,8 @@ should print 123: typedef OP *(*Perl_call_checker)(pTHX_ OP *, GV *, SV *); +#define CALL_CHECKER_REQUIRE_GV MGf_REQUIRE_GV + /* * Local variables: * c-indentation-style: bsd diff --git a/dist/Attribute-Handlers/lib/Attribute/Handlers.pm b/dist/Attribute-Handlers/lib/Attribute/Handlers.pm index 4ae65d9..17c4bb7 100644 --- a/dist/Attribute-Handlers/lib/Attribute/Handlers.pm +++ b/dist/Attribute-Handlers/lib/Attribute/Handlers.pm @@ -4,7 +4,7 @@ use Carp; use warnings; use strict; use vars qw($VERSION $AUTOLOAD); -$VERSION = '0.96'; # remember to update version in POD! +$VERSION = '0.97'; # remember to update version in POD! # $DB::single=1; my %symcache; @@ -13,12 +13,16 @@ sub findsym { return $symcache{$pkg,$ref} if $symcache{$pkg,$ref}; $type ||= ref($ref); no strict 'refs'; - foreach my $sym ( values %{$pkg."::"} ) { + my $symtab = \%{$pkg."::"}; + for ( keys %$symtab ) { for my $sym ( $$symtab{$_} ) { + if (ref $sym && $sym == $ref) { + return $symcache{$pkg,$ref} = \*{"$pkg:\:$_"}; + } use strict; next unless ref ( \$sym ) eq 'GLOB'; return $symcache{$pkg,$ref} = \$sym if *{$sym}{$type} && *{$sym}{$type} == $ref; - } + }} } my %validtype = ( @@ -266,7 +270,7 @@ Attribute::Handlers - Simpler definition of attribute handlers =head1 VERSION -This document describes version 0.96 of Attribute::Handlers. +This document describes version 0.97 of Attribute::Handlers. =head1 SYNOPSIS diff --git a/dump.c b/dump.c index 471b104..015bc49 100644 --- a/dump.c +++ b/dump.c @@ -1328,8 +1328,10 @@ const struct flag_to_name cv_flags_names[] = { {CVf_CVGV_RC, "CVGV_RC,"}, {CVf_DYNFILE, "DYNFILE,"}, {CVf_AUTOLOAD, "AUTOLOAD,"}, - {CVf_HASEVAL, "HASEVAL"}, + {CVf_HASEVAL, "HASEVAL,"}, {CVf_SLABBED, "SLABBED,"}, + {CVf_NAMED, "NAMED,"}, + {CVf_LEXICAL, "LEXICAL,"}, {CVf_ISXSUB, "ISXSUB,"} }; diff --git a/embed.fnc b/embed.fnc index 88adce2..09312e9 100644 --- a/embed.fnc +++ b/embed.fnc @@ -316,6 +316,7 @@ ApdRn |SV* |cv_const_sv |NULLOK const CV *const cv pRn |SV* |cv_const_sv_or_av|NULLOK const CV *const cv : Used in pad.c pR |SV* |op_const_sv |NULLOK const OP* o|NULLOK CV* cv +Ap |SV * |cv_name |NN CV *cv|NULLOK SV *sv Apd |void |cv_undef |NN CV* cv p |void |cv_forget_slab |NN CV *cv Ap |void |cx_dump |NN PERL_CONTEXT* cx @@ -534,6 +535,7 @@ Ap |void |gv_fullname4 |NN SV* sv|NN const GV* gv|NULLOK const char* prefix|bool : Used in scope.c pMox |GP * |newGP |NN GV *const gv pX |void |cvgv_set |NN CV* cv|NULLOK GV* gv +poX |GV * |cvgv_from_hek |NN CV* cv pX |void |cvstash_set |NN CV* cv|NULLOK HV* stash Amd |void |gv_init |NN GV* gv|NULLOK HV* stash \ |NN const char* name|STRLEN len|int multi @@ -1034,6 +1036,9 @@ po |OP* |ck_entersub_args_core|NN OP *entersubop|NN GV *namegv \ |NN SV *protosv Apd |void |cv_get_call_checker|NN CV *cv|NN Perl_call_checker *ckfun_p|NN SV **ckobj_p Apd |void |cv_set_call_checker|NN CV *cv|NN Perl_call_checker ckfun|NN SV *ckobj +Apd |void |cv_set_call_checker_flags|NN CV *cv \ + |NN Perl_call_checker ckfun \ + |NN SV *ckobj|U32 flags Apd |void |wrap_op_checker|Optype opcode|NN Perl_check_t new_checker|NN Perl_check_t *old_checker_p Apa |PERL_SI*|new_stackinfo|I32 stitems|I32 cxitems Ap |char* |scan_vstring |NN const char *s|NN const char *const e \ @@ -1920,7 +1925,6 @@ sR |OP* |search_const |NN OP *o sR |OP* |new_logop |I32 type|I32 flags|NN OP **firstp|NN OP **otherp s |void |simplify_sort |NN OP *o s |void |null_listop_in_list_context |NN OP* o -s |SV* |gv_ename |NN GV *gv sRn |bool |scalar_mod_type|NULLOK const OP *o|I32 type s |OP * |my_kid |NULLOK OP *o|NULLOK OP *attrs|NN OP **imopsp s |OP * |dup_attrlist |NN OP *o @@ -1930,16 +1934,14 @@ s |void |bad_type_pv |I32 n|NN const char *t|NN const char *name|U32 flags|NN co s |void |bad_type_gv |I32 n|NN const char *t|NN GV *gv|U32 flags|NN const OP *kid s |void |no_bareword_allowed|NN OP *o sR |OP* |no_fh_allowed|NN OP *o -sR |OP* |too_few_arguments_sv|NN OP *o|NN SV* namesv|U32 flags sR |OP* |too_few_arguments_pv|NN OP *o|NN const char* name|U32 flags s |OP* |too_many_arguments_pv|NN OP *o|NN const char* name|U32 flags -sR |OP* |too_many_arguments_sv|NN OP *o|NN SV* namesv|U32 flags s |bool |looks_like_bool|NN const OP* o s |OP* |newGIVWHENOP |NULLOK OP* cond|NN OP *block \ |I32 enter_opcode|I32 leave_opcode \ |PADOFFSET entertarg s |OP* |ref_array_or_hash|NULLOK OP* cond -s |void |process_special_blocks |I32 floor \ +s |bool |process_special_blocks |I32 floor \ |NN const char *const fullname\ |NN GV *const gv|NN CV *const cv s |void |clear_special_blocks |NN const char *const fullname\ diff --git a/embed.h b/embed.h index 17d1fd5..66fc634 100644 --- a/embed.h +++ b/embed.h @@ -100,7 +100,9 @@ #define cv_clone(a) Perl_cv_clone(aTHX_ a) #define cv_const_sv Perl_cv_const_sv #define cv_get_call_checker(a,b,c) Perl_cv_get_call_checker(aTHX_ a,b,c) +#define cv_name(a,b) Perl_cv_name(aTHX_ a,b) #define cv_set_call_checker(a,b,c) Perl_cv_set_call_checker(aTHX_ a,b,c) +#define cv_set_call_checker_flags(a,b,c,d) Perl_cv_set_call_checker_flags(aTHX_ a,b,c,d) #define cv_undef(a) Perl_cv_undef(aTHX_ a) #define cx_dump(a) Perl_cx_dump(aTHX_ a) #define cxinc() Perl_cxinc(aTHX) @@ -1501,7 +1503,6 @@ #define force_list(a,b) S_force_list(aTHX_ a,b) #define forget_pmop(a) S_forget_pmop(aTHX_ a) #define gen_constant_list(a) S_gen_constant_list(aTHX_ a) -#define gv_ename(a) S_gv_ename(aTHX_ a) #define inplace_aassign(a) S_inplace_aassign(aTHX_ a) #define is_handle_constructor S_is_handle_constructor #define is_list_assignment(a) S_is_list_assignment(aTHX_ a) @@ -1529,9 +1530,7 @@ #define search_const(a) S_search_const(aTHX_ a) #define simplify_sort(a) S_simplify_sort(aTHX_ a) #define too_few_arguments_pv(a,b,c) S_too_few_arguments_pv(aTHX_ a,b,c) -#define too_few_arguments_sv(a,b,c) S_too_few_arguments_sv(aTHX_ a,b,c) #define too_many_arguments_pv(a,b,c) S_too_many_arguments_pv(aTHX_ a,b,c) -#define too_many_arguments_sv(a,b,c) S_too_many_arguments_sv(aTHX_ a,b,c) # endif # if defined(PERL_IN_OP_C) || defined(PERL_IN_SV_C) #define report_redefined_cv(a,b,c) Perl_report_redefined_cv(aTHX_ a,b,c) diff --git a/ext/B/B.pm b/ext/B/B.pm index c908f51..edeab59 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -15,7 +15,7 @@ require Exporter; # walkoptree comes from B.xs BEGIN { - $B::VERSION = '1.50'; + $B::VERSION = '1.51'; @B::EXPORT_OK = (); # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK. @@ -35,7 +35,7 @@ push @B::EXPORT_OK, (qw(minus_c ppname save_BEGINs parents comppadlist sv_undef compile_stats timing_info begin_av init_av check_av end_av regex_padav dowarn defstash curstash warnhook diehook inc_gv @optype - @specialsv_name unitcheck_av)); + @specialsv_name unitcheck_av safename)); @B::SV::ISA = 'B::OBJECT'; @B::NULL::ISA = 'B::SV'; @@ -85,7 +85,11 @@ push @B::EXPORT_OK, (qw(minus_c ppname save_BEGINs } sub B::GV::SAFENAME { - my $name = (shift())->NAME; + safename(shift()->NAME); +} + +sub safename { + my $name = shift; # The regex below corresponds to the isCONTROLVAR macro # from toke.c @@ -537,6 +541,13 @@ be used as a string in C source code. Returns a double-quote-surrounded escaped version of STR which can be used as a string in Perl source code. +=item safename(STR) + +This function returns the string with the first character modified if it +is a control character. It converts it to ^X format first, so that "\cG" +becomes "^G". This is used internally by L<B::GV::SAFENAME|/SAFENAME>, but +you can call it directly. + =item class(OBJ) Returns the class of an object without the part of the classname diff --git a/ext/B/t/b.t b/ext/B/t/b.t index 27b4105..9933978 100644 --- a/ext/B/t/b.t +++ b/ext/B/t/b.t @@ -300,6 +300,8 @@ foo can_ok $f, 'LINES'; } +is B::safename("\cLAST_FH"), "^LAST_FH", 'basic safename test'; + my $sub1 = sub {die}; { no warnings 'once'; no strict; *Peel:: = *{"Pe\0e\x{142}::"} } my $sub2 = eval 'package Peel; sub {die}'; @@ -404,10 +406,10 @@ SKIP: my $cv = B::svref_2object(\&bar); ok($cv, "make a B::CV from a lexical sub reference"); isa_ok($cv, "B::CV"); - my $gv = $cv->GV; - isa_ok($gv, "B::SPECIAL", "GV on a lexical sub"); my $hek = $cv->NAME_HEK; is($hek, "bar", "check the NAME_HEK"); + my $gv = $cv->GV; + isa_ok($gv, "B::GV", "GV on a lexical sub"); } 1; EOS diff --git a/ext/B/t/concise-xs.t b/ext/B/t/concise-xs.t index 2f1737a..c2258f7 100644 --- a/ext/B/t/concise-xs.t +++ b/ext/B/t/concise-xs.t @@ -138,7 +138,7 @@ my $testpkgs = { perl => [qw( walksymtable walkoptree_slow walkoptree_exec timing_info savesym peekop parents objsym debug - compile_stats clearsym class + compile_stats clearsym class safename )], XS => [qw( warnhook walkoptree_debug walkoptree threadsv_names diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index ce777da..492b8ed 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/ext/Devel-Peek/t/Peek.t @@ -331,8 +331,8 @@ do_test('reference to named subroutine without prototype', RV = $ADDR SV = PVCV\\($ADDR\\) at $ADDR REFCNT = (3|4) - FLAGS = \\((?:HASEVAL)?\\) # $] < 5.015 || !thr - FLAGS = \\(DYNFILE(?:,HASEVAL)?\\) # $] >= 5.015 && thr + FLAGS = \\((?:HASEVAL(?:,NAMED)?)?\\) # $] < 5.015 || !thr + FLAGS = \\(DYNFILE(?:,HASEVAL(?:,NAMED)?)?\\) # $] >= 5.015 && thr IV = 0 # $] < 5.009 NV = 0 # $] < 5.009 COMP_STASH = $ADDR\\t"main" @@ -340,13 +340,14 @@ do_test('reference to named subroutine without prototype', ROOT = $ADDR XSUB = 0x0 # $] < 5.009 XSUBANY = 0 # $] < 5.009 - GVGV::GV = $ADDR\\t"main" :: "do_test" + NAME = "do_test" # $] >=5.021004 + GVGV::GV = $ADDR\\t"main" :: "do_test" # $] < 5.021004 FILE = ".*\\b(?i:peek\\.t)" DEPTH = 1(?: MUTEXP = $ADDR OWNER = $ADDR)? - FLAGS = 0x(?:400)?0 # $] < 5.015 || !thr - FLAGS = 0x[145]000 # $] >= 5.015 && thr + FLAGS = 0x(?:[c4]00)?0 # $] < 5.015 || !thr + FLAGS = 0x[cd145]000 # $] >= 5.015 && thr OUTSIDE_SEQ = \\d+ PADLIST = $ADDR PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\) @@ -698,7 +699,8 @@ do_test('constant subroutine', IV = 0 # $] < 5.009 NV = 0 # $] < 5.009 PROTOTYPE = "" - COMP_STASH = 0x0 + COMP_STASH = 0x0 # $] < 5.021004 + COMP_STASH = $ADDR "main" # $] >=5.021004 ROOT = 0x0 # $] < 5.009 XSUB = $ADDR XSUBANY = $ADDR \\(CONST SV\\) diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index 7fed553..2950eaf 100644 --- a/ext/XS-APItest/APItest.pm +++ b/ext/XS-APItest/APItest.pm @@ -5,7 +5,7 @@ use strict; use warnings; use Carp; -our $VERSION = '0.63'; +our $VERSION = '0.64'; require XSLoader; diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 54ee2da..777e342 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -3589,6 +3589,13 @@ alias_av(AV *av, IV ix, SV *sv) CODE: av_store(av, ix, SvREFCNT_inc(sv)); +SV * +cv_name(SVREF ref, ...) + CODE: + RETVAL = SvREFCNT_inc(cv_name((CV *)ref, items>1 ? ST(1) : NULL)); + OUTPUT: + RETVAL + MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest int diff --git a/ext/XS-APItest/t/cv_name.t b/ext/XS-APItest/t/cv_name.t new file mode 100644 index 0000000..cc6202a --- /dev/null +++ b/ext/XS-APItest/t/cv_name.t @@ -0,0 +1,29 @@ +use XS::APItest; +use Test::More tests => 15; +use feature "lexical_subs", "state"; +no warnings "experimental::lexical_subs"; + +is (cv_name(\&foo), 'main::foo', 'cv_name with package sub'); +is (cv_name(*{"foo"}{CODE}), 'main::foo', + 'cv_name with package sub via glob'); +is (cv_name(\*{"foo"}), 'main::foo', 'cv_name with typeglob'); +is (cv_name(\"foo"), 'foo', 'cv_name with string'); +state sub lex1; +is (cv_name(\&lex1), 'lex1', 'cv_name with lexical sub'); + +$ret = \cv_name(\&bar, $name); +is $ret, \$name, 'cv_name with package sub returns 2nd argument'; +is ($name, 'main::bar', 'retval of cv_name with package sub & 2nd arg'); +$ret = \cv_name(*{"bar"}{CODE}, $name); +is $ret, \$name, 'cv_name with package sub via glob returns 2nd argument'; +is ($name, 'main::bar', 'retval of cv_name w/pkg sub via glob & 2nd arg'); +$ret = \cv_name(\*{"bar"}, $name); +is $ret, \$name, 'cv_name with typeglob returns 2nd argument'; +is ($name, 'main::bar', 'retval of cv_name with typeglob & 2nd arg'); +$ret = \cv_name(\"bar", $name); +is $ret, \$name, 'cv_name with string returns 2nd argument'; +is ($name, 'bar', 'retval of cv_name with string & 2nd arg'); +state sub lex2; +$ret = \cv_name(\&lex2, $name); +is $ret, \$name, 'cv_name with lexical sub returns 2nd argument'; +is ($name, 'lex2', 'retval of cv_name with lexical sub & 2nd arg'); diff --git a/gv.c b/gv.c index 5cbcf62..1b490f8 100644 --- a/gv.c +++ b/gv.c @@ -216,7 +216,7 @@ Perl_newGP(pTHX_ GV *const gv) void Perl_cvgv_set(pTHX_ CV* cv, GV* gv) { - GV * const oldgv = CvGV(cv); + GV * const oldgv = CvNAMED(cv) ? NULL : SvANY(cv)->xcv_gv_u.xcv_gv; HEK *hek; PERL_ARGS_ASSERT_CVGV_SET; @@ -235,6 +235,7 @@ Perl_cvgv_set(pTHX_ CV* cv, GV* gv) else if ((hek = CvNAME_HEK(cv))) { unshare_hek(hek); CvNAMED_off(cv); + CvLEXICAL_off(cv); } SvANY(cv)->xcv_gv_u.xcv_gv = gv; @@ -251,6 +252,37 @@ Perl_cvgv_set(pTHX_ CV* cv, GV* gv) } } +/* Convert CvSTASH + CvNAME_HEK into a GV. Conceptually, all subs have a + GV, but for efficiency that GV may not in fact exist. This function, + called by CvGV, reifies it. */ + +GV * +Perl_cvgv_from_hek(pTHX_ CV *cv) +{ + GV *gv; + SV **svp; + PERL_ARGS_ASSERT_CVGV_FROM_HEK; + assert(SvTYPE(cv) == SVt_PVCV); + if (!CvSTASH(cv)) return NULL; + ASSUME(CvNAME_HEK(cv)); + svp = hv_fetchhek(CvSTASH(cv), CvNAME_HEK(cv), 0); + gv = MUTABLE_GV(svp && *svp ? *svp : newSV(0)); + if (!isGV(gv)) + gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)), + HEK_LEN(CvNAME_HEK(cv)), + SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv))); + if (!CvNAMED(cv)) { /* gv_init took care of it */ + assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv); + return gv; + } + unshare_hek(CvNAME_HEK(cv)); + CvNAMED_off(cv); + SvANY(cv)->xcv_gv_u.xcv_gv = gv; + if (svp && *svp) SvREFCNT_inc_simple_void_NN(gv); + CvCVGV_RC_on(cv); + return gv; +} + /* Assign CvSTASH(cv) = st, handling weak references. */ void @@ -346,10 +378,9 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag assert (!(proto && has_constant)); if (has_constant) { - /* The constant has to be a simple scalar type. */ + /* The constant has to be a scalar, array or subroutine. */ switch (SvTYPE(has_constant)) { case SVt_PVHV: - case SVt_PVCV: case SVt_PVFM: case SVt_PVIO: Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob", @@ -385,7 +416,21 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 )); if (flags & GV_ADDMULTI || doproto) /* doproto means it */ GvMULTI_on(gv); /* _was_ mentioned */ - if (doproto) { + if (has_constant && SvTYPE(has_constant) == SVt_PVCV) { + /* Not actually a constant. Just a regular sub. */ + CV * const cv = (CV *)has_constant; + GvCV_set(gv,cv); + if (CvSTASH(cv) == stash && ( + CvNAME_HEK(cv) == GvNAME_HEK(gv) + || ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv)) + && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv)) + && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv)) + && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv)) + ) + )) + CvGV_set(cv,gv); + } + else if (doproto) { CV *cv; if (has_constant) { /* newCONSTSUB takes ownership of the reference from us. */ diff --git a/inline.h b/inline.h index 0792694..ad6edf2 100644 --- a/inline.h +++ b/inline.h @@ -25,6 +25,14 @@ S_av_top_index(pTHX_ AV *av) /* ------------------------------- cv.h ------------------------------- */ +PERL_STATIC_INLINE GV * +S_CvGV(pTHX_ CV *sv) +{ + return CvNAMED(sv) + ? Perl_cvgv_from_hek(aTHX_ sv) + : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv; +} + PERL_STATIC_INLINE I32 * S_CvDEPTHp(const CV * const sv) { diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm index c15b333..0e7fa57 100644 --- a/lib/B/Deparse.pm +++ b/lib/B/Deparse.pm @@ -1420,9 +1420,14 @@ sub gv_name { my $self = shift; my $gv = shift; my $raw = shift; -Carp::confess() unless ref($gv) eq "B::GV"; - my $stash = $gv->STASH->NAME; - my $name = $raw ? $gv->NAME : $gv->SAFENAME; +#Carp::confess() unless ref($gv) eq "B::GV"; + my $cv = $gv->FLAGS & SVf_ROK ? $gv->RV : 0; + my $stash = ($cv || $gv)->STASH->NAME; + my $name = $raw + ? $cv ? $cv->NAME_HEK || $cv->GV->NAME : $gv->NAME + : $cv + ? B::safename($cv->NAME_HEK || $cv->GV->NAME) + : $gv->SAFENAME; if ($stash eq 'main' && $name =~ /^::/) { $stash = '::'; } @@ -3848,8 +3853,10 @@ sub pp_entersub { $kid = "{" . $self->deparse($kid, 0) . "}"; } elsif ($kid->first->name eq "gv") { my $gv = $self->gv_or_padgv($kid->first); - if (class($gv->CV) ne "SPECIAL") { - $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK; + my $cv; + if (class($gv) eq 'GV' && class($cv = $gv->CV) ne "SPECIAL" + || $gv->FLAGS & SVf_ROK && class($cv = $gv->RV) eq 'CV') { + $proto = $cv->PV if $cv->FLAGS & SVf_POK; } $simple = 1; # only calls of named functions can be prototyped $kid = $self->deparse($kid, 24); diff --git a/mg.h b/mg.h index 81ed296..0f2fa29 100644 --- a/mg.h +++ b/mg.h @@ -33,6 +33,7 @@ struct magic { #define MGf_TAINTEDDIR 1 /* PERL_MAGIC_envelem only */ #define MGf_MINMATCH 1 /* PERL_MAGIC_regex_global only */ +#define MGf_REQUIRE_GV 1 /* PERL_MAGIC_checkcall only */ #define MGf_REFCOUNTED 2 #define MGf_GSKIP 4 /* skip further GETs until after next SET */ #define MGf_COPY 8 /* has an svt_copy MGVTBL entry */ diff --git a/op.c b/op.c index aba7a9b..2e844bf 100644 --- a/op.c +++ b/op.c @@ -496,17 +496,6 @@ Perl_op_refcnt_dec(pTHX_ OP *o) o->op_ppaddr = PL_ppaddr[type]; \ } STMT_END -STATIC SV* -S_gv_ename(pTHX_ GV *gv) -{ - SV* const tmpsv = sv_newmortal(); - - PERL_ARGS_ASSERT_GV_ENAME; - - gv_efullname3(tmpsv, gv, NULL); - return tmpsv; -} - STATIC OP * S_no_fh_allowed(pTHX_ OP *o) { @@ -518,15 +507,6 @@ S_no_fh_allowed(pTHX_ OP *o) } STATIC OP * -S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags) -{ - PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV; - yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, SVfARG(namesv)), - SvUTF8(namesv) | flags); - return o; -} - -STATIC OP * S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags) { PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV; @@ -543,16 +523,6 @@ S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags) return o; } -STATIC OP * -S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags) -{ - PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV; - - yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)), - SvUTF8(namesv) | flags); - return o; -} - STATIC void S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid) { @@ -565,7 +535,7 @@ S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP STATIC void S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid) { - SV * const namesv = gv_ename(gv); + SV * const namesv = cv_name((CV *)gv, NULL); PERL_ARGS_ASSERT_BAD_TYPE_GV; yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)", @@ -2393,6 +2363,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) else { /* Compile-time error message: */ OP *kid = cUNOPo->op_first; CV *cv; + GV *gv; if (kid->op_type != OP_PUSHMARK) { if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) @@ -2420,7 +2391,12 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) break; } - cv = GvCV(kGVOP_gv); + gv = kGVOP_gv; + cv = isGV(gv) + ? GvCV(gv) + : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV + ? MUTABLE_CV(SvRV(gv)) + : NULL; if (!cv) break; if (CvLVALUE(cv)) @@ -7058,12 +7034,19 @@ Perl_newWHENOP(pTHX_ OP *cond, OP *block) return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0); } +/* must not conflict with SVf_UTF8 */ +#define CV_CKPROTO_CURSTASH 0x1 + void Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p, const STRLEN len, const U32 flags) { SV *name = NULL, *msg; - const char * cvp = SvROK(cv) ? "" : CvPROTO(cv); + const char * cvp = SvROK(cv) + ? SvTYPE(SvRV_const(cv)) == SVt_PVCV + ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv)) + : "" + : CvPROTO(cv); STRLEN clen = CvPROTOLEN(cv), plen = len; PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS; @@ -7100,6 +7083,16 @@ Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p, gv_efullname3(name = sv_newmortal(), gv, NULL); else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&') name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP); + else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) { + name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash))); + sv_catpvs(name, "::"); + if (SvROK(gv)) { + assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV); + assert (CvNAMED(SvRV_const(gv))); + sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv)))); + } + else sv_catsv(name, (SV *)gv); + } else name = (SV *)gv; } sv_setpvs(msg, "Prototype mismatch:"); @@ -7377,6 +7370,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), hash ) ); + CvLEXICAL_on(*spot); } if (mg) { assert(mg->mg_obj); @@ -7503,6 +7497,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) *spot = cv; } setname: + CvLEXICAL_on(cv); if (!CvNAME_HEK(cv)) { if (hek) (void)share_hek_hek(hek); else { @@ -7650,7 +7645,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, /* If the subroutine has no body, no attributes, and no builtin attributes then it's just a sub declaration, and we may be able to get away with storing with a placeholder scalar in the symbol table, rather than a - full GV and CV. If anything is present then it will take a full CV to + full CV. If anything is present then it will take a full CV to store it. */ const I32 gv_fetch_flags = ec ? GV_NOADD_NOINIT : @@ -7664,13 +7659,27 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, #ifdef PERL_DEBUG_READONLY_OPS OPSLAB *slab = NULL; #endif + bool special = FALSE; if (o_is_gv) { gv = (GV*)o; o = NULL; has_name = TRUE; } else if (name) { - gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV); + /* Try to optimise and avoid creating a GV. Instead, the CVâs name + hek and CvSTASH pointer together can imply the GV. If the name + contains a package name, then GvSTASH(CvGV(cv)) may differ from + CvSTASH, so forego the optimisation if we find any. + Also, we may be called from load_module at run time, so + PL_curstash (which sets CvSTASH) may not point to the stash the + sub is stored in. */ + const I32 flags = + ec ? GV_NOADD_NOINIT + : PL_curstash != CopSTASH(PL_curcop) + || memchr(name, ':', namlen) || memchr(name, '\'', namlen) + ? gv_fetch_flags + : GV_ADDMULTI | GV_NOINIT; + gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV); has_name = TRUE; } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) { SV * const sv = sv_newmortal(); @@ -7687,7 +7696,8 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, has_name = FALSE; } if (!ec) - move_proto_attr(&proto, &attrs, gv); + move_proto_attr(&proto, &attrs, + isGV(gv) ? gv : (GV *)cSVOPo->op_sv); if (proto) { assert(proto->op_type == OP_CONST); @@ -7726,8 +7736,18 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, goto done; } - if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at - maximum a prototype before. */ + if (!block && SvTYPE(gv) != SVt_PVGV) { + /* If we are not defining a new sub and the existing one is not a + full GV + CV... */ + if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) { + /* We are applying attributes to an existing sub, so we need it + upgraded if it is a constant. */ + if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV) + gv_init_pvn(gv, PL_curstash, name, namlen, + SVf_UTF8 * name_is_utf8); + } + else { /* Maybe prototype now, and had at maximum + a prototype or const/sub ref before. */ if (SvTYPE(gv) > SVt_NULL) { cv_ckproto_len_flags((const CV *)gv, o ? (const GV *)cSVOPo->op_sv : NULL, ps, @@ -7745,9 +7765,17 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, SvREFCNT_dec(PL_compcv); cv = PL_compcv = NULL; goto done; + } } - cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv); + cv = (!name || (isGV(gv) && GvCVGEN(gv))) + ? NULL + : isGV(gv) + ? GvCV(gv) + : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV + ? (CV *)SvRV(gv) + : NULL; + if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) @@ -7756,6 +7784,38 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, else const_sv = op_const_sv(block, NULL); + if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) { + assert (block); + cv_ckproto_len_flags((const CV *)gv, + o ? (const GV *)cSVOPo->op_sv : NULL, ps, + ps_len, ps_utf8|CV_CKPROTO_CURSTASH); + if (SvROK(gv)) { + /* All the other code for sub redefinition warnings expects the + clobbered sub to be a CV. Instead of making all those code + paths more complex, just inline the RV version here. */ + const line_t oldline = CopLINE(PL_curcop); + assert(IN_PERL_COMPILETIME); + if (PL_parser && PL_parser->copline != NOLINE) + /* This ensures that warnings are reported at the first + line of a redefinition, not the last. */ + CopLINE_set(PL_curcop, PL_parser->copline); + /* protect against fatal warnings leaking compcv */ + SAVEFREESV(PL_compcv); + + if (ckWARN(WARN_REDEFINE) + || ( ckWARN_d(WARN_REDEFINE) + && ( !const_sv || SvRV(gv) == const_sv + || sv_cmp(SvRV(gv), const_sv) ))) + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + "Constant subroutine %"SVf" redefined", + SVfARG(cSVOPo->op_sv)); + + SvREFCNT_inc_simple_void_NN(PL_compcv); + CopLINE_set(PL_curcop, oldline); + SvREFCNT_dec(SvRV(gv)); + } + } + if (cv) { const bool exists = CvROOT(cv) || CvXSUB(cv); @@ -7766,7 +7826,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (exists || SvPOK(cv)) cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8); /* already defined (or promised)? */ - if (exists || GvASSUMECV(gv)) { + if (exists || (isGV(gv) && GvASSUMECV(gv))) { if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv)) cv = NULL; else { @@ -7790,11 +7850,22 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, CvISXSUB_on(cv); } else { - if (name) GvCV_set(gv, NULL); - cv = newCONSTSUB_flags( - NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0, - const_sv - ); + if (isGV(gv)) { + if (name) GvCV_set(gv, NULL); + cv = newCONSTSUB_flags( + NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0, + const_sv + ); + } + else { + if (!SvROK(gv)) { + SV_CHECK_THINKFIRST_COW_DROP((SV *)gv); + prepare_SV_for_RV((SV *)gv); + SvOK_off((SV *)gv); + SvROK_on(gv); + } + SvRV_set(gv, const_sv); + } } op_free(block); SvREFCNT_dec(PL_compcv); @@ -7812,12 +7883,23 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE); OP * const cvstart = CvSTART(cv); - CvGV_set(cv,gv); - assert(!CvCVGV_RC(cv)); - assert(CvGV(cv) == gv); + if (isGV(gv)) { + CvGV_set(cv,gv); + assert(!CvCVGV_RC(cv)); + assert(CvGV(cv) == gv); + } + else { + U32 hash; + PERL_HASH(hash, name, namlen); + CvNAME_HEK_set(cv, + share_hek(name, + name_is_utf8 ? -namlen : namlen, + hash)); + } SvPOK_off(cv); - CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs; + CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs + | CvNAMED(cv); CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); CvPADLIST(cv) = CvPADLIST(PL_compcv); @@ -7849,16 +7931,32 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, } else { cv = PL_compcv; - if (name) { + if (name && isGV(gv)) { GvCV_set(gv, cv); GvCVGEN(gv) = 0; if (HvENAME_HEK(GvSTASH(gv))) /* sub Foo::bar { (shift)+1 } */ gv_method_changed(gv); } + else if (name) { + if (!SvROK(gv)) { + SV_CHECK_THINKFIRST_COW_DROP((SV *)gv); + prepare_SV_for_RV((SV *)gv); + SvOK_off((SV *)gv); + SvROK_on(gv); + } + SvRV_set(gv, (SV *)cv); + } } - if (!CvGV(cv)) { - CvGV_set(cv, gv); + if (!CvHASGV(cv)) { + if (isGV(gv)) CvGV_set(cv, gv); + else { + U32 hash; + PERL_HASH(hash, name, namlen); + CvNAME_HEK_set(cv, share_hek(name, + name_is_utf8 ? -namlen : namlen, + hash)); + } CvFILE_set_from_cop(cv, PL_curcop); CvSTASH_set(cv, PL_curstash); } @@ -7915,7 +8013,9 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, attrs: if (attrs) { /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */ - HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash; + HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv)) + ? GvSTASH(CvGV(cv)) + : PL_curstash; if (!name) SAVEFREESV(cv); apply_attrs(stash, MUTABLE_SV(cv), attrs); if (!name) SvREFCNT_inc_simple_void_NN(cv); @@ -7923,7 +8023,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (block && has_name) { if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { - SV * const tmpstr = sv_newmortal(); + SV * const tmpstr = cv_name(cv,NULL); GV * const db_postponed = gv_fetchpvs("DB::postponed", GV_ADDMULTI, SVt_PVHV); HV *hv; @@ -7931,7 +8031,6 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, CopFILE(PL_curcop), (long)PL_subline, (long)CopLINE(PL_curcop)); - gv_efullname3(tmpstr, gv, NULL); (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0); hv = GvHVn(db_postponed); @@ -7951,7 +8050,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (PL_parser && PL_parser->error_count) clear_special_blocks(name, gv, cv); else - process_special_blocks(floor, name, gv, cv); + special = process_special_blocks(floor, name, gv, cv); } } @@ -7961,7 +8060,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, LEAVE_SCOPE(floor); #ifdef PERL_DEBUG_READONLY_OPS /* Watch out for BEGIN blocks */ - if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab); + if (!special) Slab_to_ro(slab); #endif return cv; } @@ -7982,12 +8081,16 @@ S_clear_special_blocks(pTHX_ const char *const fullname, || (*name == 'U' && strEQ(name, "UNITCHECK")) || (*name == 'C' && strEQ(name, "CHECK")) || (*name == 'I' && strEQ(name, "INIT"))) { + if (!isGV(gv)) { + (void)CvGV(cv); + assert(isGV(gv)); + } GvCV_set(gv, NULL); SvREFCNT_dec_NN(MUTABLE_SV(cv)); } } -STATIC void +STATIC bool S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, GV *const gv, CV *const cv) @@ -8001,6 +8104,7 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, if (strEQ(name, "BEGIN")) { const I32 oldscope = PL_scopestack_ix; dSP; + (void)CvGV(cv); if (floor) LEAVE_SCOPE(floor); ENTER; PUSHSTACKi(PERLSI_REQUIRE); @@ -8015,23 +8119,24 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, POPSTACK; LEAVE; + return TRUE; } else - return; + return FALSE; } else { if (*name == 'E') { if strEQ(name, "END") { DEBUG_x( dump_sub(gv) ); Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv)); } else - return; + return FALSE; } else if (*name == 'U') { if (strEQ(name, "UNITCHECK")) { /* It's never too late to run a unitcheck block */ Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv)); } else - return; + return FALSE; } else if (*name == 'C') { if (strEQ(name, "CHECK")) { if (PL_main_start) @@ -8041,7 +8146,7 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv)); } else - return; + return FALSE; } else if (*name == 'I') { if (strEQ(name, "INIT")) { if (PL_main_start) @@ -8051,11 +8156,13 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv)); } else - return; + return FALSE; } else - return; + return FALSE; DEBUG_x( dump_sub(gv) ); + (void)CvGV(cv); GvCV_set(gv,0); /* cv has been hijacked */ + return TRUE; } } @@ -8848,10 +8955,6 @@ Perl_ck_rvconst(pTHX_ OP *o) if (kid->op_type == OP_CONST) { int iscv; - const int noexpand = o->op_type == OP_RV2CV - && o->op_private & OPpMAY_RETURN_CONSTANT - ? GV_NOEXPAND - : 0; GV *gv; SV * const kidsv = kid->op_sv; @@ -8889,10 +8992,11 @@ Perl_ck_rvconst(pTHX_ OP *o) * or we get possible typo warnings. OPpCONST_ENTERED says * whether the lexer already added THIS instance of this symbol. */ - iscv = (o->op_type == OP_RV2CV) * 2; + iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0; gv = gv_fetchsv(kidsv, - noexpand - ? noexpand + o->op_type == OP_RV2CV + && o->op_private & OPpMAY_RETURN_CONSTANT + ? GV_NOEXPAND : iscv | !(kid->op_private & OPpCONST_ENTERED), iscv ? SVt_PVCV @@ -8904,6 +9008,13 @@ Perl_ck_rvconst(pTHX_ OP *o) ? SVt_PVHV : SVt_PVGV); if (gv) { + if (!isGV(gv)) { + assert(iscv); + assert(SvROK(gv)); + if (!(o->op_private & OPpMAY_RETURN_CONSTANT) + && SvTYPE(SvRV(gv)) != SVt_PVCV) + gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV); + } kid->op_type = OP_GV; SvREFCNT_dec(kid->op_sv); #ifdef USE_ITHREADS @@ -10141,6 +10252,11 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) case OP_GV: { gv = cGVOPx_gv(rvop); if (!isGV(gv)) { + if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) { + cv = MUTABLE_CV(SvRV(gv)); + gv = NULL; + break; + } if (flags & RV2CVOPCV_RETURN_STUB) return (CV *)gv; else return NULL; @@ -10169,8 +10285,9 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) } if (SvTYPE((SV*)cv) != SVt_PVCV) return NULL; - if (flags & RV2CVOPCV_RETURN_NAME_GV) { - if (!CvANON(cv) || !gv) + if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) { + if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv) + && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv))) gv = CvGV(cv); return (CV*)gv; } else { @@ -10266,7 +10383,12 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) OP* o3 = aop; if (proto >= proto_end) - return too_many_arguments_sv(entersubop, gv_ename(namegv), 0); + { + SV * const namesv = cv_name((CV *)namegv, NULL); + yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, + SVfARG(namesv)), SvUTF8(namesv)); + return entersubop; + } switch (*proto) { case ';': @@ -10416,10 +10538,9 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) continue; default: oops: { - SV* const tmpsv = sv_newmortal(); - gv_efullname3(tmpsv, namegv, NULL); Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf, - SVfARG(tmpsv), SVfARG(protosv)); + SVfARG(cv_name((CV *)namegv, NULL)), + SVfARG(protosv)); } } @@ -10433,7 +10554,11 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) } if (!optional && proto_end > proto && (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) - return too_few_arguments_sv(entersubop, gv_ename(namegv), 0); + { + SV * const namesv = cv_name((CV *)namegv, NULL); + yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, + SVfARG(namesv)), SvUTF8(namesv)); + } return entersubop; } @@ -10601,24 +10726,33 @@ by L</cv_set_call_checker>. =cut */ -void -Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p) +static void +S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p, + U8 *flagsp) { MAGIC *callmg; - PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER; - PERL_UNUSED_CONTEXT; callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL; if (callmg) { *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr); *ckobj_p = callmg->mg_obj; + if (flagsp) *flagsp = callmg->mg_flags; } else { *ckfun_p = Perl_ck_entersub_args_proto_or_list; *ckobj_p = (SV*)cv; + if (flagsp) *flagsp = 0; } } +void +Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p) +{ + PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER; + PERL_UNUSED_CONTEXT; + return S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL); +} + /* -=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj +=for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags Sets the function that will be used to fix up a call to I<cv>. Specifically, the function is applied to an C<entersub> op tree for a @@ -10635,15 +10769,25 @@ It is intended to be called in this manner: entersubop = ckfun(aTHX_ entersubop, namegv, ckobj); In this call, I<entersubop> is a pointer to the C<entersub> op, -which may be replaced by the check function, and I<namegv> is a GV -supplying the name that should be used by the check function to refer +which may be replaced by the check function, and I<namegv> supplies +the name that should be used by the check function to refer to the callee of the C<entersub> op if it needs to emit any diagnostics. It is permitted to apply the check function in non-standard situations, such as to a call to a different subroutine or to a method call. +I<namegv> may not actually be a GV. For efficiency, perl may pass a +CV or other SV instead. Whatever is passed can be used as the first +argument to L</cv_name>. You can force perl to pass a GV by including +C<CALL_CHECKER_REQUIRE_GV> in the I<flags>. + The current setting for a particular CV can be retrieved by L</cv_get_call_checker>. +=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj + +The original form of L</cv_set_call_checker_flags>, which passes it the +C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. + =cut */ @@ -10651,6 +10795,14 @@ void Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) { PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER; + cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV); +} + +void +Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun, + SV *ckobj, U32 flags) +{ + PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS; if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) { if (SvMAGICAL((SV*)cv)) mg_free_type((SV*)cv, PERL_MAGIC_checkcall); @@ -10669,7 +10821,8 @@ Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) SvREFCNT_inc_simple_void_NN(ckobj); callmg->mg_flags |= MGf_REFCOUNTED; } - callmg->mg_flags |= MGf_COPY; + callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV) + | (flags & MGf_REQUIRE_GV) | MGf_COPY; } } @@ -10688,7 +10841,7 @@ Perl_ck_subr(pTHX_ OP *o) aop = OP_SIBLING(aop); for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ; cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY); - namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL; + namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL; o->op_private &= ~1; o->op_private |= OPpENTERSUB_HASTARG; @@ -10713,21 +10866,24 @@ Perl_ck_subr(pTHX_ OP *o) } else { Perl_call_checker ckfun; SV *ckobj; - cv_get_call_checker(cv, &ckfun, &ckobj); - if (!namegv) { /* expletive! */ - /* XXX The call checker API is public. And it guarantees that - a GV will be provided with the right name. So we have - to create a GV. But it is still not correct, as its - stringification will include the package. What we - really need is a new call checker API that accepts a - GV or string (or GV or CV). */ - HEK * const hek = CvNAME_HEK(cv); + U8 flags; + S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags); + if (!namegv) { + /* The original call checker API guarantees that a GV will be + be provided with the right name. So, if the old API was + used (or the REQUIRE_GV flag was passed), we have to reify + the CVâs GV, unless this is an anonymous sub. This is not + ideal for lexical subs, as its stringification will include + the package. But it is the best we can do. */ + if (flags & MGf_REQUIRE_GV) { + if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv))) + namegv = CvGV(cv); + } + else namegv = MUTABLE_GV(cv); /* After a syntax error in a lexical sub, the cv that rv2cv_op_cv returns may be a nameless stub. */ - if (!hek) return ck_entersub_args_list(o);; - namegv = (GV *)sv_newmortal(); - gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek), - SVf_UTF8 * !!HEK_UTF8(hek)); + if (!namegv) return ck_entersub_args_list(o); + } return ckfun(aTHX_ o, namegv, ckobj); } @@ -11356,7 +11512,7 @@ Perl_rpeep(pTHX_ OP *o) OP *rv2av, *q; p = o->op_next; if ( p->op_type == OP_GV - && (gv = cGVOPx_gv(p)) + && (gv = cGVOPx_gv(p)) && isGV(gv) && GvNAMELEN_get(gv) == 1 && *GvNAME_get(gv) == '_' && GvSTASH(gv) == PL_defstash diff --git a/op.h b/op.h index 35bd97f..7b86d59 100644 --- a/op.h +++ b/op.h @@ -693,7 +693,10 @@ preprocessing token; the type of I<arg> depends on I<which>. #define RV2CVOPCV_MARK_EARLY 0x00000001 #define RV2CVOPCV_RETURN_NAME_GV 0x00000002 #define RV2CVOPCV_RETURN_STUB 0x00000004 -#define RV2CVOPCV_FLAG_MASK 0x00000007 /* all of the above */ +#ifdef PERL_CORE /* behaviour of this flag is subject to change: */ +# define RV2CVOPCV_MAYBE_NAME_GV 0x00000008 +#endif +#define RV2CVOPCV_FLAG_MASK 0x0000000f /* all of the above */ #define op_lvalue(op,t) Perl_op_lvalue_flags(aTHX_ op,t,0) diff --git a/pad.c b/pad.c index b3f6d2c..0b10575 100644 --- a/pad.c +++ b/pad.c @@ -469,9 +469,10 @@ Perl_cv_undef(pTHX_ CV *cv) CvXSUB(cv) = NULL; } /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the - * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses + * ref status of CvOUTSIDE and CvGV, and ANON and + * LEXICAL, which pp_entersub uses * to choose an error message */ - CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON); + CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL); } /* @@ -1793,9 +1794,7 @@ Perl_pad_tidy(pTHX_ padtidy_type type) if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix])) continue; - if (!SvPADMY(PL_curpad[ix])) { - SvPADTMP_on(PL_curpad[ix]); - } else if (!SvFAKE(namep[ix])) { + if (SvPADMY(PL_curpad[ix]) && !SvFAKE(namep[ix])) { /* This is a work around for how the current implementation of ?{ } blocks in regexps interacts with lexicals. @@ -2086,6 +2085,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv) assert(SvTYPE(ppad[ix]) == SVt_PVCV); subclones = 1; sv = newSV_type(SVt_PVCV); + CvLEXICAL_on(sv); } else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv)) { @@ -2104,6 +2104,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv) * (SvUTF8(namesv) ? -1 : 1), hash) ); + CvLEXICAL_on(sv); } else sv = SvREFCNT_inc(ppad[ix]); else if (sigil == '@') @@ -2226,6 +2227,49 @@ Perl_cv_clone_into(pTHX_ CV *proto, CV *target) } /* +=for apidoc cv_name + +Returns an SV containing the name of the CV, mainly for use in error +reporting. The CV may actually be a GV instead, in which case the returned +SV holds the GV's name. Anything other than a GV or CV is treated as a +string already holding the sub name, but this could change in the future. + +An SV may be passed as a second argument. If so, the name will be assigned +to it and it will be returned. Otherwise the returned SV will be a new +mortal. + +=cut +*/ + +SV * +Perl_cv_name(pTHX_ CV *cv, SV *sv) +{ + PERL_ARGS_ASSERT_CV_NAME; + if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) { + if (sv) sv_setsv(sv,(SV *)cv); + return sv ? (sv) : (SV *)cv; + } + { + SV * const retsv = sv ? (sv) : sv_newmortal(); + if (SvTYPE(cv) == SVt_PVCV) { + if (CvNAMED(cv)) { + if (CvLEXICAL(cv)) sv_sethek(retsv, CvNAME_HEK(cv)); + else { + sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv))); + sv_catpvs(retsv, "::"); + sv_cathek(retsv, CvNAME_HEK(cv)); + } + } + else if (CvLEXICAL(cv)) + sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv)))); + else gv_efullname3(retsv, CvGV(cv), NULL); + } + else gv_efullname3(retsv,(GV *)cv,NULL); + return retsv; + } +} + +/* =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv For any anon CVs in the pad, change CvOUTSIDE of that CV from diff --git a/pp.c b/pp.c index 7cadace..ea05bb4 100644 --- a/pp.c +++ b/pp.c @@ -472,7 +472,9 @@ PP(pp_rv2cv) CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags); if (cv) NOOP; else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) { - cv = MUTABLE_CV(gv); + cv = SvTYPE(SvRV(gv)) == SVt_PVCV + ? MUTABLE_CV(SvRV(gv)) + : MUTABLE_CV(gv); } else cv = MUTABLE_CV(&PL_sv_undef); diff --git a/pp_hot.c b/pp_hot.c index 333bcc8..2624a71 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -2595,15 +2595,15 @@ PP(pp_entersub) SV* sub_name; /* anonymous or undef'd function leaves us no recourse */ - if (CvANON(cv) || !(gv = CvGV(cv))) { - if (CvNAMED(cv)) - DIE(aTHX_ "Undefined subroutine &%"HEKf" called", - HEKfARG(CvNAME_HEK(cv))); + if (CvLEXICAL(cv) && CvHASGV(cv)) + DIE(aTHX_ "Undefined subroutine &%"SVf" called", + SVfARG(cv_name(cv, NULL))); + if (CvANON(cv) || !CvHASGV(cv)) { DIE(aTHX_ "Undefined subroutine called"); } /* autoloaded stub? */ - if (cv != GvCV(gv)) { + if (cv != GvCV(gv = CvGV(cv))) { cv = GvCV(gv); } /* should call AUTOLOAD now? */ @@ -2804,17 +2804,8 @@ Perl_sub_crush_depth(pTHX_ CV *cv) if (CvANON(cv)) Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine"); else { - HEK *const hek = CvNAME_HEK(cv); - SV *tmpstr; - if (hek) { - tmpstr = sv_2mortal(newSVhek(hek)); - } - else { - tmpstr = sv_newmortal(); - gv_efullname3(tmpstr, CvGV(cv), NULL); - } Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"", - SVfARG(tmpstr)); + SVfARG(cv_name(cv,NULL))); } } diff --git a/proto.h b/proto.h index 82496b6..cca048c 100644 --- a/proto.h +++ b/proto.h @@ -811,6 +811,11 @@ PERL_CALLCONV void Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckf #define PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER \ assert(cv); assert(ckfun_p); assert(ckobj_p) +PERL_CALLCONV SV * Perl_cv_name(pTHX_ CV *cv, SV *sv) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_CV_NAME \ + assert(cv) + PERL_CALLCONV void Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) @@ -818,11 +823,23 @@ PERL_CALLCONV void Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfu #define PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER \ assert(cv); assert(ckfun); assert(ckobj) +PERL_CALLCONV void Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj, U32 flags) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2) + __attribute__nonnull__(pTHX_3); +#define PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS \ + assert(cv); assert(ckfun); assert(ckobj) + PERL_CALLCONV void Perl_cv_undef(pTHX_ CV* cv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CV_UNDEF \ assert(cv) +PERL_CALLCONV GV * Perl_cvgv_from_hek(pTHX_ CV* cv) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_CVGV_FROM_HEK \ + assert(cv) + PERL_CALLCONV void Perl_cvgv_set(pTHX_ CV* cv, GV* gv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CVGV_SET \ @@ -6169,11 +6186,6 @@ STATIC void S_forget_pmop(pTHX_ PMOP *const o) assert(o) STATIC OP* S_gen_constant_list(pTHX_ OP* o); -STATIC SV* S_gv_ename(pTHX_ GV *gv) - __attribute__nonnull__(pTHX_1); -#define PERL_ARGS_ASSERT_GV_ENAME \ - assert(gv) - STATIC void S_inplace_aassign(pTHX_ OP* o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_INPLACE_AASSIGN \ @@ -6255,7 +6267,7 @@ STATIC OP* S_pmtrans(pTHX_ OP* o, OP* expr, OP* repl) #define PERL_ARGS_ASSERT_PMTRANS \ assert(o); assert(expr); assert(repl) -STATIC void S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, GV *const gv, CV *const cv) +STATIC bool S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, GV *const gv, CV *const cv) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4); @@ -6292,26 +6304,12 @@ STATIC OP* S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags) #define PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV \ assert(o); assert(name) -STATIC OP* S_too_few_arguments_sv(pTHX_ OP *o, SV* namesv, U32 flags) - __attribute__warn_unused_result__ - __attribute__nonnull__(pTHX_1) - __attribute__nonnull__(pTHX_2); -#define PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV \ - assert(o); assert(namesv) - STATIC OP* S_too_many_arguments_pv(pTHX_ OP *o, const char* name, U32 flags) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV \ assert(o); assert(name) -STATIC OP* S_too_many_arguments_sv(pTHX_ OP *o, SV* namesv, U32 flags) - __attribute__warn_unused_result__ - __attribute__nonnull__(pTHX_1) - __attribute__nonnull__(pTHX_2); -#define PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV \ - assert(o); assert(namesv) - #endif #if defined(PERL_IN_OP_C) || defined(PERL_IN_SV_C) PERL_CALLCONV void Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv, SV * const *new_const_svp) diff --git a/scope.c b/scope.c index 50036d0..8229c1a 100644 --- a/scope.c +++ b/scope.c @@ -1030,18 +1030,14 @@ Perl_leave_scope(pTHX_ I32 base) case SVt_PVCV: { HEK *hek = - CvNAME_HEK((CV *)( CvNAMED(sv) - ? sv - : mg_find(PadlistNAMESARRAY( - CvPADLIST(find_runcv(NULL)) - )[svp-PL_curpad], - PERL_MAGIC_proto - )->mg_obj)); + ? CvNAME_HEK((CV *)sv) + : GvNAME_HEK(CvGV(sv)); assert(hek); share_hek_hek(hek); cv_undef((CV *)sv); CvNAME_HEK_set(sv, hek); + CvLEXICAL_on(sv); break; } default: @@ -1063,19 +1059,17 @@ Perl_leave_scope(pTHX_ I32 base) case SVt_PVHV: *svp = MUTABLE_SV(newHV()); break; case SVt_PVCV: { + HEK * const hek = CvNAMED(sv) + ? CvNAME_HEK((CV *)sv) + : GvNAME_HEK(CvGV(sv)); + /* Create a stub */ *svp = newSV_type(SVt_PVCV); /* Share name */ CvNAME_HEK_set(*svp, - share_hek_hek(CvNAME_HEK((CV *)( - CvNAMED(sv) - ? sv - : mg_find(PadlistNAMESARRAY( - CvPADLIST(find_runcv(NULL)) - )[svp-PL_curpad], - PERL_MAGIC_proto - )->mg_obj)))); + share_hek_hek(hek)); + CvLEXICAL_on(*svp); break; } default: *svp = newSV(0); break; diff --git a/sv.h b/sv.h index 753b5bb..17a9532 100644 --- a/sv.h +++ b/sv.h @@ -408,7 +408,8 @@ perform the upgrade if necessary. See C<svtype>. /* note that SVf_AMAGIC is now only set on stashes, so this bit is free * for non-HV SVs */ -/* Ensure this value does not clash with the GV_ADD* flags in gv.h: */ +/* Ensure this value does not clash with the GV_ADD* flags in gv.h, or the + CV_CKPROTO_* flags in op.c, or the padadd_* flags in pad.h: */ #define SVf_UTF8 0x20000000 /* SvPV is UTF-8 encoded This is also set on RVs whose overloaded stringification is UTF-8. This might @@ -1970,6 +1971,12 @@ mg.c:1024: warning: left-hand operand of comma expression has no effect (littlelen), SV_GMAGIC) #define sv_mortalcopy(sv) \ Perl_sv_mortalcopy_flags(aTHX_ sv, SV_GMAGIC|SV_DO_COW_SVSETSV) +#define sv_cathek(sv,hek) \ + STMT_START { \ + HEK * const bmxk = hek; \ + sv_catpvn_flags(sv, HEK_KEY(bmxk), HEK_LEN(bmxk), \ + HEK_UTF8(bmxk) ? SV_CATUTF8 : SV_CATBYTES); \ + } STMT_END /* Should be named SvCatPVN_utf8_upgrade? */ #define sv_catpvn_nomg_utf8_upgrade(dsv, sstr, slen, nsv) \ diff --git a/t/op/caller.t b/t/op/caller.t index c43f576..e0534ba 100644 --- a/t/op/caller.t +++ b/t/op/caller.t @@ -31,7 +31,7 @@ ok( $c[4], "hasargs true with anon sub" ); sub foo { @c = caller(0) } my $fooref = delete $::{foo}; $fooref -> (); -is( $c[3], "main::__ANON__", "deleted subroutine name" ); +is( $c[3], "main::foo", "deleted subroutine name" ); ok( $c[4], "hasargs true with deleted sub" ); BEGIN { @@ -66,7 +66,7 @@ ok( $c[4], "hasargs true with anon sub" ); sub foo2 { f() } my $fooref2 = delete $::{foo2}; $fooref2 -> (); -is( $c[3], "main::__ANON__", "deleted subroutine name" ); +is( $c[3], "main::foo2", "deleted subroutine name" ); ok( $c[4], "hasargs true with deleted sub" ); # See if caller() returns the correct warning mask diff --git a/t/op/gv.t b/t/op/gv.t index 279a9af..4c8c79d 100644 --- a/t/op/gv.t +++ b/t/op/gv.t @@ -490,6 +490,9 @@ is join("-", eval "&yarrow(1..10)"), '4-5-6', 'const list ignores & args'; is prototype "yarrow", "", 'const list has "" prototype'; is eval "yarrow", 3, 'const list in scalar cx returns length'; +$::{borage} = \&ok; +eval 'borage("sub ref in stash")' or fail "sub ref in stash"; + { use vars qw($glook $smek $foof); # Check reference assignment isn't affected by the SV type (bug #38439) @@ -512,7 +515,7 @@ is eval "yarrow", 3, 'const list in scalar cx returns length'; format = . -foreach my $value ({1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) { +foreach my $value ({1=>2}, *STDOUT{IO}, *STDOUT{FORMAT}) { # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns # IO::Handle, which isn't what we want. my $type = $value; diff --git a/t/op/symbolcache.t b/t/op/symbolcache.t index b3e567b..2596ae6 100644 --- a/t/op/symbolcache.t +++ b/t/op/symbolcache.t @@ -28,7 +28,7 @@ sub replaced { 'meth' } # simple removal sub removed2 { 24 } sub bound2 { removed2() } -undef $main::{removed2}; +{ no strict; undef *{"removed2"} } eval { bound2() }; like( $@, qr/Undefined subroutine &main::removed2 called/, 'function not bound' ); diff --git a/t/uni/gv.t b/t/uni/gv.t index 9143034..9c48cef 100644 --- a/t/uni/gv.t +++ b/t/uni/gv.t @@ -15,7 +15,7 @@ use utf8; use open qw( :utf8 :std ); use warnings; -plan( tests => 207 ); +plan( tests => 206 ); # type coersion on assignment $á = 'á'; @@ -492,7 +492,7 @@ no warnings 'once'; format = . - foreach my $value ({1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) { + foreach my $value ({1=>2}, *STDOUT{IO}, *STDOUT{FORMAT}) { # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns # IO::Handle, which isn't what we want. my $type = $value; diff --git a/t/uni/parser.t b/t/uni/parser.t index 2437e3d..83ffd8e 100644 --- a/t/uni/parser.t +++ b/t/uni/parser.t @@ -8,7 +8,7 @@ BEGIN { skip_all_without_unicode_tables(); } -plan (tests => 52); +plan (tests => 51); use utf8; use open qw( :utf8 :std ); @@ -82,8 +82,7 @@ closedir FÃÃ; sub ÑÑаÑÑники { 1 } ok $::{"ÑÑаÑÑники"}, "non-const sub declarations generate the right glob"; -ok *{$::{"ÑÑаÑÑники"}}{CODE}; -is *{$::{"ÑÑаÑÑники"}}{CODE}->(), 1; +is $::{"ÑÑаÑÑники"}->(), 1; sub å () { 1 } diff --git a/toke.c b/toke.c index edd458d..8a8d187 100644 --- a/toke.c +++ b/toke.c @@ -6552,7 +6552,11 @@ Perl_yylex(pTHX) rv2cv_op = newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op); cv = lex - ? isGV(gv) ? GvCV(gv) : (CV *)gv + ? isGV(gv) + ? GvCV(gv) + : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV + ? (CV *)SvRV(gv) + : (CV *)gv : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB); } @@ -6681,7 +6685,6 @@ Perl_yylex(pTHX) /* Not a method, so call it a subroutine (if defined) */ if (cv) { - OP *gvop; /* Check for a constant sub */ if ((sv = cv_const_sv_or_av(cv))) { its_constant: @@ -6699,20 +6702,6 @@ Perl_yylex(pTHX) TOKEN(WORD); } - /* Resolve to GV now if this is a placeholder. */ - if (!off && (gvop = cUNOPx(rv2cv_op)->op_first) - && gvop->op_type == OP_GV) { - GV *gv2 = cGVOPx_gv(gvop); - if (gv2 && !isGV(gv2)) { - gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV); - assert (SvTYPE(gv) == SVt_PVGV); - /* cv must have been some sort of placeholder, - so now needs replacing with a real code - reference. */ - cv = GvCV(gv); - } - } - op_free(pl_yylval.opval); pl_yylval.opval = off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op; diff --git a/universal.c b/universal.c index c219411..825dff5 100644 --- a/universal.c +++ b/universal.c @@ -302,11 +302,12 @@ C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as: void Perl_croak_xs_usage(const CV *const cv, const char *const params) { - const GV *const gv = CvGV(cv); + /* Avoid CvGV as it requires aTHX. */ + const GV *gv = CvNAMED(cv) ? NULL : cv->sv_any->xcv_gv_u.xcv_gv; PERL_ARGS_ASSERT_CROAK_XS_USAGE; - if (gv) { + if (gv) got_gv: { const HV *const stash = GvSTASH(gv); if (HvNAME_get(stash)) @@ -320,6 +321,9 @@ Perl_croak_xs_usage(const CV *const cv, const char *const params) Perl_croak_nocontext("Usage: %"HEKf"(%s)", HEKfARG(GvNAME_HEK(gv)), params); } else { + dTHX; + if ((gv = CvGV(cv))) goto got_gv; + /* Pants. I don't think that it should be possible to get here. */ /* diag_listed_as: SKIPME */ Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); diff --git a/util.c b/util.c index d6501bd..f307138 100644 --- a/util.c +++ b/util.c @@ -5372,10 +5372,7 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) else { sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv))); sv_catpvs(dbsv, "::"); - sv_catpvn_flags( - dbsv, GvNAME(gv), GvNAMELEN(gv), - GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES - ); + sv_cathek(dbsv, GvNAME_HEK(gv)); } } else { -- Perl5 Master Repository
