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