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