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