PATCH: [perl #131598]
[perl.git] / gv.c
1 /*    gv.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  *   'Mercy!' cried Gandalf.  'If the giving of information is to be the cure
13  * of your inquisitiveness, I shall spend all the rest of my days in answering
14  * you.  What more do you want to know?'
15  *   'The names of all the stars, and of all living things, and the whole
16  * history of Middle-earth and Over-heaven and of the Sundering Seas,'
17  * laughed Pippin.
18  *
19  *     [p.599 of _The Lord of the Rings_, III/xi: "The Palantír"]
20  */
21
22 /*
23 =head1 GV Functions
24 A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
25 It is a structure that holds a pointer to a scalar, an array, a hash etc,
26 corresponding to $foo, @foo, %foo.
27
28 GVs are usually found as values in stashes (symbol table hashes) where
29 Perl stores its global variables.
30
31 =cut
32 */
33
34 #include "EXTERN.h"
35 #define PERL_IN_GV_C
36 #include "perl.h"
37 #include "overload.inc"
38 #include "keywords.h"
39 #include "feature.h"
40
41 static const char S_autoload[] = "AUTOLOAD";
42 #define S_autolen (sizeof("AUTOLOAD")-1)
43
44 GV *
45 Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
46 {
47     SV **where;
48
49     if (
50         !gv
51      || (
52             SvTYPE((const SV *)gv) != SVt_PVGV
53          && SvTYPE((const SV *)gv) != SVt_PVLV
54         )
55     ) {
56         const char *what;
57         if (type == SVt_PVIO) {
58             /*
59              * if it walks like a dirhandle, then let's assume that
60              * this is a dirhandle.
61              */
62             what = OP_IS_DIRHOP(PL_op->op_type) ?
63                 "dirhandle" : "filehandle";
64         } else if (type == SVt_PVHV) {
65             what = "hash";
66         } else {
67             what = type == SVt_PVAV ? "array" : "scalar";
68         }
69         /* diag_listed_as: Bad symbol for filehandle */
70         Perl_croak(aTHX_ "Bad symbol for %s", what);
71     }
72
73     if (type == SVt_PVHV) {
74         where = (SV **)&GvHV(gv);
75     } else if (type == SVt_PVAV) {
76         where = (SV **)&GvAV(gv);
77     } else if (type == SVt_PVIO) {
78         where = (SV **)&GvIOp(gv);
79     } else {
80         where = &GvSV(gv);
81     }
82
83     if (!*where)
84     {
85         *where = newSV_type(type);
86             if (type == SVt_PVAV && GvNAMELEN(gv) == 3
87              && strEQs(GvNAME(gv), "ISA"))
88             sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
89     }
90     return gv;
91 }
92
93 GV *
94 Perl_gv_fetchfile(pTHX_ const char *name)
95 {
96     PERL_ARGS_ASSERT_GV_FETCHFILE;
97     return gv_fetchfile_flags(name, strlen(name), 0);
98 }
99
100 GV *
101 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
102                         const U32 flags)
103 {
104     char smallbuf[128];
105     char *tmpbuf;
106     const STRLEN tmplen = namelen + 2;
107     GV *gv;
108
109     PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS;
110     PERL_UNUSED_ARG(flags);
111
112     if (!PL_defstash)
113         return NULL;
114
115     if (tmplen <= sizeof smallbuf)
116         tmpbuf = smallbuf;
117     else
118         Newx(tmpbuf, tmplen, char);
119     /* This is where the debugger's %{"::_<$filename"} hash is created */
120     tmpbuf[0] = '_';
121     tmpbuf[1] = '<';
122     memcpy(tmpbuf + 2, name, namelen);
123     gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
124     if (!isGV(gv)) {
125         gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
126 #ifdef PERL_DONT_CREATE_GVSV
127         GvSV(gv) = newSVpvn(name, namelen);
128 #else
129         sv_setpvn(GvSV(gv), name, namelen);
130 #endif
131     }
132     if (PERLDB_LINE_OR_SAVESRC && !GvAV(gv))
133             hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile);
134     if (tmpbuf != smallbuf)
135         Safefree(tmpbuf);
136     return gv;
137 }
138
139 /*
140 =for apidoc gv_const_sv
141
142 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
143 inlining, or C<gv> is a placeholder reference that would be promoted to such
144 a typeglob, then returns the value returned by the sub.  Otherwise, returns
145 C<NULL>.
146
147 =cut
148 */
149
150 SV *
151 Perl_gv_const_sv(pTHX_ GV *gv)
152 {
153     PERL_ARGS_ASSERT_GV_CONST_SV;
154     PERL_UNUSED_CONTEXT;
155
156     if (SvTYPE(gv) == SVt_PVGV)
157         return cv_const_sv(GvCVu(gv));
158     return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV && SvTYPE(SvRV(gv)) != SVt_PVCV ? SvRV(gv) : NULL;
159 }
160
161 GP *
162 Perl_newGP(pTHX_ GV *const gv)
163 {
164     GP *gp;
165     U32 hash;
166     const char *file;
167     STRLEN len;
168 #ifndef USE_ITHREADS
169     GV *filegv;
170 #endif
171     dVAR;
172
173     PERL_ARGS_ASSERT_NEWGP;
174     Newxz(gp, 1, GP);
175     gp->gp_egv = gv; /* allow compiler to reuse gv after this */
176 #ifndef PERL_DONT_CREATE_GVSV
177     gp->gp_sv = newSV(0);
178 #endif
179
180     /* PL_curcop may be null here.  E.g.,
181         INIT { bless {} and exit }
182        frees INIT before looking up DESTROY (and creating *DESTROY)
183     */
184     if (PL_curcop) {
185         gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
186 #ifdef USE_ITHREADS
187         if (CopFILE(PL_curcop)) {
188             file = CopFILE(PL_curcop);
189             len = strlen(file);
190         }
191 #else
192         filegv = CopFILEGV(PL_curcop);
193         if (filegv) {
194             file = GvNAME(filegv)+2;
195             len = GvNAMELEN(filegv)-2;
196         }
197 #endif
198         else goto no_file;
199     }
200     else {
201         no_file:
202         file = "";
203         len = 0;
204     }
205
206     PERL_HASH(hash, file, len);
207     gp->gp_file_hek = share_hek(file, len, hash);
208     gp->gp_refcnt = 1;
209
210     return gp;
211 }
212
213 /* Assign CvGV(cv) = gv, handling weak references.
214  * See also S_anonymise_cv_maybe */
215
216 void
217 Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
218 {
219     GV * const oldgv = CvNAMED(cv) ? NULL : SvANY(cv)->xcv_gv_u.xcv_gv;
220     HEK *hek;
221     PERL_ARGS_ASSERT_CVGV_SET;
222
223     if (oldgv == gv)
224         return;
225
226     if (oldgv) {
227         if (CvCVGV_RC(cv)) {
228             SvREFCNT_dec_NN(oldgv);
229             CvCVGV_RC_off(cv);
230         }
231         else {
232             sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
233         }
234     }
235     else if ((hek = CvNAME_HEK(cv))) {
236         unshare_hek(hek);
237         CvLEXICAL_off(cv);
238     }
239
240     CvNAMED_off(cv);
241     SvANY(cv)->xcv_gv_u.xcv_gv = gv;
242     assert(!CvCVGV_RC(cv));
243
244     if (!gv)
245         return;
246
247     if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
248         Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
249     else {
250         CvCVGV_RC_on(cv);
251         SvREFCNT_inc_simple_void_NN(gv);
252     }
253 }
254
255 /* Convert CvSTASH + CvNAME_HEK into a GV.  Conceptually, all subs have a
256    GV, but for efficiency that GV may not in fact exist.  This function,
257    called by CvGV, reifies it. */
258
259 GV *
260 Perl_cvgv_from_hek(pTHX_ CV *cv)
261 {
262     GV *gv;
263     SV **svp;
264     PERL_ARGS_ASSERT_CVGV_FROM_HEK;
265     assert(SvTYPE(cv) == SVt_PVCV);
266     if (!CvSTASH(cv)) return NULL;
267     ASSUME(CvNAME_HEK(cv));
268     svp = hv_fetchhek(CvSTASH(cv), CvNAME_HEK(cv), 0);
269     gv = MUTABLE_GV(svp && *svp ? *svp : newSV(0));
270     if (!isGV(gv))
271         gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)),
272                 HEK_LEN(CvNAME_HEK(cv)),
273                 SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv)));
274     if (!CvNAMED(cv)) { /* gv_init took care of it */
275         assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv);
276         return gv;
277     }
278     unshare_hek(CvNAME_HEK(cv));
279     CvNAMED_off(cv);
280     SvANY(cv)->xcv_gv_u.xcv_gv = gv;
281     if (svp && *svp) SvREFCNT_inc_simple_void_NN(gv);
282     CvCVGV_RC_on(cv);
283     return gv;
284 }
285
286 /* Assign CvSTASH(cv) = st, handling weak references. */
287
288 void
289 Perl_cvstash_set(pTHX_ CV *cv, HV *st)
290 {
291     HV *oldst = CvSTASH(cv);
292     PERL_ARGS_ASSERT_CVSTASH_SET;
293     if (oldst == st)
294         return;
295     if (oldst)
296         sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
297     SvANY(cv)->xcv_stash = st;
298     if (st)
299         Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
300 }
301
302 /*
303 =for apidoc gv_init_pvn
304
305 Converts a scalar into a typeglob.  This is an incoercible typeglob;
306 assigning a reference to it will assign to one of its slots, instead of
307 overwriting it as happens with typeglobs created by C<SvSetSV>.  Converting
308 any scalar that is C<SvOK()> may produce unpredictable results and is reserved
309 for perl's internal use.
310
311 C<gv> is the scalar to be converted.
312
313 C<stash> is the parent stash/package, if any.
314
315 C<name> and C<len> give the name.  The name must be unqualified;
316 that is, it must not include the package name.  If C<gv> is a
317 stash element, it is the caller's responsibility to ensure that the name
318 passed to this function matches the name of the element.  If it does not
319 match, perl's internal bookkeeping will get out of sync.
320
321 C<flags> can be set to C<SVf_UTF8> if C<name> is a UTF-8 string, or
322 the return value of SvUTF8(sv).  It can also take the
323 C<GV_ADDMULTI> flag, which means to pretend that the GV has been
324 seen before (i.e., suppress "Used once" warnings).
325
326 =for apidoc gv_init
327
328 The old form of C<gv_init_pvn()>.  It does not work with UTF-8 strings, as it
329 has no flags parameter.  If the C<multi> parameter is set, the
330 C<GV_ADDMULTI> flag will be passed to C<gv_init_pvn()>.
331
332 =for apidoc gv_init_pv
333
334 Same as C<gv_init_pvn()>, but takes a nul-terminated string for the name
335 instead of separate char * and length parameters.
336
337 =for apidoc gv_init_sv
338
339 Same as C<gv_init_pvn()>, but takes an SV * for the name instead of separate
340 char * and length parameters.  C<flags> is currently unused.
341
342 =cut
343 */
344
345 void
346 Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
347 {
348    char *namepv;
349    STRLEN namelen;
350    PERL_ARGS_ASSERT_GV_INIT_SV;
351    namepv = SvPV(namesv, namelen);
352    if (SvUTF8(namesv))
353        flags |= SVf_UTF8;
354    gv_init_pvn(gv, stash, namepv, namelen, flags);
355 }
356
357 void
358 Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
359 {
360    PERL_ARGS_ASSERT_GV_INIT_PV;
361    gv_init_pvn(gv, stash, name, strlen(name), flags);
362 }
363
364 void
365 Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
366 {
367     const U32 old_type = SvTYPE(gv);
368     const bool doproto = old_type > SVt_NULL;
369     char * const proto = (doproto && SvPOK(gv))
370         ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
371         : NULL;
372     const STRLEN protolen = proto ? SvCUR(gv) : 0;
373     const U32 proto_utf8  = proto ? SvUTF8(gv) : 0;
374     SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
375     const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
376
377     PERL_ARGS_ASSERT_GV_INIT_PVN;
378     assert (!(proto && has_constant));
379
380     if (has_constant) {
381         /* The constant has to be a scalar, array or subroutine.  */
382         switch (SvTYPE(has_constant)) {
383         case SVt_PVHV:
384         case SVt_PVFM:
385         case SVt_PVIO:
386             Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
387                        sv_reftype(has_constant, 0));
388             NOT_REACHED; /* NOTREACHED */
389             break;
390
391         default: NOOP;
392         }
393         SvRV_set(gv, NULL);
394         SvROK_off(gv);
395     }
396
397
398     if (old_type < SVt_PVGV) {
399         if (old_type >= SVt_PV)
400             SvCUR_set(gv, 0);
401         sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
402     }
403     if (SvLEN(gv)) {
404         if (proto) {
405             SvPV_set(gv, NULL);
406             SvLEN_set(gv, 0);
407             SvPOK_off(gv);
408         } else
409             Safefree(SvPVX_mutable(gv));
410     }
411     SvIOK_off(gv);
412     isGV_with_GP_on(gv);
413
414     GvGP_set(gv, Perl_newGP(aTHX_ gv));
415     GvSTASH(gv) = stash;
416     if (stash)
417         Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
418     gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
419     if (flags & GV_ADDMULTI || doproto) /* doproto means it */
420         GvMULTI_on(gv);                 /* _was_ mentioned */
421     if (has_constant && SvTYPE(has_constant) == SVt_PVCV) {
422         /* Not actually a constant.  Just a regular sub.  */
423         CV * const cv = (CV *)has_constant;
424         GvCV_set(gv,cv);
425         if (CvNAMED(cv) && CvSTASH(cv) == stash && (
426                CvNAME_HEK(cv) == GvNAME_HEK(gv)
427             || (  HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv))
428                && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv))
429                && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv))
430                && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv))
431                )
432            ))
433             CvGV_set(cv,gv);
434     }
435     else if (doproto) {
436         CV *cv;
437         if (has_constant) {
438             /* newCONSTSUB takes ownership of the reference from us.  */
439             cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
440             /* In case op.c:S_process_special_blocks stole it: */
441             if (!GvCV(gv))
442                 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
443             assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
444             /* If this reference was a copy of another, then the subroutine
445                must have been "imported", by a Perl space assignment to a GV
446                from a reference to CV.  */
447             if (exported_constant)
448                 GvIMPORTED_CV_on(gv);
449             CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */
450         } else {
451             cv = newSTUB(gv,1);
452         }
453         if (proto) {
454             sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
455                             SV_HAS_TRAILING_NUL);
456             if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
457         }
458     }
459 }
460
461 STATIC void
462 S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
463 {
464     PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
465
466     switch (sv_type) {
467     case SVt_PVIO:
468         (void)GvIOn(gv);
469         break;
470     case SVt_PVAV:
471         (void)GvAVn(gv);
472         break;
473     case SVt_PVHV:
474         (void)GvHVn(gv);
475         break;
476 #ifdef PERL_DONT_CREATE_GVSV
477     case SVt_NULL:
478     case SVt_PVCV:
479     case SVt_PVFM:
480     case SVt_PVGV:
481         break;
482     default:
483         if(GvSVn(gv)) {
484             /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
485                If we just cast GvSVn(gv) to void, it ignores evaluating it for
486                its side effect */
487         }
488 #endif
489     }
490 }
491
492 static void core_xsub(pTHX_ CV* cv);
493
494 static GV *
495 S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
496                           const char * const name, const STRLEN len)
497 {
498     const int code = keyword(name, len, 1);
499     static const char file[] = __FILE__;
500     CV *cv, *oldcompcv = NULL;
501     int opnum = 0;
502     bool ampable = TRUE; /* &{}-able */
503     COP *oldcurcop = NULL;
504     yy_parser *oldparser = NULL;
505     I32 oldsavestack_ix = 0;
506
507     assert(gv || stash);
508     assert(name);
509
510     if (!code) return NULL; /* Not a keyword */
511     switch (code < 0 ? -code : code) {
512      /* no support for \&CORE::infix;
513         no support for funcs that do not parse like funcs */
514     case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD:
515     case KEY_BEGIN   : case KEY_CHECK  : case KEY_cmp:
516     case KEY_default : case KEY_DESTROY:
517     case KEY_do      : case KEY_dump   : case KEY_else  : case KEY_elsif  :
518     case KEY_END     : case KEY_eq     : case KEY_eval  :
519     case KEY_for     : case KEY_foreach: case KEY_format: case KEY_ge     :
520     case KEY_given   : case KEY_goto   : case KEY_grep  :
521     case KEY_gt   : case KEY_if: case KEY_INIT: case KEY_last: case KEY_le:
522     case KEY_local: case KEY_lt: case KEY_m   : case KEY_map : case KEY_my:
523     case KEY_ne   : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
524     case KEY_package: case KEY_print: case KEY_printf:
525     case KEY_q    : case KEY_qq   : case KEY_qr     : case KEY_qw    :
526     case KEY_qx   : case KEY_redo : case KEY_require: case KEY_return:
527     case KEY_s    : case KEY_say  : case KEY_sort   :
528     case KEY_state: case KEY_sub  :
529     case KEY_tr   : case KEY_UNITCHECK: case KEY_unless:
530     case KEY_until: case KEY_use  : case KEY_when     : case KEY_while :
531     case KEY_x    : case KEY_xor  : case KEY_y        :
532         return NULL;
533     case KEY_chdir:
534     case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
535     case KEY_eof  : case KEY_exec: case KEY_exists :
536     case KEY_lstat:
537     case KEY_split:
538     case KEY_stat:
539     case KEY_system:
540     case KEY_truncate: case KEY_unlink:
541         ampable = FALSE;
542     }
543     if (!gv) {
544         gv = (GV *)newSV(0);
545         gv_init(gv, stash, name, len, TRUE);
546     }
547     GvMULTI_on(gv);
548     if (ampable) {
549         ENTER;
550         oldcurcop = PL_curcop;
551         oldparser = PL_parser;
552         lex_start(NULL, NULL, 0);
553         oldcompcv = PL_compcv;
554         PL_compcv = NULL; /* Prevent start_subparse from setting
555                              CvOUTSIDE. */
556         oldsavestack_ix = start_subparse(FALSE,0);
557         cv = PL_compcv;
558     }
559     else {
560         /* Avoid calling newXS, as it calls us, and things start to
561            get hairy. */
562         cv = MUTABLE_CV(newSV_type(SVt_PVCV));
563         GvCV_set(gv,cv);
564         GvCVGEN(gv) = 0;
565         CvISXSUB_on(cv);
566         CvXSUB(cv) = core_xsub;
567         PoisonPADLIST(cv);
568     }
569     CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
570                          from PL_curcop. */
571     /* XSUBs can't be perl lang/perl5db.pl debugged
572     if (PERLDB_LINE_OR_SAVESRC)
573         (void)gv_fetchfile(file); */
574     CvFILE(cv) = (char *)file;
575     /* XXX This is inefficient, as doing things this order causes
576            a prototype check in newATTRSUB.  But we have to do
577            it this order as we need an op number before calling
578            new ATTRSUB. */
579     (void)core_prototype((SV *)cv, name, code, &opnum);
580     if (stash)
581         (void)hv_store(stash,name,len,(SV *)gv,0);
582     if (ampable) {
583 #ifdef DEBUGGING
584         CV *orig_cv = cv;
585 #endif
586         CvLVALUE_on(cv);
587         /* newATTRSUB will free the CV and return NULL if we're still
588            compiling after a syntax error */
589         if ((cv = newATTRSUB_x(
590                    oldsavestack_ix, (OP *)gv,
591                    NULL,NULL,
592                    coresub_op(
593                      opnum
594                        ? newSVuv((UV)opnum)
595                        : newSVpvn(name,len),
596                      code, opnum
597                    ),
598                    TRUE
599                )) != NULL) {
600             assert(GvCV(gv) == orig_cv);
601             if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
602                 && opnum != OP_UNDEF && opnum != OP_KEYS)
603                 CvLVALUE_off(cv); /* Now *that* was a neat trick. */
604         }
605         LEAVE;
606         PL_parser = oldparser;
607         PL_curcop = oldcurcop;
608         PL_compcv = oldcompcv;
609     }
610     if (cv) {
611         SV *opnumsv = newSViv(
612             (opnum == OP_ENTEREVAL && len == 9 && memEQ(name, "evalbytes", 9)) ?
613                 (OP_ENTEREVAL | (1<<16))
614             : opnum ? opnum : (((I32)name[2]) << 16));
615         cv_set_call_checker_flags(cv, Perl_ck_entersub_args_core, opnumsv, 0);
616         SvREFCNT_dec_NN(opnumsv);
617     }
618
619     return gv;
620 }
621
622 /*
623 =for apidoc gv_fetchmeth
624
625 Like L</gv_fetchmeth_pvn>, but lacks a flags parameter.
626
627 =for apidoc gv_fetchmeth_sv
628
629 Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form
630 of an SV instead of a string/length pair.
631
632 =cut
633 */
634
635 GV *
636 Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
637 {
638     char *namepv;
639     STRLEN namelen;
640     PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
641     if (LIKELY(SvPOK_nog(namesv))) /* common case */
642         return gv_fetchmeth_internal(stash, namesv, NULL, 0, level, flags);
643     namepv = SvPV(namesv, namelen);
644     if (SvUTF8(namesv)) flags |= SVf_UTF8;
645     return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
646 }
647
648 /*
649 =for apidoc gv_fetchmeth_pv
650
651 Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string 
652 instead of a string/length pair.
653
654 =cut
655 */
656
657 GV *
658 Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
659 {
660     PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
661     return gv_fetchmeth_internal(stash, NULL, name, strlen(name), level, flags);
662 }
663
664 /*
665 =for apidoc gv_fetchmeth_pvn
666
667 Returns the glob with the given C<name> and a defined subroutine or
668 C<NULL>.  The glob lives in the given C<stash>, or in the stashes
669 accessible via C<@ISA> and C<UNIVERSAL::>.
670
671 The argument C<level> should be either 0 or -1.  If C<level==0>, as a
672 side-effect creates a glob with the given C<name> in the given C<stash>
673 which in the case of success contains an alias for the subroutine, and sets
674 up caching info for this glob.
675
676 The only significant values for C<flags> are C<GV_SUPER> and C<SVf_UTF8>.
677
678 C<GV_SUPER> indicates that we want to look up the method in the superclasses
679 of the C<stash>.
680
681 The
682 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
683 visible to Perl code.  So when calling C<call_sv>, you should not use
684 the GV directly; instead, you should use the method's CV, which can be
685 obtained from the GV with the C<GvCV> macro.
686
687 =cut
688 */
689
690 /* NOTE: No support for tied ISA */
691
692 PERL_STATIC_INLINE GV*
693 S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, I32 level, U32 flags)
694 {
695     GV** gvp;
696     HE* he;
697     AV* linear_av;
698     SV** linear_svp;
699     SV* linear_sv;
700     HV* cstash, *cachestash;
701     GV* candidate = NULL;
702     CV* cand_cv = NULL;
703     GV* topgv = NULL;
704     const char *hvname;
705     I32 create = (level >= 0) ? HV_FETCH_LVALUE : 0;
706     I32 items;
707     U32 topgen_cmp;
708     U32 is_utf8 = flags & SVf_UTF8;
709
710     /* UNIVERSAL methods should be callable without a stash */
711     if (!stash) {
712         create = 0;  /* probably appropriate */
713         if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
714             return 0;
715     }
716
717     assert(stash);
718
719     hvname = HvNAME_get(stash);
720     if (!hvname)
721       Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
722
723     assert(hvname);
724     assert(name || meth);
725
726     DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n",
727                       flags & GV_SUPER ? "SUPER " : "",
728                       name ? name : SvPV_nolen(meth), hvname) );
729
730     topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
731
732     if (flags & GV_SUPER) {
733         if (!HvAUX(stash)->xhv_mro_meta->super)
734             HvAUX(stash)->xhv_mro_meta->super = newHV();
735         cachestash = HvAUX(stash)->xhv_mro_meta->super;
736     }
737     else cachestash = stash;
738
739     /* check locally for a real method or a cache entry */
740     he = (HE*)hv_common(
741         cachestash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, create, NULL, 0
742     );
743     if (he) gvp = (GV**)&HeVAL(he);
744     else gvp = NULL;
745
746     if(gvp) {
747         topgv = *gvp;
748       have_gv:
749         assert(topgv);
750         if (SvTYPE(topgv) != SVt_PVGV)
751         {
752             if (!name)
753                 name = SvPV_nomg(meth, len);
754             gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
755         }
756         if ((cand_cv = GvCV(topgv))) {
757             /* If genuine method or valid cache entry, use it */
758             if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
759                 return topgv;
760             }
761             else {
762                 /* stale cache entry, junk it and move on */
763                 SvREFCNT_dec_NN(cand_cv);
764                 GvCV_set(topgv, NULL);
765                 cand_cv = NULL;
766                 GvCVGEN(topgv) = 0;
767             }
768         }
769         else if (GvCVGEN(topgv) == topgen_cmp) {
770             /* cache indicates no such method definitively */
771             return 0;
772         }
773         else if (stash == cachestash
774               && len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
775               && strEQs(hvname, "CORE")
776               && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
777             goto have_gv;
778     }
779
780     linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
781     linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
782     items = AvFILLp(linear_av); /* no +1, to skip over self */
783     while (items--) {
784         linear_sv = *linear_svp++;
785         assert(linear_sv);
786         cstash = gv_stashsv(linear_sv, 0);
787
788         if (!cstash) {
789             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
790                            "Can't locate package %" SVf " for @%" HEKf "::ISA",
791                            SVfARG(linear_sv),
792                            HEKfARG(HvNAME_HEK(stash)));
793             continue;
794         }
795
796         assert(cstash);
797
798         gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0);
799         if (!gvp) {
800             if (len > 1 && HvNAMELEN_get(cstash) == 4) {
801                 const char *hvname = HvNAME(cstash); assert(hvname);
802                 if (strEQs(hvname, "CORE")
803                  && (candidate =
804                       S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
805                     ))
806                     goto have_candidate;
807             }
808             continue;
809         }
810         else candidate = *gvp;
811        have_candidate:
812         assert(candidate);
813         if (SvTYPE(candidate) != SVt_PVGV)
814             gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
815         if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
816             /*
817              * Found real method, cache method in topgv if:
818              *  1. topgv has no synonyms (else inheritance crosses wires)
819              *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
820              */
821             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
822                   CV *old_cv = GvCV(topgv);
823                   SvREFCNT_dec(old_cv);
824                   SvREFCNT_inc_simple_void_NN(cand_cv);
825                   GvCV_set(topgv, cand_cv);
826                   GvCVGEN(topgv) = topgen_cmp;
827             }
828             return candidate;
829         }
830     }
831
832     /* Check UNIVERSAL without caching */
833     if(level == 0 || level == -1) {
834         candidate = gv_fetchmeth_internal(NULL, meth, name, len, 1,
835                                           flags &~GV_SUPER);
836         if(candidate) {
837             cand_cv = GvCV(candidate);
838             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
839                   CV *old_cv = GvCV(topgv);
840                   SvREFCNT_dec(old_cv);
841                   SvREFCNT_inc_simple_void_NN(cand_cv);
842                   GvCV_set(topgv, cand_cv);
843                   GvCVGEN(topgv) = topgen_cmp;
844             }
845             return candidate;
846         }
847     }
848
849     if (topgv && GvREFCNT(topgv) == 1) {
850         /* cache the fact that the method is not defined */
851         GvCVGEN(topgv) = topgen_cmp;
852     }
853
854     return 0;
855 }
856
857 GV *
858 Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
859 {
860     PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
861     return gv_fetchmeth_internal(stash, NULL, name, len, level, flags);
862 }
863
864 /*
865 =for apidoc gv_fetchmeth_autoload
866
867 This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags
868 parameter.
869
870 =for apidoc gv_fetchmeth_sv_autoload
871
872 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
873 of an SV instead of a string/length pair.
874
875 =cut
876 */
877
878 GV *
879 Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
880 {
881    char *namepv;
882    STRLEN namelen;
883    PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
884    namepv = SvPV(namesv, namelen);
885    if (SvUTF8(namesv))
886        flags |= SVf_UTF8;
887    return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
888 }
889
890 /*
891 =for apidoc gv_fetchmeth_pv_autoload
892
893 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
894 instead of a string/length pair.
895
896 =cut
897 */
898
899 GV *
900 Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
901 {
902     PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
903     return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
904 }
905
906 /*
907 =for apidoc gv_fetchmeth_pvn_autoload
908
909 Same as C<gv_fetchmeth_pvn()>, but looks for autoloaded subroutines too.
910 Returns a glob for the subroutine.
911
912 For an autoloaded subroutine without a GV, will create a GV even
913 if C<level < 0>.  For an autoloaded subroutine without a stub, C<GvCV()>
914 of the result may be zero.
915
916 Currently, the only significant value for C<flags> is C<SVf_UTF8>.
917
918 =cut
919 */
920
921 GV *
922 Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
923 {
924     GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
925
926     PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
927
928     if (!gv) {
929         CV *cv;
930         GV **gvp;
931
932         if (!stash)
933             return NULL;        /* UNIVERSAL::AUTOLOAD could cause trouble */
934         if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
935             return NULL;
936         if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
937             return NULL;
938         cv = GvCV(gv);
939         if (!(CvROOT(cv) || CvXSUB(cv)))
940             return NULL;
941         /* Have an autoload */
942         if (level < 0)  /* Cannot do without a stub */
943             gv_fetchmeth_pvn(stash, name, len, 0, flags);
944         gvp = (GV**)hv_fetch(stash, name,
945                         (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
946         if (!gvp)
947             return NULL;
948         return *gvp;
949     }
950     return gv;
951 }
952
953 /*
954 =for apidoc gv_fetchmethod_autoload
955
956 Returns the glob which contains the subroutine to call to invoke the method
957 on the C<stash>.  In fact in the presence of autoloading this may be the
958 glob for "AUTOLOAD".  In this case the corresponding variable C<$AUTOLOAD> is
959 already setup.
960
961 The third parameter of C<gv_fetchmethod_autoload> determines whether
962 AUTOLOAD lookup is performed if the given method is not present: non-zero
963 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
964 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
965 with a non-zero C<autoload> parameter.
966
967 These functions grant C<"SUPER"> token
968 as a prefix of the method name.  Note
969 that if you want to keep the returned glob for a long time, you need to
970 check for it being "AUTOLOAD", since at the later time the call may load a
971 different subroutine due to C<$AUTOLOAD> changing its value.  Use the glob
972 created as a side effect to do this.
973
974 These functions have the same side-effects as C<gv_fetchmeth> with
975 C<level==0>.  The warning against passing the GV returned by
976 C<gv_fetchmeth> to C<call_sv> applies equally to these functions.
977
978 =cut
979 */
980
981 GV *
982 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
983 {
984     PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
985
986     return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
987 }
988
989 GV *
990 Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
991 {
992     char *namepv;
993     STRLEN namelen;
994     PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
995     namepv = SvPV(namesv, namelen);
996     if (SvUTF8(namesv))
997        flags |= SVf_UTF8;
998     return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
999 }
1000
1001 GV *
1002 Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
1003 {
1004     PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
1005     return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
1006 }
1007
1008 GV *
1009 Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
1010 {
1011     const char * const origname = name;
1012     const char * const name_end = name + len;
1013     const char *last_separator = NULL;
1014     GV* gv;
1015     HV* ostash = stash;
1016     SV *const error_report = MUTABLE_SV(stash);
1017     const U32 autoload = flags & GV_AUTOLOAD;
1018     const U32 do_croak = flags & GV_CROAK;
1019     const U32 is_utf8  = flags & SVf_UTF8;
1020
1021     PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
1022
1023     if (SvTYPE(stash) < SVt_PVHV)
1024         stash = NULL;
1025     else {
1026         /* The only way stash can become NULL later on is if last_separator is set,
1027            which in turn means that there is no need for a SVt_PVHV case
1028            the error reporting code.  */
1029     }
1030
1031     {
1032         /* check if the method name is fully qualified or
1033          * not, and separate the package name from the actual
1034          * method name.
1035          *
1036          * leaves last_separator pointing to the beginning of the
1037          * last package separator (either ' or ::) or 0
1038          * if none was found.
1039          *
1040          * leaves name pointing at the beginning of the
1041          * method name.
1042          */
1043         const char *name_cursor = name;
1044         const char * const name_em1 = name_end - 1; /* name_end minus 1 */
1045         for (name_cursor = name; name_cursor < name_end ; name_cursor++) {
1046             if (*name_cursor == '\'') {
1047                 last_separator = name_cursor;
1048                 name = name_cursor + 1;
1049             }
1050             else if (name_cursor < name_em1 && *name_cursor == ':' && name_cursor[1] == ':') {
1051                 last_separator = name_cursor++;
1052                 name = name_cursor + 1;
1053             }
1054         }
1055     }
1056
1057     /* did we find a separator? */
1058     if (last_separator) {
1059         STRLEN sep_len= last_separator - origname;
1060         if ( memEQs(origname, sep_len, "SUPER")) {
1061             /* ->SUPER::method should really be looked up in original stash */
1062             stash = CopSTASH(PL_curcop);
1063             flags |= GV_SUPER;
1064             DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
1065                          origname, HvENAME_get(stash), name) );
1066         }
1067         else if ( sep_len >= 7 &&
1068                  strEQs(last_separator - 7, "::SUPER")) {
1069             /* don't autovifify if ->NoSuchStash::SUPER::method */
1070             stash = gv_stashpvn(origname, sep_len - 7, is_utf8);
1071             if (stash) flags |= GV_SUPER;
1072         }
1073         else {
1074             /* don't autovifify if ->NoSuchStash::method */
1075             stash = gv_stashpvn(origname, sep_len, is_utf8);
1076         }
1077         ostash = stash;
1078     }
1079
1080     gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
1081     if (!gv) {
1082         /* This is the special case that exempts Foo->import and
1083            Foo->unimport from being an error even if there's no
1084           import/unimport subroutine */
1085         if (strEQ(name,"import") || strEQ(name,"unimport"))
1086             gv = MUTABLE_GV(&PL_sv_yes);
1087         else if (autoload)
1088             gv = gv_autoload_pvn(
1089                 ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags
1090             );
1091         if (!gv && do_croak) {
1092             /* Right now this is exclusively for the benefit of S_method_common
1093                in pp_hot.c  */
1094             if (stash) {
1095                 /* If we can't find an IO::File method, it might be a call on
1096                  * a filehandle. If IO:File has not been loaded, try to
1097                  * require it first instead of croaking */
1098                 const char *stash_name = HvNAME_get(stash);
1099                 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
1100                     && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
1101                                        STR_WITH_LEN("IO/File.pm"), 0,
1102                                        HV_FETCH_ISEXISTS, NULL, 0)
1103                 ) {
1104                     require_pv("IO/File.pm");
1105                     gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
1106                     if (gv)
1107                         return gv;
1108                 }
1109                 Perl_croak(aTHX_
1110                            "Can't locate object method \"%" UTF8f
1111                            "\" via package \"%" HEKf "\"",
1112                                     UTF8fARG(is_utf8, name_end - name, name),
1113                                     HEKfARG(HvNAME_HEK(stash)));
1114             }
1115             else {
1116                 SV* packnamesv;
1117
1118                 if (last_separator) {
1119                     packnamesv = newSVpvn_flags(origname, last_separator - origname,
1120                                                     SVs_TEMP | is_utf8);
1121                 } else {
1122                     packnamesv = error_report;
1123                 }
1124
1125                 Perl_croak(aTHX_
1126                            "Can't locate object method \"%" UTF8f
1127                            "\" via package \"%" SVf "\""
1128                            " (perhaps you forgot to load \"%" SVf "\"?)",
1129                            UTF8fARG(is_utf8, name_end - name, name),
1130                            SVfARG(packnamesv), SVfARG(packnamesv));
1131             }
1132         }
1133     }
1134     else if (autoload) {
1135         CV* const cv = GvCV(gv);
1136         if (!CvROOT(cv) && !CvXSUB(cv)) {
1137             GV* stubgv;
1138             GV* autogv;
1139
1140             if (CvANON(cv) || CvLEXICAL(cv))
1141                 stubgv = gv;
1142             else {
1143                 stubgv = CvGV(cv);
1144                 if (GvCV(stubgv) != cv)         /* orphaned import */
1145                     stubgv = gv;
1146             }
1147             autogv = gv_autoload_pvn(GvSTASH(stubgv),
1148                                   GvNAME(stubgv), GvNAMELEN(stubgv),
1149                                   GV_AUTOLOAD_ISMETHOD
1150                                    | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
1151             if (autogv)
1152                 gv = autogv;
1153         }
1154     }
1155
1156     return gv;
1157 }
1158
1159 GV*
1160 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
1161 {
1162    char *namepv;
1163    STRLEN namelen;
1164    PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
1165    namepv = SvPV(namesv, namelen);
1166    if (SvUTF8(namesv))
1167        flags |= SVf_UTF8;
1168    return gv_autoload_pvn(stash, namepv, namelen, flags);
1169 }
1170
1171 GV*
1172 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
1173 {
1174    PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
1175    return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
1176 }
1177
1178 GV*
1179 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
1180 {
1181     GV* gv;
1182     CV* cv;
1183     HV* varstash;
1184     GV* vargv;
1185     SV* varsv;
1186     SV *packname = NULL;
1187     U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
1188
1189     PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
1190
1191     if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1192         return NULL;
1193     if (stash) {
1194         if (SvTYPE(stash) < SVt_PVHV) {
1195             STRLEN packname_len = 0;
1196             const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
1197             packname = newSVpvn_flags(packname_ptr, packname_len,
1198                                       SVs_TEMP | SvUTF8(stash));
1199             stash = NULL;
1200         }
1201         else
1202             packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
1203         if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
1204     }
1205     if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE,
1206                                 is_utf8 | (flags & GV_SUPER))))
1207         return NULL;
1208     cv = GvCV(gv);
1209
1210     if (!(CvROOT(cv) || CvXSUB(cv)))
1211         return NULL;
1212
1213     /*
1214      * Inheriting AUTOLOAD for non-methods no longer works
1215      */
1216     if (
1217         !(flags & GV_AUTOLOAD_ISMETHOD)
1218      && (GvCVGEN(gv) || GvSTASH(gv) != stash)
1219     )
1220         Perl_croak(aTHX_ "Use of inherited AUTOLOAD for non-method %" SVf
1221                          "::%" UTF8f "() is no longer allowed",
1222                          SVfARG(packname),
1223                          UTF8fARG(is_utf8, len, name));
1224
1225     if (CvISXSUB(cv)) {
1226         /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
1227          * and split that value on the last '::', pass along the same data
1228          * via the SvPVX field in the CV, and the stash in CvSTASH.
1229          *
1230          * Due to an unfortunate accident of history, the SvPVX field
1231          * serves two purposes.  It is also used for the subroutine's pro-
1232          * type.  Since SvPVX has been documented as returning the sub name
1233          * for a long time, but not as returning the prototype, we have
1234          * to preserve the SvPVX AUTOLOAD behaviour and put the prototype
1235          * elsewhere.
1236          *
1237          * We put the prototype in the same allocated buffer, but after
1238          * the sub name.  The SvPOK flag indicates the presence of a proto-
1239          * type.  The CvAUTOLOAD flag indicates the presence of a sub name.
1240          * If both flags are on, then SvLEN is used to indicate the end of
1241          * the prototype (artificially lower than what is actually allo-
1242          * cated), at the risk of having to reallocate a few bytes unneces-
1243          * sarily--but that should happen very rarely, if ever.
1244          *
1245          * We use SvUTF8 for both prototypes and sub names, so if one is
1246          * UTF8, the other must be upgraded.
1247          */
1248         CvSTASH_set(cv, stash);
1249         if (SvPOK(cv)) { /* Ouch! */
1250             SV * const tmpsv = newSVpvn_flags(name, len, is_utf8);
1251             STRLEN ulen;
1252             const char *proto = CvPROTO(cv);
1253             assert(proto);
1254             if (SvUTF8(cv))
1255                 sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
1256             ulen = SvCUR(tmpsv);
1257             SvCUR(tmpsv)++; /* include null in string */
1258             sv_catpvn_flags(
1259                 tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
1260             );
1261             SvTEMP_on(tmpsv); /* Allow theft */
1262             sv_setsv_nomg((SV *)cv, tmpsv);
1263             SvTEMP_off(tmpsv);
1264             SvREFCNT_dec_NN(tmpsv);
1265             SvLEN(cv) = SvCUR(cv) + 1;
1266             SvCUR(cv) = ulen;
1267         }
1268         else {
1269           sv_setpvn((SV *)cv, name, len);
1270           SvPOK_off(cv);
1271           if (is_utf8)
1272             SvUTF8_on(cv);
1273           else SvUTF8_off(cv);
1274         }
1275         CvAUTOLOAD_on(cv);
1276     }
1277
1278     /*
1279      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1280      * The subroutine's original name may not be "AUTOLOAD", so we don't
1281      * use that, but for lack of anything better we will use the sub's
1282      * original package to look up $AUTOLOAD.
1283      */
1284     varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv));
1285     vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1286     ENTER;
1287
1288     if (!isGV(vargv)) {
1289         gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
1290 #ifdef PERL_DONT_CREATE_GVSV
1291         GvSV(vargv) = newSV(0);
1292 #endif
1293     }
1294     LEAVE;
1295     varsv = GvSVn(vargv);
1296     SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
1297     /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
1298     sv_setsv(varsv, packname);
1299     sv_catpvs(varsv, "::");
1300     /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1301        tainting if $FOO::AUTOLOAD was previously tainted, but is not now.  */
1302     sv_catpvn_flags(
1303         varsv, name, len,
1304         SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
1305     );
1306     if (is_utf8)
1307         SvUTF8_on(varsv);
1308     return gv;
1309 }
1310
1311
1312 /* require_tie_mod() internal routine for requiring a module
1313  * that implements the logic of automatic ties like %! and %-
1314  * It loads the module and then calls the _tie_it subroutine
1315  * with the passed gv as an argument.
1316  *
1317  * The "gv" parameter should be the glob.
1318  * "varname" holds the 1-char name of the var, used for error messages.
1319  * "namesv" holds the module name. Its refcount will be decremented.
1320  * "flags": if flag & 1 then save the scalar before loading.
1321  * For the protection of $! to work (it is set by this routine)
1322  * the sv slot must already be magicalized.
1323  */
1324 STATIC void
1325 S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name,
1326                         STRLEN len, const U32 flags)
1327 {
1328     const SV * const target = varname == '[' ? GvSV(gv) : (SV *)GvHV(gv);
1329
1330     PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1331
1332     /* If it is not tied */
1333     if (!target || !SvRMAGICAL(target)
1334      || !mg_find(target,
1335                  varname == '[' ? PERL_MAGIC_tiedscalar : PERL_MAGIC_tied))
1336     {
1337       HV *stash;
1338       GV **gvp;
1339       dSP;
1340
1341       PUSHSTACKi(PERLSI_MAGIC);
1342       ENTER;
1343
1344 #define HV_FETCH_TIE_FUNC (GV **)hv_fetchs(stash, "_tie_it", 0)
1345
1346       /* Load the module if it is not loaded.  */
1347       if (!(stash = gv_stashpvn(name, len, 0))
1348        || !(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp))
1349       {
1350         SV * const module = newSVpvn(name, len);
1351         const char type = varname == '[' ? '$' : '%';
1352         if ( flags & 1 )
1353             save_scalar(gv);
1354         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1355         assert(sp == PL_stack_sp);
1356         stash = gv_stashpvn(name, len, 0);
1357         if (!stash)
1358             Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available",
1359                     type, varname, name);
1360         else if (!(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp))
1361             Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it",
1362                     type, varname, name);
1363       }
1364       /* Now call the tie function.  It should be in *gvp.  */
1365       assert(gvp); assert(*gvp); assert(GvCV(*gvp));
1366       PUSHMARK(SP);
1367       XPUSHs((SV *)gv);
1368       PUTBACK;
1369       call_sv((SV *)*gvp, G_VOID|G_DISCARD);
1370       LEAVE;
1371       POPSTACK;
1372     }
1373 }
1374
1375 /* add a require_tie_mod_s - the _s suffix is similar to pvs type suffixes,
1376  * IOW it means we do STR_WITH_LEN() ourselves and the user should pass in
1377  * a true string WITHOUT a len.
1378  */
1379 #define require_tie_mod_s(gv, varname, name, flags) \
1380     S_require_tie_mod(aTHX_ gv, varname, STR_WITH_LEN(name), flags)
1381
1382 /*
1383 =for apidoc gv_stashpv
1384
1385 Returns a pointer to the stash for a specified package.  Uses C<strlen> to
1386 determine the length of C<name>, then calls C<gv_stashpvn()>.
1387
1388 =cut
1389 */
1390
1391 HV*
1392 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1393 {
1394     PERL_ARGS_ASSERT_GV_STASHPV;
1395     return gv_stashpvn(name, strlen(name), create);
1396 }
1397
1398 /*
1399 =for apidoc gv_stashpvn
1400
1401 Returns a pointer to the stash for a specified package.  The C<namelen>
1402 parameter indicates the length of the C<name>, in bytes.  C<flags> is passed
1403 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1404 created if it does not already exist.  If the package does not exist and
1405 C<flags> is 0 (or any other setting that does not create packages) then C<NULL>
1406 is returned.
1407
1408 Flags may be one of:
1409
1410     GV_ADD
1411     SVf_UTF8
1412     GV_NOADD_NOINIT
1413     GV_NOINIT
1414     GV_NOEXPAND
1415     GV_ADDMG
1416
1417 The most important of which are probably C<GV_ADD> and C<SVf_UTF8>.
1418
1419 Note, use of C<gv_stashsv> instead of C<gv_stashpvn> where possible is strongly
1420 recommended for performance reasons.
1421
1422 =cut
1423 */
1424
1425 /*
1426 gv_stashpvn_internal
1427
1428 Perform the internal bits of gv_stashsvpvn_cached. You could think of this
1429 as being one half of the logic. Not to be called except from gv_stashsvpvn_cached().
1430
1431 */
1432
1433 PERL_STATIC_INLINE HV*
1434 S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags)
1435 {
1436     char smallbuf[128];
1437     char *tmpbuf;
1438     HV *stash;
1439     GV *tmpgv;
1440     U32 tmplen = namelen + 2;
1441
1442     PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL;
1443
1444     if (tmplen <= sizeof smallbuf)
1445         tmpbuf = smallbuf;
1446     else
1447         Newx(tmpbuf, tmplen, char);
1448     Copy(name, tmpbuf, namelen, char);
1449     tmpbuf[namelen]   = ':';
1450     tmpbuf[namelen+1] = ':';
1451     tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1452     if (tmpbuf != smallbuf)
1453         Safefree(tmpbuf);
1454     if (!tmpgv || !isGV_with_GP(tmpgv))
1455         return NULL;
1456     stash = GvHV(tmpgv);
1457     if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1458     assert(stash);
1459     if (!HvNAME_get(stash)) {
1460         hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1461         
1462         /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1463         /* If the containing stash has multiple effective
1464            names, see that this one gets them, too. */
1465         if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1466             mro_package_moved(stash, NULL, tmpgv, 1);
1467     }
1468     return stash;
1469 }
1470
1471 /*
1472 gv_stashsvpvn_cached
1473
1474 Returns a pointer to the stash for a specified package, possibly
1475 cached.  Implements both C<gv_stashpvn> and C<gv_stashsv>.
1476
1477 Requires one of either namesv or namepv to be non-null.
1478
1479 See C<L</gv_stashpvn>> for details on "flags".
1480
1481 Note the sv interface is strongly preferred for performance reasons.
1482
1483 */
1484
1485 #define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \
1486     assert(namesv || name)
1487
1488 PERL_STATIC_INLINE HV*
1489 S_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags)
1490 {
1491     HV* stash;
1492     HE* he;
1493
1494     PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED;
1495
1496     he = (HE *)hv_common(
1497         PL_stashcache, namesv, name, namelen,
1498         (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0
1499     );
1500
1501     if (he) {
1502         SV *sv = HeVAL(he);
1503         HV *hv;
1504         assert(SvIOK(sv));
1505         hv = INT2PTR(HV*, SvIVX(sv));
1506         assert(SvTYPE(hv) == SVt_PVHV);
1507         return hv;
1508     }
1509     else if (flags & GV_CACHE_ONLY) return NULL;
1510
1511     if (namesv) {
1512         if (SvOK(namesv)) { /* prevent double uninit warning */
1513             STRLEN len;
1514             name = SvPV_const(namesv, len);
1515             namelen = len;
1516             flags |= SvUTF8(namesv);
1517         } else {
1518             name = ""; namelen = 0;
1519         }
1520     }
1521     stash = gv_stashpvn_internal(name, namelen, flags);
1522
1523     if (stash && namelen) {
1524         SV* const ref = newSViv(PTR2IV(stash));
1525         (void)hv_store(PL_stashcache, name,
1526             (flags & SVf_UTF8) ? -(I32)namelen : (I32)namelen, ref, 0);
1527     }
1528
1529     return stash;
1530 }
1531
1532 HV*
1533 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1534 {
1535     PERL_ARGS_ASSERT_GV_STASHPVN;
1536     return gv_stashsvpvn_cached(NULL, name, namelen, flags);
1537 }
1538
1539 /*
1540 =for apidoc gv_stashsv
1541
1542 Returns a pointer to the stash for a specified package.  See
1543 C<L</gv_stashpvn>>.
1544
1545 Note this interface is strongly preferred over C<gv_stashpvn> for performance
1546 reasons.
1547
1548 =cut
1549 */
1550
1551 HV*
1552 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1553 {
1554     PERL_ARGS_ASSERT_GV_STASHSV;
1555     return gv_stashsvpvn_cached(sv, NULL, 0, flags);
1556 }
1557
1558
1559 GV *
1560 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
1561     PERL_ARGS_ASSERT_GV_FETCHPV;
1562     return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
1563 }
1564
1565 GV *
1566 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1567     STRLEN len;
1568     const char * const nambeg =
1569        SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1570     PERL_ARGS_ASSERT_GV_FETCHSV;
1571     return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1572 }
1573
1574 PERL_STATIC_INLINE void
1575 S_gv_magicalize_isa(pTHX_ GV *gv)
1576 {
1577     AV* av;
1578
1579     PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1580
1581     av = GvAVn(gv);
1582     GvMULTI_on(gv);
1583     sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1584              NULL, 0);
1585 }
1586
1587 /* This function grabs name and tries to split a stash and glob
1588  * from its contents. TODO better description, comments
1589  * 
1590  * If the function returns TRUE and 'name == name_end', then
1591  * 'gv' can be directly returned to the caller of gv_fetchpvn_flags
1592  */
1593 PERL_STATIC_INLINE bool
1594 S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name,
1595                STRLEN *len, const char *nambeg, STRLEN full_len,
1596                const U32 is_utf8, const I32 add)
1597 {
1598     char *tmpfullbuf = NULL; /* only malloc one big chunk of memory when the smallbuff is not large enough */
1599     const char *name_cursor;
1600     const char *const name_end = nambeg + full_len;
1601     const char *const name_em1 = name_end - 1;
1602     char smallbuf[64]; /* small buffer to avoid a malloc when possible */
1603
1604     PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME;
1605     
1606     if (   full_len > 2
1607         && **name == '*'
1608         && isIDFIRST_lazy_if_safe(*name + 1, name_end, is_utf8))
1609     {
1610         /* accidental stringify on a GV? */
1611         (*name)++;
1612     }
1613
1614     for (name_cursor = *name; name_cursor < name_end; name_cursor++) {
1615         if (name_cursor < name_em1 &&
1616             ((*name_cursor == ':' && name_cursor[1] == ':')
1617            || *name_cursor == '\''))
1618         {
1619             if (!*stash)
1620                 *stash = PL_defstash;
1621             if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */
1622                 return FALSE;
1623
1624             *len = name_cursor - *name;
1625             if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1626                 const char *key;
1627                 GV**gvp;
1628                 if (*name_cursor == ':') {
1629                     key = *name;
1630                     *len += 2;
1631                 }
1632                 else { /* using ' for package separator */
1633                     /* use our pre-allocated buffer when possible to save a malloc */
1634                     char *tmpbuf;
1635                     if ( *len+2 <= sizeof smallbuf)
1636                         tmpbuf = smallbuf;
1637                     else {
1638                         /* only malloc once if needed */
1639                         if (tmpfullbuf == NULL) /* only malloc&free once, a little more than needed */
1640                             Newx(tmpfullbuf, full_len+2, char);
1641                         tmpbuf = tmpfullbuf;
1642                     }
1643                     Copy(*name, tmpbuf, *len, char);
1644                     tmpbuf[(*len)++] = ':';
1645                     tmpbuf[(*len)++] = ':';
1646                     key = tmpbuf;
1647                 }
1648                 gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add);
1649                 *gv = gvp ? *gvp : NULL;
1650                 if (!*gv || *gv == (const GV *)&PL_sv_undef) {
1651                     Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
1652                     return FALSE;
1653                 }
1654                 /* here we know that *gv && *gv != &PL_sv_undef */
1655                 if (SvTYPE(*gv) != SVt_PVGV)
1656                     gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8);
1657                 else
1658                     GvMULTI_on(*gv);
1659
1660                 if (!(*stash = GvHV(*gv))) {
1661                     *stash = GvHV(*gv) = newHV();
1662                     if (!HvNAME_get(*stash)) {
1663                         if (GvSTASH(*gv) == PL_defstash && *len == 6
1664                             && strEQs(*name, "CORE"))
1665                             hv_name_sets(*stash, "CORE", 0);
1666                         else
1667                             hv_name_set(
1668                                 *stash, nambeg, name_cursor-nambeg, is_utf8
1669                             );
1670                     /* If the containing stash has multiple effective
1671                     names, see that this one gets them, too. */
1672                     if (HvAUX(GvSTASH(*gv))->xhv_name_count)
1673                         mro_package_moved(*stash, NULL, *gv, 1);
1674                     }
1675                 }
1676                 else if (!HvNAME_get(*stash))
1677                     hv_name_set(*stash, nambeg, name_cursor - nambeg, is_utf8);
1678             }
1679
1680             if (*name_cursor == ':')
1681                 name_cursor++;
1682             *name = name_cursor+1;
1683             if (*name == name_end) {
1684                 if (!*gv) {
1685                     *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1686                     if (SvTYPE(*gv) != SVt_PVGV) {
1687                         gv_init_pvn(*gv, PL_defstash, "main::", 6,
1688                                     GV_ADDMULTI);
1689                         GvHV(*gv) =
1690                             MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
1691                     }
1692                 }
1693                 Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
1694                 return TRUE;
1695             }
1696         }
1697     }
1698     *len = name_cursor - *name;
1699     return TRUE;
1700 }
1701
1702 /* Checks if an unqualified name is in the main stash */
1703 PERL_STATIC_INLINE bool
1704 S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8)
1705 {
1706     PERL_ARGS_ASSERT_GV_IS_IN_MAIN;
1707     
1708     /* If it's an alphanumeric variable */
1709     if ( len && isIDFIRST_lazy_if_safe(name, name + len, is_utf8) ) {
1710         /* Some "normal" variables are always in main::,
1711          * like INC or STDOUT.
1712          */
1713         switch (len) {
1714             case 1:
1715             if (*name == '_')
1716                 return TRUE;
1717             break;
1718             case 3:
1719             if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1720                 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1721                 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1722                 return TRUE;
1723             break;
1724             case 4:
1725             if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1726                 && name[3] == 'V')
1727                 return TRUE;
1728             break;
1729             case 5:
1730             if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1731                 && name[3] == 'I' && name[4] == 'N')
1732                 return TRUE;
1733             break;
1734             case 6:
1735             if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1736                 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1737                     ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1738                 return TRUE;
1739             break;
1740             case 7:
1741             if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1742                 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1743                 && name[6] == 'T')
1744                 return TRUE;
1745             break;
1746         }
1747     }
1748     /* *{""}, or a special variable like $@ */
1749     else
1750         return TRUE;
1751     
1752     return FALSE;
1753 }
1754
1755
1756 /* This function is called if parse_gv_stash_name() failed to
1757  * find a stash, or if GV_NOTQUAL or an empty name was passed
1758  * to gv_fetchpvn_flags.
1759  * 
1760  * It returns FALSE if the default stash can't be found nor created,
1761  * which might happen during global destruction.
1762  */
1763 PERL_STATIC_INLINE bool
1764 S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len,
1765                const U32 is_utf8, const I32 add,
1766                const svtype sv_type)
1767 {
1768     PERL_ARGS_ASSERT_FIND_DEFAULT_STASH;
1769     
1770     /* No stash in name, so see how we can default */
1771
1772     if ( gv_is_in_main(name, len, is_utf8) ) {
1773         *stash = PL_defstash;
1774     }
1775     else {
1776         if (IN_PERL_COMPILETIME) {
1777             *stash = PL_curstash;
1778             if (add && (PL_hints & HINT_STRICT_VARS) &&
1779                 sv_type != SVt_PVCV &&
1780                 sv_type != SVt_PVGV &&
1781                 sv_type != SVt_PVFM &&
1782                 sv_type != SVt_PVIO &&
1783                 !(len == 1 && sv_type == SVt_PV &&
1784                 (*name == 'a' || *name == 'b')) )
1785             {
1786                 GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -(I32)len : (I32)len,0);
1787                 if (!gvp || *gvp == (const GV *)&PL_sv_undef ||
1788                     SvTYPE(*gvp) != SVt_PVGV)
1789                 {
1790                     *stash = NULL;
1791                 }
1792                 else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
1793                          (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1794                          (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1795                 {
1796                     /* diag_listed_as: Variable "%s" is not imported%s */
1797                     Perl_ck_warner_d(
1798                         aTHX_ packWARN(WARN_MISC),
1799                         "Variable \"%c%" UTF8f "\" is not imported",
1800                         sv_type == SVt_PVAV ? '@' :
1801                         sv_type == SVt_PVHV ? '%' : '$',
1802                         UTF8fARG(is_utf8, len, name));
1803                     if (GvCVu(*gvp))
1804                         Perl_ck_warner_d(
1805                             aTHX_ packWARN(WARN_MISC),
1806                             "\t(Did you mean &%" UTF8f " instead?)\n",
1807                             UTF8fARG(is_utf8, len, name)
1808                         );
1809                     *stash = NULL;
1810                 }
1811             }
1812         }
1813         else {
1814             /* Use the current op's stash */
1815             *stash = CopSTASH(PL_curcop);
1816         }
1817     }
1818
1819     if (!*stash) {
1820         if (add && !PL_in_clean_all) {
1821             GV *gv;
1822             qerror(Perl_mess(aTHX_
1823                  "Global symbol \"%s%" UTF8f
1824                  "\" requires explicit package name (did you forget to "
1825                  "declare \"my %s%" UTF8f "\"?)",
1826                  (sv_type == SVt_PV ? "$"
1827                   : sv_type == SVt_PVAV ? "@"
1828                   : sv_type == SVt_PVHV ? "%"
1829                   : ""), UTF8fARG(is_utf8, len, name),
1830                  (sv_type == SVt_PV ? "$"
1831                   : sv_type == SVt_PVAV ? "@"
1832                   : sv_type == SVt_PVHV ? "%"
1833                   : ""), UTF8fARG(is_utf8, len, name)));
1834             /* To maintain the output of errors after the strict exception
1835              * above, and to keep compat with older releases, rather than
1836              * placing the variables in the pad, we place
1837              * them in the <none>:: stash.
1838              */
1839             gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1840             if (!gv) {
1841                 /* symbol table under destruction */
1842                 return FALSE;
1843             }
1844             *stash = GvHV(gv);
1845         }
1846         else
1847             return FALSE;
1848     }
1849
1850     if (!SvREFCNT(*stash))   /* symbol table under destruction */
1851         return FALSE;
1852
1853     return TRUE;
1854 }
1855
1856 /* gv_magicalize only turns on the SVf_READONLY flag, not SVf_PROTECT.  So
1857    redefine SvREADONLY_on for that purpose.  We don’t use it later on in
1858    this file.  */
1859 #undef SvREADONLY_on
1860 #define SvREADONLY_on(sv) (SvFLAGS(sv) |= SVf_READONLY)
1861
1862 /* gv_magicalize() is called by gv_fetchpvn_flags when creating
1863  * a new GV.
1864  * Note that it does not insert the GV into the stash prior to
1865  * magicalization, which some variables require need in order
1866  * to work (like $[, %+, %-, %!), so callers must take care of
1867  * that.
1868  * 
1869  * It returns true if the gv did turn out to be magical one; i.e.,
1870  * if gv_magicalize actually did something.
1871  */
1872 PERL_STATIC_INLINE bool
1873 S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
1874                       const svtype sv_type)
1875 {
1876     SSize_t paren;
1877
1878     PERL_ARGS_ASSERT_GV_MAGICALIZE;
1879     
1880     if (stash != PL_defstash) { /* not the main stash */
1881         /* We only have to check for a few names here: a, b, EXPORT, ISA
1882            and VERSION. All the others apply only to the main stash or to
1883            CORE (which is checked right after this). */
1884         if (len) {
1885             switch (*name) {
1886             case 'E':
1887                 if (
1888                     len >= 6 && name[1] == 'X' &&
1889                     (memEQs(name, len, "EXPORT")
1890                     ||memEQs(name, len, "EXPORT_OK")
1891                     ||memEQs(name, len, "EXPORT_FAIL")
1892                     ||memEQs(name, len, "EXPORT_TAGS"))
1893                 )
1894                     GvMULTI_on(gv);
1895                 break;
1896             case 'I':
1897                 if (memEQs(name, len, "ISA"))
1898                     gv_magicalize_isa(gv);
1899                 break;
1900             case 'V':
1901                 if (memEQs(name, len, "VERSION"))
1902                     GvMULTI_on(gv);
1903                 break;
1904             case 'a':
1905                 if (stash == PL_debstash && memEQs(name, len, "args")) {
1906                     GvMULTI_on(gv_AVadd(gv));
1907                     break;
1908                 }
1909                 /* FALLTHROUGH */
1910             case 'b':
1911                 if (len == 1 && sv_type == SVt_PV)
1912                     GvMULTI_on(gv);
1913                 /* FALLTHROUGH */
1914             default:
1915                 goto try_core;
1916             }
1917             goto ret;
1918         }
1919       try_core:
1920         if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1921           /* Avoid null warning: */
1922           const char * const stashname = HvNAME(stash); assert(stashname);
1923           if (strEQs(stashname, "CORE"))
1924             S_maybe_add_coresub(aTHX_ 0, gv, name, len);
1925         }
1926     }
1927     else if (len > 1) {
1928 #ifndef EBCDIC
1929         if (*name > 'V' ) {
1930             NOOP;
1931             /* Nothing else to do.
1932                The compiler will probably turn the switch statement into a
1933                branch table. Make sure we avoid even that small overhead for
1934                the common case of lower case variable names.  (On EBCDIC
1935                platforms, we can't just do:
1936                  if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) {
1937                because cases like '\027' in the switch statement below are
1938                C1 (non-ASCII) controls on those platforms, so the remapping
1939                would make them larger than 'V')
1940              */
1941         } else
1942 #endif
1943         {
1944             switch (*name) {
1945             case 'A':
1946                 if (memEQs(name, len, "ARGV")) {
1947                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1948                 }
1949                 else if (memEQs(name, len, "ARGVOUT")) {
1950                     GvMULTI_on(gv);
1951                 }
1952                 break;
1953             case 'E':
1954                 if (
1955                     len >= 6 && name[1] == 'X' &&
1956                     (memEQs(name, len, "EXPORT")
1957                     ||memEQs(name, len, "EXPORT_OK")
1958                     ||memEQs(name, len, "EXPORT_FAIL")
1959                     ||memEQs(name, len, "EXPORT_TAGS"))
1960                 )
1961                     GvMULTI_on(gv);
1962                 break;
1963             case 'I':
1964                 if (memEQs(name, len, "ISA")) {
1965                     gv_magicalize_isa(gv);
1966                 }
1967                 break;
1968             case 'S':
1969                 if (memEQs(name, len, "SIG")) {
1970                     HV *hv;
1971                     I32 i;
1972                     if (!PL_psig_name) {
1973                         Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1974                         Newxz(PL_psig_pend, SIG_SIZE, int);
1975                         PL_psig_ptr = PL_psig_name + SIG_SIZE;
1976                     } else {
1977                         /* I think that the only way to get here is to re-use an
1978                            embedded perl interpreter, where the previous
1979                            use didn't clean up fully because
1980                            PL_perl_destruct_level was 0. I'm not sure that we
1981                            "support" that, in that I suspect in that scenario
1982                            there are sufficient other garbage values left in the
1983                            interpreter structure that something else will crash
1984                            before we get here. I suspect that this is one of
1985                            those "doctor, it hurts when I do this" bugs.  */
1986                         Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1987                         Zero(PL_psig_pend, SIG_SIZE, int);
1988                     }
1989                     GvMULTI_on(gv);
1990                     hv = GvHVn(gv);
1991                     hv_magic(hv, NULL, PERL_MAGIC_sig);
1992                     for (i = 1; i < SIG_SIZE; i++) {
1993                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1994                         if (init)
1995                             sv_setsv(*init, &PL_sv_undef);
1996                     }
1997                 }
1998                 break;
1999             case 'V':
2000                 if (memEQs(name, len, "VERSION"))
2001                     GvMULTI_on(gv);
2002                 break;
2003             case '\003':        /* $^CHILD_ERROR_NATIVE */
2004                 if (memEQs(name, len, "\003HILD_ERROR_NATIVE"))
2005                     goto magicalize;
2006                                 /* @{^CAPTURE} %{^CAPTURE} */
2007                 if (memEQs(name, len, "\003APTURE")) {
2008                     AV* const av = GvAVn(gv);
2009                     const Size_t n = *name;
2010
2011                     sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
2012                     SvREADONLY_on(av);
2013
2014                     if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2015                         require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
2016
2017                 } else          /* %{^CAPTURE_ALL} */
2018                 if (memEQs(name, len, "\003APTURE_ALL")) {
2019                     if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2020                         require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
2021                 }
2022                 break;
2023             case '\005':        /* $^ENCODING */
2024                 if (memEQs(name, len, "\005NCODING"))
2025                     goto magicalize;
2026                 break;
2027             case '\007':        /* $^GLOBAL_PHASE */
2028                 if (memEQs(name, len, "\007LOBAL_PHASE"))
2029                     goto ro_magicalize;
2030                 break;
2031             case '\014':        /* $^LAST_FH */
2032                 if (memEQs(name, len, "\014AST_FH"))
2033                     goto ro_magicalize;
2034                 break;
2035             case '\015':        /* $^MATCH */
2036                 if (memEQs(name, len, "\015ATCH")) {
2037                     paren = RX_BUFF_IDX_CARET_FULLMATCH;
2038                     goto storeparen;
2039                 }
2040                 break;
2041             case '\017':        /* $^OPEN */
2042                 if (memEQs(name, len, "\017PEN"))
2043                     goto magicalize;
2044                 break;
2045             case '\020':        /* $^PREMATCH  $^POSTMATCH */
2046                 if (memEQs(name, len, "\020REMATCH")) {
2047                     paren = RX_BUFF_IDX_CARET_PREMATCH;
2048                     goto storeparen;
2049                 }
2050                 if (memEQs(name, len, "\020OSTMATCH")) {
2051                     paren = RX_BUFF_IDX_CARET_POSTMATCH;
2052                     goto storeparen;
2053                 }
2054                 break;
2055             case '\024':        /* ${^TAINT} */
2056                 if (memEQs(name, len, "\024AINT"))
2057                     goto ro_magicalize;
2058                 break;
2059             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
2060                 if (memEQs(name, len, "\025NICODE"))
2061                     goto ro_magicalize;
2062                 if (memEQs(name, len, "\025TF8LOCALE"))
2063                     goto ro_magicalize;
2064                 if (memEQs(name, len, "\025TF8CACHE"))
2065                     goto magicalize;
2066                 break;
2067             case '\027':        /* $^WARNING_BITS */
2068                 if (memEQs(name, len, "\027ARNING_BITS"))
2069                     goto magicalize;
2070 #ifdef WIN32
2071                 else if (memEQs(name, len, "\027IN32_SLOPPY_STAT"))
2072                     goto magicalize;
2073 #endif
2074                 break;
2075             case '1':
2076             case '2':
2077             case '3':
2078             case '4':
2079             case '5':
2080             case '6':
2081             case '7':
2082             case '8':
2083             case '9':
2084             {
2085                 /* Ensures that we have an all-digit variable, ${"1foo"} fails
2086                    this test  */
2087                 UV uv;
2088                 if (!grok_atoUV(name, &uv, NULL) || uv > I32_MAX)
2089                     goto ret;
2090                 /* XXX why are we using a SSize_t? */
2091                 paren = (SSize_t)(I32)uv;
2092                 goto storeparen;
2093             }
2094             }
2095         }
2096     } else {
2097         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
2098            be case '\0' in this switch statement (ie a default case)  */
2099         switch (*name) {
2100         case '&':               /* $& */
2101             paren = RX_BUFF_IDX_FULLMATCH;
2102             goto sawampersand;
2103         case '`':               /* $` */
2104             paren = RX_BUFF_IDX_PREMATCH;
2105             goto sawampersand;
2106         case '\'':              /* $' */
2107             paren = RX_BUFF_IDX_POSTMATCH;
2108         sawampersand:
2109 #ifdef PERL_SAWAMPERSAND
2110             if (!(
2111                 sv_type == SVt_PVAV ||
2112                 sv_type == SVt_PVHV ||
2113                 sv_type == SVt_PVCV ||
2114                 sv_type == SVt_PVFM ||
2115                 sv_type == SVt_PVIO
2116                 )) { PL_sawampersand |=
2117                         (*name == '`')
2118                             ? SAWAMPERSAND_LEFT
2119                             : (*name == '&')
2120                                 ? SAWAMPERSAND_MIDDLE
2121                                 : SAWAMPERSAND_RIGHT;
2122                 }
2123 #endif
2124             goto storeparen;
2125         case '1':               /* $1 */
2126         case '2':               /* $2 */
2127         case '3':               /* $3 */
2128         case '4':               /* $4 */
2129         case '5':               /* $5 */
2130         case '6':               /* $6 */
2131         case '7':               /* $7 */
2132         case '8':               /* $8 */
2133         case '9':               /* $9 */
2134             paren = *name - '0';
2135
2136         storeparen:
2137             /* Flag the capture variables with a NULL mg_ptr
2138                Use mg_len for the array index to lookup.  */
2139             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren);
2140             break;
2141
2142         case ':':               /* $: */
2143             sv_setpv(GvSVn(gv),PL_chopset);
2144             goto magicalize;
2145
2146         case '?':               /* $? */
2147 #ifdef COMPLEX_STATUS
2148             SvUPGRADE(GvSVn(gv), SVt_PVLV);
2149 #endif
2150             goto magicalize;
2151
2152         case '!':               /* $! */
2153             GvMULTI_on(gv);
2154             /* If %! has been used, automatically load Errno.pm. */
2155
2156             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2157
2158             /* magicalization must be done before require_tie_mod_s is called */
2159             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2160                 require_tie_mod_s(gv, '!', "Errno", 1);
2161
2162             break;
2163         case '-':               /* $-, %-, @- */
2164         case '+':               /* $+, %+, @+ */
2165             GvMULTI_on(gv); /* no used once warnings here */
2166             {   /* $- $+ */
2167                 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2168                 if (*name == '+')
2169                     SvREADONLY_on(GvSVn(gv));
2170             }
2171             {   /* %- %+ */
2172                 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2173                     require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture",0);
2174             }
2175             {   /* @- @+ */
2176                 AV* const av = GvAVn(gv);
2177                 const Size_t n = *name;
2178
2179                 sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
2180                 SvREADONLY_on(av);
2181             }
2182             break;
2183         case '*':               /* $* */
2184         case '#':               /* $# */
2185             if (sv_type == SVt_PV)
2186                 /* diag_listed_as: $* is no longer supported. Its use will be fatal in Perl 5.30 */
2187                 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
2188                                  "$%c is no longer supported. Its use "
2189                                  "will be fatal in Perl 5.30", *name);
2190             break;
2191         case '\010':    /* $^H */
2192             {
2193                 HV *const hv = GvHVn(gv);
2194                 hv_magic(hv, NULL, PERL_MAGIC_hints);
2195             }
2196             goto magicalize;
2197         case '[':               /* $[ */
2198             if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
2199              && FEATURE_ARYBASE_IS_ENABLED) {
2200                 require_tie_mod_s(gv,'[',"arybase",0);
2201             }
2202             else goto magicalize;
2203             break;
2204         case '\023':    /* $^S */
2205         ro_magicalize:
2206             SvREADONLY_on(GvSVn(gv));
2207             /* FALLTHROUGH */
2208         case '0':               /* $0 */
2209         case '^':               /* $^ */
2210         case '~':               /* $~ */
2211         case '=':               /* $= */
2212         case '%':               /* $% */
2213         case '.':               /* $. */
2214         case '(':               /* $( */
2215         case ')':               /* $) */
2216         case '<':               /* $< */
2217         case '>':               /* $> */
2218         case '\\':              /* $\ */
2219         case '/':               /* $/ */
2220         case '|':               /* $| */
2221         case '$':               /* $$ */
2222         case '\001':    /* $^A */
2223         case '\003':    /* $^C */
2224         case '\004':    /* $^D */
2225         case '\005':    /* $^E */
2226         case '\006':    /* $^F */
2227         case '\011':    /* $^I, NOT \t in EBCDIC */
2228         case '\016':    /* $^N */
2229         case '\017':    /* $^O */
2230         case '\020':    /* $^P */
2231         case '\024':    /* $^T */
2232         case '\027':    /* $^W */
2233         magicalize:
2234             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2235             break;
2236
2237         case '\014':    /* $^L */
2238             sv_setpvs(GvSVn(gv),"\f");
2239             break;
2240         case ';':               /* $; */
2241             sv_setpvs(GvSVn(gv),"\034");
2242             break;
2243         case ']':               /* $] */
2244         {
2245             SV * const sv = GvSV(gv);
2246             if (!sv_derived_from(PL_patchlevel, "version"))
2247                 upg_version(PL_patchlevel, TRUE);
2248             GvSV(gv) = vnumify(PL_patchlevel);
2249             SvREADONLY_on(GvSV(gv));
2250             SvREFCNT_dec(sv);
2251         }
2252         break;
2253         case '\026':    /* $^V */
2254         {
2255             SV * const sv = GvSV(gv);
2256             GvSV(gv) = new_version(PL_patchlevel);
2257             SvREADONLY_on(GvSV(gv));
2258             SvREFCNT_dec(sv);
2259         }
2260         break;
2261         case 'a':
2262         case 'b':
2263             if (sv_type == SVt_PV)
2264                 GvMULTI_on(gv);
2265         }
2266     }
2267
2268    ret:
2269     /* Return true if we actually did something.  */
2270     return GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv)
2271         || ( GvSV(gv) && (
2272                            SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv))
2273                          )
2274            );
2275 }
2276
2277 /* If we do ever start using this later on in the file, we need to make
2278    sure we don’t accidentally use the wrong definition.  */
2279 #undef SvREADONLY_on
2280
2281 /* This function is called when the stash already holds the GV of the magic
2282  * variable we're looking for, but we need to check that it has the correct
2283  * kind of magic.  For example, if someone first uses $! and then %!, the
2284  * latter would end up here, and we add the Errno tie to the HASH slot of
2285  * the *! glob.
2286  */
2287 PERL_STATIC_INLINE void
2288 S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
2289 {
2290     PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV;
2291
2292     if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
2293         if (*name == '!')
2294             require_tie_mod_s(gv, '!', "Errno", 1);
2295         else if (*name == '-' || *name == '+')
2296             require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture", 0);
2297     } else if (sv_type == SVt_PV) {
2298         if (*name == '*' || *name == '#') {
2299             /* diag_listed_as: $# is no longer supported. Its use will be fatal in Perl 5.30 */
2300             Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
2301                                              WARN_SYNTAX),
2302                              "$%c is no longer supported. Its use "
2303                              "will be fatal in Perl 5.30", *name);
2304         }
2305     }
2306     if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
2307       switch (*name) {
2308       case '[':
2309           require_tie_mod_s(gv,'[',"arybase",0);
2310           break;
2311 #ifdef PERL_SAWAMPERSAND
2312       case '`':
2313           PL_sawampersand |= SAWAMPERSAND_LEFT;
2314           (void)GvSVn(gv);
2315           break;
2316       case '&':
2317           PL_sawampersand |= SAWAMPERSAND_MIDDLE;
2318           (void)GvSVn(gv);
2319           break;
2320       case '\'':
2321           PL_sawampersand |= SAWAMPERSAND_RIGHT;
2322           (void)GvSVn(gv);
2323           break;
2324 #endif
2325       }
2326     }
2327 }
2328
2329 GV *
2330 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
2331                        const svtype sv_type)
2332 {
2333     const char *name = nambeg;
2334     GV *gv = NULL;
2335     GV**gvp;
2336     STRLEN len;
2337     HV *stash = NULL;
2338     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
2339     const I32 no_expand = flags & GV_NOEXPAND;
2340     const I32 add = flags & ~GV_NOADD_MASK;
2341     const U32 is_utf8 = flags & SVf_UTF8;
2342     bool addmg = cBOOL(flags & GV_ADDMG);
2343     const char *const name_end = nambeg + full_len;
2344     U32 faking_it;
2345
2346     PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
2347
2348      /* If we have GV_NOTQUAL, the caller promised that
2349       * there is no stash, so we can skip the check.
2350       * Similarly if full_len is 0, since then we're
2351       * dealing with something like *{""} or ""->foo()
2352       */
2353     if ((flags & GV_NOTQUAL) || !full_len) {
2354         len = full_len;
2355     }
2356     else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) {
2357         if (name == name_end) return gv;
2358     }
2359     else {
2360         return NULL;
2361     }
2362
2363     if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) {
2364         return NULL;
2365     }
2366     
2367     /* By this point we should have a stash and a name */
2368     gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add);
2369     if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
2370         if (addmg) gv = (GV *)newSV(0);
2371         else return NULL;
2372     }
2373     else gv = *gvp, addmg = 0;
2374     /* From this point on, addmg means gv has not been inserted in the
2375        symtab yet. */
2376
2377     if (SvTYPE(gv) == SVt_PVGV) {
2378         /* The GV already exists, so return it, but check if we need to do
2379          * anything else with it before that.
2380          */
2381         if (add) {
2382             /* This is the heuristic that handles if a variable triggers the
2383              * 'used only once' warning.  If there's already a GV in the stash
2384              * with this name, then we assume that the variable has been used
2385              * before and turn its MULTI flag on.
2386              * It's a heuristic because it can easily be "tricked", like with
2387              * BEGIN { $a = 1; $::{foo} = *a }; () = $foo
2388              * not warning about $main::foo being used just once
2389              */
2390             GvMULTI_on(gv);
2391             gv_init_svtype(gv, sv_type);
2392             /* You reach this path once the typeglob has already been created,
2393                either by the same or a different sigil.  If this path didn't
2394                exist, then (say) referencing $! first, and %! second would
2395                mean that %! was not handled correctly.  */
2396             if (len == 1 && stash == PL_defstash) {
2397                 maybe_multimagic_gv(gv, name, sv_type);
2398             }
2399             else if (len == 3 && sv_type == SVt_PVAV
2400                   && strEQs(name, "ISA")
2401                   && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
2402                 gv_magicalize_isa(gv);
2403         }
2404         return gv;
2405     } else if (no_init) {
2406         assert(!addmg);
2407         return gv;
2408     }
2409     /* If GV_NOEXPAND is true and what we got off the stash is a ref,
2410      * don't expand it to a glob. This is an optimization so that things
2411      * copying constants over, like Exporter, don't have to be rewritten
2412      * to take into account that you can store more than just globs in
2413      * stashes.
2414      */
2415     else if (no_expand && SvROK(gv)) {
2416         assert(!addmg);
2417         return gv;
2418     }
2419
2420     /* Adding a new symbol.
2421        Unless of course there was already something non-GV here, in which case
2422        we want to behave as if there was always a GV here, containing some sort
2423        of subroutine.
2424        Otherwise we run the risk of creating things like GvIO, which can cause
2425        subtle bugs. eg the one that tripped up SQL::Translator  */
2426
2427     faking_it = SvOK(gv);
2428
2429     if (add & GV_ADDWARN)
2430         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2431                 "Had to create %" UTF8f " unexpectedly",
2432                  UTF8fARG(is_utf8, name_end-nambeg, nambeg));
2433     gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
2434
2435     if (   full_len != 0
2436         && isIDFIRST_lazy_if_safe(name, name + full_len, is_utf8)
2437         && !ckWARN(WARN_ONCE) )
2438     {
2439         GvMULTI_on(gv) ;
2440     }
2441
2442     /* set up magic where warranted */
2443     if ( gv_magicalize(gv, stash, name, len, sv_type) ) {
2444         /* See 23496c6 */
2445         if (addmg) {
2446                 /* gv_magicalize magicalised this gv, so we want it
2447                  * stored in the symtab.
2448                  * Effectively the caller is asking, ‘Does this gv exist?’ 
2449                  * And we respond, ‘Er, *now* it does!’
2450                  */
2451                 (void)hv_store(stash,name,len,(SV *)gv,0);
2452         }
2453     }
2454     else if (addmg) {
2455                 /* The temporary GV created above */
2456                 SvREFCNT_dec_NN(gv);
2457                 gv = NULL;
2458     }
2459     
2460     if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
2461     return gv;
2462 }
2463
2464 void
2465 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2466 {
2467     const char *name;
2468     const HV * const hv = GvSTASH(gv);
2469
2470     PERL_ARGS_ASSERT_GV_FULLNAME4;
2471
2472     sv_setpv(sv, prefix ? prefix : "");
2473
2474     if (hv && (name = HvNAME(hv))) {
2475       const STRLEN len = HvNAMELEN(hv);
2476       if (keepmain || strnNE(name, "main", len)) {
2477         sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
2478         sv_catpvs(sv,"::");
2479       }
2480     }
2481     else sv_catpvs(sv,"__ANON__::");
2482     sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2483 }
2484
2485 void
2486 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2487 {
2488     const GV * const egv = GvEGVx(gv);
2489
2490     PERL_ARGS_ASSERT_GV_EFULLNAME4;
2491
2492     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2493 }
2494
2495
2496 /* recursively scan a stash and any nested stashes looking for entries
2497  * that need the "only used once" warning raised
2498  */
2499
2500 void
2501 Perl_gv_check(pTHX_ HV *stash)
2502 {
2503     I32 i;
2504
2505     PERL_ARGS_ASSERT_GV_CHECK;
2506
2507     if (!SvOOK(stash))
2508         return;
2509
2510     assert(HvARRAY(stash));
2511
2512     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2513         const HE *entry;
2514         /* mark stash is being scanned, to avoid recursing */
2515         HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH;
2516         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2517             GV *gv;
2518             HV *hv;
2519             STRLEN keylen = HeKLEN(entry);
2520             const char * const key = HeKEY(entry);
2521
2522             if (keylen >= 2 && key[keylen-2] == ':'  && key[keylen-1] == ':' &&
2523                 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2524             {
2525                 if (hv != PL_defstash && hv != stash
2526                     && !(SvOOK(hv)
2527                         && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH))
2528                 )
2529                      gv_check(hv);              /* nested package */
2530             }
2531             else if (   HeKLEN(entry) != 0
2532                      && *HeKEY(entry) != '_'
2533                      && isIDFIRST_lazy_if_safe(HeKEY(entry),
2534                                                HeKEY(entry) + HeKLEN(entry),
2535                                                HeUTF8(entry)) )
2536             {
2537                 const char *file;
2538                 gv = MUTABLE_GV(HeVAL(entry));
2539                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2540                     continue;
2541                 file = GvFILE(gv);
2542                 CopLINE_set(PL_curcop, GvLINE(gv));
2543 #ifdef USE_ITHREADS
2544                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
2545 #else
2546                 CopFILEGV(PL_curcop)
2547                     = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2548 #endif
2549                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2550                         "Name \"%" HEKf "::%" HEKf
2551                         "\" used only once: possible typo",
2552                             HEKfARG(HvNAME_HEK(stash)),
2553                             HEKfARG(GvNAME_HEK(gv)));
2554             }
2555         }
2556         HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH;
2557     }
2558 }
2559
2560 GV *
2561 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2562 {
2563     PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2564     assert(!(flags & ~SVf_UTF8));
2565
2566     return gv_fetchpv(Perl_form(aTHX_ "%" UTF8f "::_GEN_%ld",
2567                                 UTF8fARG(flags, strlen(pack), pack),
2568                                 (long)PL_gensym++),
2569                       GV_ADD, SVt_PVGV);
2570 }
2571
2572 /* hopefully this is only called on local symbol table entries */
2573
2574 GP*
2575 Perl_gp_ref(pTHX_ GP *gp)
2576 {
2577     if (!gp)
2578         return NULL;
2579     gp->gp_refcnt++;
2580     if (gp->gp_cv) {
2581         if (gp->gp_cvgen) {
2582             /* If the GP they asked for a reference to contains
2583                a method cache entry, clear it first, so that we
2584                don't infect them with our cached entry */
2585             SvREFCNT_dec_NN(gp->gp_cv);
2586             gp->gp_cv = NULL;
2587             gp->gp_cvgen = 0;
2588         }
2589     }
2590     return gp;
2591 }
2592
2593 void
2594 Perl_gp_free(pTHX_ GV *gv)
2595 {
2596     GP* gp;
2597     int attempts = 100;
2598
2599     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2600         return;
2601     if (gp->gp_refcnt == 0) {
2602         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2603                          "Attempt to free unreferenced glob pointers"
2604                          pTHX__FORMAT pTHX__VALUE);
2605         return;
2606     }
2607     if (gp->gp_refcnt > 1) {
2608        borrowed:
2609         if (gp->gp_egv == gv)
2610             gp->gp_egv = 0;
2611         gp->gp_refcnt--;
2612         GvGP_set(gv, NULL);
2613         return;
2614     }
2615
2616     while (1) {
2617       /* Copy and null out all the glob slots, so destructors do not see
2618          freed SVs. */
2619       HEK * const file_hek = gp->gp_file_hek;
2620       SV  * const sv       = gp->gp_sv;
2621       AV  * const av       = gp->gp_av;
2622       HV  * const hv       = gp->gp_hv;
2623       IO  * const io       = gp->gp_io;
2624       CV  * const cv       = gp->gp_cv;
2625       CV  * const form     = gp->gp_form;
2626
2627       gp->gp_file_hek = NULL;
2628       gp->gp_sv       = NULL;
2629       gp->gp_av       = NULL;
2630       gp->gp_hv       = NULL;
2631       gp->gp_io       = NULL;
2632       gp->gp_cv       = NULL;
2633       gp->gp_form     = NULL;
2634
2635       if (file_hek)
2636         unshare_hek(file_hek);
2637
2638       SvREFCNT_dec(sv);
2639       SvREFCNT_dec(av);
2640       /* FIXME - another reference loop GV -> symtab -> GV ?
2641          Somehow gp->gp_hv can end up pointing at freed garbage.  */
2642       if (hv && SvTYPE(hv) == SVt_PVHV) {
2643         const HEK *hvname_hek = HvNAME_HEK(hv);
2644         if (PL_stashcache && hvname_hek) {
2645            DEBUG_o(Perl_deb(aTHX_
2646                           "gp_free clearing PL_stashcache for '%" HEKf "'\n",
2647                            HEKfARG(hvname_hek)));
2648            (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
2649         }
2650         SvREFCNT_dec(hv);
2651       }
2652       if (io && SvREFCNT(io) == 1 && IoIFP(io)
2653              && (IoTYPE(io) == IoTYPE_WRONLY ||
2654                  IoTYPE(io) == IoTYPE_RDWR   ||
2655                  IoTYPE(io) == IoTYPE_APPEND)
2656              && ckWARN_d(WARN_IO)
2657              && IoIFP(io) != PerlIO_stdin()
2658              && IoIFP(io) != PerlIO_stdout()
2659              && IoIFP(io) != PerlIO_stderr()
2660              && !(IoFLAGS(io) & IOf_FAKE_DIRP))
2661         io_close(io, gv, FALSE, TRUE);
2662       SvREFCNT_dec(io);
2663       SvREFCNT_dec(cv);
2664       SvREFCNT_dec(form);
2665
2666       /* Possibly reallocated by a destructor */
2667       gp = GvGP(gv);
2668
2669       if (!gp->gp_file_hek
2670        && !gp->gp_sv
2671        && !gp->gp_av
2672        && !gp->gp_hv
2673        && !gp->gp_io
2674        && !gp->gp_cv
2675        && !gp->gp_form) break;
2676
2677       if (--attempts == 0) {
2678         Perl_die(aTHX_
2679           "panic: gp_free failed to free glob pointer - "
2680           "something is repeatedly re-creating entries"
2681         );
2682       }
2683     }
2684
2685     /* Possibly incremented by a destructor doing glob assignment */
2686     if (gp->gp_refcnt > 1) goto borrowed;
2687     Safefree(gp);
2688     GvGP_set(gv, NULL);
2689 }
2690
2691 int
2692 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2693 {
2694     AMT * const amtp = (AMT*)mg->mg_ptr;
2695     PERL_UNUSED_ARG(sv);
2696
2697     PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2698
2699     if (amtp && AMT_AMAGIC(amtp)) {
2700         int i;
2701         for (i = 1; i < NofAMmeth; i++) {
2702             CV * const cv = amtp->table[i];
2703             if (cv) {
2704                 SvREFCNT_dec_NN(MUTABLE_SV(cv));
2705                 amtp->table[i] = NULL;
2706             }
2707         }
2708     }
2709  return 0;
2710 }
2711
2712 /* Updates and caches the CV's */
2713 /* Returns:
2714  * 1 on success and there is some overload
2715  * 0 if there is no overload
2716  * -1 if some error occurred and it couldn't croak
2717  */
2718
2719 int
2720 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2721 {
2722   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2723   AMT amt;
2724   const struct mro_meta* stash_meta = HvMROMETA(stash);
2725   U32 newgen;
2726
2727   PERL_ARGS_ASSERT_GV_AMUPDATE;
2728
2729   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2730   if (mg) {
2731       const AMT * const amtp = (AMT*)mg->mg_ptr;
2732       if (amtp->was_ok_sub == newgen) {
2733           return AMT_AMAGIC(amtp) ? 1 : 0;
2734       }
2735       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2736   }
2737
2738   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2739
2740   Zero(&amt,1,AMT);
2741   amt.was_ok_sub = newgen;
2742   amt.fallback = AMGfallNO;
2743   amt.flags = 0;
2744
2745   {
2746     int filled = 0;
2747     int i;
2748     bool deref_seen = 0;
2749
2750
2751     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2752
2753     /* Try to find via inheritance. */
2754     GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2755     SV * const sv = gv ? GvSV(gv) : NULL;
2756     CV* cv;
2757
2758     if (!gv)
2759     {
2760       if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
2761         goto no_table;
2762     }
2763 #ifdef PERL_DONT_CREATE_GVSV
2764     else if (!sv) {
2765         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
2766     }
2767 #endif
2768     else if (SvTRUE(sv))
2769         /* don't need to set overloading here because fallback => 1
2770          * is the default setting for classes without overloading */
2771         amt.fallback=AMGfallYES;
2772     else if (SvOK(sv)) {
2773         amt.fallback=AMGfallNEVER;
2774         filled = 1;
2775     }
2776     else {
2777         filled = 1;
2778     }
2779
2780     assert(SvOOK(stash));
2781     /* initially assume the worst */
2782     HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
2783
2784     for (i = 1; i < NofAMmeth; i++) {
2785         const char * const cooky = PL_AMG_names[i];
2786         /* Human-readable form, for debugging: */
2787         const char * const cp = AMG_id2name(i);
2788         const STRLEN l = PL_AMG_namelens[i];
2789
2790         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2791                      cp, HvNAME_get(stash)) );
2792         /* don't fill the cache while looking up!
2793            Creation of inheritance stubs in intermediate packages may
2794            conflict with the logic of runtime method substitution.
2795            Indeed, for inheritance A -> B -> C, if C overloads "+0",
2796            then we could have created stubs for "(+0" in A and C too.
2797            But if B overloads "bool", we may want to use it for
2798            numifying instead of C's "+0". */
2799         gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2800         cv = 0;
2801         if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) {
2802             const HEK * const gvhek =
2803                 CvNAMED(cv) ? CvNAME_HEK(cv) : GvNAME_HEK(CvGV(cv));
2804             const HEK * const stashek =
2805                 HvNAME_HEK(CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv)));
2806             if (HEK_LEN(gvhek) == 3 && strEQ(HEK_KEY(gvhek), "nil")
2807              && stashek && HEK_LEN(stashek) == 8
2808              && strEQ(HEK_KEY(stashek), "overload")) {
2809                 /* This is a hack to support autoloading..., while
2810                    knowing *which* methods were declared as overloaded. */
2811                 /* GvSV contains the name of the method. */
2812                 GV *ngv = NULL;
2813                 SV *gvsv = GvSV(gv);
2814
2815                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%" SVf256\
2816                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
2817                              (void*)GvSV(gv), cp, HvNAME(stash)) );
2818                 if (!gvsv || !SvPOK(gvsv)
2819                     || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2820                 {
2821                     /* Can be an import stub (created by "can"). */
2822                     if (destructing) {
2823                         return -1;
2824                     }
2825                     else {
2826                         const SV * const name = (gvsv && SvPOK(gvsv))
2827                                                     ? gvsv
2828                                                     : newSVpvs_flags("???", SVs_TEMP);
2829                         /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
2830                         Perl_croak(aTHX_ "%s method \"%" SVf256
2831                                     "\" overloading \"%s\" "\
2832                                     "in package \"%" HEKf256 "\"",
2833                                    (GvCVGEN(gv) ? "Stub found while resolving"
2834                                     : "Can't resolve"),
2835                                    SVfARG(name), cp,
2836                                    HEKfARG(
2837                                         HvNAME_HEK(stash)
2838                                    ));
2839                     }
2840                 }
2841                 cv = GvCV(gv = ngv);
2842             }
2843             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2844                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2845                          GvNAME(CvGV(cv))) );
2846             filled = 1;
2847         } else if (gv) {                /* Autoloaded... */
2848             cv = MUTABLE_CV(gv);
2849             filled = 1;
2850         }
2851         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2852
2853         if (gv) {
2854             switch (i) {
2855             case to_sv_amg:
2856             case to_av_amg:
2857             case to_hv_amg:
2858             case to_gv_amg:
2859             case to_cv_amg:
2860             case nomethod_amg:
2861                 deref_seen = 1;
2862                 break;
2863             }
2864         }
2865     }
2866     if (!deref_seen)
2867         /* none of @{} etc overloaded; we can do $obj->[N] quicker.
2868          * NB - aux var invalid here, HvARRAY() could have been
2869          * reallocated since it was assigned to */
2870         HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF;
2871
2872     if (filled) {
2873       AMT_AMAGIC_on(&amt);
2874       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2875                                                 (char*)&amt, sizeof(AMT));
2876       return TRUE;
2877     }
2878   }
2879   /* Here we have no table: */
2880  no_table:
2881   AMT_AMAGIC_off(&amt);
2882   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2883                                                 (char*)&amt, sizeof(AMTS));
2884   return 0;
2885 }
2886
2887
2888 CV*
2889 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2890 {
2891     MAGIC *mg;
2892     AMT *amtp;
2893     U32 newgen;
2894     struct mro_meta* stash_meta;
2895
2896     if (!stash || !HvNAME_get(stash))
2897         return NULL;
2898
2899     stash_meta = HvMROMETA(stash);
2900     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2901
2902     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2903     if (!mg) {
2904       do_update:
2905         if (Gv_AMupdate(stash, 0) == -1)
2906             return NULL;
2907         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2908     }
2909     assert(mg);
2910     amtp = (AMT*)mg->mg_ptr;
2911     if ( amtp->was_ok_sub != newgen )
2912         goto do_update;
2913     if (AMT_AMAGIC(amtp)) {
2914         CV * const ret = amtp->table[id];
2915         if (ret && isGV(ret)) {         /* Autoloading stab */
2916             /* Passing it through may have resulted in a warning
2917                "Inherited AUTOLOAD for a non-method deprecated", since
2918                our caller is going through a function call, not a method call.
2919                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2920             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2921
2922             if (gv && GvCV(gv))
2923                 return GvCV(gv);
2924         }
2925         return ret;
2926     }
2927
2928     return NULL;
2929 }
2930
2931
2932 /* Implement tryAMAGICun_MG macro.
2933    Do get magic, then see if the stack arg is overloaded and if so call it.
2934    Flags:
2935         AMGf_set     return the arg using SETs rather than assigning to
2936                      the targ
2937         AMGf_numeric apply sv_2num to the stack arg.
2938 */
2939
2940 bool
2941 Perl_try_amagic_un(pTHX_ int method, int flags) {
2942     dSP;
2943     SV* tmpsv;
2944     SV* const arg = TOPs;
2945
2946     SvGETMAGIC(arg);
2947
2948     if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2949                                               AMGf_noright | AMGf_unary
2950                                             | (flags & AMGf_numarg))))
2951     {
2952         if (flags & AMGf_set) {
2953             SETs(tmpsv);
2954         }
2955         else {
2956             dTARGET;
2957             if (SvPADMY(TARG)) {
2958                 sv_setsv(TARG, tmpsv);
2959                 SETTARG;
2960             }
2961             else
2962                 SETs(tmpsv);
2963         }
2964         PUTBACK;
2965         return TRUE;
2966     }
2967
2968     if ((flags & AMGf_numeric) && SvROK(arg))
2969         *sp = sv_2num(arg);
2970     return FALSE;
2971 }
2972
2973
2974 /* Implement tryAMAGICbin_MG macro.
2975    Do get magic, then see if the two stack args are overloaded and if so
2976    call it.
2977    Flags:
2978         AMGf_set     return the arg using SETs rather than assigning to
2979                      the targ
2980         AMGf_assign  op may be called as mutator (eg +=)
2981         AMGf_numeric apply sv_2num to the stack arg.
2982 */
2983
2984 bool
2985 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2986     dSP;
2987     SV* const left = TOPm1s;
2988     SV* const right = TOPs;
2989
2990     SvGETMAGIC(left);
2991     if (left != right)
2992         SvGETMAGIC(right);
2993
2994     if (SvAMAGIC(left) || SvAMAGIC(right)) {
2995         SV * const tmpsv = amagic_call(left, right, method,
2996                     ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0)
2997                   | (flags & AMGf_numarg));
2998         if (tmpsv) {
2999             if (flags & AMGf_set) {
3000                 (void)POPs;
3001                 SETs(tmpsv);
3002             }
3003             else {
3004                 dATARGET;
3005                 (void)POPs;
3006                 if (opASSIGN || SvPADMY(TARG)) {
3007                     sv_setsv(TARG, tmpsv);
3008                     SETTARG;
3009                 }
3010                 else
3011                     SETs(tmpsv);
3012             }
3013             PUTBACK;
3014             return TRUE;
3015         }
3016     }
3017     if(left==right && SvGMAGICAL(left)) {
3018         SV * const left = sv_newmortal();
3019         *(sp-1) = left;
3020         /* Print the uninitialized warning now, so it includes the vari-
3021            able name. */
3022         if (!SvOK(right)) {
3023             if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
3024             sv_setsv_flags(left, &PL_sv_no, 0);
3025         }
3026         else sv_setsv_flags(left, right, 0);
3027         SvGETMAGIC(right);
3028     }
3029     if (flags & AMGf_numeric) {
3030         if (SvROK(TOPm1s))
3031             *(sp-1) = sv_2num(TOPm1s);
3032         if (SvROK(right))
3033             *sp     = sv_2num(right);
3034     }
3035     return FALSE;
3036 }
3037
3038 SV *
3039 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
3040     SV *tmpsv = NULL;
3041     HV *stash;
3042
3043     PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
3044
3045     if (!SvAMAGIC(ref))
3046         return ref;
3047     /* return quickly if none of the deref ops are overloaded */
3048     stash = SvSTASH(SvRV(ref));
3049     assert(SvOOK(stash));
3050     if (HvAUX(stash)->xhv_aux_flags & HvAUXf_NO_DEREF)
3051         return ref;
3052
3053     while ((tmpsv = amagic_call(ref, &PL_sv_undef, method,
3054                                 AMGf_noright | AMGf_unary))) { 
3055         if (!SvROK(tmpsv))
3056             Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
3057         if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
3058             /* Bail out if it returns us the same reference.  */
3059             return tmpsv;
3060         }
3061         ref = tmpsv;
3062         if (!SvAMAGIC(ref))
3063             break;
3064     }
3065     return tmpsv ? tmpsv : ref;
3066 }
3067
3068 bool
3069 Perl_amagic_is_enabled(pTHX_ int method)
3070 {
3071       SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
3072
3073       assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
3074
3075       if ( !lex_mask || !SvOK(lex_mask) )
3076           /* overloading lexically disabled */
3077           return FALSE;
3078       else if ( lex_mask && SvPOK(lex_mask) ) {
3079           /* we have an entry in the hints hash, check if method has been
3080            * masked by overloading.pm */
3081           STRLEN len;
3082           const int offset = method / 8;
3083           const int bit    = method % 8;
3084           char *pv = SvPV(lex_mask, len);
3085
3086           /* Bit set, so this overloading operator is disabled */
3087           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
3088               return FALSE;
3089       }
3090       return TRUE;
3091 }
3092
3093 SV*
3094 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
3095 {
3096   dVAR;
3097   MAGIC *mg;
3098   CV *cv=NULL;
3099   CV **cvp=NULL, **ocvp=NULL;
3100   AMT *amtp=NULL, *oamtp=NULL;
3101   int off = 0, off1, lr = 0, notfound = 0;
3102   int postpr = 0, force_cpy = 0;
3103   int assign = AMGf_assign & flags;
3104   const int assignshift = assign ? 1 : 0;
3105   int use_default_op = 0;
3106   int force_scalar = 0;
3107 #ifdef DEBUGGING
3108   int fl=0;
3109 #endif
3110   HV* stash=NULL;
3111
3112   PERL_ARGS_ASSERT_AMAGIC_CALL;
3113
3114   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
3115       if (!amagic_is_enabled(method)) return NULL;
3116   }
3117
3118   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
3119       && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
3120       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3121       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3122                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
3123                         : NULL))
3124       && ((cv = cvp[off=method+assignshift])
3125           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
3126                                                           * usual method */
3127                   (
3128 #ifdef DEBUGGING
3129                    fl = 1,
3130 #endif
3131                    cv = cvp[off=method])))) {
3132     lr = -1;                    /* Call method for left argument */
3133   } else {
3134     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
3135       int logic;
3136
3137       /* look for substituted methods */
3138       /* In all the covered cases we should be called with assign==0. */
3139          switch (method) {
3140          case inc_amg:
3141            force_cpy = 1;
3142            if ((cv = cvp[off=add_ass_amg])
3143                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3144              right = &PL_sv_yes; lr = -1; assign = 1;
3145            }
3146            break;
3147          case dec_amg:
3148            force_cpy = 1;
3149            if ((cv = cvp[off = subtr_ass_amg])
3150                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3151              right = &PL_sv_yes; lr = -1; assign = 1;
3152            }
3153            break;
3154          case bool__amg:
3155            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
3156            break;
3157          case numer_amg:
3158            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
3159            break;
3160          case string_amg:
3161            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
3162            break;
3163          case not_amg:
3164            (void)((cv = cvp[off=bool__amg])
3165                   || (cv = cvp[off=numer_amg])
3166                   || (cv = cvp[off=string_amg]));
3167            if (cv)
3168                postpr = 1;
3169            break;
3170          case copy_amg:
3171            {
3172              /*
3173                   * SV* ref causes confusion with the interpreter variable of
3174                   * the same name
3175                   */
3176              SV* const tmpRef=SvRV(left);
3177              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
3178                 /*
3179                  * Just to be extra cautious.  Maybe in some
3180                  * additional cases sv_setsv is safe, too.
3181                  */
3182                 SV* const newref = newSVsv(tmpRef);
3183                 SvOBJECT_on(newref);
3184                 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
3185                    delegate to the stash. */
3186                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
3187                 return newref;
3188              }
3189            }
3190            break;
3191          case abs_amg:
3192            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
3193                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
3194              SV* const nullsv=&PL_sv_zero;
3195              if (off1==lt_amg) {
3196                SV* const lessp = amagic_call(left,nullsv,
3197                                        lt_amg,AMGf_noright);
3198                logic = SvTRUE_NN(lessp);
3199              } else {
3200                SV* const lessp = amagic_call(left,nullsv,
3201                                        ncmp_amg,AMGf_noright);
3202                logic = (SvNV(lessp) < 0);
3203              }
3204              if (logic) {
3205                if (off==subtr_amg) {
3206                  right = left;
3207                  left = nullsv;
3208                  lr = 1;
3209                }
3210              } else {
3211                return left;
3212              }
3213            }
3214            break;
3215          case neg_amg:
3216            if ((cv = cvp[off=subtr_amg])) {
3217              right = left;
3218              left = &PL_sv_zero;
3219              lr = 1;
3220            }
3221            break;
3222          case int_amg:
3223          case iter_amg:                 /* XXXX Eventually should do to_gv. */
3224          case ftest_amg:                /* XXXX Eventually should do to_gv. */
3225          case regexp_amg:
3226              /* FAIL safe */
3227              return NULL;       /* Delegate operation to standard mechanisms. */
3228
3229          case to_sv_amg:
3230          case to_av_amg:
3231          case to_hv_amg:
3232          case to_gv_amg:
3233          case to_cv_amg:
3234              /* FAIL safe */
3235              return left;       /* Delegate operation to standard mechanisms. */
3236
3237          default:
3238            goto not_found;
3239          }
3240          if (!cv) goto not_found;
3241     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
3242                && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
3243                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3244                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3245                           ? (amtp = (AMT*)mg->mg_ptr)->table
3246                           : NULL))
3247                && (cv = cvp[off=method])) { /* Method for right
3248                                              * argument found */
3249       lr=1;
3250     } else if (((cvp && amtp->fallback > AMGfallNEVER)
3251                 || (ocvp && oamtp->fallback > AMGfallNEVER))
3252                && !(flags & AMGf_unary)) {
3253                                 /* We look for substitution for
3254                                  * comparison operations and
3255                                  * concatenation */
3256       if (method==concat_amg || method==concat_ass_amg
3257           || method==repeat_amg || method==repeat_ass_amg) {
3258         return NULL;            /* Delegate operation to string conversion */
3259       }
3260       off = -1;
3261       switch (method) {
3262          case lt_amg:
3263          case le_amg:
3264          case gt_amg:
3265          case ge_amg:
3266          case eq_amg:
3267          case ne_amg:
3268              off = ncmp_amg;
3269              break;
3270          case slt_amg:
3271          case sle_amg:
3272          case sgt_amg:
3273          case sge_amg:
3274          case seq_amg:
3275          case sne_amg:
3276              off = scmp_amg;
3277              break;
3278          }
3279       if (off != -1) {
3280           if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
3281               cv = ocvp[off];
3282               lr = -1;
3283           }
3284           if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
3285               cv = cvp[off];
3286               lr = 1;
3287           }
3288       }
3289       if (cv)
3290           postpr = 1;
3291       else
3292           goto not_found;
3293     } else {
3294     not_found:                  /* No method found, either report or croak */
3295       switch (method) {
3296          case to_sv_amg:
3297          case to_av_amg:
3298          case to_hv_amg:
3299          case to_gv_amg:
3300          case to_cv_amg:
3301              /* FAIL safe */
3302              return left;       /* Delegate operation to standard mechanisms. */
3303       }
3304       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
3305         notfound = 1; lr = -1;
3306       } else if (cvp && (cv=cvp[nomethod_amg])) {
3307         notfound = 1; lr = 1;
3308       } else if ((use_default_op =
3309                   (!ocvp || oamtp->fallback >= AMGfallYES)
3310                   && (!cvp || amtp->fallback >= AMGfallYES))
3311                  && !DEBUG_o_TEST) {
3312         /* Skip generating the "no method found" message.  */
3313         return NULL;
3314       } else {
3315         SV *msg;
3316         if (off==-1) off=method;
3317         msg = sv_2mortal(Perl_newSVpvf(aTHX_
3318                       "Operation \"%s\": no method found,%sargument %s%" SVf "%s%" SVf,
3319                       AMG_id2name(method + assignshift),
3320                       (flags & AMGf_unary ? " " : "\n\tleft "),
3321                       SvAMAGIC(left)?
3322                         "in overloaded package ":
3323                         "has no overloaded magic",
3324                       SvAMAGIC(left)?
3325                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
3326                         SVfARG(&PL_sv_no),
3327                       SvAMAGIC(right)?
3328                         ",\n\tright argument in overloaded package ":
3329                         (flags & AMGf_unary
3330                          ? ""
3331                          : ",\n\tright argument has no overloaded magic"),
3332                       SvAMAGIC(right)?
3333                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
3334                         SVfARG(&PL_sv_no)));
3335         if (use_default_op) {
3336           DEBUG_o( Perl_deb(aTHX_ "%" SVf, SVfARG(msg)) );
3337         } else {
3338           Perl_croak(aTHX_ "%" SVf, SVfARG(msg));
3339         }
3340         return NULL;
3341       }
3342       force_cpy = force_cpy || assign;
3343     }
3344   }
3345
3346   switch (method) {
3347     /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
3348      * operation. we need this to return a value, so that it can be assigned
3349      * later on, in the postpr block (case inc_amg/dec_amg), even if the
3350      * increment or decrement was itself called in void context */
3351     case inc_amg:
3352       if (off == add_amg)
3353         force_scalar = 1;
3354       break;
3355     case dec_amg:
3356       if (off == subtr_amg)
3357         force_scalar = 1;
3358       break;
3359     /* in these cases, we're calling an assignment variant of an operator
3360      * (+= rather than +, for instance). regardless of whether it's a
3361      * fallback or not, it always has to return a value, which will be
3362      * assigned to the proper variable later */
3363     case add_amg:
3364     case subtr_amg:
3365     case mult_amg:
3366     case div_amg:
3367     case modulo_amg:
3368     case pow_amg:
3369     case lshift_amg:
3370     case rshift_amg:
3371     case repeat_amg:
3372     case concat_amg:
3373     case band_amg:
3374     case bor_amg:
3375     case bxor_amg:
3376     case sband_amg:
3377     case sbor_amg:
3378     case sbxor_amg:
3379       if (assign)
3380         force_scalar = 1;
3381       break;
3382     /* the copy constructor always needs to return a value */
3383     case copy_amg:
3384       force_scalar = 1;
3385       break;
3386     /* because of the way these are implemented (they don't perform the
3387      * dereferencing themselves, they return a reference that perl then
3388      * dereferences later), they always have to be in scalar context */
3389     case to_sv_amg:
3390     case to_av_amg:
3391     case to_hv_amg:
3392     case to_gv_amg:
3393     case to_cv_amg:
3394       force_scalar = 1;
3395       break;
3396     /* these don't have an op of their own; they're triggered by their parent
3397      * op, so the context there isn't meaningful ('$a and foo()' in void
3398      * context still needs to pass scalar context on to $a's bool overload) */
3399     case bool__amg:
3400     case numer_amg:
3401     case string_amg:
3402       force_scalar = 1;
3403       break;
3404   }
3405
3406 #ifdef DEBUGGING
3407   if (!notfound) {
3408     DEBUG_o(Perl_deb(aTHX_
3409                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %" SVf "%s\n",
3410                      AMG_id2name(off),
3411                      method+assignshift==off? "" :
3412                      " (initially \"",
3413                      method+assignshift==off? "" :
3414                      AMG_id2name(method+assignshift),
3415                      method+assignshift==off? "" : "\")",
3416                      flags & AMGf_unary? "" :
3417                      lr==1 ? " for right argument": " for left argument",
3418                      flags & AMGf_unary? " for argument" : "",
3419                      stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
3420                      fl? ",\n\tassignment variant used": "") );
3421   }
3422 #endif
3423     /* Since we use shallow copy during assignment, we need
3424      * to dublicate the contents, probably calling user-supplied
3425      * version of copy operator
3426      */
3427     /* We need to copy in following cases:
3428      * a) Assignment form was called.
3429      *          assignshift==1,  assign==T, method + 1 == off
3430      * b) Increment or decrement, called directly.
3431      *          assignshift==0,  assign==0, method + 0 == off
3432      * c) Increment or decrement, translated to assignment add/subtr.
3433      *          assignshift==0,  assign==T,
3434      *          force_cpy == T
3435      * d) Increment or decrement, translated to nomethod.
3436      *          assignshift==0,  assign==0,
3437      *          force_cpy == T
3438      * e) Assignment form translated to nomethod.
3439      *          assignshift==1,  assign==T, method + 1 != off
3440      *          force_cpy == T
3441      */
3442     /*  off is method, method+assignshift, or a result of opcode substitution.
3443      *  In the latter case assignshift==0, so only notfound case is important.
3444      */
3445   if ( (lr == -1) && ( ( (method + assignshift == off)
3446         && (assign || (method == inc_amg) || (method == dec_amg)))
3447       || force_cpy) )
3448   {
3449       /* newSVsv does not behave as advertised, so we copy missing
3450        * information by hand */
3451       SV *tmpRef = SvRV(left);
3452       SV *rv_copy;
3453       if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
3454           SvRV_set(left, rv_copy);
3455           SvSETMAGIC(left);
3456           SvREFCNT_dec_NN(tmpRef);  
3457       }
3458   }
3459
3460   {
3461     dSP;
3462     BINOP myop;
3463     SV* res;
3464     const bool oldcatch = CATCH_GET;
3465     I32 oldmark, nret;
3466     U8 gimme = force_scalar ? G_SCALAR : GIMME_V;
3467
3468     CATCH_SET(TRUE);
3469     Zero(&myop, 1, BINOP);
3470     myop.op_last = (OP *) &myop;
3471     myop.op_next = NULL;
3472     myop.op_flags = OPf_STACKED;
3473
3474     switch (gimme) {
3475         case G_VOID:
3476             myop.op_flags |= OPf_WANT_VOID;
3477             break;
3478         case G_ARRAY:
3479             if (flags & AMGf_want_list) {
3480                 myop.op_flags |= OPf_WANT_LIST;
3481                 break;
3482             }
3483             /* FALLTHROUGH */
3484         default:
3485             myop.op_flags |= OPf_WANT_SCALAR;
3486             break;
3487     }
3488
3489     PUSHSTACKi(PERLSI_OVERLOAD);
3490     ENTER;
3491     SAVEOP();
3492     PL_op = (OP *) &myop;
3493     if (PERLDB_SUB && PL_curstash != PL_debstash)
3494         PL_op->op_private |= OPpENTERSUB_DB;
3495     Perl_pp_pushmark(aTHX);
3496
3497     EXTEND(SP, notfound + 5);
3498     PUSHs(lr>0? right: left);
3499     PUSHs(lr>0? left: right);
3500     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
3501     if (notfound) {
3502       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3503                            AMG_id2namelen(method + assignshift), SVs_TEMP));
3504     }
3505     else if (flags & AMGf_numarg)
3506       PUSHs(&PL_sv_undef);
3507     if (flags & AMGf_numarg)
3508       PUSHs(&PL_sv_yes);
3509     PUSHs(MUTABLE_SV(cv));
3510     PUTBACK;
3511     oldmark = TOPMARK;
3512
3513     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3514       CALLRUNOPS(aTHX);
3515     LEAVE;
3516     SPAGAIN;
3517     nret = SP - (PL_stack_base + oldmark);
3518
3519     switch (gimme) {
3520         case G_VOID:
3521             /* returning NULL has another meaning, and we check the context
3522              * at the call site too, so this can be differentiated from the
3523              * scalar case */
3524             res = &PL_sv_undef;
3525             SP = PL_stack_base + oldmark;
3526             break;
3527         case G_ARRAY: {
3528             if (flags & AMGf_want_list) {
3529                 res = sv_2mortal((SV *)newAV());
3530                 av_extend((AV *)res, nret);
3531                 while (nret--)
3532                     av_store((AV *)res, nret, POPs);
3533                 break;
3534             }
3535             /* FALLTHROUGH */
3536         }
3537         default:
3538             res = POPs;
3539             break;
3540     }
3541
3542     PUTBACK;
3543     POPSTACK;
3544     CATCH_SET(oldcatch);
3545
3546     if (postpr) {
3547       int ans;
3548       switch (method) {
3549       case le_amg:
3550       case sle_amg:
3551         ans=SvIV(res)<=0; break;
3552       case lt_amg:
3553       case slt_amg:
3554         ans=SvIV(res)<0; break;
3555       case ge_amg:
3556       case sge_amg:
3557         ans=SvIV(res)>=0; break;
3558       case gt_amg:
3559       case sgt_amg:
3560         ans=SvIV(res)>0; break;
3561       case eq_amg:
3562       case seq_amg:
3563         ans=SvIV(res)==0; break;
3564       case ne_amg:
3565       case sne_amg:
3566         ans=SvIV(res)!=0; break;
3567       case inc_amg:
3568       case dec_amg:
3569         SvSetSV(left,res); return left;
3570       case not_amg:
3571         ans=!SvTRUE_NN(res); break;
3572       default:
3573         ans=0; break;
3574       }
3575       return boolSV(ans);
3576     } else if (method==copy_amg) {
3577       if (!SvROK(res)) {
3578         Perl_croak(aTHX_ "Copy method did not return a reference");
3579       }
3580       return SvREFCNT_inc(SvRV(res));
3581     } else {
3582       return res;
3583     }
3584   }
3585 }
3586
3587 void
3588 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3589 {
3590     dVAR;
3591     U32 hash;
3592
3593     PERL_ARGS_ASSERT_GV_NAME_SET;
3594
3595     if (len > I32_MAX)
3596         Perl_croak(aTHX_ "panic: gv name too long (%" UVuf ")", (UV) len);
3597
3598     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3599         unshare_hek(GvNAME_HEK(gv));
3600     }
3601
3602     PERL_HASH(hash, name, len);
3603     GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3604 }
3605
3606 /*
3607 =for apidoc gv_try_downgrade
3608
3609 If the typeglob C<gv> can be expressed more succinctly, by having
3610 something other than a real GV in its place in the stash, replace it
3611 with the optimised form.  Basic requirements for this are that C<gv>
3612 is a real typeglob, is sufficiently ordinary, and is only referenced
3613 from its package.  This function is meant to be used when a GV has been
3614 looked up in part to see what was there, causing upgrading, but based
3615 on what was found it turns out that the real GV isn't required after all.
3616
3617 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3618
3619 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3620 sub, the typeglob is replaced with a scalar-reference placeholder that
3621 more compactly represents the same thing.
3622
3623 =cut
3624 */
3625
3626 void
3627 Perl_gv_try_downgrade(pTHX_ GV *gv)
3628 {
3629     HV *stash;
3630     CV *cv;
3631     HEK *namehek;
3632     SV **gvp;
3633     PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3634
3635     /* XXX Why and where does this leave dangling pointers during global
3636        destruction? */
3637     if (PL_phase == PERL_PHASE_DESTRUCT) return;
3638
3639     if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3640             !SvOBJECT(gv) && !SvREADONLY(gv) &&
3641             isGV_with_GP(gv) && GvGP(gv) &&
3642             !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3643             !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3644             GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3645         return;
3646     if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv)
3647         return;
3648     if (SvMAGICAL(gv)) {
3649         MAGIC *mg;
3650         /* only backref magic is allowed */
3651         if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3652             return;
3653         for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3654             if (mg->mg_type != PERL_MAGIC_backref)
3655                 return;
3656         }
3657     }
3658     cv = GvCV(gv);
3659     if (!cv) {
3660         HEK *gvnhek = GvNAME_HEK(gv);
3661         (void)hv_deletehek(stash, gvnhek, G_DISCARD);
3662     } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 &&
3663             !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3664             CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv &&
3665             CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3666             !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3667             (namehek = GvNAME_HEK(gv)) &&
3668             (gvp = hv_fetchhek(stash, namehek, 0)) &&
3669             *gvp == (SV*)gv) {
3670         SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3671         const bool imported = !!GvIMPORTED_CV(gv);
3672         SvREFCNT(gv) = 0;
3673         sv_clear((SV*)gv);
3674         SvREFCNT(gv) = 1;
3675         SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
3676
3677         /* See also: 'SET_SVANY_FOR_BODYLESS_IV' in sv.c */
3678         SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3679                                 STRUCT_OFFSET(XPVIV, xiv_iv));
3680         SvRV_set(gv, value);
3681     }
3682 }
3683
3684 GV *
3685 Perl_gv_override(pTHX_ const char * const name, const STRLEN len)
3686 {
3687     GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV);
3688     GV * const *gvp;
3689     PERL_ARGS_ASSERT_GV_OVERRIDE;
3690     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv;
3691     gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE);
3692     gv = gvp ? *gvp : NULL;
3693     if (gv && !isGV(gv)) {
3694         if (!SvPCS_IMPORTED(gv)) return NULL;
3695         gv_init(gv, PL_globalstash, name, len, 0);
3696         return gv;
3697     }
3698     return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL;
3699 }
3700
3701 #include "XSUB.h"
3702
3703 static void
3704 core_xsub(pTHX_ CV* cv)
3705 {
3706     Perl_croak(aTHX_
3707        "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3708     );
3709 }
3710
3711 /*
3712  * ex: set ts=8 sts=4 sw=4 et:
3713  */