This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Expand AMG_CALLun_var() into all its users, and eliminate it.
[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                     stash = GvHV(gv) = newHV();
1076
1077                 if (!HvNAME_get(stash))
1078                     hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
1079             }
1080
1081             if (*name_cursor == ':')
1082                 name_cursor++;
1083             name_cursor++;
1084             name = name_cursor;
1085             if (name == name_end)
1086                 return gv
1087                     ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1088         }
1089     }
1090     len = name_cursor - name;
1091
1092     /* No stash in name, so see how we can default */
1093
1094     if (!stash) {
1095     no_stash:
1096         if (len && isIDFIRST_lazy(name)) {
1097             bool global = FALSE;
1098
1099             switch (len) {
1100             case 1:
1101                 if (*name == '_')
1102                     global = TRUE;
1103                 break;
1104             case 3:
1105                 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1106                     || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1107                     || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1108                     global = TRUE;
1109                 break;
1110             case 4:
1111                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1112                     && name[3] == 'V')
1113                     global = TRUE;
1114                 break;
1115             case 5:
1116                 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1117                     && name[3] == 'I' && name[4] == 'N')
1118                     global = TRUE;
1119                 break;
1120             case 6:
1121                 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1122                     &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1123                        ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1124                     global = TRUE;
1125                 break;
1126             case 7:
1127                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1128                     && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1129                     && name[6] == 'T')
1130                     global = TRUE;
1131                 break;
1132             }
1133
1134             if (global)
1135                 stash = PL_defstash;
1136             else if (IN_PERL_COMPILETIME) {
1137                 stash = PL_curstash;
1138                 if (add && (PL_hints & HINT_STRICT_VARS) &&
1139                     sv_type != SVt_PVCV &&
1140                     sv_type != SVt_PVGV &&
1141                     sv_type != SVt_PVFM &&
1142                     sv_type != SVt_PVIO &&
1143                     !(len == 1 && sv_type == SVt_PV &&
1144                       (*name == 'a' || *name == 'b')) )
1145                 {
1146                     gvp = (GV**)hv_fetch(stash,name,len,0);
1147                     if (!gvp ||
1148                         *gvp == (const GV *)&PL_sv_undef ||
1149                         SvTYPE(*gvp) != SVt_PVGV)
1150                     {
1151                         stash = NULL;
1152                     }
1153                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
1154                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1155                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1156                     {
1157                         /* diag_listed_as: Variable "%s" is not imported%s */
1158                         Perl_ck_warner_d(
1159                             aTHX_ packWARN(WARN_MISC),
1160                             "Variable \"%c%s\" is not imported",
1161                             sv_type == SVt_PVAV ? '@' :
1162                             sv_type == SVt_PVHV ? '%' : '$',
1163                             name);
1164                         if (GvCVu(*gvp))
1165                             Perl_ck_warner_d(
1166                                 aTHX_ packWARN(WARN_MISC),
1167                                 "\t(Did you mean &%s instead?)\n", name
1168                             );
1169                         stash = NULL;
1170                     }
1171                 }
1172             }
1173             else
1174                 stash = CopSTASH(PL_curcop);
1175         }
1176         else
1177             stash = PL_defstash;
1178     }
1179
1180     /* By this point we should have a stash and a name */
1181
1182     if (!stash) {
1183         if (add) {
1184             SV * const err = Perl_mess(aTHX_
1185                  "Global symbol \"%s%s\" requires explicit package name",
1186                  (sv_type == SVt_PV ? "$"
1187                   : sv_type == SVt_PVAV ? "@"
1188                   : sv_type == SVt_PVHV ? "%"
1189                   : ""), name);
1190             GV *gv;
1191             if (USE_UTF8_IN_NAMES)
1192                 SvUTF8_on(err);
1193             qerror(err);
1194             gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1195             if(!gv) {
1196                 /* symbol table under destruction */
1197                 return NULL;
1198             }   
1199             stash = GvHV(gv);
1200         }
1201         else
1202             return NULL;
1203     }
1204
1205     if (!SvREFCNT(stash))       /* symbol table under destruction */
1206         return NULL;
1207
1208     gvp = (GV**)hv_fetch(stash,name,len,add);
1209     if (!gvp || *gvp == (const GV *)&PL_sv_undef)
1210         return NULL;
1211     gv = *gvp;
1212     if (SvTYPE(gv) == SVt_PVGV) {
1213         if (add) {
1214             GvMULTI_on(gv);
1215             gv_init_sv(gv, sv_type);
1216             if (len == 1 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
1217                 if (*name == '!')
1218                     require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1219                 else if (*name == '-' || *name == '+')
1220                     require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1221             }
1222         }
1223         return gv;
1224     } else if (no_init) {
1225         return gv;
1226     } else if (no_expand && SvROK(gv)) {
1227         return gv;
1228     }
1229
1230     /* Adding a new symbol.
1231        Unless of course there was already something non-GV here, in which case
1232        we want to behave as if there was always a GV here, containing some sort
1233        of subroutine.
1234        Otherwise we run the risk of creating things like GvIO, which can cause
1235        subtle bugs. eg the one that tripped up SQL::Translator  */
1236
1237     faking_it = SvOK(gv);
1238
1239     if (add & GV_ADDWARN)
1240         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
1241     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
1242     gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type);
1243
1244     if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
1245                                             : (PL_dowarn & G_WARN_ON ) ) )
1246         GvMULTI_on(gv) ;
1247
1248     /* set up magic where warranted */
1249     if (stash != PL_defstash) { /* not the main stash */
1250         /* We only have to check for four names here: EXPORT, ISA, OVERLOAD
1251            and VERSION. All the others apply only to the main stash. */
1252         if (len > 1) {
1253             const char * const name2 = name + 1;
1254             switch (*name) {
1255             case 'E':
1256                 if (strnEQ(name2, "XPORT", 5))
1257                     GvMULTI_on(gv);
1258                 break;
1259             case 'I':
1260                 if (strEQ(name2, "SA"))
1261                     gv_magicalize_isa(gv);
1262                 break;
1263             case 'O':
1264                 if (strEQ(name2, "VERLOAD"))
1265                     gv_magicalize_overload(gv);
1266                 break;
1267             case 'V':
1268                 if (strEQ(name2, "ERSION"))
1269                     GvMULTI_on(gv);
1270                 break;
1271             }
1272         }
1273     }
1274     else if (len > 1) {
1275 #ifndef EBCDIC
1276         if (*name > 'V' ) {
1277             NOOP;
1278             /* Nothing else to do.
1279                The compiler will probably turn the switch statement into a
1280                branch table. Make sure we avoid even that small overhead for
1281                the common case of lower case variable names.  */
1282         } else
1283 #endif
1284         {
1285             const char * const name2 = name + 1;
1286             switch (*name) {
1287             case 'A':
1288                 if (strEQ(name2, "RGV")) {
1289                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1290                 }
1291                 else if (strEQ(name2, "RGVOUT")) {
1292                     GvMULTI_on(gv);
1293                 }
1294                 break;
1295             case 'E':
1296                 if (strnEQ(name2, "XPORT", 5))
1297                     GvMULTI_on(gv);
1298                 break;
1299             case 'I':
1300                 if (strEQ(name2, "SA")) {
1301                     gv_magicalize_isa(gv);
1302                 }
1303                 break;
1304             case 'O':
1305                 if (strEQ(name2, "VERLOAD")) {
1306                     gv_magicalize_overload(gv);
1307                 }
1308                 break;
1309             case 'S':
1310                 if (strEQ(name2, "IG")) {
1311                     HV *hv;
1312                     I32 i;
1313                     if (!PL_psig_name) {
1314                         Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1315                         Newxz(PL_psig_pend, SIG_SIZE, int);
1316                         PL_psig_ptr = PL_psig_name + SIG_SIZE;
1317                     } else {
1318                         /* I think that the only way to get here is to re-use an
1319                            embedded perl interpreter, where the previous
1320                            use didn't clean up fully because
1321                            PL_perl_destruct_level was 0. I'm not sure that we
1322                            "support" that, in that I suspect in that scenario
1323                            there are sufficient other garbage values left in the
1324                            interpreter structure that something else will crash
1325                            before we get here. I suspect that this is one of
1326                            those "doctor, it hurts when I do this" bugs.  */
1327                         Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1328                         Zero(PL_psig_pend, SIG_SIZE, int);
1329                     }
1330                     GvMULTI_on(gv);
1331                     hv = GvHVn(gv);
1332                     hv_magic(hv, NULL, PERL_MAGIC_sig);
1333                     for (i = 1; i < SIG_SIZE; i++) {
1334                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1335                         if (init)
1336                             sv_setsv(*init, &PL_sv_undef);
1337                     }
1338                 }
1339                 break;
1340             case 'V':
1341                 if (strEQ(name2, "ERSION"))
1342                     GvMULTI_on(gv);
1343                 break;
1344             case '\003':        /* $^CHILD_ERROR_NATIVE */
1345                 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1346                     goto magicalize;
1347                 break;
1348             case '\005':        /* $^ENCODING */
1349                 if (strEQ(name2, "NCODING"))
1350                     goto magicalize;
1351                 break;
1352             case '\015':        /* $^MATCH */
1353                 if (strEQ(name2, "ATCH"))
1354                     goto magicalize;
1355             case '\017':        /* $^OPEN */
1356                 if (strEQ(name2, "PEN"))
1357                     goto magicalize;
1358                 break;
1359             case '\020':        /* $^PREMATCH  $^POSTMATCH */
1360                 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1361                     goto magicalize;  
1362             case '\024':        /* ${^TAINT} */
1363                 if (strEQ(name2, "AINT"))
1364                     goto ro_magicalize;
1365                 break;
1366             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
1367                 if (strEQ(name2, "NICODE"))
1368                     goto ro_magicalize;
1369                 if (strEQ(name2, "TF8LOCALE"))
1370                     goto ro_magicalize;
1371                 if (strEQ(name2, "TF8CACHE"))
1372                     goto magicalize;
1373                 break;
1374             case '\027':        /* $^WARNING_BITS */
1375                 if (strEQ(name2, "ARNING_BITS"))
1376                     goto magicalize;
1377                 break;
1378             case '1':
1379             case '2':
1380             case '3':
1381             case '4':
1382             case '5':
1383             case '6':
1384             case '7':
1385             case '8':
1386             case '9':
1387             {
1388                 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1389                    this test  */
1390                 /* This snippet is taken from is_gv_magical */
1391                 const char *end = name + len;
1392                 while (--end > name) {
1393                     if (!isDIGIT(*end)) return gv;
1394                 }
1395                 goto magicalize;
1396             }
1397             }
1398         }
1399     } else {
1400         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
1401            be case '\0' in this switch statement (ie a default case)  */
1402         switch (*name) {
1403         case '&':               /* $& */
1404         case '`':               /* $` */
1405         case '\'':              /* $' */
1406             if (
1407                 sv_type == SVt_PVAV ||
1408                 sv_type == SVt_PVHV ||
1409                 sv_type == SVt_PVCV ||
1410                 sv_type == SVt_PVFM ||
1411                 sv_type == SVt_PVIO
1412                 ) { break; }
1413             PL_sawampersand = TRUE;
1414             goto magicalize;
1415
1416         case ':':               /* $: */
1417             sv_setpv(GvSVn(gv),PL_chopset);
1418             goto magicalize;
1419
1420         case '?':               /* $? */
1421 #ifdef COMPLEX_STATUS
1422             SvUPGRADE(GvSVn(gv), SVt_PVLV);
1423 #endif
1424             goto magicalize;
1425
1426         case '!':               /* $! */
1427             GvMULTI_on(gv);
1428             /* If %! has been used, automatically load Errno.pm. */
1429
1430             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1431
1432             /* magicalization must be done before require_tie_mod is called */
1433             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1434                 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1435
1436             break;
1437         case '-':               /* $- */
1438         case '+':               /* $+ */
1439         GvMULTI_on(gv); /* no used once warnings here */
1440         {
1441             AV* const av = GvAVn(gv);
1442             SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1443
1444             sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1445             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1446             if (avc)
1447                 SvREADONLY_on(GvSVn(gv));
1448             SvREADONLY_on(av);
1449
1450             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1451                 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1452
1453             break;
1454         }
1455         case '*':               /* $* */
1456         case '#':               /* $# */
1457             if (sv_type == SVt_PV)
1458                 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1459                                  "$%c is no longer supported", *name);
1460             break;
1461         case '|':               /* $| */
1462             sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1463             goto magicalize;
1464
1465         case '\010':    /* $^H */
1466             {
1467                 HV *const hv = GvHVn(gv);
1468                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1469             }
1470             goto magicalize;
1471         case '\023':    /* $^S */
1472         ro_magicalize:
1473             SvREADONLY_on(GvSVn(gv));
1474             /* FALL THROUGH */
1475         case '0':               /* $0 */
1476         case '1':               /* $1 */
1477         case '2':               /* $2 */
1478         case '3':               /* $3 */
1479         case '4':               /* $4 */
1480         case '5':               /* $5 */
1481         case '6':               /* $6 */
1482         case '7':               /* $7 */
1483         case '8':               /* $8 */
1484         case '9':               /* $9 */
1485         case '[':               /* $[ */
1486         case '^':               /* $^ */
1487         case '~':               /* $~ */
1488         case '=':               /* $= */
1489         case '%':               /* $% */
1490         case '.':               /* $. */
1491         case '(':               /* $( */
1492         case ')':               /* $) */
1493         case '<':               /* $< */
1494         case '>':               /* $> */
1495         case '\\':              /* $\ */
1496         case '/':               /* $/ */
1497         case '\001':    /* $^A */
1498         case '\003':    /* $^C */
1499         case '\004':    /* $^D */
1500         case '\005':    /* $^E */
1501         case '\006':    /* $^F */
1502         case '\011':    /* $^I, NOT \t in EBCDIC */
1503         case '\016':    /* $^N */
1504         case '\017':    /* $^O */
1505         case '\020':    /* $^P */
1506         case '\024':    /* $^T */
1507         case '\027':    /* $^W */
1508         magicalize:
1509             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1510             break;
1511
1512         case '\014':    /* $^L */
1513             sv_setpvs(GvSVn(gv),"\f");
1514             PL_formfeed = GvSVn(gv);
1515             break;
1516         case ';':               /* $; */
1517             sv_setpvs(GvSVn(gv),"\034");
1518             break;
1519         case ']':               /* $] */
1520         {
1521             SV * const sv = GvSVn(gv);
1522             if (!sv_derived_from(PL_patchlevel, "version"))
1523                 upg_version(PL_patchlevel, TRUE);
1524             GvSV(gv) = vnumify(PL_patchlevel);
1525             SvREADONLY_on(GvSV(gv));
1526             SvREFCNT_dec(sv);
1527         }
1528         break;
1529         case '\026':    /* $^V */
1530         {
1531             SV * const sv = GvSVn(gv);
1532             GvSV(gv) = new_version(PL_patchlevel);
1533             SvREADONLY_on(GvSV(gv));
1534             SvREFCNT_dec(sv);
1535         }
1536         break;
1537         }
1538     }
1539     return gv;
1540 }
1541
1542 void
1543 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1544 {
1545     const char *name;
1546     STRLEN namelen;
1547     const HV * const hv = GvSTASH(gv);
1548
1549     PERL_ARGS_ASSERT_GV_FULLNAME4;
1550
1551     if (!hv) {
1552         SvOK_off(sv);
1553         return;
1554     }
1555     sv_setpv(sv, prefix ? prefix : "");
1556
1557     name = HvNAME_get(hv);
1558     if (name) {
1559         namelen = HvNAMELEN_get(hv);
1560     } else {
1561         name = "__ANON__";
1562         namelen = 8;
1563     }
1564
1565     if (keepmain || strNE(name, "main")) {
1566         sv_catpvn(sv,name,namelen);
1567         sv_catpvs(sv,"::");
1568     }
1569     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1570 }
1571
1572 void
1573 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1574 {
1575     const GV * const egv = GvEGVx(gv);
1576
1577     PERL_ARGS_ASSERT_GV_EFULLNAME4;
1578
1579     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1580 }
1581
1582 void
1583 Perl_gv_check(pTHX_ const HV *stash)
1584 {
1585     dVAR;
1586     register I32 i;
1587
1588     PERL_ARGS_ASSERT_GV_CHECK;
1589
1590     if (!HvARRAY(stash))
1591         return;
1592     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1593         const HE *entry;
1594         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1595             register GV *gv;
1596             HV *hv;
1597             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1598                 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
1599             {
1600                 if (hv != PL_defstash && hv != stash)
1601                      gv_check(hv);              /* nested package */
1602             }
1603             else if (isALPHA(*HeKEY(entry))) {
1604                 const char *file;
1605                 gv = MUTABLE_GV(HeVAL(entry));
1606                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1607                     continue;
1608                 file = GvFILE(gv);
1609                 CopLINE_set(PL_curcop, GvLINE(gv));
1610 #ifdef USE_ITHREADS
1611                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
1612 #else
1613                 CopFILEGV(PL_curcop)
1614                     = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
1615 #endif
1616                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1617                         "Name \"%s::%s\" used only once: possible typo",
1618                         HvNAME_get(stash), GvNAME(gv));
1619             }
1620         }
1621     }
1622 }
1623
1624 GV *
1625 Perl_newGVgen(pTHX_ const char *pack)
1626 {
1627     dVAR;
1628
1629     PERL_ARGS_ASSERT_NEWGVGEN;
1630
1631     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1632                       GV_ADD, SVt_PVGV);
1633 }
1634
1635 /* hopefully this is only called on local symbol table entries */
1636
1637 GP*
1638 Perl_gp_ref(pTHX_ GP *gp)
1639 {
1640     dVAR;
1641     if (!gp)
1642         return NULL;
1643     gp->gp_refcnt++;
1644     if (gp->gp_cv) {
1645         if (gp->gp_cvgen) {
1646             /* If the GP they asked for a reference to contains
1647                a method cache entry, clear it first, so that we
1648                don't infect them with our cached entry */
1649             SvREFCNT_dec(gp->gp_cv);
1650             gp->gp_cv = NULL;
1651             gp->gp_cvgen = 0;
1652         }
1653     }
1654     return gp;
1655 }
1656
1657 void
1658 Perl_gp_free(pTHX_ GV *gv)
1659 {
1660     dVAR;
1661     GP* gp;
1662
1663     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1664         return;
1665     if (gp->gp_refcnt == 0) {
1666         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1667                          "Attempt to free unreferenced glob pointers"
1668                          pTHX__FORMAT pTHX__VALUE);
1669         return;
1670     }
1671     if (--gp->gp_refcnt > 0) {
1672         if (gp->gp_egv == gv)
1673             gp->gp_egv = 0;
1674         GvGP(gv) = 0;
1675         return;
1676     }
1677
1678     if (gp->gp_file_hek)
1679         unshare_hek(gp->gp_file_hek);
1680     SvREFCNT_dec(gp->gp_sv);
1681     SvREFCNT_dec(gp->gp_av);
1682     /* FIXME - another reference loop GV -> symtab -> GV ?
1683        Somehow gp->gp_hv can end up pointing at freed garbage.  */
1684     if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1685         const char *hvname = HvNAME_get(gp->gp_hv);
1686         if (PL_stashcache && hvname)
1687             (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1688                       G_DISCARD);
1689         SvREFCNT_dec(gp->gp_hv);
1690     }
1691     SvREFCNT_dec(gp->gp_io);
1692     SvREFCNT_dec(gp->gp_cv);
1693     SvREFCNT_dec(gp->gp_form);
1694
1695     Safefree(gp);
1696     GvGP(gv) = 0;
1697 }
1698
1699 int
1700 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1701 {
1702     AMT * const amtp = (AMT*)mg->mg_ptr;
1703     PERL_UNUSED_ARG(sv);
1704
1705     PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
1706
1707     if (amtp && AMT_AMAGIC(amtp)) {
1708         int i;
1709         for (i = 1; i < NofAMmeth; i++) {
1710             CV * const cv = amtp->table[i];
1711             if (cv) {
1712                 SvREFCNT_dec(MUTABLE_SV(cv));
1713                 amtp->table[i] = NULL;
1714             }
1715         }
1716     }
1717  return 0;
1718 }
1719
1720 /* Updates and caches the CV's */
1721 /* Returns:
1722  * 1 on success and there is some overload
1723  * 0 if there is no overload
1724  * -1 if some error occurred and it couldn't croak
1725  */
1726
1727 int
1728 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
1729 {
1730   dVAR;
1731   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
1732   AMT amt;
1733   const struct mro_meta* stash_meta = HvMROMETA(stash);
1734   U32 newgen;
1735
1736   PERL_ARGS_ASSERT_GV_AMUPDATE;
1737
1738   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
1739   if (mg) {
1740       const AMT * const amtp = (AMT*)mg->mg_ptr;
1741       if (amtp->was_ok_am == PL_amagic_generation
1742           && amtp->was_ok_sub == newgen) {
1743           return AMT_OVERLOADED(amtp) ? 1 : 0;
1744       }
1745       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
1746   }
1747
1748   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1749
1750   Zero(&amt,1,AMT);
1751   amt.was_ok_am = PL_amagic_generation;
1752   amt.was_ok_sub = newgen;
1753   amt.fallback = AMGfallNO;
1754   amt.flags = 0;
1755
1756   {
1757     int filled = 0, have_ovl = 0;
1758     int i, lim = 1;
1759
1760     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1761
1762     /* Try to find via inheritance. */
1763     GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1764     SV * const sv = gv ? GvSV(gv) : NULL;
1765     CV* cv;
1766
1767     if (!gv)
1768         lim = DESTROY_amg;              /* Skip overloading entries. */
1769 #ifdef PERL_DONT_CREATE_GVSV
1770     else if (!sv) {
1771         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
1772     }
1773 #endif
1774     else if (SvTRUE(sv))
1775         amt.fallback=AMGfallYES;
1776     else if (SvOK(sv))
1777         amt.fallback=AMGfallNEVER;
1778
1779     for (i = 1; i < lim; i++)
1780         amt.table[i] = NULL;
1781     for (; i < NofAMmeth; i++) {
1782         const char * const cooky = PL_AMG_names[i];
1783         /* Human-readable form, for debugging: */
1784         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1785         const STRLEN l = PL_AMG_namelens[i];
1786
1787         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1788                      cp, HvNAME_get(stash)) );
1789         /* don't fill the cache while looking up!
1790            Creation of inheritance stubs in intermediate packages may
1791            conflict with the logic of runtime method substitution.
1792            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1793            then we could have created stubs for "(+0" in A and C too.
1794            But if B overloads "bool", we may want to use it for
1795            numifying instead of C's "+0". */
1796         if (i >= DESTROY_amg)
1797             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1798         else                            /* Autoload taken care of below */
1799             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1800         cv = 0;
1801         if (gv && (cv = GvCV(gv))) {
1802             const char *hvname;
1803             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1804                 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1805                 /* This is a hack to support autoloading..., while
1806                    knowing *which* methods were declared as overloaded. */
1807                 /* GvSV contains the name of the method. */
1808                 GV *ngv = NULL;
1809                 SV *gvsv = GvSV(gv);
1810
1811                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1812                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
1813                              (void*)GvSV(gv), cp, hvname) );
1814                 if (!gvsv || !SvPOK(gvsv)
1815                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1816                                                        FALSE)))
1817                 {
1818                     /* Can be an import stub (created by "can"). */
1819                     if (destructing) {
1820                         return -1;
1821                     }
1822                     else {
1823                         const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
1824                         Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1825                                     "in package \"%.256s\"",
1826                                    (GvCVGEN(gv) ? "Stub found while resolving"
1827                                     : "Can't resolve"),
1828                                    name, cp, hvname);
1829                     }
1830                 }
1831                 cv = GvCV(gv = ngv);
1832             }
1833             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1834                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1835                          GvNAME(CvGV(cv))) );
1836             filled = 1;
1837             if (i < DESTROY_amg)
1838                 have_ovl = 1;
1839         } else if (gv) {                /* Autoloaded... */
1840             cv = MUTABLE_CV(gv);
1841             filled = 1;
1842         }
1843         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
1844     }
1845     if (filled) {
1846       AMT_AMAGIC_on(&amt);
1847       if (have_ovl)
1848           AMT_OVERLOADED_on(&amt);
1849       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
1850                                                 (char*)&amt, sizeof(AMT));
1851       return have_ovl;
1852     }
1853   }
1854   /* Here we have no table: */
1855   /* no_table: */
1856   AMT_AMAGIC_off(&amt);
1857   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
1858                                                 (char*)&amt, sizeof(AMTS));
1859   return 0;
1860 }
1861
1862
1863 CV*
1864 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1865 {
1866     dVAR;
1867     MAGIC *mg;
1868     AMT *amtp;
1869     U32 newgen;
1870     struct mro_meta* stash_meta;
1871
1872     if (!stash || !HvNAME_get(stash))
1873         return NULL;
1874
1875     stash_meta = HvMROMETA(stash);
1876     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
1877
1878     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
1879     if (!mg) {
1880       do_update:
1881         /* If we're looking up a destructor to invoke, we must avoid
1882          * that Gv_AMupdate croaks, because we might be dying already */
1883         if (Gv_AMupdate(stash, id == DESTROY_amg) == -1) {
1884             /* and if it didn't found a destructor, we fall back
1885              * to a simpler method that will only look for the
1886              * destructor instead of the whole magic */
1887             if (id == DESTROY_amg) {
1888                 GV * const gv = gv_fetchmethod(stash, "DESTROY");
1889                 if (gv)
1890                     return GvCV(gv);
1891             }
1892             return NULL;
1893         }
1894         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
1895     }
1896     assert(mg);
1897     amtp = (AMT*)mg->mg_ptr;
1898     if ( amtp->was_ok_am != PL_amagic_generation
1899          || amtp->was_ok_sub != newgen )
1900         goto do_update;
1901     if (AMT_AMAGIC(amtp)) {
1902         CV * const ret = amtp->table[id];
1903         if (ret && isGV(ret)) {         /* Autoloading stab */
1904             /* Passing it through may have resulted in a warning
1905                "Inherited AUTOLOAD for a non-method deprecated", since
1906                our caller is going through a function call, not a method call.
1907                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1908             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1909
1910             if (gv && GvCV(gv))
1911                 return GvCV(gv);
1912         }
1913         return ret;
1914     }
1915
1916     return NULL;
1917 }
1918
1919
1920 /* Implement tryAMAGICun_MG macro.
1921    Do get magic, then see if the stack arg is overloaded and if so call it.
1922    Flags:
1923         AMGf_set     return the arg using SETs rather than assigning to
1924                      the targ
1925         AMGf_numeric apply sv_2num to the stack arg.
1926 */
1927
1928 bool
1929 Perl_try_amagic_un(pTHX_ int method, int flags) {
1930     dVAR;
1931     dSP;
1932     SV* tmpsv;
1933     SV* const arg = TOPs;
1934
1935     SvGETMAGIC(arg);
1936
1937     if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
1938                                               AMGf_noright | AMGf_unary))) {
1939         if (flags & AMGf_set) {
1940             SETs(tmpsv);
1941         }
1942         else {
1943             dTARGET;
1944             if (SvPADMY(TARG)) {
1945                 sv_setsv(TARG, tmpsv);
1946                 SETTARG;
1947             }
1948             else
1949                 SETs(tmpsv);
1950         }
1951         PUTBACK;
1952         return TRUE;
1953     }
1954
1955     if ((flags & AMGf_numeric) && SvROK(arg))
1956         *sp = sv_2num(arg);
1957     return FALSE;
1958 }
1959
1960
1961 /* Implement tryAMAGICbin_MG macro.
1962    Do get magic, then see if the two stack args are overloaded and if so
1963    call it.
1964    Flags:
1965         AMGf_set     return the arg using SETs rather than assigning to
1966                      the targ
1967         AMGf_assign  op may be called as mutator (eg +=)
1968         AMGf_numeric apply sv_2num to the stack arg.
1969 */
1970
1971 bool
1972 Perl_try_amagic_bin(pTHX_ int method, int flags) {
1973     dVAR;
1974     dSP;
1975     SV* const left = TOPm1s;
1976     SV* const right = TOPs;
1977
1978     SvGETMAGIC(left);
1979     if (left != right)
1980         SvGETMAGIC(right);
1981
1982     if (SvAMAGIC(left) || SvAMAGIC(right)) {
1983         SV * const tmpsv = amagic_call(left, right, method,
1984                     ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
1985         if (tmpsv) {
1986             if (flags & AMGf_set) {
1987                 (void)POPs;
1988                 SETs(tmpsv);
1989             }
1990             else {
1991                 dATARGET;
1992                 (void)POPs;
1993                 if (opASSIGN || SvPADMY(TARG)) {
1994                     sv_setsv(TARG, tmpsv);
1995                     SETTARG;
1996                 }
1997                 else
1998                     SETs(tmpsv);
1999             }
2000             PUTBACK;
2001             return TRUE;
2002         }
2003     }
2004     if (flags & AMGf_numeric) {
2005         if (SvROK(left))
2006             *(sp-1) = sv_2num(left);
2007         if (SvROK(right))
2008             *sp     = sv_2num(right);
2009     }
2010     return FALSE;
2011 }
2012
2013
2014 SV*
2015 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2016 {
2017   dVAR;
2018   MAGIC *mg;
2019   CV *cv=NULL;
2020   CV **cvp=NULL, **ocvp=NULL;
2021   AMT *amtp=NULL, *oamtp=NULL;
2022   int off = 0, off1, lr = 0, notfound = 0;
2023   int postpr = 0, force_cpy = 0;
2024   int assign = AMGf_assign & flags;
2025   const int assignshift = assign ? 1 : 0;
2026 #ifdef DEBUGGING
2027   int fl=0;
2028 #endif
2029   HV* stash=NULL;
2030
2031   PERL_ARGS_ASSERT_AMAGIC_CALL;
2032
2033   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2034       SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2035
2036       if ( !lex_mask || !SvOK(lex_mask) )
2037           /* overloading lexically disabled */
2038           return NULL;
2039       else if ( lex_mask && SvPOK(lex_mask) ) {
2040           /* we have an entry in the hints hash, check if method has been
2041            * masked by overloading.pm */
2042           STRLEN len;
2043           const int offset = method / 8;
2044           const int bit    = method % 8;
2045           char *pv = SvPV(lex_mask, len);
2046
2047           /* Bit set, so this overloading operator is disabled */
2048           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2049               return NULL;
2050       }
2051   }
2052
2053   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2054       && (stash = SvSTASH(SvRV(left)))
2055       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2056       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2057                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2058                         : NULL))
2059       && ((cv = cvp[off=method+assignshift])
2060           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2061                                                           * usual method */
2062                   (
2063 #ifdef DEBUGGING
2064                    fl = 1,
2065 #endif
2066                    cv = cvp[off=method])))) {
2067     lr = -1;                    /* Call method for left argument */
2068   } else {
2069     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2070       int logic;
2071
2072       /* look for substituted methods */
2073       /* In all the covered cases we should be called with assign==0. */
2074          switch (method) {
2075          case inc_amg:
2076            force_cpy = 1;
2077            if ((cv = cvp[off=add_ass_amg])
2078                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2079              right = &PL_sv_yes; lr = -1; assign = 1;
2080            }
2081            break;
2082          case dec_amg:
2083            force_cpy = 1;
2084            if ((cv = cvp[off = subtr_ass_amg])
2085                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2086              right = &PL_sv_yes; lr = -1; assign = 1;
2087            }
2088            break;
2089          case bool__amg:
2090            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2091            break;
2092          case numer_amg:
2093            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2094            break;
2095          case string_amg:
2096            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2097            break;
2098          case not_amg:
2099            (void)((cv = cvp[off=bool__amg])
2100                   || (cv = cvp[off=numer_amg])
2101                   || (cv = cvp[off=string_amg]));
2102            if (cv)
2103                postpr = 1;
2104            break;
2105          case copy_amg:
2106            {
2107              /*
2108                   * SV* ref causes confusion with the interpreter variable of
2109                   * the same name
2110                   */
2111              SV* const tmpRef=SvRV(left);
2112              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2113                 /*
2114                  * Just to be extra cautious.  Maybe in some
2115                  * additional cases sv_setsv is safe, too.
2116                  */
2117                 SV* const newref = newSVsv(tmpRef);
2118                 SvOBJECT_on(newref);
2119                 /* As a bit of a source compatibility hack, SvAMAGIC() and
2120                    friends dereference an RV, to behave the same was as when
2121                    overloading was stored on the reference, not the referant.
2122                    Hence we can't use SvAMAGIC_on()
2123                 */
2124                 SvFLAGS(newref) |= SVf_AMAGIC;
2125                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2126                 return newref;
2127              }
2128            }
2129            break;
2130          case abs_amg:
2131            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2132                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2133              SV* const nullsv=sv_2mortal(newSViv(0));
2134              if (off1==lt_amg) {
2135                SV* const lessp = amagic_call(left,nullsv,
2136                                        lt_amg,AMGf_noright);
2137                logic = SvTRUE(lessp);
2138              } else {
2139                SV* const lessp = amagic_call(left,nullsv,
2140                                        ncmp_amg,AMGf_noright);
2141                logic = (SvNV(lessp) < 0);
2142              }
2143              if (logic) {
2144                if (off==subtr_amg) {
2145                  right = left;
2146                  left = nullsv;
2147                  lr = 1;
2148                }
2149              } else {
2150                return left;
2151              }
2152            }
2153            break;
2154          case neg_amg:
2155            if ((cv = cvp[off=subtr_amg])) {
2156              right = left;
2157              left = sv_2mortal(newSViv(0));
2158              lr = 1;
2159            }
2160            break;
2161          case int_amg:
2162          case iter_amg:                 /* XXXX Eventually should do to_gv. */
2163          case ftest_amg:                /* XXXX Eventually should do to_gv. */
2164          case regexp_amg:
2165              /* FAIL safe */
2166              return NULL;       /* Delegate operation to standard mechanisms. */
2167              break;
2168          case to_sv_amg:
2169          case to_av_amg:
2170          case to_hv_amg:
2171          case to_gv_amg:
2172          case to_cv_amg:
2173              /* FAIL safe */
2174              return left;       /* Delegate operation to standard mechanisms. */
2175              break;
2176          default:
2177            goto not_found;
2178          }
2179          if (!cv) goto not_found;
2180     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2181                && (stash = SvSTASH(SvRV(right)))
2182                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2183                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2184                           ? (amtp = (AMT*)mg->mg_ptr)->table
2185                           : NULL))
2186                && (cv = cvp[off=method])) { /* Method for right
2187                                              * argument found */
2188       lr=1;
2189     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
2190                  && (cvp=ocvp) && (lr = -1))
2191                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
2192                && !(flags & AMGf_unary)) {
2193                                 /* We look for substitution for
2194                                  * comparison operations and
2195                                  * concatenation */
2196       if (method==concat_amg || method==concat_ass_amg
2197           || method==repeat_amg || method==repeat_ass_amg) {
2198         return NULL;            /* Delegate operation to string conversion */
2199       }
2200       off = -1;
2201       switch (method) {
2202          case lt_amg:
2203          case le_amg:
2204          case gt_amg:
2205          case ge_amg:
2206          case eq_amg:
2207          case ne_amg:
2208              off = ncmp_amg;
2209              break;
2210          case slt_amg:
2211          case sle_amg:
2212          case sgt_amg:
2213          case sge_amg:
2214          case seq_amg:
2215          case sne_amg:
2216              off = scmp_amg;
2217              break;
2218          }
2219       if ((off != -1) && (cv = cvp[off]))
2220           postpr = 1;
2221       else
2222           goto not_found;
2223     } else {
2224     not_found:                  /* No method found, either report or croak */
2225       switch (method) {
2226          case to_sv_amg:
2227          case to_av_amg:
2228          case to_hv_amg:
2229          case to_gv_amg:
2230          case to_cv_amg:
2231              /* FAIL safe */
2232              return left;       /* Delegate operation to standard mechanisms. */
2233              break;
2234       }
2235       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2236         notfound = 1; lr = -1;
2237       } else if (cvp && (cv=cvp[nomethod_amg])) {
2238         notfound = 1; lr = 1;
2239       } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
2240         /* Skip generating the "no method found" message.  */
2241         return NULL;
2242       } else {
2243         SV *msg;
2244         if (off==-1) off=method;
2245         msg = sv_2mortal(Perl_newSVpvf(aTHX_
2246                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
2247                       AMG_id2name(method + assignshift),
2248                       (flags & AMGf_unary ? " " : "\n\tleft "),
2249                       SvAMAGIC(left)?
2250                         "in overloaded package ":
2251                         "has no overloaded magic",
2252                       SvAMAGIC(left)?
2253                         HvNAME_get(SvSTASH(SvRV(left))):
2254                         "",
2255                       SvAMAGIC(right)?
2256                         ",\n\tright argument in overloaded package ":
2257                         (flags & AMGf_unary
2258                          ? ""
2259                          : ",\n\tright argument has no overloaded magic"),
2260                       SvAMAGIC(right)?
2261                         HvNAME_get(SvSTASH(SvRV(right))):
2262                         ""));
2263         if (amtp && amtp->fallback >= AMGfallYES) {
2264           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
2265         } else {
2266           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2267         }
2268         return NULL;
2269       }
2270       force_cpy = force_cpy || assign;
2271     }
2272   }
2273 #ifdef DEBUGGING
2274   if (!notfound) {
2275     DEBUG_o(Perl_deb(aTHX_
2276                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
2277                      AMG_id2name(off),
2278                      method+assignshift==off? "" :
2279                      " (initially \"",
2280                      method+assignshift==off? "" :
2281                      AMG_id2name(method+assignshift),
2282                      method+assignshift==off? "" : "\")",
2283                      flags & AMGf_unary? "" :
2284                      lr==1 ? " for right argument": " for left argument",
2285                      flags & AMGf_unary? " for argument" : "",
2286                      stash ? HvNAME_get(stash) : "null",
2287                      fl? ",\n\tassignment variant used": "") );
2288   }
2289 #endif
2290     /* Since we use shallow copy during assignment, we need
2291      * to dublicate the contents, probably calling user-supplied
2292      * version of copy operator
2293      */
2294     /* We need to copy in following cases:
2295      * a) Assignment form was called.
2296      *          assignshift==1,  assign==T, method + 1 == off
2297      * b) Increment or decrement, called directly.
2298      *          assignshift==0,  assign==0, method + 0 == off
2299      * c) Increment or decrement, translated to assignment add/subtr.
2300      *          assignshift==0,  assign==T,
2301      *          force_cpy == T
2302      * d) Increment or decrement, translated to nomethod.
2303      *          assignshift==0,  assign==0,
2304      *          force_cpy == T
2305      * e) Assignment form translated to nomethod.
2306      *          assignshift==1,  assign==T, method + 1 != off
2307      *          force_cpy == T
2308      */
2309     /*  off is method, method+assignshift, or a result of opcode substitution.
2310      *  In the latter case assignshift==0, so only notfound case is important.
2311      */
2312   if (( (method + assignshift == off)
2313         && (assign || (method == inc_amg) || (method == dec_amg)))
2314       || force_cpy)
2315   {
2316     RvDEEPCP(left);
2317   }
2318
2319   {
2320     dSP;
2321     BINOP myop;
2322     SV* res;
2323     const bool oldcatch = CATCH_GET;
2324
2325     CATCH_SET(TRUE);
2326     Zero(&myop, 1, BINOP);
2327     myop.op_last = (OP *) &myop;
2328     myop.op_next = NULL;
2329     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
2330
2331     PUSHSTACKi(PERLSI_OVERLOAD);
2332     ENTER;
2333     SAVEOP();
2334     PL_op = (OP *) &myop;
2335     if (PERLDB_SUB && PL_curstash != PL_debstash)
2336         PL_op->op_private |= OPpENTERSUB_DB;
2337     PUTBACK;
2338     pp_pushmark();
2339
2340     EXTEND(SP, notfound + 5);
2341     PUSHs(lr>0? right: left);
2342     PUSHs(lr>0? left: right);
2343     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
2344     if (notfound) {
2345       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
2346                            AMG_id2namelen(method + assignshift), SVs_TEMP));
2347     }
2348     PUSHs(MUTABLE_SV(cv));
2349     PUTBACK;
2350
2351     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
2352       CALLRUNOPS(aTHX);
2353     LEAVE;
2354     SPAGAIN;
2355
2356     res=POPs;
2357     PUTBACK;
2358     POPSTACK;
2359     CATCH_SET(oldcatch);
2360
2361     if (postpr) {
2362       int ans;
2363       switch (method) {
2364       case le_amg:
2365       case sle_amg:
2366         ans=SvIV(res)<=0; break;
2367       case lt_amg:
2368       case slt_amg:
2369         ans=SvIV(res)<0; break;
2370       case ge_amg:
2371       case sge_amg:
2372         ans=SvIV(res)>=0; break;
2373       case gt_amg:
2374       case sgt_amg:
2375         ans=SvIV(res)>0; break;
2376       case eq_amg:
2377       case seq_amg:
2378         ans=SvIV(res)==0; break;
2379       case ne_amg:
2380       case sne_amg:
2381         ans=SvIV(res)!=0; break;
2382       case inc_amg:
2383       case dec_amg:
2384         SvSetSV(left,res); return left;
2385       case not_amg:
2386         ans=!SvTRUE(res); break;
2387       default:
2388         ans=0; break;
2389       }
2390       return boolSV(ans);
2391     } else if (method==copy_amg) {
2392       if (!SvROK(res)) {
2393         Perl_croak(aTHX_ "Copy method did not return a reference");
2394       }
2395       return SvREFCNT_inc(SvRV(res));
2396     } else {
2397       return res;
2398     }
2399   }
2400 }
2401
2402 /*
2403 =for apidoc is_gv_magical_sv
2404
2405 Returns C<TRUE> if given the name of a magical GV.
2406
2407 Currently only useful internally when determining if a GV should be
2408 created even in rvalue contexts.
2409
2410 C<flags> is not used at present but available for future extension to
2411 allow selecting particular classes of magical variable.
2412
2413 Currently assumes that C<name> is NUL terminated (as well as len being valid).
2414 This assumption is met by all callers within the perl core, which all pass
2415 pointers returned by SvPV.
2416
2417 =cut
2418 */
2419
2420 bool
2421 Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags)
2422 {
2423     STRLEN len;
2424     const char *const name = SvPV_const(name_sv, len);
2425
2426     PERL_UNUSED_ARG(flags);
2427     PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV;
2428
2429     if (len > 1) {
2430         const char * const name1 = name + 1;
2431         switch (*name) {
2432         case 'I':
2433             if (len == 3 && name[1] == 'S' && name[2] == 'A')
2434                 goto yes;
2435             break;
2436         case 'O':
2437             if (len == 8 && strEQ(name1, "VERLOAD"))
2438                 goto yes;
2439             break;
2440         case 'S':
2441             if (len == 3 && name[1] == 'I' && name[2] == 'G')
2442                 goto yes;
2443             break;
2444             /* Using ${^...} variables is likely to be sufficiently rare that
2445                it seems sensible to avoid the space hit of also checking the
2446                length.  */
2447         case '\017':   /* ${^OPEN} */
2448             if (strEQ(name1, "PEN"))
2449                 goto yes;
2450             break;
2451         case '\024':   /* ${^TAINT} */
2452             if (strEQ(name1, "AINT"))
2453                 goto yes;
2454             break;
2455         case '\025':    /* ${^UNICODE} */
2456             if (strEQ(name1, "NICODE"))
2457                 goto yes;
2458             if (strEQ(name1, "TF8LOCALE"))
2459                 goto yes;
2460             break;
2461         case '\027':   /* ${^WARNING_BITS} */
2462             if (strEQ(name1, "ARNING_BITS"))
2463                 goto yes;
2464             break;
2465         case '1':
2466         case '2':
2467         case '3':
2468         case '4':
2469         case '5':
2470         case '6':
2471         case '7':
2472         case '8':
2473         case '9':
2474         {
2475             const char *end = name + len;
2476             while (--end > name) {
2477                 if (!isDIGIT(*end))
2478                     return FALSE;
2479             }
2480             goto yes;
2481         }
2482         }
2483     } else {
2484         /* Because we're already assuming that name is NUL terminated
2485            below, we can treat an empty name as "\0"  */
2486         switch (*name) {
2487         case '&':
2488         case '`':
2489         case '\'':
2490         case ':':
2491         case '?':
2492         case '!':
2493         case '-':
2494         case '#':
2495         case '[':
2496         case '^':
2497         case '~':
2498         case '=':
2499         case '%':
2500         case '.':
2501         case '(':
2502         case ')':
2503         case '<':
2504         case '>':
2505         case '\\':
2506         case '/':
2507         case '|':
2508         case '+':
2509         case ';':
2510         case ']':
2511         case '\001':   /* $^A */
2512         case '\003':   /* $^C */
2513         case '\004':   /* $^D */
2514         case '\005':   /* $^E */
2515         case '\006':   /* $^F */
2516         case '\010':   /* $^H */
2517         case '\011':   /* $^I, NOT \t in EBCDIC */
2518         case '\014':   /* $^L */
2519         case '\016':   /* $^N */
2520         case '\017':   /* $^O */
2521         case '\020':   /* $^P */
2522         case '\023':   /* $^S */
2523         case '\024':   /* $^T */
2524         case '\026':   /* $^V */
2525         case '\027':   /* $^W */
2526         case '1':
2527         case '2':
2528         case '3':
2529         case '4':
2530         case '5':
2531         case '6':
2532         case '7':
2533         case '8':
2534         case '9':
2535         yes:
2536             return TRUE;
2537         default:
2538             break;
2539         }
2540     }
2541     return FALSE;
2542 }
2543
2544 void
2545 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2546 {
2547     dVAR;
2548     U32 hash;
2549
2550     PERL_ARGS_ASSERT_GV_NAME_SET;
2551     PERL_UNUSED_ARG(flags);
2552
2553     if (len > I32_MAX)
2554         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2555
2556     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2557         unshare_hek(GvNAME_HEK(gv));
2558     }
2559
2560     PERL_HASH(hash, name, len);
2561     GvNAME_HEK(gv) = share_hek(name, len, hash);
2562 }
2563
2564 /*
2565 =for apidoc gv_try_downgrade
2566
2567 If the typeglob C<gv> can be expressed more succinctly, by having
2568 something other than a real GV in its place in the stash, replace it
2569 with the optimised form.  Basic requirements for this are that C<gv>
2570 is a real typeglob, is sufficiently ordinary, and is only referenced
2571 from its package.  This function is meant to be used when a GV has been
2572 looked up in part to see what was there, causing upgrading, but based
2573 on what was found it turns out that the real GV isn't required after all.
2574
2575 If C<gv> is a completely empty typeglob, it is deleted from the stash.
2576
2577 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
2578 sub, the typeglob is replaced with a scalar-reference placeholder that
2579 more compactly represents the same thing.
2580
2581 =cut
2582 */
2583
2584 void
2585 Perl_gv_try_downgrade(pTHX_ GV *gv)
2586 {
2587     HV *stash;
2588     CV *cv;
2589     HEK *namehek;
2590     SV **gvp;
2591     PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
2592
2593     /* XXX Why and where does this leave dangling pointers during global
2594        destruction? */
2595     if (PL_dirty) return;
2596
2597     if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
2598             !SvOBJECT(gv) && !SvREADONLY(gv) &&
2599             isGV_with_GP(gv) && GvGP(gv) &&
2600             !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
2601             !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
2602             GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
2603         return;
2604     if (SvMAGICAL(gv)) {
2605         MAGIC *mg;
2606         /* only backref magic is allowed */
2607         if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
2608             return;
2609         for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
2610             if (mg->mg_type != PERL_MAGIC_backref)
2611                 return;
2612         }
2613     }
2614     cv = GvCV(gv);
2615     if (!cv) {
2616         HEK *gvnhek = GvNAME_HEK(gv);
2617         (void)hv_delete(stash, HEK_KEY(gvnhek),
2618             HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
2619     } else if (GvMULTI(gv) && cv &&
2620             !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
2621             CvSTASH(cv) == stash && CvGV(cv) == gv &&
2622             CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
2623             !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
2624             (namehek = GvNAME_HEK(gv)) &&
2625             (gvp = hv_fetch(stash, HEK_KEY(namehek),
2626                         HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
2627             *gvp == (SV*)gv) {
2628         SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
2629         SvREFCNT(gv) = 0;
2630         sv_clear((SV*)gv);
2631         SvREFCNT(gv) = 1;
2632         SvFLAGS(gv) = SVt_IV|SVf_ROK;
2633         SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
2634                                 STRUCT_OFFSET(XPVIV, xiv_iv));
2635         SvRV_set(gv, value);
2636     }
2637 }
2638
2639 /*
2640  * Local variables:
2641  * c-indentation-style: bsd
2642  * c-basic-offset: 4
2643  * indent-tabs-mode: t
2644  * End:
2645  *
2646  * ex: set ts=8 sts=4 sw=4 noet:
2647  */