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