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