This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[Merge] CVs without GVs
authorFather Chrysostomos <sprout@cpan.org>
Mon, 15 Sep 2014 13:20:16 +0000 (06:20 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Mon, 15 Sep 2014 13:20:16 +0000 (06:20 -0700)
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

33 files changed:
MANIFEST
cv.h
dist/Attribute-Handlers/lib/Attribute/Handlers.pm
dump.c
embed.fnc
embed.h
ext/B/B.pm
ext/B/t/b.t
ext/B/t/concise-xs.t
ext/Devel-Peek/t/Peek.t
ext/XS-APItest/APItest.pm
ext/XS-APItest/APItest.xs
ext/XS-APItest/t/cv_name.t [new file with mode: 0644]
gv.c
inline.h
lib/B/Deparse.pm
mg.h
op.c
op.h
pad.c
pp.c
pp_hot.c
proto.h
scope.c
sv.h
t/op/caller.t
t/op/gv.t
t/op/symbolcache.t
t/uni/gv.t
t/uni/parser.t
toke.c
universal.c
util.c

index eb29a94..34573fd 100644 (file)
--- 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 (file)
--- 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
index 4ae65d9..17c4bb7 100644 (file)
@@ -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 (file)
--- 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,"}
 };
 
index 88adce2..09312e9 100644 (file)
--- 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 (file)
--- a/embed.h
+++ b/embed.h
 #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)
 #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)
 #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)
index c908f51..edeab59 100644 (file)
@@ -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
index 27b4105..9933978 100644 (file)
@@ -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
index 2f1737a..c2258f7 100644 (file)
@@ -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
index ce777da..492b8ed 100644 (file)
@@ -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\\)
index 7fed553..2950eaf 100644 (file)
@@ -5,7 +5,7 @@ use strict;
 use warnings;
 use Carp;
 
-our $VERSION = '0.63';
+our $VERSION = '0.64';
 
 require XSLoader;
 
index 54ee2da..777e342 100644 (file)
@@ -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 (file)
index 0000000..cc6202a
--- /dev/null
@@ -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 (file)
--- 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.  */
index 0792694..ad6edf2 100644 (file)
--- 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)
 {
index c15b333..0e7fa57 100644 (file)
@@ -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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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);
index 333bcc8..2624a71 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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)      \
index c43f576..e0534ba 100644 (file)
@@ -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
index 279a9af..4c8c79d 100644 (file)
--- 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;
index b3e567b..2596ae6 100644 (file)
@@ -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' );
index 9143034..9c48cef 100644 (file)
@@ -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;
index 2437e3d..83ffd8e 100644 (file)
@@ -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 (file)
--- 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;
index c219411..825dff5 100644 (file)
@@ -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 (file)
--- 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 {