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