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