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