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