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