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