This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
eb4ab927febf468b96d9f21bf14edd07b4244d52
[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 A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
25 It is a structure that holds a pointer to a scalar, an array, a hash etc,
26 corresponding to $foo, @foo, %foo.
27
28 GVs are usually found as values in stashes (symbol table hashes) where
29 Perl stores its global variables.
30
31 =cut
32 */
33
34 #include "EXTERN.h"
35 #define PERL_IN_GV_C
36 #include "perl.h"
37 #include "overload.inc"
38 #include "keywords.h"
39 #include "feature.h"
40
41 static const char S_autoload[] = "AUTOLOAD";
42 #define S_autolen (sizeof("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         } else if (type == SVt_PVHV) {
65             what = "hash";
66         } else {
67             what = type == SVt_PVAV ? "array" : "scalar";
68         }
69         /* diag_listed_as: Bad symbol for filehandle */
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     {
85         *where = newSV_type(type);
86             if (type == SVt_PVAV
87              && memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA"))
88             sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
89     }
90     return gv;
91 }
92
93 GV *
94 Perl_gv_fetchfile(pTHX_ const char *name)
95 {
96     PERL_ARGS_ASSERT_GV_FETCHFILE;
97     return gv_fetchfile_flags(name, strlen(name), 0);
98 }
99
100 GV *
101 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
102                         const U32 flags)
103 {
104     char smallbuf[128];
105     char *tmpbuf;
106     const STRLEN tmplen = namelen + 2;
107     GV *gv;
108
109     PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS;
110     PERL_UNUSED_ARG(flags);
111
112     if (!PL_defstash)
113         return NULL;
114
115     if (tmplen <= sizeof smallbuf)
116         tmpbuf = smallbuf;
117     else
118         Newx(tmpbuf, tmplen, char);
119     /* This is where the debugger's %{"::_<$filename"} hash is created */
120     tmpbuf[0] = '_';
121     tmpbuf[1] = '<';
122     memcpy(tmpbuf + 2, name, namelen);
123     gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
124     if (!isGV(gv)) {
125         gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
126 #ifdef PERL_DONT_CREATE_GVSV
127         GvSV(gv) = newSVpvn(name, namelen);
128 #else
129         sv_setpvn(GvSV(gv), name, namelen);
130 #endif
131     }
132     if (PERLDB_LINE_OR_SAVESRC && !GvAV(gv))
133             hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile);
134     if (tmpbuf != smallbuf)
135         Safefree(tmpbuf);
136     return gv;
137 }
138
139 /*
140 =for apidoc gv_const_sv
141
142 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
143 inlining, or C<gv> is a placeholder reference that would be promoted to such
144 a typeglob, then returns the value returned by the sub.  Otherwise, returns
145 C<NULL>.
146
147 =cut
148 */
149
150 SV *
151 Perl_gv_const_sv(pTHX_ GV *gv)
152 {
153     PERL_ARGS_ASSERT_GV_CONST_SV;
154     PERL_UNUSED_CONTEXT;
155
156     if (SvTYPE(gv) == SVt_PVGV)
157         return cv_const_sv(GvCVu(gv));
158     return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV && SvTYPE(SvRV(gv)) != SVt_PVCV ? SvRV(gv) : NULL;
159 }
160
161 GP *
162 Perl_newGP(pTHX_ GV *const gv)
163 {
164     GP *gp;
165     U32 hash;
166     const char *file;
167     STRLEN len;
168 #ifndef USE_ITHREADS
169     GV *filegv;
170 #endif
171     dVAR;
172
173     PERL_ARGS_ASSERT_NEWGP;
174     Newxz(gp, 1, GP);
175     gp->gp_egv = gv; /* allow compiler to reuse gv after this */
176 #ifndef PERL_DONT_CREATE_GVSV
177     gp->gp_sv = newSV(0);
178 #endif
179
180     /* PL_curcop may be null here.  E.g.,
181         INIT { bless {} and exit }
182        frees INIT before looking up DESTROY (and creating *DESTROY)
183     */
184     if (PL_curcop) {
185         gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
186 #ifdef USE_ITHREADS
187         if (CopFILE(PL_curcop)) {
188             file = CopFILE(PL_curcop);
189             len = strlen(file);
190         }
191 #else
192         filegv = CopFILEGV(PL_curcop);
193         if (filegv) {
194             file = GvNAME(filegv)+2;
195             len = GvNAMELEN(filegv)-2;
196         }
197 #endif
198         else goto no_file;
199     }
200     else {
201         no_file:
202         file = "";
203         len = 0;
204     }
205
206     PERL_HASH(hash, file, len);
207     gp->gp_file_hek = share_hek(file, len, hash);
208     gp->gp_refcnt = 1;
209
210     return gp;
211 }
212
213 /* Assign CvGV(cv) = gv, handling weak references.
214  * See also S_anonymise_cv_maybe */
215
216 void
217 Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
218 {
219     GV * const oldgv = CvNAMED(cv) ? NULL : SvANY(cv)->xcv_gv_u.xcv_gv;
220     HEK *hek;
221     PERL_ARGS_ASSERT_CVGV_SET;
222
223     if (oldgv == gv)
224         return;
225
226     if (oldgv) {
227         if (CvCVGV_RC(cv)) {
228             SvREFCNT_dec_NN(oldgv);
229             CvCVGV_RC_off(cv);
230         }
231         else {
232             sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
233         }
234     }
235     else if ((hek = CvNAME_HEK(cv))) {
236         unshare_hek(hek);
237         CvLEXICAL_off(cv);
238     }
239
240     CvNAMED_off(cv);
241     SvANY(cv)->xcv_gv_u.xcv_gv = gv;
242     assert(!CvCVGV_RC(cv));
243
244     if (!gv)
245         return;
246
247     if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
248         Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
249     else {
250         CvCVGV_RC_on(cv);
251         SvREFCNT_inc_simple_void_NN(gv);
252     }
253 }
254
255 /* Convert CvSTASH + CvNAME_HEK into a GV.  Conceptually, all subs have a
256    GV, but for efficiency that GV may not in fact exist.  This function,
257    called by CvGV, reifies it. */
258
259 GV *
260 Perl_cvgv_from_hek(pTHX_ CV *cv)
261 {
262     GV *gv;
263     SV **svp;
264     PERL_ARGS_ASSERT_CVGV_FROM_HEK;
265     assert(SvTYPE(cv) == SVt_PVCV);
266     if (!CvSTASH(cv)) return NULL;
267     ASSUME(CvNAME_HEK(cv));
268     svp = hv_fetchhek(CvSTASH(cv), CvNAME_HEK(cv), 0);
269     gv = MUTABLE_GV(svp && *svp ? *svp : newSV(0));
270     if (!isGV(gv))
271         gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)),
272                 HEK_LEN(CvNAME_HEK(cv)),
273                 SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv)));
274     if (!CvNAMED(cv)) { /* gv_init took care of it */
275         assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv);
276         return gv;
277     }
278     unshare_hek(CvNAME_HEK(cv));
279     CvNAMED_off(cv);
280     SvANY(cv)->xcv_gv_u.xcv_gv = gv;
281     if (svp && *svp) SvREFCNT_inc_simple_void_NN(gv);
282     CvCVGV_RC_on(cv);
283     return gv;
284 }
285
286 /* Assign CvSTASH(cv) = st, handling weak references. */
287
288 void
289 Perl_cvstash_set(pTHX_ CV *cv, HV *st)
290 {
291     HV *oldst = CvSTASH(cv);
292     PERL_ARGS_ASSERT_CVSTASH_SET;
293     if (oldst == st)
294         return;
295     if (oldst)
296         sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
297     SvANY(cv)->xcv_stash = st;
298     if (st)
299         Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
300 }
301
302 /*
303 =for apidoc gv_init_pvn
304
305 Converts a scalar into a typeglob.  This is an incoercible typeglob;
306 assigning a reference to it will assign to one of its slots, instead of
307 overwriting it as happens with typeglobs created by C<SvSetSV>.  Converting
308 any scalar that is C<SvOK()> may produce unpredictable results and is reserved
309 for perl's internal use.
310
311 C<gv> is the scalar to be converted.
312
313 C<stash> is the parent stash/package, if any.
314
315 C<name> and C<len> give the name.  The name must be unqualified;
316 that is, it must not include the package name.  If C<gv> is a
317 stash element, it is the caller's responsibility to ensure that the name
318 passed to this function matches the name of the element.  If it does not
319 match, perl's internal bookkeeping will get out of sync.
320
321 C<flags> can be set to C<SVf_UTF8> if C<name> is a UTF-8 string, or
322 the return value of SvUTF8(sv).  It can also take the
323 C<GV_ADDMULTI> flag, which means to pretend that the GV has been
324 seen before (i.e., suppress "Used once" warnings).
325
326 =for apidoc gv_init
327
328 The old form of C<gv_init_pvn()>.  It does not work with UTF-8 strings, as it
329 has no flags parameter.  If the C<multi> parameter is set, the
330 C<GV_ADDMULTI> flag will be passed to C<gv_init_pvn()>.
331
332 =for apidoc gv_init_pv
333
334 Same as C<gv_init_pvn()>, but takes a nul-terminated string for the name
335 instead of separate char * and length parameters.
336
337 =for apidoc gv_init_sv
338
339 Same as C<gv_init_pvn()>, but takes an SV * for the name instead of separate
340 char * and length parameters.  C<flags> is currently unused.
341
342 =cut
343 */
344
345 void
346 Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
347 {
348    char *namepv;
349    STRLEN namelen;
350    PERL_ARGS_ASSERT_GV_INIT_SV;
351    namepv = SvPV(namesv, namelen);
352    if (SvUTF8(namesv))
353        flags |= SVf_UTF8;
354    gv_init_pvn(gv, stash, namepv, namelen, flags);
355 }
356
357 void
358 Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
359 {
360    PERL_ARGS_ASSERT_GV_INIT_PV;
361    gv_init_pvn(gv, stash, name, strlen(name), flags);
362 }
363
364 void
365 Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
366 {
367     const U32 old_type = SvTYPE(gv);
368     const bool doproto = old_type > SVt_NULL;
369     char * const proto = (doproto && SvPOK(gv))
370         ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
371         : NULL;
372     const STRLEN protolen = proto ? SvCUR(gv) : 0;
373     const U32 proto_utf8  = proto ? SvUTF8(gv) : 0;
374     SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
375     const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
376     const bool really_sub =
377         has_constant && SvTYPE(has_constant) == SVt_PVCV;
378     COP * const old = PL_curcop;
379
380     PERL_ARGS_ASSERT_GV_INIT_PVN;
381     assert (!(proto && has_constant));
382
383     if (has_constant) {
384         /* The constant has to be a scalar, array or subroutine.  */
385         switch (SvTYPE(has_constant)) {
386         case SVt_PVHV:
387         case SVt_PVFM:
388         case SVt_PVIO:
389             Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
390                        sv_reftype(has_constant, 0));
391             NOT_REACHED; /* NOTREACHED */
392             break;
393
394         default: NOOP;
395         }
396         SvRV_set(gv, NULL);
397         SvROK_off(gv);
398     }
399
400
401     if (old_type < SVt_PVGV) {
402         if (old_type >= SVt_PV)
403             SvCUR_set(gv, 0);
404         sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
405     }
406     if (SvLEN(gv)) {
407         if (proto) {
408             SvPV_set(gv, NULL);
409             SvLEN_set(gv, 0);
410             SvPOK_off(gv);
411         } else
412             Safefree(SvPVX_mutable(gv));
413     }
414     SvIOK_off(gv);
415     isGV_with_GP_on(gv);
416
417     if (really_sub && !CvISXSUB(has_constant) && CvSTART(has_constant)
418      && (  CvSTART(has_constant)->op_type == OP_NEXTSTATE
419         || CvSTART(has_constant)->op_type == OP_DBSTATE))
420         PL_curcop = (COP *)CvSTART(has_constant);
421     GvGP_set(gv, Perl_newGP(aTHX_ gv));
422     PL_curcop = old;
423     GvSTASH(gv) = stash;
424     if (stash)
425         Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
426     gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
427     if (flags & GV_ADDMULTI || doproto) /* doproto means it */
428         GvMULTI_on(gv);                 /* _was_ mentioned */
429     if (really_sub) {
430         /* Not actually a constant.  Just a regular sub.  */
431         CV * const cv = (CV *)has_constant;
432         GvCV_set(gv,cv);
433         if (CvNAMED(cv) && CvSTASH(cv) == stash && (
434                CvNAME_HEK(cv) == GvNAME_HEK(gv)
435             || (  HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv))
436                && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv))
437                && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv))
438                && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv))
439                )
440            ))
441             CvGV_set(cv,gv);
442     }
443     else if (doproto) {
444         CV *cv;
445         if (has_constant) {
446             /* newCONSTSUB takes ownership of the reference from us.  */
447             cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
448             /* In case op.c:S_process_special_blocks stole it: */
449             if (!GvCV(gv))
450                 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
451             assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
452             /* If this reference was a copy of another, then the subroutine
453                must have been "imported", by a Perl space assignment to a GV
454                from a reference to CV.  */
455             if (exported_constant)
456                 GvIMPORTED_CV_on(gv);
457             CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */
458         } else {
459             cv = newSTUB(gv,1);
460         }
461         if (proto) {
462             sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
463                             SV_HAS_TRAILING_NUL);
464             if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
465         }
466     }
467 }
468
469 STATIC void
470 S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
471 {
472     PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
473
474     switch (sv_type) {
475     case SVt_PVIO:
476         (void)GvIOn(gv);
477         break;
478     case SVt_PVAV:
479         (void)GvAVn(gv);
480         break;
481     case SVt_PVHV:
482         (void)GvHVn(gv);
483         break;
484 #ifdef PERL_DONT_CREATE_GVSV
485     case SVt_NULL:
486     case SVt_PVCV:
487     case SVt_PVFM:
488     case SVt_PVGV:
489         break;
490     default:
491         if(GvSVn(gv)) {
492             /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
493                If we just cast GvSVn(gv) to void, it ignores evaluating it for
494                its side effect */
495         }
496 #endif
497     }
498 }
499
500 static void core_xsub(pTHX_ CV* cv);
501
502 static GV *
503 S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
504                           const char * const name, const STRLEN len)
505 {
506     const int code = keyword(name, len, 1);
507     static const char file[] = __FILE__;
508     CV *cv, *oldcompcv = NULL;
509     int opnum = 0;
510     bool ampable = TRUE; /* &{}-able */
511     COP *oldcurcop = NULL;
512     yy_parser *oldparser = NULL;
513     I32 oldsavestack_ix = 0;
514
515     assert(gv || stash);
516     assert(name);
517
518     if (!code) return NULL; /* Not a keyword */
519     switch (code < 0 ? -code : code) {
520      /* no support for \&CORE::infix;
521         no support for funcs that do not parse like funcs */
522     case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD:
523     case KEY_BEGIN   : case KEY_CHECK  : case KEY_cmp:
524     case KEY_default : case KEY_DESTROY:
525     case KEY_do      : case KEY_dump   : case KEY_else  : case KEY_elsif  :
526     case KEY_END     : case KEY_eq     : case KEY_eval  :
527     case KEY_for     : case KEY_foreach: case KEY_format: case KEY_ge     :
528     case KEY_given   : case KEY_goto   : case KEY_grep  : case KEY_gt     :
529     case KEY_if      : case KEY_isa    : case KEY_INIT  : case KEY_last   :
530     case KEY_le      : case KEY_local  : case KEY_lt    : case KEY_m      :
531     case KEY_map     : case KEY_my:
532     case KEY_ne   : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
533     case KEY_package: case KEY_print: case KEY_printf:
534     case KEY_q    : case KEY_qq   : case KEY_qr     : case KEY_qw    :
535     case KEY_qx   : case KEY_redo : case KEY_require: case KEY_return:
536     case KEY_s    : case KEY_say  : case KEY_sort   :
537     case KEY_state: case KEY_sub  :
538     case KEY_tr   : case KEY_UNITCHECK: case KEY_unless:
539     case KEY_until: case KEY_use  : case KEY_when     : case KEY_while :
540     case KEY_x    : case KEY_xor  : case KEY_y        :
541         return NULL;
542     case KEY_chdir:
543     case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
544     case KEY_eof  : case KEY_exec: case KEY_exists :
545     case KEY_lstat:
546     case KEY_split:
547     case KEY_stat:
548     case KEY_system:
549     case KEY_truncate: case KEY_unlink:
550         ampable = FALSE;
551     }
552     if (!gv) {
553         gv = (GV *)newSV(0);
554         gv_init(gv, stash, name, len, TRUE);
555     }
556     GvMULTI_on(gv);
557     if (ampable) {
558         ENTER;
559         oldcurcop = PL_curcop;
560         oldparser = PL_parser;
561         lex_start(NULL, NULL, 0);
562         oldcompcv = PL_compcv;
563         PL_compcv = NULL; /* Prevent start_subparse from setting
564                              CvOUTSIDE. */
565         oldsavestack_ix = start_subparse(FALSE,0);
566         cv = PL_compcv;
567     }
568     else {
569         /* Avoid calling newXS, as it calls us, and things start to
570            get hairy. */
571         cv = MUTABLE_CV(newSV_type(SVt_PVCV));
572         GvCV_set(gv,cv);
573         GvCVGEN(gv) = 0;
574         CvISXSUB_on(cv);
575         CvXSUB(cv) = core_xsub;
576         PoisonPADLIST(cv);
577     }
578     CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
579                          from PL_curcop. */
580     /* XSUBs can't be perl lang/perl5db.pl debugged
581     if (PERLDB_LINE_OR_SAVESRC)
582         (void)gv_fetchfile(file); */
583     CvFILE(cv) = (char *)file;
584     /* XXX This is inefficient, as doing things this order causes
585            a prototype check in newATTRSUB.  But we have to do
586            it this order as we need an op number before calling
587            new ATTRSUB. */
588     (void)core_prototype((SV *)cv, name, code, &opnum);
589     if (stash)
590         (void)hv_store(stash,name,len,(SV *)gv,0);
591     if (ampable) {
592 #ifdef DEBUGGING
593         CV *orig_cv = cv;
594 #endif
595         CvLVALUE_on(cv);
596         /* newATTRSUB will free the CV and return NULL if we're still
597            compiling after a syntax error */
598         if ((cv = newATTRSUB_x(
599                    oldsavestack_ix, (OP *)gv,
600                    NULL,NULL,
601                    coresub_op(
602                      opnum
603                        ? newSVuv((UV)opnum)
604                        : newSVpvn(name,len),
605                      code, opnum
606                    ),
607                    TRUE
608                )) != NULL) {
609             assert(GvCV(gv) == orig_cv);
610             if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
611                 && opnum != OP_UNDEF && opnum != OP_KEYS)
612                 CvLVALUE_off(cv); /* Now *that* was a neat trick. */
613         }
614         LEAVE;
615         PL_parser = oldparser;
616         PL_curcop = oldcurcop;
617         PL_compcv = oldcompcv;
618     }
619     if (cv) {
620         SV *opnumsv = newSViv(
621             (opnum == OP_ENTEREVAL && len == 9 && memEQ(name, "evalbytes", 9)) ?
622                 (OP_ENTEREVAL | (1<<16))
623             : opnum ? opnum : (((I32)name[2]) << 16));
624         cv_set_call_checker_flags(cv, Perl_ck_entersub_args_core, opnumsv, 0);
625         SvREFCNT_dec_NN(opnumsv);
626     }
627
628     return gv;
629 }
630
631 /*
632 =for apidoc gv_fetchmeth
633
634 Like L</gv_fetchmeth_pvn>, but lacks a flags parameter.
635
636 =for apidoc gv_fetchmeth_sv
637
638 Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form
639 of an SV instead of a string/length pair.
640
641 =cut
642 */
643
644 GV *
645 Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
646 {
647     char *namepv;
648     STRLEN namelen;
649     PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
650     if (LIKELY(SvPOK_nog(namesv))) /* common case */
651         return gv_fetchmeth_internal(stash, namesv, NULL, 0, level,
652                                      flags | SvUTF8(namesv));
653     namepv = SvPV(namesv, namelen);
654     if (SvUTF8(namesv)) flags |= SVf_UTF8;
655     return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
656 }
657
658 /*
659 =for apidoc gv_fetchmeth_pv
660
661 Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string 
662 instead of a string/length pair.
663
664 =cut
665 */
666
667 GV *
668 Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
669 {
670     PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
671     return gv_fetchmeth_internal(stash, NULL, name, strlen(name), level, flags);
672 }
673
674 /*
675 =for apidoc gv_fetchmeth_pvn
676
677 Returns the glob with the given C<name> and a defined subroutine or
678 C<NULL>.  The glob lives in the given C<stash>, or in the stashes
679 accessible via C<@ISA> and C<UNIVERSAL::>.
680
681 The argument C<level> should be either 0 or -1.  If C<level==0>, as a
682 side-effect creates a glob with the given C<name> in the given C<stash>
683 which in the case of success contains an alias for the subroutine, and sets
684 up caching info for this glob.
685
686 The only significant values for C<flags> are C<GV_SUPER> and C<SVf_UTF8>.
687
688 C<GV_SUPER> indicates that we want to look up the method in the superclasses
689 of the C<stash>.
690
691 The
692 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
693 visible to Perl code.  So when calling C<call_sv>, you should not use
694 the GV directly; instead, you should use the method's CV, which can be
695 obtained from the GV with the C<GvCV> macro.
696
697 =for apidoc Amnh||GV_SUPER
698
699 =cut
700 */
701
702 /* NOTE: No support for tied ISA */
703
704 PERL_STATIC_INLINE GV*
705 S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, I32 level, U32 flags)
706 {
707     GV** gvp;
708     HE* he;
709     AV* linear_av;
710     SV** linear_svp;
711     SV* linear_sv;
712     HV* cstash, *cachestash;
713     GV* candidate = NULL;
714     CV* cand_cv = NULL;
715     GV* topgv = NULL;
716     const char *hvname;
717     STRLEN hvnamelen;
718     I32 create = (level >= 0) ? HV_FETCH_LVALUE : 0;
719     I32 items;
720     U32 topgen_cmp;
721     U32 is_utf8 = flags & SVf_UTF8;
722
723     /* UNIVERSAL methods should be callable without a stash */
724     if (!stash) {
725         create = 0;  /* probably appropriate */
726         if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
727             return 0;
728     }
729
730     assert(stash);
731
732     hvname = HvNAME_get(stash);
733     hvnamelen = HvNAMELEN_get(stash);
734     if (!hvname)
735       Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
736
737     assert(hvname);
738     assert(name || meth);
739
740     DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n",
741                       flags & GV_SUPER ? "SUPER " : "",
742                       name ? name : SvPV_nolen(meth), hvname) );
743
744     topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
745
746     if (flags & GV_SUPER) {
747         if (!HvAUX(stash)->xhv_mro_meta->super)
748             HvAUX(stash)->xhv_mro_meta->super = newHV();
749         cachestash = HvAUX(stash)->xhv_mro_meta->super;
750     }
751     else cachestash = stash;
752
753     /* check locally for a real method or a cache entry */
754     he = (HE*)hv_common(
755         cachestash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, create, NULL, 0
756     );
757     if (he) gvp = (GV**)&HeVAL(he);
758     else gvp = NULL;
759
760     if(gvp) {
761         topgv = *gvp;
762       have_gv:
763         assert(topgv);
764         if (SvTYPE(topgv) != SVt_PVGV)
765         {
766             if (!name)
767                 name = SvPV_nomg(meth, len);
768             gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
769         }
770         if ((cand_cv = GvCV(topgv))) {
771             /* If genuine method or valid cache entry, use it */
772             if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
773                 return topgv;
774             }
775             else {
776                 /* stale cache entry, junk it and move on */
777                 SvREFCNT_dec_NN(cand_cv);
778                 GvCV_set(topgv, NULL);
779                 cand_cv = NULL;
780                 GvCVGEN(topgv) = 0;
781             }
782         }
783         else if (GvCVGEN(topgv) == topgen_cmp) {
784             /* cache indicates no such method definitively */
785             return 0;
786         }
787         else if (stash == cachestash
788               && len > 1 /* shortest is uc */
789               && memEQs(hvname, HvNAMELEN_get(stash), "CORE")
790               && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
791             goto have_gv;
792     }
793
794     linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
795     linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
796     items = AvFILLp(linear_av); /* no +1, to skip over self */
797     while (items--) {
798         linear_sv = *linear_svp++;
799         assert(linear_sv);
800         cstash = gv_stashsv(linear_sv, 0);
801
802         if (!cstash) {
803             if ( ckWARN(WARN_SYNTAX)) {
804                 if(     /* these are loaded from Perl_Gv_AMupdate() one way or another */
805                            ( len    && name[0] == '(' )  /* overload.pm related, in particular "()" */
806                         || ( memEQs( name, len, "DESTROY") )
807                 ) {
808                      Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
809                             "Can't locate package %" SVf " for @%" HEKf "::ISA",
810                             SVfARG(linear_sv),
811                             HEKfARG(HvNAME_HEK(stash)));
812
813                 } else if( memEQs( name, len, "AUTOLOAD") ) {
814                     /* gobble this warning */
815                 } else {
816                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
817                         "While trying to resolve method call %.*s->%.*s()"
818                         " can not locate package \"%" SVf "\" yet it is mentioned in @%.*s::ISA"
819                         " (perhaps you forgot to load \"%" SVf "\"?)",
820                          (int) hvnamelen, hvname,
821                          (int) len, name,
822                         SVfARG(linear_sv),
823                          (int) hvnamelen, hvname,
824                          SVfARG(linear_sv));
825                 }
826             }
827             continue;
828         }
829
830         assert(cstash);
831
832         gvp = (GV**)hv_common(
833             cstash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, HV_FETCH_JUST_SV, NULL, 0
834         );
835         if (!gvp) {
836             if (len > 1 && HvNAMELEN_get(cstash) == 4) {
837                 const char *hvname = HvNAME(cstash); assert(hvname);
838                 if (strBEGINs(hvname, "CORE")
839                  && (candidate =
840                       S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
841                     ))
842                     goto have_candidate;
843             }
844             continue;
845         }
846         else candidate = *gvp;
847        have_candidate:
848         assert(candidate);
849         if (SvTYPE(candidate) != SVt_PVGV)
850             gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
851         if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
852             /*
853              * Found real method, cache method in topgv if:
854              *  1. topgv has no synonyms (else inheritance crosses wires)
855              *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
856              */
857             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
858                   CV *old_cv = GvCV(topgv);
859                   SvREFCNT_dec(old_cv);
860                   SvREFCNT_inc_simple_void_NN(cand_cv);
861                   GvCV_set(topgv, cand_cv);
862                   GvCVGEN(topgv) = topgen_cmp;
863             }
864             return candidate;
865         }
866     }
867
868     /* Check UNIVERSAL without caching */
869     if(level == 0 || level == -1) {
870         candidate = gv_fetchmeth_internal(NULL, meth, name, len, 1,
871                                           flags &~GV_SUPER);
872         if(candidate) {
873             cand_cv = GvCV(candidate);
874             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
875                   CV *old_cv = GvCV(topgv);
876                   SvREFCNT_dec(old_cv);
877                   SvREFCNT_inc_simple_void_NN(cand_cv);
878                   GvCV_set(topgv, cand_cv);
879                   GvCVGEN(topgv) = topgen_cmp;
880             }
881             return candidate;
882         }
883     }
884
885     if (topgv && GvREFCNT(topgv) == 1) {
886         /* cache the fact that the method is not defined */
887         GvCVGEN(topgv) = topgen_cmp;
888     }
889
890     return 0;
891 }
892
893 GV *
894 Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
895 {
896     PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
897     return gv_fetchmeth_internal(stash, NULL, name, len, level, flags);
898 }
899
900 /*
901 =for apidoc gv_fetchmeth_autoload
902
903 This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags
904 parameter.
905
906 =for apidoc gv_fetchmeth_sv_autoload
907
908 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
909 of an SV instead of a string/length pair.
910
911 =cut
912 */
913
914 GV *
915 Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
916 {
917    char *namepv;
918    STRLEN namelen;
919    PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
920    namepv = SvPV(namesv, namelen);
921    if (SvUTF8(namesv))
922        flags |= SVf_UTF8;
923    return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
924 }
925
926 /*
927 =for apidoc gv_fetchmeth_pv_autoload
928
929 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
930 instead of a string/length pair.
931
932 =cut
933 */
934
935 GV *
936 Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
937 {
938     PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
939     return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
940 }
941
942 /*
943 =for apidoc gv_fetchmeth_pvn_autoload
944
945 Same as C<gv_fetchmeth_pvn()>, but looks for autoloaded subroutines too.
946 Returns a glob for the subroutine.
947
948 For an autoloaded subroutine without a GV, will create a GV even
949 if C<level < 0>.  For an autoloaded subroutine without a stub, C<GvCV()>
950 of the result may be zero.
951
952 Currently, the only significant value for C<flags> is C<SVf_UTF8>.
953
954 =cut
955 */
956
957 GV *
958 Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
959 {
960     GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
961
962     PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
963
964     if (!gv) {
965         CV *cv;
966         GV **gvp;
967
968         if (!stash)
969             return NULL;        /* UNIVERSAL::AUTOLOAD could cause trouble */
970         if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
971             return NULL;
972         if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
973             return NULL;
974         cv = GvCV(gv);
975         if (!(CvROOT(cv) || CvXSUB(cv)))
976             return NULL;
977         /* Have an autoload */
978         if (level < 0)  /* Cannot do without a stub */
979             gv_fetchmeth_pvn(stash, name, len, 0, flags);
980         gvp = (GV**)hv_fetch(stash, name,
981                         (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
982         if (!gvp)
983             return NULL;
984         return *gvp;
985     }
986     return gv;
987 }
988
989 /*
990 =for apidoc gv_fetchmethod_autoload
991
992 Returns the glob which contains the subroutine to call to invoke the method
993 on the C<stash>.  In fact in the presence of autoloading this may be the
994 glob for "AUTOLOAD".  In this case the corresponding variable C<$AUTOLOAD> is
995 already setup.
996
997 The third parameter of C<gv_fetchmethod_autoload> determines whether
998 AUTOLOAD lookup is performed if the given method is not present: non-zero
999 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
1000 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
1001 with a non-zero C<autoload> parameter.
1002
1003 These functions grant C<"SUPER"> token
1004 as a prefix of the method name.  Note
1005 that if you want to keep the returned glob for a long time, you need to
1006 check for it being "AUTOLOAD", since at the later time the call may load a
1007 different subroutine due to C<$AUTOLOAD> changing its value.  Use the glob
1008 created as a side effect to do this.
1009
1010 These functions have the same side-effects as C<gv_fetchmeth> with
1011 C<level==0>.  The warning against passing the GV returned by
1012 C<gv_fetchmeth> to C<call_sv> applies equally to these functions.
1013
1014 =cut
1015 */
1016
1017 GV *
1018 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
1019 {
1020     PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
1021
1022     return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
1023 }
1024
1025 GV *
1026 Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
1027 {
1028     char *namepv;
1029     STRLEN namelen;
1030     PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
1031     namepv = SvPV(namesv, namelen);
1032     if (SvUTF8(namesv))
1033        flags |= SVf_UTF8;
1034     return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
1035 }
1036
1037 GV *
1038 Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
1039 {
1040     PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
1041     return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
1042 }
1043
1044 GV *
1045 Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
1046 {
1047     const char * const origname = name;
1048     const char * const name_end = name + len;
1049     const char *last_separator = NULL;
1050     GV* gv;
1051     HV* ostash = stash;
1052     SV *const error_report = MUTABLE_SV(stash);
1053     const U32 autoload = flags & GV_AUTOLOAD;
1054     const U32 do_croak = flags & GV_CROAK;
1055     const U32 is_utf8  = flags & SVf_UTF8;
1056
1057     PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
1058
1059     if (SvTYPE(stash) < SVt_PVHV)
1060         stash = NULL;
1061     else {
1062         /* The only way stash can become NULL later on is if last_separator is set,
1063            which in turn means that there is no need for a SVt_PVHV case
1064            the error reporting code.  */
1065     }
1066
1067     {
1068         /* check if the method name is fully qualified or
1069          * not, and separate the package name from the actual
1070          * method name.
1071          *
1072          * leaves last_separator pointing to the beginning of the
1073          * last package separator (either ' or ::) or 0
1074          * if none was found.
1075          *
1076          * leaves name pointing at the beginning of the
1077          * method name.
1078          */
1079         const char *name_cursor = name;
1080         const char * const name_em1 = name_end - 1; /* name_end minus 1 */
1081         for (name_cursor = name; name_cursor < name_end ; name_cursor++) {
1082             if (*name_cursor == '\'') {
1083                 last_separator = name_cursor;
1084                 name = name_cursor + 1;
1085             }
1086             else if (name_cursor < name_em1 && *name_cursor == ':' && name_cursor[1] == ':') {
1087                 last_separator = name_cursor++;
1088                 name = name_cursor + 1;
1089             }
1090         }
1091     }
1092
1093     /* did we find a separator? */
1094     if (last_separator) {
1095         STRLEN sep_len= last_separator - origname;
1096         if ( memEQs(origname, sep_len, "SUPER")) {
1097             /* ->SUPER::method should really be looked up in original stash */
1098             stash = CopSTASH(PL_curcop);
1099             flags |= GV_SUPER;
1100             DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
1101                          origname, HvENAME_get(stash), name) );
1102         }
1103         else if ( sep_len >= 7 &&
1104                  strBEGINs(last_separator - 7, "::SUPER")) {
1105             /* don't autovifify if ->NoSuchStash::SUPER::method */
1106             stash = gv_stashpvn(origname, sep_len - 7, is_utf8);
1107             if (stash) flags |= GV_SUPER;
1108         }
1109         else {
1110             /* don't autovifify if ->NoSuchStash::method */
1111             stash = gv_stashpvn(origname, sep_len, is_utf8);
1112         }
1113         ostash = stash;
1114     }
1115
1116     gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
1117     if (!gv) {
1118         /* This is the special case that exempts Foo->import and
1119            Foo->unimport from being an error even if there's no
1120           import/unimport subroutine */
1121         if (strEQ(name,"import") || strEQ(name,"unimport")) {
1122             gv = (GV*)sv_2mortal((SV*)newCONSTSUB_flags(NULL,
1123                                                 NULL, 0, 0, NULL));
1124         } else if (autoload)
1125             gv = gv_autoload_pvn(
1126                 ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags
1127             );
1128         if (!gv && do_croak) {
1129             /* Right now this is exclusively for the benefit of S_method_common
1130                in pp_hot.c  */
1131             if (stash) {
1132                 /* If we can't find an IO::File method, it might be a call on
1133                  * a filehandle. If IO:File has not been loaded, try to
1134                  * require it first instead of croaking */
1135                 const char *stash_name = HvNAME_get(stash);
1136                 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
1137                     && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
1138                                        STR_WITH_LEN("IO/File.pm"), 0,
1139                                        HV_FETCH_ISEXISTS, NULL, 0)
1140                 ) {
1141                     require_pv("IO/File.pm");
1142                     gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
1143                     if (gv)
1144                         return gv;
1145                 }
1146                 Perl_croak(aTHX_
1147                            "Can't locate object method \"%" UTF8f
1148                            "\" via package \"%" HEKf "\"",
1149                                     UTF8fARG(is_utf8, name_end - name, name),
1150                                     HEKfARG(HvNAME_HEK(stash)));
1151             }
1152             else {
1153                 SV* packnamesv;
1154
1155                 if (last_separator) {
1156                     packnamesv = newSVpvn_flags(origname, last_separator - origname,
1157                                                     SVs_TEMP | is_utf8);
1158                 } else {
1159                     packnamesv = error_report;
1160                 }
1161
1162                 Perl_croak(aTHX_
1163                            "Can't locate object method \"%" UTF8f
1164                            "\" via package \"%" SVf "\""
1165                            " (perhaps you forgot to load \"%" SVf "\"?)",
1166                            UTF8fARG(is_utf8, name_end - name, name),
1167                            SVfARG(packnamesv), SVfARG(packnamesv));
1168             }
1169         }
1170     }
1171     else if (autoload) {
1172         CV* const cv = GvCV(gv);
1173         if (!CvROOT(cv) && !CvXSUB(cv)) {
1174             GV* stubgv;
1175             GV* autogv;
1176
1177             if (CvANON(cv) || CvLEXICAL(cv))
1178                 stubgv = gv;
1179             else {
1180                 stubgv = CvGV(cv);
1181                 if (GvCV(stubgv) != cv)         /* orphaned import */
1182                     stubgv = gv;
1183             }
1184             autogv = gv_autoload_pvn(GvSTASH(stubgv),
1185                                   GvNAME(stubgv), GvNAMELEN(stubgv),
1186                                   GV_AUTOLOAD_ISMETHOD
1187                                    | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
1188             if (autogv)
1189                 gv = autogv;
1190         }
1191     }
1192
1193     return gv;
1194 }
1195
1196 GV*
1197 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
1198 {
1199    char *namepv;
1200    STRLEN namelen;
1201    PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
1202    namepv = SvPV(namesv, namelen);
1203    if (SvUTF8(namesv))
1204        flags |= SVf_UTF8;
1205    return gv_autoload_pvn(stash, namepv, namelen, flags);
1206 }
1207
1208 GV*
1209 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
1210 {
1211    PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
1212    return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
1213 }
1214
1215 GV*
1216 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
1217 {
1218     GV* gv;
1219     CV* cv;
1220     HV* varstash;
1221     GV* vargv;
1222     SV* varsv;
1223     SV *packname = NULL;
1224     U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
1225
1226     PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
1227
1228     if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1229         return NULL;
1230     if (stash) {
1231         if (SvTYPE(stash) < SVt_PVHV) {
1232             STRLEN packname_len = 0;
1233             const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
1234             packname = newSVpvn_flags(packname_ptr, packname_len,
1235                                       SVs_TEMP | SvUTF8(stash));
1236             stash = NULL;
1237         }
1238         else
1239             packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
1240         if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
1241     }
1242     if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE,
1243                                 is_utf8 | (flags & GV_SUPER))))
1244         return NULL;
1245     cv = GvCV(gv);
1246
1247     if (!(CvROOT(cv) || CvXSUB(cv)))
1248         return NULL;
1249
1250     /*
1251      * Inheriting AUTOLOAD for non-methods no longer works
1252      */
1253     if (
1254         !(flags & GV_AUTOLOAD_ISMETHOD)
1255      && (GvCVGEN(gv) || GvSTASH(gv) != stash)
1256     )
1257         Perl_croak(aTHX_ "Use of inherited AUTOLOAD for non-method %" SVf
1258                          "::%" UTF8f "() is no longer allowed",
1259                          SVfARG(packname),
1260                          UTF8fARG(is_utf8, len, name));
1261
1262     if (CvISXSUB(cv)) {
1263         /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
1264          * and split that value on the last '::', pass along the same data
1265          * via the SvPVX field in the CV, and the stash in CvSTASH.
1266          *
1267          * Due to an unfortunate accident of history, the SvPVX field
1268          * serves two purposes.  It is also used for the subroutine's pro-
1269          * type.  Since SvPVX has been documented as returning the sub name
1270          * for a long time, but not as returning the prototype, we have
1271          * to preserve the SvPVX AUTOLOAD behaviour and put the prototype
1272          * elsewhere.
1273          *
1274          * We put the prototype in the same allocated buffer, but after
1275          * the sub name.  The SvPOK flag indicates the presence of a proto-
1276          * type.  The CvAUTOLOAD flag indicates the presence of a sub name.
1277          * If both flags are on, then SvLEN is used to indicate the end of
1278          * the prototype (artificially lower than what is actually allo-
1279          * cated), at the risk of having to reallocate a few bytes unneces-
1280          * sarily--but that should happen very rarely, if ever.
1281          *
1282          * We use SvUTF8 for both prototypes and sub names, so if one is
1283          * UTF8, the other must be upgraded.
1284          */
1285         CvSTASH_set(cv, stash);
1286         if (SvPOK(cv)) { /* Ouch! */
1287             SV * const tmpsv = newSVpvn_flags(name, len, is_utf8);
1288             STRLEN ulen;
1289             const char *proto = CvPROTO(cv);
1290             assert(proto);
1291             if (SvUTF8(cv))
1292                 sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
1293             ulen = SvCUR(tmpsv);
1294             SvCUR_set(tmpsv, SvCUR(tmpsv) + 1); /* include null in string */
1295             sv_catpvn_flags(
1296                 tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
1297             );
1298             SvTEMP_on(tmpsv); /* Allow theft */
1299             sv_setsv_nomg((SV *)cv, tmpsv);
1300             SvTEMP_off(tmpsv);
1301             SvREFCNT_dec_NN(tmpsv);
1302             SvLEN_set(cv, SvCUR(cv) + 1);
1303             SvCUR_set(cv, ulen);
1304         }
1305         else {
1306           sv_setpvn((SV *)cv, name, len);
1307           SvPOK_off(cv);
1308           if (is_utf8)
1309             SvUTF8_on(cv);
1310           else SvUTF8_off(cv);
1311         }
1312         CvAUTOLOAD_on(cv);
1313     }
1314
1315     /*
1316      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1317      * The subroutine's original name may not be "AUTOLOAD", so we don't
1318      * use that, but for lack of anything better we will use the sub's
1319      * original package to look up $AUTOLOAD.
1320      */
1321     varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv));
1322     vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1323     ENTER;
1324
1325     if (!isGV(vargv)) {
1326         gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
1327 #ifdef PERL_DONT_CREATE_GVSV
1328         GvSV(vargv) = newSV(0);
1329 #endif
1330     }
1331     LEAVE;
1332     varsv = GvSVn(vargv);
1333     SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
1334     /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
1335     sv_setsv(varsv, packname);
1336     sv_catpvs(varsv, "::");
1337     /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1338        tainting if $FOO::AUTOLOAD was previously tainted, but is not now.  */
1339     sv_catpvn_flags(
1340         varsv, name, len,
1341         SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
1342     );
1343     if (is_utf8)
1344         SvUTF8_on(varsv);
1345     return gv;
1346 }
1347
1348
1349 /* require_tie_mod() internal routine for requiring a module
1350  * that implements the logic of automatic ties like %! and %-
1351  * It loads the module and then calls the _tie_it subroutine
1352  * with the passed gv as an argument.
1353  *
1354  * The "gv" parameter should be the glob.
1355  * "varname" holds the 1-char name of the var, used for error messages.
1356  * "namesv" holds the module name. Its refcount will be decremented.
1357  * "flags": if flag & 1 then save the scalar before loading.
1358  * For the protection of $! to work (it is set by this routine)
1359  * the sv slot must already be magicalized.
1360  */
1361 STATIC void
1362 S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name,
1363                         STRLEN len, const U32 flags)
1364 {
1365     const SV * const target = varname == '[' ? GvSV(gv) : (SV *)GvHV(gv);
1366
1367     PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1368
1369     /* If it is not tied */
1370     if (!target || !SvRMAGICAL(target)
1371      || !mg_find(target,
1372                  varname == '[' ? PERL_MAGIC_tiedscalar : PERL_MAGIC_tied))
1373     {
1374       HV *stash;
1375       GV **gvp;
1376       dSP;
1377
1378       PUSHSTACKi(PERLSI_MAGIC);
1379       ENTER;
1380
1381 #define GET_HV_FETCH_TIE_FUNC                            \
1382     (  (gvp = (GV **)hv_fetchs(stash, "_tie_it", 0))      \
1383     && *gvp                                                \
1384     && (  (isGV(*gvp) && GvCV(*gvp))                        \
1385        || (SvROK(*gvp) && SvTYPE(SvRV(*gvp)) == SVt_PVCV)  ) \
1386     )
1387
1388       /* Load the module if it is not loaded.  */
1389       if (!(stash = gv_stashpvn(name, len, 0))
1390        || ! GET_HV_FETCH_TIE_FUNC)
1391       {
1392         SV * const module = newSVpvn(name, len);
1393         const char type = varname == '[' ? '$' : '%';
1394         if ( flags & 1 )
1395             save_scalar(gv);
1396         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1397         assert(sp == PL_stack_sp);
1398         stash = gv_stashpvn(name, len, 0);
1399         if (!stash)
1400             Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available",
1401                     type, varname, name);
1402         else if (! GET_HV_FETCH_TIE_FUNC)
1403             Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it",
1404                     type, varname, name);
1405       }
1406       /* Now call the tie function.  It should be in *gvp.  */
1407       assert(gvp); assert(*gvp);
1408       PUSHMARK(SP);
1409       XPUSHs((SV *)gv);
1410       PUTBACK;
1411       call_sv((SV *)*gvp, G_VOID|G_DISCARD);
1412       LEAVE;
1413       POPSTACK;
1414     }
1415 }
1416
1417 /* add a require_tie_mod_s - the _s suffix is similar to pvs type suffixes,
1418  * IOW it means we do STR_WITH_LEN() ourselves and the user should pass in
1419  * a true string WITHOUT a len.
1420  */
1421 #define require_tie_mod_s(gv, varname, name, flags) \
1422     S_require_tie_mod(aTHX_ gv, varname, STR_WITH_LEN(name), flags)
1423
1424 /*
1425 =for apidoc gv_stashpv
1426
1427 Returns a pointer to the stash for a specified package.  Uses C<strlen> to
1428 determine the length of C<name>, then calls C<gv_stashpvn()>.
1429
1430 =cut
1431 */
1432
1433 HV*
1434 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1435 {
1436     PERL_ARGS_ASSERT_GV_STASHPV;
1437     return gv_stashpvn(name, strlen(name), create);
1438 }
1439
1440 /*
1441 =for apidoc gv_stashpvn
1442
1443 Returns a pointer to the stash for a specified package.  The C<namelen>
1444 parameter indicates the length of the C<name>, in bytes.  C<flags> is passed
1445 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1446 created if it does not already exist.  If the package does not exist and
1447 C<flags> is 0 (or any other setting that does not create packages) then C<NULL>
1448 is returned.
1449
1450 Flags may be one of:
1451
1452     GV_ADD
1453     SVf_UTF8
1454     GV_NOADD_NOINIT
1455     GV_NOINIT
1456     GV_NOEXPAND
1457     GV_ADDMG
1458
1459 The most important of which are probably C<GV_ADD> and C<SVf_UTF8>.
1460
1461 Note, use of C<gv_stashsv> instead of C<gv_stashpvn> where possible is strongly
1462 recommended for performance reasons.
1463
1464 =for apidoc Amnh||GV_ADD
1465
1466 =cut
1467 */
1468
1469 /*
1470 gv_stashpvn_internal
1471
1472 Perform the internal bits of gv_stashsvpvn_cached. You could think of this
1473 as being one half of the logic. Not to be called except from gv_stashsvpvn_cached().
1474
1475 */
1476
1477 PERL_STATIC_INLINE HV*
1478 S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags)
1479 {
1480     char smallbuf[128];
1481     char *tmpbuf;
1482     HV *stash;
1483     GV *tmpgv;
1484     U32 tmplen = namelen + 2;
1485
1486     PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL;
1487
1488     if (tmplen <= sizeof smallbuf)
1489         tmpbuf = smallbuf;
1490     else
1491         Newx(tmpbuf, tmplen, char);
1492     Copy(name, tmpbuf, namelen, char);
1493     tmpbuf[namelen]   = ':';
1494     tmpbuf[namelen+1] = ':';
1495     tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1496     if (tmpbuf != smallbuf)
1497         Safefree(tmpbuf);
1498     if (!tmpgv || !isGV_with_GP(tmpgv))
1499         return NULL;
1500     stash = GvHV(tmpgv);
1501     if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1502     assert(stash);
1503     if (!HvNAME_get(stash)) {
1504         hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1505         
1506         /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1507         /* If the containing stash has multiple effective
1508            names, see that this one gets them, too. */
1509         if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1510             mro_package_moved(stash, NULL, tmpgv, 1);
1511     }
1512     return stash;
1513 }
1514
1515 /*
1516 gv_stashsvpvn_cached
1517
1518 Returns a pointer to the stash for a specified package, possibly
1519 cached.  Implements both C<gv_stashpvn> and C<gv_stashsv>.
1520
1521 Requires one of either namesv or namepv to be non-null.
1522
1523 See C<L</gv_stashpvn>> for details on "flags".
1524
1525 Note the sv interface is strongly preferred for performance reasons.
1526
1527 */
1528
1529 #define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \
1530     assert(namesv || name)
1531
1532 HV*
1533 Perl_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags)
1534 {
1535     HV* stash;
1536     HE* he;
1537
1538     PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED;
1539
1540     he = (HE *)hv_common(
1541         PL_stashcache, namesv, name, namelen,
1542         (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0
1543     );
1544
1545     if (he) {
1546         SV *sv = HeVAL(he);
1547         HV *hv;
1548         assert(SvIOK(sv));
1549         hv = INT2PTR(HV*, SvIVX(sv));
1550         assert(SvTYPE(hv) == SVt_PVHV);
1551         return hv;
1552     }
1553     else if (flags & GV_CACHE_ONLY) return NULL;
1554
1555     if (namesv) {
1556         if (SvOK(namesv)) { /* prevent double uninit warning */
1557             STRLEN len;
1558             name = SvPV_const(namesv, len);
1559             namelen = len;
1560             flags |= SvUTF8(namesv);
1561         } else {
1562             name = ""; namelen = 0;
1563         }
1564     }
1565     stash = gv_stashpvn_internal(name, namelen, flags);
1566
1567     if (stash && namelen) {
1568         SV* const ref = newSViv(PTR2IV(stash));
1569         (void)hv_store(PL_stashcache, name,
1570             (flags & SVf_UTF8) ? -(I32)namelen : (I32)namelen, ref, 0);
1571     }
1572
1573     return stash;
1574 }
1575
1576 HV*
1577 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1578 {
1579     PERL_ARGS_ASSERT_GV_STASHPVN;
1580     return gv_stashsvpvn_cached(NULL, name, namelen, flags);
1581 }
1582
1583 /*
1584 =for apidoc gv_stashsv
1585
1586 Returns a pointer to the stash for a specified package.  See
1587 C<L</gv_stashpvn>>.
1588
1589 Note this interface is strongly preferred over C<gv_stashpvn> for performance
1590 reasons.
1591
1592 =cut
1593 */
1594
1595 HV*
1596 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1597 {
1598     PERL_ARGS_ASSERT_GV_STASHSV;
1599     return gv_stashsvpvn_cached(sv, NULL, 0, flags);
1600 }
1601
1602
1603 GV *
1604 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
1605     PERL_ARGS_ASSERT_GV_FETCHPV;
1606     return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
1607 }
1608
1609 GV *
1610 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1611     STRLEN len;
1612     const char * const nambeg =
1613        SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1614     PERL_ARGS_ASSERT_GV_FETCHSV;
1615     return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1616 }
1617
1618 PERL_STATIC_INLINE void
1619 S_gv_magicalize_isa(pTHX_ GV *gv)
1620 {
1621     AV* av;
1622
1623     PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1624
1625     av = GvAVn(gv);
1626     GvMULTI_on(gv);
1627     sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1628              NULL, 0);
1629 }
1630
1631 /* This function grabs name and tries to split a stash and glob
1632  * from its contents. TODO better description, comments
1633  * 
1634  * If the function returns TRUE and 'name == name_end', then
1635  * 'gv' can be directly returned to the caller of gv_fetchpvn_flags
1636  */
1637 PERL_STATIC_INLINE bool
1638 S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name,
1639                STRLEN *len, const char *nambeg, STRLEN full_len,
1640                const U32 is_utf8, const I32 add)
1641 {
1642     char *tmpfullbuf = NULL; /* only malloc one big chunk of memory when the smallbuff is not large enough */
1643     const char *name_cursor;
1644     const char *const name_end = nambeg + full_len;
1645     const char *const name_em1 = name_end - 1;
1646     char smallbuf[64]; /* small buffer to avoid a malloc when possible */
1647
1648     PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME;
1649     
1650     if (   full_len > 2
1651         && **name == '*'
1652         && isIDFIRST_lazy_if_safe(*name + 1, name_end, is_utf8))
1653     {
1654         /* accidental stringify on a GV? */
1655         (*name)++;
1656     }
1657
1658     for (name_cursor = *name; name_cursor < name_end; name_cursor++) {
1659         if (name_cursor < name_em1 &&
1660             ((*name_cursor == ':' && name_cursor[1] == ':')
1661            || *name_cursor == '\''))
1662         {
1663             if (!*stash)
1664                 *stash = PL_defstash;
1665             if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */
1666                 goto notok;
1667
1668             *len = name_cursor - *name;
1669             if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1670                 const char *key;
1671                 GV**gvp;
1672                 if (*name_cursor == ':') {
1673                     key = *name;
1674                     *len += 2;
1675                 }
1676                 else { /* using ' for package separator */
1677                     /* use our pre-allocated buffer when possible to save a malloc */
1678                     char *tmpbuf;
1679                     if ( *len+2 <= sizeof smallbuf)
1680                         tmpbuf = smallbuf;
1681                     else {
1682                         /* only malloc once if needed */
1683                         if (tmpfullbuf == NULL) /* only malloc&free once, a little more than needed */
1684                             Newx(tmpfullbuf, full_len+2, char);
1685                         tmpbuf = tmpfullbuf;
1686                     }
1687                     Copy(*name, tmpbuf, *len, char);
1688                     tmpbuf[(*len)++] = ':';
1689                     tmpbuf[(*len)++] = ':';
1690                     key = tmpbuf;
1691                 }
1692                 gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add);
1693                 *gv = gvp ? *gvp : NULL;
1694                 if (!*gv || *gv == (const GV *)&PL_sv_undef) {
1695                     goto notok;
1696                 }
1697                 /* here we know that *gv && *gv != &PL_sv_undef */
1698                 if (SvTYPE(*gv) != SVt_PVGV)
1699                     gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8);
1700                 else
1701                     GvMULTI_on(*gv);
1702
1703                 if (!(*stash = GvHV(*gv))) {
1704                     *stash = GvHV(*gv) = newHV();
1705                     if (!HvNAME_get(*stash)) {
1706                         if (GvSTASH(*gv) == PL_defstash && *len == 6
1707                             && strBEGINs(*name, "CORE"))
1708                             hv_name_sets(*stash, "CORE", 0);
1709                         else
1710                             hv_name_set(
1711                                 *stash, nambeg, name_cursor-nambeg, is_utf8
1712                             );
1713                     /* If the containing stash has multiple effective
1714                     names, see that this one gets them, too. */
1715                     if (HvAUX(GvSTASH(*gv))->xhv_name_count)
1716                         mro_package_moved(*stash, NULL, *gv, 1);
1717                     }
1718                 }
1719                 else if (!HvNAME_get(*stash))
1720                     hv_name_set(*stash, nambeg, name_cursor - nambeg, is_utf8);
1721             }
1722
1723             if (*name_cursor == ':')
1724                 name_cursor++;
1725             *name = name_cursor+1;
1726             if (*name == name_end) {
1727                 if (!*gv) {
1728                     *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1729                     if (SvTYPE(*gv) != SVt_PVGV) {
1730                         gv_init_pvn(*gv, PL_defstash, "main::", 6,
1731                                     GV_ADDMULTI);
1732                         GvHV(*gv) =
1733                             MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
1734                     }
1735                 }
1736                 goto ok;
1737             }
1738         }
1739     }
1740     *len = name_cursor - *name;
1741   ok:
1742     Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
1743     return TRUE;
1744   notok:
1745     Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
1746     return FALSE;
1747 }
1748
1749
1750 /* Checks if an unqualified name is in the main stash */
1751 PERL_STATIC_INLINE bool
1752 S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8)
1753 {
1754     PERL_ARGS_ASSERT_GV_IS_IN_MAIN;
1755     
1756     /* If it's an alphanumeric variable */
1757     if ( len && isIDFIRST_lazy_if_safe(name, name + len, is_utf8) ) {
1758         /* Some "normal" variables are always in main::,
1759          * like INC or STDOUT.
1760          */
1761         switch (len) {
1762             case 1:
1763             if (*name == '_')
1764                 return TRUE;
1765             break;
1766             case 3:
1767             if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1768                 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1769                 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1770                 return TRUE;
1771             break;
1772             case 4:
1773             if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1774                 && name[3] == 'V')
1775                 return TRUE;
1776             break;
1777             case 5:
1778             if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1779                 && name[3] == 'I' && name[4] == 'N')
1780                 return TRUE;
1781             break;
1782             case 6:
1783             if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1784                 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1785                     ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1786                 return TRUE;
1787             break;
1788             case 7:
1789             if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1790                 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1791                 && name[6] == 'T')
1792                 return TRUE;
1793             break;
1794         }
1795     }
1796     /* *{""}, or a special variable like $@ */
1797     else
1798         return TRUE;
1799     
1800     return FALSE;
1801 }
1802
1803
1804 /* This function is called if parse_gv_stash_name() failed to
1805  * find a stash, or if GV_NOTQUAL or an empty name was passed
1806  * to gv_fetchpvn_flags.
1807  * 
1808  * It returns FALSE if the default stash can't be found nor created,
1809  * which might happen during global destruction.
1810  */
1811 PERL_STATIC_INLINE bool
1812 S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len,
1813                const U32 is_utf8, const I32 add,
1814                const svtype sv_type)
1815 {
1816     PERL_ARGS_ASSERT_FIND_DEFAULT_STASH;
1817     
1818     /* No stash in name, so see how we can default */
1819
1820     if ( gv_is_in_main(name, len, is_utf8) ) {
1821         *stash = PL_defstash;
1822     }
1823     else {
1824         if (IN_PERL_COMPILETIME) {
1825             *stash = PL_curstash;
1826             if (add && (PL_hints & HINT_STRICT_VARS) &&
1827                 sv_type != SVt_PVCV &&
1828                 sv_type != SVt_PVGV &&
1829                 sv_type != SVt_PVFM &&
1830                 sv_type != SVt_PVIO &&
1831                 !(len == 1 && sv_type == SVt_PV &&
1832                 (*name == 'a' || *name == 'b')) )
1833             {
1834                 GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -(I32)len : (I32)len,0);
1835                 if (!gvp || *gvp == (const GV *)&PL_sv_undef ||
1836                     SvTYPE(*gvp) != SVt_PVGV)
1837                 {
1838                     *stash = NULL;
1839                 }
1840                 else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
1841                          (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1842                          (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1843                 {
1844                     /* diag_listed_as: Variable "%s" is not imported%s */
1845                     Perl_ck_warner_d(
1846                         aTHX_ packWARN(WARN_MISC),
1847                         "Variable \"%c%" UTF8f "\" is not imported",
1848                         sv_type == SVt_PVAV ? '@' :
1849                         sv_type == SVt_PVHV ? '%' : '$',
1850                         UTF8fARG(is_utf8, len, name));
1851                     if (GvCVu(*gvp))
1852                         Perl_ck_warner_d(
1853                             aTHX_ packWARN(WARN_MISC),
1854                             "\t(Did you mean &%" UTF8f " instead?)\n",
1855                             UTF8fARG(is_utf8, len, name)
1856                         );
1857                     *stash = NULL;
1858                 }
1859             }
1860         }
1861         else {
1862             /* Use the current op's stash */
1863             *stash = CopSTASH(PL_curcop);
1864         }
1865     }
1866
1867     if (!*stash) {
1868         if (add && !PL_in_clean_all) {
1869             GV *gv;
1870             qerror(Perl_mess(aTHX_
1871                  "Global symbol \"%s%" UTF8f
1872                  "\" requires explicit package name (did you forget to "
1873                  "declare \"my %s%" UTF8f "\"?)",
1874                  (sv_type == SVt_PV ? "$"
1875                   : sv_type == SVt_PVAV ? "@"
1876                   : sv_type == SVt_PVHV ? "%"
1877                   : ""), UTF8fARG(is_utf8, len, name),
1878                  (sv_type == SVt_PV ? "$"
1879                   : sv_type == SVt_PVAV ? "@"
1880                   : sv_type == SVt_PVHV ? "%"
1881                   : ""), UTF8fARG(is_utf8, len, name)));
1882             /* To maintain the output of errors after the strict exception
1883              * above, and to keep compat with older releases, rather than
1884              * placing the variables in the pad, we place
1885              * them in the <none>:: stash.
1886              */
1887             gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1888             if (!gv) {
1889                 /* symbol table under destruction */
1890                 return FALSE;
1891             }
1892             *stash = GvHV(gv);
1893         }
1894         else
1895             return FALSE;
1896     }
1897
1898     if (!SvREFCNT(*stash))   /* symbol table under destruction */
1899         return FALSE;
1900
1901     return TRUE;
1902 }
1903
1904 /* gv_magicalize only turns on the SVf_READONLY flag, not SVf_PROTECT.  So
1905    redefine SvREADONLY_on for that purpose.  We don’t use it later on in
1906    this file.  */
1907 #undef SvREADONLY_on
1908 #define SvREADONLY_on(sv) (SvFLAGS(sv) |= SVf_READONLY)
1909
1910 /* gv_magicalize() is called by gv_fetchpvn_flags when creating
1911  * a new GV.
1912  * Note that it does not insert the GV into the stash prior to
1913  * magicalization, which some variables require need in order
1914  * to work (like %+, %-, %!), so callers must take care of
1915  * that.
1916  * 
1917  * It returns true if the gv did turn out to be magical one; i.e.,
1918  * if gv_magicalize actually did something.
1919  */
1920 PERL_STATIC_INLINE bool
1921 S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
1922                       const svtype sv_type)
1923 {
1924     SSize_t paren;
1925
1926     PERL_ARGS_ASSERT_GV_MAGICALIZE;
1927     
1928     if (stash != PL_defstash) { /* not the main stash */
1929         /* We only have to check for a few names here: a, b, EXPORT, ISA
1930            and VERSION. All the others apply only to the main stash or to
1931            CORE (which is checked right after this). */
1932         if (len) {
1933             switch (*name) {
1934             case 'E':
1935                 if (
1936                     len >= 6 && name[1] == 'X' &&
1937                     (memEQs(name, len, "EXPORT")
1938                     ||memEQs(name, len, "EXPORT_OK")
1939                     ||memEQs(name, len, "EXPORT_FAIL")
1940                     ||memEQs(name, len, "EXPORT_TAGS"))
1941                 )
1942                     GvMULTI_on(gv);
1943                 break;
1944             case 'I':
1945                 if (memEQs(name, len, "ISA"))
1946                     gv_magicalize_isa(gv);
1947                 break;
1948             case 'V':
1949                 if (memEQs(name, len, "VERSION"))
1950                     GvMULTI_on(gv);
1951                 break;
1952             case 'a':
1953                 if (stash == PL_debstash && memEQs(name, len, "args")) {
1954                     GvMULTI_on(gv_AVadd(gv));
1955                     break;
1956                 }
1957                 /* FALLTHROUGH */
1958             case 'b':
1959                 if (len == 1 && sv_type == SVt_PV)
1960                     GvMULTI_on(gv);
1961                 /* FALLTHROUGH */
1962             default:
1963                 goto try_core;
1964             }
1965             goto ret;
1966         }
1967       try_core:
1968         if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1969           /* Avoid null warning: */
1970           const char * const stashname = HvNAME(stash); assert(stashname);
1971           if (strBEGINs(stashname, "CORE"))
1972             S_maybe_add_coresub(aTHX_ 0, gv, name, len);
1973         }
1974     }
1975     else if (len > 1) {
1976 #ifndef EBCDIC
1977         if (*name > 'V' ) {
1978             NOOP;
1979             /* Nothing else to do.
1980                The compiler will probably turn the switch statement into a
1981                branch table. Make sure we avoid even that small overhead for
1982                the common case of lower case variable names.  (On EBCDIC
1983                platforms, we can't just do:
1984                  if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) {
1985                because cases like '\027' in the switch statement below are
1986                C1 (non-ASCII) controls on those platforms, so the remapping
1987                would make them larger than 'V')
1988              */
1989         } else
1990 #endif
1991         {
1992             switch (*name) {
1993             case 'A':
1994                 if (memEQs(name, len, "ARGV")) {
1995                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1996                 }
1997                 else if (memEQs(name, len, "ARGVOUT")) {
1998                     GvMULTI_on(gv);
1999                 }
2000                 break;
2001             case 'E':
2002                 if (
2003                     len >= 6 && name[1] == 'X' &&
2004                     (memEQs(name, len, "EXPORT")
2005                     ||memEQs(name, len, "EXPORT_OK")
2006                     ||memEQs(name, len, "EXPORT_FAIL")
2007                     ||memEQs(name, len, "EXPORT_TAGS"))
2008                 )
2009                     GvMULTI_on(gv);
2010                 break;
2011             case 'I':
2012                 if (memEQs(name, len, "ISA")) {
2013                     gv_magicalize_isa(gv);
2014                 }
2015                 break;
2016             case 'S':
2017                 if (memEQs(name, len, "SIG")) {
2018                     HV *hv;
2019                     I32 i;
2020                     if (!PL_psig_name) {
2021                         Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
2022                         Newxz(PL_psig_pend, SIG_SIZE, int);
2023                         PL_psig_ptr = PL_psig_name + SIG_SIZE;
2024                     } else {
2025                         /* I think that the only way to get here is to re-use an
2026                            embedded perl interpreter, where the previous
2027                            use didn't clean up fully because
2028                            PL_perl_destruct_level was 0. I'm not sure that we
2029                            "support" that, in that I suspect in that scenario
2030                            there are sufficient other garbage values left in the
2031                            interpreter structure that something else will crash
2032                            before we get here. I suspect that this is one of
2033                            those "doctor, it hurts when I do this" bugs.  */
2034                         Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
2035                         Zero(PL_psig_pend, SIG_SIZE, int);
2036                     }
2037                     GvMULTI_on(gv);
2038                     hv = GvHVn(gv);
2039                     hv_magic(hv, NULL, PERL_MAGIC_sig);
2040                     for (i = 1; i < SIG_SIZE; i++) {
2041                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
2042                         if (init)
2043                             sv_setsv(*init, &PL_sv_undef);
2044                     }
2045                 }
2046                 break;
2047             case 'V':
2048                 if (memEQs(name, len, "VERSION"))
2049                     GvMULTI_on(gv);
2050                 break;
2051             case '\003':        /* $^CHILD_ERROR_NATIVE */
2052                 if (memEQs(name, len, "\003HILD_ERROR_NATIVE"))
2053                     goto magicalize;
2054                                 /* @{^CAPTURE} %{^CAPTURE} */
2055                 if (memEQs(name, len, "\003APTURE")) {
2056                     AV* const av = GvAVn(gv);
2057                     const Size_t n = *name;
2058
2059                     sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
2060                     SvREADONLY_on(av);
2061
2062                     require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
2063
2064                 } else          /* %{^CAPTURE_ALL} */
2065                 if (memEQs(name, len, "\003APTURE_ALL")) {
2066                     require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
2067                 }
2068                 break;
2069             case '\005':        /* $^ENCODING */
2070                 if (memEQs(name, len, "\005NCODING"))
2071                     goto magicalize;
2072                 break;
2073             case '\007':        /* $^GLOBAL_PHASE */
2074                 if (memEQs(name, len, "\007LOBAL_PHASE"))
2075                     goto ro_magicalize;
2076                 break;
2077             case '\014':        /* $^LAST_FH */
2078                 if (memEQs(name, len, "\014AST_FH"))
2079                     goto ro_magicalize;
2080                 break;
2081             case '\015':        /* $^MATCH */
2082                 if (memEQs(name, len, "\015ATCH")) {
2083                     paren = RX_BUFF_IDX_CARET_FULLMATCH;
2084                     goto storeparen;
2085                 }
2086                 break;
2087             case '\017':        /* $^OPEN */
2088                 if (memEQs(name, len, "\017PEN"))
2089                     goto magicalize;
2090                 break;
2091             case '\020':        /* $^PREMATCH  $^POSTMATCH */
2092                 if (memEQs(name, len, "\020REMATCH")) {
2093                     paren = RX_BUFF_IDX_CARET_PREMATCH;
2094                     goto storeparen;
2095                 }
2096                 if (memEQs(name, len, "\020OSTMATCH")) {
2097                     paren = RX_BUFF_IDX_CARET_POSTMATCH;
2098                     goto storeparen;
2099                 }
2100                 break;
2101             case '\023':
2102                 if (memEQs(name, len, "\023AFE_LOCALES"))
2103                     goto ro_magicalize;
2104                 break;
2105             case '\024':        /* ${^TAINT} */
2106                 if (memEQs(name, len, "\024AINT"))
2107                     goto ro_magicalize;
2108                 break;
2109             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
2110                 if (memEQs(name, len, "\025NICODE"))
2111                     goto ro_magicalize;
2112                 if (memEQs(name, len, "\025TF8LOCALE"))
2113                     goto ro_magicalize;
2114                 if (memEQs(name, len, "\025TF8CACHE"))
2115                     goto magicalize;
2116                 break;
2117             case '\027':        /* $^WARNING_BITS */
2118                 if (memEQs(name, len, "\027ARNING_BITS"))
2119                     goto magicalize;
2120 #ifdef WIN32
2121                 else if (memEQs(name, len, "\027IN32_SLOPPY_STAT"))
2122                     goto magicalize;
2123 #endif
2124                 break;
2125             case '1':
2126             case '2':
2127             case '3':
2128             case '4':
2129             case '5':
2130             case '6':
2131             case '7':
2132             case '8':
2133             case '9':
2134             {
2135                 /* Ensures that we have an all-digit variable, ${"1foo"} fails
2136                    this test  */
2137                 UV uv;
2138                 if (!grok_atoUV(name, &uv, NULL) || uv > I32_MAX)
2139                     goto ret;
2140                 /* XXX why are we using a SSize_t? */
2141                 paren = (SSize_t)(I32)uv;
2142                 goto storeparen;
2143             }
2144             }
2145         }
2146     } else {
2147         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
2148            be case '\0' in this switch statement (ie a default case)  */
2149         switch (*name) {
2150         case '&':               /* $& */
2151             paren = RX_BUFF_IDX_FULLMATCH;
2152             goto sawampersand;
2153         case '`':               /* $` */
2154             paren = RX_BUFF_IDX_PREMATCH;
2155             goto sawampersand;
2156         case '\'':              /* $' */
2157             paren = RX_BUFF_IDX_POSTMATCH;
2158         sawampersand:
2159 #ifdef PERL_SAWAMPERSAND
2160             if (!(
2161                 sv_type == SVt_PVAV ||
2162                 sv_type == SVt_PVHV ||
2163                 sv_type == SVt_PVCV ||
2164                 sv_type == SVt_PVFM ||
2165                 sv_type == SVt_PVIO
2166                 )) { PL_sawampersand |=
2167                         (*name == '`')
2168                             ? SAWAMPERSAND_LEFT
2169                             : (*name == '&')
2170                                 ? SAWAMPERSAND_MIDDLE
2171                                 : SAWAMPERSAND_RIGHT;
2172                 }
2173 #endif
2174             goto storeparen;
2175         case '1':               /* $1 */
2176         case '2':               /* $2 */
2177         case '3':               /* $3 */
2178         case '4':               /* $4 */
2179         case '5':               /* $5 */
2180         case '6':               /* $6 */
2181         case '7':               /* $7 */
2182         case '8':               /* $8 */
2183         case '9':               /* $9 */
2184             paren = *name - '0';
2185
2186         storeparen:
2187             /* Flag the capture variables with a NULL mg_ptr
2188                Use mg_len for the array index to lookup.  */
2189             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren);
2190             break;
2191
2192         case ':':               /* $: */
2193             sv_setpv(GvSVn(gv),PL_chopset);
2194             goto magicalize;
2195
2196         case '?':               /* $? */
2197 #ifdef COMPLEX_STATUS
2198             SvUPGRADE(GvSVn(gv), SVt_PVLV);
2199 #endif
2200             goto magicalize;
2201
2202         case '!':               /* $! */
2203             GvMULTI_on(gv);
2204             /* If %! has been used, automatically load Errno.pm. */
2205
2206             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2207
2208             /* magicalization must be done before require_tie_mod_s is called */
2209             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2210                 require_tie_mod_s(gv, '!', "Errno", 1);
2211
2212             break;
2213         case '-':               /* $-, %-, @- */
2214         case '+':               /* $+, %+, @+ */
2215             GvMULTI_on(gv); /* no used once warnings here */
2216             {   /* $- $+ */
2217                 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2218                 if (*name == '+')
2219                     SvREADONLY_on(GvSVn(gv));
2220             }
2221             {   /* %- %+ */
2222                 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2223                     require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture",0);
2224             }
2225             {   /* @- @+ */
2226                 AV* const av = GvAVn(gv);
2227                 const Size_t n = *name;
2228
2229                 sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
2230                 SvREADONLY_on(av);
2231             }
2232             break;
2233         case '*':               /* $* */
2234         case '#':               /* $# */
2235         if (sv_type == SVt_PV)
2236             /* diag_listed_as: $* is no longer supported as of Perl 5.30 */
2237             Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name);
2238         break;
2239         case '\010':    /* $^H */
2240             {
2241                 HV *const hv = GvHVn(gv);
2242                 hv_magic(hv, NULL, PERL_MAGIC_hints);
2243             }
2244             goto magicalize;
2245         case '\023':    /* $^S */
2246         ro_magicalize:
2247             SvREADONLY_on(GvSVn(gv));
2248             /* FALLTHROUGH */
2249         case '0':               /* $0 */
2250         case '^':               /* $^ */
2251         case '~':               /* $~ */
2252         case '=':               /* $= */
2253         case '%':               /* $% */
2254         case '.':               /* $. */
2255         case '(':               /* $( */
2256         case ')':               /* $) */
2257         case '<':               /* $< */
2258         case '>':               /* $> */
2259         case '\\':              /* $\ */
2260         case '/':               /* $/ */
2261         case '|':               /* $| */
2262         case '$':               /* $$ */
2263         case '[':               /* $[ */
2264         case '\001':    /* $^A */
2265         case '\003':    /* $^C */
2266         case '\004':    /* $^D */
2267         case '\005':    /* $^E */
2268         case '\006':    /* $^F */
2269         case '\011':    /* $^I, NOT \t in EBCDIC */
2270         case '\016':    /* $^N */
2271         case '\017':    /* $^O */
2272         case '\020':    /* $^P */
2273         case '\024':    /* $^T */
2274         case '\027':    /* $^W */
2275         magicalize:
2276             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2277             break;
2278
2279         case '\014':    /* $^L */
2280             sv_setpvs(GvSVn(gv),"\f");
2281             break;
2282         case ';':               /* $; */
2283             sv_setpvs(GvSVn(gv),"\034");
2284             break;
2285         case ']':               /* $] */
2286         {
2287             SV * const sv = GvSV(gv);
2288             if (!sv_derived_from(PL_patchlevel, "version"))
2289                 upg_version(PL_patchlevel, TRUE);
2290             GvSV(gv) = vnumify(PL_patchlevel);
2291             SvREADONLY_on(GvSV(gv));
2292             SvREFCNT_dec(sv);
2293         }
2294         break;
2295         case '\026':    /* $^V */
2296         {
2297             SV * const sv = GvSV(gv);
2298             GvSV(gv) = new_version(PL_patchlevel);
2299             SvREADONLY_on(GvSV(gv));
2300             SvREFCNT_dec(sv);
2301         }
2302         break;
2303         case 'a':
2304         case 'b':
2305             if (sv_type == SVt_PV)
2306                 GvMULTI_on(gv);
2307         }
2308     }
2309
2310    ret:
2311     /* Return true if we actually did something.  */
2312     return GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv)
2313         || ( GvSV(gv) && (
2314                            SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv))
2315                          )
2316            );
2317 }
2318
2319 /* If we do ever start using this later on in the file, we need to make
2320    sure we don’t accidentally use the wrong definition.  */
2321 #undef SvREADONLY_on
2322
2323 /* This function is called when the stash already holds the GV of the magic
2324  * variable we're looking for, but we need to check that it has the correct
2325  * kind of magic.  For example, if someone first uses $! and then %!, the
2326  * latter would end up here, and we add the Errno tie to the HASH slot of
2327  * the *! glob.
2328  */
2329 PERL_STATIC_INLINE void
2330 S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
2331 {
2332     PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV;
2333
2334     if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
2335         if (*name == '!')
2336             require_tie_mod_s(gv, '!', "Errno", 1);
2337         else if (*name == '-' || *name == '+')
2338             require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture", 0);
2339     } else if (sv_type == SVt_PV) {
2340         if (*name == '*' || *name == '#') {
2341             /* diag_listed_as: $* is no longer supported as of Perl 5.30 */
2342             Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name);
2343         }
2344     }
2345     if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
2346       switch (*name) {
2347 #ifdef PERL_SAWAMPERSAND
2348       case '`':
2349           PL_sawampersand |= SAWAMPERSAND_LEFT;
2350           (void)GvSVn(gv);
2351           break;
2352       case '&':
2353           PL_sawampersand |= SAWAMPERSAND_MIDDLE;
2354           (void)GvSVn(gv);
2355           break;
2356       case '\'':
2357           PL_sawampersand |= SAWAMPERSAND_RIGHT;
2358           (void)GvSVn(gv);
2359           break;
2360 #endif
2361       }
2362     }
2363 }
2364
2365 GV *
2366 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
2367                        const svtype sv_type)
2368 {
2369     const char *name = nambeg;
2370     GV *gv = NULL;
2371     GV**gvp;
2372     STRLEN len;
2373     HV *stash = NULL;
2374     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
2375     const I32 no_expand = flags & GV_NOEXPAND;
2376     const I32 add = flags & ~GV_NOADD_MASK;
2377     const U32 is_utf8 = flags & SVf_UTF8;
2378     bool addmg = cBOOL(flags & GV_ADDMG);
2379     const char *const name_end = nambeg + full_len;
2380     U32 faking_it;
2381
2382     PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
2383
2384      /* If we have GV_NOTQUAL, the caller promised that
2385       * there is no stash, so we can skip the check.
2386       * Similarly if full_len is 0, since then we're
2387       * dealing with something like *{""} or ""->foo()
2388       */
2389     if ((flags & GV_NOTQUAL) || !full_len) {
2390         len = full_len;
2391     }
2392     else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) {
2393         if (name == name_end) return gv;
2394     }
2395     else {
2396         return NULL;
2397     }
2398
2399     if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) {
2400         return NULL;
2401     }
2402     
2403     /* By this point we should have a stash and a name */
2404     gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add);
2405     if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
2406         if (addmg) gv = (GV *)newSV(0);
2407         else return NULL;
2408     }
2409     else gv = *gvp, addmg = 0;
2410     /* From this point on, addmg means gv has not been inserted in the
2411        symtab yet. */
2412
2413     if (SvTYPE(gv) == SVt_PVGV) {
2414         /* The GV already exists, so return it, but check if we need to do
2415          * anything else with it before that.
2416          */
2417         if (add) {
2418             /* This is the heuristic that handles if a variable triggers the
2419              * 'used only once' warning.  If there's already a GV in the stash
2420              * with this name, then we assume that the variable has been used
2421              * before and turn its MULTI flag on.
2422              * It's a heuristic because it can easily be "tricked", like with
2423              * BEGIN { $a = 1; $::{foo} = *a }; () = $foo
2424              * not warning about $main::foo being used just once
2425              */
2426             GvMULTI_on(gv);
2427             gv_init_svtype(gv, sv_type);
2428             /* You reach this path once the typeglob has already been created,
2429                either by the same or a different sigil.  If this path didn't
2430                exist, then (say) referencing $! first, and %! second would
2431                mean that %! was not handled correctly.  */
2432             if (len == 1 && stash == PL_defstash) {
2433                 maybe_multimagic_gv(gv, name, sv_type);
2434             }
2435             else if (sv_type == SVt_PVAV
2436                   && memEQs(name, len, "ISA")
2437                   && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
2438                 gv_magicalize_isa(gv);
2439         }
2440         return gv;
2441     } else if (no_init) {
2442         assert(!addmg);
2443         return gv;
2444     }
2445     /* If GV_NOEXPAND is true and what we got off the stash is a ref,
2446      * don't expand it to a glob. This is an optimization so that things
2447      * copying constants over, like Exporter, don't have to be rewritten
2448      * to take into account that you can store more than just globs in
2449      * stashes.
2450      */
2451     else if (no_expand && SvROK(gv)) {
2452         assert(!addmg);
2453         return gv;
2454     }
2455
2456     /* Adding a new symbol.
2457        Unless of course there was already something non-GV here, in which case
2458        we want to behave as if there was always a GV here, containing some sort
2459        of subroutine.
2460        Otherwise we run the risk of creating things like GvIO, which can cause
2461        subtle bugs. eg the one that tripped up SQL::Translator  */
2462
2463     faking_it = SvOK(gv);
2464
2465     if (add & GV_ADDWARN)
2466         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2467                 "Had to create %" UTF8f " unexpectedly",
2468                  UTF8fARG(is_utf8, name_end-nambeg, nambeg));
2469     gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
2470
2471     if (   full_len != 0
2472         && isIDFIRST_lazy_if_safe(name, name + full_len, is_utf8)
2473         && !ckWARN(WARN_ONCE) )
2474     {
2475         GvMULTI_on(gv) ;
2476     }
2477
2478     /* set up magic where warranted */
2479     if ( gv_magicalize(gv, stash, name, len, sv_type) ) {
2480         /* See 23496c6 */
2481         if (addmg) {
2482                 /* gv_magicalize magicalised this gv, so we want it
2483                  * stored in the symtab.
2484                  * Effectively the caller is asking, ‘Does this gv exist?’ 
2485                  * And we respond, ‘Er, *now* it does!’
2486                  */
2487                 (void)hv_store(stash,name,len,(SV *)gv,0);
2488         }
2489     }
2490     else if (addmg) {
2491                 /* The temporary GV created above */
2492                 SvREFCNT_dec_NN(gv);
2493                 gv = NULL;
2494     }
2495     
2496     if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
2497     return gv;
2498 }
2499
2500 void
2501 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2502 {
2503     const char *name;
2504     const HV * const hv = GvSTASH(gv);
2505
2506     PERL_ARGS_ASSERT_GV_FULLNAME4;
2507
2508     sv_setpv(sv, prefix ? prefix : "");
2509
2510     if (hv && (name = HvNAME(hv))) {
2511       const STRLEN len = HvNAMELEN(hv);
2512       if (keepmain || ! memBEGINs(name, len, "main")) {
2513         sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
2514         sv_catpvs(sv,"::");
2515       }
2516     }
2517     else sv_catpvs(sv,"__ANON__::");
2518     sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2519 }
2520
2521 void
2522 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2523 {
2524     const GV * const egv = GvEGVx(gv);
2525
2526     PERL_ARGS_ASSERT_GV_EFULLNAME4;
2527
2528     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2529 }
2530
2531
2532 /* recursively scan a stash and any nested stashes looking for entries
2533  * that need the "only used once" warning raised
2534  */
2535
2536 void
2537 Perl_gv_check(pTHX_ HV *stash)
2538 {
2539     I32 i;
2540
2541     PERL_ARGS_ASSERT_GV_CHECK;
2542
2543     if (!SvOOK(stash))
2544         return;
2545
2546     assert(HvARRAY(stash));
2547
2548     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2549         const HE *entry;
2550         /* mark stash is being scanned, to avoid recursing */
2551         HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH;
2552         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2553             GV *gv;
2554             HV *hv;
2555             STRLEN keylen = HeKLEN(entry);
2556             const char * const key = HeKEY(entry);
2557
2558             if (keylen >= 2 && key[keylen-2] == ':'  && key[keylen-1] == ':' &&
2559                 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2560             {
2561                 if (hv != PL_defstash && hv != stash
2562                     && !(SvOOK(hv)
2563                         && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH))
2564                 )
2565                      gv_check(hv);              /* nested package */
2566             }
2567             else if (   HeKLEN(entry) != 0
2568                      && *HeKEY(entry) != '_'
2569                      && isIDFIRST_lazy_if_safe(HeKEY(entry),
2570                                                HeKEY(entry) + HeKLEN(entry),
2571                                                HeUTF8(entry)) )
2572             {
2573                 const char *file;
2574                 gv = MUTABLE_GV(HeVAL(entry));
2575                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2576                     continue;
2577                 file = GvFILE(gv);
2578                 CopLINE_set(PL_curcop, GvLINE(gv));
2579 #ifdef USE_ITHREADS
2580                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
2581 #else
2582                 CopFILEGV(PL_curcop)
2583                     = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2584 #endif
2585                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2586                         "Name \"%" HEKf "::%" HEKf
2587                         "\" used only once: possible typo",
2588                             HEKfARG(HvNAME_HEK(stash)),
2589                             HEKfARG(GvNAME_HEK(gv)));
2590             }
2591         }
2592         HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH;
2593     }
2594 }
2595
2596 GV *
2597 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2598 {
2599     PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2600     assert(!(flags & ~SVf_UTF8));
2601
2602     return gv_fetchpv(Perl_form(aTHX_ "%" UTF8f "::_GEN_%ld",
2603                                 UTF8fARG(flags, strlen(pack), pack),
2604                                 (long)PL_gensym++),
2605                       GV_ADD, SVt_PVGV);
2606 }
2607
2608 /* hopefully this is only called on local symbol table entries */
2609
2610 GP*
2611 Perl_gp_ref(pTHX_ GP *gp)
2612 {
2613     if (!gp)
2614         return NULL;
2615     gp->gp_refcnt++;
2616     if (gp->gp_cv) {
2617         if (gp->gp_cvgen) {
2618             /* If the GP they asked for a reference to contains
2619                a method cache entry, clear it first, so that we
2620                don't infect them with our cached entry */
2621             SvREFCNT_dec_NN(gp->gp_cv);
2622             gp->gp_cv = NULL;
2623             gp->gp_cvgen = 0;
2624         }
2625     }
2626     return gp;
2627 }
2628
2629 void
2630 Perl_gp_free(pTHX_ GV *gv)
2631 {
2632     GP* gp;
2633     int attempts = 100;
2634
2635     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2636         return;
2637     if (gp->gp_refcnt == 0) {
2638         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2639                          "Attempt to free unreferenced glob pointers"
2640                          pTHX__FORMAT pTHX__VALUE);
2641         return;
2642     }
2643     if (gp->gp_refcnt > 1) {
2644        borrowed:
2645         if (gp->gp_egv == gv)
2646             gp->gp_egv = 0;
2647         gp->gp_refcnt--;
2648         GvGP_set(gv, NULL);
2649         return;
2650     }
2651
2652     while (1) {
2653       /* Copy and null out all the glob slots, so destructors do not see
2654          freed SVs. */
2655       HEK * const file_hek = gp->gp_file_hek;
2656       SV  * const sv       = gp->gp_sv;
2657       AV  * const av       = gp->gp_av;
2658       HV  * const hv       = gp->gp_hv;
2659       IO  * const io       = gp->gp_io;
2660       CV  * const cv       = gp->gp_cv;
2661       CV  * const form     = gp->gp_form;
2662
2663       gp->gp_file_hek = NULL;
2664       gp->gp_sv       = NULL;
2665       gp->gp_av       = NULL;
2666       gp->gp_hv       = NULL;
2667       gp->gp_io       = NULL;
2668       gp->gp_cv       = NULL;
2669       gp->gp_form     = NULL;
2670
2671       if (file_hek)
2672         unshare_hek(file_hek);
2673
2674       SvREFCNT_dec(sv);
2675       SvREFCNT_dec(av);
2676       /* FIXME - another reference loop GV -> symtab -> GV ?
2677          Somehow gp->gp_hv can end up pointing at freed garbage.  */
2678       if (hv && SvTYPE(hv) == SVt_PVHV) {
2679         const HEK *hvname_hek = HvNAME_HEK(hv);
2680         if (PL_stashcache && hvname_hek) {
2681            DEBUG_o(Perl_deb(aTHX_
2682                           "gp_free clearing PL_stashcache for '%" HEKf "'\n",
2683                            HEKfARG(hvname_hek)));
2684            (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
2685         }
2686         SvREFCNT_dec(hv);
2687       }
2688       if (io && SvREFCNT(io) == 1 && IoIFP(io)
2689              && (IoTYPE(io) == IoTYPE_WRONLY ||
2690                  IoTYPE(io) == IoTYPE_RDWR   ||
2691                  IoTYPE(io) == IoTYPE_APPEND)
2692              && ckWARN_d(WARN_IO)
2693              && IoIFP(io) != PerlIO_stdin()
2694              && IoIFP(io) != PerlIO_stdout()
2695              && IoIFP(io) != PerlIO_stderr()
2696              && !(IoFLAGS(io) & IOf_FAKE_DIRP))
2697         io_close(io, gv, FALSE, TRUE);
2698       SvREFCNT_dec(io);
2699       SvREFCNT_dec(cv);
2700       SvREFCNT_dec(form);
2701
2702       /* Possibly reallocated by a destructor */
2703       gp = GvGP(gv);
2704
2705       if (!gp->gp_file_hek
2706        && !gp->gp_sv
2707        && !gp->gp_av
2708        && !gp->gp_hv
2709        && !gp->gp_io
2710        && !gp->gp_cv
2711        && !gp->gp_form) break;
2712
2713       if (--attempts == 0) {
2714         Perl_die(aTHX_
2715           "panic: gp_free failed to free glob pointer - "
2716           "something is repeatedly re-creating entries"
2717         );
2718       }
2719     }
2720
2721     /* Possibly incremented by a destructor doing glob assignment */
2722     if (gp->gp_refcnt > 1) goto borrowed;
2723     Safefree(gp);
2724     GvGP_set(gv, NULL);
2725 }
2726
2727 int
2728 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2729 {
2730     AMT * const amtp = (AMT*)mg->mg_ptr;
2731     PERL_UNUSED_ARG(sv);
2732
2733     PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2734
2735     if (amtp && AMT_AMAGIC(amtp)) {
2736         int i;
2737         for (i = 1; i < NofAMmeth; i++) {
2738             CV * const cv = amtp->table[i];
2739             if (cv) {
2740                 SvREFCNT_dec_NN(MUTABLE_SV(cv));
2741                 amtp->table[i] = NULL;
2742             }
2743         }
2744     }
2745  return 0;
2746 }
2747
2748 /* Updates and caches the CV's */
2749 /* Returns:
2750  * 1 on success and there is some overload
2751  * 0 if there is no overload
2752  * -1 if some error occurred and it couldn't croak
2753  */
2754
2755 int
2756 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2757 {
2758   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2759   AMT amt;
2760   const struct mro_meta* stash_meta = HvMROMETA(stash);
2761   U32 newgen;
2762
2763   PERL_ARGS_ASSERT_GV_AMUPDATE;
2764
2765   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2766   if (mg) {
2767       const AMT * const amtp = (AMT*)mg->mg_ptr;
2768       if (amtp->was_ok_sub == newgen) {
2769           return AMT_AMAGIC(amtp) ? 1 : 0;
2770       }
2771       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2772   }
2773
2774   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2775
2776   Zero(&amt,1,AMT);
2777   amt.was_ok_sub = newgen;
2778   amt.fallback = AMGfallNO;
2779   amt.flags = 0;
2780
2781   {
2782     int filled = 0;
2783     int i;
2784     bool deref_seen = 0;
2785
2786
2787     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2788
2789     /* Try to find via inheritance. */
2790     GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2791     SV * const sv = gv ? GvSV(gv) : NULL;
2792     CV* cv;
2793
2794     if (!gv)
2795     {
2796       if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
2797         goto no_table;
2798     }
2799 #ifdef PERL_DONT_CREATE_GVSV
2800     else if (!sv) {
2801         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
2802     }
2803 #endif
2804     else if (SvTRUE(sv))
2805         /* don't need to set overloading here because fallback => 1
2806          * is the default setting for classes without overloading */
2807         amt.fallback=AMGfallYES;
2808     else if (SvOK(sv)) {
2809         amt.fallback=AMGfallNEVER;
2810         filled = 1;
2811     }
2812     else {
2813         filled = 1;
2814     }
2815
2816     assert(SvOOK(stash));
2817     /* initially assume the worst */
2818     HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
2819
2820     for (i = 1; i < NofAMmeth; i++) {
2821         const char * const cooky = PL_AMG_names[i];
2822         /* Human-readable form, for debugging: */
2823         const char * const cp = AMG_id2name(i);
2824         const STRLEN l = PL_AMG_namelens[i];
2825
2826         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2827                      cp, HvNAME_get(stash)) );
2828         /* don't fill the cache while looking up!
2829            Creation of inheritance stubs in intermediate packages may
2830            conflict with the logic of runtime method substitution.
2831            Indeed, for inheritance A -> B -> C, if C overloads "+0",
2832            then we could have created stubs for "(+0" in A and C too.
2833            But if B overloads "bool", we may want to use it for
2834            numifying instead of C's "+0". */
2835         gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2836         cv = 0;
2837         if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) {
2838             const HEK * const gvhek = CvGvNAME_HEK(cv);
2839             const HEK * const stashek =
2840                 HvNAME_HEK(CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv)));
2841             if (memEQs(HEK_KEY(gvhek), HEK_LEN(gvhek), "nil")
2842              && stashek
2843              && memEQs(HEK_KEY(stashek), HEK_LEN(stashek), "overload")) {
2844                 /* This is a hack to support autoloading..., while
2845                    knowing *which* methods were declared as overloaded. */
2846                 /* GvSV contains the name of the method. */
2847                 GV *ngv = NULL;
2848                 SV *gvsv = GvSV(gv);
2849
2850                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%" SVf256\
2851                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
2852                              (void*)GvSV(gv), cp, HvNAME(stash)) );
2853                 if (!gvsv || !SvPOK(gvsv)
2854                     || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2855                 {
2856                     /* Can be an import stub (created by "can"). */
2857                     if (destructing) {
2858                         return -1;
2859                     }
2860                     else {
2861                         const SV * const name = (gvsv && SvPOK(gvsv))
2862                                                     ? gvsv
2863                                                     : newSVpvs_flags("???", SVs_TEMP);
2864                         /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
2865                         Perl_croak(aTHX_ "%s method \"%" SVf256
2866                                     "\" overloading \"%s\" "\
2867                                     "in package \"%" HEKf256 "\"",
2868                                    (GvCVGEN(gv) ? "Stub found while resolving"
2869                                     : "Can't resolve"),
2870                                    SVfARG(name), cp,
2871                                    HEKfARG(
2872                                         HvNAME_HEK(stash)
2873                                    ));
2874                     }
2875                 }
2876                 cv = GvCV(gv = ngv);
2877             }
2878             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2879                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2880                          GvNAME(CvGV(cv))) );
2881             filled = 1;
2882         } else if (gv) {                /* Autoloaded... */
2883             cv = MUTABLE_CV(gv);
2884             filled = 1;
2885         }
2886         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2887
2888         if (gv) {
2889             switch (i) {
2890             case to_sv_amg:
2891             case to_av_amg:
2892             case to_hv_amg:
2893             case to_gv_amg:
2894             case to_cv_amg:
2895             case nomethod_amg:
2896                 deref_seen = 1;
2897                 break;
2898             }
2899         }
2900     }
2901     if (!deref_seen)
2902         /* none of @{} etc overloaded; we can do $obj->[N] quicker.
2903          * NB - aux var invalid here, HvARRAY() could have been
2904          * reallocated since it was assigned to */
2905         HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF;
2906
2907     if (filled) {
2908       AMT_AMAGIC_on(&amt);
2909       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2910                                                 (char*)&amt, sizeof(AMT));
2911       return TRUE;
2912     }
2913   }
2914   /* Here we have no table: */
2915  no_table:
2916   AMT_AMAGIC_off(&amt);
2917   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2918                                                 (char*)&amt, sizeof(AMTS));
2919   return 0;
2920 }
2921
2922
2923 CV*
2924 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2925 {
2926     MAGIC *mg;
2927     AMT *amtp;
2928     U32 newgen;
2929     struct mro_meta* stash_meta;
2930
2931     if (!stash || !HvNAME_get(stash))
2932         return NULL;
2933
2934     stash_meta = HvMROMETA(stash);
2935     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2936
2937     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2938     if (!mg) {
2939       do_update:
2940         if (Gv_AMupdate(stash, 0) == -1)
2941             return NULL;
2942         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2943     }
2944     assert(mg);
2945     amtp = (AMT*)mg->mg_ptr;
2946     if ( amtp->was_ok_sub != newgen )
2947         goto do_update;
2948     if (AMT_AMAGIC(amtp)) {
2949         CV * const ret = amtp->table[id];
2950         if (ret && isGV(ret)) {         /* Autoloading stab */
2951             /* Passing it through may have resulted in a warning
2952                "Inherited AUTOLOAD for a non-method deprecated", since
2953                our caller is going through a function call, not a method call.
2954                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2955             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2956
2957             if (gv && GvCV(gv))
2958                 return GvCV(gv);
2959         }
2960         return ret;
2961     }
2962
2963     return NULL;
2964 }
2965
2966
2967 /* Implement tryAMAGICun_MG macro.
2968    Do get magic, then see if the stack arg is overloaded and if so call it.
2969    Flags:
2970         AMGf_numeric apply sv_2num to the stack arg.
2971 */
2972
2973 bool
2974 Perl_try_amagic_un(pTHX_ int method, int flags) {
2975     dSP;
2976     SV* tmpsv;
2977     SV* const arg = TOPs;
2978
2979     SvGETMAGIC(arg);
2980
2981     if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2982                                               AMGf_noright | AMGf_unary
2983                                             | (flags & AMGf_numarg))))
2984     {
2985         /* where the op is of the form:
2986          *    $lex = $x op $y (where the assign is optimised away)
2987          * then assign the returned value to targ and return that;
2988          * otherwise return the value directly
2989          */
2990         if (   (PL_opargs[PL_op->op_type] & OA_TARGLEX)
2991             && (PL_op->op_private & OPpTARGET_MY))
2992         {
2993             dTARGET;
2994             sv_setsv(TARG, tmpsv);
2995             SETTARG;
2996         }
2997         else
2998             SETs(tmpsv);
2999
3000         PUTBACK;
3001         return TRUE;
3002     }
3003
3004     if ((flags & AMGf_numeric) && SvROK(arg))
3005         *sp = sv_2num(arg);
3006     return FALSE;
3007 }
3008
3009
3010 /* Implement tryAMAGICbin_MG macro.
3011    Do get magic, then see if the two stack args are overloaded and if so
3012    call it.
3013    Flags:
3014         AMGf_assign  op may be called as mutator (eg +=)
3015         AMGf_numeric apply sv_2num to the stack arg.
3016 */
3017
3018 bool
3019 Perl_try_amagic_bin(pTHX_ int method, int flags) {
3020     dSP;
3021     SV* const left = TOPm1s;
3022     SV* const right = TOPs;
3023
3024     SvGETMAGIC(left);
3025     if (left != right)
3026         SvGETMAGIC(right);
3027
3028     if (SvAMAGIC(left) || SvAMAGIC(right)) {
3029         SV * tmpsv;
3030         /* STACKED implies mutator variant, e.g. $x += 1 */
3031         bool mutator = (flags & AMGf_assign) && (PL_op->op_flags & OPf_STACKED);
3032
3033         tmpsv = amagic_call(left, right, method,
3034                     (mutator ? AMGf_assign: 0)
3035                   | (flags & AMGf_numarg));
3036         if (tmpsv) {
3037             (void)POPs;
3038             /* where the op is one of the two forms:
3039              *    $x op= $y
3040              *    $lex = $x op $y (where the assign is optimised away)
3041              * then assign the returned value to targ and return that;
3042              * otherwise return the value directly
3043              */
3044             if (   mutator
3045                 || (   (PL_opargs[PL_op->op_type] & OA_TARGLEX)
3046                     && (PL_op->op_private & OPpTARGET_MY)))
3047             {
3048                 dTARG;
3049                 TARG = mutator ? *SP : PAD_SV(PL_op->op_targ);
3050                 sv_setsv(TARG, tmpsv);
3051                 SETTARG;
3052             }
3053             else
3054                 SETs(tmpsv);
3055
3056             PUTBACK;
3057             return TRUE;
3058         }
3059     }
3060
3061     if(left==right && SvGMAGICAL(left)) {
3062         SV * const left = sv_newmortal();
3063         *(sp-1) = left;
3064         /* Print the uninitialized warning now, so it includes the vari-
3065            able name. */
3066         if (!SvOK(right)) {
3067             if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
3068             sv_setsv_flags(left, &PL_sv_no, 0);
3069         }
3070         else sv_setsv_flags(left, right, 0);
3071         SvGETMAGIC(right);
3072     }
3073     if (flags & AMGf_numeric) {
3074         if (SvROK(TOPm1s))
3075             *(sp-1) = sv_2num(TOPm1s);
3076         if (SvROK(right))
3077             *sp     = sv_2num(right);
3078     }
3079     return FALSE;
3080 }
3081
3082 SV *
3083 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
3084     SV *tmpsv = NULL;
3085     HV *stash;
3086
3087     PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
3088
3089     if (!SvAMAGIC(ref))
3090         return ref;
3091     /* return quickly if none of the deref ops are overloaded */
3092     stash = SvSTASH(SvRV(ref));
3093     assert(SvOOK(stash));
3094     if (HvAUX(stash)->xhv_aux_flags & HvAUXf_NO_DEREF)
3095         return ref;
3096
3097     while ((tmpsv = amagic_call(ref, &PL_sv_undef, method,
3098                                 AMGf_noright | AMGf_unary))) { 
3099         if (!SvROK(tmpsv))
3100             Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
3101         if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
3102             /* Bail out if it returns us the same reference.  */
3103             return tmpsv;
3104         }
3105         ref = tmpsv;
3106         if (!SvAMAGIC(ref))
3107             break;
3108     }
3109     return tmpsv ? tmpsv : ref;
3110 }
3111
3112 bool
3113 Perl_amagic_is_enabled(pTHX_ int method)
3114 {
3115       SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
3116
3117       assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
3118
3119       if ( !lex_mask || !SvOK(lex_mask) )
3120           /* overloading lexically disabled */
3121           return FALSE;
3122       else if ( lex_mask && SvPOK(lex_mask) ) {
3123           /* we have an entry in the hints hash, check if method has been
3124            * masked by overloading.pm */
3125           STRLEN len;
3126           const int offset = method / 8;
3127           const int bit    = method % 8;
3128           char *pv = SvPV(lex_mask, len);
3129
3130           /* Bit set, so this overloading operator is disabled */
3131           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
3132               return FALSE;
3133       }
3134       return TRUE;
3135 }
3136
3137 SV*
3138 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
3139 {
3140   dVAR;
3141   MAGIC *mg;
3142   CV *cv=NULL;
3143   CV **cvp=NULL, **ocvp=NULL;
3144   AMT *amtp=NULL, *oamtp=NULL;
3145   int off = 0, off1, lr = 0, notfound = 0;
3146   int postpr = 0, force_cpy = 0;
3147   int assign = AMGf_assign & flags;
3148   const int assignshift = assign ? 1 : 0;
3149   int use_default_op = 0;
3150   int force_scalar = 0;
3151 #ifdef DEBUGGING
3152   int fl=0;
3153 #endif
3154   HV* stash=NULL;
3155
3156   PERL_ARGS_ASSERT_AMAGIC_CALL;
3157
3158   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
3159       if (!amagic_is_enabled(method)) return NULL;
3160   }
3161
3162   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
3163       && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
3164       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3165       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3166                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
3167                         : NULL))
3168       && ((cv = cvp[off=method+assignshift])
3169           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
3170                                                           * usual method */
3171                   (
3172 #ifdef DEBUGGING
3173                    fl = 1,
3174 #endif
3175                    cv = cvp[off=method])))) {
3176     lr = -1;                    /* Call method for left argument */
3177   } else {
3178     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
3179       int logic;
3180
3181       /* look for substituted methods */
3182       /* In all the covered cases we should be called with assign==0. */
3183          switch (method) {
3184          case inc_amg:
3185            force_cpy = 1;
3186            if ((cv = cvp[off=add_ass_amg])
3187                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3188              right = &PL_sv_yes; lr = -1; assign = 1;
3189            }
3190            break;
3191          case dec_amg:
3192            force_cpy = 1;
3193            if ((cv = cvp[off = subtr_ass_amg])
3194                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3195              right = &PL_sv_yes; lr = -1; assign = 1;
3196            }
3197            break;
3198          case bool__amg:
3199            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
3200            break;
3201          case numer_amg:
3202            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
3203            break;
3204          case string_amg:
3205            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
3206            break;
3207          case not_amg:
3208            (void)((cv = cvp[off=bool__amg])
3209                   || (cv = cvp[off=numer_amg])
3210                   || (cv = cvp[off=string_amg]));
3211            if (cv)
3212                postpr = 1;
3213            break;
3214          case copy_amg:
3215            {
3216              /*
3217                   * SV* ref causes confusion with the interpreter variable of
3218                   * the same name
3219                   */
3220              SV* const tmpRef=SvRV(left);
3221              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
3222                 /*
3223                  * Just to be extra cautious.  Maybe in some
3224                  * additional cases sv_setsv is safe, too.
3225                  */
3226                 SV* const newref = newSVsv(tmpRef);
3227                 SvOBJECT_on(newref);
3228                 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
3229                    delegate to the stash. */
3230                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
3231                 return newref;
3232              }
3233            }
3234            break;
3235          case abs_amg:
3236            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
3237                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
3238              SV* const nullsv=&PL_sv_zero;
3239              if (off1==lt_amg) {
3240                SV* const lessp = amagic_call(left,nullsv,
3241                                        lt_amg,AMGf_noright);
3242                logic = SvTRUE_NN(lessp);
3243              } else {
3244                SV* const lessp = amagic_call(left,nullsv,
3245                                        ncmp_amg,AMGf_noright);
3246                logic = (SvNV(lessp) < 0);
3247              }
3248              if (logic) {
3249                if (off==subtr_amg) {
3250                  right = left;
3251                  left = nullsv;
3252                  lr = 1;
3253                }
3254              } else {
3255                return left;
3256              }
3257            }
3258            break;
3259          case neg_amg:
3260            if ((cv = cvp[off=subtr_amg])) {
3261              right = left;
3262              left = &PL_sv_zero;
3263              lr = 1;
3264            }
3265            break;
3266          case int_amg:
3267          case iter_amg:                 /* XXXX Eventually should do to_gv. */
3268          case ftest_amg:                /* XXXX Eventually should do to_gv. */
3269          case regexp_amg:
3270              /* FAIL safe */
3271              return NULL;       /* Delegate operation to standard mechanisms. */
3272
3273          case to_sv_amg:
3274          case to_av_amg:
3275          case to_hv_amg:
3276          case to_gv_amg:
3277          case to_cv_amg:
3278              /* FAIL safe */
3279              return left;       /* Delegate operation to standard mechanisms. */
3280
3281          default:
3282            goto not_found;
3283          }
3284          if (!cv) goto not_found;
3285     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
3286                && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
3287                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3288                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3289                           ? (amtp = (AMT*)mg->mg_ptr)->table
3290                           : NULL))
3291                && (cv = cvp[off=method])) { /* Method for right
3292                                              * argument found */
3293       lr=1;
3294     } else if (((cvp && amtp->fallback > AMGfallNEVER)
3295                 || (ocvp && oamtp->fallback > AMGfallNEVER))
3296                && !(flags & AMGf_unary)) {
3297                                 /* We look for substitution for
3298                                  * comparison operations and
3299                                  * concatenation */
3300       if (method==concat_amg || method==concat_ass_amg
3301           || method==repeat_amg || method==repeat_ass_amg) {
3302         return NULL;            /* Delegate operation to string conversion */
3303       }
3304       off = -1;
3305       switch (method) {
3306          case lt_amg:
3307          case le_amg:
3308          case gt_amg:
3309          case ge_amg:
3310          case eq_amg:
3311          case ne_amg:
3312              off = ncmp_amg;
3313              break;
3314          case slt_amg:
3315          case sle_amg:
3316          case sgt_amg:
3317          case sge_amg:
3318          case seq_amg:
3319          case sne_amg:
3320              off = scmp_amg;
3321              break;
3322          }
3323       if (off != -1) {
3324           if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
3325               cv = ocvp[off];
3326               lr = -1;
3327           }
3328           if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
3329               cv = cvp[off];
3330               lr = 1;
3331           }
3332       }
3333       if (cv)
3334           postpr = 1;
3335       else
3336           goto not_found;
3337     } else {
3338     not_found:                  /* No method found, either report or croak */
3339       switch (method) {
3340          case to_sv_amg:
3341          case to_av_amg:
3342          case to_hv_amg:
3343          case to_gv_amg:
3344          case to_cv_amg:
3345              /* FAIL safe */
3346              return left;       /* Delegate operation to standard mechanisms. */
3347       }
3348       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
3349         notfound = 1; lr = -1;
3350       } else if (cvp && (cv=cvp[nomethod_amg])) {
3351         notfound = 1; lr = 1;
3352       } else if ((use_default_op =
3353                   (!ocvp || oamtp->fallback >= AMGfallYES)
3354                   && (!cvp || amtp->fallback >= AMGfallYES))
3355                  && !DEBUG_o_TEST) {
3356         /* Skip generating the "no method found" message.  */
3357         return NULL;
3358       } else {
3359         SV *msg;
3360         if (off==-1) off=method;
3361         msg = sv_2mortal(Perl_newSVpvf(aTHX_
3362                       "Operation \"%s\": no method found,%sargument %s%" SVf "%s%" SVf,
3363                       AMG_id2name(method + assignshift),
3364                       (flags & AMGf_unary ? " " : "\n\tleft "),
3365                       SvAMAGIC(left)?
3366                         "in overloaded package ":
3367                         "has no overloaded magic",
3368                       SvAMAGIC(left)?
3369                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
3370                         SVfARG(&PL_sv_no),
3371                       SvAMAGIC(right)?
3372                         ",\n\tright argument in overloaded package ":
3373                         (flags & AMGf_unary
3374                          ? ""
3375                          : ",\n\tright argument has no overloaded magic"),
3376                       SvAMAGIC(right)?
3377                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
3378                         SVfARG(&PL_sv_no)));
3379         if (use_default_op) {
3380           DEBUG_o( Perl_deb(aTHX_ "%" SVf, SVfARG(msg)) );
3381         } else {
3382           Perl_croak(aTHX_ "%" SVf, SVfARG(msg));
3383         }
3384         return NULL;
3385       }
3386       force_cpy = force_cpy || assign;
3387     }
3388   }
3389
3390   switch (method) {
3391     /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
3392      * operation. we need this to return a value, so that it can be assigned
3393      * later on, in the postpr block (case inc_amg/dec_amg), even if the
3394      * increment or decrement was itself called in void context */
3395     case inc_amg:
3396       if (off == add_amg)
3397         force_scalar = 1;
3398       break;
3399     case dec_amg:
3400       if (off == subtr_amg)
3401         force_scalar = 1;
3402       break;
3403     /* in these cases, we're calling an assignment variant of an operator
3404      * (+= rather than +, for instance). regardless of whether it's a
3405      * fallback or not, it always has to return a value, which will be
3406      * assigned to the proper variable later */
3407     case add_amg:
3408     case subtr_amg:
3409     case mult_amg:
3410     case div_amg:
3411     case modulo_amg:
3412     case pow_amg:
3413     case lshift_amg:
3414     case rshift_amg:
3415     case repeat_amg:
3416     case concat_amg:
3417     case band_amg:
3418     case bor_amg:
3419     case bxor_amg:
3420     case sband_amg:
3421     case sbor_amg:
3422     case sbxor_amg:
3423       if (assign)
3424         force_scalar = 1;
3425       break;
3426     /* the copy constructor always needs to return a value */
3427     case copy_amg:
3428       force_scalar = 1;
3429       break;
3430     /* because of the way these are implemented (they don't perform the
3431      * dereferencing themselves, they return a reference that perl then
3432      * dereferences later), they always have to be in scalar context */
3433     case to_sv_amg:
3434     case to_av_amg:
3435     case to_hv_amg:
3436     case to_gv_amg:
3437     case to_cv_amg:
3438       force_scalar = 1;
3439       break;
3440     /* these don't have an op of their own; they're triggered by their parent
3441      * op, so the context there isn't meaningful ('$a and foo()' in void
3442      * context still needs to pass scalar context on to $a's bool overload) */
3443     case bool__amg:
3444     case numer_amg:
3445     case string_amg:
3446       force_scalar = 1;
3447       break;
3448   }
3449
3450 #ifdef DEBUGGING
3451   if (!notfound) {
3452     DEBUG_o(Perl_deb(aTHX_
3453                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %" SVf "%s\n",
3454                      AMG_id2name(off),
3455                      method+assignshift==off? "" :
3456                      " (initially \"",
3457                      method+assignshift==off? "" :
3458                      AMG_id2name(method+assignshift),
3459                      method+assignshift==off? "" : "\")",
3460                      flags & AMGf_unary? "" :
3461                      lr==1 ? " for right argument": " for left argument",
3462                      flags & AMGf_unary? " for argument" : "",
3463                      stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
3464                      fl? ",\n\tassignment variant used": "") );
3465   }
3466 #endif
3467     /* Since we use shallow copy during assignment, we need
3468      * to dublicate the contents, probably calling user-supplied
3469      * version of copy operator
3470      */
3471     /* We need to copy in following cases:
3472      * a) Assignment form was called.
3473      *          assignshift==1,  assign==T, method + 1 == off
3474      * b) Increment or decrement, called directly.
3475      *          assignshift==0,  assign==0, method + 0 == off
3476      * c) Increment or decrement, translated to assignment add/subtr.
3477      *          assignshift==0,  assign==T,
3478      *          force_cpy == T
3479      * d) Increment or decrement, translated to nomethod.
3480      *          assignshift==0,  assign==0,
3481      *          force_cpy == T
3482      * e) Assignment form translated to nomethod.
3483      *          assignshift==1,  assign==T, method + 1 != off
3484      *          force_cpy == T
3485      */
3486     /*  off is method, method+assignshift, or a result of opcode substitution.
3487      *  In the latter case assignshift==0, so only notfound case is important.
3488      */
3489   if ( (lr == -1) && ( ( (method + assignshift == off)
3490         && (assign || (method == inc_amg) || (method == dec_amg)))
3491       || force_cpy) )
3492   {
3493       /* newSVsv does not behave as advertised, so we copy missing
3494        * information by hand */
3495       SV *tmpRef = SvRV(left);
3496       SV *rv_copy;
3497       if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
3498           SvRV_set(left, rv_copy);
3499           SvSETMAGIC(left);
3500           SvREFCNT_dec_NN(tmpRef);  
3501       }
3502   }
3503
3504   {
3505     dSP;
3506     BINOP myop;
3507     SV* res;
3508     const bool oldcatch = CATCH_GET;
3509     I32 oldmark, nret;
3510                 /* for multiconcat, we may call overload several times,
3511                  * with the context of individual concats being scalar,
3512                  * regardless of the overall context of the multiconcat op
3513                  */
3514     U8 gimme = (force_scalar || PL_op->op_type == OP_MULTICONCAT)
3515                     ? G_SCALAR : GIMME_V;
3516
3517     CATCH_SET(TRUE);
3518     Zero(&myop, 1, BINOP);
3519     myop.op_last = (OP *) &myop;
3520     myop.op_next = NULL;
3521     myop.op_flags = OPf_STACKED;
3522
3523     switch (gimme) {
3524         case G_VOID:
3525             myop.op_flags |= OPf_WANT_VOID;
3526             break;
3527         case G_ARRAY:
3528             if (flags & AMGf_want_list) {
3529                 myop.op_flags |= OPf_WANT_LIST;
3530                 break;
3531             }
3532             /* FALLTHROUGH */
3533         default:
3534             myop.op_flags |= OPf_WANT_SCALAR;
3535             break;
3536     }
3537
3538     PUSHSTACKi(PERLSI_OVERLOAD);
3539     ENTER;
3540     SAVEOP();
3541     PL_op = (OP *) &myop;
3542     if (PERLDB_SUB && PL_curstash != PL_debstash)
3543         PL_op->op_private |= OPpENTERSUB_DB;
3544     Perl_pp_pushmark(aTHX);
3545
3546     EXTEND(SP, notfound + 5);
3547     PUSHs(lr>0? right: left);
3548     PUSHs(lr>0? left: right);
3549     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
3550     if (notfound) {
3551       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3552                            AMG_id2namelen(method + assignshift), SVs_TEMP));
3553     }
3554     else if (flags & AMGf_numarg)
3555       PUSHs(&PL_sv_undef);
3556     if (flags & AMGf_numarg)
3557       PUSHs(&PL_sv_yes);
3558     PUSHs(MUTABLE_SV(cv));
3559     PUTBACK;
3560     oldmark = TOPMARK;
3561
3562     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3563       CALLRUNOPS(aTHX);
3564     LEAVE;
3565     SPAGAIN;
3566     nret = SP - (PL_stack_base + oldmark);
3567
3568     switch (gimme) {
3569         case G_VOID:
3570             /* returning NULL has another meaning, and we check the context
3571              * at the call site too, so this can be differentiated from the
3572              * scalar case */
3573             res = &PL_sv_undef;
3574             SP = PL_stack_base + oldmark;
3575             break;
3576         case G_ARRAY:
3577             if (flags & AMGf_want_list) {
3578                 res = sv_2mortal((SV *)newAV());
3579                 av_extend((AV *)res, nret);
3580                 while (nret--)
3581                     av_store((AV *)res, nret, POPs);
3582                 break;
3583             }
3584             /* FALLTHROUGH */
3585         default:
3586             res = POPs;
3587             break;
3588     }
3589
3590     PUTBACK;
3591     POPSTACK;
3592     CATCH_SET(oldcatch);
3593
3594     if (postpr) {
3595       int ans;
3596       switch (method) {
3597       case le_amg:
3598       case sle_amg:
3599         ans=SvIV(res)<=0; break;
3600       case lt_amg:
3601       case slt_amg:
3602         ans=SvIV(res)<0; break;
3603       case ge_amg:
3604       case sge_amg:
3605         ans=SvIV(res)>=0; break;
3606       case gt_amg:
3607       case sgt_amg:
3608         ans=SvIV(res)>0; break;
3609       case eq_amg:
3610       case seq_amg:
3611         ans=SvIV(res)==0; break;
3612       case ne_amg:
3613       case sne_amg:
3614         ans=SvIV(res)!=0; break;
3615       case inc_amg:
3616       case dec_amg:
3617         SvSetSV(left,res); return left;
3618       case not_amg:
3619         ans=!SvTRUE_NN(res); break;
3620       default:
3621         ans=0; break;
3622       }
3623       return boolSV(ans);
3624     } else if (method==copy_amg) {
3625       if (!SvROK(res)) {
3626         Perl_croak(aTHX_ "Copy method did not return a reference");
3627       }
3628       return SvREFCNT_inc(SvRV(res));
3629     } else {
3630       return res;
3631     }
3632   }
3633 }
3634
3635 void
3636 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3637 {
3638     dVAR;
3639     U32 hash;
3640
3641     PERL_ARGS_ASSERT_GV_NAME_SET;
3642
3643     if (len > I32_MAX)
3644         Perl_croak(aTHX_ "panic: gv name too long (%" UVuf ")", (UV) len);
3645
3646     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3647         unshare_hek(GvNAME_HEK(gv));
3648     }
3649
3650     PERL_HASH(hash, name, len);
3651     GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3652 }
3653
3654 /*
3655 =for apidoc gv_try_downgrade
3656
3657 If the typeglob C<gv> can be expressed more succinctly, by having
3658 something other than a real GV in its place in the stash, replace it
3659 with the optimised form.  Basic requirements for this are that C<gv>
3660 is a real typeglob, is sufficiently ordinary, and is only referenced
3661 from its package.  This function is meant to be used when a GV has been
3662 looked up in part to see what was there, causing upgrading, but based
3663 on what was found it turns out that the real GV isn't required after all.
3664
3665 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3666
3667 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3668 sub, the typeglob is replaced with a scalar-reference placeholder that
3669 more compactly represents the same thing.
3670
3671 =cut
3672 */
3673
3674 void
3675 Perl_gv_try_downgrade(pTHX_ GV *gv)
3676 {
3677     HV *stash;
3678     CV *cv;
3679     HEK *namehek;
3680     SV **gvp;
3681     PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3682
3683     /* XXX Why and where does this leave dangling pointers during global
3684        destruction? */
3685     if (PL_phase == PERL_PHASE_DESTRUCT) return;
3686
3687     if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3688             !SvOBJECT(gv) && !SvREADONLY(gv) &&
3689             isGV_with_GP(gv) && GvGP(gv) &&
3690             !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3691             !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3692             GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3693         return;
3694     if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv)
3695         return;
3696     if (SvMAGICAL(gv)) {
3697         MAGIC *mg;
3698         /* only backref magic is allowed */
3699         if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3700             return;
3701         for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3702             if (mg->mg_type != PERL_MAGIC_backref)
3703                 return;
3704         }
3705     }
3706     cv = GvCV(gv);
3707     if (!cv) {
3708         HEK *gvnhek = GvNAME_HEK(gv);
3709         (void)hv_deletehek(stash, gvnhek, G_DISCARD);
3710     } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 &&
3711             !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3712             CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv &&
3713             CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3714             !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3715             (namehek = GvNAME_HEK(gv)) &&
3716             (gvp = hv_fetchhek(stash, namehek, 0)) &&
3717             *gvp == (SV*)gv) {
3718         SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3719         const bool imported = !!GvIMPORTED_CV(gv);
3720         SvREFCNT(gv) = 0;
3721         sv_clear((SV*)gv);
3722         SvREFCNT(gv) = 1;
3723         SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
3724
3725         /* See also: 'SET_SVANY_FOR_BODYLESS_IV' in sv.c */
3726         SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3727                                 STRUCT_OFFSET(XPVIV, xiv_iv));
3728         SvRV_set(gv, value);
3729     }
3730 }
3731
3732 GV *
3733 Perl_gv_override(pTHX_ const char * const name, const STRLEN len)
3734 {
3735     GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV);
3736     GV * const *gvp;
3737     PERL_ARGS_ASSERT_GV_OVERRIDE;
3738     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv;
3739     gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE);
3740     gv = gvp ? *gvp : NULL;
3741     if (gv && !isGV(gv)) {
3742         if (!SvPCS_IMPORTED(gv)) return NULL;
3743         gv_init(gv, PL_globalstash, name, len, 0);
3744         return gv;
3745     }
3746     return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL;
3747 }
3748
3749 #include "XSUB.h"
3750
3751 static void
3752 core_xsub(pTHX_ CV* cv)
3753 {
3754     Perl_croak(aTHX_
3755        "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3756     );
3757 }
3758
3759 /*
3760  * ex: set ts=8 sts=4 sw=4 et:
3761  */