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