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