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