This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In Perl_gp_free() use PL_tmps_stack to avoid freeing glob entries immediately.
[perl5.git] / gv.c
1 /*    gv.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  *   'Mercy!' cried Gandalf.  'If the giving of information is to be the cure
13  * of your inquisitiveness, I shall spend all the rest of my days in answering
14  * you.  What more do you want to know?'
15  *   'The names of all the stars, and of all living things, and the whole
16  * history of Middle-earth and Over-heaven and of the Sundering Seas,'
17  * laughed Pippin.
18  *
19  *     [p.599 of _The Lord of the Rings_, III/xi: "The Palantír"]
20  */
21
22 /*
23 =head1 GV Handling
24 A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
25 It is a structure that holds a pointer to a scalar, an array, a hash etc,
26 corresponding to $foo, @foo, %foo.
27
28 GVs are usually found as values in stashes (symbol table hashes) where
29 Perl stores its global variables.
30
31 =for apidoc Ayh||GV
32
33 =cut
34 */
35
36 #include "EXTERN.h"
37 #define PERL_IN_GV_C
38 #include "perl.h"
39 #include "overload.inc"
40 #include "keywords.h"
41 #include "feature.h"
42
43 static const char S_autoload[] = "AUTOLOAD";
44 #define S_autolen (sizeof("AUTOLOAD")-1)
45
46 GV *
47 Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
48 {
49     SV **where;
50
51     if (
52         !gv
53      || (
54             SvTYPE((const SV *)gv) != SVt_PVGV
55          && SvTYPE((const SV *)gv) != SVt_PVLV
56         )
57     ) {
58         const char *what;
59         if (type == SVt_PVIO) {
60             /*
61              * if it walks like a dirhandle, then let's assume that
62              * this is a dirhandle.
63              */
64             what = OP_IS_DIRHOP(PL_op->op_type) ?
65                 "dirhandle" : "filehandle";
66         } else if (type == SVt_PVHV) {
67             what = "hash";
68         } else {
69             what = type == SVt_PVAV ? "array" : "scalar";
70         }
71         /* diag_listed_as: Bad symbol for filehandle */
72         Perl_croak(aTHX_ "Bad symbol for %s", what);
73     }
74
75     if (type == SVt_PVHV) {
76         where = (SV **)&GvHV(gv);
77     } else if (type == SVt_PVAV) {
78         where = (SV **)&GvAV(gv);
79     } else if (type == SVt_PVIO) {
80         where = (SV **)&GvIOp(gv);
81     } else {
82         where = &GvSV(gv);
83     }
84
85     if (!*where)
86     {
87         *where = newSV_type(type);
88             if (type == SVt_PVAV
89              && memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA"))
90             sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
91     }
92     return gv;
93 }
94
95 /*
96 =for apidoc gv_fetchfile
97 =for apidoc_item gv_fetchfile_flags
98
99 These return the debugger glob for the file (compiled by Perl) whose name is
100 given by the C<name> parameter.
101
102 There are currently exactly two differences between these functions.
103
104 The C<name> parameter to C<gv_fetchfile> is a C string, meaning it is
105 C<NUL>-terminated; whereas the C<name> parameter to C<gv_fetchfile_flags> is a
106 Perl string, whose length (in bytes) is passed in via the C<namelen> parameter
107 This means the name may contain embedded C<NUL> characters.
108 C<namelen> doesn't exist in plain C<gv_fetchfile>).
109
110 The other difference is that C<gv_fetchfile_flags> has an extra C<flags>
111 parameter, which is currently completely ignored, but allows for possible
112 future extensions.
113
114 =cut
115 */
116 GV *
117 Perl_gv_fetchfile(pTHX_ const char *name)
118 {
119     PERL_ARGS_ASSERT_GV_FETCHFILE;
120     return gv_fetchfile_flags(name, strlen(name), 0);
121 }
122
123 GV *
124 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
125                         const U32 flags)
126 {
127     char smallbuf[128];
128     char *tmpbuf;
129     const STRLEN tmplen = namelen + 2;
130     GV *gv;
131
132     PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS;
133     PERL_UNUSED_ARG(flags);
134
135     if (!PL_defstash)
136         return NULL;
137
138     if (tmplen <= sizeof smallbuf)
139         tmpbuf = smallbuf;
140     else
141         Newx(tmpbuf, tmplen, char);
142     /* This is where the debugger's %{"::_<$filename"} hash is created */
143     tmpbuf[0] = '_';
144     tmpbuf[1] = '<';
145     memcpy(tmpbuf + 2, name, namelen);
146     gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
147     if (!isGV(gv)) {
148         gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
149 #ifdef PERL_DONT_CREATE_GVSV
150         GvSV(gv) = newSVpvn(name, namelen);
151 #else
152         sv_setpvn(GvSV(gv), name, namelen);
153 #endif
154     }
155     if (PERLDB_LINE_OR_SAVESRC && !GvAV(gv))
156             hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile);
157     if (tmpbuf != smallbuf)
158         Safefree(tmpbuf);
159     return gv;
160 }
161
162 /*
163 =for apidoc gv_const_sv
164
165 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
166 inlining, or C<gv> is a placeholder reference that would be promoted to such
167 a typeglob, then returns the value returned by the sub.  Otherwise, returns
168 C<NULL>.
169
170 =cut
171 */
172
173 SV *
174 Perl_gv_const_sv(pTHX_ GV *gv)
175 {
176     PERL_ARGS_ASSERT_GV_CONST_SV;
177     PERL_UNUSED_CONTEXT;
178
179     if (SvTYPE(gv) == SVt_PVGV)
180         return cv_const_sv(GvCVu(gv));
181     return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV && SvTYPE(SvRV(gv)) != SVt_PVCV ? SvRV(gv) : NULL;
182 }
183
184 GP *
185 Perl_newGP(pTHX_ GV *const gv)
186 {
187     GP *gp;
188     U32 hash;
189     const char *file;
190     STRLEN len;
191 #ifndef USE_ITHREADS
192     GV *filegv;
193 #endif
194
195     PERL_ARGS_ASSERT_NEWGP;
196     Newxz(gp, 1, GP);
197     gp->gp_egv = gv; /* allow compiler to reuse gv after this */
198 #ifndef PERL_DONT_CREATE_GVSV
199     gp->gp_sv = newSV(0);
200 #endif
201
202     /* PL_curcop may be null here.  E.g.,
203         INIT { bless {} and exit }
204        frees INIT before looking up DESTROY (and creating *DESTROY)
205     */
206     if (PL_curcop) {
207         gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
208 #ifdef USE_ITHREADS
209         if (CopFILE(PL_curcop)) {
210             file = CopFILE(PL_curcop);
211             len = strlen(file);
212         }
213 #else
214         filegv = CopFILEGV(PL_curcop);
215         if (filegv) {
216             file = GvNAME(filegv)+2;
217             len = GvNAMELEN(filegv)-2;
218         }
219 #endif
220         else goto no_file;
221     }
222     else {
223         no_file:
224         file = "";
225         len = 0;
226     }
227
228     PERL_HASH(hash, file, len);
229     gp->gp_file_hek = share_hek(file, len, hash);
230     gp->gp_refcnt = 1;
231
232     return gp;
233 }
234
235 /* Assign CvGV(cv) = gv, handling weak references.
236  * See also S_anonymise_cv_maybe */
237
238 void
239 Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
240 {
241     GV * const oldgv = CvNAMED(cv) ? NULL : SvANY(cv)->xcv_gv_u.xcv_gv;
242     HEK *hek;
243     PERL_ARGS_ASSERT_CVGV_SET;
244
245     if (oldgv == gv)
246         return;
247
248     if (oldgv) {
249         if (CvCVGV_RC(cv)) {
250             SvREFCNT_dec_NN(oldgv);
251             CvCVGV_RC_off(cv);
252         }
253         else {
254             sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
255         }
256     }
257     else if ((hek = CvNAME_HEK(cv))) {
258         unshare_hek(hek);
259         CvLEXICAL_off(cv);
260     }
261
262     CvNAMED_off(cv);
263     SvANY(cv)->xcv_gv_u.xcv_gv = gv;
264     assert(!CvCVGV_RC(cv));
265
266     if (!gv)
267         return;
268
269     if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
270         Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
271     else {
272         CvCVGV_RC_on(cv);
273         SvREFCNT_inc_simple_void_NN(gv);
274     }
275 }
276
277 /* Convert CvSTASH + CvNAME_HEK into a GV.  Conceptually, all subs have a
278    GV, but for efficiency that GV may not in fact exist.  This function,
279    called by CvGV, reifies it. */
280
281 GV *
282 Perl_cvgv_from_hek(pTHX_ CV *cv)
283 {
284     GV *gv;
285     SV **svp;
286     PERL_ARGS_ASSERT_CVGV_FROM_HEK;
287     assert(SvTYPE(cv) == SVt_PVCV);
288     if (!CvSTASH(cv)) return NULL;
289     ASSUME(CvNAME_HEK(cv));
290     svp = hv_fetchhek(CvSTASH(cv), CvNAME_HEK(cv), 0);
291     gv = MUTABLE_GV(svp && *svp ? *svp : newSV(0));
292     if (!isGV(gv))
293         gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)),
294                 HEK_LEN(CvNAME_HEK(cv)),
295                 SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv)));
296     if (!CvNAMED(cv)) { /* gv_init took care of it */
297         assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv);
298         return gv;
299     }
300     unshare_hek(CvNAME_HEK(cv));
301     CvNAMED_off(cv);
302     SvANY(cv)->xcv_gv_u.xcv_gv = gv;
303     if (svp && *svp) SvREFCNT_inc_simple_void_NN(gv);
304     CvCVGV_RC_on(cv);
305     return gv;
306 }
307
308 /* Assign CvSTASH(cv) = st, handling weak references. */
309
310 void
311 Perl_cvstash_set(pTHX_ CV *cv, HV *st)
312 {
313     HV *oldst = CvSTASH(cv);
314     PERL_ARGS_ASSERT_CVSTASH_SET;
315     if (oldst == st)
316         return;
317     if (oldst)
318         sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
319     SvANY(cv)->xcv_stash = st;
320     if (st)
321         Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
322 }
323
324 /*
325 =for apidoc gv_init_pvn
326
327 Converts a scalar into a typeglob.  This is an incoercible typeglob;
328 assigning a reference to it will assign to one of its slots, instead of
329 overwriting it as happens with typeglobs created by C<SvSetSV>.  Converting
330 any scalar that is C<SvOK()> may produce unpredictable results and is reserved
331 for perl's internal use.
332
333 C<gv> is the scalar to be converted.
334
335 C<stash> is the parent stash/package, if any.
336
337 C<name> and C<len> give the name.  The name must be unqualified;
338 that is, it must not include the package name.  If C<gv> is a
339 stash element, it is the caller's responsibility to ensure that the name
340 passed to this function matches the name of the element.  If it does not
341 match, perl's internal bookkeeping will get out of sync.
342
343 C<flags> can be set to C<SVf_UTF8> if C<name> is a UTF-8 string, or
344 the return value of SvUTF8(sv).  It can also take the
345 C<GV_ADDMULTI> flag, which means to pretend that the GV has been
346 seen before (i.e., suppress "Used once" warnings).
347
348 =for apidoc Amnh||GV_ADDMULTI
349
350 =for apidoc gv_init
351
352 The old form of C<gv_init_pvn()>.  It does not work with UTF-8 strings, as it
353 has no flags parameter.  If the C<multi> parameter is set, the
354 C<GV_ADDMULTI> flag will be passed to C<gv_init_pvn()>.
355
356 =for apidoc gv_init_pv
357
358 Same as C<gv_init_pvn()>, but takes a nul-terminated string for the name
359 instead of separate char * and length parameters.
360
361 =for apidoc gv_init_sv
362
363 Same as C<gv_init_pvn()>, but takes an SV * for the name instead of separate
364 char * and length parameters.  C<flags> is currently unused.
365
366 =cut
367 */
368
369 void
370 Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
371 {
372    char *namepv;
373    STRLEN namelen;
374    PERL_ARGS_ASSERT_GV_INIT_SV;
375    namepv = SvPV(namesv, namelen);
376    if (SvUTF8(namesv))
377        flags |= SVf_UTF8;
378    gv_init_pvn(gv, stash, namepv, namelen, flags);
379 }
380
381 void
382 Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
383 {
384    PERL_ARGS_ASSERT_GV_INIT_PV;
385    gv_init_pvn(gv, stash, name, strlen(name), flags);
386 }
387
388 void
389 Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
390 {
391     const U32 old_type = SvTYPE(gv);
392     const bool doproto = old_type > SVt_NULL;
393     char * const proto = (doproto && SvPOK(gv))
394         ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
395         : NULL;
396     const STRLEN protolen = proto ? SvCUR(gv) : 0;
397     const U32 proto_utf8  = proto ? SvUTF8(gv) : 0;
398     SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
399     const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
400     const bool really_sub =
401         has_constant && SvTYPE(has_constant) == SVt_PVCV;
402     COP * const old = PL_curcop;
403
404     PERL_ARGS_ASSERT_GV_INIT_PVN;
405     assert (!(proto && has_constant));
406
407     if (has_constant) {
408         /* The constant has to be a scalar, array or subroutine.  */
409         switch (SvTYPE(has_constant)) {
410         case SVt_PVHV:
411         case SVt_PVFM:
412         case SVt_PVIO:
413             Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
414                        sv_reftype(has_constant, 0));
415             NOT_REACHED; /* NOTREACHED */
416             break;
417
418         default: NOOP;
419         }
420         SvRV_set(gv, NULL);
421         SvROK_off(gv);
422     }
423
424
425     if (old_type < SVt_PVGV) {
426         if (old_type >= SVt_PV)
427             SvCUR_set(gv, 0);
428         sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
429     }
430     if (SvLEN(gv)) {
431         if (proto) {
432             SvPV_set(gv, NULL);
433             SvLEN_set(gv, 0);
434             SvPOK_off(gv);
435         } else
436             Safefree(SvPVX_mutable(gv));
437     }
438     SvIOK_off(gv);
439     isGV_with_GP_on(gv);
440
441     if (really_sub && !CvISXSUB(has_constant) && CvSTART(has_constant)
442      && (  CvSTART(has_constant)->op_type == OP_NEXTSTATE
443         || CvSTART(has_constant)->op_type == OP_DBSTATE))
444         PL_curcop = (COP *)CvSTART(has_constant);
445     GvGP_set(gv, Perl_newGP(aTHX_ gv));
446     PL_curcop = old;
447     GvSTASH(gv) = stash;
448     if (stash)
449         Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
450     gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
451     if (flags & GV_ADDMULTI || doproto) /* doproto means it */
452         GvMULTI_on(gv);                 /* _was_ mentioned */
453     if (really_sub) {
454         /* Not actually a constant.  Just a regular sub.  */
455         CV * const cv = (CV *)has_constant;
456         GvCV_set(gv,cv);
457         if (CvNAMED(cv) && CvSTASH(cv) == stash && (
458                CvNAME_HEK(cv) == GvNAME_HEK(gv)
459             || (  HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv))
460                && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv))
461                && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv))
462                && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv))
463                )
464            ))
465             CvGV_set(cv,gv);
466     }
467     else if (doproto) {
468         CV *cv;
469         if (has_constant) {
470             /* newCONSTSUB takes ownership of the reference from us.  */
471             cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
472             /* In case op.c:S_process_special_blocks stole it: */
473             if (!GvCV(gv))
474                 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
475             assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
476             /* If this reference was a copy of another, then the subroutine
477                must have been "imported", by a Perl space assignment to a GV
478                from a reference to CV.  */
479             if (exported_constant)
480                 GvIMPORTED_CV_on(gv);
481             CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */
482         } else {
483             cv = newSTUB(gv,1);
484         }
485         if (proto) {
486             sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
487                             SV_HAS_TRAILING_NUL);
488             if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
489         }
490     }
491 }
492
493 STATIC void
494 S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
495 {
496     PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
497
498     switch (sv_type) {
499     case SVt_PVIO:
500         (void)GvIOn(gv);
501         break;
502     case SVt_PVAV:
503         (void)GvAVn(gv);
504         break;
505     case SVt_PVHV:
506         (void)GvHVn(gv);
507         break;
508 #ifdef PERL_DONT_CREATE_GVSV
509     case SVt_NULL:
510     case SVt_PVCV:
511     case SVt_PVFM:
512     case SVt_PVGV:
513         break;
514     default:
515         if(GvSVn(gv)) {
516             /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
517                If we just cast GvSVn(gv) to void, it ignores evaluating it for
518                its side effect */
519         }
520 #endif
521     }
522 }
523
524 static void core_xsub(pTHX_ CV* cv);
525
526 static GV *
527 S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
528                           const char * const name, const STRLEN len)
529 {
530     const int code = keyword(name, len, 1);
531     static const char file[] = __FILE__;
532     CV *cv, *oldcompcv = NULL;
533     int opnum = 0;
534     bool ampable = TRUE; /* &{}-able */
535     COP *oldcurcop = NULL;
536     yy_parser *oldparser = NULL;
537     I32 oldsavestack_ix = 0;
538
539     assert(gv || stash);
540     assert(name);
541
542     if (!code) return NULL; /* Not a keyword */
543     switch (code < 0 ? -code : code) {
544      /* no support for \&CORE::infix;
545         no support for funcs that do not parse like funcs */
546     case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD:
547     case KEY_BEGIN   : case KEY_CHECK  : case KEY_catch : case KEY_cmp:
548     case KEY_default : case KEY_defer  : case KEY_DESTROY:
549     case KEY_do      : case KEY_dump   : case KEY_else  : case KEY_elsif  :
550     case KEY_END     : case KEY_eq     : case KEY_eval  :
551     case KEY_for     : case KEY_foreach: case KEY_format: case KEY_ge     :
552     case KEY_given   : case KEY_goto   : case KEY_grep  : case KEY_gt     :
553     case KEY_if      : case KEY_isa    : case KEY_INIT  : case KEY_last   :
554     case KEY_le      : case KEY_local  : case KEY_lt    : case KEY_m      :
555     case KEY_map     : case KEY_my:
556     case KEY_ne   : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
557     case KEY_package: case KEY_print: case KEY_printf:
558     case KEY_q    : case KEY_qq   : case KEY_qr     : case KEY_qw    :
559     case KEY_qx   : case KEY_redo : case KEY_require: case KEY_return:
560     case KEY_s    : case KEY_say  : case KEY_sort   :
561     case KEY_state: case KEY_sub  :
562     case KEY_tr   : case KEY_try  : case KEY_UNITCHECK: case KEY_unless:
563     case KEY_until: case KEY_use  : case KEY_when     : case KEY_while :
564     case KEY_x    : case KEY_xor  : case KEY_y        :
565         return NULL;
566     case KEY_chdir:
567     case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
568     case KEY_eof  : case KEY_exec: case KEY_exists :
569     case KEY_lstat:
570     case KEY_split:
571     case KEY_stat:
572     case KEY_system:
573     case KEY_truncate: case KEY_unlink:
574         ampable = FALSE;
575     }
576     if (!gv) {
577         gv = (GV *)newSV(0);
578         gv_init(gv, stash, name, len, TRUE);
579     }
580     GvMULTI_on(gv);
581     if (ampable) {
582         ENTER;
583         oldcurcop = PL_curcop;
584         oldparser = PL_parser;
585         lex_start(NULL, NULL, 0);
586         oldcompcv = PL_compcv;
587         PL_compcv = NULL; /* Prevent start_subparse from setting
588                              CvOUTSIDE. */
589         oldsavestack_ix = start_subparse(FALSE,0);
590         cv = PL_compcv;
591     }
592     else {
593         /* Avoid calling newXS, as it calls us, and things start to
594            get hairy. */
595         cv = MUTABLE_CV(newSV_type(SVt_PVCV));
596         GvCV_set(gv,cv);
597         GvCVGEN(gv) = 0;
598         CvISXSUB_on(cv);
599         CvXSUB(cv) = core_xsub;
600         PoisonPADLIST(cv);
601     }
602     CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
603                          from PL_curcop. */
604     /* XSUBs can't be perl lang/perl5db.pl debugged
605     if (PERLDB_LINE_OR_SAVESRC)
606         (void)gv_fetchfile(file); */
607     CvFILE(cv) = (char *)file;
608     /* XXX This is inefficient, as doing things this order causes
609            a prototype check in newATTRSUB.  But we have to do
610            it this order as we need an op number before calling
611            new ATTRSUB. */
612     (void)core_prototype((SV *)cv, name, code, &opnum);
613     if (stash)
614         (void)hv_store(stash,name,len,(SV *)gv,0);
615     if (ampable) {
616 #ifdef DEBUGGING
617         CV *orig_cv = cv;
618 #endif
619         CvLVALUE_on(cv);
620         /* newATTRSUB will free the CV and return NULL if we're still
621            compiling after a syntax error */
622         if ((cv = newATTRSUB_x(
623                    oldsavestack_ix, (OP *)gv,
624                    NULL,NULL,
625                    coresub_op(
626                      opnum
627                        ? newSVuv((UV)opnum)
628                        : newSVpvn(name,len),
629                      code, opnum
630                    ),
631                    TRUE
632                )) != NULL) {
633             assert(GvCV(gv) == orig_cv);
634             if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
635                 && opnum != OP_UNDEF && opnum != OP_KEYS)
636                 CvLVALUE_off(cv); /* Now *that* was a neat trick. */
637         }
638         LEAVE;
639         PL_parser = oldparser;
640         PL_curcop = oldcurcop;
641         PL_compcv = oldcompcv;
642     }
643     if (cv) {
644         SV *opnumsv = newSViv(
645             (opnum == OP_ENTEREVAL && len == 9 && memEQ(name, "evalbytes", 9)) ?
646                 (OP_ENTEREVAL | (1<<16))
647             : opnum ? opnum : (((I32)name[2]) << 16));
648         cv_set_call_checker_flags(cv, Perl_ck_entersub_args_core, opnumsv, 0);
649         SvREFCNT_dec_NN(opnumsv);
650     }
651
652     return gv;
653 }
654
655 /*
656 =for apidoc gv_fetchmeth
657
658 Like L</gv_fetchmeth_pvn>, but lacks a flags parameter.
659
660 =for apidoc gv_fetchmeth_sv
661
662 Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form
663 of an SV instead of a string/length pair.
664
665 =cut
666 */
667
668 GV *
669 Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
670 {
671     char *namepv;
672     STRLEN namelen;
673     PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
674     if (LIKELY(SvPOK_nog(namesv))) /* common case */
675         return gv_fetchmeth_internal(stash, namesv, NULL, 0, level,
676                                      flags | SvUTF8(namesv));
677     namepv = SvPV(namesv, namelen);
678     if (SvUTF8(namesv)) flags |= SVf_UTF8;
679     return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
680 }
681
682 /*
683 =for apidoc gv_fetchmeth_pv
684
685 Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string 
686 instead of a string/length pair.
687
688 =cut
689 */
690
691 GV *
692 Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
693 {
694     PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
695     return gv_fetchmeth_internal(stash, NULL, name, strlen(name), level, flags);
696 }
697
698 /*
699 =for apidoc gv_fetchmeth_pvn
700
701 Returns the glob with the given C<name> and a defined subroutine or
702 C<NULL>.  The glob lives in the given C<stash>, or in the stashes
703 accessible via C<@ISA> and C<UNIVERSAL::>.
704
705 The argument C<level> should be either 0 or -1.  If C<level==0>, as a
706 side-effect creates a glob with the given C<name> in the given C<stash>
707 which in the case of success contains an alias for the subroutine, and sets
708 up caching info for this glob.
709
710 The only significant values for C<flags> are C<GV_SUPER>, C<GV_NOUNIVERSAL>, and
711 C<SVf_UTF8>.
712
713 C<GV_SUPER> indicates that we want to look up the method in the superclasses
714 of the C<stash>.
715
716 C<GV_NOUNIVERSAL> indicates that we do not want to look up the method in
717 the stash accessible by C<UNIVERSAL::>.
718
719 The
720 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
721 visible to Perl code.  So when calling C<call_sv>, you should not use
722 the GV directly; instead, you should use the method's CV, which can be
723 obtained from the GV with the C<GvCV> macro.
724
725 =for apidoc Amnh||GV_SUPER
726
727 =cut
728 */
729
730 /* NOTE: No support for tied ISA */
731
732 PERL_STATIC_INLINE GV*
733 S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, I32 level, U32 flags)
734 {
735     GV** gvp;
736     HE* he;
737     AV* linear_av;
738     SV** linear_svp;
739     SV* linear_sv;
740     HV* cstash, *cachestash;
741     GV* candidate = NULL;
742     CV* cand_cv = NULL;
743     GV* topgv = NULL;
744     const char *hvname;
745     STRLEN hvnamelen;
746     I32 create = (level >= 0) ? HV_FETCH_LVALUE : 0;
747     I32 items;
748     U32 topgen_cmp;
749     U32 is_utf8 = flags & SVf_UTF8;
750
751     /* UNIVERSAL methods should be callable without a stash */
752     if (!stash) {
753         create = 0;  /* probably appropriate */
754         if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
755             return 0;
756     }
757
758     assert(stash);
759
760     hvname = HvNAME_get(stash);
761     hvnamelen = HvNAMELEN_get(stash);
762     if (!hvname)
763       Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
764
765     assert(hvname);
766     assert(name || meth);
767
768     DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n",
769                       flags & GV_SUPER ? "SUPER " : "",
770                       name ? name : SvPV_nolen(meth), hvname) );
771
772     topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
773
774     if (flags & GV_SUPER) {
775         if (!HvAUX(stash)->xhv_mro_meta->super)
776             HvAUX(stash)->xhv_mro_meta->super = newHV();
777         cachestash = HvAUX(stash)->xhv_mro_meta->super;
778     }
779     else cachestash = stash;
780
781     /* check locally for a real method or a cache entry */
782     he = (HE*)hv_common(
783         cachestash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, create, NULL, 0
784     );
785     if (he) gvp = (GV**)&HeVAL(he);
786     else gvp = NULL;
787
788     if(gvp) {
789         topgv = *gvp;
790       have_gv:
791         assert(topgv);
792         if (SvTYPE(topgv) != SVt_PVGV)
793         {
794             if (!name)
795                 name = SvPV_nomg(meth, len);
796             gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
797         }
798         if ((cand_cv = GvCV(topgv))) {
799             /* If genuine method or valid cache entry, use it */
800             if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
801                 return topgv;
802             }
803             else {
804                 /* stale cache entry, junk it and move on */
805                 SvREFCNT_dec_NN(cand_cv);
806                 GvCV_set(topgv, NULL);
807                 cand_cv = NULL;
808                 GvCVGEN(topgv) = 0;
809             }
810         }
811         else if (GvCVGEN(topgv) == topgen_cmp) {
812             /* cache indicates no such method definitively */
813             return 0;
814         }
815         else if (stash == cachestash
816               && len > 1 /* shortest is uc */
817               && memEQs(hvname, HvNAMELEN_get(stash), "CORE")
818               && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
819             goto have_gv;
820     }
821
822     linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
823     linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
824     items = AvFILLp(linear_av); /* no +1, to skip over self */
825     while (items--) {
826         linear_sv = *linear_svp++;
827         assert(linear_sv);
828         cstash = gv_stashsv(linear_sv, 0);
829
830         if (!cstash) {
831             if ( ckWARN(WARN_SYNTAX)) {
832                 if(     /* these are loaded from Perl_Gv_AMupdate() one way or another */
833                            ( len    && name[0] == '(' )  /* overload.pm related, in particular "()" */
834                         || ( memEQs( name, len, "DESTROY") )
835                 ) {
836                      Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
837                             "Can't locate package %" SVf " for @%" HEKf "::ISA",
838                             SVfARG(linear_sv),
839                             HEKfARG(HvNAME_HEK(stash)));
840
841                 } else if( memEQs( name, len, "AUTOLOAD") ) {
842                     /* gobble this warning */
843                 } else {
844                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
845                         "While trying to resolve method call %.*s->%.*s()"
846                         " can not locate package \"%" SVf "\" yet it is mentioned in @%.*s::ISA"
847                         " (perhaps you forgot to load \"%" SVf "\"?)",
848                          (int) hvnamelen, hvname,
849                          (int) len, name,
850                         SVfARG(linear_sv),
851                          (int) hvnamelen, hvname,
852                          SVfARG(linear_sv));
853                 }
854             }
855             continue;
856         }
857
858         assert(cstash);
859
860         gvp = (GV**)hv_common(
861             cstash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, HV_FETCH_JUST_SV, NULL, 0
862         );
863         if (!gvp) {
864             if (len > 1 && HvNAMELEN_get(cstash) == 4) {
865                 const char *hvname = HvNAME(cstash); assert(hvname);
866                 if (strBEGINs(hvname, "CORE")
867                  && (candidate =
868                       S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
869                     ))
870                     goto have_candidate;
871             }
872             continue;
873         }
874         else candidate = *gvp;
875        have_candidate:
876         assert(candidate);
877         if (SvTYPE(candidate) != SVt_PVGV)
878             gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
879         if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
880             /*
881              * Found real method, cache method in topgv if:
882              *  1. topgv has no synonyms (else inheritance crosses wires)
883              *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
884              */
885             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
886                   CV *old_cv = GvCV(topgv);
887                   SvREFCNT_dec(old_cv);
888                   SvREFCNT_inc_simple_void_NN(cand_cv);
889                   GvCV_set(topgv, cand_cv);
890                   GvCVGEN(topgv) = topgen_cmp;
891             }
892             return candidate;
893         }
894     }
895
896     /* Check UNIVERSAL without caching */
897     if((level == 0 || level == -1) && !(flags & GV_NOUNIVERSAL)) {
898         candidate = gv_fetchmeth_internal(NULL, meth, name, len, 1,
899                                           flags &~GV_SUPER);
900         if(candidate) {
901             cand_cv = GvCV(candidate);
902             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
903                   CV *old_cv = GvCV(topgv);
904                   SvREFCNT_dec(old_cv);
905                   SvREFCNT_inc_simple_void_NN(cand_cv);
906                   GvCV_set(topgv, cand_cv);
907                   GvCVGEN(topgv) = topgen_cmp;
908             }
909             return candidate;
910         }
911     }
912
913     if (topgv && GvREFCNT(topgv) == 1) {
914         /* cache the fact that the method is not defined */
915         GvCVGEN(topgv) = topgen_cmp;
916     }
917
918     return 0;
919 }
920
921 GV *
922 Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
923 {
924     PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
925     return gv_fetchmeth_internal(stash, NULL, name, len, level, flags);
926 }
927
928 /*
929 =for apidoc gv_fetchmeth_autoload
930
931 This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags
932 parameter.
933
934 =for apidoc gv_fetchmeth_sv_autoload
935
936 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
937 of an SV instead of a string/length pair.
938
939 =cut
940 */
941
942 GV *
943 Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
944 {
945    char *namepv;
946    STRLEN namelen;
947    PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
948    namepv = SvPV(namesv, namelen);
949    if (SvUTF8(namesv))
950        flags |= SVf_UTF8;
951    return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
952 }
953
954 /*
955 =for apidoc gv_fetchmeth_pv_autoload
956
957 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
958 instead of a string/length pair.
959
960 =cut
961 */
962
963 GV *
964 Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
965 {
966     PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
967     return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
968 }
969
970 /*
971 =for apidoc gv_fetchmeth_pvn_autoload
972
973 Same as C<gv_fetchmeth_pvn()>, but looks for autoloaded subroutines too.
974 Returns a glob for the subroutine.
975
976 For an autoloaded subroutine without a GV, will create a GV even
977 if C<level < 0>.  For an autoloaded subroutine without a stub, C<GvCV()>
978 of the result may be zero.
979
980 Currently, the only significant value for C<flags> is C<SVf_UTF8>.
981
982 =cut
983 */
984
985 GV *
986 Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
987 {
988     GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
989
990     PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
991
992     if (!gv) {
993         CV *cv;
994         GV **gvp;
995
996         if (!stash)
997             return NULL;        /* UNIVERSAL::AUTOLOAD could cause trouble */
998         if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
999             return NULL;
1000         if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
1001             return NULL;
1002         cv = GvCV(gv);
1003         if (!(CvROOT(cv) || CvXSUB(cv)))
1004             return NULL;
1005         /* Have an autoload */
1006         if (level < 0)  /* Cannot do without a stub */
1007             gv_fetchmeth_pvn(stash, name, len, 0, flags);
1008         gvp = (GV**)hv_fetch(stash, name,
1009                         (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
1010         if (!gvp)
1011             return NULL;
1012         return *gvp;
1013     }
1014     return gv;
1015 }
1016
1017 /*
1018 =for apidoc gv_fetchmethod_autoload
1019
1020 Returns the glob which contains the subroutine to call to invoke the method
1021 on the C<stash>.  In fact in the presence of autoloading this may be the
1022 glob for "AUTOLOAD".  In this case the corresponding variable C<$AUTOLOAD> is
1023 already setup.
1024
1025 The third parameter of C<gv_fetchmethod_autoload> determines whether
1026 AUTOLOAD lookup is performed if the given method is not present: non-zero
1027 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
1028 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
1029 with a non-zero C<autoload> parameter.
1030
1031 These functions grant C<"SUPER"> token
1032 as a prefix of the method name.  Note
1033 that if you want to keep the returned glob for a long time, you need to
1034 check for it being "AUTOLOAD", since at the later time the call may load a
1035 different subroutine due to C<$AUTOLOAD> changing its value.  Use the glob
1036 created as a side effect to do this.
1037
1038 These functions have the same side-effects as C<gv_fetchmeth> with
1039 C<level==0>.  The warning against passing the GV returned by
1040 C<gv_fetchmeth> to C<call_sv> applies equally to these functions.
1041
1042 =cut
1043 */
1044
1045 GV *
1046 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
1047 {
1048     PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
1049
1050     return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
1051 }
1052
1053 GV *
1054 Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
1055 {
1056     char *namepv;
1057     STRLEN namelen;
1058     PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
1059     namepv = SvPV(namesv, namelen);
1060     if (SvUTF8(namesv))
1061        flags |= SVf_UTF8;
1062     return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
1063 }
1064
1065 GV *
1066 Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
1067 {
1068     PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
1069     return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
1070 }
1071
1072 GV *
1073 Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
1074 {
1075     const char * const origname = name;
1076     const char * const name_end = name + len;
1077     const char *last_separator = NULL;
1078     GV* gv;
1079     HV* ostash = stash;
1080     SV *const error_report = MUTABLE_SV(stash);
1081     const U32 autoload = flags & GV_AUTOLOAD;
1082     const U32 do_croak = flags & GV_CROAK;
1083     const U32 is_utf8  = flags & SVf_UTF8;
1084
1085     PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
1086
1087     if (SvTYPE(stash) < SVt_PVHV)
1088         stash = NULL;
1089     else {
1090         /* The only way stash can become NULL later on is if last_separator is set,
1091            which in turn means that there is no need for a SVt_PVHV case
1092            the error reporting code.  */
1093     }
1094
1095     {
1096         /* check if the method name is fully qualified or
1097          * not, and separate the package name from the actual
1098          * method name.
1099          *
1100          * leaves last_separator pointing to the beginning of the
1101          * last package separator (either ' or ::) or 0
1102          * if none was found.
1103          *
1104          * leaves name pointing at the beginning of the
1105          * method name.
1106          */
1107         const char *name_cursor = name;
1108         const char * const name_em1 = name_end - 1; /* name_end minus 1 */
1109         for (name_cursor = name; name_cursor < name_end ; name_cursor++) {
1110             if (*name_cursor == '\'') {
1111                 last_separator = name_cursor;
1112                 name = name_cursor + 1;
1113             }
1114             else if (name_cursor < name_em1 && *name_cursor == ':' && name_cursor[1] == ':') {
1115                 last_separator = name_cursor++;
1116                 name = name_cursor + 1;
1117             }
1118         }
1119     }
1120
1121     /* did we find a separator? */
1122     if (last_separator) {
1123         STRLEN sep_len= last_separator - origname;
1124         if ( memEQs(origname, sep_len, "SUPER")) {
1125             /* ->SUPER::method should really be looked up in original stash */
1126             stash = CopSTASH(PL_curcop);
1127             flags |= GV_SUPER;
1128             DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
1129                          origname, HvENAME_get(stash), name) );
1130         }
1131         else if ( sep_len >= 7 &&
1132                  strBEGINs(last_separator - 7, "::SUPER")) {
1133             /* don't autovifify if ->NoSuchStash::SUPER::method */
1134             stash = gv_stashpvn(origname, sep_len - 7, is_utf8);
1135             if (stash) flags |= GV_SUPER;
1136         }
1137         else {
1138             /* don't autovifify if ->NoSuchStash::method */
1139             stash = gv_stashpvn(origname, sep_len, is_utf8);
1140         }
1141         ostash = stash;
1142     }
1143
1144     gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
1145     if (!gv) {
1146         /* This is the special case that exempts Foo->import and
1147            Foo->unimport from being an error even if there's no
1148           import/unimport subroutine */
1149         if (strEQ(name,"import") || strEQ(name,"unimport")) {
1150             gv = (GV*)sv_2mortal((SV*)newCONSTSUB_flags(NULL,
1151                                                 NULL, 0, 0, NULL));
1152         } else if (autoload)
1153             gv = gv_autoload_pvn(
1154                 ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags
1155             );
1156         if (!gv && do_croak) {
1157             /* Right now this is exclusively for the benefit of S_method_common
1158                in pp_hot.c  */
1159             if (stash) {
1160                 /* If we can't find an IO::File method, it might be a call on
1161                  * a filehandle. If IO:File has not been loaded, try to
1162                  * require it first instead of croaking */
1163                 const char *stash_name = HvNAME_get(stash);
1164                 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
1165                     && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
1166                                        STR_WITH_LEN("IO/File.pm"), 0,
1167                                        HV_FETCH_ISEXISTS, NULL, 0)
1168                 ) {
1169                     require_pv("IO/File.pm");
1170                     gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
1171                     if (gv)
1172                         return gv;
1173                 }
1174                 Perl_croak(aTHX_
1175                            "Can't locate object method \"%" UTF8f
1176                            "\" via package \"%" HEKf "\"",
1177                                     UTF8fARG(is_utf8, name_end - name, name),
1178                                     HEKfARG(HvNAME_HEK(stash)));
1179             }
1180             else {
1181                 SV* packnamesv;
1182
1183                 if (last_separator) {
1184                     packnamesv = newSVpvn_flags(origname, last_separator - origname,
1185                                                     SVs_TEMP | is_utf8);
1186                 } else {
1187                     packnamesv = error_report;
1188                 }
1189
1190                 Perl_croak(aTHX_
1191                            "Can't locate object method \"%" UTF8f
1192                            "\" via package \"%" SVf "\""
1193                            " (perhaps you forgot to load \"%" SVf "\"?)",
1194                            UTF8fARG(is_utf8, name_end - name, name),
1195                            SVfARG(packnamesv), SVfARG(packnamesv));
1196             }
1197         }
1198     }
1199     else if (autoload) {
1200         CV* const cv = GvCV(gv);
1201         if (!CvROOT(cv) && !CvXSUB(cv)) {
1202             GV* stubgv;
1203             GV* autogv;
1204
1205             if (CvANON(cv) || CvLEXICAL(cv))
1206                 stubgv = gv;
1207             else {
1208                 stubgv = CvGV(cv);
1209                 if (GvCV(stubgv) != cv)         /* orphaned import */
1210                     stubgv = gv;
1211             }
1212             autogv = gv_autoload_pvn(GvSTASH(stubgv),
1213                                   GvNAME(stubgv), GvNAMELEN(stubgv),
1214                                   GV_AUTOLOAD_ISMETHOD
1215                                    | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
1216             if (autogv)
1217                 gv = autogv;
1218         }
1219     }
1220
1221     return gv;
1222 }
1223
1224 GV*
1225 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
1226 {
1227    char *namepv;
1228    STRLEN namelen;
1229    PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
1230    namepv = SvPV(namesv, namelen);
1231    if (SvUTF8(namesv))
1232        flags |= SVf_UTF8;
1233    return gv_autoload_pvn(stash, namepv, namelen, flags);
1234 }
1235
1236 GV*
1237 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
1238 {
1239    PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
1240    return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
1241 }
1242
1243 GV*
1244 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
1245 {
1246     GV* gv;
1247     CV* cv;
1248     HV* varstash;
1249     GV* vargv;
1250     SV* varsv;
1251     SV *packname = NULL;
1252     U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
1253
1254     PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
1255
1256     if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1257         return NULL;
1258     if (stash) {
1259         if (SvTYPE(stash) < SVt_PVHV) {
1260             STRLEN packname_len = 0;
1261             const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
1262             packname = newSVpvn_flags(packname_ptr, packname_len,
1263                                       SVs_TEMP | SvUTF8(stash));
1264             stash = NULL;
1265         }
1266         else
1267             packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
1268         if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
1269     }
1270     if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE,
1271                                 is_utf8 | (flags & GV_SUPER))))
1272         return NULL;
1273     cv = GvCV(gv);
1274
1275     if (!(CvROOT(cv) || CvXSUB(cv)))
1276         return NULL;
1277
1278     /*
1279      * Inheriting AUTOLOAD for non-methods no longer works
1280      */
1281     if (
1282         !(flags & GV_AUTOLOAD_ISMETHOD)
1283      && (GvCVGEN(gv) || GvSTASH(gv) != stash)
1284     )
1285         Perl_croak(aTHX_ "Use of inherited AUTOLOAD for non-method %" SVf
1286                          "::%" UTF8f "() is no longer allowed",
1287                          SVfARG(packname),
1288                          UTF8fARG(is_utf8, len, name));
1289
1290     if (CvISXSUB(cv)) {
1291         /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
1292          * and split that value on the last '::', pass along the same data
1293          * via the SvPVX field in the CV, and the stash in CvSTASH.
1294          *
1295          * Due to an unfortunate accident of history, the SvPVX field
1296          * serves two purposes.  It is also used for the subroutine's pro-
1297          * type.  Since SvPVX has been documented as returning the sub name
1298          * for a long time, but not as returning the prototype, we have
1299          * to preserve the SvPVX AUTOLOAD behaviour and put the prototype
1300          * elsewhere.
1301          *
1302          * We put the prototype in the same allocated buffer, but after
1303          * the sub name.  The SvPOK flag indicates the presence of a proto-
1304          * type.  The CvAUTOLOAD flag indicates the presence of a sub name.
1305          * If both flags are on, then SvLEN is used to indicate the end of
1306          * the prototype (artificially lower than what is actually allo-
1307          * cated), at the risk of having to reallocate a few bytes unneces-
1308          * sarily--but that should happen very rarely, if ever.
1309          *
1310          * We use SvUTF8 for both prototypes and sub names, so if one is
1311          * UTF8, the other must be upgraded.
1312          */
1313         CvSTASH_set(cv, stash);
1314         if (SvPOK(cv)) { /* Ouch! */
1315             SV * const tmpsv = newSVpvn_flags(name, len, is_utf8);
1316             STRLEN ulen;
1317             const char *proto = CvPROTO(cv);
1318             assert(proto);
1319             if (SvUTF8(cv))
1320                 sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
1321             ulen = SvCUR(tmpsv);
1322             SvCUR_set(tmpsv, SvCUR(tmpsv) + 1); /* include null in string */
1323             sv_catpvn_flags(
1324                 tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
1325             );
1326             SvTEMP_on(tmpsv); /* Allow theft */
1327             sv_setsv_nomg((SV *)cv, tmpsv);
1328             SvTEMP_off(tmpsv);
1329             SvREFCNT_dec_NN(tmpsv);
1330             SvLEN_set(cv, SvCUR(cv) + 1);
1331             SvCUR_set(cv, ulen);
1332         }
1333         else {
1334           sv_setpvn((SV *)cv, name, len);
1335           SvPOK_off(cv);
1336           if (is_utf8)
1337             SvUTF8_on(cv);
1338           else SvUTF8_off(cv);
1339         }
1340         CvAUTOLOAD_on(cv);
1341     }
1342
1343     /*
1344      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1345      * The subroutine's original name may not be "AUTOLOAD", so we don't
1346      * use that, but for lack of anything better we will use the sub's
1347      * original package to look up $AUTOLOAD.
1348      */
1349     varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv));
1350     vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1351     ENTER;
1352
1353     if (!isGV(vargv)) {
1354         gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
1355 #ifdef PERL_DONT_CREATE_GVSV
1356         GvSV(vargv) = newSV(0);
1357 #endif
1358     }
1359     LEAVE;
1360     varsv = GvSVn(vargv);
1361     SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
1362     /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
1363     sv_setsv(varsv, packname);
1364     sv_catpvs(varsv, "::");
1365     /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1366        tainting if $FOO::AUTOLOAD was previously tainted, but is not now.  */
1367     sv_catpvn_flags(
1368         varsv, name, len,
1369         SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
1370     );
1371     if (is_utf8)
1372         SvUTF8_on(varsv);
1373     return gv;
1374 }
1375
1376
1377 /* require_tie_mod() internal routine for requiring a module
1378  * that implements the logic of automatic ties like %! and %-
1379  * It loads the module and then calls the _tie_it subroutine
1380  * with the passed gv as an argument.
1381  *
1382  * The "gv" parameter should be the glob.
1383  * "varname" holds the 1-char name of the var, used for error messages.
1384  * "namesv" holds the module name. Its refcount will be decremented.
1385  * "flags": if flag & 1 then save the scalar before loading.
1386  * For the protection of $! to work (it is set by this routine)
1387  * the sv slot must already be magicalized.
1388  */
1389 STATIC void
1390 S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name,
1391                         STRLEN len, const U32 flags)
1392 {
1393     const SV * const target = varname == '[' ? GvSV(gv) : (SV *)GvHV(gv);
1394
1395     PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1396
1397     /* If it is not tied */
1398     if (!target || !SvRMAGICAL(target)
1399      || !mg_find(target,
1400                  varname == '[' ? PERL_MAGIC_tiedscalar : PERL_MAGIC_tied))
1401     {
1402       HV *stash;
1403       GV **gvp;
1404       dSP;
1405
1406       PUSHSTACKi(PERLSI_MAGIC);
1407       ENTER;
1408
1409 #define GET_HV_FETCH_TIE_FUNC                            \
1410     (  (gvp = (GV **)hv_fetchs(stash, "_tie_it", 0))      \
1411     && *gvp                                                \
1412     && (  (isGV(*gvp) && GvCV(*gvp))                        \
1413        || (SvROK(*gvp) && SvTYPE(SvRV(*gvp)) == SVt_PVCV)  ) \
1414     )
1415
1416       /* Load the module if it is not loaded.  */
1417       if (!(stash = gv_stashpvn(name, len, 0))
1418        || ! GET_HV_FETCH_TIE_FUNC)
1419       {
1420         SV * const module = newSVpvn(name, len);
1421         const char type = varname == '[' ? '$' : '%';
1422         if ( flags & 1 )
1423             save_scalar(gv);
1424         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1425         assert(sp == PL_stack_sp);
1426         stash = gv_stashpvn(name, len, 0);
1427         if (!stash)
1428             Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available",
1429                     type, varname, name);
1430         else if (! GET_HV_FETCH_TIE_FUNC)
1431             Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it",
1432                     type, varname, name);
1433       }
1434       /* Now call the tie function.  It should be in *gvp.  */
1435       assert(gvp); assert(*gvp);
1436       PUSHMARK(SP);
1437       XPUSHs((SV *)gv);
1438       PUTBACK;
1439       call_sv((SV *)*gvp, G_VOID|G_DISCARD);
1440       LEAVE;
1441       POPSTACK;
1442     }
1443 }
1444
1445 /* add a require_tie_mod_s - the _s suffix is similar to pvs type suffixes,
1446  * IOW it means we do STR_WITH_LEN() ourselves and the user should pass in
1447  * a true string WITHOUT a len.
1448  */
1449 #define require_tie_mod_s(gv, varname, name, flags) \
1450     S_require_tie_mod(aTHX_ gv, varname, STR_WITH_LEN(name), flags)
1451
1452 /*
1453 =for apidoc gv_stashpv
1454
1455 Returns a pointer to the stash for a specified package.  Uses C<strlen> to
1456 determine the length of C<name>, then calls C<gv_stashpvn()>.
1457
1458 =cut
1459 */
1460
1461 HV*
1462 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1463 {
1464     PERL_ARGS_ASSERT_GV_STASHPV;
1465     return gv_stashpvn(name, strlen(name), create);
1466 }
1467
1468 /*
1469 =for apidoc gv_stashpvn
1470
1471 Returns a pointer to the stash for a specified package.  The C<namelen>
1472 parameter indicates the length of the C<name>, in bytes.  C<flags> is passed
1473 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1474 created if it does not already exist.  If the package does not exist and
1475 C<flags> is 0 (or any other setting that does not create packages) then C<NULL>
1476 is returned.
1477
1478 Flags may be one of:
1479
1480  GV_ADD           Create and initialize the package if doesn't
1481                   already exist
1482  GV_NOADD_NOINIT  Don't create the package,
1483  GV_ADDMG         GV_ADD iff the GV is magical
1484  GV_NOINIT        GV_ADD, but don't initialize
1485  GV_NOEXPAND      Don't expand SvOK() entries to PVGV
1486  SVf_UTF8         The name is in UTF-8
1487
1488 The most important of which are probably C<GV_ADD> and C<SVf_UTF8>.
1489
1490 Note, use of C<gv_stashsv> instead of C<gv_stashpvn> where possible is strongly
1491 recommended for performance reasons.
1492
1493 =for apidoc Amnh||GV_ADD
1494 =for apidoc Amnh||GV_NOADD_NOINIT
1495 =for apidoc Amnh||GV_NOINIT
1496 =for apidoc Amnh||GV_NOEXPAND
1497 =for apidoc Amnh||GV_ADDMG
1498 =for apidoc Amnh||SVf_UTF8
1499
1500 =cut
1501 */
1502
1503 /*
1504 gv_stashpvn_internal
1505
1506 Perform the internal bits of gv_stashsvpvn_cached. You could think of this
1507 as being one half of the logic. Not to be called except from gv_stashsvpvn_cached().
1508
1509 */
1510
1511 PERL_STATIC_INLINE HV*
1512 S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags)
1513 {
1514     char smallbuf[128];
1515     char *tmpbuf;
1516     HV *stash;
1517     GV *tmpgv;
1518     U32 tmplen = namelen + 2;
1519
1520     PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL;
1521
1522     if (tmplen <= sizeof smallbuf)
1523         tmpbuf = smallbuf;
1524     else
1525         Newx(tmpbuf, tmplen, char);
1526     Copy(name, tmpbuf, namelen, char);
1527     tmpbuf[namelen]   = ':';
1528     tmpbuf[namelen+1] = ':';
1529     tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1530     if (tmpbuf != smallbuf)
1531         Safefree(tmpbuf);
1532     if (!tmpgv || !isGV_with_GP(tmpgv))
1533         return NULL;
1534     stash = GvHV(tmpgv);
1535     if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1536     assert(stash);
1537     if (!HvNAME_get(stash)) {
1538         hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1539         
1540         /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1541         /* If the containing stash has multiple effective
1542            names, see that this one gets them, too. */
1543         if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1544             mro_package_moved(stash, NULL, tmpgv, 1);
1545     }
1546     return stash;
1547 }
1548
1549 /*
1550 =for apidoc gv_stashsvpvn_cached
1551
1552 Returns a pointer to the stash for a specified package, possibly
1553 cached.  Implements both L<perlapi/C<gv_stashpvn>> and
1554 L<perlapi/C<gv_stashsv>>.
1555
1556 Requires one of either C<namesv> or C<namepv> to be non-null.
1557
1558 If the flag C<GV_CACHE_ONLY> is set, return the stash only if found in the
1559 cache; see L<perlapi/C<gv_stashpvn>> for details on the other C<flags>.
1560
1561 Note it is strongly preferred for C<namesv> to be non-null, for performance
1562 reasons.
1563
1564 =for apidoc Emnh||GV_CACHE_ONLY
1565
1566 =cut
1567 */
1568
1569 #define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \
1570     assert(namesv || name)
1571
1572 HV*
1573 Perl_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags)
1574 {
1575     HV* stash;
1576     HE* he;
1577
1578     PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED;
1579
1580     he = (HE *)hv_common(
1581         PL_stashcache, namesv, name, namelen,
1582         (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0
1583     );
1584
1585     if (he) {
1586         SV *sv = HeVAL(he);
1587         HV *hv;
1588         assert(SvIOK(sv));
1589         hv = INT2PTR(HV*, SvIVX(sv));
1590         assert(SvTYPE(hv) == SVt_PVHV);
1591         return hv;
1592     }
1593     else if (flags & GV_CACHE_ONLY) return NULL;
1594
1595     if (namesv) {
1596         if (SvOK(namesv)) { /* prevent double uninit warning */
1597             STRLEN len;
1598             name = SvPV_const(namesv, len);
1599             namelen = len;
1600             flags |= SvUTF8(namesv);
1601         } else {
1602             name = ""; namelen = 0;
1603         }
1604     }
1605     stash = gv_stashpvn_internal(name, namelen, flags);
1606
1607     if (stash && namelen) {
1608         SV* const ref = newSViv(PTR2IV(stash));
1609         (void)hv_store(PL_stashcache, name,
1610             (flags & SVf_UTF8) ? -(I32)namelen : (I32)namelen, ref, 0);
1611     }
1612
1613     return stash;
1614 }
1615
1616 HV*
1617 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1618 {
1619     PERL_ARGS_ASSERT_GV_STASHPVN;
1620     return gv_stashsvpvn_cached(NULL, name, namelen, flags);
1621 }
1622
1623 /*
1624 =for apidoc gv_stashsv
1625
1626 Returns a pointer to the stash for a specified package.  See
1627 C<L</gv_stashpvn>>.
1628
1629 Note this interface is strongly preferred over C<gv_stashpvn> for performance
1630 reasons.
1631
1632 =cut
1633 */
1634
1635 HV*
1636 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1637 {
1638     PERL_ARGS_ASSERT_GV_STASHSV;
1639     return gv_stashsvpvn_cached(sv, NULL, 0, flags);
1640 }
1641 GV *
1642 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 flags, const svtype sv_type) {
1643     PERL_ARGS_ASSERT_GV_FETCHPV;
1644     return gv_fetchpvn_flags(nambeg, strlen(nambeg), flags, sv_type);
1645 }
1646
1647 GV *
1648 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1649     STRLEN len;
1650     const char * const nambeg =
1651        SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1652     PERL_ARGS_ASSERT_GV_FETCHSV;
1653     return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1654 }
1655
1656 PERL_STATIC_INLINE void
1657 S_gv_magicalize_isa(pTHX_ GV *gv)
1658 {
1659     AV* av;
1660
1661     PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1662
1663     av = GvAVn(gv);
1664     GvMULTI_on(gv);
1665     sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1666              NULL, 0);
1667 }
1668
1669 /* This function grabs name and tries to split a stash and glob
1670  * from its contents. TODO better description, comments
1671  * 
1672  * If the function returns TRUE and 'name == name_end', then
1673  * 'gv' can be directly returned to the caller of gv_fetchpvn_flags
1674  */
1675 PERL_STATIC_INLINE bool
1676 S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name,
1677                STRLEN *len, const char *nambeg, STRLEN full_len,
1678                const U32 is_utf8, const I32 add)
1679 {
1680     char *tmpfullbuf = NULL; /* only malloc one big chunk of memory when the smallbuff is not large enough */
1681     const char *name_cursor;
1682     const char *const name_end = nambeg + full_len;
1683     const char *const name_em1 = name_end - 1;
1684     char smallbuf[64]; /* small buffer to avoid a malloc when possible */
1685
1686     PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME;
1687     
1688     if (   full_len > 2
1689         && **name == '*'
1690         && isIDFIRST_lazy_if_safe(*name + 1, name_end, is_utf8))
1691     {
1692         /* accidental stringify on a GV? */
1693         (*name)++;
1694     }
1695
1696     for (name_cursor = *name; name_cursor < name_end; name_cursor++) {
1697         if (name_cursor < name_em1 &&
1698             ((*name_cursor == ':' && name_cursor[1] == ':')
1699            || *name_cursor == '\''))
1700         {
1701             if (!*stash)
1702                 *stash = PL_defstash;
1703             if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */
1704                 goto notok;
1705
1706             *len = name_cursor - *name;
1707             if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1708                 const char *key;
1709                 GV**gvp;
1710                 if (*name_cursor == ':') {
1711                     key = *name;
1712                     *len += 2;
1713                 }
1714                 else { /* using ' for package separator */
1715                     /* use our pre-allocated buffer when possible to save a malloc */
1716                     char *tmpbuf;
1717                     if ( *len+2 <= sizeof smallbuf)
1718                         tmpbuf = smallbuf;
1719                     else {
1720                         /* only malloc once if needed */
1721                         if (tmpfullbuf == NULL) /* only malloc&free once, a little more than needed */
1722                             Newx(tmpfullbuf, full_len+2, char);
1723                         tmpbuf = tmpfullbuf;
1724                     }
1725                     Copy(*name, tmpbuf, *len, char);
1726                     tmpbuf[(*len)++] = ':';
1727                     tmpbuf[(*len)++] = ':';
1728                     key = tmpbuf;
1729                 }
1730                 gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add);
1731                 *gv = gvp ? *gvp : NULL;
1732                 if (!*gv || *gv == (const GV *)&PL_sv_undef) {
1733                     goto notok;
1734                 }
1735                 /* here we know that *gv && *gv != &PL_sv_undef */
1736                 if (SvTYPE(*gv) != SVt_PVGV)
1737                     gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8);
1738                 else
1739                     GvMULTI_on(*gv);
1740
1741                 if (!(*stash = GvHV(*gv))) {
1742                     *stash = GvHV(*gv) = newHV();
1743                     if (!HvNAME_get(*stash)) {
1744                         if (GvSTASH(*gv) == PL_defstash && *len == 6
1745                             && strBEGINs(*name, "CORE"))
1746                             hv_name_sets(*stash, "CORE", 0);
1747                         else
1748                             hv_name_set(
1749                                 *stash, nambeg, name_cursor-nambeg, is_utf8
1750                             );
1751                     /* If the containing stash has multiple effective
1752                     names, see that this one gets them, too. */
1753                     if (HvAUX(GvSTASH(*gv))->xhv_name_count)
1754                         mro_package_moved(*stash, NULL, *gv, 1);
1755                     }
1756                 }
1757                 else if (!HvNAME_get(*stash))
1758                     hv_name_set(*stash, nambeg, name_cursor - nambeg, is_utf8);
1759             }
1760
1761             if (*name_cursor == ':')
1762                 name_cursor++;
1763             *name = name_cursor+1;
1764             if (*name == name_end) {
1765                 if (!*gv) {
1766                     *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1767                     if (SvTYPE(*gv) != SVt_PVGV) {
1768                         gv_init_pvn(*gv, PL_defstash, "main::", 6,
1769                                     GV_ADDMULTI);
1770                         GvHV(*gv) =
1771                             MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
1772                     }
1773                 }
1774                 goto ok;
1775             }
1776         }
1777     }
1778     *len = name_cursor - *name;
1779   ok:
1780     Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
1781     return TRUE;
1782   notok:
1783     Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
1784     return FALSE;
1785 }
1786
1787
1788 /* Checks if an unqualified name is in the main stash */
1789 PERL_STATIC_INLINE bool
1790 S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8)
1791 {
1792     PERL_ARGS_ASSERT_GV_IS_IN_MAIN;
1793     
1794     /* If it's an alphanumeric variable */
1795     if ( len && isIDFIRST_lazy_if_safe(name, name + len, is_utf8) ) {
1796         /* Some "normal" variables are always in main::,
1797          * like INC or STDOUT.
1798          */
1799         switch (len) {
1800             case 1:
1801             if (*name == '_')
1802                 return TRUE;
1803             break;
1804             case 3:
1805             if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1806                 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1807                 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1808                 return TRUE;
1809             break;
1810             case 4:
1811             if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1812                 && name[3] == 'V')
1813                 return TRUE;
1814             break;
1815             case 5:
1816             if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1817                 && name[3] == 'I' && name[4] == 'N')
1818                 return TRUE;
1819             break;
1820             case 6:
1821             if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1822                 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1823                     ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1824                 return TRUE;
1825             break;
1826             case 7:
1827             if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1828                 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1829                 && name[6] == 'T')
1830                 return TRUE;
1831             break;
1832         }
1833     }
1834     /* *{""}, or a special variable like $@ */
1835     else
1836         return TRUE;
1837     
1838     return FALSE;
1839 }
1840
1841
1842 /* This function is called if parse_gv_stash_name() failed to
1843  * find a stash, or if GV_NOTQUAL or an empty name was passed
1844  * to gv_fetchpvn_flags.
1845  * 
1846  * It returns FALSE if the default stash can't be found nor created,
1847  * which might happen during global destruction.
1848  */
1849 PERL_STATIC_INLINE bool
1850 S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len,
1851                const U32 is_utf8, const I32 add,
1852                const svtype sv_type)
1853 {
1854     PERL_ARGS_ASSERT_FIND_DEFAULT_STASH;
1855     
1856     /* No stash in name, so see how we can default */
1857
1858     if ( gv_is_in_main(name, len, is_utf8) ) {
1859         *stash = PL_defstash;
1860     }
1861     else {
1862         if (IN_PERL_COMPILETIME) {
1863             *stash = PL_curstash;
1864             if (add && (PL_hints & HINT_STRICT_VARS) &&
1865                 sv_type != SVt_PVCV &&
1866                 sv_type != SVt_PVGV &&
1867                 sv_type != SVt_PVFM &&
1868                 sv_type != SVt_PVIO &&
1869                 !(len == 1 && sv_type == SVt_PV &&
1870                 (*name == 'a' || *name == 'b')) )
1871             {
1872                 GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -(I32)len : (I32)len,0);
1873                 if (!gvp || *gvp == (const GV *)&PL_sv_undef ||
1874                     SvTYPE(*gvp) != SVt_PVGV)
1875                 {
1876                     *stash = NULL;
1877                 }
1878                 else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
1879                          (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1880                          (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1881                 {
1882                     /* diag_listed_as: Variable "%s" is not imported%s */
1883                     Perl_ck_warner_d(
1884                         aTHX_ packWARN(WARN_MISC),
1885                         "Variable \"%c%" UTF8f "\" is not imported",
1886                         sv_type == SVt_PVAV ? '@' :
1887                         sv_type == SVt_PVHV ? '%' : '$',
1888                         UTF8fARG(is_utf8, len, name));
1889                     if (GvCVu(*gvp))
1890                         Perl_ck_warner_d(
1891                             aTHX_ packWARN(WARN_MISC),
1892                             "\t(Did you mean &%" UTF8f " instead?)\n",
1893                             UTF8fARG(is_utf8, len, name)
1894                         );
1895                     *stash = NULL;
1896                 }
1897             }
1898         }
1899         else {
1900             /* Use the current op's stash */
1901             *stash = CopSTASH(PL_curcop);
1902         }
1903     }
1904
1905     if (!*stash) {
1906         if (add && !PL_in_clean_all) {
1907             GV *gv;
1908             qerror(Perl_mess(aTHX_
1909                  "Global symbol \"%s%" UTF8f
1910                  "\" requires explicit package name (did you forget to "
1911                  "declare \"my %s%" UTF8f "\"?)",
1912                  (sv_type == SVt_PV ? "$"
1913                   : sv_type == SVt_PVAV ? "@"
1914                   : sv_type == SVt_PVHV ? "%"
1915                   : ""), UTF8fARG(is_utf8, len, name),
1916                  (sv_type == SVt_PV ? "$"
1917                   : sv_type == SVt_PVAV ? "@"
1918                   : sv_type == SVt_PVHV ? "%"
1919                   : ""), UTF8fARG(is_utf8, len, name)));
1920             /* To maintain the output of errors after the strict exception
1921              * above, and to keep compat with older releases, rather than
1922              * placing the variables in the pad, we place
1923              * them in the <none>:: stash.
1924              */
1925             gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1926             if (!gv) {
1927                 /* symbol table under destruction */
1928                 return FALSE;
1929             }
1930             *stash = GvHV(gv);
1931         }
1932         else
1933             return FALSE;
1934     }
1935
1936     if (!SvREFCNT(*stash))   /* symbol table under destruction */
1937         return FALSE;
1938
1939     return TRUE;
1940 }
1941
1942 /* gv_magicalize only turns on the SVf_READONLY flag, not SVf_PROTECT.  So
1943    redefine SvREADONLY_on for that purpose.  We don’t use it later on in
1944    this file.  */
1945 #undef SvREADONLY_on
1946 #define SvREADONLY_on(sv) (SvFLAGS(sv) |= SVf_READONLY)
1947
1948 /* gv_magicalize() is called by gv_fetchpvn_flags when creating
1949  * a new GV.
1950  * Note that it does not insert the GV into the stash prior to
1951  * magicalization, which some variables require need in order
1952  * to work (like %+, %-, %!), so callers must take care of
1953  * that.
1954  * 
1955  * It returns true if the gv did turn out to be magical one; i.e.,
1956  * if gv_magicalize actually did something.
1957  */
1958 PERL_STATIC_INLINE bool
1959 S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
1960                       const svtype sv_type)
1961 {
1962     SSize_t paren;
1963
1964     PERL_ARGS_ASSERT_GV_MAGICALIZE;
1965     
1966     if (stash != PL_defstash) { /* not the main stash */
1967         /* We only have to check for a few names here: a, b, EXPORT, ISA
1968            and VERSION. All the others apply only to the main stash or to
1969            CORE (which is checked right after this). */
1970         if (len) {
1971             switch (*name) {
1972             case 'E':
1973                 if (
1974                     len >= 6 && name[1] == 'X' &&
1975                     (memEQs(name, len, "EXPORT")
1976                     ||memEQs(name, len, "EXPORT_OK")
1977                     ||memEQs(name, len, "EXPORT_FAIL")
1978                     ||memEQs(name, len, "EXPORT_TAGS"))
1979                 )
1980                     GvMULTI_on(gv);
1981                 break;
1982             case 'I':
1983                 if (memEQs(name, len, "ISA"))
1984                     gv_magicalize_isa(gv);
1985                 break;
1986             case 'V':
1987                 if (memEQs(name, len, "VERSION"))
1988                     GvMULTI_on(gv);
1989                 break;
1990             case 'a':
1991                 if (stash == PL_debstash && memEQs(name, len, "args")) {
1992                     GvMULTI_on(gv_AVadd(gv));
1993                     break;
1994                 }
1995                 /* FALLTHROUGH */
1996             case 'b':
1997                 if (len == 1 && sv_type == SVt_PV)
1998                     GvMULTI_on(gv);
1999                 /* FALLTHROUGH */
2000             default:
2001                 goto try_core;
2002             }
2003             goto ret;
2004         }
2005       try_core:
2006         if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
2007           /* Avoid null warning: */
2008           const char * const stashname = HvNAME(stash); assert(stashname);
2009           if (strBEGINs(stashname, "CORE"))
2010             S_maybe_add_coresub(aTHX_ 0, gv, name, len);
2011         }
2012     }
2013     else if (len > 1) {
2014 #ifndef EBCDIC
2015         if (*name > 'V' ) {
2016             NOOP;
2017             /* Nothing else to do.
2018                The compiler will probably turn the switch statement into a
2019                branch table. Make sure we avoid even that small overhead for
2020                the common case of lower case variable names.  (On EBCDIC
2021                platforms, we can't just do:
2022                  if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) {
2023                because cases like '\027' in the switch statement below are
2024                C1 (non-ASCII) controls on those platforms, so the remapping
2025                would make them larger than 'V')
2026              */
2027         } else
2028 #endif
2029         {
2030             switch (*name) {
2031             case 'A':
2032                 if (memEQs(name, len, "ARGV")) {
2033                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
2034                 }
2035                 else if (memEQs(name, len, "ARGVOUT")) {
2036                     GvMULTI_on(gv);
2037                 }
2038                 break;
2039             case 'E':
2040                 if (
2041                     len >= 6 && name[1] == 'X' &&
2042                     (memEQs(name, len, "EXPORT")
2043                     ||memEQs(name, len, "EXPORT_OK")
2044                     ||memEQs(name, len, "EXPORT_FAIL")
2045                     ||memEQs(name, len, "EXPORT_TAGS"))
2046                 )
2047                     GvMULTI_on(gv);
2048                 break;
2049             case 'I':
2050                 if (memEQs(name, len, "ISA")) {
2051                     gv_magicalize_isa(gv);
2052                 }
2053                 break;
2054             case 'S':
2055                 if (memEQs(name, len, "SIG")) {
2056                     HV *hv;
2057                     I32 i;
2058                     if (!PL_psig_name) {
2059                         Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
2060                         Newxz(PL_psig_pend, SIG_SIZE, int);
2061                         PL_psig_ptr = PL_psig_name + SIG_SIZE;
2062                     } else {
2063                         /* I think that the only way to get here is to re-use an
2064                            embedded perl interpreter, where the previous
2065                            use didn't clean up fully because
2066                            PL_perl_destruct_level was 0. I'm not sure that we
2067                            "support" that, in that I suspect in that scenario
2068                            there are sufficient other garbage values left in the
2069                            interpreter structure that something else will crash
2070                            before we get here. I suspect that this is one of
2071                            those "doctor, it hurts when I do this" bugs.  */
2072                         Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
2073                         Zero(PL_psig_pend, SIG_SIZE, int);
2074                     }
2075                     GvMULTI_on(gv);
2076                     hv = GvHVn(gv);
2077                     hv_magic(hv, NULL, PERL_MAGIC_sig);
2078                     for (i = 1; i < SIG_SIZE; i++) {
2079                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
2080                         if (init)
2081                             sv_setsv(*init, &PL_sv_undef);
2082                     }
2083                 }
2084                 break;
2085             case 'V':
2086                 if (memEQs(name, len, "VERSION"))
2087                     GvMULTI_on(gv);
2088                 break;
2089             case '\003':        /* $^CHILD_ERROR_NATIVE */
2090                 if (memEQs(name, len, "\003HILD_ERROR_NATIVE"))
2091                     goto magicalize;
2092                                 /* @{^CAPTURE} %{^CAPTURE} */
2093                 if (memEQs(name, len, "\003APTURE")) {
2094                     AV* const av = GvAVn(gv);
2095                     const Size_t n = *name;
2096
2097                     sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
2098                     SvREADONLY_on(av);
2099
2100                     require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
2101
2102                 } else          /* %{^CAPTURE_ALL} */
2103                 if (memEQs(name, len, "\003APTURE_ALL")) {
2104                     require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
2105                 }
2106                 break;
2107             case '\005':        /* $^ENCODING */
2108                 if (memEQs(name, len, "\005NCODING"))
2109                     goto magicalize;
2110                 break;
2111             case '\007':        /* $^GLOBAL_PHASE */
2112                 if (memEQs(name, len, "\007LOBAL_PHASE"))
2113                     goto ro_magicalize;
2114                 break;
2115             case '\014':        /* $^LAST_FH */
2116                 if (memEQs(name, len, "\014AST_FH"))
2117                     goto ro_magicalize;
2118                 break;
2119             case '\015':        /* $^MATCH */
2120                 if (memEQs(name, len, "\015ATCH")) {
2121                     paren = RX_BUFF_IDX_CARET_FULLMATCH;
2122                     goto storeparen;
2123                 }
2124                 break;
2125             case '\017':        /* $^OPEN */
2126                 if (memEQs(name, len, "\017PEN"))
2127                     goto magicalize;
2128                 break;
2129             case '\020':        /* $^PREMATCH  $^POSTMATCH */
2130                 if (memEQs(name, len, "\020REMATCH")) {
2131                     paren = RX_BUFF_IDX_CARET_PREMATCH;
2132                     goto storeparen;
2133                 }
2134                 if (memEQs(name, len, "\020OSTMATCH")) {
2135                     paren = RX_BUFF_IDX_CARET_POSTMATCH;
2136                     goto storeparen;
2137                 }
2138                 break;
2139             case '\023':
2140                 if (memEQs(name, len, "\023AFE_LOCALES"))
2141                     goto ro_magicalize;
2142                 break;
2143             case '\024':        /* ${^TAINT} */
2144                 if (memEQs(name, len, "\024AINT"))
2145                     goto ro_magicalize;
2146                 break;
2147             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
2148                 if (memEQs(name, len, "\025NICODE"))
2149                     goto ro_magicalize;
2150                 if (memEQs(name, len, "\025TF8LOCALE"))
2151                     goto ro_magicalize;
2152                 if (memEQs(name, len, "\025TF8CACHE"))
2153                     goto magicalize;
2154                 break;
2155             case '\027':        /* $^WARNING_BITS */
2156                 if (memEQs(name, len, "\027ARNING_BITS"))
2157                     goto magicalize;
2158 #ifdef WIN32
2159                 else if (memEQs(name, len, "\027IN32_SLOPPY_STAT"))
2160                     goto magicalize;
2161 #endif
2162                 break;
2163             case '1':
2164             case '2':
2165             case '3':
2166             case '4':
2167             case '5':
2168             case '6':
2169             case '7':
2170             case '8':
2171             case '9':
2172             {
2173                 /* Ensures that we have an all-digit variable, ${"1foo"} fails
2174                    this test  */
2175                 UV uv;
2176                 if (!grok_atoUV(name, &uv, NULL) || uv > I32_MAX)
2177                     goto ret;
2178                 /* XXX why are we using a SSize_t? */
2179                 paren = (SSize_t)(I32)uv;
2180                 goto storeparen;
2181             }
2182             }
2183         }
2184     } else {
2185         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
2186            be case '\0' in this switch statement (ie a default case)  */
2187         switch (*name) {
2188         case '&':               /* $& */
2189             paren = RX_BUFF_IDX_FULLMATCH;
2190             goto sawampersand;
2191         case '`':               /* $` */
2192             paren = RX_BUFF_IDX_PREMATCH;
2193             goto sawampersand;
2194         case '\'':              /* $' */
2195             paren = RX_BUFF_IDX_POSTMATCH;
2196         sawampersand:
2197 #ifdef PERL_SAWAMPERSAND
2198             if (!(
2199                 sv_type == SVt_PVAV ||
2200                 sv_type == SVt_PVHV ||
2201                 sv_type == SVt_PVCV ||
2202                 sv_type == SVt_PVFM ||
2203                 sv_type == SVt_PVIO
2204                 )) { PL_sawampersand |=
2205                         (*name == '`')
2206                             ? SAWAMPERSAND_LEFT
2207                             : (*name == '&')
2208                                 ? SAWAMPERSAND_MIDDLE
2209                                 : SAWAMPERSAND_RIGHT;
2210                 }
2211 #endif
2212             goto storeparen;
2213         case '1':               /* $1 */
2214         case '2':               /* $2 */
2215         case '3':               /* $3 */
2216         case '4':               /* $4 */
2217         case '5':               /* $5 */
2218         case '6':               /* $6 */
2219         case '7':               /* $7 */
2220         case '8':               /* $8 */
2221         case '9':               /* $9 */
2222             paren = *name - '0';
2223
2224         storeparen:
2225             /* Flag the capture variables with a NULL mg_ptr
2226                Use mg_len for the array index to lookup.  */
2227             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren);
2228             break;
2229
2230         case ':':               /* $: */
2231             sv_setpv(GvSVn(gv),PL_chopset);
2232             goto magicalize;
2233
2234         case '?':               /* $? */
2235 #ifdef COMPLEX_STATUS
2236             SvUPGRADE(GvSVn(gv), SVt_PVLV);
2237 #endif
2238             goto magicalize;
2239
2240         case '!':               /* $! */
2241             GvMULTI_on(gv);
2242             /* If %! has been used, automatically load Errno.pm. */
2243
2244             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2245
2246             /* magicalization must be done before require_tie_mod_s is called */
2247             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2248                 require_tie_mod_s(gv, '!', "Errno", 1);
2249
2250             break;
2251         case '-':               /* $-, %-, @- */
2252         case '+':               /* $+, %+, @+ */
2253             GvMULTI_on(gv); /* no used once warnings here */
2254             {   /* $- $+ */
2255                 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2256                 if (*name == '+')
2257                     SvREADONLY_on(GvSVn(gv));
2258             }
2259             {   /* %- %+ */
2260                 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2261                     require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture",0);
2262             }
2263             {   /* @- @+ */
2264                 AV* const av = GvAVn(gv);
2265                 const Size_t n = *name;
2266
2267                 sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
2268                 SvREADONLY_on(av);
2269             }
2270             break;
2271         case '*':               /* $* */
2272         case '#':               /* $# */
2273         if (sv_type == SVt_PV)
2274             /* diag_listed_as: $* is no longer supported as of Perl 5.30 */
2275             Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name);
2276         break;
2277         case '\010':    /* $^H */
2278             {
2279                 HV *const hv = GvHVn(gv);
2280                 hv_magic(hv, NULL, PERL_MAGIC_hints);
2281             }
2282             goto magicalize;
2283         case '\023':    /* $^S */
2284         ro_magicalize:
2285             SvREADONLY_on(GvSVn(gv));
2286             /* FALLTHROUGH */
2287         case '0':               /* $0 */
2288         case '^':               /* $^ */
2289         case '~':               /* $~ */
2290         case '=':               /* $= */
2291         case '%':               /* $% */
2292         case '.':               /* $. */
2293         case '(':               /* $( */
2294         case ')':               /* $) */
2295         case '<':               /* $< */
2296         case '>':               /* $> */
2297         case '\\':              /* $\ */
2298         case '/':               /* $/ */
2299         case '|':               /* $| */
2300         case '$':               /* $$ */
2301         case '[':               /* $[ */
2302         case '\001':    /* $^A */
2303         case '\003':    /* $^C */
2304         case '\004':    /* $^D */
2305         case '\005':    /* $^E */
2306         case '\006':    /* $^F */
2307         case '\011':    /* $^I, NOT \t in EBCDIC */
2308         case '\016':    /* $^N */
2309         case '\017':    /* $^O */
2310         case '\020':    /* $^P */
2311         case '\024':    /* $^T */
2312         case '\027':    /* $^W */
2313         magicalize:
2314             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2315             break;
2316
2317         case '\014':    /* $^L */
2318             sv_setpvs(GvSVn(gv),"\f");
2319             break;
2320         case ';':               /* $; */
2321             sv_setpvs(GvSVn(gv),"\034");
2322             break;
2323         case ']':               /* $] */
2324         {
2325             SV * const sv = GvSV(gv);
2326             if (!sv_derived_from(PL_patchlevel, "version"))
2327                 upg_version(PL_patchlevel, TRUE);
2328             GvSV(gv) = vnumify(PL_patchlevel);
2329             SvREADONLY_on(GvSV(gv));
2330             SvREFCNT_dec(sv);
2331         }
2332         break;
2333         case '\026':    /* $^V */
2334         {
2335             SV * const sv = GvSV(gv);
2336             GvSV(gv) = new_version(PL_patchlevel);
2337             SvREADONLY_on(GvSV(gv));
2338             SvREFCNT_dec(sv);
2339         }
2340         break;
2341         case 'a':
2342         case 'b':
2343             if (sv_type == SVt_PV)
2344                 GvMULTI_on(gv);
2345         }
2346     }
2347
2348    ret:
2349     /* Return true if we actually did something.  */
2350     return GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv)
2351         || ( GvSV(gv) && (
2352                            SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv))
2353                          )
2354            );
2355 }
2356
2357 /* If we do ever start using this later on in the file, we need to make
2358    sure we don’t accidentally use the wrong definition.  */
2359 #undef SvREADONLY_on
2360
2361 /* This function is called when the stash already holds the GV of the magic
2362  * variable we're looking for, but we need to check that it has the correct
2363  * kind of magic.  For example, if someone first uses $! and then %!, the
2364  * latter would end up here, and we add the Errno tie to the HASH slot of
2365  * the *! glob.
2366  */
2367 PERL_STATIC_INLINE void
2368 S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
2369 {
2370     PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV;
2371
2372     if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
2373         if (*name == '!')
2374             require_tie_mod_s(gv, '!', "Errno", 1);
2375         else if (*name == '-' || *name == '+')
2376             require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture", 0);
2377     } else if (sv_type == SVt_PV) {
2378         if (*name == '*' || *name == '#') {
2379             /* diag_listed_as: $* is no longer supported as of Perl 5.30 */
2380             Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name);
2381         }
2382     }
2383     if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
2384       switch (*name) {
2385 #ifdef PERL_SAWAMPERSAND
2386       case '`':
2387           PL_sawampersand |= SAWAMPERSAND_LEFT;
2388           (void)GvSVn(gv);
2389           break;
2390       case '&':
2391           PL_sawampersand |= SAWAMPERSAND_MIDDLE;
2392           (void)GvSVn(gv);
2393           break;
2394       case '\'':
2395           PL_sawampersand |= SAWAMPERSAND_RIGHT;
2396           (void)GvSVn(gv);
2397           break;
2398 #endif
2399       }
2400     }
2401 }
2402
2403 /*
2404 =for apidoc gv_fetchpv
2405 =for apidoc_item |GV *|gv_fetchpvn|const char * nambeg|STRLEN full_len|I32 flags|const svtype sv_type
2406 =for apidoc_item ||gv_fetchpvn_flags
2407 =for apidoc_item |GV *|gv_fetchpvs|"name"|I32 flags|const svtype sv_type
2408 =for apidoc_item ||gv_fetchsv
2409 =for apidoc_item |GV *|gv_fetchsv_nomg|SV *name|I32 flags|const svtype sv_type
2410
2411 These all return the GV of type C<sv_type> whose name is given by the inputs,
2412 or NULL if no GV of that name and type could be found.  See L<perlguts/Stashes
2413 and Globs>.
2414
2415 The only differences are how the input name is specified, and if 'get' magic is
2416 normally used in getting that name.
2417
2418 Don't be fooled by the fact that only one form has C<flags> in its name.  They
2419 all have a C<flags> parameter in fact, and all the flag bits have the same
2420 meanings for all
2421
2422 If any of the flags C<GV_ADD>, C<GV_ADDMG>, C<GV_ADDWARN>, C<GV_ADDMULTI>, or
2423 C<GV_NOINIT> is set, a GV is created if none already exists for the input name
2424 and type.  However, C<GV_ADDMG> will only do the creation for magical GV's.
2425 For all of these flags except C<GV_NOINIT>, C<L</gv_init_pvn>> is called after
2426 the addition.  C<GV_ADDWARN> is used when the caller expects that adding won't
2427 be necessary because the symbol should already exist; but if not, add it
2428 anyway, with a warning that it was unexpectedly absent.  The C<GV_ADDMULTI>
2429 flag means to pretend that the GV has been seen before (I<i.e.>, suppress "Used
2430 once" warnings).
2431
2432 The flag C<GV_NOADD_NOINIT> causes C<L</gv_init_pvn>> not be to called if the
2433 GV existed but isn't PVGV.
2434
2435 If the C<SVf_UTF8> bit is set, the name is treated as being encoded in UTF-8;
2436 otherwise the name won't be considered to be UTF-8 in the C<pv>-named forms,
2437 and the UTF-8ness of the underlying SVs will be used in the C<sv> forms.
2438
2439 If the flag C<GV_NOTQUAL> is set, the caller warrants that the input name is a
2440 plain symbol name, not qualified with a package, otherwise the name is checked
2441 for being a qualified one.
2442
2443 In C<gv_fetchpv>, C<nambeg> is a C string, NUL-terminated with no intermediate
2444 NULs.
2445
2446 In C<gv_fetchpvs>, C<name> is a literal C string, hence is enclosed in
2447 double quotes.
2448
2449 C<gv_fetchpvn> and C<gv_fetchpvn_flags> are identical.  In these, <nambeg> is
2450 a Perl string whose byte length is given by C<full_len>, and may contain
2451 embedded NULs.
2452
2453 In C<gv_fetchsv> and C<gv_fetchsv_nomg>, the name is extracted from the PV of
2454 the input C<name> SV.  The only difference between these two forms is that
2455 'get' magic is normally done on C<name> in C<gv_fetchsv>, and always skipped
2456 with C<gv_fetchsv_nomg>.  Including C<GV_NO_SVGMAGIC> in the C<flags> parameter
2457 to C<gv_fetchsv> makes it behave identically to C<gv_fetchsv_nomg>.
2458
2459 =for apidoc Amnh||GV_ADD
2460 =for apidoc Amnh||GV_ADDMG
2461 =for apidoc Amnh||GV_ADDMULTI
2462 =for apidoc Amnh||GV_ADDWARN
2463 =for apidoc Amnh||GV_NOADD_NOINIT
2464 =for apidoc Amnh||GV_NOINIT
2465 =for apidoc Amnh||GV_NOTQUAL
2466 =for apidoc Amnh||GV_NO_SVGMAGIC
2467 =for apidoc Amnh||SVf_UTF8
2468
2469 =cut
2470 */
2471
2472 GV *
2473 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
2474                        const svtype sv_type)
2475 {
2476     const char *name = nambeg;
2477     GV *gv = NULL;
2478     GV**gvp;
2479     STRLEN len;
2480     HV *stash = NULL;
2481     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
2482     const I32 no_expand = flags & GV_NOEXPAND;
2483     const I32 add = flags & ~GV_NOADD_MASK;
2484     const U32 is_utf8 = flags & SVf_UTF8;
2485     bool addmg = cBOOL(flags & GV_ADDMG);
2486     const char *const name_end = nambeg + full_len;
2487     U32 faking_it;
2488
2489     PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
2490
2491      /* If we have GV_NOTQUAL, the caller promised that
2492       * there is no stash, so we can skip the check.
2493       * Similarly if full_len is 0, since then we're
2494       * dealing with something like *{""} or ""->foo()
2495       */
2496     if ((flags & GV_NOTQUAL) || !full_len) {
2497         len = full_len;
2498     }
2499     else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) {
2500         if (name == name_end) return gv;
2501     }
2502     else {
2503         return NULL;
2504     }
2505
2506     if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) {
2507         return NULL;
2508     }
2509     
2510     /* By this point we should have a stash and a name */
2511     gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add);
2512     if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
2513         if (addmg) gv = (GV *)newSV(0);     /* tentatively */
2514         else return NULL;
2515     }
2516     else gv = *gvp, addmg = 0;
2517     /* From this point on, addmg means gv has not been inserted in the
2518        symtab yet. */
2519
2520     if (SvTYPE(gv) == SVt_PVGV) {
2521         /* The GV already exists, so return it, but check if we need to do
2522          * anything else with it before that.
2523          */
2524         if (add) {
2525             /* This is the heuristic that handles if a variable triggers the
2526              * 'used only once' warning.  If there's already a GV in the stash
2527              * with this name, then we assume that the variable has been used
2528              * before and turn its MULTI flag on.
2529              * It's a heuristic because it can easily be "tricked", like with
2530              * BEGIN { $a = 1; $::{foo} = *a }; () = $foo
2531              * not warning about $main::foo being used just once
2532              */
2533             GvMULTI_on(gv);
2534             gv_init_svtype(gv, sv_type);
2535             /* You reach this path once the typeglob has already been created,
2536                either by the same or a different sigil.  If this path didn't
2537                exist, then (say) referencing $! first, and %! second would
2538                mean that %! was not handled correctly.  */
2539             if (len == 1 && stash == PL_defstash) {
2540                 maybe_multimagic_gv(gv, name, sv_type);
2541             }
2542             else if (sv_type == SVt_PVAV
2543                   && memEQs(name, len, "ISA")
2544                   && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
2545                 gv_magicalize_isa(gv);
2546         }
2547         return gv;
2548     } else if (no_init) {
2549         assert(!addmg);
2550         return gv;
2551     }
2552     /* If GV_NOEXPAND is true and what we got off the stash is a ref,
2553      * don't expand it to a glob. This is an optimization so that things
2554      * copying constants over, like Exporter, don't have to be rewritten
2555      * to take into account that you can store more than just globs in
2556      * stashes.
2557      */
2558     else if (no_expand && SvROK(gv)) {
2559         assert(!addmg);
2560         return gv;
2561     }
2562
2563     /* Adding a new symbol.
2564        Unless of course there was already something non-GV here, in which case
2565        we want to behave as if there was always a GV here, containing some sort
2566        of subroutine.
2567        Otherwise we run the risk of creating things like GvIO, which can cause
2568        subtle bugs. eg the one that tripped up SQL::Translator  */
2569
2570     faking_it = SvOK(gv);
2571
2572     if (add & GV_ADDWARN)
2573         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2574                 "Had to create %" UTF8f " unexpectedly",
2575                  UTF8fARG(is_utf8, name_end-nambeg, nambeg));
2576     gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
2577
2578     if (   full_len != 0
2579         && isIDFIRST_lazy_if_safe(name, name + full_len, is_utf8)
2580         && !ckWARN(WARN_ONCE) )
2581     {
2582         GvMULTI_on(gv) ;
2583     }
2584
2585     /* set up magic where warranted */
2586     if ( gv_magicalize(gv, stash, name, len, sv_type) ) {
2587         /* See 23496c6 */
2588         if (addmg) {
2589                 /* gv_magicalize magicalised this gv, so we want it
2590                  * stored in the symtab.
2591                  * Effectively the caller is asking, ‘Does this gv exist?’ 
2592                  * And we respond, ‘Er, *now* it does!’
2593                  */
2594                 (void)hv_store(stash,name,len,(SV *)gv,0);
2595         }
2596     }
2597     else if (addmg) {
2598                 /* The temporary GV created above */
2599                 SvREFCNT_dec_NN(gv);
2600                 gv = NULL;
2601     }
2602     
2603     if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
2604     return gv;
2605 }
2606
2607 void
2608 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2609 {
2610     const char *name;
2611     const HV * const hv = GvSTASH(gv);
2612
2613     PERL_ARGS_ASSERT_GV_FULLNAME4;
2614
2615     sv_setpv(sv, prefix ? prefix : "");
2616
2617     if (hv && (name = HvNAME(hv))) {
2618       const STRLEN len = HvNAMELEN(hv);
2619       if (keepmain || ! memBEGINs(name, len, "main")) {
2620         sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
2621         sv_catpvs(sv,"::");
2622       }
2623     }
2624     else sv_catpvs(sv,"__ANON__::");
2625     sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2626 }
2627
2628 void
2629 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2630 {
2631     const GV * const egv = GvEGVx(gv);
2632
2633     PERL_ARGS_ASSERT_GV_EFULLNAME4;
2634
2635     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2636 }
2637
2638
2639 /* recursively scan a stash and any nested stashes looking for entries
2640  * that need the "only used once" warning raised
2641  */
2642
2643 void
2644 Perl_gv_check(pTHX_ HV *stash)
2645 {
2646     I32 i;
2647
2648     PERL_ARGS_ASSERT_GV_CHECK;
2649
2650     if (!SvOOK(stash))
2651         return;
2652
2653     assert(HvARRAY(stash));
2654
2655     /* mark stash is being scanned, to avoid recursing */
2656     HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH;
2657     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2658         const HE *entry;
2659         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2660             GV *gv;
2661             HV *hv;
2662             STRLEN keylen = HeKLEN(entry);
2663             const char * const key = HeKEY(entry);
2664
2665             if (keylen >= 2 && key[keylen-2] == ':'  && key[keylen-1] == ':' &&
2666                 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2667             {
2668                 if (hv != PL_defstash && hv != stash
2669                     && !(SvOOK(hv)
2670                         && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH))
2671                 )
2672                      gv_check(hv);              /* nested package */
2673             }
2674             else if (   HeKLEN(entry) != 0
2675                      && *HeKEY(entry) != '_'
2676                      && isIDFIRST_lazy_if_safe(HeKEY(entry),
2677                                                HeKEY(entry) + HeKLEN(entry),
2678                                                HeUTF8(entry)) )
2679             {
2680                 const char *file;
2681                 gv = MUTABLE_GV(HeVAL(entry));
2682                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2683                     continue;
2684                 file = GvFILE(gv);
2685                 CopLINE_set(PL_curcop, GvLINE(gv));
2686 #ifdef USE_ITHREADS
2687                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
2688 #else
2689                 CopFILEGV(PL_curcop)
2690                     = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2691 #endif
2692                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2693                         "Name \"%" HEKf "::%" HEKf
2694                         "\" used only once: possible typo",
2695                             HEKfARG(HvNAME_HEK(stash)),
2696                             HEKfARG(GvNAME_HEK(gv)));
2697             }
2698         }
2699     }
2700     HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH;
2701 }
2702
2703 GV *
2704 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2705 {
2706     PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2707     assert(!(flags & ~SVf_UTF8));
2708
2709     return gv_fetchpv(Perl_form(aTHX_ "%" UTF8f "::_GEN_%ld",
2710                                 UTF8fARG(flags, strlen(pack), pack),
2711                                 (long)PL_gensym++),
2712                       GV_ADD, SVt_PVGV);
2713 }
2714
2715 /* hopefully this is only called on local symbol table entries */
2716
2717 GP*
2718 Perl_gp_ref(pTHX_ GP *gp)
2719 {
2720     if (!gp)
2721         return NULL;
2722     gp->gp_refcnt++;
2723     if (gp->gp_cv) {
2724         if (gp->gp_cvgen) {
2725             /* If the GP they asked for a reference to contains
2726                a method cache entry, clear it first, so that we
2727                don't infect them with our cached entry */
2728             SvREFCNT_dec_NN(gp->gp_cv);
2729             gp->gp_cv = NULL;
2730             gp->gp_cvgen = 0;
2731         }
2732     }
2733     return gp;
2734 }
2735
2736 void
2737 Perl_gp_free(pTHX_ GV *gv)
2738 {
2739     GP* gp;
2740     int attempts = 100;
2741     bool in_global_destruction = PL_phase == PERL_PHASE_DESTRUCT;
2742
2743     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2744         return;
2745     if (gp->gp_refcnt == 0) {
2746         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2747                          "Attempt to free unreferenced glob pointers"
2748                          pTHX__FORMAT pTHX__VALUE);
2749         return;
2750     }
2751     if (gp->gp_refcnt > 1) {
2752        borrowed:
2753         if (gp->gp_egv == gv)
2754             gp->gp_egv = 0;
2755         gp->gp_refcnt--;
2756         GvGP_set(gv, NULL);
2757         return;
2758     }
2759
2760     while (1) {
2761       /* Copy and null out all the glob slots, so destructors do not see
2762          freed SVs. */
2763       HEK * const file_hek = gp->gp_file_hek;
2764       SV  * sv             = gp->gp_sv;
2765       AV  * av             = gp->gp_av;
2766       HV  * hv             = gp->gp_hv;
2767       IO  * io             = gp->gp_io;
2768       CV  * cv             = gp->gp_cv;
2769       CV  * form           = gp->gp_form;
2770
2771       int need = 0;
2772
2773       gp->gp_file_hek = NULL;
2774       gp->gp_sv       = NULL;
2775       gp->gp_av       = NULL;
2776       gp->gp_hv       = NULL;
2777       gp->gp_io       = NULL;
2778       gp->gp_cv       = NULL;
2779       gp->gp_form     = NULL;
2780
2781       if (file_hek)
2782         unshare_hek(file_hek);
2783
2784       /* Storing the SV on the temps stack (instead of freeing it immediately)
2785          is an admitted bodge that attempt to compensate for the lack of
2786          reference counting on the stack. The motivation is that typeglob syntax
2787          is extremely short hence programs such as '$a += (*a = 2)' are often
2788          found randomly by researchers running fuzzers. Previously these
2789          programs would trigger errors, that the researchers would
2790          (legitimately) report, and then we would spend time figuring out that
2791          the cause was "stack not reference counted" and so not a dangerous
2792          security hole. This consumed a lot of researcher time, our time, and
2793          prevents "interesting" security holes being uncovered.
2794
2795          Typeglob assignment is rarely used in performance critical production
2796          code, so we aren't causing much slowdown by doing extra work here.
2797
2798          In turn, the need to check for SvOBJECT (and references to objects) is
2799          because we have regression tests that rely on timely destruction that
2800          happens *within this while loop* to demonstrate behaviour, and
2801          potentially there is also *working* code in the wild that relies on
2802          such behaviour.
2803
2804          And we need to avoid doing this in global destruction else we can end
2805          up with "Attempt to free temp prematurely ... Unbalanced string table
2806          refcount".
2807
2808          Hence the whole thing is a heuristic intended to mitigate against
2809          simple problems likely found by fuzzers but never written by humans,
2810          whilst leaving working code unchanged. */
2811       if (sv) {
2812           SV *referant;
2813           if (SvREFCNT(sv) > 1 || SvOBJECT(sv) || UNLIKELY(in_global_destruction)) {
2814               SvREFCNT_dec_NN(sv);
2815               sv = NULL;
2816           } else if (SvROK(sv) && (referant = SvRV(sv))
2817                      && (SvREFCNT(referant) > 1 || SvOBJECT(referant))) {
2818               SvREFCNT_dec_NN(sv);
2819               sv = NULL;
2820           } else {
2821               ++need;
2822           }
2823       }
2824       if (av) {
2825           if (SvREFCNT(av) > 1 || SvOBJECT(av) || UNLIKELY(in_global_destruction)) {
2826               SvREFCNT_dec_NN(av);
2827               av = NULL;
2828           } else {
2829               ++need;
2830           }
2831       }
2832       /* FIXME - another reference loop GV -> symtab -> GV ?
2833          Somehow gp->gp_hv can end up pointing at freed garbage.  */
2834       if (hv && SvTYPE(hv) == SVt_PVHV) {
2835         const HEK *hvname_hek = HvNAME_HEK(hv);
2836         if (PL_stashcache && hvname_hek) {
2837            DEBUG_o(Perl_deb(aTHX_
2838                           "gp_free clearing PL_stashcache for '%" HEKf "'\n",
2839                            HEKfARG(hvname_hek)));
2840            (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
2841         }
2842         if (SvREFCNT(hv) > 1 || SvOBJECT(hv) || UNLIKELY(in_global_destruction)) {
2843           SvREFCNT_dec_NN(hv);
2844           hv = NULL;
2845         } else {
2846           ++need;
2847         }
2848       }
2849       if (io && SvREFCNT(io) == 1 && IoIFP(io)
2850              && (IoTYPE(io) == IoTYPE_WRONLY ||
2851                  IoTYPE(io) == IoTYPE_RDWR   ||
2852                  IoTYPE(io) == IoTYPE_APPEND)
2853              && ckWARN_d(WARN_IO)
2854              && IoIFP(io) != PerlIO_stdin()
2855              && IoIFP(io) != PerlIO_stdout()
2856              && IoIFP(io) != PerlIO_stderr()
2857              && !(IoFLAGS(io) & IOf_FAKE_DIRP))
2858         io_close(io, gv, FALSE, TRUE);
2859       if (io) {
2860           if (SvREFCNT(io) > 1 || SvOBJECT(io) || UNLIKELY(in_global_destruction)) {
2861               SvREFCNT_dec_NN(io);
2862               io = NULL;
2863           } else {
2864               ++need;
2865           }
2866       }
2867       if (cv) {
2868           if (SvREFCNT(cv) > 1 || SvOBJECT(cv) || UNLIKELY(in_global_destruction)) {
2869               SvREFCNT_dec_NN(cv);
2870               cv = NULL;
2871           } else {
2872               ++need;
2873           }
2874       }
2875       if (form) {
2876           if (SvREFCNT(form) > 1 || SvOBJECT(form) || UNLIKELY(in_global_destruction)) {
2877               SvREFCNT_dec_NN(form);
2878               form = NULL;
2879           } else {
2880               ++need;
2881           }
2882       }
2883
2884       if (need) {
2885           /* We don't strictly need to defer all this to the end, but it's
2886              easiest to do so. The subtle problems we have are
2887              1) any of the actions triggered by the various SvREFCNT_dec()s in
2888                 any of the intermediate blocks can cause more items to be added
2889                 to the temps stack. So we can't "cache" its state locally
2890              2) We'd have to re-check the "extend by 1?" for each time.
2891                 Whereas if we don't NULL out the values that we want to put onto
2892                 the save stack until here, we can do it in one go, with one
2893                 one size check. */
2894
2895           SSize_t max_ix = PL_tmps_ix + need;
2896
2897           if (max_ix >= PL_tmps_max) {
2898               tmps_grow_p(max_ix);
2899           }
2900
2901           if (sv) {
2902               PL_tmps_stack[++PL_tmps_ix] = sv;
2903           }
2904           if (av) {
2905               PL_tmps_stack[++PL_tmps_ix] = (SV *) av;
2906           }
2907           if (hv) {
2908               PL_tmps_stack[++PL_tmps_ix] = (SV *) hv;
2909           }
2910           if (io) {
2911               PL_tmps_stack[++PL_tmps_ix] = (SV *) io;
2912           }
2913           if (cv) {
2914               PL_tmps_stack[++PL_tmps_ix] = (SV *) cv;
2915           }
2916           if (form) {
2917               PL_tmps_stack[++PL_tmps_ix] = (SV *) form;
2918           }
2919       }
2920
2921       /* Possibly reallocated by a destructor */
2922       gp = GvGP(gv);
2923
2924       if (!gp->gp_file_hek
2925        && !gp->gp_sv
2926        && !gp->gp_av
2927        && !gp->gp_hv
2928        && !gp->gp_io
2929        && !gp->gp_cv
2930        && !gp->gp_form) break;
2931
2932       if (--attempts == 0) {
2933         Perl_die(aTHX_
2934           "panic: gp_free failed to free glob pointer - "
2935           "something is repeatedly re-creating entries"
2936         );
2937       }
2938     }
2939
2940     /* Possibly incremented by a destructor doing glob assignment */
2941     if (gp->gp_refcnt > 1) goto borrowed;
2942     Safefree(gp);
2943     GvGP_set(gv, NULL);
2944 }
2945
2946 int
2947 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2948 {
2949     AMT * const amtp = (AMT*)mg->mg_ptr;
2950     PERL_UNUSED_ARG(sv);
2951
2952     PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2953
2954     if (amtp && AMT_AMAGIC(amtp)) {
2955         int i;
2956         for (i = 1; i < NofAMmeth; i++) {
2957             CV * const cv = amtp->table[i];
2958             if (cv) {
2959                 SvREFCNT_dec_NN(MUTABLE_SV(cv));
2960                 amtp->table[i] = NULL;
2961             }
2962         }
2963     }
2964  return 0;
2965 }
2966
2967 /* Updates and caches the CV's */
2968 /* Returns:
2969  * 1 on success and there is some overload
2970  * 0 if there is no overload
2971  * -1 if some error occurred and it couldn't croak
2972  */
2973
2974 int
2975 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2976 {
2977   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2978   AMT amt;
2979   const struct mro_meta* stash_meta = HvMROMETA(stash);
2980   U32 newgen;
2981
2982   PERL_ARGS_ASSERT_GV_AMUPDATE;
2983
2984   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2985   if (mg) {
2986       const AMT * const amtp = (AMT*)mg->mg_ptr;
2987       if (amtp->was_ok_sub == newgen) {
2988           return AMT_AMAGIC(amtp) ? 1 : 0;
2989       }
2990       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2991   }
2992
2993   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2994
2995   Zero(&amt,1,AMT);
2996   amt.was_ok_sub = newgen;
2997   amt.fallback = AMGfallNO;
2998   amt.flags = 0;
2999
3000   {
3001     int filled = 0;
3002     int i;
3003     bool deref_seen = 0;
3004
3005
3006     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
3007
3008     /* Try to find via inheritance. */
3009     GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
3010     SV * const sv = gv ? GvSV(gv) : NULL;
3011     CV* cv;
3012
3013     if (!gv)
3014     {
3015       if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
3016         goto no_table;
3017     }
3018 #ifdef PERL_DONT_CREATE_GVSV
3019     else if (!sv) {
3020         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
3021     }
3022 #endif
3023     else if (SvTRUE(sv))
3024         /* don't need to set overloading here because fallback => 1
3025          * is the default setting for classes without overloading */
3026         amt.fallback=AMGfallYES;
3027     else if (SvOK(sv)) {
3028         amt.fallback=AMGfallNEVER;
3029         filled = 1;
3030     }
3031     else {
3032         filled = 1;
3033     }
3034
3035     assert(SvOOK(stash));
3036     /* initially assume the worst */
3037     HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
3038
3039     for (i = 1; i < NofAMmeth; i++) {
3040         const char * const cooky = PL_AMG_names[i];
3041         /* Human-readable form, for debugging: */
3042         const char * const cp = AMG_id2name(i);
3043         const STRLEN l = PL_AMG_namelens[i];
3044
3045         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
3046                      cp, HvNAME_get(stash)) );
3047         /* don't fill the cache while looking up!
3048            Creation of inheritance stubs in intermediate packages may
3049            conflict with the logic of runtime method substitution.
3050            Indeed, for inheritance A -> B -> C, if C overloads "+0",
3051            then we could have created stubs for "(+0" in A and C too.
3052            But if B overloads "bool", we may want to use it for
3053            numifying instead of C's "+0". */
3054         gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
3055         cv = 0;
3056         if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) {
3057             const HEK * const gvhek = CvGvNAME_HEK(cv);
3058             const HEK * const stashek =
3059                 HvNAME_HEK(CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv)));
3060             if (memEQs(HEK_KEY(gvhek), HEK_LEN(gvhek), "nil")
3061              && stashek
3062              && memEQs(HEK_KEY(stashek), HEK_LEN(stashek), "overload")) {
3063                 /* This is a hack to support autoloading..., while
3064                    knowing *which* methods were declared as overloaded. */
3065                 /* GvSV contains the name of the method. */
3066                 GV *ngv = NULL;
3067                 SV *gvsv = GvSV(gv);
3068
3069                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%" SVf256\
3070                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
3071                              (void*)GvSV(gv), cp, HvNAME(stash)) );
3072                 if (!gvsv || !SvPOK(gvsv)
3073                     || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
3074                 {
3075                     /* Can be an import stub (created by "can"). */
3076                     if (destructing) {
3077                         return -1;
3078                     }
3079                     else {
3080                         const SV * const name = (gvsv && SvPOK(gvsv))
3081                                                     ? gvsv
3082                                                     : newSVpvs_flags("???", SVs_TEMP);
3083                         /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
3084                         Perl_croak(aTHX_ "%s method \"%" SVf256
3085                                     "\" overloading \"%s\" "\
3086                                     "in package \"%" HEKf256 "\"",
3087                                    (GvCVGEN(gv) ? "Stub found while resolving"
3088                                     : "Can't resolve"),
3089                                    SVfARG(name), cp,
3090                                    HEKfARG(
3091                                         HvNAME_HEK(stash)
3092                                    ));
3093                     }
3094                 }
3095                 cv = GvCV(gv = ngv);
3096             }
3097             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
3098                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
3099                          GvNAME(CvGV(cv))) );
3100             filled = 1;
3101         } else if (gv) {                /* Autoloaded... */
3102             cv = MUTABLE_CV(gv);
3103             filled = 1;
3104         }
3105         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
3106
3107         if (gv) {
3108             switch (i) {
3109             case to_sv_amg:
3110             case to_av_amg:
3111             case to_hv_amg:
3112             case to_gv_amg:
3113             case to_cv_amg:
3114             case nomethod_amg:
3115                 deref_seen = 1;
3116                 break;
3117             }
3118         }
3119     }
3120     if (!deref_seen)
3121         /* none of @{} etc overloaded; we can do $obj->[N] quicker.
3122          * NB - aux var invalid here, HvARRAY() could have been
3123          * reallocated since it was assigned to */
3124         HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF;
3125
3126     if (filled) {
3127       AMT_AMAGIC_on(&amt);
3128       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
3129                                                 (char*)&amt, sizeof(AMT));
3130       return TRUE;
3131     }
3132   }
3133   /* Here we have no table: */
3134  no_table:
3135   AMT_AMAGIC_off(&amt);
3136   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
3137                                                 (char*)&amt, sizeof(AMTS));
3138   return 0;
3139 }
3140
3141
3142 CV*
3143 Perl_gv_handler(pTHX_ HV *stash, I32 id)
3144 {
3145     MAGIC *mg;
3146     AMT *amtp;
3147     U32 newgen;
3148     struct mro_meta* stash_meta;
3149
3150     if (!stash || !HvNAME_get(stash))
3151         return NULL;
3152
3153     stash_meta = HvMROMETA(stash);
3154     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
3155
3156     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
3157     if (!mg) {
3158       do_update:
3159         if (Gv_AMupdate(stash, 0) == -1)
3160             return NULL;
3161         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
3162     }
3163     assert(mg);
3164     amtp = (AMT*)mg->mg_ptr;
3165     if ( amtp->was_ok_sub != newgen )
3166         goto do_update;
3167     if (AMT_AMAGIC(amtp)) {
3168         CV * const ret = amtp->table[id];
3169         if (ret && isGV(ret)) {         /* Autoloading stab */
3170             /* Passing it through may have resulted in a warning
3171                "Inherited AUTOLOAD for a non-method deprecated", since
3172                our caller is going through a function call, not a method call.
3173                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
3174             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
3175
3176             if (gv && GvCV(gv))
3177                 return GvCV(gv);
3178         }
3179         return ret;
3180     }
3181
3182     return NULL;
3183 }
3184
3185
3186 /* Implement tryAMAGICun_MG macro.
3187    Do get magic, then see if the stack arg is overloaded and if so call it.
3188    Flags:
3189         AMGf_numeric apply sv_2num to the stack arg.
3190 */
3191
3192 bool
3193 Perl_try_amagic_un(pTHX_ int method, int flags) {
3194     dSP;
3195     SV* tmpsv;
3196     SV* const arg = TOPs;
3197
3198     SvGETMAGIC(arg);
3199
3200     if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
3201                                               AMGf_noright | AMGf_unary
3202                                             | (flags & AMGf_numarg))))
3203     {
3204         /* where the op is of the form:
3205          *    $lex = $x op $y (where the assign is optimised away)
3206          * then assign the returned value to targ and return that;
3207          * otherwise return the value directly
3208          */
3209         if (   (PL_opargs[PL_op->op_type] & OA_TARGLEX)
3210             && (PL_op->op_private & OPpTARGET_MY))
3211         {
3212             dTARGET;
3213             sv_setsv(TARG, tmpsv);
3214             SETTARG;
3215         }
3216         else
3217             SETs(tmpsv);
3218
3219         PUTBACK;
3220         return TRUE;
3221     }
3222
3223     if ((flags & AMGf_numeric) && SvROK(arg))
3224         *sp = sv_2num(arg);
3225     return FALSE;
3226 }
3227
3228
3229 /* Implement tryAMAGICbin_MG macro.
3230    Do get magic, then see if the two stack args are overloaded and if so
3231    call it.
3232    Flags:
3233         AMGf_assign  op may be called as mutator (eg +=)
3234         AMGf_numeric apply sv_2num to the stack arg.
3235 */
3236
3237 bool
3238 Perl_try_amagic_bin(pTHX_ int method, int flags) {
3239     dSP;
3240     SV* const left = TOPm1s;
3241     SV* const right = TOPs;
3242
3243     SvGETMAGIC(left);
3244     if (left != right)
3245         SvGETMAGIC(right);
3246
3247     if (SvAMAGIC(left) || SvAMAGIC(right)) {
3248         SV * tmpsv;
3249         /* STACKED implies mutator variant, e.g. $x += 1 */
3250         bool mutator = (flags & AMGf_assign) && (PL_op->op_flags & OPf_STACKED);
3251
3252         tmpsv = amagic_call(left, right, method,
3253                     (mutator ? AMGf_assign: 0)
3254                   | (flags & AMGf_numarg));
3255         if (tmpsv) {
3256             (void)POPs;
3257             /* where the op is one of the two forms:
3258              *    $x op= $y
3259              *    $lex = $x op $y (where the assign is optimised away)
3260              * then assign the returned value to targ and return that;
3261              * otherwise return the value directly
3262              */
3263             if (   mutator
3264                 || (   (PL_opargs[PL_op->op_type] & OA_TARGLEX)
3265                     && (PL_op->op_private & OPpTARGET_MY)))
3266             {
3267                 dTARG;
3268                 TARG = mutator ? *SP : PAD_SV(PL_op->op_targ);
3269                 sv_setsv(TARG, tmpsv);
3270                 SETTARG;
3271             }
3272             else
3273                 SETs(tmpsv);
3274
3275             PUTBACK;
3276             return TRUE;
3277         }
3278     }
3279
3280     if(left==right && SvGMAGICAL(left)) {
3281         SV * const left = sv_newmortal();
3282         *(sp-1) = left;
3283         /* Print the uninitialized warning now, so it includes the vari-
3284            able name. */
3285         if (!SvOK(right)) {
3286             if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
3287             sv_setbool(left, FALSE);
3288         }
3289         else sv_setsv_flags(left, right, 0);
3290         SvGETMAGIC(right);
3291     }
3292     if (flags & AMGf_numeric) {
3293         if (SvROK(TOPm1s))
3294             *(sp-1) = sv_2num(TOPm1s);
3295         if (SvROK(right))
3296             *sp     = sv_2num(right);
3297     }
3298     return FALSE;
3299 }
3300
3301 SV *
3302 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
3303     SV *tmpsv = NULL;
3304     HV *stash;
3305
3306     PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
3307
3308     if (!SvAMAGIC(ref))
3309         return ref;
3310     /* return quickly if none of the deref ops are overloaded */
3311     stash = SvSTASH(SvRV(ref));
3312     assert(SvOOK(stash));
3313     if (HvAUX(stash)->xhv_aux_flags & HvAUXf_NO_DEREF)
3314         return ref;
3315
3316     while ((tmpsv = amagic_call(ref, &PL_sv_undef, method,
3317                                 AMGf_noright | AMGf_unary))) { 
3318         if (!SvROK(tmpsv))
3319             Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
3320         if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
3321             /* Bail out if it returns us the same reference.  */
3322             return tmpsv;
3323         }
3324         ref = tmpsv;
3325         if (!SvAMAGIC(ref))
3326             break;
3327     }
3328     return tmpsv ? tmpsv : ref;
3329 }
3330
3331 bool
3332 Perl_amagic_is_enabled(pTHX_ int method)
3333 {
3334       SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
3335
3336       assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
3337
3338       if ( !lex_mask || !SvOK(lex_mask) )
3339           /* overloading lexically disabled */
3340           return FALSE;
3341       else if ( lex_mask && SvPOK(lex_mask) ) {
3342           /* we have an entry in the hints hash, check if method has been
3343            * masked by overloading.pm */
3344           STRLEN len;
3345           const int offset = method / 8;
3346           const int bit    = method % 8;
3347           char *pv = SvPV(lex_mask, len);
3348
3349           /* Bit set, so this overloading operator is disabled */
3350           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
3351               return FALSE;
3352       }
3353       return TRUE;
3354 }
3355
3356 SV*
3357 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
3358 {
3359   MAGIC *mg;
3360   CV *cv=NULL;
3361   CV **cvp=NULL, **ocvp=NULL;
3362   AMT *amtp=NULL, *oamtp=NULL;
3363   int off = 0, off1, lr = 0, notfound = 0;
3364   int postpr = 0, force_cpy = 0;
3365   int assign = AMGf_assign & flags;
3366   const int assignshift = assign ? 1 : 0;
3367   int use_default_op = 0;
3368   int force_scalar = 0;
3369 #ifdef DEBUGGING
3370   int fl=0;
3371 #endif
3372   HV* stash=NULL;
3373
3374   PERL_ARGS_ASSERT_AMAGIC_CALL;
3375
3376   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
3377       if (!amagic_is_enabled(method)) return NULL;
3378   }
3379
3380   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
3381       && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
3382       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3383       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3384                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
3385                         : NULL))
3386       && ((cv = cvp[off=method+assignshift])
3387           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
3388                                                           * usual method */
3389                   (
3390 #ifdef DEBUGGING
3391                    fl = 1,
3392 #endif
3393                    cv = cvp[off=method])))) {
3394     lr = -1;                    /* Call method for left argument */
3395   } else {
3396     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
3397       int logic;
3398
3399       /* look for substituted methods */
3400       /* In all the covered cases we should be called with assign==0. */
3401          switch (method) {
3402          case inc_amg:
3403            force_cpy = 1;
3404            if ((cv = cvp[off=add_ass_amg])
3405                || ((cv = cvp[off = add_amg])
3406                    && (force_cpy = 0, (postpr = 1)))) {
3407              right = &PL_sv_yes; lr = -1; assign = 1;
3408            }
3409            break;
3410          case dec_amg:
3411            force_cpy = 1;
3412            if ((cv = cvp[off = subtr_ass_amg])
3413                || ((cv = cvp[off = subtr_amg])
3414                    && (force_cpy = 0, (postpr=1)))) {
3415              right = &PL_sv_yes; lr = -1; assign = 1;
3416            }
3417            break;
3418          case bool__amg:
3419            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
3420            break;
3421          case numer_amg:
3422            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
3423            break;
3424          case string_amg:
3425            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
3426            break;
3427          case not_amg:
3428            (void)((cv = cvp[off=bool__amg])
3429                   || (cv = cvp[off=numer_amg])
3430                   || (cv = cvp[off=string_amg]));
3431            if (cv)
3432                postpr = 1;
3433            break;
3434          case copy_amg:
3435            {
3436              /*
3437                   * SV* ref causes confusion with the interpreter variable of
3438                   * the same name
3439                   */
3440              SV* const tmpRef=SvRV(left);
3441              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
3442                 /*
3443                  * Just to be extra cautious.  Maybe in some
3444                  * additional cases sv_setsv is safe, too.
3445                  */
3446                 SV* const newref = newSVsv(tmpRef);
3447                 SvOBJECT_on(newref);
3448                 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
3449                    delegate to the stash. */
3450                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
3451                 return newref;
3452              }
3453            }
3454            break;
3455          case abs_amg:
3456            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
3457                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
3458              SV* const nullsv=&PL_sv_zero;
3459              if (off1==lt_amg) {
3460                SV* const lessp = amagic_call(left,nullsv,
3461                                        lt_amg,AMGf_noright);
3462                logic = SvTRUE_NN(lessp);
3463              } else {
3464                SV* const lessp = amagic_call(left,nullsv,
3465                                        ncmp_amg,AMGf_noright);
3466                logic = (SvNV(lessp) < 0);
3467              }
3468              if (logic) {
3469                if (off==subtr_amg) {
3470                  right = left;
3471                  left = nullsv;
3472                  lr = 1;
3473                }
3474              } else {
3475                return left;
3476              }
3477            }
3478            break;
3479          case neg_amg:
3480            if ((cv = cvp[off=subtr_amg])) {
3481              right = left;
3482              left = &PL_sv_zero;
3483              lr = 1;
3484            }
3485            break;
3486          case int_amg:
3487          case iter_amg:                 /* XXXX Eventually should do to_gv. */
3488          case ftest_amg:                /* XXXX Eventually should do to_gv. */
3489          case regexp_amg:
3490              /* FAIL safe */
3491              return NULL;       /* Delegate operation to standard mechanisms. */
3492
3493          case to_sv_amg:
3494          case to_av_amg:
3495          case to_hv_amg:
3496          case to_gv_amg:
3497          case to_cv_amg:
3498              /* FAIL safe */
3499              return left;       /* Delegate operation to standard mechanisms. */
3500
3501          default:
3502            goto not_found;
3503          }
3504          if (!cv) goto not_found;
3505     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
3506                && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
3507                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3508                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3509                           ? (amtp = (AMT*)mg->mg_ptr)->table
3510                           : NULL))
3511                && (cv = cvp[off=method])) { /* Method for right
3512                                              * argument found */
3513       lr=1;
3514     } else if (((cvp && amtp->fallback > AMGfallNEVER)
3515                 || (ocvp && oamtp->fallback > AMGfallNEVER))
3516                && !(flags & AMGf_unary)) {
3517                                 /* We look for substitution for
3518                                  * comparison operations and
3519                                  * concatenation */
3520       if (method==concat_amg || method==concat_ass_amg
3521           || method==repeat_amg || method==repeat_ass_amg) {
3522         return NULL;            /* Delegate operation to string conversion */
3523       }
3524       off = -1;
3525       switch (method) {
3526          case lt_amg:
3527          case le_amg:
3528          case gt_amg:
3529          case ge_amg:
3530          case eq_amg:
3531          case ne_amg:
3532              off = ncmp_amg;
3533              break;
3534          case slt_amg:
3535          case sle_amg:
3536          case sgt_amg:
3537          case sge_amg:
3538          case seq_amg:
3539          case sne_amg:
3540              off = scmp_amg;
3541              break;
3542          }
3543       if (off != -1) {
3544           if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
3545               cv = ocvp[off];
3546               lr = -1;
3547           }
3548           if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
3549               cv = cvp[off];
3550               lr = 1;
3551           }
3552       }
3553       if (cv)
3554           postpr = 1;
3555       else
3556           goto not_found;
3557     } else {
3558     not_found:                  /* No method found, either report or croak */
3559       switch (method) {
3560          case to_sv_amg:
3561          case to_av_amg:
3562          case to_hv_amg:
3563          case to_gv_amg:
3564          case to_cv_amg:
3565              /* FAIL safe */
3566              return left;       /* Delegate operation to standard mechanisms. */
3567       }
3568       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
3569         notfound = 1; lr = -1;
3570       } else if (cvp && (cv=cvp[nomethod_amg])) {
3571         notfound = 1; lr = 1;
3572       } else if ((use_default_op =
3573                   (!ocvp || oamtp->fallback >= AMGfallYES)
3574                   && (!cvp || amtp->fallback >= AMGfallYES))
3575                  && !DEBUG_o_TEST) {
3576         /* Skip generating the "no method found" message.  */
3577         return NULL;
3578       } else {
3579         SV *msg;
3580         if (off==-1) off=method;
3581         msg = sv_2mortal(Perl_newSVpvf(aTHX_
3582                       "Operation \"%s\": no method found,%sargument %s%" SVf "%s%" SVf,
3583                       AMG_id2name(method + assignshift),
3584                       (flags & AMGf_unary ? " " : "\n\tleft "),
3585                       SvAMAGIC(left)?
3586                         "in overloaded package ":
3587                         "has no overloaded magic",
3588                       SvAMAGIC(left)?
3589                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
3590                         SVfARG(&PL_sv_no),
3591                       SvAMAGIC(right)?
3592                         ",\n\tright argument in overloaded package ":
3593                         (flags & AMGf_unary
3594                          ? ""
3595                          : ",\n\tright argument has no overloaded magic"),
3596                       SvAMAGIC(right)?
3597                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
3598                         SVfARG(&PL_sv_no)));
3599         if (use_default_op) {
3600           DEBUG_o( Perl_deb(aTHX_ "%" SVf, SVfARG(msg)) );
3601         } else {
3602           Perl_croak(aTHX_ "%" SVf, SVfARG(msg));
3603         }
3604         return NULL;
3605       }
3606       force_cpy = force_cpy || assign;
3607     }
3608   }
3609
3610   switch (method) {
3611     /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
3612      * operation. we need this to return a value, so that it can be assigned
3613      * later on, in the postpr block (case inc_amg/dec_amg), even if the
3614      * increment or decrement was itself called in void context */
3615     case inc_amg:
3616       if (off == add_amg)
3617         force_scalar = 1;
3618       break;
3619     case dec_amg:
3620       if (off == subtr_amg)
3621         force_scalar = 1;
3622       break;
3623     /* in these cases, we're calling an assignment variant of an operator
3624      * (+= rather than +, for instance). regardless of whether it's a
3625      * fallback or not, it always has to return a value, which will be
3626      * assigned to the proper variable later */
3627     case add_amg:
3628     case subtr_amg:
3629     case mult_amg:
3630     case div_amg:
3631     case modulo_amg:
3632     case pow_amg:
3633     case lshift_amg:
3634     case rshift_amg:
3635     case repeat_amg:
3636     case concat_amg:
3637     case band_amg:
3638     case bor_amg:
3639     case bxor_amg:
3640     case sband_amg:
3641     case sbor_amg:
3642     case sbxor_amg:
3643       if (assign)
3644         force_scalar = 1;
3645       break;
3646     /* the copy constructor always needs to return a value */
3647     case copy_amg:
3648       force_scalar = 1;
3649       break;
3650     /* because of the way these are implemented (they don't perform the
3651      * dereferencing themselves, they return a reference that perl then
3652      * dereferences later), they always have to be in scalar context */
3653     case to_sv_amg:
3654     case to_av_amg:
3655     case to_hv_amg:
3656     case to_gv_amg:
3657     case to_cv_amg:
3658       force_scalar = 1;
3659       break;
3660     /* these don't have an op of their own; they're triggered by their parent
3661      * op, so the context there isn't meaningful ('$a and foo()' in void
3662      * context still needs to pass scalar context on to $a's bool overload) */
3663     case bool__amg:
3664     case numer_amg:
3665     case string_amg:
3666       force_scalar = 1;
3667       break;
3668   }
3669
3670 #ifdef DEBUGGING
3671   if (!notfound) {
3672     DEBUG_o(Perl_deb(aTHX_
3673                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %" SVf "%s\n",
3674                      AMG_id2name(off),
3675                      method+assignshift==off? "" :
3676                      " (initially \"",
3677                      method+assignshift==off? "" :
3678                      AMG_id2name(method+assignshift),
3679                      method+assignshift==off? "" : "\")",
3680                      flags & AMGf_unary? "" :
3681                      lr==1 ? " for right argument": " for left argument",
3682                      flags & AMGf_unary? " for argument" : "",
3683                      stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
3684                      fl? ",\n\tassignment variant used": "") );
3685   }
3686 #endif
3687     /* Since we use shallow copy during assignment, we need
3688      * to dublicate the contents, probably calling user-supplied
3689      * version of copy operator
3690      */
3691     /* We need to copy in following cases:
3692      * a) Assignment form was called.
3693      *          assignshift==1,  assign==T, method + 1 == off
3694      * b) Increment or decrement, called directly.
3695      *          assignshift==0,  assign==0, method + 0 == off
3696      * c) Increment or decrement, translated to assignment add/subtr.
3697      *          assignshift==0,  assign==T,
3698      *          force_cpy == T
3699      * d) Increment or decrement, translated to nomethod.
3700      *          assignshift==0,  assign==0,
3701      *          force_cpy == T
3702      * e) Assignment form translated to nomethod.
3703      *          assignshift==1,  assign==T, method + 1 != off
3704      *          force_cpy == T
3705      */
3706     /*  off is method, method+assignshift, or a result of opcode substitution.
3707      *  In the latter case assignshift==0, so only notfound case is important.
3708      */
3709   if ( (lr == -1) && ( ( (method + assignshift == off)
3710         && (assign || (method == inc_amg) || (method == dec_amg)))
3711       || force_cpy) )
3712   {
3713       /* newSVsv does not behave as advertised, so we copy missing
3714        * information by hand */
3715       SV *tmpRef = SvRV(left);
3716       SV *rv_copy;
3717       if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
3718           SvRV_set(left, rv_copy);
3719           SvSETMAGIC(left);
3720           SvREFCNT_dec_NN(tmpRef);  
3721       }
3722   }
3723
3724   {
3725     dSP;
3726     BINOP myop;
3727     SV* res;
3728     const bool oldcatch = CATCH_GET;
3729     I32 oldmark, nret;
3730                 /* for multiconcat, we may call overload several times,
3731                  * with the context of individual concats being scalar,
3732                  * regardless of the overall context of the multiconcat op
3733                  */
3734     U8 gimme = (force_scalar || PL_op->op_type == OP_MULTICONCAT)
3735                     ? G_SCALAR : GIMME_V;
3736
3737     CATCH_SET(TRUE);
3738     Zero(&myop, 1, BINOP);
3739     myop.op_last = (OP *) &myop;
3740     myop.op_next = NULL;
3741     myop.op_flags = OPf_STACKED;
3742
3743     switch (gimme) {
3744         case G_VOID:
3745             myop.op_flags |= OPf_WANT_VOID;
3746             break;
3747         case G_LIST:
3748             if (flags & AMGf_want_list) {
3749                 myop.op_flags |= OPf_WANT_LIST;
3750                 break;
3751             }
3752             /* FALLTHROUGH */
3753         default:
3754             myop.op_flags |= OPf_WANT_SCALAR;
3755             break;
3756     }
3757
3758     PUSHSTACKi(PERLSI_OVERLOAD);
3759     ENTER;
3760     SAVEOP();
3761     PL_op = (OP *) &myop;
3762     if (PERLDB_SUB && PL_curstash != PL_debstash)
3763         PL_op->op_private |= OPpENTERSUB_DB;
3764     Perl_pp_pushmark(aTHX);
3765
3766     EXTEND(SP, notfound + 5);
3767     PUSHs(lr>0? right: left);
3768     PUSHs(lr>0? left: right);
3769     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
3770     if (notfound) {
3771       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3772                            AMG_id2namelen(method + assignshift), SVs_TEMP));
3773     }
3774     else if (flags & AMGf_numarg)
3775       PUSHs(&PL_sv_undef);
3776     if (flags & AMGf_numarg)
3777       PUSHs(&PL_sv_yes);
3778     PUSHs(MUTABLE_SV(cv));
3779     PUTBACK;
3780     oldmark = TOPMARK;
3781
3782     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3783       CALLRUNOPS(aTHX);
3784     LEAVE;
3785     SPAGAIN;
3786     nret = SP - (PL_stack_base + oldmark);
3787
3788     switch (gimme) {
3789         case G_VOID:
3790             /* returning NULL has another meaning, and we check the context
3791              * at the call site too, so this can be differentiated from the
3792              * scalar case */
3793             res = &PL_sv_undef;
3794             SP = PL_stack_base + oldmark;
3795             break;
3796         case G_LIST:
3797             if (flags & AMGf_want_list) {
3798                 res = sv_2mortal((SV *)newAV());
3799                 av_extend((AV *)res, nret);
3800                 while (nret--)
3801                     av_store((AV *)res, nret, POPs);
3802                 break;
3803             }
3804             /* FALLTHROUGH */
3805         default:
3806             res = POPs;
3807             break;
3808     }
3809
3810     PUTBACK;
3811     POPSTACK;
3812     CATCH_SET(oldcatch);
3813
3814     if (postpr) {
3815       int ans;
3816       switch (method) {
3817       case le_amg:
3818       case sle_amg:
3819         ans=SvIV(res)<=0; break;
3820       case lt_amg:
3821       case slt_amg:
3822         ans=SvIV(res)<0; break;
3823       case ge_amg:
3824       case sge_amg:
3825         ans=SvIV(res)>=0; break;
3826       case gt_amg:
3827       case sgt_amg:
3828         ans=SvIV(res)>0; break;
3829       case eq_amg:
3830       case seq_amg:
3831         ans=SvIV(res)==0; break;
3832       case ne_amg:
3833       case sne_amg:
3834         ans=SvIV(res)!=0; break;
3835       case inc_amg:
3836       case dec_amg:
3837         SvSetSV(left,res); return left;
3838       case not_amg:
3839         ans=!SvTRUE_NN(res); break;
3840       default:
3841         ans=0; break;
3842       }
3843       return boolSV(ans);
3844     } else if (method==copy_amg) {
3845       if (!SvROK(res)) {
3846         Perl_croak(aTHX_ "Copy method did not return a reference");
3847       }
3848       return SvREFCNT_inc(SvRV(res));
3849     } else {
3850       return res;
3851     }
3852   }
3853 }
3854
3855 void
3856 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3857 {
3858     U32 hash;
3859
3860     PERL_ARGS_ASSERT_GV_NAME_SET;
3861
3862     if (len > I32_MAX)
3863         Perl_croak(aTHX_ "panic: gv name too long (%" UVuf ")", (UV) len);
3864
3865     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3866         unshare_hek(GvNAME_HEK(gv));
3867     }
3868
3869     PERL_HASH(hash, name, len);
3870     GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3871 }
3872
3873 /*
3874 =for apidoc gv_try_downgrade
3875
3876 If the typeglob C<gv> can be expressed more succinctly, by having
3877 something other than a real GV in its place in the stash, replace it
3878 with the optimised form.  Basic requirements for this are that C<gv>
3879 is a real typeglob, is sufficiently ordinary, and is only referenced
3880 from its package.  This function is meant to be used when a GV has been
3881 looked up in part to see what was there, causing upgrading, but based
3882 on what was found it turns out that the real GV isn't required after all.
3883
3884 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3885
3886 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3887 sub, the typeglob is replaced with a scalar-reference placeholder that
3888 more compactly represents the same thing.
3889
3890 =cut
3891 */
3892
3893 void
3894 Perl_gv_try_downgrade(pTHX_ GV *gv)
3895 {
3896     HV *stash;
3897     CV *cv;
3898     HEK *namehek;
3899     SV **gvp;
3900     PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3901
3902     /* XXX Why and where does this leave dangling pointers during global
3903        destruction? */
3904     if (PL_phase == PERL_PHASE_DESTRUCT) return;
3905
3906     if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3907             !SvOBJECT(gv) && !SvREADONLY(gv) &&
3908             isGV_with_GP(gv) && GvGP(gv) &&
3909             !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3910             !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3911             GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3912         return;
3913     if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv)
3914         return;
3915     if (SvMAGICAL(gv)) {
3916         MAGIC *mg;
3917         /* only backref magic is allowed */
3918         if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3919             return;
3920         for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3921             if (mg->mg_type != PERL_MAGIC_backref)
3922                 return;
3923         }
3924     }
3925     cv = GvCV(gv);
3926     if (!cv) {
3927         HEK *gvnhek = GvNAME_HEK(gv);
3928         (void)hv_deletehek(stash, gvnhek, G_DISCARD);
3929     } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 &&
3930             !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3931             CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv &&
3932             CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3933             !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3934             (namehek = GvNAME_HEK(gv)) &&
3935             (gvp = hv_fetchhek(stash, namehek, 0)) &&
3936             *gvp == (SV*)gv) {
3937         SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3938         const bool imported = !!GvIMPORTED_CV(gv);
3939         SvREFCNT(gv) = 0;
3940         sv_clear((SV*)gv);
3941         SvREFCNT(gv) = 1;
3942         SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
3943
3944         /* See also: 'SET_SVANY_FOR_BODYLESS_IV' in sv.c */
3945         SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3946                                 STRUCT_OFFSET(XPVIV, xiv_iv));
3947         SvRV_set(gv, value);
3948     }
3949 }
3950
3951 GV *
3952 Perl_gv_override(pTHX_ const char * const name, const STRLEN len)
3953 {
3954     GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV);
3955     GV * const *gvp;
3956     PERL_ARGS_ASSERT_GV_OVERRIDE;
3957     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv;
3958     gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE);
3959     gv = gvp ? *gvp : NULL;
3960     if (gv && !isGV(gv)) {
3961         if (!SvPCS_IMPORTED(gv)) return NULL;
3962         gv_init(gv, PL_globalstash, name, len, 0);
3963         return gv;
3964     }
3965     return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL;
3966 }
3967
3968 #include "XSUB.h"
3969
3970 static void
3971 core_xsub(pTHX_ CV* cv)
3972 {
3973     Perl_croak(aTHX_
3974        "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3975     );
3976 }
3977
3978 /*
3979  * ex: set ts=8 sts=4 sw=4 et:
3980  */