Test for namedprotos: @_ should be a valid slurpy param
[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 '\010':    /* $^H */
1917             {
1918                 HV *const hv = GvHVn(gv);
1919                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1920             }
1921             goto magicalize;
1922         case '[':               /* $[ */
1923             if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
1924              && FEATURE_ARYBASE_IS_ENABLED) {
1925                 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1926                 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
1927                 addmg = 0;
1928             }
1929             else goto magicalize;
1930             break;
1931         case '\023':    /* $^S */
1932         ro_magicalize:
1933             SvREADONLY_on(GvSVn(gv));
1934             /* FALL THROUGH */
1935         case '0':               /* $0 */
1936         case '1':               /* $1 */
1937         case '2':               /* $2 */
1938         case '3':               /* $3 */
1939         case '4':               /* $4 */
1940         case '5':               /* $5 */
1941         case '6':               /* $6 */
1942         case '7':               /* $7 */
1943         case '8':               /* $8 */
1944         case '9':               /* $9 */
1945         case '^':               /* $^ */
1946         case '~':               /* $~ */
1947         case '=':               /* $= */
1948         case '%':               /* $% */
1949         case '.':               /* $. */
1950         case '(':               /* $( */
1951         case ')':               /* $) */
1952         case '<':               /* $< */
1953         case '>':               /* $> */
1954         case '\\':              /* $\ */
1955         case '/':               /* $/ */
1956         case '|':               /* $| */
1957         case '$':               /* $$ */
1958         case '\001':    /* $^A */
1959         case '\003':    /* $^C */
1960         case '\004':    /* $^D */
1961         case '\005':    /* $^E */
1962         case '\006':    /* $^F */
1963         case '\011':    /* $^I, NOT \t in EBCDIC */
1964         case '\016':    /* $^N */
1965         case '\017':    /* $^O */
1966         case '\020':    /* $^P */
1967         case '\024':    /* $^T */
1968         case '\027':    /* $^W */
1969         magicalize:
1970             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1971             break;
1972
1973         case '\014':    /* $^L */
1974             sv_setpvs(GvSVn(gv),"\f");
1975             break;
1976         case ';':               /* $; */
1977             sv_setpvs(GvSVn(gv),"\034");
1978             break;
1979         case ']':               /* $] */
1980         {
1981             SV * const sv = GvSV(gv);
1982             if (!sv_derived_from(PL_patchlevel, "version"))
1983                 upg_version(PL_patchlevel, TRUE);
1984             GvSV(gv) = vnumify(PL_patchlevel);
1985             SvREADONLY_on(GvSV(gv));
1986             SvREFCNT_dec(sv);
1987         }
1988         break;
1989         case '\026':    /* $^V */
1990         {
1991             SV * const sv = GvSV(gv);
1992             GvSV(gv) = new_version(PL_patchlevel);
1993             SvREADONLY_on(GvSV(gv));
1994             SvREFCNT_dec(sv);
1995         }
1996         break;
1997         }
1998     }
1999   add_magical_gv:
2000     if (addmg) {
2001         if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
2002              GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
2003            ))
2004             (void)hv_store(stash,name,len,(SV *)gv,0);
2005         else SvREFCNT_dec(gv), gv = NULL;
2006     }
2007     if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
2008     return gv;
2009 }
2010
2011 void
2012 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2013 {
2014     const char *name;
2015     const HV * const hv = GvSTASH(gv);
2016
2017     PERL_ARGS_ASSERT_GV_FULLNAME4;
2018
2019     sv_setpv(sv, prefix ? prefix : "");
2020
2021     if (hv && (name = HvNAME(hv))) {
2022       const STRLEN len = HvNAMELEN(hv);
2023       if (keepmain || strnNE(name, "main", len)) {
2024         sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
2025         sv_catpvs(sv,"::");
2026       }
2027     }
2028     else sv_catpvs(sv,"__ANON__::");
2029     sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2030 }
2031
2032 void
2033 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2034 {
2035     const GV * const egv = GvEGVx(gv);
2036
2037     PERL_ARGS_ASSERT_GV_EFULLNAME4;
2038
2039     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2040 }
2041
2042 void
2043 Perl_gv_check(pTHX_ const HV *stash)
2044 {
2045     dVAR;
2046     I32 i;
2047
2048     PERL_ARGS_ASSERT_GV_CHECK;
2049
2050     if (!HvARRAY(stash))
2051         return;
2052     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2053         const HE *entry;
2054         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2055             GV *gv;
2056             HV *hv;
2057             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
2058                 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2059             {
2060                 if (hv != PL_defstash && hv != stash)
2061                      gv_check(hv);              /* nested package */
2062             }
2063             else if ( *HeKEY(entry) != '_'
2064                         && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
2065                 const char *file;
2066                 gv = MUTABLE_GV(HeVAL(entry));
2067                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2068                     continue;
2069                 file = GvFILE(gv);
2070                 CopLINE_set(PL_curcop, GvLINE(gv));
2071 #ifdef USE_ITHREADS
2072                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
2073 #else
2074                 CopFILEGV(PL_curcop)
2075                     = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2076 #endif
2077                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2078                         "Name \"%"HEKf"::%"HEKf
2079                         "\" used only once: possible typo",
2080                             HEKfARG(HvNAME_HEK(stash)),
2081                             HEKfARG(GvNAME_HEK(gv)));
2082             }
2083         }
2084     }
2085 }
2086
2087 GV *
2088 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2089 {
2090     dVAR;
2091     PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2092
2093     return gv_fetchpv(Perl_form(aTHX_ "%"SVf"::_GEN_%ld",
2094                                     SVfARG(newSVpvn_flags(pack, strlen(pack),
2095                                             SVs_TEMP | flags)),
2096                                 (long)PL_gensym++),
2097                       GV_ADD, SVt_PVGV);
2098 }
2099
2100 /* hopefully this is only called on local symbol table entries */
2101
2102 GP*
2103 Perl_gp_ref(pTHX_ GP *gp)
2104 {
2105     dVAR;
2106     if (!gp)
2107         return NULL;
2108     gp->gp_refcnt++;
2109     if (gp->gp_cv) {
2110         if (gp->gp_cvgen) {
2111             /* If the GP they asked for a reference to contains
2112                a method cache entry, clear it first, so that we
2113                don't infect them with our cached entry */
2114             SvREFCNT_dec(gp->gp_cv);
2115             gp->gp_cv = NULL;
2116             gp->gp_cvgen = 0;
2117         }
2118     }
2119     return gp;
2120 }
2121
2122 void
2123 Perl_gp_free(pTHX_ GV *gv)
2124 {
2125     dVAR;
2126     GP* gp;
2127     int attempts = 100;
2128
2129     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2130         return;
2131     if (gp->gp_refcnt == 0) {
2132         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2133                          "Attempt to free unreferenced glob pointers"
2134                          pTHX__FORMAT pTHX__VALUE);
2135         return;
2136     }
2137     if (--gp->gp_refcnt > 0) {
2138         if (gp->gp_egv == gv)
2139             gp->gp_egv = 0;
2140         GvGP_set(gv, NULL);
2141         return;
2142     }
2143
2144     while (1) {
2145       /* Copy and null out all the glob slots, so destructors do not see
2146          freed SVs. */
2147       HEK * const file_hek = gp->gp_file_hek;
2148       SV  * const sv       = gp->gp_sv;
2149       AV  * const av       = gp->gp_av;
2150       HV  * const hv       = gp->gp_hv;
2151       IO  * const io       = gp->gp_io;
2152       CV  * const cv       = gp->gp_cv;
2153       CV  * const form     = gp->gp_form;
2154
2155       gp->gp_file_hek = NULL;
2156       gp->gp_sv       = NULL;
2157       gp->gp_av       = NULL;
2158       gp->gp_hv       = NULL;
2159       gp->gp_io       = NULL;
2160       gp->gp_cv       = NULL;
2161       gp->gp_form     = NULL;
2162
2163       if (file_hek)
2164         unshare_hek(file_hek);
2165
2166       SvREFCNT_dec(sv);
2167       SvREFCNT_dec(av);
2168       /* FIXME - another reference loop GV -> symtab -> GV ?
2169          Somehow gp->gp_hv can end up pointing at freed garbage.  */
2170       if (hv && SvTYPE(hv) == SVt_PVHV) {
2171         const HEK *hvname_hek = HvNAME_HEK(hv);
2172         DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", hvname_hek));
2173         if (PL_stashcache && hvname_hek)
2174            (void)hv_delete(PL_stashcache, HEK_KEY(hvname_hek),
2175                       (HEK_UTF8(hvname_hek) ? -HEK_LEN(hvname_hek) : HEK_LEN(hvname_hek)),
2176                       G_DISCARD);
2177         SvREFCNT_dec(hv);
2178       }
2179       SvREFCNT_dec(io);
2180       SvREFCNT_dec(cv);
2181       SvREFCNT_dec(form);
2182
2183       if (!gp->gp_file_hek
2184        && !gp->gp_sv
2185        && !gp->gp_av
2186        && !gp->gp_hv
2187        && !gp->gp_io
2188        && !gp->gp_cv
2189        && !gp->gp_form) break;
2190
2191       if (--attempts == 0) {
2192         Perl_die(aTHX_
2193           "panic: gp_free failed to free glob pointer - "
2194           "something is repeatedly re-creating entries"
2195         );
2196       }
2197     }
2198
2199     Safefree(gp);
2200     GvGP_set(gv, NULL);
2201 }
2202
2203 int
2204 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2205 {
2206     AMT * const amtp = (AMT*)mg->mg_ptr;
2207     PERL_UNUSED_ARG(sv);
2208
2209     PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2210
2211     if (amtp && AMT_AMAGIC(amtp)) {
2212         int i;
2213         for (i = 1; i < NofAMmeth; i++) {
2214             CV * const cv = amtp->table[i];
2215             if (cv) {
2216                 SvREFCNT_dec(MUTABLE_SV(cv));
2217                 amtp->table[i] = NULL;
2218             }
2219         }
2220     }
2221  return 0;
2222 }
2223
2224 /* Updates and caches the CV's */
2225 /* Returns:
2226  * 1 on success and there is some overload
2227  * 0 if there is no overload
2228  * -1 if some error occurred and it couldn't croak
2229  */
2230
2231 int
2232 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2233 {
2234   dVAR;
2235   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2236   AMT amt;
2237   const struct mro_meta* stash_meta = HvMROMETA(stash);
2238   U32 newgen;
2239
2240   PERL_ARGS_ASSERT_GV_AMUPDATE;
2241
2242   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2243   if (mg) {
2244       const AMT * const amtp = (AMT*)mg->mg_ptr;
2245       if (amtp->was_ok_sub == newgen) {
2246           return AMT_OVERLOADED(amtp) ? 1 : 0;
2247       }
2248       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2249   }
2250
2251   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2252
2253   Zero(&amt,1,AMT);
2254   amt.was_ok_sub = newgen;
2255   amt.fallback = AMGfallNO;
2256   amt.flags = 0;
2257
2258   {
2259     int filled = 0, have_ovl = 0;
2260     int i, lim = 1;
2261
2262     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2263
2264     /* Try to find via inheritance. */
2265     GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2266     SV * const sv = gv ? GvSV(gv) : NULL;
2267     CV* cv;
2268
2269     if (!gv)
2270     {
2271       if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
2272         lim = DESTROY_amg;              /* Skip overloading entries. */
2273     }
2274 #ifdef PERL_DONT_CREATE_GVSV
2275     else if (!sv) {
2276         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
2277     }
2278 #endif
2279     else if (SvTRUE(sv))
2280         /* don't need to set overloading here because fallback => 1
2281          * is the default setting for classes without overloading */
2282         amt.fallback=AMGfallYES;
2283     else if (SvOK(sv)) {
2284         amt.fallback=AMGfallNEVER;
2285         filled = 1;
2286         have_ovl = 1;
2287     }
2288     else {
2289         filled = 1;
2290         have_ovl = 1;
2291     }
2292
2293     for (i = 1; i < lim; i++)
2294         amt.table[i] = NULL;
2295     for (; i < NofAMmeth; i++) {
2296         const char * const cooky = PL_AMG_names[i];
2297         /* Human-readable form, for debugging: */
2298         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
2299         const STRLEN l = PL_AMG_namelens[i];
2300
2301         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2302                      cp, HvNAME_get(stash)) );
2303         /* don't fill the cache while looking up!
2304            Creation of inheritance stubs in intermediate packages may
2305            conflict with the logic of runtime method substitution.
2306            Indeed, for inheritance A -> B -> C, if C overloads "+0",
2307            then we could have created stubs for "(+0" in A and C too.
2308            But if B overloads "bool", we may want to use it for
2309            numifying instead of C's "+0". */
2310         if (i >= DESTROY_amg)
2311             gv = Perl_gv_fetchmeth_pvn_autoload(aTHX_ stash, cooky, l, 0, 0);
2312         else                            /* Autoload taken care of below */
2313             gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2314         cv = 0;
2315         if (gv && (cv = GvCV(gv))) {
2316             if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
2317               const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
2318               if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
2319                && strEQ(hvname, "overload")) {
2320                 /* This is a hack to support autoloading..., while
2321                    knowing *which* methods were declared as overloaded. */
2322                 /* GvSV contains the name of the method. */
2323                 GV *ngv = NULL;
2324                 SV *gvsv = GvSV(gv);
2325
2326                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2327                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
2328                              (void*)GvSV(gv), cp, HvNAME(stash)) );
2329                 if (!gvsv || !SvPOK(gvsv)
2330                     || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2331                 {
2332                     /* Can be an import stub (created by "can"). */
2333                     if (destructing) {
2334                         return -1;
2335                     }
2336                     else {
2337                         const SV * const name = (gvsv && SvPOK(gvsv))
2338                                                     ? gvsv
2339                                                     : newSVpvs_flags("???", SVs_TEMP);
2340                         /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
2341                         Perl_croak(aTHX_ "%s method \"%"SVf256
2342                                     "\" overloading \"%s\" "\
2343                                     "in package \"%"HEKf256"\"",
2344                                    (GvCVGEN(gv) ? "Stub found while resolving"
2345                                     : "Can't resolve"),
2346                                    SVfARG(name), cp,
2347                                    HEKfARG(
2348                                         HvNAME_HEK(stash)
2349                                    ));
2350                     }
2351                 }
2352                 cv = GvCV(gv = ngv);
2353               }
2354             }
2355             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2356                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2357                          GvNAME(CvGV(cv))) );
2358             filled = 1;
2359             if (i < DESTROY_amg)
2360                 have_ovl = 1;
2361         } else if (gv) {                /* Autoloaded... */
2362             cv = MUTABLE_CV(gv);
2363             filled = 1;
2364         }
2365         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2366     }
2367     if (filled) {
2368       AMT_AMAGIC_on(&amt);
2369       if (have_ovl)
2370           AMT_OVERLOADED_on(&amt);
2371       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2372                                                 (char*)&amt, sizeof(AMT));
2373       return have_ovl;
2374     }
2375   }
2376   /* Here we have no table: */
2377   /* no_table: */
2378   AMT_AMAGIC_off(&amt);
2379   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2380                                                 (char*)&amt, sizeof(AMTS));
2381   return 0;
2382 }
2383
2384
2385 CV*
2386 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2387 {
2388     dVAR;
2389     MAGIC *mg;
2390     AMT *amtp;
2391     U32 newgen;
2392     struct mro_meta* stash_meta;
2393
2394     if (!stash || !HvNAME_get(stash))
2395         return NULL;
2396
2397     stash_meta = HvMROMETA(stash);
2398     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2399
2400     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2401     if (!mg) {
2402       do_update:
2403         /* If we're looking up a destructor to invoke, we must avoid
2404          * that Gv_AMupdate croaks, because we might be dying already */
2405         if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
2406             /* and if it didn't found a destructor, we fall back
2407              * to a simpler method that will only look for the
2408              * destructor instead of the whole magic */
2409             if (id == DESTROY_amg) {
2410                 GV * const gv = gv_fetchmethod(stash, "DESTROY");
2411                 if (gv)
2412                     return GvCV(gv);
2413             }
2414             return NULL;
2415         }
2416         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2417     }
2418     assert(mg);
2419     amtp = (AMT*)mg->mg_ptr;
2420     if ( amtp->was_ok_sub != newgen )
2421         goto do_update;
2422     if (AMT_AMAGIC(amtp)) {
2423         CV * const ret = amtp->table[id];
2424         if (ret && isGV(ret)) {         /* Autoloading stab */
2425             /* Passing it through may have resulted in a warning
2426                "Inherited AUTOLOAD for a non-method deprecated", since
2427                our caller is going through a function call, not a method call.
2428                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2429             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2430
2431             if (gv && GvCV(gv))
2432                 return GvCV(gv);
2433         }
2434         return ret;
2435     }
2436
2437     return NULL;
2438 }
2439
2440
2441 /* Implement tryAMAGICun_MG macro.
2442    Do get magic, then see if the stack arg is overloaded and if so call it.
2443    Flags:
2444         AMGf_set     return the arg using SETs rather than assigning to
2445                      the targ
2446         AMGf_numeric apply sv_2num to the stack arg.
2447 */
2448
2449 bool
2450 Perl_try_amagic_un(pTHX_ int method, int flags) {
2451     dVAR;
2452     dSP;
2453     SV* tmpsv;
2454     SV* const arg = TOPs;
2455
2456     SvGETMAGIC(arg);
2457
2458     if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2459                                               AMGf_noright | AMGf_unary))) {
2460         if (flags & AMGf_set) {
2461             SETs(tmpsv);
2462         }
2463         else {
2464             dTARGET;
2465             if (SvPADMY(TARG)) {
2466                 sv_setsv(TARG, tmpsv);
2467                 SETTARG;
2468             }
2469             else
2470                 SETs(tmpsv);
2471         }
2472         PUTBACK;
2473         return TRUE;
2474     }
2475
2476     if ((flags & AMGf_numeric) && SvROK(arg))
2477         *sp = sv_2num(arg);
2478     return FALSE;
2479 }
2480
2481
2482 /* Implement tryAMAGICbin_MG macro.
2483    Do get magic, then see if the two stack args are overloaded and if so
2484    call it.
2485    Flags:
2486         AMGf_set     return the arg using SETs rather than assigning to
2487                      the targ
2488         AMGf_assign  op may be called as mutator (eg +=)
2489         AMGf_numeric apply sv_2num to the stack arg.
2490 */
2491
2492 bool
2493 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2494     dVAR;
2495     dSP;
2496     SV* const left = TOPm1s;
2497     SV* const right = TOPs;
2498
2499     SvGETMAGIC(left);
2500     if (left != right)
2501         SvGETMAGIC(right);
2502
2503     if (SvAMAGIC(left) || SvAMAGIC(right)) {
2504         SV * const tmpsv = amagic_call(left, right, method,
2505                     ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2506         if (tmpsv) {
2507             if (flags & AMGf_set) {
2508                 (void)POPs;
2509                 SETs(tmpsv);
2510             }
2511             else {
2512                 dATARGET;
2513                 (void)POPs;
2514                 if (opASSIGN || SvPADMY(TARG)) {
2515                     sv_setsv(TARG, tmpsv);
2516                     SETTARG;
2517                 }
2518                 else
2519                     SETs(tmpsv);
2520             }
2521             PUTBACK;
2522             return TRUE;
2523         }
2524     }
2525     if(left==right && SvGMAGICAL(left)) {
2526         SV * const left = sv_newmortal();
2527         *(sp-1) = left;
2528         /* Print the uninitialized warning now, so it includes the vari-
2529            able name. */
2530         if (!SvOK(right)) {
2531             if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2532             sv_setsv_flags(left, &PL_sv_no, 0);
2533         }
2534         else sv_setsv_flags(left, right, 0);
2535         SvGETMAGIC(right);
2536     }
2537     if (flags & AMGf_numeric) {
2538         if (SvROK(TOPm1s))
2539             *(sp-1) = sv_2num(TOPm1s);
2540         if (SvROK(right))
2541             *sp     = sv_2num(right);
2542     }
2543     return FALSE;
2544 }
2545
2546 SV *
2547 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2548     SV *tmpsv = NULL;
2549
2550     PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2551
2552     while (SvAMAGIC(ref) && 
2553            (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2554                                 AMGf_noright | AMGf_unary))) { 
2555         if (!SvROK(tmpsv))
2556             Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2557         if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2558             /* Bail out if it returns us the same reference.  */
2559             return tmpsv;
2560         }
2561         ref = tmpsv;
2562     }
2563     return tmpsv ? tmpsv : ref;
2564 }
2565
2566 bool
2567 Perl_amagic_is_enabled(pTHX_ int method)
2568 {
2569       SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2570
2571       assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
2572
2573       if ( !lex_mask || !SvOK(lex_mask) )
2574           /* overloading lexically disabled */
2575           return FALSE;
2576       else if ( lex_mask && SvPOK(lex_mask) ) {
2577           /* we have an entry in the hints hash, check if method has been
2578            * masked by overloading.pm */
2579           STRLEN len;
2580           const int offset = method / 8;
2581           const int bit    = method % 8;
2582           char *pv = SvPV(lex_mask, len);
2583
2584           /* Bit set, so this overloading operator is disabled */
2585           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2586               return FALSE;
2587       }
2588       return TRUE;
2589 }
2590
2591 SV*
2592 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2593 {
2594   dVAR;
2595   MAGIC *mg;
2596   CV *cv=NULL;
2597   CV **cvp=NULL, **ocvp=NULL;
2598   AMT *amtp=NULL, *oamtp=NULL;
2599   int off = 0, off1, lr = 0, notfound = 0;
2600   int postpr = 0, force_cpy = 0;
2601   int assign = AMGf_assign & flags;
2602   const int assignshift = assign ? 1 : 0;
2603   int use_default_op = 0;
2604   int force_scalar = 0;
2605 #ifdef DEBUGGING
2606   int fl=0;
2607 #endif
2608   HV* stash=NULL;
2609
2610   PERL_ARGS_ASSERT_AMAGIC_CALL;
2611
2612   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2613       if (!amagic_is_enabled(method)) return NULL;
2614   }
2615
2616   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2617       && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
2618       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2619       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2620                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2621                         : NULL))
2622       && ((cv = cvp[off=method+assignshift])
2623           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2624                                                           * usual method */
2625                   (
2626 #ifdef DEBUGGING
2627                    fl = 1,
2628 #endif
2629                    cv = cvp[off=method])))) {
2630     lr = -1;                    /* Call method for left argument */
2631   } else {
2632     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2633       int logic;
2634
2635       /* look for substituted methods */
2636       /* In all the covered cases we should be called with assign==0. */
2637          switch (method) {
2638          case inc_amg:
2639            force_cpy = 1;
2640            if ((cv = cvp[off=add_ass_amg])
2641                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2642              right = &PL_sv_yes; lr = -1; assign = 1;
2643            }
2644            break;
2645          case dec_amg:
2646            force_cpy = 1;
2647            if ((cv = cvp[off = subtr_ass_amg])
2648                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2649              right = &PL_sv_yes; lr = -1; assign = 1;
2650            }
2651            break;
2652          case bool__amg:
2653            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2654            break;
2655          case numer_amg:
2656            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2657            break;
2658          case string_amg:
2659            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2660            break;
2661          case not_amg:
2662            (void)((cv = cvp[off=bool__amg])
2663                   || (cv = cvp[off=numer_amg])
2664                   || (cv = cvp[off=string_amg]));
2665            if (cv)
2666                postpr = 1;
2667            break;
2668          case copy_amg:
2669            {
2670              /*
2671                   * SV* ref causes confusion with the interpreter variable of
2672                   * the same name
2673                   */
2674              SV* const tmpRef=SvRV(left);
2675              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2676                 /*
2677                  * Just to be extra cautious.  Maybe in some
2678                  * additional cases sv_setsv is safe, too.
2679                  */
2680                 SV* const newref = newSVsv(tmpRef);
2681                 SvOBJECT_on(newref);
2682                 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
2683                    delegate to the stash. */
2684                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2685                 return newref;
2686              }
2687            }
2688            break;
2689          case abs_amg:
2690            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2691                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2692              SV* const nullsv=sv_2mortal(newSViv(0));
2693              if (off1==lt_amg) {
2694                SV* const lessp = amagic_call(left,nullsv,
2695                                        lt_amg,AMGf_noright);
2696                logic = SvTRUE(lessp);
2697              } else {
2698                SV* const lessp = amagic_call(left,nullsv,
2699                                        ncmp_amg,AMGf_noright);
2700                logic = (SvNV(lessp) < 0);
2701              }
2702              if (logic) {
2703                if (off==subtr_amg) {
2704                  right = left;
2705                  left = nullsv;
2706                  lr = 1;
2707                }
2708              } else {
2709                return left;
2710              }
2711            }
2712            break;
2713          case neg_amg:
2714            if ((cv = cvp[off=subtr_amg])) {
2715              right = left;
2716              left = sv_2mortal(newSViv(0));
2717              lr = 1;
2718            }
2719            break;
2720          case int_amg:
2721          case iter_amg:                 /* XXXX Eventually should do to_gv. */
2722          case ftest_amg:                /* XXXX Eventually should do to_gv. */
2723          case regexp_amg:
2724              /* FAIL safe */
2725              return NULL;       /* Delegate operation to standard mechanisms. */
2726              break;
2727          case to_sv_amg:
2728          case to_av_amg:
2729          case to_hv_amg:
2730          case to_gv_amg:
2731          case to_cv_amg:
2732              /* FAIL safe */
2733              return left;       /* Delegate operation to standard mechanisms. */
2734              break;
2735          default:
2736            goto not_found;
2737          }
2738          if (!cv) goto not_found;
2739     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2740                && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
2741                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2742                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2743                           ? (amtp = (AMT*)mg->mg_ptr)->table
2744                           : NULL))
2745                && ((cv = cvp[off=method+assignshift])
2746                    || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2747                                                                    * usual method */
2748                        (
2749 #ifdef DEBUGGING
2750                         fl = 1,
2751 #endif
2752                         cv = cvp[off=method])))) { /* Method for right
2753                                                     * argument found */
2754         lr=1;
2755     } else if (((cvp && amtp->fallback > AMGfallNEVER)
2756                 || (ocvp && oamtp->fallback > AMGfallNEVER))
2757                && !(flags & AMGf_unary)) {
2758                                 /* We look for substitution for
2759                                  * comparison operations and
2760                                  * concatenation */
2761       if (method==concat_amg || method==concat_ass_amg
2762           || method==repeat_amg || method==repeat_ass_amg) {
2763         return NULL;            /* Delegate operation to string conversion */
2764       }
2765       off = -1;
2766       switch (method) {
2767          case lt_amg:
2768          case le_amg:
2769          case gt_amg:
2770          case ge_amg:
2771          case eq_amg:
2772          case ne_amg:
2773              off = ncmp_amg;
2774              break;
2775          case slt_amg:
2776          case sle_amg:
2777          case sgt_amg:
2778          case sge_amg:
2779          case seq_amg:
2780          case sne_amg:
2781              off = scmp_amg;
2782              break;
2783          }
2784       if (off != -1) {
2785           if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2786               cv = ocvp[off];
2787               lr = -1;
2788           }
2789           if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2790               cv = cvp[off];
2791               lr = 1;
2792           }
2793       }
2794       if (cv)
2795           postpr = 1;
2796       else
2797           goto not_found;
2798     } else {
2799     not_found:                  /* No method found, either report or croak */
2800       switch (method) {
2801          case to_sv_amg:
2802          case to_av_amg:
2803          case to_hv_amg:
2804          case to_gv_amg:
2805          case to_cv_amg:
2806              /* FAIL safe */
2807              return left;       /* Delegate operation to standard mechanisms. */
2808              break;
2809       }
2810       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2811         notfound = 1; lr = -1;
2812       } else if (cvp && (cv=cvp[nomethod_amg])) {
2813         notfound = 1; lr = 1;
2814       } else if ((use_default_op =
2815                   (!ocvp || oamtp->fallback >= AMGfallYES)
2816                   && (!cvp || amtp->fallback >= AMGfallYES))
2817                  && !DEBUG_o_TEST) {
2818         /* Skip generating the "no method found" message.  */
2819         return NULL;
2820       } else {
2821         SV *msg;
2822         if (off==-1) off=method;
2823         msg = sv_2mortal(Perl_newSVpvf(aTHX_
2824                       "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
2825                       AMG_id2name(method + assignshift),
2826                       (flags & AMGf_unary ? " " : "\n\tleft "),
2827                       SvAMAGIC(left)?
2828                         "in overloaded package ":
2829                         "has no overloaded magic",
2830                       SvAMAGIC(left)?
2831                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
2832                         SVfARG(&PL_sv_no),
2833                       SvAMAGIC(right)?
2834                         ",\n\tright argument in overloaded package ":
2835                         (flags & AMGf_unary
2836                          ? ""
2837                          : ",\n\tright argument has no overloaded magic"),
2838                       SvAMAGIC(right)?
2839                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
2840                         SVfARG(&PL_sv_no)));
2841         if (use_default_op) {
2842           DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
2843         } else {
2844           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2845         }
2846         return NULL;
2847       }
2848       force_cpy = force_cpy || assign;
2849     }
2850   }
2851
2852   switch (method) {
2853     /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
2854      * operation. we need this to return a value, so that it can be assigned
2855      * later on, in the postpr block (case inc_amg/dec_amg), even if the
2856      * increment or decrement was itself called in void context */
2857     case inc_amg:
2858       if (off == add_amg)
2859         force_scalar = 1;
2860       break;
2861     case dec_amg:
2862       if (off == subtr_amg)
2863         force_scalar = 1;
2864       break;
2865     /* in these cases, we're calling an assignment variant of an operator
2866      * (+= rather than +, for instance). regardless of whether it's a
2867      * fallback or not, it always has to return a value, which will be
2868      * assigned to the proper variable later */
2869     case add_amg:
2870     case subtr_amg:
2871     case mult_amg:
2872     case div_amg:
2873     case modulo_amg:
2874     case pow_amg:
2875     case lshift_amg:
2876     case rshift_amg:
2877     case repeat_amg:
2878     case concat_amg:
2879     case band_amg:
2880     case bor_amg:
2881     case bxor_amg:
2882       if (assign)
2883         force_scalar = 1;
2884       break;
2885     /* the copy constructor always needs to return a value */
2886     case copy_amg:
2887       force_scalar = 1;
2888       break;
2889     /* because of the way these are implemented (they don't perform the
2890      * dereferencing themselves, they return a reference that perl then
2891      * dereferences later), they always have to be in scalar context */
2892     case to_sv_amg:
2893     case to_av_amg:
2894     case to_hv_amg:
2895     case to_gv_amg:
2896     case to_cv_amg:
2897       force_scalar = 1;
2898       break;
2899     /* these don't have an op of their own; they're triggered by their parent
2900      * op, so the context there isn't meaningful ('$a and foo()' in void
2901      * context still needs to pass scalar context on to $a's bool overload) */
2902     case bool__amg:
2903     case numer_amg:
2904     case string_amg:
2905       force_scalar = 1;
2906       break;
2907   }
2908
2909 #ifdef DEBUGGING
2910   if (!notfound) {
2911     DEBUG_o(Perl_deb(aTHX_
2912                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
2913                      AMG_id2name(off),
2914                      method+assignshift==off? "" :
2915                      " (initially \"",
2916                      method+assignshift==off? "" :
2917                      AMG_id2name(method+assignshift),
2918                      method+assignshift==off? "" : "\")",
2919                      flags & AMGf_unary? "" :
2920                      lr==1 ? " for right argument": " for left argument",
2921                      flags & AMGf_unary? " for argument" : "",
2922                      stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
2923                      fl? ",\n\tassignment variant used": "") );
2924   }
2925 #endif
2926     /* Since we use shallow copy during assignment, we need
2927      * to dublicate the contents, probably calling user-supplied
2928      * version of copy operator
2929      */
2930     /* We need to copy in following cases:
2931      * a) Assignment form was called.
2932      *          assignshift==1,  assign==T, method + 1 == off
2933      * b) Increment or decrement, called directly.
2934      *          assignshift==0,  assign==0, method + 0 == off
2935      * c) Increment or decrement, translated to assignment add/subtr.
2936      *          assignshift==0,  assign==T,
2937      *          force_cpy == T
2938      * d) Increment or decrement, translated to nomethod.
2939      *          assignshift==0,  assign==0,
2940      *          force_cpy == T
2941      * e) Assignment form translated to nomethod.
2942      *          assignshift==1,  assign==T, method + 1 != off
2943      *          force_cpy == T
2944      */
2945     /*  off is method, method+assignshift, or a result of opcode substitution.
2946      *  In the latter case assignshift==0, so only notfound case is important.
2947      */
2948   if ( (lr == -1) && ( ( (method + assignshift == off)
2949         && (assign || (method == inc_amg) || (method == dec_amg)))
2950       || force_cpy) )
2951   {
2952       /* newSVsv does not behave as advertised, so we copy missing
2953        * information by hand */
2954       SV *tmpRef = SvRV(left);
2955       SV *rv_copy;
2956       if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
2957           SvRV_set(left, rv_copy);
2958           SvSETMAGIC(left);
2959           SvREFCNT_dec(tmpRef);  
2960       }
2961   }
2962
2963   {
2964     dSP;
2965     BINOP myop;
2966     SV* res;
2967     const bool oldcatch = CATCH_GET;
2968     I32 oldmark, nret;
2969     int gimme = force_scalar ? G_SCALAR : GIMME_V;
2970
2971     CATCH_SET(TRUE);
2972     Zero(&myop, 1, BINOP);
2973     myop.op_last = (OP *) &myop;
2974     myop.op_next = NULL;
2975     myop.op_flags = OPf_STACKED;
2976
2977     switch (gimme) {
2978         case G_VOID:
2979             myop.op_flags |= OPf_WANT_VOID;
2980             break;
2981         case G_ARRAY:
2982             if (flags & AMGf_want_list) {
2983                 myop.op_flags |= OPf_WANT_LIST;
2984                 break;
2985             }
2986             /* FALLTHROUGH */
2987         default:
2988             myop.op_flags |= OPf_WANT_SCALAR;
2989             break;
2990     }
2991
2992     PUSHSTACKi(PERLSI_OVERLOAD);
2993     ENTER;
2994     SAVEOP();
2995     PL_op = (OP *) &myop;
2996     if (PERLDB_SUB && PL_curstash != PL_debstash)
2997         PL_op->op_private |= OPpENTERSUB_DB;
2998     PUTBACK;
2999     Perl_pp_pushmark(aTHX);
3000
3001     EXTEND(SP, notfound + 5);
3002     PUSHs(lr>0? right: left);
3003     PUSHs(lr>0? left: right);
3004     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
3005     if (notfound) {
3006       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3007                            AMG_id2namelen(method + assignshift), SVs_TEMP));
3008     }
3009     PUSHs(MUTABLE_SV(cv));
3010     PUTBACK;
3011     oldmark = TOPMARK;
3012
3013     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3014       CALLRUNOPS(aTHX);
3015     LEAVE;
3016     SPAGAIN;
3017     nret = SP - (PL_stack_base + oldmark);
3018
3019     switch (gimme) {
3020         case G_VOID:
3021             /* returning NULL has another meaning, and we check the context
3022              * at the call site too, so this can be differentiated from the
3023              * scalar case */
3024             res = &PL_sv_undef;
3025             SP = PL_stack_base + oldmark;
3026             break;
3027         case G_ARRAY: {
3028             if (flags & AMGf_want_list) {
3029                 res = sv_2mortal((SV *)newAV());
3030                 av_extend((AV *)res, nret);
3031                 while (nret--)
3032                     av_store((AV *)res, nret, POPs);
3033                 break;
3034             }
3035             /* FALLTHROUGH */
3036         }
3037         default:
3038             res = POPs;
3039             break;
3040     }
3041
3042     PUTBACK;
3043     POPSTACK;
3044     CATCH_SET(oldcatch);
3045
3046     if (postpr) {
3047       int ans;
3048       switch (method) {
3049       case le_amg:
3050       case sle_amg:
3051         ans=SvIV(res)<=0; break;
3052       case lt_amg:
3053       case slt_amg:
3054         ans=SvIV(res)<0; break;
3055       case ge_amg:
3056       case sge_amg:
3057         ans=SvIV(res)>=0; break;
3058       case gt_amg:
3059       case sgt_amg:
3060         ans=SvIV(res)>0; break;
3061       case eq_amg:
3062       case seq_amg:
3063         ans=SvIV(res)==0; break;
3064       case ne_amg:
3065       case sne_amg:
3066         ans=SvIV(res)!=0; break;
3067       case inc_amg:
3068       case dec_amg:
3069         SvSetSV(left,res); return left;
3070       case not_amg:
3071         ans=!SvTRUE(res); break;
3072       default:
3073         ans=0; break;
3074       }
3075       return boolSV(ans);
3076     } else if (method==copy_amg) {
3077       if (!SvROK(res)) {
3078         Perl_croak(aTHX_ "Copy method did not return a reference");
3079       }
3080       return SvREFCNT_inc(SvRV(res));
3081     } else {
3082       return res;
3083     }
3084   }
3085 }
3086
3087 void
3088 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3089 {
3090     dVAR;
3091     U32 hash;
3092
3093     PERL_ARGS_ASSERT_GV_NAME_SET;
3094
3095     if (len > I32_MAX)
3096         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
3097
3098     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3099         unshare_hek(GvNAME_HEK(gv));
3100     }
3101
3102     PERL_HASH(hash, name, len);
3103     GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3104 }
3105
3106 /*
3107 =for apidoc gv_try_downgrade
3108
3109 If the typeglob C<gv> can be expressed more succinctly, by having
3110 something other than a real GV in its place in the stash, replace it
3111 with the optimised form.  Basic requirements for this are that C<gv>
3112 is a real typeglob, is sufficiently ordinary, and is only referenced
3113 from its package.  This function is meant to be used when a GV has been
3114 looked up in part to see what was there, causing upgrading, but based
3115 on what was found it turns out that the real GV isn't required after all.
3116
3117 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3118
3119 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3120 sub, the typeglob is replaced with a scalar-reference placeholder that
3121 more compactly represents the same thing.
3122
3123 =cut
3124 */
3125
3126 void
3127 Perl_gv_try_downgrade(pTHX_ GV *gv)
3128 {
3129     HV *stash;
3130     CV *cv;
3131     HEK *namehek;
3132     SV **gvp;
3133     PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3134
3135     /* XXX Why and where does this leave dangling pointers during global
3136        destruction? */
3137     if (PL_phase == PERL_PHASE_DESTRUCT) return;
3138
3139     if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3140             !SvOBJECT(gv) && !SvREADONLY(gv) &&
3141             isGV_with_GP(gv) && GvGP(gv) &&
3142             !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3143             !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3144             GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3145         return;
3146     if (SvMAGICAL(gv)) {
3147         MAGIC *mg;
3148         /* only backref magic is allowed */
3149         if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3150             return;
3151         for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3152             if (mg->mg_type != PERL_MAGIC_backref)
3153                 return;
3154         }
3155     }
3156     cv = GvCV(gv);
3157     if (!cv) {
3158         HEK *gvnhek = GvNAME_HEK(gv);
3159         (void)hv_delete(stash, HEK_KEY(gvnhek),
3160             HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
3161     } else if (GvMULTI(gv) && cv &&
3162             !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3163             CvSTASH(cv) == stash && CvGV(cv) == gv &&
3164             CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3165             !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3166             (namehek = GvNAME_HEK(gv)) &&
3167             (gvp = hv_fetch(stash, HEK_KEY(namehek),
3168                         HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
3169             *gvp == (SV*)gv) {
3170         SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3171         SvREFCNT(gv) = 0;
3172         sv_clear((SV*)gv);
3173         SvREFCNT(gv) = 1;
3174         SvFLAGS(gv) = SVt_IV|SVf_ROK;
3175         SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3176                                 STRUCT_OFFSET(XPVIV, xiv_iv));
3177         SvRV_set(gv, value);
3178     }
3179 }
3180
3181 #include "XSUB.h"
3182
3183 static void
3184 core_xsub(pTHX_ CV* cv)
3185 {
3186     Perl_croak(aTHX_
3187        "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3188     );
3189 }
3190
3191 /*
3192  * Local variables:
3193  * c-indentation-style: bsd
3194  * c-basic-offset: 4
3195  * indent-tabs-mode: nil
3196  * End:
3197  *
3198  * ex: set ts=8 sts=4 sw=4 et:
3199  */