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