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