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