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