narrower localisation of PL_compcv around eval
[perl.git] / gv.c
1 /*    gv.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  *   'Mercy!' cried Gandalf.  'If the giving of information is to be the cure
13  * of your inquisitiveness, I shall spend all the rest of my days in answering
14  * you.  What more do you want to know?'
15  *   'The names of all the stars, and of all living things, and the whole
16  * history of Middle-earth and Over-heaven and of the Sundering Seas,'
17  * laughed Pippin.
18  *
19  *     [p.599 of _The Lord of the Rings_, III/xi: "The Palantír"]
20  */
21
22 /*
23 =head1 GV Functions
24
25 A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
26 It is a structure that holds a pointer to a scalar, an array, a hash etc,
27 corresponding to $foo, @foo, %foo.
28
29 GVs are usually found as values in stashes (symbol table hashes) where
30 Perl stores its global variables.
31
32 =cut
33 */
34
35 #include "EXTERN.h"
36 #define PERL_IN_GV_C
37 #include "perl.h"
38 #include "overload.c"
39 #include "keywords.h"
40
41 static const char S_autoload[] = "AUTOLOAD";
42 static const STRLEN S_autolen = sizeof(S_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             /* diag_listed_as: Bad symbol for filehandle */
65         } else if (type == SVt_PVHV) {
66             what = "hash";
67         } else {
68             what = type == SVt_PVAV ? "array" : "scalar";
69         }
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         *where = newSV_type(type);
85     return gv;
86 }
87
88 GV *
89 Perl_gv_fetchfile(pTHX_ const char *name)
90 {
91     PERL_ARGS_ASSERT_GV_FETCHFILE;
92     return gv_fetchfile_flags(name, strlen(name), 0);
93 }
94
95 GV *
96 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
97                         const U32 flags)
98 {
99     dVAR;
100     char smallbuf[128];
101     char *tmpbuf;
102     const STRLEN tmplen = namelen + 2;
103     GV *gv;
104
105     PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS;
106     PERL_UNUSED_ARG(flags);
107
108     if (!PL_defstash)
109         return NULL;
110
111     if (tmplen <= sizeof smallbuf)
112         tmpbuf = smallbuf;
113     else
114         Newx(tmpbuf, tmplen, char);
115     /* This is where the debugger's %{"::_<$filename"} hash is created */
116     tmpbuf[0] = '_';
117     tmpbuf[1] = '<';
118     memcpy(tmpbuf + 2, name, namelen);
119     gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
120     if (!isGV(gv)) {
121         gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
122 #ifdef PERL_DONT_CREATE_GVSV
123         GvSV(gv) = newSVpvn(name, namelen);
124 #else
125         sv_setpvn(GvSV(gv), name, namelen);
126 #endif
127     }
128     if ((PERLDB_LINE || PERLDB_SAVESRC) && !GvAV(gv))
129             hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile);
130     if (tmpbuf != smallbuf)
131         Safefree(tmpbuf);
132     return gv;
133 }
134
135 /*
136 =for apidoc gv_const_sv
137
138 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
139 inlining, or C<gv> is a placeholder reference that would be promoted to such
140 a typeglob, then returns the value returned by the sub.  Otherwise, returns
141 NULL.
142
143 =cut
144 */
145
146 SV *
147 Perl_gv_const_sv(pTHX_ GV *gv)
148 {
149     PERL_ARGS_ASSERT_GV_CONST_SV;
150
151     if (SvTYPE(gv) == SVt_PVGV)
152         return cv_const_sv(GvCVu(gv));
153     return SvROK(gv) ? SvRV(gv) : NULL;
154 }
155
156 GP *
157 Perl_newGP(pTHX_ GV *const gv)
158 {
159     GP *gp;
160     U32 hash;
161 #ifdef USE_ITHREADS
162     const char *const file
163         = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : "";
164     const STRLEN len = strlen(file);
165 #else
166     SV *const temp_sv = CopFILESV(PL_curcop);
167     const char *file;
168     STRLEN len;
169
170     PERL_ARGS_ASSERT_NEWGP;
171
172     if (temp_sv) {
173         file = SvPVX(temp_sv);
174         len = SvCUR(temp_sv);
175     } else {
176         file = "";
177         len = 0;
178     }
179 #endif
180
181     PERL_HASH(hash, file, len);
182
183     Newxz(gp, 1, GP);
184
185 #ifndef PERL_DONT_CREATE_GVSV
186     gp->gp_sv = newSV(0);
187 #endif
188
189     gp->gp_line = PL_curcop ? CopLINE(PL_curcop) : 0;
190     /* XXX Ideally this cast would be replaced with a change to const char*
191        in the struct.  */
192     gp->gp_file_hek = share_hek(file, len, hash);
193     gp->gp_egv = gv;
194     gp->gp_refcnt = 1;
195
196     return gp;
197 }
198
199 /* Assign CvGV(cv) = gv, handling weak references.
200  * See also S_anonymise_cv_maybe */
201
202 void
203 Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
204 {
205     GV * const oldgv = CvGV(cv);
206     PERL_ARGS_ASSERT_CVGV_SET;
207
208     if (oldgv == gv)
209         return;
210
211     if (oldgv) {
212         if (CvCVGV_RC(cv)) {
213             SvREFCNT_dec(oldgv);
214             CvCVGV_RC_off(cv);
215         }
216         else {
217             sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
218         }
219     }
220
221     SvANY(cv)->xcv_gv = gv;
222     assert(!CvCVGV_RC(cv));
223
224     if (!gv)
225         return;
226
227     if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
228         Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
229     else {
230         CvCVGV_RC_on(cv);
231         SvREFCNT_inc_simple_void_NN(gv);
232     }
233 }
234
235 /* Assign CvSTASH(cv) = st, handling weak references. */
236
237 void
238 Perl_cvstash_set(pTHX_ CV *cv, HV *st)
239 {
240     HV *oldst = CvSTASH(cv);
241     PERL_ARGS_ASSERT_CVSTASH_SET;
242     if (oldst == st)
243         return;
244     if (oldst)
245         sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
246     SvANY(cv)->xcv_stash = st;
247     if (st)
248         Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
249 }
250
251 /*
252 =for apidoc gv_init_pvn
253
254 Converts a scalar into a typeglob.  This is an incoercible typeglob;
255 assigning a reference to it will assign to one of its slots, instead of
256 overwriting it as happens with typeglobs created by SvSetSV.  Converting
257 any scalar that is SvOK() may produce unpredictable results and is reserved
258 for perl's internal use.
259
260 C<gv> is the scalar to be converted.
261
262 C<stash> is the parent stash/package, if any.
263
264 C<name> and C<len> give the name.  The name must be unqualified;
265 that is, it must not include the package name.  If C<gv> is a
266 stash element, it is the caller's responsibility to ensure that the name
267 passed to this function matches the name of the element.  If it does not
268 match, perl's internal bookkeeping will get out of sync.
269
270 C<flags> can be set to SVf_UTF8 if C<name> is a UTF8 string, or
271 the return value of SvUTF8(sv).  It can also take the
272 GV_ADDMULTI flag, which means to pretend that the GV has been
273 seen before (i.e., suppress "Used once" warnings).
274
275 =for apidoc gv_init
276
277 The old form of gv_init_pvn().  It does not work with UTF8 strings, as it
278 has no flags parameter.  If the C<multi> parameter is set, the
279 GV_ADDMULTI flag will be passed to gv_init_pvn().
280
281 =for apidoc gv_init_pv
282
283 Same as gv_init_pvn(), but takes a nul-terminated string for the name
284 instead of separate char * and length parameters.
285
286 =for apidoc gv_init_sv
287
288 Same as gv_init_pvn(), but takes an SV * for the name instead of separate
289 char * and length parameters.  C<flags> is currently unused.
290
291 =cut
292 */
293
294 void
295 Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
296 {
297    char *namepv;
298    STRLEN namelen;
299    PERL_ARGS_ASSERT_GV_INIT_SV;
300    namepv = SvPV(namesv, namelen);
301    if (SvUTF8(namesv))
302        flags |= SVf_UTF8;
303    gv_init_pvn(gv, stash, namepv, namelen, flags);
304 }
305
306 void
307 Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
308 {
309    PERL_ARGS_ASSERT_GV_INIT_PV;
310    gv_init_pvn(gv, stash, name, strlen(name), flags);
311 }
312
313 void
314 Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
315 {
316     dVAR;
317     const U32 old_type = SvTYPE(gv);
318     const bool doproto = old_type > SVt_NULL;
319     char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
320     const STRLEN protolen = proto ? SvCUR(gv) : 0;
321     const U32 proto_utf8  = proto ? SvUTF8(gv) : 0;
322     SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
323     const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
324
325     PERL_ARGS_ASSERT_GV_INIT_PVN;
326     assert (!(proto && has_constant));
327
328     if (has_constant) {
329         /* The constant has to be a simple scalar type.  */
330         switch (SvTYPE(has_constant)) {
331         case SVt_PVAV:
332         case SVt_PVHV:
333         case SVt_PVCV:
334         case SVt_PVFM:
335         case SVt_PVIO:
336             Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
337                        sv_reftype(has_constant, 0));
338         default: NOOP;
339         }
340         SvRV_set(gv, NULL);
341         SvROK_off(gv);
342     }
343
344
345     if (old_type < SVt_PVGV) {
346         if (old_type >= SVt_PV)
347             SvCUR_set(gv, 0);
348         sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
349     }
350     if (SvLEN(gv)) {
351         if (proto) {
352             SvPV_set(gv, NULL);
353             SvLEN_set(gv, 0);
354             SvPOK_off(gv);
355         } else
356             Safefree(SvPVX_mutable(gv));
357     }
358     SvIOK_off(gv);
359     isGV_with_GP_on(gv);
360
361     GvGP_set(gv, Perl_newGP(aTHX_ gv));
362     GvSTASH(gv) = stash;
363     if (stash)
364         Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
365     gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
366     if (flags & GV_ADDMULTI || doproto) /* doproto means it */
367         GvMULTI_on(gv);                 /* _was_ mentioned */
368     if (doproto) {                      /* Replicate part of newSUB here. */
369         CV *cv;
370         ENTER;
371         if (has_constant) {
372             char *name0 = NULL;
373             if (name[len])
374                 /* newCONSTSUB doesn't take a len arg, so make sure we
375                  * give it a \0-terminated string */
376                 name0 = savepvn(name,len);
377
378             /* newCONSTSUB takes ownership of the reference from us.  */
379             cv = newCONSTSUB_flags(stash, (name0 ? name0 : name), flags, has_constant);
380             /* In case op.c:S_process_special_blocks stole it: */
381             if (!GvCV(gv))
382                 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
383             assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
384             if (name0)
385                 Safefree(name0);
386             /* If this reference was a copy of another, then the subroutine
387                must have been "imported", by a Perl space assignment to a GV
388                from a reference to CV.  */
389             if (exported_constant)
390                 GvIMPORTED_CV_on(gv);
391         } else {
392             (void) start_subparse(0,0); /* Create empty CV in compcv. */
393             cv = PL_compcv;
394             GvCV_set(gv,cv);
395         }
396         LEAVE;
397
398         mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
399         CvGV_set(cv, gv);
400         CvFILE_set_from_cop(cv, PL_curcop);
401         CvSTASH_set(cv, PL_curstash);
402         if (proto) {
403             sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
404                             SV_HAS_TRAILING_NUL);
405             if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
406         }
407     }
408 }
409
410 STATIC void
411 S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
412 {
413     PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
414
415     switch (sv_type) {
416     case SVt_PVIO:
417         (void)GvIOn(gv);
418         break;
419     case SVt_PVAV:
420         (void)GvAVn(gv);
421         break;
422     case SVt_PVHV:
423         (void)GvHVn(gv);
424         break;
425 #ifdef PERL_DONT_CREATE_GVSV
426     case SVt_NULL:
427     case SVt_PVCV:
428     case SVt_PVFM:
429     case SVt_PVGV:
430         break;
431     default:
432         if(GvSVn(gv)) {
433             /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
434                If we just cast GvSVn(gv) to void, it ignores evaluating it for
435                its side effect */
436         }
437 #endif
438     }
439 }
440
441 static void core_xsub(pTHX_ CV* cv);
442
443 static GV *
444 S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
445                           const char * const name, const STRLEN len,
446                           const char * const fullname, STRLEN const fullen)
447 {
448     const int code = keyword(name, len, 1);
449     static const char file[] = __FILE__;
450     CV *cv, *oldcompcv = NULL;
451     int opnum = 0;
452     SV *opnumsv;
453     bool ampable = TRUE; /* &{}-able */
454     COP *oldcurcop = NULL;
455     yy_parser *oldparser = NULL;
456     I32 oldsavestack_ix = 0;
457
458     assert(gv || stash);
459     assert(name);
460     assert(stash || fullname);
461
462     if (!fullname && !HvENAME(stash)) return NULL; /* pathological case
463                                                      that would require
464                                                     inlining newATTRSUB */
465     if (code >= 0) return NULL; /* not overridable */
466     switch (-code) {
467      /* no support for \&CORE::infix;
468         no support for funcs that take labels, as their parsing is
469         weird  */
470     case KEY_and: case KEY_cmp: case KEY_CORE: case KEY_dump:
471     case KEY_eq: case KEY_ge:
472     case KEY_gt: case KEY_le: case KEY_lt: case KEY_ne:
473     case KEY_or: case KEY_x: case KEY_xor:
474         return NULL;
475     case KEY_chdir:
476     case KEY_chomp: case KEY_chop:
477     case KEY_each: case KEY_eof: case KEY_exec:
478     case KEY_keys:
479     case KEY_lstat:
480     case KEY_pop:
481     case KEY_push:
482     case KEY_shift:
483     case KEY_splice:
484     case KEY_stat:
485     case KEY_system:
486     case KEY_truncate: case KEY_unlink:
487     case KEY_unshift:
488     case KEY_values:
489         ampable = FALSE;
490     }
491     if (!gv) {
492         gv = (GV *)newSV(0);
493         gv_init(gv, stash, name, len, TRUE);
494     }
495     if (ampable) {
496         ENTER;
497         oldcurcop = PL_curcop;
498         oldparser = PL_parser;
499         lex_start(NULL, NULL, 0);
500         oldcompcv = PL_compcv;
501         PL_compcv = NULL; /* Prevent start_subparse from setting
502                              CvOUTSIDE. */
503         oldsavestack_ix = start_subparse(FALSE,0);
504         cv = PL_compcv;
505     }
506     else {
507         /* Avoid calling newXS, as it calls us, and things start to
508            get hairy. */
509         cv = MUTABLE_CV(newSV_type(SVt_PVCV));
510         GvCV_set(gv,cv);
511         GvCVGEN(gv) = 0;
512         mro_method_changed_in(GvSTASH(gv));
513         CvISXSUB_on(cv);
514         CvXSUB(cv) = core_xsub;
515     }
516     CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
517                          from PL_curcop. */
518     (void)gv_fetchfile(file);
519     CvFILE(cv) = (char *)file;
520     /* XXX This is inefficient, as doing things this order causes
521            a prototype check in newATTRSUB.  But we have to do
522            it this order as we need an op number before calling
523            new ATTRSUB. */
524     (void)core_prototype((SV *)cv, name, code, &opnum);
525     if (stash && (fullname || !fullen))
526         (void)hv_store(stash,name,len,(SV *)gv,0);
527     if (ampable) {
528         SV *tmpstr;
529         CvLVALUE_on(cv);
530         if (!fullname) {
531             tmpstr = newSVhek(HvENAME_HEK(stash));
532             sv_catpvs(tmpstr, "::");
533             sv_catpvn(tmpstr,name,len);
534         }
535         else tmpstr = newSVpvn_share(fullname,fullen,0);
536         newATTRSUB(oldsavestack_ix,
537                    newSVOP(OP_CONST, 0, tmpstr),
538                    NULL,NULL,
539                    coresub_op(
540                      opnum
541                        ? newSVuv((UV)opnum)
542                        : newSVpvn(name,len),
543                      code, opnum
544                    )
545         );
546         assert(GvCV(gv) == cv);
547         if (opnum != OP_VEC && opnum != OP_SUBSTR)
548             CvLVALUE_off(cv); /* Now *that* was a neat trick. */
549         LEAVE;
550         PL_parser = oldparser;
551         PL_curcop = oldcurcop;
552         PL_compcv = oldcompcv;
553     }
554     opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
555     cv_set_call_checker(
556        cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
557     );
558     SvREFCNT_dec(opnumsv);
559     return gv;
560 }
561
562 /*
563 =for apidoc gv_fetchmeth
564
565 Like L</gv_fetchmeth_pvn>, but lacks a flags parameter.
566
567 =for apidoc gv_fetchmeth_sv
568
569 Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form
570 of an SV instead of a string/length pair.
571
572 =cut
573 */
574
575 GV *
576 Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
577 {
578    char *namepv;
579    STRLEN namelen;
580    PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
581    namepv = SvPV(namesv, namelen);
582    if (SvUTF8(namesv))
583        flags |= SVf_UTF8;
584    return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
585 }
586
587 /*
588 =for apidoc gv_fetchmeth_pv
589
590 Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string 
591 instead of a string/length pair.
592
593 =cut
594 */
595
596 GV *
597 Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
598 {
599     PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
600     return gv_fetchmeth_pvn(stash, name, strlen(name), level, flags);
601 }
602
603 /*
604 =for apidoc gv_fetchmeth_pvn
605
606 Returns the glob with the given C<name> and a defined subroutine or
607 C<NULL>.  The glob lives in the given C<stash>, or in the stashes
608 accessible via @ISA and UNIVERSAL::.
609
610 The argument C<level> should be either 0 or -1.  If C<level==0>, as a
611 side-effect creates a glob with the given C<name> in the given C<stash>
612 which in the case of success contains an alias for the subroutine, and sets
613 up caching info for this glob.
614
615 Currently, the only significant value for C<flags> is SVf_UTF8.
616
617 This function grants C<"SUPER"> token as a postfix of the stash name. The
618 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
619 visible to Perl code.  So when calling C<call_sv>, you should not use
620 the GV directly; instead, you should use the method's CV, which can be
621 obtained from the GV with the C<GvCV> macro.
622
623 =cut
624 */
625
626 /* NOTE: No support for tied ISA */
627
628 GV *
629 Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
630 {
631     dVAR;
632     GV** gvp;
633     AV* linear_av;
634     SV** linear_svp;
635     SV* linear_sv;
636     HV* cstash;
637     GV* candidate = NULL;
638     CV* cand_cv = NULL;
639     GV* topgv = NULL;
640     const char *hvname;
641     I32 create = (level >= 0) ? 1 : 0;
642     I32 items;
643     STRLEN packlen;
644     U32 topgen_cmp;
645     U32 is_utf8 = flags & SVf_UTF8;
646
647     PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
648
649     /* UNIVERSAL methods should be callable without a stash */
650     if (!stash) {
651         create = 0;  /* probably appropriate */
652         if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
653             return 0;
654     }
655
656     assert(stash);
657
658     hvname = HvNAME_get(stash);
659     if (!hvname)
660       Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
661
662     assert(hvname);
663     assert(name);
664
665     DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
666
667     topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
668
669     /* check locally for a real method or a cache entry */
670     gvp = (GV**)hv_fetch(stash, name, is_utf8 ? -(I32)len : (I32)len, create);
671     if(gvp) {
672         topgv = *gvp;
673       have_gv:
674         assert(topgv);
675         if (SvTYPE(topgv) != SVt_PVGV)
676             gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
677         if ((cand_cv = GvCV(topgv))) {
678             /* If genuine method or valid cache entry, use it */
679             if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
680                 return topgv;
681             }
682             else {
683                 /* stale cache entry, junk it and move on */
684                 SvREFCNT_dec(cand_cv);
685                 GvCV_set(topgv, NULL);
686                 cand_cv = NULL;
687                 GvCVGEN(topgv) = 0;
688             }
689         }
690         else if (GvCVGEN(topgv) == topgen_cmp) {
691             /* cache indicates no such method definitively */
692             return 0;
693         }
694         else if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
695               && strnEQ(hvname, "CORE", 4)
696               && S_maybe_add_coresub(aTHX_ stash,topgv,name,len,0,1))
697             goto have_gv;
698     }
699
700     packlen = HvNAMELEN_get(stash);
701     if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
702         HV* basestash;
703         packlen -= 7;
704         basestash = gv_stashpvn(hvname, packlen,
705                                 GV_ADD | (HvNAMEUTF8(stash) ? SVf_UTF8 : 0));
706         linear_av = mro_get_linear_isa(basestash);
707     }
708     else {
709         linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
710     }
711
712     linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
713     items = AvFILLp(linear_av); /* no +1, to skip over self */
714     while (items--) {
715         linear_sv = *linear_svp++;
716         assert(linear_sv);
717         cstash = gv_stashsv(linear_sv, 0);
718
719         if (!cstash) {
720             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
721                            "Can't locate package %"SVf" for @%"HEKf"::ISA",
722                            SVfARG(linear_sv),
723                            HEKfARG(HvNAME_HEK(stash)));
724             continue;
725         }
726
727         assert(cstash);
728
729         gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0);
730         if (!gvp) {
731             if (len > 1 && HvNAMELEN_get(cstash) == 4) {
732                 const char *hvname = HvNAME(cstash); assert(hvname);
733                 if (strnEQ(hvname, "CORE", 4)
734                  && (candidate =
735                       S_maybe_add_coresub(aTHX_ cstash,NULL,name,len,0,0)
736                     ))
737                     goto have_candidate;
738             }
739             continue;
740         }
741         else candidate = *gvp;
742        have_candidate:
743         assert(candidate);
744         if (SvTYPE(candidate) != SVt_PVGV)
745             gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
746         if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
747             /*
748              * Found real method, cache method in topgv if:
749              *  1. topgv has no synonyms (else inheritance crosses wires)
750              *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
751              */
752             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
753                   CV *old_cv = GvCV(topgv);
754                   SvREFCNT_dec(old_cv);
755                   SvREFCNT_inc_simple_void_NN(cand_cv);
756                   GvCV_set(topgv, cand_cv);
757                   GvCVGEN(topgv) = topgen_cmp;
758             }
759             return candidate;
760         }
761     }
762
763     /* Check UNIVERSAL without caching */
764     if(level == 0 || level == -1) {
765         candidate = gv_fetchmeth_pvn(NULL, name, len, 1, flags);
766         if(candidate) {
767             cand_cv = GvCV(candidate);
768             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
769                   CV *old_cv = GvCV(topgv);
770                   SvREFCNT_dec(old_cv);
771                   SvREFCNT_inc_simple_void_NN(cand_cv);
772                   GvCV_set(topgv, cand_cv);
773                   GvCVGEN(topgv) = topgen_cmp;
774             }
775             return candidate;
776         }
777     }
778
779     if (topgv && GvREFCNT(topgv) == 1) {
780         /* cache the fact that the method is not defined */
781         GvCVGEN(topgv) = topgen_cmp;
782     }
783
784     return 0;
785 }
786
787 /*
788 =for apidoc gv_fetchmeth_autoload
789
790 This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags
791 parameter.
792
793 =for apidoc gv_fetchmeth_sv_autoload
794
795 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
796 of an SV instead of a string/length pair.
797
798 =cut
799 */
800
801 GV *
802 Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
803 {
804    char *namepv;
805    STRLEN namelen;
806    PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
807    namepv = SvPV(namesv, namelen);
808    if (SvUTF8(namesv))
809        flags |= SVf_UTF8;
810    return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
811 }
812
813 /*
814 =for apidoc gv_fetchmeth_pv_autoload
815
816 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
817 instead of a string/length pair.
818
819 =cut
820 */
821
822 GV *
823 Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
824 {
825     PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
826     return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
827 }
828
829 /*
830 =for apidoc gv_fetchmeth_pvn_autoload
831
832 Same as gv_fetchmeth_pvn(), but looks for autoloaded subroutines too.
833 Returns a glob for the subroutine.
834
835 For an autoloaded subroutine without a GV, will create a GV even
836 if C<level < 0>.  For an autoloaded subroutine without a stub, GvCV()
837 of the result may be zero.
838
839 Currently, the only significant value for C<flags> is SVf_UTF8.
840
841 =cut
842 */
843
844 GV *
845 Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
846 {
847     GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
848
849     PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
850
851     if (!gv) {
852         CV *cv;
853         GV **gvp;
854
855         if (!stash)
856             return NULL;        /* UNIVERSAL::AUTOLOAD could cause trouble */
857         if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
858             return NULL;
859         if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
860             return NULL;
861         cv = GvCV(gv);
862         if (!(CvROOT(cv) || CvXSUB(cv)))
863             return NULL;
864         /* Have an autoload */
865         if (level < 0)  /* Cannot do without a stub */
866             gv_fetchmeth_pvn(stash, name, len, 0, flags);
867         gvp = (GV**)hv_fetch(stash, name,
868                         (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
869         if (!gvp)
870             return NULL;
871         return *gvp;
872     }
873     return gv;
874 }
875
876 /*
877 =for apidoc gv_fetchmethod_autoload
878
879 Returns the glob which contains the subroutine to call to invoke the method
880 on the C<stash>.  In fact in the presence of autoloading this may be the
881 glob for "AUTOLOAD".  In this case the corresponding variable $AUTOLOAD is
882 already setup.
883
884 The third parameter of C<gv_fetchmethod_autoload> determines whether
885 AUTOLOAD lookup is performed if the given method is not present: non-zero
886 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
887 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
888 with a non-zero C<autoload> parameter.
889
890 These functions grant C<"SUPER"> token as a prefix of the method name. Note
891 that if you want to keep the returned glob for a long time, you need to
892 check for it being "AUTOLOAD", since at the later time the call may load a
893 different subroutine due to $AUTOLOAD changing its value. Use the glob
894 created via a side effect to do this.
895
896 These functions have the same side-effects and as C<gv_fetchmeth> with
897 C<level==0>.  C<name> should be writable if contains C<':'> or C<'
898 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
899 C<call_sv> apply equally to these functions.
900
901 =cut
902 */
903
904 STATIC HV*
905 S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen, U32 flags)
906 {
907     AV* superisa;
908     GV** gvp;
909     GV* gv;
910     HV* stash;
911
912     PERL_ARGS_ASSERT_GV_GET_SUPER_PKG;
913
914     stash = gv_stashpvn(name, namelen, flags);
915     if(stash) return stash;
916
917     /* If we must create it, give it an @ISA array containing
918        the real package this SUPER is for, so that it's tied
919        into the cache invalidation code correctly */
920     stash = gv_stashpvn(name, namelen, GV_ADD | flags);
921     gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
922     gv = *gvp;
923     gv_init(gv, stash, "ISA", 3, TRUE);
924     superisa = GvAVn(gv);
925     GvMULTI_on(gv);
926     sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0);
927 #ifdef USE_ITHREADS
928     av_push(superisa, newSVpvn_flags(CopSTASHPV(PL_curcop),
929                                      strlen(CopSTASHPV(PL_curcop)),
930                                      CopSTASH_flags(PL_curcop)
931                                     ));
932 #else
933     av_push(superisa, newSVhek(CopSTASH(PL_curcop)
934                                ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL));
935 #endif
936
937     return stash;
938 }
939
940 GV *
941 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
942 {
943     PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
944
945     return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
946 }
947
948 GV *
949 Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
950 {
951     char *namepv;
952     STRLEN namelen;
953     PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
954     namepv = SvPV(namesv, namelen);
955     if (SvUTF8(namesv))
956        flags |= SVf_UTF8;
957     return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
958 }
959
960 GV *
961 Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
962 {
963     PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
964     return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
965 }
966
967 /* Don't merge this yet, as it's likely to get a len parameter, and possibly
968    even a U32 hash */
969 GV *
970 Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
971 {
972     dVAR;
973     register const char *nend;
974     const char *nsplit = NULL;
975     GV* gv;
976     HV* ostash = stash;
977     const char * const origname = name;
978     SV *const error_report = MUTABLE_SV(stash);
979     const U32 autoload = flags & GV_AUTOLOAD;
980     const U32 do_croak = flags & GV_CROAK;
981     const U32 is_utf8  = flags & SVf_UTF8;
982
983     PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
984
985     if (SvTYPE(stash) < SVt_PVHV)
986         stash = NULL;
987     else {
988         /* The only way stash can become NULL later on is if nsplit is set,
989            which in turn means that there is no need for a SVt_PVHV case
990            the error reporting code.  */
991     }
992
993     for (nend = name; *nend || nend != (origname + len); nend++) {
994         if (*nend == '\'') {
995             nsplit = nend;
996             name = nend + 1;
997         }
998         else if (*nend == ':' && *(nend + 1) == ':') {
999             nsplit = nend++;
1000             name = nend + 1;
1001         }
1002     }
1003     if (nsplit) {
1004         if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
1005             /* ->SUPER::method should really be looked up in original stash */
1006             SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_
1007                      "%"HEKf"::SUPER",
1008                       HEKfARG(HvNAME_HEK((HV*)CopSTASH(PL_curcop)))
1009             ));
1010             /* __PACKAGE__::SUPER stash should be autovivified */
1011             stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr), SvUTF8(tmpstr));
1012             DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
1013                          origname, HvNAME_get(stash), name) );
1014         }
1015         else {
1016             /* don't autovifify if ->NoSuchStash::method */
1017             stash = gv_stashpvn(origname, nsplit - origname, is_utf8);
1018
1019             /* however, explicit calls to Pkg::SUPER::method may
1020                happen, and may require autovivification to work */
1021             if (!stash && (nsplit - origname) >= 7 &&
1022                 strnEQ(nsplit - 7, "::SUPER", 7) &&
1023                 gv_stashpvn(origname, nsplit - origname - 7, is_utf8))
1024               stash = gv_get_super_pkg(origname, nsplit - origname, flags);
1025         }
1026         ostash = stash;
1027     }
1028
1029     gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
1030     if (!gv) {
1031         if (strEQ(name,"import") || strEQ(name,"unimport"))
1032             gv = MUTABLE_GV(&PL_sv_yes);
1033         else if (autoload)
1034             gv = gv_autoload_pvn(
1035                 ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags
1036             );
1037         if (!gv && do_croak) {
1038             /* Right now this is exclusively for the benefit of S_method_common
1039                in pp_hot.c  */
1040             if (stash) {
1041                 /* If we can't find an IO::File method, it might be a call on
1042                  * a filehandle. If IO:File has not been loaded, try to
1043                  * require it first instead of croaking */
1044                 const char *stash_name = HvNAME_get(stash);
1045                 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
1046                     && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
1047                                        STR_WITH_LEN("IO/File.pm"), 0,
1048                                        HV_FETCH_ISEXISTS, NULL, 0)
1049                 ) {
1050                     require_pv("IO/File.pm");
1051                     gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
1052                     if (gv)
1053                         return gv;
1054                 }
1055                 Perl_croak(aTHX_
1056                            "Can't locate object method \"%"SVf
1057                            "\" via package \"%"HEKf"\"",
1058                                     SVfARG(newSVpvn_flags(name, nend - name,
1059                                            SVs_TEMP | is_utf8)),
1060                                     HEKfARG(HvNAME_HEK(stash)));
1061             }
1062             else {
1063                 SV* packnamesv;
1064
1065                 if (nsplit) {
1066                     packnamesv = newSVpvn_flags(origname, nsplit - origname,
1067                                                     SVs_TEMP | is_utf8);
1068                 } else {
1069                     packnamesv = sv_2mortal(newSVsv(error_report));
1070                 }
1071
1072                 Perl_croak(aTHX_
1073                            "Can't locate object method \"%"SVf"\" via package \"%"SVf"\""
1074                            " (perhaps you forgot to load \"%"SVf"\"?)",
1075                            SVfARG(newSVpvn_flags(name, nend - name,
1076                                 SVs_TEMP | is_utf8)),
1077                            SVfARG(packnamesv), SVfARG(packnamesv));
1078             }
1079         }
1080     }
1081     else if (autoload) {
1082         CV* const cv = GvCV(gv);
1083         if (!CvROOT(cv) && !CvXSUB(cv)) {
1084             GV* stubgv;
1085             GV* autogv;
1086
1087             if (CvANON(cv))
1088                 stubgv = gv;
1089             else {
1090                 stubgv = CvGV(cv);
1091                 if (GvCV(stubgv) != cv)         /* orphaned import */
1092                     stubgv = gv;
1093             }
1094             autogv = gv_autoload_pvn(GvSTASH(stubgv),
1095                                   GvNAME(stubgv), GvNAMELEN(stubgv),
1096                                   GV_AUTOLOAD_ISMETHOD
1097                                    | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
1098             if (autogv)
1099                 gv = autogv;
1100         }
1101     }
1102
1103     return gv;
1104 }
1105
1106 GV*
1107 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
1108 {
1109    char *namepv;
1110    STRLEN namelen;
1111    PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
1112    namepv = SvPV(namesv, namelen);
1113    if (SvUTF8(namesv))
1114        flags |= SVf_UTF8;
1115    return gv_autoload_pvn(stash, namepv, namelen, flags);
1116 }
1117
1118 GV*
1119 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
1120 {
1121    PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
1122    return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
1123 }
1124
1125 GV*
1126 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
1127 {
1128     dVAR;
1129     GV* gv;
1130     CV* cv;
1131     HV* varstash;
1132     GV* vargv;
1133     SV* varsv;
1134     SV *packname = NULL;
1135     U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
1136
1137     PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
1138
1139     if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1140         return NULL;
1141     if (stash) {
1142         if (SvTYPE(stash) < SVt_PVHV) {
1143             STRLEN packname_len = 0;
1144             const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
1145             packname = newSVpvn_flags(packname_ptr, packname_len,
1146                                       SVs_TEMP | SvUTF8(stash));
1147             stash = NULL;
1148         }
1149         else
1150             packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
1151     }
1152     if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, is_utf8)))
1153         return NULL;
1154     cv = GvCV(gv);
1155
1156     if (!(CvROOT(cv) || CvXSUB(cv)))
1157         return NULL;
1158
1159     /*
1160      * Inheriting AUTOLOAD for non-methods works ... for now.
1161      */
1162     if (
1163         !(flags & GV_AUTOLOAD_ISMETHOD)
1164      && (GvCVGEN(gv) || GvSTASH(gv) != stash)
1165     )
1166         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
1167                          "Use of inherited AUTOLOAD for non-method %"SVf"::%"SVf"() is deprecated",
1168                          SVfARG(packname),
1169                          SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
1170
1171     if (CvISXSUB(cv)) {
1172         /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
1173          * and split that value on the last '::', pass along the same data
1174          * via the SvPVX field in the CV, and the stash in CvSTASH.
1175          *
1176          * Due to an unfortunate accident of history, the SvPVX field
1177          * serves two purposes.  It is also used for the subroutine's pro-
1178          * type.  Since SvPVX has been documented as returning the sub name
1179          * for a long time, but not as returning the prototype, we have
1180          * to preserve the SvPVX AUTOLOAD behaviour and put the prototype
1181          * elsewhere.
1182          *
1183          * We put the prototype in the same allocated buffer, but after
1184          * the sub name.  The SvPOK flag indicates the presence of a proto-
1185          * type.  The CvAUTOLOAD flag indicates the presence of a sub name.
1186          * If both flags are on, then SvLEN is used to indicate the end of
1187          * the prototype (artificially lower than what is actually allo-
1188          * cated), at the risk of having to reallocate a few bytes unneces-
1189          * sarily--but that should happen very rarely, if ever.
1190          *
1191          * We use SvUTF8 for both prototypes and sub names, so if one is
1192          * UTF8, the other must be upgraded.
1193          */
1194         CvSTASH_set(cv, stash);
1195         if (SvPOK(cv)) { /* Ouch! */
1196             SV *tmpsv = newSVpvn_flags(name, len, is_utf8);
1197             STRLEN ulen;
1198             const char *proto = CvPROTO(cv);
1199             assert(proto);
1200             if (SvUTF8(cv))
1201                 sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
1202             ulen = SvCUR(tmpsv);
1203             SvCUR(tmpsv)++; /* include null in string */
1204             sv_catpvn_flags(
1205                 tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
1206             );
1207             SvTEMP_on(tmpsv); /* Allow theft */
1208             sv_setsv_nomg((SV *)cv, tmpsv);
1209             SvTEMP_off(tmpsv);
1210             SvREFCNT_dec(tmpsv);
1211             SvLEN(cv) = SvCUR(cv) + 1;
1212             SvCUR(cv) = ulen;
1213         }
1214         else {
1215           sv_setpvn((SV *)cv, name, len);
1216           SvPOK_off(cv);
1217           if (is_utf8)
1218             SvUTF8_on(cv);
1219           else SvUTF8_off(cv);
1220         }
1221         CvAUTOLOAD_on(cv);
1222     }
1223
1224     /*
1225      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1226      * The subroutine's original name may not be "AUTOLOAD", so we don't
1227      * use that, but for lack of anything better we will use the sub's
1228      * original package to look up $AUTOLOAD.
1229      */
1230     varstash = GvSTASH(CvGV(cv));
1231     vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1232     ENTER;
1233
1234     if (!isGV(vargv)) {
1235         gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
1236 #ifdef PERL_DONT_CREATE_GVSV
1237         GvSV(vargv) = newSV(0);
1238 #endif
1239     }
1240     LEAVE;
1241     varsv = GvSVn(vargv);
1242     sv_setsv(varsv, packname);
1243     sv_catpvs(varsv, "::");
1244     /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1245        tainting if $FOO::AUTOLOAD was previously tainted, but is not now.  */
1246     sv_catpvn_flags(
1247         varsv, name, len,
1248         SV_GMAGIC|SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
1249     );
1250     if (is_utf8)
1251         SvUTF8_on(varsv);
1252     return gv;
1253 }
1254
1255
1256 /* require_tie_mod() internal routine for requiring a module
1257  * that implements the logic of automatic ties like %! and %-
1258  *
1259  * The "gv" parameter should be the glob.
1260  * "varpv" holds the name of the var, used for error messages.
1261  * "namesv" holds the module name. Its refcount will be decremented.
1262  * "methpv" holds the method name to test for to check that things
1263  *   are working reasonably close to as expected.
1264  * "flags": if flag & 1 then save the scalar before loading.
1265  * For the protection of $! to work (it is set by this routine)
1266  * the sv slot must already be magicalized.
1267  */
1268 STATIC HV*
1269 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
1270 {
1271     dVAR;
1272     HV* stash = gv_stashsv(namesv, 0);
1273
1274     PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1275
1276     if (!stash || !(gv_fetchmethod(stash, methpv))) {
1277         SV *module = newSVsv(namesv);
1278         char varname = *varpv; /* varpv might be clobbered by load_module,
1279                                   so save it. For the moment it's always
1280                                   a single char. */
1281         const char type = varname == '[' ? '$' : '%';
1282         dSP;
1283         ENTER;
1284         if ( flags & 1 )
1285             save_scalar(gv);
1286         PUSHSTACKi(PERLSI_MAGIC);
1287         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1288         POPSTACK;
1289         LEAVE;
1290         SPAGAIN;
1291         stash = gv_stashsv(namesv, 0);
1292         if (!stash)
1293             Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available",
1294                     type, varname, SVfARG(namesv));
1295         else if (!gv_fetchmethod(stash, methpv))
1296             Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not support method %s",
1297                     type, varname, SVfARG(namesv), methpv);
1298     }
1299     SvREFCNT_dec(namesv);
1300     return stash;
1301 }
1302
1303 /*
1304 =for apidoc gv_stashpv
1305
1306 Returns a pointer to the stash for a specified package.  Uses C<strlen> to
1307 determine the length of C<name>, then calls C<gv_stashpvn()>.
1308
1309 =cut
1310 */
1311
1312 HV*
1313 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1314 {
1315     PERL_ARGS_ASSERT_GV_STASHPV;
1316     return gv_stashpvn(name, strlen(name), create);
1317 }
1318
1319 /*
1320 =for apidoc gv_stashpvn
1321
1322 Returns a pointer to the stash for a specified package.  The C<namelen>
1323 parameter indicates the length of the C<name>, in bytes.  C<flags> is passed
1324 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1325 created if it does not already exist.  If the package does not exist and
1326 C<flags> is 0 (or any other setting that does not create packages) then NULL
1327 is returned.
1328
1329
1330 =cut
1331 */
1332
1333 HV*
1334 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1335 {
1336     char smallbuf[128];
1337     char *tmpbuf;
1338     HV *stash;
1339     GV *tmpgv;
1340     U32 tmplen = namelen + 2;
1341
1342     PERL_ARGS_ASSERT_GV_STASHPVN;
1343
1344     if (tmplen <= sizeof smallbuf)
1345         tmpbuf = smallbuf;
1346     else
1347         Newx(tmpbuf, tmplen, char);
1348     Copy(name, tmpbuf, namelen, char);
1349     tmpbuf[namelen]   = ':';
1350     tmpbuf[namelen+1] = ':';
1351     tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1352     if (tmpbuf != smallbuf)
1353         Safefree(tmpbuf);
1354     if (!tmpgv)
1355         return NULL;
1356     stash = GvHV(tmpgv);
1357     if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1358     assert(stash);
1359     if (!HvNAME_get(stash)) {
1360         hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1361         
1362         /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1363         /* If the containing stash has multiple effective
1364            names, see that this one gets them, too. */
1365         if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1366             mro_package_moved(stash, NULL, tmpgv, 1);
1367     }
1368     return stash;
1369 }
1370
1371 /*
1372 =for apidoc gv_stashsv
1373
1374 Returns a pointer to the stash for a specified package.  See C<gv_stashpvn>.
1375
1376 =cut
1377 */
1378
1379 HV*
1380 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1381 {
1382     STRLEN len;
1383     const char * const ptr = SvPV_const(sv,len);
1384
1385     PERL_ARGS_ASSERT_GV_STASHSV;
1386
1387     return gv_stashpvn(ptr, len, flags | SvUTF8(sv));
1388 }
1389
1390
1391 GV *
1392 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
1393     PERL_ARGS_ASSERT_GV_FETCHPV;
1394     return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
1395 }
1396
1397 GV *
1398 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1399     STRLEN len;
1400     const char * const nambeg =
1401        SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1402     PERL_ARGS_ASSERT_GV_FETCHSV;
1403     return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1404 }
1405
1406 STATIC void
1407 S_gv_magicalize_isa(pTHX_ GV *gv)
1408 {
1409     AV* av;
1410
1411     PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1412
1413     av = GvAVn(gv);
1414     GvMULTI_on(gv);
1415     sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1416              NULL, 0);
1417 }
1418
1419 STATIC void
1420 S_gv_magicalize_overload(pTHX_ GV *gv)
1421 {
1422     HV* hv;
1423
1424     PERL_ARGS_ASSERT_GV_MAGICALIZE_OVERLOAD;
1425
1426     hv = GvHVn(gv);
1427     GvMULTI_on(gv);
1428     hv_magic(hv, NULL, PERL_MAGIC_overload);
1429 }
1430
1431 GV *
1432 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
1433                        const svtype sv_type)
1434 {
1435     dVAR;
1436     register const char *name = nambeg;
1437     register GV *gv = NULL;
1438     GV**gvp;
1439     I32 len;
1440     register const char *name_cursor;
1441     HV *stash = NULL;
1442     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
1443     const I32 no_expand = flags & GV_NOEXPAND;
1444     const I32 add = flags & ~GV_NOADD_MASK;
1445     const U32 is_utf8 = flags & SVf_UTF8;
1446     bool addmg = !!(flags & GV_ADDMG);
1447     const char *const name_end = nambeg + full_len;
1448     const char *const name_em1 = name_end - 1;
1449     U32 faking_it;
1450
1451     PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
1452
1453     if (flags & GV_NOTQUAL) {
1454         /* Caller promised that there is no stash, so we can skip the check. */
1455         len = full_len;
1456         goto no_stash;
1457     }
1458
1459     if (full_len > 2 && *name == '*' && isIDFIRST_lazy_if(name + 1, is_utf8)) {
1460         /* accidental stringify on a GV? */
1461         name++;
1462     }
1463
1464     for (name_cursor = name; name_cursor < name_end; name_cursor++) {
1465         if (name_cursor < name_em1 &&
1466             ((*name_cursor == ':'
1467              && name_cursor[1] == ':')
1468             || *name_cursor == '\''))
1469         {
1470             if (!stash)
1471                 stash = PL_defstash;
1472             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
1473                 return NULL;
1474
1475             len = name_cursor - name;
1476             if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1477                 const char *key;
1478                 if (*name_cursor == ':') {
1479                     key = name;
1480                     len += 2;
1481                 } else {
1482                     char *tmpbuf;
1483                     Newx(tmpbuf, len+2, char);
1484                     Copy(name, tmpbuf, len, char);
1485                     tmpbuf[len++] = ':';
1486                     tmpbuf[len++] = ':';
1487                     key = tmpbuf;
1488                 }
1489                 gvp = (GV**)hv_fetch(stash, key, is_utf8 ? -len : len, add);
1490                 gv = gvp ? *gvp : NULL;
1491                 if (gv && gv != (const GV *)&PL_sv_undef) {
1492                     if (SvTYPE(gv) != SVt_PVGV)
1493                         gv_init_pvn(gv, stash, key, len, (add & GV_ADDMULTI)|is_utf8);
1494                     else
1495                         GvMULTI_on(gv);
1496                 }
1497                 if (key != name)
1498                     Safefree(key);
1499                 if (!gv || gv == (const GV *)&PL_sv_undef)
1500                     return NULL;
1501
1502                 if (!(stash = GvHV(gv)))
1503                 {
1504                     stash = GvHV(gv) = newHV();
1505                     if (!HvNAME_get(stash)) {
1506                         if (GvSTASH(gv) == PL_defstash && len == 6
1507                          && strnEQ(name, "CORE", 4))
1508                             hv_name_set(stash, "CORE", 4, 0);
1509                         else
1510                             hv_name_set(
1511                                 stash, nambeg, name_cursor-nambeg, is_utf8
1512                             );
1513                         /* If the containing stash has multiple effective
1514                            names, see that this one gets them, too. */
1515                         if (HvAUX(GvSTASH(gv))->xhv_name_count)
1516                             mro_package_moved(stash, NULL, gv, 1);
1517                     }
1518                 }
1519                 else if (!HvNAME_get(stash))
1520                     hv_name_set(stash, nambeg, name_cursor - nambeg, is_utf8);
1521             }
1522
1523             if (*name_cursor == ':')
1524                 name_cursor++;
1525             name = name_cursor+1;
1526             if (name == name_end)
1527                 return gv
1528                     ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1529         }
1530     }
1531     len = name_cursor - name;
1532
1533     /* No stash in name, so see how we can default */
1534
1535     if (!stash) {
1536     no_stash:
1537         if (len && isIDFIRST_lazy(name)) {
1538             bool global = FALSE;
1539
1540             switch (len) {
1541             case 1:
1542                 if (*name == '_')
1543                     global = TRUE;
1544                 break;
1545             case 3:
1546                 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1547                     || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1548                     || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1549                     global = TRUE;
1550                 break;
1551             case 4:
1552                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1553                     && name[3] == 'V')
1554                     global = TRUE;
1555                 break;
1556             case 5:
1557                 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1558                     && name[3] == 'I' && name[4] == 'N')
1559                     global = TRUE;
1560                 break;
1561             case 6:
1562                 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1563                     &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1564                        ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1565                     global = TRUE;
1566                 break;
1567             case 7:
1568                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1569                     && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1570                     && name[6] == 'T')
1571                     global = TRUE;
1572                 break;
1573             }
1574
1575             if (global)
1576                 stash = PL_defstash;
1577             else if (IN_PERL_COMPILETIME) {
1578                 stash = PL_curstash;
1579                 if (add && (PL_hints & HINT_STRICT_VARS) &&
1580                     sv_type != SVt_PVCV &&
1581                     sv_type != SVt_PVGV &&
1582                     sv_type != SVt_PVFM &&
1583                     sv_type != SVt_PVIO &&
1584                     !(len == 1 && sv_type == SVt_PV &&
1585                       (*name == 'a' || *name == 'b')) )
1586                 {
1587                     gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,0);
1588                     if (!gvp ||
1589                         *gvp == (const GV *)&PL_sv_undef ||
1590                         SvTYPE(*gvp) != SVt_PVGV)
1591                     {
1592                         stash = NULL;
1593                     }
1594                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
1595                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1596                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1597                     {
1598                         SV* namesv = newSVpvn_flags(name, len, SVs_TEMP | is_utf8);
1599                         /* diag_listed_as: Variable "%s" is not imported%s */
1600                         Perl_ck_warner_d(
1601                             aTHX_ packWARN(WARN_MISC),
1602                             "Variable \"%c%"SVf"\" is not imported",
1603                             sv_type == SVt_PVAV ? '@' :
1604                             sv_type == SVt_PVHV ? '%' : '$',
1605                             SVfARG(namesv));
1606                         if (GvCVu(*gvp))
1607                             Perl_ck_warner_d(
1608                                 aTHX_ packWARN(WARN_MISC),
1609                                 "\t(Did you mean &%"SVf" instead?)\n", SVfARG(namesv)
1610                             );
1611                         stash = NULL;
1612                     }
1613                 }
1614             }
1615             else
1616                 stash = CopSTASH(PL_curcop);
1617         }
1618         else
1619             stash = PL_defstash;
1620     }
1621
1622     /* By this point we should have a stash and a name */
1623
1624     if (!stash) {
1625         if (add) {
1626             SV * const err = Perl_mess(aTHX_
1627                  "Global symbol \"%s%"SVf"\" requires explicit package name",
1628                  (sv_type == SVt_PV ? "$"
1629                   : sv_type == SVt_PVAV ? "@"
1630                   : sv_type == SVt_PVHV ? "%"
1631                   : ""), SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
1632             GV *gv;
1633             if (USE_UTF8_IN_NAMES)
1634                 SvUTF8_on(err);
1635             qerror(err);
1636             gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1637             if(!gv) {
1638                 /* symbol table under destruction */
1639                 return NULL;
1640             }   
1641             stash = GvHV(gv);
1642         }
1643         else
1644             return NULL;
1645     }
1646
1647     if (!SvREFCNT(stash))       /* symbol table under destruction */
1648         return NULL;
1649
1650     gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,add);
1651     if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
1652         if (addmg) gv = (GV *)newSV(0);
1653         else return NULL;
1654     }
1655     else gv = *gvp, addmg = 0;
1656     /* From this point on, addmg means gv has not been inserted in the
1657        symtab yet. */
1658
1659     if (SvTYPE(gv) == SVt_PVGV) {
1660         if (add) {
1661             GvMULTI_on(gv);
1662             gv_init_svtype(gv, sv_type);
1663             if (len == 1 && stash == PL_defstash) {
1664               if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
1665                 if (*name == '!')
1666                     require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1667                 else if (*name == '-' || *name == '+')
1668                     require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1669               }
1670               if ((sv_type==SVt_PV || sv_type==SVt_PVGV) && *name == '[')
1671                 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
1672             }
1673             else if (len == 3 && sv_type == SVt_PVAV
1674                   && strnEQ(name, "ISA", 3)
1675                   && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
1676                 gv_magicalize_isa(gv);
1677         }
1678         return gv;
1679     } else if (no_init) {
1680         assert(!addmg);
1681         return gv;
1682     } else if (no_expand && SvROK(gv)) {
1683         assert(!addmg);
1684         return gv;
1685     }
1686
1687     /* Adding a new symbol.
1688        Unless of course there was already something non-GV here, in which case
1689        we want to behave as if there was always a GV here, containing some sort
1690        of subroutine.
1691        Otherwise we run the risk of creating things like GvIO, which can cause
1692        subtle bugs. eg the one that tripped up SQL::Translator  */
1693
1694     faking_it = SvOK(gv);
1695
1696     if (add & GV_ADDWARN)
1697         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %"SVf" unexpectedly",
1698                 SVfARG(newSVpvn_flags(nambeg, name_end-nambeg, SVs_TEMP | is_utf8 )));
1699     gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
1700
1701     if ( isIDFIRST_lazy_if(name, is_utf8)
1702                 && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) )
1703         GvMULTI_on(gv) ;
1704
1705     /* set up magic where warranted */
1706     if (stash != PL_defstash) { /* not the main stash */
1707         /* We only have to check for four names here: EXPORT, ISA, OVERLOAD
1708            and VERSION. All the others apply only to the main stash or to
1709            CORE (which is checked right after this). */
1710         if (len > 2) {
1711             const char * const name2 = name + 1;
1712             switch (*name) {
1713             case 'E':
1714                 if (strnEQ(name2, "XPORT", 5))
1715                     GvMULTI_on(gv);
1716                 break;
1717             case 'I':
1718                 if (strEQ(name2, "SA"))
1719                     gv_magicalize_isa(gv);
1720                 break;
1721             case 'O':
1722                 if (strEQ(name2, "VERLOAD"))
1723                     gv_magicalize_overload(gv);
1724                 break;
1725             case 'V':
1726                 if (strEQ(name2, "ERSION"))
1727                     GvMULTI_on(gv);
1728                 break;
1729             default:
1730                 goto try_core;
1731             }
1732             goto add_magical_gv;
1733         }
1734       try_core:
1735         if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1736           /* Avoid null warning: */
1737           const char * const stashname = HvNAME(stash); assert(stashname);
1738           if (strnEQ(stashname, "CORE", 4)
1739            && S_maybe_add_coresub(aTHX_
1740                 addmg ? stash : 0, gv, name, len, nambeg, full_len
1741               ))
1742             addmg = 0;
1743         }
1744     }
1745     else if (len > 1) {
1746 #ifndef EBCDIC
1747         if (*name > 'V' ) {
1748             NOOP;
1749             /* Nothing else to do.
1750                The compiler will probably turn the switch statement into a
1751                branch table. Make sure we avoid even that small overhead for
1752                the common case of lower case variable names.  */
1753         } else
1754 #endif
1755         {
1756             const char * const name2 = name + 1;
1757             switch (*name) {
1758             case 'A':
1759                 if (strEQ(name2, "RGV")) {
1760                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1761                 }
1762                 else if (strEQ(name2, "RGVOUT")) {
1763                     GvMULTI_on(gv);
1764                 }
1765                 break;
1766             case 'E':
1767                 if (strnEQ(name2, "XPORT", 5))
1768                     GvMULTI_on(gv);
1769                 break;
1770             case 'I':
1771                 if (strEQ(name2, "SA")) {
1772                     gv_magicalize_isa(gv);
1773                 }
1774                 break;
1775             case 'O':
1776                 if (strEQ(name2, "VERLOAD")) {
1777                     gv_magicalize_overload(gv);
1778                 }
1779                 break;
1780             case 'S':
1781                 if (strEQ(name2, "IG")) {
1782                     HV *hv;
1783                     I32 i;
1784                     if (!PL_psig_name) {
1785                         Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1786                         Newxz(PL_psig_pend, SIG_SIZE, int);
1787                         PL_psig_ptr = PL_psig_name + SIG_SIZE;
1788                     } else {
1789                         /* I think that the only way to get here is to re-use an
1790                            embedded perl interpreter, where the previous
1791                            use didn't clean up fully because
1792                            PL_perl_destruct_level was 0. I'm not sure that we
1793                            "support" that, in that I suspect in that scenario
1794                            there are sufficient other garbage values left in the
1795                            interpreter structure that something else will crash
1796                            before we get here. I suspect that this is one of
1797                            those "doctor, it hurts when I do this" bugs.  */
1798                         Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1799                         Zero(PL_psig_pend, SIG_SIZE, int);
1800                     }
1801                     GvMULTI_on(gv);
1802                     hv = GvHVn(gv);
1803                     hv_magic(hv, NULL, PERL_MAGIC_sig);
1804                     for (i = 1; i < SIG_SIZE; i++) {
1805                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1806                         if (init)
1807                             sv_setsv(*init, &PL_sv_undef);
1808                     }
1809                 }
1810                 break;
1811             case 'V':
1812                 if (strEQ(name2, "ERSION"))
1813                     GvMULTI_on(gv);
1814                 break;
1815             case '\003':        /* $^CHILD_ERROR_NATIVE */
1816                 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1817                     goto magicalize;
1818                 break;
1819             case '\005':        /* $^ENCODING */
1820                 if (strEQ(name2, "NCODING"))
1821                     goto magicalize;
1822                 break;
1823             case '\007':        /* $^GLOBAL_PHASE */
1824                 if (strEQ(name2, "LOBAL_PHASE"))
1825                     goto ro_magicalize;
1826                 break;
1827             case '\015':        /* $^MATCH */
1828                 if (strEQ(name2, "ATCH"))
1829                     goto magicalize;
1830             case '\017':        /* $^OPEN */
1831                 if (strEQ(name2, "PEN"))
1832                     goto magicalize;
1833                 break;
1834             case '\020':        /* $^PREMATCH  $^POSTMATCH */
1835                 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1836                     goto magicalize;
1837                 break;
1838             case '\024':        /* ${^TAINT} */
1839                 if (strEQ(name2, "AINT"))
1840                     goto ro_magicalize;
1841                 break;
1842             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
1843                 if (strEQ(name2, "NICODE"))
1844                     goto ro_magicalize;
1845                 if (strEQ(name2, "TF8LOCALE"))
1846                     goto ro_magicalize;
1847                 if (strEQ(name2, "TF8CACHE"))
1848                     goto magicalize;
1849                 break;
1850             case '\027':        /* $^WARNING_BITS */
1851                 if (strEQ(name2, "ARNING_BITS"))
1852                     goto magicalize;
1853                 break;
1854             case '1':
1855             case '2':
1856             case '3':
1857             case '4':
1858             case '5':
1859             case '6':
1860             case '7':
1861             case '8':
1862             case '9':
1863             {
1864                 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1865                    this test  */
1866                 /* This snippet is taken from is_gv_magical */
1867                 const char *end = name + len;
1868                 while (--end > name) {
1869                     if (!isDIGIT(*end)) goto add_magical_gv;
1870                 }
1871                 goto magicalize;
1872             }
1873             }
1874         }
1875     } else {
1876         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
1877            be case '\0' in this switch statement (ie a default case)  */
1878         switch (*name) {
1879         case '&':               /* $& */
1880         case '`':               /* $` */
1881         case '\'':              /* $' */
1882             if (
1883                 sv_type == SVt_PVAV ||
1884                 sv_type == SVt_PVHV ||
1885                 sv_type == SVt_PVCV ||
1886                 sv_type == SVt_PVFM ||
1887                 sv_type == SVt_PVIO
1888                 ) { break; }
1889             PL_sawampersand = TRUE;
1890             goto magicalize;
1891
1892         case ':':               /* $: */
1893             sv_setpv(GvSVn(gv),PL_chopset);
1894             goto magicalize;
1895
1896         case '?':               /* $? */
1897 #ifdef COMPLEX_STATUS
1898             SvUPGRADE(GvSVn(gv), SVt_PVLV);
1899 #endif
1900             goto magicalize;
1901
1902         case '!':               /* $! */
1903             GvMULTI_on(gv);
1904             /* If %! has been used, automatically load Errno.pm. */
1905
1906             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1907
1908             /* magicalization must be done before require_tie_mod is called */
1909             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1910                 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1911
1912             break;
1913         case '-':               /* $- */
1914         case '+':               /* $+ */
1915         GvMULTI_on(gv); /* no used once warnings here */
1916         {
1917             AV* const av = GvAVn(gv);
1918             SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1919
1920             sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1921             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1922             if (avc)
1923                 SvREADONLY_on(GvSVn(gv));
1924             SvREADONLY_on(av);
1925
1926             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1927                 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1928
1929             break;
1930         }
1931         case '*':               /* $* */
1932         case '#':               /* $# */
1933             if (sv_type == SVt_PV)
1934                 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1935                                  "$%c is no longer supported", *name);
1936             break;
1937         case '|':               /* $| */
1938             sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1939             goto magicalize;
1940
1941         case '\010':    /* $^H */
1942             {
1943                 HV *const hv = GvHVn(gv);
1944                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1945             }
1946             goto magicalize;
1947         case '[':               /* $[ */
1948             if (sv_type == SVt_PV || sv_type == SVt_PVGV) {
1949                 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1950                 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
1951                 addmg = 0;
1952             }
1953             break;
1954         case '\023':    /* $^S */
1955         ro_magicalize:
1956             SvREADONLY_on(GvSVn(gv));
1957             /* FALL THROUGH */
1958         case '0':               /* $0 */
1959         case '1':               /* $1 */
1960         case '2':               /* $2 */
1961         case '3':               /* $3 */
1962         case '4':               /* $4 */
1963         case '5':               /* $5 */
1964         case '6':               /* $6 */
1965         case '7':               /* $7 */
1966         case '8':               /* $8 */
1967         case '9':               /* $9 */
1968         case '^':               /* $^ */
1969         case '~':               /* $~ */
1970         case '=':               /* $= */
1971         case '%':               /* $% */
1972         case '.':               /* $. */
1973         case '(':               /* $( */
1974         case ')':               /* $) */
1975         case '<':               /* $< */
1976         case '>':               /* $> */
1977         case '\\':              /* $\ */
1978         case '/':               /* $/ */
1979         case '$':               /* $$ */
1980         case '\001':    /* $^A */
1981         case '\003':    /* $^C */
1982         case '\004':    /* $^D */
1983         case '\005':    /* $^E */
1984         case '\006':    /* $^F */
1985         case '\011':    /* $^I, NOT \t in EBCDIC */
1986         case '\016':    /* $^N */
1987         case '\017':    /* $^O */
1988         case '\020':    /* $^P */
1989         case '\024':    /* $^T */
1990         case '\027':    /* $^W */
1991         magicalize:
1992             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1993             break;
1994
1995         case '\014':    /* $^L */
1996             sv_setpvs(GvSVn(gv),"\f");
1997             PL_formfeed = GvSVn(gv);
1998             break;
1999         case ';':               /* $; */
2000             sv_setpvs(GvSVn(gv),"\034");
2001             break;
2002         case ']':               /* $] */
2003         {
2004             SV * const sv = GvSV(gv);
2005             if (!sv_derived_from(PL_patchlevel, "version"))
2006                 upg_version(PL_patchlevel, TRUE);
2007             GvSV(gv) = vnumify(PL_patchlevel);
2008             SvREADONLY_on(GvSV(gv));
2009             SvREFCNT_dec(sv);
2010         }
2011         break;
2012         case '\026':    /* $^V */
2013         {
2014             SV * const sv = GvSV(gv);
2015             GvSV(gv) = new_version(PL_patchlevel);
2016             SvREADONLY_on(GvSV(gv));
2017             SvREFCNT_dec(sv);
2018         }
2019         break;
2020         }
2021     }
2022   add_magical_gv:
2023     if (addmg) {
2024         if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
2025              GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
2026            ))
2027             (void)hv_store(stash,name,len,(SV *)gv,0);
2028         else SvREFCNT_dec(gv), gv = NULL;
2029     }
2030     if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
2031     return gv;
2032 }
2033
2034 void
2035 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2036 {
2037     const char *name;
2038     const HV * const hv = GvSTASH(gv);
2039
2040     PERL_ARGS_ASSERT_GV_FULLNAME4;
2041
2042     sv_setpv(sv, prefix ? prefix : "");
2043
2044     if (hv && (name = HvNAME(hv))) {
2045       const STRLEN len = HvNAMELEN(hv);
2046       if (keepmain || strnNE(name, "main", len)) {
2047         sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
2048         sv_catpvs(sv,"::");
2049       }
2050     }
2051     else sv_catpvs(sv,"__ANON__::");
2052     sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2053 }
2054
2055 void
2056 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2057 {
2058     const GV * const egv = GvEGVx(gv);
2059
2060     PERL_ARGS_ASSERT_GV_EFULLNAME4;
2061
2062     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2063 }
2064
2065 void
2066 Perl_gv_check(pTHX_ const HV *stash)
2067 {
2068     dVAR;
2069     register I32 i;
2070
2071     PERL_ARGS_ASSERT_GV_CHECK;
2072
2073     if (!HvARRAY(stash))
2074         return;
2075     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2076         const HE *entry;
2077         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2078             register GV *gv;
2079             HV *hv;
2080             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
2081                 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2082             {
2083                 if (hv != PL_defstash && hv != stash)
2084                      gv_check(hv);              /* nested package */
2085             }
2086             else if ( *HeKEY(entry) != '_'
2087                         && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
2088                 const char *file;
2089                 gv = MUTABLE_GV(HeVAL(entry));
2090                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2091                     continue;
2092                 file = GvFILE(gv);
2093                 CopLINE_set(PL_curcop, GvLINE(gv));
2094 #ifdef USE_ITHREADS
2095                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
2096 #else
2097                 CopFILEGV(PL_curcop)
2098                     = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2099 #endif
2100                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2101                         "Name \"%"HEKf"::%"HEKf
2102                         "\" used only once: possible typo",
2103                             HEKfARG(HvNAME_HEK(stash)),
2104                             HEKfARG(GvNAME_HEK(gv)));
2105             }
2106         }
2107     }
2108 }
2109
2110 GV *
2111 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2112 {
2113     dVAR;
2114     PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2115
2116     return gv_fetchpv(Perl_form(aTHX_ "%"SVf"::_GEN_%ld",
2117                                     SVfARG(newSVpvn_flags(pack, strlen(pack),
2118                                             SVs_TEMP | flags)),
2119                                 (long)PL_gensym++),
2120                       GV_ADD, SVt_PVGV);
2121 }
2122
2123 /* hopefully this is only called on local symbol table entries */
2124
2125 GP*
2126 Perl_gp_ref(pTHX_ GP *gp)
2127 {
2128     dVAR;
2129     if (!gp)
2130         return NULL;
2131     gp->gp_refcnt++;
2132     if (gp->gp_cv) {
2133         if (gp->gp_cvgen) {
2134             /* If the GP they asked for a reference to contains
2135                a method cache entry, clear it first, so that we
2136                don't infect them with our cached entry */
2137             SvREFCNT_dec(gp->gp_cv);
2138             gp->gp_cv = NULL;
2139             gp->gp_cvgen = 0;
2140         }
2141     }
2142     return gp;
2143 }
2144
2145 void
2146 Perl_gp_free(pTHX_ GV *gv)
2147 {
2148     dVAR;
2149     GP* gp;
2150     int attempts = 100;
2151
2152     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2153         return;
2154     if (gp->gp_refcnt == 0) {
2155         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2156                          "Attempt to free unreferenced glob pointers"
2157                          pTHX__FORMAT pTHX__VALUE);
2158         return;
2159     }
2160     if (--gp->gp_refcnt > 0) {
2161         if (gp->gp_egv == gv)
2162             gp->gp_egv = 0;
2163         GvGP_set(gv, NULL);
2164         return;
2165     }
2166
2167     while (1) {
2168       /* Copy and null out all the glob slots, so destructors do not see
2169          freed SVs. */
2170       HEK * const file_hek = gp->gp_file_hek;
2171       SV  * const sv       = gp->gp_sv;
2172       AV  * const av       = gp->gp_av;
2173       HV  * const hv       = gp->gp_hv;
2174       IO  * const io       = gp->gp_io;
2175       CV  * const cv       = gp->gp_cv;
2176       CV  * const form     = gp->gp_form;
2177
2178       gp->gp_file_hek = NULL;
2179       gp->gp_sv       = NULL;
2180       gp->gp_av       = NULL;
2181       gp->gp_hv       = NULL;
2182       gp->gp_io       = NULL;
2183       gp->gp_cv       = NULL;
2184       gp->gp_form     = NULL;
2185
2186       if (file_hek)
2187         unshare_hek(file_hek);
2188
2189       SvREFCNT_dec(sv);
2190       SvREFCNT_dec(av);
2191       /* FIXME - another reference loop GV -> symtab -> GV ?
2192          Somehow gp->gp_hv can end up pointing at freed garbage.  */
2193       if (hv && SvTYPE(hv) == SVt_PVHV) {
2194         const HEK *hvname_hek = HvNAME_HEK(hv);
2195         if (PL_stashcache && hvname_hek)
2196            (void)hv_delete(PL_stashcache, HEK_KEY(hvname_hek),
2197                       (HEK_UTF8(hvname_hek) ? -HEK_LEN(hvname_hek) : HEK_LEN(hvname_hek)),
2198                       G_DISCARD);
2199         SvREFCNT_dec(hv);
2200       }
2201       SvREFCNT_dec(io);
2202       SvREFCNT_dec(cv);
2203       SvREFCNT_dec(form);
2204
2205       if (!gp->gp_file_hek
2206        && !gp->gp_sv
2207        && !gp->gp_av
2208        && !gp->gp_hv
2209        && !gp->gp_io
2210        && !gp->gp_cv
2211        && !gp->gp_form) break;
2212
2213       if (--attempts == 0) {
2214         Perl_die(aTHX_
2215           "panic: gp_free failed to free glob pointer - "
2216           "something is repeatedly re-creating entries"
2217         );
2218       }
2219     }
2220
2221     Safefree(gp);
2222     GvGP_set(gv, NULL);
2223 }
2224
2225 int
2226 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2227 {
2228     AMT * const amtp = (AMT*)mg->mg_ptr;
2229     PERL_UNUSED_ARG(sv);
2230
2231     PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2232
2233     if (amtp && AMT_AMAGIC(amtp)) {
2234         int i;
2235         for (i = 1; i < NofAMmeth; i++) {
2236             CV * const cv = amtp->table[i];
2237             if (cv) {
2238                 SvREFCNT_dec(MUTABLE_SV(cv));
2239                 amtp->table[i] = NULL;
2240             }
2241         }
2242     }
2243  return 0;
2244 }
2245
2246 /* Updates and caches the CV's */
2247 /* Returns:
2248  * 1 on success and there is some overload
2249  * 0 if there is no overload
2250  * -1 if some error occurred and it couldn't croak
2251  */
2252
2253 int
2254 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2255 {
2256   dVAR;
2257   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2258   AMT amt;
2259   const struct mro_meta* stash_meta = HvMROMETA(stash);
2260   U32 newgen;
2261
2262   PERL_ARGS_ASSERT_GV_AMUPDATE;
2263
2264   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2265   if (mg) {
2266       const AMT * const amtp = (AMT*)mg->mg_ptr;
2267       if (amtp->was_ok_am == PL_amagic_generation
2268           && amtp->was_ok_sub == newgen) {
2269           return AMT_OVERLOADED(amtp) ? 1 : 0;
2270       }
2271       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2272   }
2273
2274   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2275
2276   Zero(&amt,1,AMT);
2277   amt.was_ok_am = PL_amagic_generation;
2278   amt.was_ok_sub = newgen;
2279   amt.fallback = AMGfallNO;
2280   amt.flags = 0;
2281
2282   {
2283     int filled = 0, have_ovl = 0;
2284     int i, lim = 1;
2285
2286     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2287
2288     /* Try to find via inheritance. */
2289     GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2290     SV * const sv = gv ? GvSV(gv) : NULL;
2291     CV* cv;
2292
2293     if (!gv)
2294         lim = DESTROY_amg;              /* Skip overloading entries. */
2295 #ifdef PERL_DONT_CREATE_GVSV
2296     else if (!sv) {
2297         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
2298     }
2299 #endif
2300     else if (SvTRUE(sv))
2301         amt.fallback=AMGfallYES;
2302     else if (SvOK(sv))
2303         amt.fallback=AMGfallNEVER;
2304
2305     for (i = 1; i < lim; i++)
2306         amt.table[i] = NULL;
2307     for (; i < NofAMmeth; i++) {
2308         const char * const cooky = PL_AMG_names[i];
2309         /* Human-readable form, for debugging: */
2310         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
2311         const STRLEN l = PL_AMG_namelens[i];
2312
2313         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2314                      cp, HvNAME_get(stash)) );
2315         /* don't fill the cache while looking up!
2316            Creation of inheritance stubs in intermediate packages may
2317            conflict with the logic of runtime method substitution.
2318            Indeed, for inheritance A -> B -> C, if C overloads "+0",
2319            then we could have created stubs for "(+0" in A and C too.
2320            But if B overloads "bool", we may want to use it for
2321            numifying instead of C's "+0". */
2322         if (i >= DESTROY_amg)
2323             gv = Perl_gv_fetchmeth_pvn_autoload(aTHX_ stash, cooky, l, 0, 0);
2324         else                            /* Autoload taken care of below */
2325             gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2326         cv = 0;
2327         if (gv && (cv = GvCV(gv))) {
2328             if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
2329               const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
2330               if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
2331                && strEQ(hvname, "overload")) {
2332                 /* This is a hack to support autoloading..., while
2333                    knowing *which* methods were declared as overloaded. */
2334                 /* GvSV contains the name of the method. */
2335                 GV *ngv = NULL;
2336                 SV *gvsv = GvSV(gv);
2337
2338                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2339                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
2340                              (void*)GvSV(gv), cp, HvNAME(stash)) );
2341                 if (!gvsv || !SvPOK(gvsv)
2342                     || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2343                 {
2344                     /* Can be an import stub (created by "can"). */
2345                     if (destructing) {
2346                         return -1;
2347                     }
2348                     else {
2349                         const SV * const name = (gvsv && SvPOK(gvsv))
2350                                                     ? gvsv
2351                                                     : newSVpvs_flags("???", SVs_TEMP);
2352                         Perl_croak(aTHX_ "%s method \"%"SVf256
2353                                     "\" overloading \"%s\" "\
2354                                     "in package \"%"HEKf256"\"",
2355                                    (GvCVGEN(gv) ? "Stub found while resolving"
2356                                     : "Can't resolve"),
2357                                    SVfARG(name), cp,
2358                                    HEKfARG(
2359                                         HvNAME_HEK(stash)
2360                                    ));
2361                     }
2362                 }
2363                 cv = GvCV(gv = ngv);
2364               }
2365             }
2366             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2367                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2368                          GvNAME(CvGV(cv))) );
2369             filled = 1;
2370             if (i < DESTROY_amg)
2371                 have_ovl = 1;
2372         } else if (gv) {                /* Autoloaded... */
2373             cv = MUTABLE_CV(gv);
2374             filled = 1;
2375         }
2376         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2377     }
2378     if (filled) {
2379       AMT_AMAGIC_on(&amt);
2380       if (have_ovl)
2381           AMT_OVERLOADED_on(&amt);
2382       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2383                                                 (char*)&amt, sizeof(AMT));
2384       return have_ovl;
2385     }
2386   }
2387   /* Here we have no table: */
2388   /* no_table: */
2389   AMT_AMAGIC_off(&amt);
2390   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2391                                                 (char*)&amt, sizeof(AMTS));
2392   return 0;
2393 }
2394
2395
2396 CV*
2397 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2398 {
2399     dVAR;
2400     MAGIC *mg;
2401     AMT *amtp;
2402     U32 newgen;
2403     struct mro_meta* stash_meta;
2404
2405     if (!stash || !HvNAME_get(stash))
2406         return NULL;
2407
2408     stash_meta = HvMROMETA(stash);
2409     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2410
2411     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2412     if (!mg) {
2413       do_update:
2414         /* If we're looking up a destructor to invoke, we must avoid
2415          * that Gv_AMupdate croaks, because we might be dying already */
2416         if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
2417             /* and if it didn't found a destructor, we fall back
2418              * to a simpler method that will only look for the
2419              * destructor instead of the whole magic */
2420             if (id == DESTROY_amg) {
2421                 GV * const gv = gv_fetchmethod(stash, "DESTROY");
2422                 if (gv)
2423                     return GvCV(gv);
2424             }
2425             return NULL;
2426         }
2427         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2428     }
2429     assert(mg);
2430     amtp = (AMT*)mg->mg_ptr;
2431     if ( amtp->was_ok_am != PL_amagic_generation
2432          || amtp->was_ok_sub != newgen )
2433         goto do_update;
2434     if (AMT_AMAGIC(amtp)) {
2435         CV * const ret = amtp->table[id];
2436         if (ret && isGV(ret)) {         /* Autoloading stab */
2437             /* Passing it through may have resulted in a warning
2438                "Inherited AUTOLOAD for a non-method deprecated", since
2439                our caller is going through a function call, not a method call.
2440                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2441             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2442
2443             if (gv && GvCV(gv))
2444                 return GvCV(gv);
2445         }
2446         return ret;
2447     }
2448
2449     return NULL;
2450 }
2451
2452
2453 /* Implement tryAMAGICun_MG macro.
2454    Do get magic, then see if the stack arg is overloaded and if so call it.
2455    Flags:
2456         AMGf_set     return the arg using SETs rather than assigning to
2457                      the targ
2458         AMGf_numeric apply sv_2num to the stack arg.
2459 */
2460
2461 bool
2462 Perl_try_amagic_un(pTHX_ int method, int flags) {
2463     dVAR;
2464     dSP;
2465     SV* tmpsv;
2466     SV* const arg = TOPs;
2467
2468     SvGETMAGIC(arg);
2469
2470     if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2471                                               AMGf_noright | AMGf_unary))) {
2472         if (flags & AMGf_set) {
2473             SETs(tmpsv);
2474         }
2475         else {
2476             dTARGET;
2477             if (SvPADMY(TARG)) {
2478                 sv_setsv(TARG, tmpsv);
2479                 SETTARG;
2480             }
2481             else
2482                 SETs(tmpsv);
2483         }
2484         PUTBACK;
2485         return TRUE;
2486     }
2487
2488     if ((flags & AMGf_numeric) && SvROK(arg))
2489         *sp = sv_2num(arg);
2490     return FALSE;
2491 }
2492
2493
2494 /* Implement tryAMAGICbin_MG macro.
2495    Do get magic, then see if the two stack args are overloaded and if so
2496    call it.
2497    Flags:
2498         AMGf_set     return the arg using SETs rather than assigning to
2499                      the targ
2500         AMGf_assign  op may be called as mutator (eg +=)
2501         AMGf_numeric apply sv_2num to the stack arg.
2502 */
2503
2504 bool
2505 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2506     dVAR;
2507     dSP;
2508     SV* const left = TOPm1s;
2509     SV* const right = TOPs;
2510
2511     SvGETMAGIC(left);
2512     if (left != right)
2513         SvGETMAGIC(right);
2514
2515     if (SvAMAGIC(left) || SvAMAGIC(right)) {
2516         SV * const tmpsv = amagic_call(left, right, method,
2517                     ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2518         if (tmpsv) {
2519             if (flags & AMGf_set) {
2520                 (void)POPs;
2521                 SETs(tmpsv);
2522             }
2523             else {
2524                 dATARGET;
2525                 (void)POPs;
2526                 if (opASSIGN || SvPADMY(TARG)) {
2527                     sv_setsv(TARG, tmpsv);
2528                     SETTARG;
2529                 }
2530                 else
2531                     SETs(tmpsv);
2532             }
2533             PUTBACK;
2534             return TRUE;
2535         }
2536     }
2537     if(left==right && SvGMAGICAL(left)) {
2538         SV * const left = sv_newmortal();
2539         *(sp-1) = left;
2540         /* Print the uninitialized warning now, so it includes the vari-
2541            able name. */
2542         if (!SvOK(right)) {
2543             if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2544             sv_setsv_flags(left, &PL_sv_no, 0);
2545         }
2546         else sv_setsv_flags(left, right, 0);
2547         SvGETMAGIC(right);
2548     }
2549     if (flags & AMGf_numeric) {
2550         if (SvROK(TOPm1s))
2551             *(sp-1) = sv_2num(TOPm1s);
2552         if (SvROK(right))
2553             *sp     = sv_2num(right);
2554     }
2555     return FALSE;
2556 }
2557
2558 SV *
2559 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2560     SV *tmpsv = NULL;
2561
2562     PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2563
2564     while (SvAMAGIC(ref) && 
2565            (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2566                                 AMGf_noright | AMGf_unary))) { 
2567         if (!SvROK(tmpsv))
2568             Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2569         if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2570             /* Bail out if it returns us the same reference.  */
2571             return tmpsv;
2572         }
2573         ref = tmpsv;
2574     }
2575     return tmpsv ? tmpsv : ref;
2576 }
2577
2578 SV*
2579 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2580 {
2581   dVAR;
2582   MAGIC *mg;
2583   CV *cv=NULL;
2584   CV **cvp=NULL, **ocvp=NULL;
2585   AMT *amtp=NULL, *oamtp=NULL;
2586   int off = 0, off1, lr = 0, notfound = 0;
2587   int postpr = 0, force_cpy = 0;
2588   int assign = AMGf_assign & flags;
2589   const int assignshift = assign ? 1 : 0;
2590   int use_default_op = 0;
2591 #ifdef DEBUGGING
2592   int fl=0;
2593 #endif
2594   HV* stash=NULL;
2595
2596   PERL_ARGS_ASSERT_AMAGIC_CALL;
2597
2598   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2599       SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2600
2601       if ( !lex_mask || !SvOK(lex_mask) )
2602           /* overloading lexically disabled */
2603           return NULL;
2604       else if ( lex_mask && SvPOK(lex_mask) ) {
2605           /* we have an entry in the hints hash, check if method has been
2606            * masked by overloading.pm */
2607           STRLEN len;
2608           const int offset = method / 8;
2609           const int bit    = method % 8;
2610           char *pv = SvPV(lex_mask, len);
2611
2612           /* Bit set, so this overloading operator is disabled */
2613           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2614               return NULL;
2615       }
2616   }
2617
2618   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2619       && (stash = SvSTASH(SvRV(left)))
2620       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2621       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2622                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2623                         : NULL))
2624       && ((cv = cvp[off=method+assignshift])
2625           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2626                                                           * usual method */
2627                   (
2628 #ifdef DEBUGGING
2629                    fl = 1,
2630 #endif
2631                    cv = cvp[off=method])))) {
2632     lr = -1;                    /* Call method for left argument */
2633   } else {
2634     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2635       int logic;
2636
2637       /* look for substituted methods */
2638       /* In all the covered cases we should be called with assign==0. */
2639          switch (method) {
2640          case inc_amg:
2641            force_cpy = 1;
2642            if ((cv = cvp[off=add_ass_amg])
2643                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2644              right = &PL_sv_yes; lr = -1; assign = 1;
2645            }
2646            break;
2647          case dec_amg:
2648            force_cpy = 1;
2649            if ((cv = cvp[off = subtr_ass_amg])
2650                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2651              right = &PL_sv_yes; lr = -1; assign = 1;
2652            }
2653            break;
2654          case bool__amg:
2655            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2656            break;
2657          case numer_amg:
2658            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2659            break;
2660          case string_amg:
2661            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2662            break;
2663          case not_amg:
2664            (void)((cv = cvp[off=bool__amg])
2665                   || (cv = cvp[off=numer_amg])
2666                   || (cv = cvp[off=string_amg]));
2667            if (cv)
2668                postpr = 1;
2669            break;
2670          case copy_amg:
2671            {
2672              /*
2673                   * SV* ref causes confusion with the interpreter variable of
2674                   * the same name
2675                   */
2676              SV* const tmpRef=SvRV(left);
2677              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2678                 /*
2679                  * Just to be extra cautious.  Maybe in some
2680                  * additional cases sv_setsv is safe, too.
2681                  */
2682                 SV* const newref = newSVsv(tmpRef);
2683                 SvOBJECT_on(newref);
2684                 /* As a bit of a source compatibility hack, SvAMAGIC() and
2685                    friends dereference an RV, to behave the same was as when
2686                    overloading was stored on the reference, not the referant.
2687                    Hence we can't use SvAMAGIC_on()
2688                 */
2689                 SvFLAGS(newref) |= SVf_AMAGIC;
2690                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2691                 return newref;
2692              }
2693            }
2694            break;
2695          case abs_amg:
2696            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2697                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2698              SV* const nullsv=sv_2mortal(newSViv(0));
2699              if (off1==lt_amg) {
2700                SV* const lessp = amagic_call(left,nullsv,
2701                                        lt_amg,AMGf_noright);
2702                logic = SvTRUE(lessp);
2703              } else {
2704                SV* const lessp = amagic_call(left,nullsv,
2705                                        ncmp_amg,AMGf_noright);
2706                logic = (SvNV(lessp) < 0);
2707              }
2708              if (logic) {
2709                if (off==subtr_amg) {
2710                  right = left;
2711                  left = nullsv;
2712                  lr = 1;
2713                }
2714              } else {
2715                return left;
2716              }
2717            }
2718            break;
2719          case neg_amg:
2720            if ((cv = cvp[off=subtr_amg])) {
2721              right = left;
2722              left = sv_2mortal(newSViv(0));
2723              lr = 1;
2724            }
2725            break;
2726          case int_amg:
2727          case iter_amg:                 /* XXXX Eventually should do to_gv. */
2728          case ftest_amg:                /* XXXX Eventually should do to_gv. */
2729          case regexp_amg:
2730              /* FAIL safe */
2731              return NULL;       /* Delegate operation to standard mechanisms. */
2732              break;
2733          case to_sv_amg:
2734          case to_av_amg:
2735          case to_hv_amg:
2736          case to_gv_amg:
2737          case to_cv_amg:
2738              /* FAIL safe */
2739              return left;       /* Delegate operation to standard mechanisms. */
2740              break;
2741          default:
2742            goto not_found;
2743          }
2744          if (!cv) goto not_found;
2745     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2746                && (stash = SvSTASH(SvRV(right)))
2747                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2748                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2749                           ? (amtp = (AMT*)mg->mg_ptr)->table
2750                           : NULL))
2751                && (cv = cvp[off=method])) { /* Method for right
2752                                              * argument found */
2753       lr=1;
2754     } else if (((cvp && amtp->fallback > AMGfallNEVER)
2755                 || (ocvp && oamtp->fallback > AMGfallNEVER))
2756                && !(flags & AMGf_unary)) {
2757                                 /* We look for substitution for
2758                                  * comparison operations and
2759                                  * concatenation */
2760       if (method==concat_amg || method==concat_ass_amg
2761           || method==repeat_amg || method==repeat_ass_amg) {
2762         return NULL;            /* Delegate operation to string conversion */
2763       }
2764       off = -1;
2765       switch (method) {
2766          case lt_amg:
2767          case le_amg:
2768          case gt_amg:
2769          case ge_amg:
2770          case eq_amg:
2771          case ne_amg:
2772              off = ncmp_amg;
2773              break;
2774          case slt_amg:
2775          case sle_amg:
2776          case sgt_amg:
2777          case sge_amg:
2778          case seq_amg:
2779          case sne_amg:
2780              off = scmp_amg;
2781              break;
2782          }
2783       if (off != -1) {
2784           if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2785               cv = ocvp[off];
2786               lr = -1;
2787           }
2788           if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2789               cv = cvp[off];
2790               lr = 1;
2791           }
2792       }
2793       if (cv)
2794           postpr = 1;
2795       else
2796           goto not_found;
2797     } else {
2798     not_found:                  /* No method found, either report or croak */
2799       switch (method) {
2800          case to_sv_amg:
2801          case to_av_amg:
2802          case to_hv_amg:
2803          case to_gv_amg:
2804          case to_cv_amg:
2805              /* FAIL safe */
2806              return left;       /* Delegate operation to standard mechanisms. */
2807              break;
2808       }
2809       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2810         notfound = 1; lr = -1;
2811       } else if (cvp && (cv=cvp[nomethod_amg])) {
2812         notfound = 1; lr = 1;
2813       } else if ((use_default_op =
2814                   (!ocvp || oamtp->fallback >= AMGfallYES)
2815                   && (!cvp || amtp->fallback >= AMGfallYES))
2816                  && !DEBUG_o_TEST) {
2817         /* Skip generating the "no method found" message.  */
2818         return NULL;
2819       } else {
2820         SV *msg;
2821         if (off==-1) off=method;
2822         msg = sv_2mortal(Perl_newSVpvf(aTHX_
2823                       "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
2824                       AMG_id2name(method + assignshift),
2825                       (flags & AMGf_unary ? " " : "\n\tleft "),
2826                       SvAMAGIC(left)?
2827                         "in overloaded package ":
2828                         "has no overloaded magic",
2829                       SvAMAGIC(left)?
2830                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
2831                         SVfARG(&PL_sv_no),
2832                       SvAMAGIC(right)?
2833                         ",\n\tright argument in overloaded package ":
2834                         (flags & AMGf_unary
2835                          ? ""
2836                          : ",\n\tright argument has no overloaded magic"),
2837                       SvAMAGIC(right)?
2838                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
2839                         SVfARG(&PL_sv_no)));
2840         if (use_default_op) {
2841           DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
2842         } else {
2843           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2844         }
2845         return NULL;
2846       }
2847       force_cpy = force_cpy || assign;
2848     }
2849   }
2850 #ifdef DEBUGGING
2851   if (!notfound) {
2852     DEBUG_o(Perl_deb(aTHX_
2853                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
2854                      AMG_id2name(off),
2855                      method+assignshift==off? "" :
2856                      " (initially \"",
2857                      method+assignshift==off? "" :
2858                      AMG_id2name(method+assignshift),
2859                      method+assignshift==off? "" : "\")",
2860                      flags & AMGf_unary? "" :
2861                      lr==1 ? " for right argument": " for left argument",
2862                      flags & AMGf_unary? " for argument" : "",
2863                      stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
2864                      fl? ",\n\tassignment variant used": "") );
2865   }
2866 #endif
2867     /* Since we use shallow copy during assignment, we need
2868      * to dublicate the contents, probably calling user-supplied
2869      * version of copy operator
2870      */
2871     /* We need to copy in following cases:
2872      * a) Assignment form was called.
2873      *          assignshift==1,  assign==T, method + 1 == off
2874      * b) Increment or decrement, called directly.
2875      *          assignshift==0,  assign==0, method + 0 == off
2876      * c) Increment or decrement, translated to assignment add/subtr.
2877      *          assignshift==0,  assign==T,
2878      *          force_cpy == T
2879      * d) Increment or decrement, translated to nomethod.
2880      *          assignshift==0,  assign==0,
2881      *          force_cpy == T
2882      * e) Assignment form translated to nomethod.
2883      *          assignshift==1,  assign==T, method + 1 != off
2884      *          force_cpy == T
2885      */
2886     /*  off is method, method+assignshift, or a result of opcode substitution.
2887      *  In the latter case assignshift==0, so only notfound case is important.
2888      */
2889   if (( (method + assignshift == off)
2890         && (assign || (method == inc_amg) || (method == dec_amg)))
2891       || force_cpy)
2892   {
2893       /* newSVsv does not behave as advertised, so we copy missing
2894        * information by hand */
2895       SV *tmpRef = SvRV(left);
2896       SV *rv_copy;
2897       if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
2898           SvRV_set(left, rv_copy);
2899           SvSETMAGIC(left);
2900           SvREFCNT_dec(tmpRef);  
2901       }
2902   }
2903
2904   {
2905     dSP;
2906     BINOP myop;
2907     SV* res;
2908     const bool oldcatch = CATCH_GET;
2909
2910     CATCH_SET(TRUE);
2911     Zero(&myop, 1, BINOP);
2912     myop.op_last = (OP *) &myop;
2913     myop.op_next = NULL;
2914     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
2915
2916     PUSHSTACKi(PERLSI_OVERLOAD);
2917     ENTER;
2918     SAVEOP();
2919     PL_op = (OP *) &myop;
2920     if (PERLDB_SUB && PL_curstash != PL_debstash)
2921         PL_op->op_private |= OPpENTERSUB_DB;
2922     PUTBACK;
2923     Perl_pp_pushmark(aTHX);
2924
2925     EXTEND(SP, notfound + 5);
2926     PUSHs(lr>0? right: left);
2927     PUSHs(lr>0? left: right);
2928     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
2929     if (notfound) {
2930       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
2931                            AMG_id2namelen(method + assignshift), SVs_TEMP));
2932     }
2933     PUSHs(MUTABLE_SV(cv));
2934     PUTBACK;
2935
2936     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
2937       CALLRUNOPS(aTHX);
2938     LEAVE;
2939     SPAGAIN;
2940
2941     res=POPs;
2942     PUTBACK;
2943     POPSTACK;
2944     CATCH_SET(oldcatch);
2945
2946     if (postpr) {
2947       int ans;
2948       switch (method) {
2949       case le_amg:
2950       case sle_amg:
2951         ans=SvIV(res)<=0; break;
2952       case lt_amg:
2953       case slt_amg:
2954         ans=SvIV(res)<0; break;
2955       case ge_amg:
2956       case sge_amg:
2957         ans=SvIV(res)>=0; break;
2958       case gt_amg:
2959       case sgt_amg:
2960         ans=SvIV(res)>0; break;
2961       case eq_amg:
2962       case seq_amg:
2963         ans=SvIV(res)==0; break;
2964       case ne_amg:
2965       case sne_amg:
2966         ans=SvIV(res)!=0; break;
2967       case inc_amg:
2968       case dec_amg:
2969         SvSetSV(left,res); return left;
2970       case not_amg:
2971         ans=!SvTRUE(res); break;
2972       default:
2973         ans=0; break;
2974       }
2975       return boolSV(ans);
2976     } else if (method==copy_amg) {
2977       if (!SvROK(res)) {
2978         Perl_croak(aTHX_ "Copy method did not return a reference");
2979       }
2980       return SvREFCNT_inc(SvRV(res));
2981     } else {
2982       return res;
2983     }
2984   }
2985 }
2986
2987 void
2988 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2989 {
2990     dVAR;
2991     U32 hash;
2992
2993     PERL_ARGS_ASSERT_GV_NAME_SET;
2994
2995     if (len > I32_MAX)
2996         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2997
2998     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2999         unshare_hek(GvNAME_HEK(gv));
3000     }
3001
3002     PERL_HASH(hash, name, len);
3003     GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3004 }
3005
3006 /*
3007 =for apidoc gv_try_downgrade
3008
3009 If the typeglob C<gv> can be expressed more succinctly, by having
3010 something other than a real GV in its place in the stash, replace it
3011 with the optimised form.  Basic requirements for this are that C<gv>
3012 is a real typeglob, is sufficiently ordinary, and is only referenced
3013 from its package.  This function is meant to be used when a GV has been
3014 looked up in part to see what was there, causing upgrading, but based
3015 on what was found it turns out that the real GV isn't required after all.
3016
3017 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3018
3019 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3020 sub, the typeglob is replaced with a scalar-reference placeholder that
3021 more compactly represents the same thing.
3022
3023 =cut
3024 */
3025
3026 void
3027 Perl_gv_try_downgrade(pTHX_ GV *gv)
3028 {
3029     HV *stash;
3030     CV *cv;
3031     HEK *namehek;
3032     SV **gvp;
3033     PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3034
3035     /* XXX Why and where does this leave dangling pointers during global
3036        destruction? */
3037     if (PL_phase == PERL_PHASE_DESTRUCT) return;
3038
3039     if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3040             !SvOBJECT(gv) && !SvREADONLY(gv) &&
3041             isGV_with_GP(gv) && GvGP(gv) &&
3042             !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3043             !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3044             GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3045         return;
3046     if (SvMAGICAL(gv)) {
3047         MAGIC *mg;
3048         /* only backref magic is allowed */
3049         if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3050             return;
3051         for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3052             if (mg->mg_type != PERL_MAGIC_backref)
3053                 return;
3054         }
3055     }
3056     cv = GvCV(gv);
3057     if (!cv) {
3058         HEK *gvnhek = GvNAME_HEK(gv);
3059         (void)hv_delete(stash, HEK_KEY(gvnhek),
3060             HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
3061     } else if (GvMULTI(gv) && cv &&
3062             !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3063             CvSTASH(cv) == stash && CvGV(cv) == gv &&
3064             CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3065             !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3066             (namehek = GvNAME_HEK(gv)) &&
3067             (gvp = hv_fetch(stash, HEK_KEY(namehek),
3068                         HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
3069             *gvp == (SV*)gv) {
3070         SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3071         SvREFCNT(gv) = 0;
3072         sv_clear((SV*)gv);
3073         SvREFCNT(gv) = 1;
3074         SvFLAGS(gv) = SVt_IV|SVf_ROK;
3075         SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3076                                 STRUCT_OFFSET(XPVIV, xiv_iv));
3077         SvRV_set(gv, value);
3078     }
3079 }
3080
3081 #include "XSUB.h"
3082
3083 static void
3084 core_xsub(pTHX_ CV* cv)
3085 {
3086     Perl_croak(aTHX_
3087        "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3088     );
3089 }
3090
3091 /*
3092  * Local variables:
3093  * c-indentation-style: bsd
3094  * c-basic-offset: 4
3095  * indent-tabs-mode: t
3096  * End:
3097  *
3098  * ex: set ts=8 sts=4 sw=4 noet:
3099  */