fix 386a548 for fallback => undef
[perl.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         /* don't need to set overloading here because fallback => 1
2279          * is the default setting for classes without overloading */
2280         amt.fallback=AMGfallYES;
2281     else if (SvOK(sv)) {
2282         amt.fallback=AMGfallNEVER;
2283         filled = 1;
2284         have_ovl = 1;
2285     }
2286     else {
2287         filled = 1;
2288         have_ovl = 1;
2289     }
2290
2291     for (i = 1; i < lim; i++)
2292         amt.table[i] = NULL;
2293     for (; i < NofAMmeth; i++) {
2294         const char * const cooky = PL_AMG_names[i];
2295         /* Human-readable form, for debugging: */
2296         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
2297         const STRLEN l = PL_AMG_namelens[i];
2298
2299         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2300                      cp, HvNAME_get(stash)) );
2301         /* don't fill the cache while looking up!
2302            Creation of inheritance stubs in intermediate packages may
2303            conflict with the logic of runtime method substitution.
2304            Indeed, for inheritance A -> B -> C, if C overloads "+0",
2305            then we could have created stubs for "(+0" in A and C too.
2306            But if B overloads "bool", we may want to use it for
2307            numifying instead of C's "+0". */
2308         if (i >= DESTROY_amg)
2309             gv = Perl_gv_fetchmeth_pvn_autoload(aTHX_ stash, cooky, l, 0, 0);
2310         else                            /* Autoload taken care of below */
2311             gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2312         cv = 0;
2313         if (gv && (cv = GvCV(gv))) {
2314             if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
2315               const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
2316               if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
2317                && strEQ(hvname, "overload")) {
2318                 /* This is a hack to support autoloading..., while
2319                    knowing *which* methods were declared as overloaded. */
2320                 /* GvSV contains the name of the method. */
2321                 GV *ngv = NULL;
2322                 SV *gvsv = GvSV(gv);
2323
2324                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2325                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
2326                              (void*)GvSV(gv), cp, HvNAME(stash)) );
2327                 if (!gvsv || !SvPOK(gvsv)
2328                     || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2329                 {
2330                     /* Can be an import stub (created by "can"). */
2331                     if (destructing) {
2332                         return -1;
2333                     }
2334                     else {
2335                         const SV * const name = (gvsv && SvPOK(gvsv))
2336                                                     ? gvsv
2337                                                     : newSVpvs_flags("???", SVs_TEMP);
2338                         /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
2339                         Perl_croak(aTHX_ "%s method \"%"SVf256
2340                                     "\" overloading \"%s\" "\
2341                                     "in package \"%"HEKf256"\"",
2342                                    (GvCVGEN(gv) ? "Stub found while resolving"
2343                                     : "Can't resolve"),
2344                                    SVfARG(name), cp,
2345                                    HEKfARG(
2346                                         HvNAME_HEK(stash)
2347                                    ));
2348                     }
2349                 }
2350                 cv = GvCV(gv = ngv);
2351               }
2352             }
2353             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2354                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2355                          GvNAME(CvGV(cv))) );
2356             filled = 1;
2357             if (i < DESTROY_amg)
2358                 have_ovl = 1;
2359         } else if (gv) {                /* Autoloaded... */
2360             cv = MUTABLE_CV(gv);
2361             filled = 1;
2362         }
2363         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2364     }
2365     if (filled) {
2366       AMT_AMAGIC_on(&amt);
2367       if (have_ovl)
2368           AMT_OVERLOADED_on(&amt);
2369       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2370                                                 (char*)&amt, sizeof(AMT));
2371       return have_ovl;
2372     }
2373   }
2374   /* Here we have no table: */
2375   /* no_table: */
2376   AMT_AMAGIC_off(&amt);
2377   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2378                                                 (char*)&amt, sizeof(AMTS));
2379   return 0;
2380 }
2381
2382
2383 CV*
2384 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2385 {
2386     dVAR;
2387     MAGIC *mg;
2388     AMT *amtp;
2389     U32 newgen;
2390     struct mro_meta* stash_meta;
2391
2392     if (!stash || !HvNAME_get(stash))
2393         return NULL;
2394
2395     stash_meta = HvMROMETA(stash);
2396     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2397
2398     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2399     if (!mg) {
2400       do_update:
2401         /* If we're looking up a destructor to invoke, we must avoid
2402          * that Gv_AMupdate croaks, because we might be dying already */
2403         if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
2404             /* and if it didn't found a destructor, we fall back
2405              * to a simpler method that will only look for the
2406              * destructor instead of the whole magic */
2407             if (id == DESTROY_amg) {
2408                 GV * const gv = gv_fetchmethod(stash, "DESTROY");
2409                 if (gv)
2410                     return GvCV(gv);
2411             }
2412             return NULL;
2413         }
2414         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2415     }
2416     assert(mg);
2417     amtp = (AMT*)mg->mg_ptr;
2418     if ( amtp->was_ok_sub != newgen )
2419         goto do_update;
2420     if (AMT_AMAGIC(amtp)) {
2421         CV * const ret = amtp->table[id];
2422         if (ret && isGV(ret)) {         /* Autoloading stab */
2423             /* Passing it through may have resulted in a warning
2424                "Inherited AUTOLOAD for a non-method deprecated", since
2425                our caller is going through a function call, not a method call.
2426                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2427             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2428
2429             if (gv && GvCV(gv))
2430                 return GvCV(gv);
2431         }
2432         return ret;
2433     }
2434
2435     return NULL;
2436 }
2437
2438
2439 /* Implement tryAMAGICun_MG macro.
2440    Do get magic, then see if the stack arg is overloaded and if so call it.
2441    Flags:
2442         AMGf_set     return the arg using SETs rather than assigning to
2443                      the targ
2444         AMGf_numeric apply sv_2num to the stack arg.
2445 */
2446
2447 bool
2448 Perl_try_amagic_un(pTHX_ int method, int flags) {
2449     dVAR;
2450     dSP;
2451     SV* tmpsv;
2452     SV* const arg = TOPs;
2453
2454     SvGETMAGIC(arg);
2455
2456     if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2457                                               AMGf_noright | AMGf_unary))) {
2458         if (flags & AMGf_set) {
2459             SETs(tmpsv);
2460         }
2461         else {
2462             dTARGET;
2463             if (SvPADMY(TARG)) {
2464                 sv_setsv(TARG, tmpsv);
2465                 SETTARG;
2466             }
2467             else
2468                 SETs(tmpsv);
2469         }
2470         PUTBACK;
2471         return TRUE;
2472     }
2473
2474     if ((flags & AMGf_numeric) && SvROK(arg))
2475         *sp = sv_2num(arg);
2476     return FALSE;
2477 }
2478
2479
2480 /* Implement tryAMAGICbin_MG macro.
2481    Do get magic, then see if the two stack args are overloaded and if so
2482    call it.
2483    Flags:
2484         AMGf_set     return the arg using SETs rather than assigning to
2485                      the targ
2486         AMGf_assign  op may be called as mutator (eg +=)
2487         AMGf_numeric apply sv_2num to the stack arg.
2488 */
2489
2490 bool
2491 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2492     dVAR;
2493     dSP;
2494     SV* const left = TOPm1s;
2495     SV* const right = TOPs;
2496
2497     SvGETMAGIC(left);
2498     if (left != right)
2499         SvGETMAGIC(right);
2500
2501     if (SvAMAGIC(left) || SvAMAGIC(right)) {
2502         SV * const tmpsv = amagic_call(left, right, method,
2503                     ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2504         if (tmpsv) {
2505             if (flags & AMGf_set) {
2506                 (void)POPs;
2507                 SETs(tmpsv);
2508             }
2509             else {
2510                 dATARGET;
2511                 (void)POPs;
2512                 if (opASSIGN || SvPADMY(TARG)) {
2513                     sv_setsv(TARG, tmpsv);
2514                     SETTARG;
2515                 }
2516                 else
2517                     SETs(tmpsv);
2518             }
2519             PUTBACK;
2520             return TRUE;
2521         }
2522     }
2523     if(left==right && SvGMAGICAL(left)) {
2524         SV * const left = sv_newmortal();
2525         *(sp-1) = left;
2526         /* Print the uninitialized warning now, so it includes the vari-
2527            able name. */
2528         if (!SvOK(right)) {
2529             if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2530             sv_setsv_flags(left, &PL_sv_no, 0);
2531         }
2532         else sv_setsv_flags(left, right, 0);
2533         SvGETMAGIC(right);
2534     }
2535     if (flags & AMGf_numeric) {
2536         if (SvROK(TOPm1s))
2537             *(sp-1) = sv_2num(TOPm1s);
2538         if (SvROK(right))
2539             *sp     = sv_2num(right);
2540     }
2541     return FALSE;
2542 }
2543
2544 SV *
2545 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2546     SV *tmpsv = NULL;
2547
2548     PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2549
2550     while (SvAMAGIC(ref) && 
2551            (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2552                                 AMGf_noright | AMGf_unary))) { 
2553         if (!SvROK(tmpsv))
2554             Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2555         if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2556             /* Bail out if it returns us the same reference.  */
2557             return tmpsv;
2558         }
2559         ref = tmpsv;
2560     }
2561     return tmpsv ? tmpsv : ref;
2562 }
2563
2564 bool
2565 Perl_amagic_is_enabled(pTHX_ int method)
2566 {
2567       SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2568
2569       assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
2570
2571       if ( !lex_mask || !SvOK(lex_mask) )
2572           /* overloading lexically disabled */
2573           return FALSE;
2574       else if ( lex_mask && SvPOK(lex_mask) ) {
2575           /* we have an entry in the hints hash, check if method has been
2576            * masked by overloading.pm */
2577           STRLEN len;
2578           const int offset = method / 8;
2579           const int bit    = method % 8;
2580           char *pv = SvPV(lex_mask, len);
2581
2582           /* Bit set, so this overloading operator is disabled */
2583           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2584               return FALSE;
2585       }
2586       return TRUE;
2587 }
2588
2589 SV*
2590 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2591 {
2592   dVAR;
2593   MAGIC *mg;
2594   CV *cv=NULL;
2595   CV **cvp=NULL, **ocvp=NULL;
2596   AMT *amtp=NULL, *oamtp=NULL;
2597   int off = 0, off1, lr = 0, notfound = 0;
2598   int postpr = 0, force_cpy = 0;
2599   int assign = AMGf_assign & flags;
2600   const int assignshift = assign ? 1 : 0;
2601   int use_default_op = 0;
2602   int force_scalar = 0;
2603 #ifdef DEBUGGING
2604   int fl=0;
2605 #endif
2606   HV* stash=NULL;
2607
2608   PERL_ARGS_ASSERT_AMAGIC_CALL;
2609
2610   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2611       if (!amagic_is_enabled(method)) return NULL;
2612   }
2613
2614   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2615       && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
2616       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2617       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2618                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2619                         : NULL))
2620       && ((cv = cvp[off=method+assignshift])
2621           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2622                                                           * usual method */
2623                   (
2624 #ifdef DEBUGGING
2625                    fl = 1,
2626 #endif
2627                    cv = cvp[off=method])))) {
2628     lr = -1;                    /* Call method for left argument */
2629   } else {
2630     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2631       int logic;
2632
2633       /* look for substituted methods */
2634       /* In all the covered cases we should be called with assign==0. */
2635          switch (method) {
2636          case inc_amg:
2637            force_cpy = 1;
2638            if ((cv = cvp[off=add_ass_amg])
2639                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2640              right = &PL_sv_yes; lr = -1; assign = 1;
2641            }
2642            break;
2643          case dec_amg:
2644            force_cpy = 1;
2645            if ((cv = cvp[off = subtr_ass_amg])
2646                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2647              right = &PL_sv_yes; lr = -1; assign = 1;
2648            }
2649            break;
2650          case bool__amg:
2651            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2652            break;
2653          case numer_amg:
2654            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2655            break;
2656          case string_amg:
2657            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2658            break;
2659          case not_amg:
2660            (void)((cv = cvp[off=bool__amg])
2661                   || (cv = cvp[off=numer_amg])
2662                   || (cv = cvp[off=string_amg]));
2663            if (cv)
2664                postpr = 1;
2665            break;
2666          case copy_amg:
2667            {
2668              /*
2669                   * SV* ref causes confusion with the interpreter variable of
2670                   * the same name
2671                   */
2672              SV* const tmpRef=SvRV(left);
2673              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2674                 /*
2675                  * Just to be extra cautious.  Maybe in some
2676                  * additional cases sv_setsv is safe, too.
2677                  */
2678                 SV* const newref = newSVsv(tmpRef);
2679                 SvOBJECT_on(newref);
2680                 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
2681                    delegate to the stash. */
2682                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2683                 return newref;
2684              }
2685            }
2686            break;
2687          case abs_amg:
2688            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2689                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2690              SV* const nullsv=sv_2mortal(newSViv(0));
2691              if (off1==lt_amg) {
2692                SV* const lessp = amagic_call(left,nullsv,
2693                                        lt_amg,AMGf_noright);
2694                logic = SvTRUE(lessp);
2695              } else {
2696                SV* const lessp = amagic_call(left,nullsv,
2697                                        ncmp_amg,AMGf_noright);
2698                logic = (SvNV(lessp) < 0);
2699              }
2700              if (logic) {
2701                if (off==subtr_amg) {
2702                  right = left;
2703                  left = nullsv;
2704                  lr = 1;
2705                }
2706              } else {
2707                return left;
2708              }
2709            }
2710            break;
2711          case neg_amg:
2712            if ((cv = cvp[off=subtr_amg])) {
2713              right = left;
2714              left = sv_2mortal(newSViv(0));
2715              lr = 1;
2716            }
2717            break;
2718          case int_amg:
2719          case iter_amg:                 /* XXXX Eventually should do to_gv. */
2720          case ftest_amg:                /* XXXX Eventually should do to_gv. */
2721          case regexp_amg:
2722              /* FAIL safe */
2723              return NULL;       /* Delegate operation to standard mechanisms. */
2724              break;
2725          case to_sv_amg:
2726          case to_av_amg:
2727          case to_hv_amg:
2728          case to_gv_amg:
2729          case to_cv_amg:
2730              /* FAIL safe */
2731              return left;       /* Delegate operation to standard mechanisms. */
2732              break;
2733          default:
2734            goto not_found;
2735          }
2736          if (!cv) goto not_found;
2737     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2738                && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
2739                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2740                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2741                           ? (amtp = (AMT*)mg->mg_ptr)->table
2742                           : NULL))
2743                && ((cv = cvp[off=method+assignshift])
2744                    || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2745                                                                    * usual method */
2746                        (
2747 #ifdef DEBUGGING
2748                         fl = 1,
2749 #endif
2750                         cv = cvp[off=method])))) { /* Method for right
2751                                                     * argument found */
2752         lr=1;
2753     } else if (((cvp && amtp->fallback > AMGfallNEVER)
2754                 || (ocvp && oamtp->fallback > AMGfallNEVER))
2755                && !(flags & AMGf_unary)) {
2756                                 /* We look for substitution for
2757                                  * comparison operations and
2758                                  * concatenation */
2759       if (method==concat_amg || method==concat_ass_amg
2760           || method==repeat_amg || method==repeat_ass_amg) {
2761         return NULL;            /* Delegate operation to string conversion */
2762       }
2763       off = -1;
2764       switch (method) {
2765          case lt_amg:
2766          case le_amg:
2767          case gt_amg:
2768          case ge_amg:
2769          case eq_amg:
2770          case ne_amg:
2771              off = ncmp_amg;
2772              break;
2773          case slt_amg:
2774          case sle_amg:
2775          case sgt_amg:
2776          case sge_amg:
2777          case seq_amg:
2778          case sne_amg:
2779              off = scmp_amg;
2780              break;
2781          }
2782       if (off != -1) {
2783           if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2784               cv = ocvp[off];
2785               lr = -1;
2786           }
2787           if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2788               cv = cvp[off];
2789               lr = 1;
2790           }
2791       }
2792       if (cv)
2793           postpr = 1;
2794       else
2795           goto not_found;
2796     } else {
2797     not_found:                  /* No method found, either report or croak */
2798       switch (method) {
2799          case to_sv_amg:
2800          case to_av_amg:
2801          case to_hv_amg:
2802          case to_gv_amg:
2803          case to_cv_amg:
2804              /* FAIL safe */
2805              return left;       /* Delegate operation to standard mechanisms. */
2806              break;
2807       }
2808       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2809         notfound = 1; lr = -1;
2810       } else if (cvp && (cv=cvp[nomethod_amg])) {
2811         notfound = 1; lr = 1;
2812       } else if ((use_default_op =
2813                   (!ocvp || oamtp->fallback >= AMGfallYES)
2814                   && (!cvp || amtp->fallback >= AMGfallYES))
2815                  && !DEBUG_o_TEST) {
2816         /* Skip generating the "no method found" message.  */
2817         return NULL;
2818       } else {
2819         SV *msg;
2820         if (off==-1) off=method;
2821         msg = sv_2mortal(Perl_newSVpvf(aTHX_
2822                       "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
2823                       AMG_id2name(method + assignshift),
2824                       (flags & AMGf_unary ? " " : "\n\tleft "),
2825                       SvAMAGIC(left)?
2826                         "in overloaded package ":
2827                         "has no overloaded magic",
2828                       SvAMAGIC(left)?
2829                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
2830                         SVfARG(&PL_sv_no),
2831                       SvAMAGIC(right)?
2832                         ",\n\tright argument in overloaded package ":
2833                         (flags & AMGf_unary
2834                          ? ""
2835                          : ",\n\tright argument has no overloaded magic"),
2836                       SvAMAGIC(right)?
2837                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
2838                         SVfARG(&PL_sv_no)));
2839         if (use_default_op) {
2840           DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
2841         } else {
2842           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2843         }
2844         return NULL;
2845       }
2846       force_cpy = force_cpy || assign;
2847     }
2848   }
2849
2850   switch (method) {
2851     /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
2852      * operation. we need this to return a value, so that it can be assigned
2853      * later on, in the postpr block (case inc_amg/dec_amg), even if the
2854      * increment or decrement was itself called in void context */
2855     case inc_amg:
2856       if (off == add_amg)
2857         force_scalar = 1;
2858       break;
2859     case dec_amg:
2860       if (off == subtr_amg)
2861         force_scalar = 1;
2862       break;
2863     /* in these cases, we're calling an assignment variant of an operator
2864      * (+= rather than +, for instance). regardless of whether it's a
2865      * fallback or not, it always has to return a value, which will be
2866      * assigned to the proper variable later */
2867     case add_amg:
2868     case subtr_amg:
2869     case mult_amg:
2870     case div_amg:
2871     case modulo_amg:
2872     case pow_amg:
2873     case lshift_amg:
2874     case rshift_amg:
2875     case repeat_amg:
2876     case concat_amg:
2877     case band_amg:
2878     case bor_amg:
2879     case bxor_amg:
2880       if (assign)
2881         force_scalar = 1;
2882       break;
2883     /* the copy constructor always needs to return a value */
2884     case copy_amg:
2885       force_scalar = 1;
2886       break;
2887     /* because of the way these are implemented (they don't perform the
2888      * dereferencing themselves, they return a reference that perl then
2889      * dereferences later), they always have to be in scalar context */
2890     case to_sv_amg:
2891     case to_av_amg:
2892     case to_hv_amg:
2893     case to_gv_amg:
2894     case to_cv_amg:
2895       force_scalar = 1;
2896       break;
2897     /* these don't have an op of their own; they're triggered by their parent
2898      * op, so the context there isn't meaningful ('$a and foo()' in void
2899      * context still needs to pass scalar context on to $a's bool overload) */
2900     case bool__amg:
2901     case numer_amg:
2902     case string_amg:
2903       force_scalar = 1;
2904       break;
2905   }
2906
2907 #ifdef DEBUGGING
2908   if (!notfound) {
2909     DEBUG_o(Perl_deb(aTHX_
2910                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
2911                      AMG_id2name(off),
2912                      method+assignshift==off? "" :
2913                      " (initially \"",
2914                      method+assignshift==off? "" :
2915                      AMG_id2name(method+assignshift),
2916                      method+assignshift==off? "" : "\")",
2917                      flags & AMGf_unary? "" :
2918                      lr==1 ? " for right argument": " for left argument",
2919                      flags & AMGf_unary? " for argument" : "",
2920                      stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
2921                      fl? ",\n\tassignment variant used": "") );
2922   }
2923 #endif
2924     /* Since we use shallow copy during assignment, we need
2925      * to dublicate the contents, probably calling user-supplied
2926      * version of copy operator
2927      */
2928     /* We need to copy in following cases:
2929      * a) Assignment form was called.
2930      *          assignshift==1,  assign==T, method + 1 == off
2931      * b) Increment or decrement, called directly.
2932      *          assignshift==0,  assign==0, method + 0 == off
2933      * c) Increment or decrement, translated to assignment add/subtr.
2934      *          assignshift==0,  assign==T,
2935      *          force_cpy == T
2936      * d) Increment or decrement, translated to nomethod.
2937      *          assignshift==0,  assign==0,
2938      *          force_cpy == T
2939      * e) Assignment form translated to nomethod.
2940      *          assignshift==1,  assign==T, method + 1 != off
2941      *          force_cpy == T
2942      */
2943     /*  off is method, method+assignshift, or a result of opcode substitution.
2944      *  In the latter case assignshift==0, so only notfound case is important.
2945      */
2946   if ( (lr == -1) && ( ( (method + assignshift == off)
2947         && (assign || (method == inc_amg) || (method == dec_amg)))
2948       || force_cpy) )
2949   {
2950       /* newSVsv does not behave as advertised, so we copy missing
2951        * information by hand */
2952       SV *tmpRef = SvRV(left);
2953       SV *rv_copy;
2954       if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
2955           SvRV_set(left, rv_copy);
2956           SvSETMAGIC(left);
2957           SvREFCNT_dec(tmpRef);  
2958       }
2959   }
2960
2961   {
2962     dSP;
2963     BINOP myop;
2964     SV* res;
2965     const bool oldcatch = CATCH_GET;
2966     I32 oldmark, nret;
2967     int gimme = force_scalar ? G_SCALAR : GIMME_V;
2968
2969     CATCH_SET(TRUE);
2970     Zero(&myop, 1, BINOP);
2971     myop.op_last = (OP *) &myop;
2972     myop.op_next = NULL;
2973     myop.op_flags = OPf_STACKED;
2974
2975     switch (gimme) {
2976         case G_VOID:
2977             myop.op_flags |= OPf_WANT_VOID;
2978             break;
2979         case G_ARRAY:
2980             if (flags & AMGf_want_list) {
2981                 myop.op_flags |= OPf_WANT_LIST;
2982                 break;
2983             }
2984             /* FALLTHROUGH */
2985         default:
2986             myop.op_flags |= OPf_WANT_SCALAR;
2987             break;
2988     }
2989
2990     PUSHSTACKi(PERLSI_OVERLOAD);
2991     ENTER;
2992     SAVEOP();
2993     PL_op = (OP *) &myop;
2994     if (PERLDB_SUB && PL_curstash != PL_debstash)
2995         PL_op->op_private |= OPpENTERSUB_DB;
2996     PUTBACK;
2997     Perl_pp_pushmark(aTHX);
2998
2999     EXTEND(SP, notfound + 5);
3000     PUSHs(lr>0? right: left);
3001     PUSHs(lr>0? left: right);
3002     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
3003     if (notfound) {
3004       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3005                            AMG_id2namelen(method + assignshift), SVs_TEMP));
3006     }
3007     PUSHs(MUTABLE_SV(cv));
3008     PUTBACK;
3009     oldmark = TOPMARK;
3010
3011     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3012       CALLRUNOPS(aTHX);
3013     LEAVE;
3014     SPAGAIN;
3015     nret = SP - (PL_stack_base + oldmark);
3016
3017     switch (gimme) {
3018         case G_VOID:
3019             /* returning NULL has another meaning, and we check the context
3020              * at the call site too, so this can be differentiated from the
3021              * scalar case */
3022             res = &PL_sv_undef;
3023             SP = PL_stack_base + oldmark;
3024             break;
3025         case G_ARRAY: {
3026             if (flags & AMGf_want_list) {
3027                 res = sv_2mortal((SV *)newAV());
3028                 av_extend((AV *)res, nret);
3029                 while (nret--)
3030                     av_store((AV *)res, nret, POPs);
3031                 break;
3032             }
3033             /* FALLTHROUGH */
3034         }
3035         default:
3036             res = POPs;
3037             break;
3038     }
3039
3040     PUTBACK;
3041     POPSTACK;
3042     CATCH_SET(oldcatch);
3043
3044     if (postpr) {
3045       int ans;
3046       switch (method) {
3047       case le_amg:
3048       case sle_amg:
3049         ans=SvIV(res)<=0; break;
3050       case lt_amg:
3051       case slt_amg:
3052         ans=SvIV(res)<0; break;
3053       case ge_amg:
3054       case sge_amg:
3055         ans=SvIV(res)>=0; break;
3056       case gt_amg:
3057       case sgt_amg:
3058         ans=SvIV(res)>0; break;
3059       case eq_amg:
3060       case seq_amg:
3061         ans=SvIV(res)==0; break;
3062       case ne_amg:
3063       case sne_amg:
3064         ans=SvIV(res)!=0; break;
3065       case inc_amg:
3066       case dec_amg:
3067         SvSetSV(left,res); return left;
3068       case not_amg:
3069         ans=!SvTRUE(res); break;
3070       default:
3071         ans=0; break;
3072       }
3073       return boolSV(ans);
3074     } else if (method==copy_amg) {
3075       if (!SvROK(res)) {
3076         Perl_croak(aTHX_ "Copy method did not return a reference");
3077       }
3078       return SvREFCNT_inc(SvRV(res));
3079     } else {
3080       return res;
3081     }
3082   }
3083 }
3084
3085 void
3086 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3087 {
3088     dVAR;
3089     U32 hash;
3090
3091     PERL_ARGS_ASSERT_GV_NAME_SET;
3092
3093     if (len > I32_MAX)
3094         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
3095
3096     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3097         unshare_hek(GvNAME_HEK(gv));
3098     }
3099
3100     PERL_HASH(hash, name, len);
3101     GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3102 }
3103
3104 /*
3105 =for apidoc gv_try_downgrade
3106
3107 If the typeglob C<gv> can be expressed more succinctly, by having
3108 something other than a real GV in its place in the stash, replace it
3109 with the optimised form.  Basic requirements for this are that C<gv>
3110 is a real typeglob, is sufficiently ordinary, and is only referenced
3111 from its package.  This function is meant to be used when a GV has been
3112 looked up in part to see what was there, causing upgrading, but based
3113 on what was found it turns out that the real GV isn't required after all.
3114
3115 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3116
3117 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3118 sub, the typeglob is replaced with a scalar-reference placeholder that
3119 more compactly represents the same thing.
3120
3121 =cut
3122 */
3123
3124 void
3125 Perl_gv_try_downgrade(pTHX_ GV *gv)
3126 {
3127     HV *stash;
3128     CV *cv;
3129     HEK *namehek;
3130     SV **gvp;
3131     PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3132
3133     /* XXX Why and where does this leave dangling pointers during global
3134        destruction? */
3135     if (PL_phase == PERL_PHASE_DESTRUCT) return;
3136
3137     if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3138             !SvOBJECT(gv) && !SvREADONLY(gv) &&
3139             isGV_with_GP(gv) && GvGP(gv) &&
3140             !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3141             !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3142             GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3143         return;
3144     if (SvMAGICAL(gv)) {
3145         MAGIC *mg;
3146         /* only backref magic is allowed */
3147         if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3148             return;
3149         for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3150             if (mg->mg_type != PERL_MAGIC_backref)
3151                 return;
3152         }
3153     }
3154     cv = GvCV(gv);
3155     if (!cv) {
3156         HEK *gvnhek = GvNAME_HEK(gv);
3157         (void)hv_delete(stash, HEK_KEY(gvnhek),
3158             HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
3159     } else if (GvMULTI(gv) && cv &&
3160             !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3161             CvSTASH(cv) == stash && CvGV(cv) == gv &&
3162             CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3163             !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3164             (namehek = GvNAME_HEK(gv)) &&
3165             (gvp = hv_fetch(stash, HEK_KEY(namehek),
3166                         HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
3167             *gvp == (SV*)gv) {
3168         SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3169         SvREFCNT(gv) = 0;
3170         sv_clear((SV*)gv);
3171         SvREFCNT(gv) = 1;
3172         SvFLAGS(gv) = SVt_IV|SVf_ROK;
3173         SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3174                                 STRUCT_OFFSET(XPVIV, xiv_iv));
3175         SvRV_set(gv, value);
3176     }
3177 }
3178
3179 #include "XSUB.h"
3180
3181 static void
3182 core_xsub(pTHX_ CV* cv)
3183 {
3184     Perl_croak(aTHX_
3185        "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3186     );
3187 }
3188
3189 /*
3190  * Local variables:
3191  * c-indentation-style: bsd
3192  * c-basic-offset: 4
3193  * indent-tabs-mode: nil
3194  * End:
3195  *
3196  * ex: set ts=8 sts=4 sw=4 et:
3197  */