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