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