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