This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
89ee978b459b3f1c3cb6f82b5a6e102cac45ad8a
[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 GV *
935 Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
936 {
937     char *namepv;
938     STRLEN namelen;
939     PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
940     namepv = SvPV(namesv, namelen);
941     if (SvUTF8(namesv))
942        flags |= SVf_UTF8;
943     return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
944 }
945
946 GV *
947 Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
948 {
949     PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
950     return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
951 }
952
953 /* Don't merge this yet, as it's likely to get a len parameter, and possibly
954    even a U32 hash */
955 GV *
956 Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
957 {
958     dVAR;
959     register const char *nend;
960     const char *nsplit = NULL;
961     GV* gv;
962     HV* ostash = stash;
963     const char * const origname = name;
964     SV *const error_report = MUTABLE_SV(stash);
965     const U32 autoload = flags & GV_AUTOLOAD;
966     const U32 do_croak = flags & GV_CROAK;
967
968     PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
969
970     if (SvTYPE(stash) < SVt_PVHV)
971         stash = NULL;
972     else {
973         /* The only way stash can become NULL later on is if nsplit is set,
974            which in turn means that there is no need for a SVt_PVHV case
975            the error reporting code.  */
976     }
977
978     for (nend = name; *nend || nend != (origname + len); nend++) {
979         if (*nend == '\'') {
980             nsplit = nend;
981             name = nend + 1;
982         }
983         else if (*nend == ':' && *(nend + 1) == ':') {
984             nsplit = nend++;
985             name = nend + 1;
986         }
987     }
988     if (nsplit) {
989         if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
990             /* ->SUPER::method should really be looked up in original stash */
991             SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
992                                                   CopSTASHPV(PL_curcop)));
993             /* __PACKAGE__::SUPER stash should be autovivified */
994             stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr));
995             DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
996                          origname, HvNAME_get(stash), name) );
997         }
998         else {
999             /* don't autovifify if ->NoSuchStash::method */
1000             stash = gv_stashpvn(origname, nsplit - origname, 0);
1001
1002             /* however, explicit calls to Pkg::SUPER::method may
1003                happen, and may require autovivification to work */
1004             if (!stash && (nsplit - origname) >= 7 &&
1005                 strnEQ(nsplit - 7, "::SUPER", 7) &&
1006                 gv_stashpvn(origname, nsplit - origname - 7, 0))
1007               stash = gv_get_super_pkg(origname, nsplit - origname);
1008         }
1009         ostash = stash;
1010     }
1011
1012     gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, 0);
1013     if (!gv) {
1014         if (strEQ(name,"import") || strEQ(name,"unimport"))
1015             gv = MUTABLE_GV(&PL_sv_yes);
1016         else if (autoload)
1017             gv = gv_autoload4(ostash, name, nend - name, TRUE);
1018         if (!gv && do_croak) {
1019             /* Right now this is exclusively for the benefit of S_method_common
1020                in pp_hot.c  */
1021             if (stash) {
1022                 /* If we can't find an IO::File method, it might be a call on
1023                  * a filehandle. If IO:File has not been loaded, try to
1024                  * require it first instead of croaking */
1025                 const char *stash_name = HvNAME_get(stash);
1026                 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
1027                     && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
1028                                        STR_WITH_LEN("IO/File.pm"), 0,
1029                                        HV_FETCH_ISEXISTS, NULL, 0)
1030                 ) {
1031                     require_pv("IO/File.pm");
1032                     gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, 0);
1033                     if (gv)
1034                         return gv;
1035                 }
1036                 Perl_croak(aTHX_
1037                            "Can't locate object method \"%s\" via package \"%.*s\"",
1038                            name, (int)HvNAMELEN_get(stash), HvNAME_get(stash));
1039             }
1040             else {
1041                 STRLEN packlen;
1042                 const char *packname;
1043
1044                 if (nsplit) {
1045                     packlen = nsplit - origname;
1046                     packname = origname;
1047                 } else {
1048                     packname = SvPV_const(error_report, packlen);
1049                 }
1050
1051                 Perl_croak(aTHX_
1052                            "Can't locate object method \"%s\" via package \"%.*s\""
1053                            " (perhaps you forgot to load \"%.*s\"?)",
1054                            name, (int)packlen, packname, (int)packlen, packname);
1055             }
1056         }
1057     }
1058     else if (autoload) {
1059         CV* const cv = GvCV(gv);
1060         if (!CvROOT(cv) && !CvXSUB(cv)) {
1061             GV* stubgv;
1062             GV* autogv;
1063
1064             if (CvANON(cv))
1065                 stubgv = gv;
1066             else {
1067                 stubgv = CvGV(cv);
1068                 if (GvCV(stubgv) != cv)         /* orphaned import */
1069                     stubgv = gv;
1070             }
1071             autogv = gv_autoload4(GvSTASH(stubgv),
1072                                   GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
1073             if (autogv)
1074                 gv = autogv;
1075         }
1076     }
1077
1078     return gv;
1079 }
1080
1081 GV*
1082 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
1083 {
1084     dVAR;
1085     GV* gv;
1086     CV* cv;
1087     HV* varstash;
1088     GV* vargv;
1089     SV* varsv;
1090     const char *packname = "";
1091     STRLEN packname_len = 0;
1092
1093     PERL_ARGS_ASSERT_GV_AUTOLOAD4;
1094
1095     if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1096         return NULL;
1097     if (stash) {
1098         if (SvTYPE(stash) < SVt_PVHV) {
1099             packname = SvPV_const(MUTABLE_SV(stash), packname_len);
1100             stash = NULL;
1101         }
1102         else {
1103             packname = HvNAME_get(stash);
1104             packname_len = HvNAMELEN_get(stash);
1105         }
1106     }
1107     if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, 0)))
1108         return NULL;
1109     cv = GvCV(gv);
1110
1111     if (!(CvROOT(cv) || CvXSUB(cv)))
1112         return NULL;
1113
1114     /*
1115      * Inheriting AUTOLOAD for non-methods works ... for now.
1116      */
1117     if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash)
1118     )
1119         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
1120                          "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
1121                          packname, (int)len, name);
1122
1123     if (CvISXSUB(cv)) {
1124         /* rather than lookup/init $AUTOLOAD here
1125          * only to have the XSUB do another lookup for $AUTOLOAD
1126          * and split that value on the last '::',
1127          * pass along the same data via some unused fields in the CV
1128          */
1129         CvSTASH_set(cv, stash);
1130         SvPV_set(cv, (char *)name); /* cast to lose constness warning */
1131         SvCUR_set(cv, len);
1132         return gv;
1133     }
1134
1135     /*
1136      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1137      * The subroutine's original name may not be "AUTOLOAD", so we don't
1138      * use that, but for lack of anything better we will use the sub's
1139      * original package to look up $AUTOLOAD.
1140      */
1141     varstash = GvSTASH(CvGV(cv));
1142     vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1143     ENTER;
1144
1145     if (!isGV(vargv)) {
1146         gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
1147 #ifdef PERL_DONT_CREATE_GVSV
1148         GvSV(vargv) = newSV(0);
1149 #endif
1150     }
1151     LEAVE;
1152     varsv = GvSVn(vargv);
1153     sv_setpvn(varsv, packname, packname_len);
1154     sv_catpvs(varsv, "::");
1155     /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1156        tainting if $FOO::AUTOLOAD was previously tainted, but is not now.  */
1157     sv_catpvn_mg(varsv, name, len);
1158     return gv;
1159 }
1160
1161
1162 /* require_tie_mod() internal routine for requiring a module
1163  * that implements the logic of automatic ties like %! and %-
1164  *
1165  * The "gv" parameter should be the glob.
1166  * "varpv" holds the name of the var, used for error messages.
1167  * "namesv" holds the module name. Its refcount will be decremented.
1168  * "methpv" holds the method name to test for to check that things
1169  *   are working reasonably close to as expected.
1170  * "flags": if flag & 1 then save the scalar before loading.
1171  * For the protection of $! to work (it is set by this routine)
1172  * the sv slot must already be magicalized.
1173  */
1174 STATIC HV*
1175 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
1176 {
1177     dVAR;
1178     HV* stash = gv_stashsv(namesv, 0);
1179
1180     PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1181
1182     if (!stash || !(gv_fetchmethod(stash, methpv))) {
1183         SV *module = newSVsv(namesv);
1184         char varname = *varpv; /* varpv might be clobbered by load_module,
1185                                   so save it. For the moment it's always
1186                                   a single char. */
1187         dSP;
1188         ENTER;
1189         if ( flags & 1 )
1190             save_scalar(gv);
1191         PUSHSTACKi(PERLSI_MAGIC);
1192         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1193         POPSTACK;
1194         LEAVE;
1195         SPAGAIN;
1196         stash = gv_stashsv(namesv, 0);
1197         if (!stash)
1198             Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available",
1199                     varname, SVfARG(namesv));
1200         else if (!gv_fetchmethod(stash, methpv))
1201             Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s",
1202                     varname, SVfARG(namesv), methpv);
1203     }
1204     SvREFCNT_dec(namesv);
1205     return stash;
1206 }
1207
1208 /*
1209 =for apidoc gv_stashpv
1210
1211 Returns a pointer to the stash for a specified package.  Uses C<strlen> to
1212 determine the length of C<name>, then calls C<gv_stashpvn()>.
1213
1214 =cut
1215 */
1216
1217 HV*
1218 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1219 {
1220     PERL_ARGS_ASSERT_GV_STASHPV;
1221     return gv_stashpvn(name, strlen(name), create);
1222 }
1223
1224 /*
1225 =for apidoc gv_stashpvn
1226
1227 Returns a pointer to the stash for a specified package.  The C<namelen>
1228 parameter indicates the length of the C<name>, in bytes.  C<flags> is passed
1229 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1230 created if it does not already exist.  If the package does not exist and
1231 C<flags> is 0 (or any other setting that does not create packages) then NULL
1232 is returned.
1233
1234
1235 =cut
1236 */
1237
1238 HV*
1239 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1240 {
1241     char smallbuf[128];
1242     char *tmpbuf;
1243     HV *stash;
1244     GV *tmpgv;
1245     U32 tmplen = namelen + 2;
1246
1247     PERL_ARGS_ASSERT_GV_STASHPVN;
1248
1249     if (tmplen <= sizeof smallbuf)
1250         tmpbuf = smallbuf;
1251     else
1252         Newx(tmpbuf, tmplen, char);
1253     Copy(name, tmpbuf, namelen, char);
1254     tmpbuf[namelen]   = ':';
1255     tmpbuf[namelen+1] = ':';
1256     tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1257     if (tmpbuf != smallbuf)
1258         Safefree(tmpbuf);
1259     if (!tmpgv)
1260         return NULL;
1261     stash = GvHV(tmpgv);
1262     if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1263     assert(stash);
1264     if (!HvNAME_get(stash)) {
1265         hv_name_set(stash, name, namelen, 0);
1266         
1267         /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1268         /* If the containing stash has multiple effective
1269            names, see that this one gets them, too. */
1270         if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1271             mro_package_moved(stash, NULL, tmpgv, 1);
1272     }
1273     return stash;
1274 }
1275
1276 /*
1277 =for apidoc gv_stashsv
1278
1279 Returns a pointer to the stash for a specified package.  See C<gv_stashpvn>.
1280
1281 =cut
1282 */
1283
1284 HV*
1285 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1286 {
1287     STRLEN len;
1288     const char * const ptr = SvPV_const(sv,len);
1289
1290     PERL_ARGS_ASSERT_GV_STASHSV;
1291
1292     return gv_stashpvn(ptr, len, flags);
1293 }
1294
1295
1296 GV *
1297 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
1298     PERL_ARGS_ASSERT_GV_FETCHPV;
1299     return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
1300 }
1301
1302 GV *
1303 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1304     STRLEN len;
1305     const char * const nambeg =
1306        SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1307     PERL_ARGS_ASSERT_GV_FETCHSV;
1308     return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1309 }
1310
1311 STATIC void
1312 S_gv_magicalize_isa(pTHX_ GV *gv)
1313 {
1314     AV* av;
1315
1316     PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1317
1318     av = GvAVn(gv);
1319     GvMULTI_on(gv);
1320     sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1321              NULL, 0);
1322 }
1323
1324 STATIC void
1325 S_gv_magicalize_overload(pTHX_ GV *gv)
1326 {
1327     HV* hv;
1328
1329     PERL_ARGS_ASSERT_GV_MAGICALIZE_OVERLOAD;
1330
1331     hv = GvHVn(gv);
1332     GvMULTI_on(gv);
1333     hv_magic(hv, NULL, PERL_MAGIC_overload);
1334 }
1335
1336 GV *
1337 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
1338                        const svtype sv_type)
1339 {
1340     dVAR;
1341     register const char *name = nambeg;
1342     register GV *gv = NULL;
1343     GV**gvp;
1344     I32 len;
1345     register const char *name_cursor;
1346     HV *stash = NULL;
1347     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
1348     const I32 no_expand = flags & GV_NOEXPAND;
1349     const I32 add = flags & ~GV_NOADD_MASK;
1350     bool addmg = !!(flags & GV_ADDMG);
1351     const char *const name_end = nambeg + full_len;
1352     const char *const name_em1 = name_end - 1;
1353     U32 faking_it;
1354
1355     PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
1356
1357     if (flags & GV_NOTQUAL) {
1358         /* Caller promised that there is no stash, so we can skip the check. */
1359         len = full_len;
1360         goto no_stash;
1361     }
1362
1363     if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
1364         /* accidental stringify on a GV? */
1365         name++;
1366     }
1367
1368     for (name_cursor = name; name_cursor < name_end; name_cursor++) {
1369         if (name_cursor < name_em1 &&
1370             ((*name_cursor == ':'
1371              && name_cursor[1] == ':')
1372             || *name_cursor == '\''))
1373         {
1374             if (!stash)
1375                 stash = PL_defstash;
1376             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
1377                 return NULL;
1378
1379             len = name_cursor - name;
1380             if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1381                 const char *key;
1382                 if (*name_cursor == ':') {
1383                     key = name;
1384                     len += 2;
1385                 } else {
1386                     char *tmpbuf;
1387                     Newx(tmpbuf, len+2, char);
1388                     Copy(name, tmpbuf, len, char);
1389                     tmpbuf[len++] = ':';
1390                     tmpbuf[len++] = ':';
1391                     key = tmpbuf;
1392                 }
1393                 gvp = (GV**)hv_fetch(stash, key, len, add);
1394                 gv = gvp ? *gvp : NULL;
1395                 if (gv && gv != (const GV *)&PL_sv_undef) {
1396                     if (SvTYPE(gv) != SVt_PVGV)
1397                         gv_init(gv, stash, key, len, (add & GV_ADDMULTI));
1398                     else
1399                         GvMULTI_on(gv);
1400                 }
1401                 if (key != name)
1402                     Safefree(key);
1403                 if (!gv || gv == (const GV *)&PL_sv_undef)
1404                     return NULL;
1405
1406                 if (!(stash = GvHV(gv)))
1407                 {
1408                     stash = GvHV(gv) = newHV();
1409                     if (!HvNAME_get(stash)) {
1410                         if (GvSTASH(gv) == PL_defstash && len == 6
1411                          && strnEQ(name, "CORE", 4))
1412                             hv_name_set(stash, "CORE", 4, 0);
1413                         else
1414                             hv_name_set(
1415                                 stash, nambeg, name_cursor-nambeg, 0
1416                             );
1417                         /* If the containing stash has multiple effective
1418                            names, see that this one gets them, too. */
1419                         if (HvAUX(GvSTASH(gv))->xhv_name_count)
1420                             mro_package_moved(stash, NULL, gv, 1);
1421                     }
1422                 }
1423                 else if (!HvNAME_get(stash))
1424                     hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
1425             }
1426
1427             if (*name_cursor == ':')
1428                 name_cursor++;
1429             name = name_cursor+1;
1430             if (name == name_end)
1431                 return gv
1432                     ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1433         }
1434     }
1435     len = name_cursor - name;
1436
1437     /* No stash in name, so see how we can default */
1438
1439     if (!stash) {
1440     no_stash:
1441         if (len && isIDFIRST_lazy(name)) {
1442             bool global = FALSE;
1443
1444             switch (len) {
1445             case 1:
1446                 if (*name == '_')
1447                     global = TRUE;
1448                 break;
1449             case 3:
1450                 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1451                     || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1452                     || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1453                     global = TRUE;
1454                 break;
1455             case 4:
1456                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1457                     && name[3] == 'V')
1458                     global = TRUE;
1459                 break;
1460             case 5:
1461                 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1462                     && name[3] == 'I' && name[4] == 'N')
1463                     global = TRUE;
1464                 break;
1465             case 6:
1466                 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1467                     &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1468                        ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1469                     global = TRUE;
1470                 break;
1471             case 7:
1472                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1473                     && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1474                     && name[6] == 'T')
1475                     global = TRUE;
1476                 break;
1477             }
1478
1479             if (global)
1480                 stash = PL_defstash;
1481             else if (IN_PERL_COMPILETIME) {
1482                 stash = PL_curstash;
1483                 if (add && (PL_hints & HINT_STRICT_VARS) &&
1484                     sv_type != SVt_PVCV &&
1485                     sv_type != SVt_PVGV &&
1486                     sv_type != SVt_PVFM &&
1487                     sv_type != SVt_PVIO &&
1488                     !(len == 1 && sv_type == SVt_PV &&
1489                       (*name == 'a' || *name == 'b')) )
1490                 {
1491                     gvp = (GV**)hv_fetch(stash,name,len,0);
1492                     if (!gvp ||
1493                         *gvp == (const GV *)&PL_sv_undef ||
1494                         SvTYPE(*gvp) != SVt_PVGV)
1495                     {
1496                         stash = NULL;
1497                     }
1498                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
1499                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1500                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1501                     {
1502                         /* diag_listed_as: Variable "%s" is not imported%s */
1503                         Perl_ck_warner_d(
1504                             aTHX_ packWARN(WARN_MISC),
1505                             "Variable \"%c%s\" is not imported",
1506                             sv_type == SVt_PVAV ? '@' :
1507                             sv_type == SVt_PVHV ? '%' : '$',
1508                             name);
1509                         if (GvCVu(*gvp))
1510                             Perl_ck_warner_d(
1511                                 aTHX_ packWARN(WARN_MISC),
1512                                 "\t(Did you mean &%s instead?)\n", name
1513                             );
1514                         stash = NULL;
1515                     }
1516                 }
1517             }
1518             else
1519                 stash = CopSTASH(PL_curcop);
1520         }
1521         else
1522             stash = PL_defstash;
1523     }
1524
1525     /* By this point we should have a stash and a name */
1526
1527     if (!stash) {
1528         if (add) {
1529             SV * const err = Perl_mess(aTHX_
1530                  "Global symbol \"%s%s\" requires explicit package name",
1531                  (sv_type == SVt_PV ? "$"
1532                   : sv_type == SVt_PVAV ? "@"
1533                   : sv_type == SVt_PVHV ? "%"
1534                   : ""), name);
1535             GV *gv;
1536             if (USE_UTF8_IN_NAMES)
1537                 SvUTF8_on(err);
1538             qerror(err);
1539             gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1540             if(!gv) {
1541                 /* symbol table under destruction */
1542                 return NULL;
1543             }   
1544             stash = GvHV(gv);
1545         }
1546         else
1547             return NULL;
1548     }
1549
1550     if (!SvREFCNT(stash))       /* symbol table under destruction */
1551         return NULL;
1552
1553     gvp = (GV**)hv_fetch(stash,name,len,add);
1554     if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
1555         if (addmg) gv = (GV *)newSV(0);
1556         else return NULL;
1557     }
1558     else gv = *gvp, addmg = 0;
1559     /* From this point on, addmg means gv has not been inserted in the
1560        symtab yet. */
1561
1562     if (SvTYPE(gv) == SVt_PVGV) {
1563         if (add) {
1564             GvMULTI_on(gv);
1565             gv_init_svtype(gv, sv_type);
1566             if (len == 1 && stash == PL_defstash
1567                 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
1568                 if (*name == '!')
1569                     require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1570                 else if (*name == '-' || *name == '+')
1571                     require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1572             }
1573             else if (len == 3 && sv_type == SVt_PVAV
1574                   && strnEQ(name, "ISA", 3)
1575                   && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
1576                 gv_magicalize_isa(gv);
1577         }
1578         return gv;
1579     } else if (no_init) {
1580         assert(!addmg);
1581         return gv;
1582     } else if (no_expand && SvROK(gv)) {
1583         assert(!addmg);
1584         return gv;
1585     }
1586
1587     /* Adding a new symbol.
1588        Unless of course there was already something non-GV here, in which case
1589        we want to behave as if there was always a GV here, containing some sort
1590        of subroutine.
1591        Otherwise we run the risk of creating things like GvIO, which can cause
1592        subtle bugs. eg the one that tripped up SQL::Translator  */
1593
1594     faking_it = SvOK(gv);
1595
1596     if (add & GV_ADDWARN)
1597         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
1598     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
1599
1600     if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
1601                                             : (PL_dowarn & G_WARN_ON ) ) )
1602         GvMULTI_on(gv) ;
1603
1604     /* set up magic where warranted */
1605     if (stash != PL_defstash) { /* not the main stash */
1606         /* We only have to check for four names here: EXPORT, ISA, OVERLOAD
1607            and VERSION. All the others apply only to the main stash or to
1608            CORE (which is checked right after this). */
1609         if (len > 2) {
1610             const char * const name2 = name + 1;
1611             switch (*name) {
1612             case 'E':
1613                 if (strnEQ(name2, "XPORT", 5))
1614                     GvMULTI_on(gv);
1615                 break;
1616             case 'I':
1617                 if (strEQ(name2, "SA"))
1618                     gv_magicalize_isa(gv);
1619                 break;
1620             case 'O':
1621                 if (strEQ(name2, "VERLOAD"))
1622                     gv_magicalize_overload(gv);
1623                 break;
1624             case 'V':
1625                 if (strEQ(name2, "ERSION"))
1626                     GvMULTI_on(gv);
1627                 break;
1628             default:
1629                 goto try_core;
1630             }
1631             goto add_magical_gv;
1632         }
1633       try_core:
1634         if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1635           /* Avoid null warning: */
1636           const char * const stashname = HvNAME(stash); assert(stashname);
1637           if (strnEQ(stashname, "CORE", 4)
1638            && S_maybe_add_coresub(aTHX_
1639                 addmg ? stash : 0, gv, name, len, nambeg, full_len
1640               ))
1641             addmg = 0;
1642         }
1643     }
1644     else if (len > 1) {
1645 #ifndef EBCDIC
1646         if (*name > 'V' ) {
1647             NOOP;
1648             /* Nothing else to do.
1649                The compiler will probably turn the switch statement into a
1650                branch table. Make sure we avoid even that small overhead for
1651                the common case of lower case variable names.  */
1652         } else
1653 #endif
1654         {
1655             const char * const name2 = name + 1;
1656             switch (*name) {
1657             case 'A':
1658                 if (strEQ(name2, "RGV")) {
1659                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1660                 }
1661                 else if (strEQ(name2, "RGVOUT")) {
1662                     GvMULTI_on(gv);
1663                 }
1664                 break;
1665             case 'E':
1666                 if (strnEQ(name2, "XPORT", 5))
1667                     GvMULTI_on(gv);
1668                 break;
1669             case 'I':
1670                 if (strEQ(name2, "SA")) {
1671                     gv_magicalize_isa(gv);
1672                 }
1673                 break;
1674             case 'O':
1675                 if (strEQ(name2, "VERLOAD")) {
1676                     gv_magicalize_overload(gv);
1677                 }
1678                 break;
1679             case 'S':
1680                 if (strEQ(name2, "IG")) {
1681                     HV *hv;
1682                     I32 i;
1683                     if (!PL_psig_name) {
1684                         Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1685                         Newxz(PL_psig_pend, SIG_SIZE, int);
1686                         PL_psig_ptr = PL_psig_name + SIG_SIZE;
1687                     } else {
1688                         /* I think that the only way to get here is to re-use an
1689                            embedded perl interpreter, where the previous
1690                            use didn't clean up fully because
1691                            PL_perl_destruct_level was 0. I'm not sure that we
1692                            "support" that, in that I suspect in that scenario
1693                            there are sufficient other garbage values left in the
1694                            interpreter structure that something else will crash
1695                            before we get here. I suspect that this is one of
1696                            those "doctor, it hurts when I do this" bugs.  */
1697                         Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1698                         Zero(PL_psig_pend, SIG_SIZE, int);
1699                     }
1700                     GvMULTI_on(gv);
1701                     hv = GvHVn(gv);
1702                     hv_magic(hv, NULL, PERL_MAGIC_sig);
1703                     for (i = 1; i < SIG_SIZE; i++) {
1704                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1705                         if (init)
1706                             sv_setsv(*init, &PL_sv_undef);
1707                     }
1708                 }
1709                 break;
1710             case 'V':
1711                 if (strEQ(name2, "ERSION"))
1712                     GvMULTI_on(gv);
1713                 break;
1714             case '\003':        /* $^CHILD_ERROR_NATIVE */
1715                 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1716                     goto magicalize;
1717                 break;
1718             case '\005':        /* $^ENCODING */
1719                 if (strEQ(name2, "NCODING"))
1720                     goto magicalize;
1721                 break;
1722             case '\007':        /* $^GLOBAL_PHASE */
1723                 if (strEQ(name2, "LOBAL_PHASE"))
1724                     goto ro_magicalize;
1725                 break;
1726             case '\015':        /* $^MATCH */
1727                 if (strEQ(name2, "ATCH"))
1728                     goto magicalize;
1729             case '\017':        /* $^OPEN */
1730                 if (strEQ(name2, "PEN"))
1731                     goto magicalize;
1732                 break;
1733             case '\020':        /* $^PREMATCH  $^POSTMATCH */
1734                 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1735                     goto magicalize;
1736                 break;
1737             case '\024':        /* ${^TAINT} */
1738                 if (strEQ(name2, "AINT"))
1739                     goto ro_magicalize;
1740                 break;
1741             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
1742                 if (strEQ(name2, "NICODE"))
1743                     goto ro_magicalize;
1744                 if (strEQ(name2, "TF8LOCALE"))
1745                     goto ro_magicalize;
1746                 if (strEQ(name2, "TF8CACHE"))
1747                     goto magicalize;
1748                 break;
1749             case '\027':        /* $^WARNING_BITS */
1750                 if (strEQ(name2, "ARNING_BITS"))
1751                     goto magicalize;
1752                 break;
1753             case '1':
1754             case '2':
1755             case '3':
1756             case '4':
1757             case '5':
1758             case '6':
1759             case '7':
1760             case '8':
1761             case '9':
1762             {
1763                 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1764                    this test  */
1765                 /* This snippet is taken from is_gv_magical */
1766                 const char *end = name + len;
1767                 while (--end > name) {
1768                     if (!isDIGIT(*end)) goto add_magical_gv;
1769                 }
1770                 goto magicalize;
1771             }
1772             }
1773         }
1774     } else {
1775         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
1776            be case '\0' in this switch statement (ie a default case)  */
1777         switch (*name) {
1778         case '&':               /* $& */
1779         case '`':               /* $` */
1780         case '\'':              /* $' */
1781             if (
1782                 sv_type == SVt_PVAV ||
1783                 sv_type == SVt_PVHV ||
1784                 sv_type == SVt_PVCV ||
1785                 sv_type == SVt_PVFM ||
1786                 sv_type == SVt_PVIO
1787                 ) { break; }
1788             PL_sawampersand = TRUE;
1789             goto magicalize;
1790
1791         case ':':               /* $: */
1792             sv_setpv(GvSVn(gv),PL_chopset);
1793             goto magicalize;
1794
1795         case '?':               /* $? */
1796 #ifdef COMPLEX_STATUS
1797             SvUPGRADE(GvSVn(gv), SVt_PVLV);
1798 #endif
1799             goto magicalize;
1800
1801         case '!':               /* $! */
1802             GvMULTI_on(gv);
1803             /* If %! has been used, automatically load Errno.pm. */
1804
1805             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1806
1807             /* magicalization must be done before require_tie_mod is called */
1808             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1809                 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1810
1811             break;
1812         case '-':               /* $- */
1813         case '+':               /* $+ */
1814         GvMULTI_on(gv); /* no used once warnings here */
1815         {
1816             AV* const av = GvAVn(gv);
1817             SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1818
1819             sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1820             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1821             if (avc)
1822                 SvREADONLY_on(GvSVn(gv));
1823             SvREADONLY_on(av);
1824
1825             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1826                 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1827
1828             break;
1829         }
1830         case '*':               /* $* */
1831         case '#':               /* $# */
1832             if (sv_type == SVt_PV)
1833                 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1834                                  "$%c is no longer supported", *name);
1835             break;
1836         case '|':               /* $| */
1837             sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1838             goto magicalize;
1839
1840         case '\010':    /* $^H */
1841             {
1842                 HV *const hv = GvHVn(gv);
1843                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1844             }
1845             goto magicalize;
1846         case '\023':    /* $^S */
1847         ro_magicalize:
1848             SvREADONLY_on(GvSVn(gv));
1849             /* FALL THROUGH */
1850         case '0':               /* $0 */
1851         case '1':               /* $1 */
1852         case '2':               /* $2 */
1853         case '3':               /* $3 */
1854         case '4':               /* $4 */
1855         case '5':               /* $5 */
1856         case '6':               /* $6 */
1857         case '7':               /* $7 */
1858         case '8':               /* $8 */
1859         case '9':               /* $9 */
1860         case '[':               /* $[ */
1861         case '^':               /* $^ */
1862         case '~':               /* $~ */
1863         case '=':               /* $= */
1864         case '%':               /* $% */
1865         case '.':               /* $. */
1866         case '(':               /* $( */
1867         case ')':               /* $) */
1868         case '<':               /* $< */
1869         case '>':               /* $> */
1870         case '\\':              /* $\ */
1871         case '/':               /* $/ */
1872         case '$':               /* $$ */
1873         case '\001':    /* $^A */
1874         case '\003':    /* $^C */
1875         case '\004':    /* $^D */
1876         case '\005':    /* $^E */
1877         case '\006':    /* $^F */
1878         case '\011':    /* $^I, NOT \t in EBCDIC */
1879         case '\016':    /* $^N */
1880         case '\017':    /* $^O */
1881         case '\020':    /* $^P */
1882         case '\024':    /* $^T */
1883         case '\027':    /* $^W */
1884         magicalize:
1885             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1886             break;
1887
1888         case '\014':    /* $^L */
1889             sv_setpvs(GvSVn(gv),"\f");
1890             PL_formfeed = GvSVn(gv);
1891             break;
1892         case ';':               /* $; */
1893             sv_setpvs(GvSVn(gv),"\034");
1894             break;
1895         case ']':               /* $] */
1896         {
1897             SV * const sv = GvSV(gv);
1898             if (!sv_derived_from(PL_patchlevel, "version"))
1899                 upg_version(PL_patchlevel, TRUE);
1900             GvSV(gv) = vnumify(PL_patchlevel);
1901             SvREADONLY_on(GvSV(gv));
1902             SvREFCNT_dec(sv);
1903         }
1904         break;
1905         case '\026':    /* $^V */
1906         {
1907             SV * const sv = GvSV(gv);
1908             GvSV(gv) = new_version(PL_patchlevel);
1909             SvREADONLY_on(GvSV(gv));
1910             SvREFCNT_dec(sv);
1911         }
1912         break;
1913         }
1914     }
1915   add_magical_gv:
1916     if (addmg) {
1917         if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
1918              GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
1919            ))
1920             (void)hv_store(stash,name,len,(SV *)gv,0);
1921         else SvREFCNT_dec(gv), gv = NULL;
1922     }
1923     if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
1924     return gv;
1925 }
1926
1927 void
1928 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1929 {
1930     const char *name;
1931     STRLEN namelen;
1932     const HV * const hv = GvSTASH(gv);
1933
1934     PERL_ARGS_ASSERT_GV_FULLNAME4;
1935
1936     if (!hv) {
1937         SvOK_off(sv);
1938         return;
1939     }
1940     sv_setpv(sv, prefix ? prefix : "");
1941
1942     name = HvNAME_get(hv);
1943     if (name) {
1944         namelen = HvNAMELEN_get(hv);
1945     } else {
1946         name = "__ANON__";
1947         namelen = 8;
1948     }
1949
1950     if (keepmain || strNE(name, "main")) {
1951         sv_catpvn(sv,name,namelen);
1952         sv_catpvs(sv,"::");
1953     }
1954     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1955 }
1956
1957 void
1958 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1959 {
1960     const GV * const egv = GvEGVx(gv);
1961
1962     PERL_ARGS_ASSERT_GV_EFULLNAME4;
1963
1964     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1965 }
1966
1967 void
1968 Perl_gv_check(pTHX_ const HV *stash)
1969 {
1970     dVAR;
1971     register I32 i;
1972
1973     PERL_ARGS_ASSERT_GV_CHECK;
1974
1975     if (!HvARRAY(stash))
1976         return;
1977     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1978         const HE *entry;
1979         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1980             register GV *gv;
1981             HV *hv;
1982             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1983                 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
1984             {
1985                 if (hv != PL_defstash && hv != stash)
1986                      gv_check(hv);              /* nested package */
1987             }
1988             else if (isALPHA(*HeKEY(entry))) {
1989                 const char *file;
1990                 gv = MUTABLE_GV(HeVAL(entry));
1991                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1992                     continue;
1993                 file = GvFILE(gv);
1994                 CopLINE_set(PL_curcop, GvLINE(gv));
1995 #ifdef USE_ITHREADS
1996                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
1997 #else
1998                 CopFILEGV(PL_curcop)
1999                     = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2000 #endif
2001                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2002                         "Name \"%s::%s\" used only once: possible typo",
2003                         HvNAME_get(stash), GvNAME(gv));
2004             }
2005         }
2006     }
2007 }
2008
2009 GV *
2010 Perl_newGVgen(pTHX_ const char *pack)
2011 {
2012     dVAR;
2013
2014     PERL_ARGS_ASSERT_NEWGVGEN;
2015
2016     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
2017                       GV_ADD, SVt_PVGV);
2018 }
2019
2020 /* hopefully this is only called on local symbol table entries */
2021
2022 GP*
2023 Perl_gp_ref(pTHX_ GP *gp)
2024 {
2025     dVAR;
2026     if (!gp)
2027         return NULL;
2028     gp->gp_refcnt++;
2029     if (gp->gp_cv) {
2030         if (gp->gp_cvgen) {
2031             /* If the GP they asked for a reference to contains
2032                a method cache entry, clear it first, so that we
2033                don't infect them with our cached entry */
2034             SvREFCNT_dec(gp->gp_cv);
2035             gp->gp_cv = NULL;
2036             gp->gp_cvgen = 0;
2037         }
2038     }
2039     return gp;
2040 }
2041
2042 void
2043 Perl_gp_free(pTHX_ GV *gv)
2044 {
2045     dVAR;
2046     GP* gp;
2047     int attempts = 100;
2048
2049     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2050         return;
2051     if (gp->gp_refcnt == 0) {
2052         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2053                          "Attempt to free unreferenced glob pointers"
2054                          pTHX__FORMAT pTHX__VALUE);
2055         return;
2056     }
2057     if (--gp->gp_refcnt > 0) {
2058         if (gp->gp_egv == gv)
2059             gp->gp_egv = 0;
2060         GvGP_set(gv, NULL);
2061         return;
2062     }
2063
2064     while (1) {
2065       /* Copy and null out all the glob slots, so destructors do not see
2066          freed SVs. */
2067       HEK * const file_hek = gp->gp_file_hek;
2068       SV  * const sv       = gp->gp_sv;
2069       AV  * const av       = gp->gp_av;
2070       HV  * const hv       = gp->gp_hv;
2071       IO  * const io       = gp->gp_io;
2072       CV  * const cv       = gp->gp_cv;
2073       CV  * const form     = gp->gp_form;
2074
2075       gp->gp_file_hek = NULL;
2076       gp->gp_sv       = NULL;
2077       gp->gp_av       = NULL;
2078       gp->gp_hv       = NULL;
2079       gp->gp_io       = NULL;
2080       gp->gp_cv       = NULL;
2081       gp->gp_form     = NULL;
2082
2083       if (file_hek)
2084         unshare_hek(file_hek);
2085
2086       SvREFCNT_dec(sv);
2087       SvREFCNT_dec(av);
2088       /* FIXME - another reference loop GV -> symtab -> GV ?
2089          Somehow gp->gp_hv can end up pointing at freed garbage.  */
2090       if (hv && SvTYPE(hv) == SVt_PVHV) {
2091         const char *hvname = HvNAME_get(hv);
2092         if (PL_stashcache && hvname)
2093             (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(hv),
2094                       G_DISCARD);
2095         SvREFCNT_dec(hv);
2096       }
2097       SvREFCNT_dec(io);
2098       SvREFCNT_dec(cv);
2099       SvREFCNT_dec(form);
2100
2101       if (!gp->gp_file_hek
2102        && !gp->gp_sv
2103        && !gp->gp_av
2104        && !gp->gp_hv
2105        && !gp->gp_io
2106        && !gp->gp_cv
2107        && !gp->gp_form) break;
2108
2109       if (--attempts == 0) {
2110         Perl_die(aTHX_
2111           "panic: gp_free failed to free glob pointer - "
2112           "something is repeatedly re-creating entries"
2113         );
2114       }
2115     }
2116
2117     Safefree(gp);
2118     GvGP_set(gv, NULL);
2119 }
2120
2121 int
2122 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2123 {
2124     AMT * const amtp = (AMT*)mg->mg_ptr;
2125     PERL_UNUSED_ARG(sv);
2126
2127     PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2128
2129     if (amtp && AMT_AMAGIC(amtp)) {
2130         int i;
2131         for (i = 1; i < NofAMmeth; i++) {
2132             CV * const cv = amtp->table[i];
2133             if (cv) {
2134                 SvREFCNT_dec(MUTABLE_SV(cv));
2135                 amtp->table[i] = NULL;
2136             }
2137         }
2138     }
2139  return 0;
2140 }
2141
2142 /* Updates and caches the CV's */
2143 /* Returns:
2144  * 1 on success and there is some overload
2145  * 0 if there is no overload
2146  * -1 if some error occurred and it couldn't croak
2147  */
2148
2149 int
2150 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2151 {
2152   dVAR;
2153   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2154   AMT amt;
2155   const struct mro_meta* stash_meta = HvMROMETA(stash);
2156   U32 newgen;
2157
2158   PERL_ARGS_ASSERT_GV_AMUPDATE;
2159
2160   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2161   if (mg) {
2162       const AMT * const amtp = (AMT*)mg->mg_ptr;
2163       if (amtp->was_ok_am == PL_amagic_generation
2164           && amtp->was_ok_sub == newgen) {
2165           return AMT_OVERLOADED(amtp) ? 1 : 0;
2166       }
2167       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2168   }
2169
2170   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2171
2172   Zero(&amt,1,AMT);
2173   amt.was_ok_am = PL_amagic_generation;
2174   amt.was_ok_sub = newgen;
2175   amt.fallback = AMGfallNO;
2176   amt.flags = 0;
2177
2178   {
2179     int filled = 0, have_ovl = 0;
2180     int i, lim = 1;
2181
2182     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2183
2184     /* Try to find via inheritance. */
2185     GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2186     SV * const sv = gv ? GvSV(gv) : NULL;
2187     CV* cv;
2188
2189     if (!gv)
2190         lim = DESTROY_amg;              /* Skip overloading entries. */
2191 #ifdef PERL_DONT_CREATE_GVSV
2192     else if (!sv) {
2193         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
2194     }
2195 #endif
2196     else if (SvTRUE(sv))
2197         amt.fallback=AMGfallYES;
2198     else if (SvOK(sv))
2199         amt.fallback=AMGfallNEVER;
2200
2201     for (i = 1; i < lim; i++)
2202         amt.table[i] = NULL;
2203     for (; i < NofAMmeth; i++) {
2204         const char * const cooky = PL_AMG_names[i];
2205         /* Human-readable form, for debugging: */
2206         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
2207         const STRLEN l = PL_AMG_namelens[i];
2208
2209         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2210                      cp, HvNAME_get(stash)) );
2211         /* don't fill the cache while looking up!
2212            Creation of inheritance stubs in intermediate packages may
2213            conflict with the logic of runtime method substitution.
2214            Indeed, for inheritance A -> B -> C, if C overloads "+0",
2215            then we could have created stubs for "(+0" in A and C too.
2216            But if B overloads "bool", we may want to use it for
2217            numifying instead of C's "+0". */
2218         if (i >= DESTROY_amg)
2219             gv = Perl_gv_fetchmeth_pvn_autoload(aTHX_ stash, cooky, l, 0, 0);
2220         else                            /* Autoload taken care of below */
2221             gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2222         cv = 0;
2223         if (gv && (cv = GvCV(gv))) {
2224             if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
2225               const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
2226               if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
2227                && strEQ(hvname, "overload")) {
2228                 /* This is a hack to support autoloading..., while
2229                    knowing *which* methods were declared as overloaded. */
2230                 /* GvSV contains the name of the method. */
2231                 GV *ngv = NULL;
2232                 SV *gvsv = GvSV(gv);
2233
2234                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2235                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
2236                              (void*)GvSV(gv), cp, HvNAME(stash)) );
2237                 if (!gvsv || !SvPOK(gvsv)
2238                     || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2239                 {
2240                     /* Can be an import stub (created by "can"). */
2241                     if (destructing) {
2242                         return -1;
2243                     }
2244                     else {
2245                         const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
2246                         Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
2247                                     "in package \"%.256s\"",
2248                                    (GvCVGEN(gv) ? "Stub found while resolving"
2249                                     : "Can't resolve"),
2250                                    name, cp, HvNAME(stash));
2251                     }
2252                 }
2253                 cv = GvCV(gv = ngv);
2254               }
2255             }
2256             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2257                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2258                          GvNAME(CvGV(cv))) );
2259             filled = 1;
2260             if (i < DESTROY_amg)
2261                 have_ovl = 1;
2262         } else if (gv) {                /* Autoloaded... */
2263             cv = MUTABLE_CV(gv);
2264             filled = 1;
2265         }
2266         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2267     }
2268     if (filled) {
2269       AMT_AMAGIC_on(&amt);
2270       if (have_ovl)
2271           AMT_OVERLOADED_on(&amt);
2272       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2273                                                 (char*)&amt, sizeof(AMT));
2274       return have_ovl;
2275     }
2276   }
2277   /* Here we have no table: */
2278   /* no_table: */
2279   AMT_AMAGIC_off(&amt);
2280   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2281                                                 (char*)&amt, sizeof(AMTS));
2282   return 0;
2283 }
2284
2285
2286 CV*
2287 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2288 {
2289     dVAR;
2290     MAGIC *mg;
2291     AMT *amtp;
2292     U32 newgen;
2293     struct mro_meta* stash_meta;
2294
2295     if (!stash || !HvNAME_get(stash))
2296         return NULL;
2297
2298     stash_meta = HvMROMETA(stash);
2299     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2300
2301     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2302     if (!mg) {
2303       do_update:
2304         /* If we're looking up a destructor to invoke, we must avoid
2305          * that Gv_AMupdate croaks, because we might be dying already */
2306         if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
2307             /* and if it didn't found a destructor, we fall back
2308              * to a simpler method that will only look for the
2309              * destructor instead of the whole magic */
2310             if (id == DESTROY_amg) {
2311                 GV * const gv = gv_fetchmethod(stash, "DESTROY");
2312                 if (gv)
2313                     return GvCV(gv);
2314             }
2315             return NULL;
2316         }
2317         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2318     }
2319     assert(mg);
2320     amtp = (AMT*)mg->mg_ptr;
2321     if ( amtp->was_ok_am != PL_amagic_generation
2322          || amtp->was_ok_sub != newgen )
2323         goto do_update;
2324     if (AMT_AMAGIC(amtp)) {
2325         CV * const ret = amtp->table[id];
2326         if (ret && isGV(ret)) {         /* Autoloading stab */
2327             /* Passing it through may have resulted in a warning
2328                "Inherited AUTOLOAD for a non-method deprecated", since
2329                our caller is going through a function call, not a method call.
2330                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2331             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2332
2333             if (gv && GvCV(gv))
2334                 return GvCV(gv);
2335         }
2336         return ret;
2337     }
2338
2339     return NULL;
2340 }
2341
2342
2343 /* Implement tryAMAGICun_MG macro.
2344    Do get magic, then see if the stack arg is overloaded and if so call it.
2345    Flags:
2346         AMGf_set     return the arg using SETs rather than assigning to
2347                      the targ
2348         AMGf_numeric apply sv_2num to the stack arg.
2349 */
2350
2351 bool
2352 Perl_try_amagic_un(pTHX_ int method, int flags) {
2353     dVAR;
2354     dSP;
2355     SV* tmpsv;
2356     SV* const arg = TOPs;
2357
2358     SvGETMAGIC(arg);
2359
2360     if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2361                                               AMGf_noright | AMGf_unary))) {
2362         if (flags & AMGf_set) {
2363             SETs(tmpsv);
2364         }
2365         else {
2366             dTARGET;
2367             if (SvPADMY(TARG)) {
2368                 sv_setsv(TARG, tmpsv);
2369                 SETTARG;
2370             }
2371             else
2372                 SETs(tmpsv);
2373         }
2374         PUTBACK;
2375         return TRUE;
2376     }
2377
2378     if ((flags & AMGf_numeric) && SvROK(arg))
2379         *sp = sv_2num(arg);
2380     return FALSE;
2381 }
2382
2383
2384 /* Implement tryAMAGICbin_MG macro.
2385    Do get magic, then see if the two stack args are overloaded and if so
2386    call it.
2387    Flags:
2388         AMGf_set     return the arg using SETs rather than assigning to
2389                      the targ
2390         AMGf_assign  op may be called as mutator (eg +=)
2391         AMGf_numeric apply sv_2num to the stack arg.
2392 */
2393
2394 bool
2395 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2396     dVAR;
2397     dSP;
2398     SV* const left = TOPm1s;
2399     SV* const right = TOPs;
2400
2401     SvGETMAGIC(left);
2402     if (left != right)
2403         SvGETMAGIC(right);
2404
2405     if (SvAMAGIC(left) || SvAMAGIC(right)) {
2406         SV * const tmpsv = amagic_call(left, right, method,
2407                     ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2408         if (tmpsv) {
2409             if (flags & AMGf_set) {
2410                 (void)POPs;
2411                 SETs(tmpsv);
2412             }
2413             else {
2414                 dATARGET;
2415                 (void)POPs;
2416                 if (opASSIGN || SvPADMY(TARG)) {
2417                     sv_setsv(TARG, tmpsv);
2418                     SETTARG;
2419                 }
2420                 else
2421                     SETs(tmpsv);
2422             }
2423             PUTBACK;
2424             return TRUE;
2425         }
2426     }
2427     if(left==right && SvGMAGICAL(left)) {
2428         SV * const left = sv_newmortal();
2429         *(sp-1) = left;
2430         /* Print the uninitialized warning now, so it includes the vari-
2431            able name. */
2432         if (!SvOK(right)) {
2433             if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2434             sv_setsv_flags(left, &PL_sv_no, 0);
2435         }
2436         else sv_setsv_flags(left, right, 0);
2437         SvGETMAGIC(right);
2438     }
2439     if (flags & AMGf_numeric) {
2440         if (SvROK(TOPm1s))
2441             *(sp-1) = sv_2num(TOPm1s);
2442         if (SvROK(right))
2443             *sp     = sv_2num(right);
2444     }
2445     return FALSE;
2446 }
2447
2448 SV *
2449 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2450     SV *tmpsv = NULL;
2451
2452     PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2453
2454     while (SvAMAGIC(ref) && 
2455            (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2456                                 AMGf_noright | AMGf_unary))) { 
2457         if (!SvROK(tmpsv))
2458             Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2459         if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2460             /* Bail out if it returns us the same reference.  */
2461             return tmpsv;
2462         }
2463         ref = tmpsv;
2464     }
2465     return tmpsv ? tmpsv : ref;
2466 }
2467
2468 SV*
2469 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2470 {
2471   dVAR;
2472   MAGIC *mg;
2473   CV *cv=NULL;
2474   CV **cvp=NULL, **ocvp=NULL;
2475   AMT *amtp=NULL, *oamtp=NULL;
2476   int off = 0, off1, lr = 0, notfound = 0;
2477   int postpr = 0, force_cpy = 0;
2478   int assign = AMGf_assign & flags;
2479   const int assignshift = assign ? 1 : 0;
2480   int use_default_op = 0;
2481 #ifdef DEBUGGING
2482   int fl=0;
2483 #endif
2484   HV* stash=NULL;
2485
2486   PERL_ARGS_ASSERT_AMAGIC_CALL;
2487
2488   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2489       SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2490
2491       if ( !lex_mask || !SvOK(lex_mask) )
2492           /* overloading lexically disabled */
2493           return NULL;
2494       else if ( lex_mask && SvPOK(lex_mask) ) {
2495           /* we have an entry in the hints hash, check if method has been
2496            * masked by overloading.pm */
2497           STRLEN len;
2498           const int offset = method / 8;
2499           const int bit    = method % 8;
2500           char *pv = SvPV(lex_mask, len);
2501
2502           /* Bit set, so this overloading operator is disabled */
2503           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2504               return NULL;
2505       }
2506   }
2507
2508   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2509       && (stash = SvSTASH(SvRV(left)))
2510       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2511       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2512                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2513                         : NULL))
2514       && ((cv = cvp[off=method+assignshift])
2515           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2516                                                           * usual method */
2517                   (
2518 #ifdef DEBUGGING
2519                    fl = 1,
2520 #endif
2521                    cv = cvp[off=method])))) {
2522     lr = -1;                    /* Call method for left argument */
2523   } else {
2524     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2525       int logic;
2526
2527       /* look for substituted methods */
2528       /* In all the covered cases we should be called with assign==0. */
2529          switch (method) {
2530          case inc_amg:
2531            force_cpy = 1;
2532            if ((cv = cvp[off=add_ass_amg])
2533                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2534              right = &PL_sv_yes; lr = -1; assign = 1;
2535            }
2536            break;
2537          case dec_amg:
2538            force_cpy = 1;
2539            if ((cv = cvp[off = subtr_ass_amg])
2540                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2541              right = &PL_sv_yes; lr = -1; assign = 1;
2542            }
2543            break;
2544          case bool__amg:
2545            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2546            break;
2547          case numer_amg:
2548            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2549            break;
2550          case string_amg:
2551            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2552            break;
2553          case not_amg:
2554            (void)((cv = cvp[off=bool__amg])
2555                   || (cv = cvp[off=numer_amg])
2556                   || (cv = cvp[off=string_amg]));
2557            if (cv)
2558                postpr = 1;
2559            break;
2560          case copy_amg:
2561            {
2562              /*
2563                   * SV* ref causes confusion with the interpreter variable of
2564                   * the same name
2565                   */
2566              SV* const tmpRef=SvRV(left);
2567              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2568                 /*
2569                  * Just to be extra cautious.  Maybe in some
2570                  * additional cases sv_setsv is safe, too.
2571                  */
2572                 SV* const newref = newSVsv(tmpRef);
2573                 SvOBJECT_on(newref);
2574                 /* As a bit of a source compatibility hack, SvAMAGIC() and
2575                    friends dereference an RV, to behave the same was as when
2576                    overloading was stored on the reference, not the referant.
2577                    Hence we can't use SvAMAGIC_on()
2578                 */
2579                 SvFLAGS(newref) |= SVf_AMAGIC;
2580                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2581                 return newref;
2582              }
2583            }
2584            break;
2585          case abs_amg:
2586            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2587                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2588              SV* const nullsv=sv_2mortal(newSViv(0));
2589              if (off1==lt_amg) {
2590                SV* const lessp = amagic_call(left,nullsv,
2591                                        lt_amg,AMGf_noright);
2592                logic = SvTRUE(lessp);
2593              } else {
2594                SV* const lessp = amagic_call(left,nullsv,
2595                                        ncmp_amg,AMGf_noright);
2596                logic = (SvNV(lessp) < 0);
2597              }
2598              if (logic) {
2599                if (off==subtr_amg) {
2600                  right = left;
2601                  left = nullsv;
2602                  lr = 1;
2603                }
2604              } else {
2605                return left;
2606              }
2607            }
2608            break;
2609          case neg_amg:
2610            if ((cv = cvp[off=subtr_amg])) {
2611              right = left;
2612              left = sv_2mortal(newSViv(0));
2613              lr = 1;
2614            }
2615            break;
2616          case int_amg:
2617          case iter_amg:                 /* XXXX Eventually should do to_gv. */
2618          case ftest_amg:                /* XXXX Eventually should do to_gv. */
2619          case regexp_amg:
2620              /* FAIL safe */
2621              return NULL;       /* Delegate operation to standard mechanisms. */
2622              break;
2623          case to_sv_amg:
2624          case to_av_amg:
2625          case to_hv_amg:
2626          case to_gv_amg:
2627          case to_cv_amg:
2628              /* FAIL safe */
2629              return left;       /* Delegate operation to standard mechanisms. */
2630              break;
2631          default:
2632            goto not_found;
2633          }
2634          if (!cv) goto not_found;
2635     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2636                && (stash = SvSTASH(SvRV(right)))
2637                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2638                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2639                           ? (amtp = (AMT*)mg->mg_ptr)->table
2640                           : NULL))
2641                && (cv = cvp[off=method])) { /* Method for right
2642                                              * argument found */
2643       lr=1;
2644     } else if (((cvp && amtp->fallback > AMGfallNEVER)
2645                 || (ocvp && oamtp->fallback > AMGfallNEVER))
2646                && !(flags & AMGf_unary)) {
2647                                 /* We look for substitution for
2648                                  * comparison operations and
2649                                  * concatenation */
2650       if (method==concat_amg || method==concat_ass_amg
2651           || method==repeat_amg || method==repeat_ass_amg) {
2652         return NULL;            /* Delegate operation to string conversion */
2653       }
2654       off = -1;
2655       switch (method) {
2656          case lt_amg:
2657          case le_amg:
2658          case gt_amg:
2659          case ge_amg:
2660          case eq_amg:
2661          case ne_amg:
2662              off = ncmp_amg;
2663              break;
2664          case slt_amg:
2665          case sle_amg:
2666          case sgt_amg:
2667          case sge_amg:
2668          case seq_amg:
2669          case sne_amg:
2670              off = scmp_amg;
2671              break;
2672          }
2673       if (off != -1) {
2674           if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2675               cv = ocvp[off];
2676               lr = -1;
2677           }
2678           if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2679               cv = cvp[off];
2680               lr = 1;
2681           }
2682       }
2683       if (cv)
2684           postpr = 1;
2685       else
2686           goto not_found;
2687     } else {
2688     not_found:                  /* No method found, either report or croak */
2689       switch (method) {
2690          case to_sv_amg:
2691          case to_av_amg:
2692          case to_hv_amg:
2693          case to_gv_amg:
2694          case to_cv_amg:
2695              /* FAIL safe */
2696              return left;       /* Delegate operation to standard mechanisms. */
2697              break;
2698       }
2699       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2700         notfound = 1; lr = -1;
2701       } else if (cvp && (cv=cvp[nomethod_amg])) {
2702         notfound = 1; lr = 1;
2703       } else if ((use_default_op =
2704                   (!ocvp || oamtp->fallback >= AMGfallYES)
2705                   && (!cvp || amtp->fallback >= AMGfallYES))
2706                  && !DEBUG_o_TEST) {
2707         /* Skip generating the "no method found" message.  */
2708         return NULL;
2709       } else {
2710         SV *msg;
2711         if (off==-1) off=method;
2712         msg = sv_2mortal(Perl_newSVpvf(aTHX_
2713                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
2714                       AMG_id2name(method + assignshift),
2715                       (flags & AMGf_unary ? " " : "\n\tleft "),
2716                       SvAMAGIC(left)?
2717                         "in overloaded package ":
2718                         "has no overloaded magic",
2719                       SvAMAGIC(left)?
2720                         HvNAME_get(SvSTASH(SvRV(left))):
2721                         "",
2722                       SvAMAGIC(right)?
2723                         ",\n\tright argument in overloaded package ":
2724                         (flags & AMGf_unary
2725                          ? ""
2726                          : ",\n\tright argument has no overloaded magic"),
2727                       SvAMAGIC(right)?
2728                         HvNAME_get(SvSTASH(SvRV(right))):
2729                         ""));
2730         if (use_default_op) {
2731           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
2732         } else {
2733           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2734         }
2735         return NULL;
2736       }
2737       force_cpy = force_cpy || assign;
2738     }
2739   }
2740 #ifdef DEBUGGING
2741   if (!notfound) {
2742     DEBUG_o(Perl_deb(aTHX_
2743                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
2744                      AMG_id2name(off),
2745                      method+assignshift==off? "" :
2746                      " (initially \"",
2747                      method+assignshift==off? "" :
2748                      AMG_id2name(method+assignshift),
2749                      method+assignshift==off? "" : "\")",
2750                      flags & AMGf_unary? "" :
2751                      lr==1 ? " for right argument": " for left argument",
2752                      flags & AMGf_unary? " for argument" : "",
2753                      stash ? HvNAME_get(stash) : "null",
2754                      fl? ",\n\tassignment variant used": "") );
2755   }
2756 #endif
2757     /* Since we use shallow copy during assignment, we need
2758      * to dublicate the contents, probably calling user-supplied
2759      * version of copy operator
2760      */
2761     /* We need to copy in following cases:
2762      * a) Assignment form was called.
2763      *          assignshift==1,  assign==T, method + 1 == off
2764      * b) Increment or decrement, called directly.
2765      *          assignshift==0,  assign==0, method + 0 == off
2766      * c) Increment or decrement, translated to assignment add/subtr.
2767      *          assignshift==0,  assign==T,
2768      *          force_cpy == T
2769      * d) Increment or decrement, translated to nomethod.
2770      *          assignshift==0,  assign==0,
2771      *          force_cpy == T
2772      * e) Assignment form translated to nomethod.
2773      *          assignshift==1,  assign==T, method + 1 != off
2774      *          force_cpy == T
2775      */
2776     /*  off is method, method+assignshift, or a result of opcode substitution.
2777      *  In the latter case assignshift==0, so only notfound case is important.
2778      */
2779   if (( (method + assignshift == off)
2780         && (assign || (method == inc_amg) || (method == dec_amg)))
2781       || force_cpy)
2782   {
2783       /* newSVsv does not behave as advertised, so we copy missing
2784        * information by hand */
2785       SV *tmpRef = SvRV(left);
2786       SV *rv_copy;
2787       if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
2788           SvRV_set(left, rv_copy);
2789           SvSETMAGIC(left);
2790           SvREFCNT_dec(tmpRef);  
2791       }
2792   }
2793
2794   {
2795     dSP;
2796     BINOP myop;
2797     SV* res;
2798     const bool oldcatch = CATCH_GET;
2799
2800     CATCH_SET(TRUE);
2801     Zero(&myop, 1, BINOP);
2802     myop.op_last = (OP *) &myop;
2803     myop.op_next = NULL;
2804     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
2805
2806     PUSHSTACKi(PERLSI_OVERLOAD);
2807     ENTER;
2808     SAVEOP();
2809     PL_op = (OP *) &myop;
2810     if (PERLDB_SUB && PL_curstash != PL_debstash)
2811         PL_op->op_private |= OPpENTERSUB_DB;
2812     PUTBACK;
2813     Perl_pp_pushmark(aTHX);
2814
2815     EXTEND(SP, notfound + 5);
2816     PUSHs(lr>0? right: left);
2817     PUSHs(lr>0? left: right);
2818     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
2819     if (notfound) {
2820       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
2821                            AMG_id2namelen(method + assignshift), SVs_TEMP));
2822     }
2823     PUSHs(MUTABLE_SV(cv));
2824     PUTBACK;
2825
2826     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
2827       CALLRUNOPS(aTHX);
2828     LEAVE;
2829     SPAGAIN;
2830
2831     res=POPs;
2832     PUTBACK;
2833     POPSTACK;
2834     CATCH_SET(oldcatch);
2835
2836     if (postpr) {
2837       int ans;
2838       switch (method) {
2839       case le_amg:
2840       case sle_amg:
2841         ans=SvIV(res)<=0; break;
2842       case lt_amg:
2843       case slt_amg:
2844         ans=SvIV(res)<0; break;
2845       case ge_amg:
2846       case sge_amg:
2847         ans=SvIV(res)>=0; break;
2848       case gt_amg:
2849       case sgt_amg:
2850         ans=SvIV(res)>0; break;
2851       case eq_amg:
2852       case seq_amg:
2853         ans=SvIV(res)==0; break;
2854       case ne_amg:
2855       case sne_amg:
2856         ans=SvIV(res)!=0; break;
2857       case inc_amg:
2858       case dec_amg:
2859         SvSetSV(left,res); return left;
2860       case not_amg:
2861         ans=!SvTRUE(res); break;
2862       default:
2863         ans=0; break;
2864       }
2865       return boolSV(ans);
2866     } else if (method==copy_amg) {
2867       if (!SvROK(res)) {
2868         Perl_croak(aTHX_ "Copy method did not return a reference");
2869       }
2870       return SvREFCNT_inc(SvRV(res));
2871     } else {
2872       return res;
2873     }
2874   }
2875 }
2876
2877 void
2878 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2879 {
2880     dVAR;
2881     U32 hash;
2882
2883     PERL_ARGS_ASSERT_GV_NAME_SET;
2884     PERL_UNUSED_ARG(flags);
2885
2886     if (len > I32_MAX)
2887         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2888
2889     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2890         unshare_hek(GvNAME_HEK(gv));
2891     }
2892
2893     PERL_HASH(hash, name, len);
2894     GvNAME_HEK(gv) = share_hek(name, len, hash);
2895 }
2896
2897 /*
2898 =for apidoc gv_try_downgrade
2899
2900 If the typeglob C<gv> can be expressed more succinctly, by having
2901 something other than a real GV in its place in the stash, replace it
2902 with the optimised form.  Basic requirements for this are that C<gv>
2903 is a real typeglob, is sufficiently ordinary, and is only referenced
2904 from its package.  This function is meant to be used when a GV has been
2905 looked up in part to see what was there, causing upgrading, but based
2906 on what was found it turns out that the real GV isn't required after all.
2907
2908 If C<gv> is a completely empty typeglob, it is deleted from the stash.
2909
2910 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
2911 sub, the typeglob is replaced with a scalar-reference placeholder that
2912 more compactly represents the same thing.
2913
2914 =cut
2915 */
2916
2917 void
2918 Perl_gv_try_downgrade(pTHX_ GV *gv)
2919 {
2920     HV *stash;
2921     CV *cv;
2922     HEK *namehek;
2923     SV **gvp;
2924     PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
2925
2926     /* XXX Why and where does this leave dangling pointers during global
2927        destruction? */
2928     if (PL_phase == PERL_PHASE_DESTRUCT) return;
2929
2930     if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
2931             !SvOBJECT(gv) && !SvREADONLY(gv) &&
2932             isGV_with_GP(gv) && GvGP(gv) &&
2933             !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
2934             !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
2935             GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
2936         return;
2937     if (SvMAGICAL(gv)) {
2938         MAGIC *mg;
2939         /* only backref magic is allowed */
2940         if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
2941             return;
2942         for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
2943             if (mg->mg_type != PERL_MAGIC_backref)
2944                 return;
2945         }
2946     }
2947     cv = GvCV(gv);
2948     if (!cv) {
2949         HEK *gvnhek = GvNAME_HEK(gv);
2950         (void)hv_delete(stash, HEK_KEY(gvnhek),
2951             HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
2952     } else if (GvMULTI(gv) && cv &&
2953             !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
2954             CvSTASH(cv) == stash && CvGV(cv) == gv &&
2955             CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
2956             !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
2957             (namehek = GvNAME_HEK(gv)) &&
2958             (gvp = hv_fetch(stash, HEK_KEY(namehek),
2959                         HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
2960             *gvp == (SV*)gv) {
2961         SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
2962         SvREFCNT(gv) = 0;
2963         sv_clear((SV*)gv);
2964         SvREFCNT(gv) = 1;
2965         SvFLAGS(gv) = SVt_IV|SVf_ROK;
2966         SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
2967                                 STRUCT_OFFSET(XPVIV, xiv_iv));
2968         SvRV_set(gv, value);
2969     }
2970 }
2971
2972 #include "XSUB.h"
2973
2974 static void
2975 core_xsub(pTHX_ CV* cv)
2976 {
2977     Perl_croak(aTHX_
2978        "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
2979     );
2980 }
2981
2982 /*
2983  * Local variables:
2984  * c-indentation-style: bsd
2985  * c-basic-offset: 4
2986  * indent-tabs-mode: t
2987  * End:
2988  *
2989  * ex: set ts=8 sts=4 sw=4 noet:
2990  */