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