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