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