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