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