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