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