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