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