de205a1ab8a5d39f673cf84a18126f552839343d
[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_open: case KEY_pop:
1360             case KEY_push: case KEY_rand: case KEY_read:
1361             case KEY_recv: case KEY_reset:
1362             case KEY_select: case KEY_send:
1363             case KEY_setpgrp: case KEY_shift: case KEY_sleep:
1364             case KEY_splice:
1365             case KEY_srand: case KEY_stat: case KEY_substr:
1366             case KEY_sysopen: case KEY_sysread:
1367             case KEY_system: case KEY_syswrite:
1368             case KEY_tell: case KEY_tie: case KEY_tied:
1369             case KEY_truncate: case KEY_umask: case KEY_unlink:
1370             case KEY_unpack: case KEY_unshift: case KEY_untie:
1371             case KEY_values: case KEY_write:
1372                 ampable = FALSE;
1373             }
1374             if (ampable) {
1375                 ENTER;
1376                 oldcurcop = PL_curcop;
1377                 oldparser = PL_parser;
1378                 lex_start(NULL, NULL, 0);
1379                 oldcompcv = PL_compcv;
1380                 PL_compcv = NULL; /* Prevent start_subparse from setting
1381                                      CvOUTSIDE. */
1382                 oldsavestack_ix = start_subparse(FALSE,0);
1383                 cv = PL_compcv;
1384             }
1385             else {
1386                 /* Avoid calling newXS, as it calls us, and things start to
1387                    get hairy. */
1388                 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
1389                 GvCV_set(gv,cv);
1390                 GvCVGEN(gv) = 0;
1391                 mro_method_changed_in(GvSTASH(gv));
1392                 CvISXSUB_on(cv);
1393                 CvXSUB(cv) = core_xsub;
1394             }
1395             CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
1396                                  from PL_curcop. */
1397             (void)gv_fetchfile(file);
1398             CvFILE(cv) = (char *)file;
1399             /* XXX This is inefficient, as doing things this order causes
1400                    a prototype check in newATTRSUB.  But we have to do
1401                    it this order as we need an op number before calling
1402                    new ATTRSUB. */
1403             (void)core_prototype((SV *)cv, name, code, &opnum);
1404             if (ampable) {
1405                 if (opnum == OP_VEC || opnum == OP_LOCK) CvLVALUE_on(cv);
1406                 newATTRSUB(oldsavestack_ix,
1407                            newSVOP(
1408                                  OP_CONST, 0,
1409                                  newSVpvn_share(nambeg,full_len,0)
1410                            ),
1411                            NULL,NULL,
1412                            coresub_op(
1413                              opnum
1414                                ? newSVuv((UV)opnum)
1415                                : newSVpvn(name,len),
1416                              code, opnum
1417                            )
1418                 );
1419                 assert(GvCV(gv) == cv);
1420                 if (opnum == OP_LOCK)
1421                     CvLVALUE_off(cv); /* Now *that* was a neat trick. */
1422                 LEAVE;
1423                 PL_parser = oldparser;
1424                 PL_curcop = oldcurcop;
1425                 PL_compcv = oldcompcv;
1426             }
1427             opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
1428             cv_set_call_checker(
1429                cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
1430             );
1431             SvREFCNT_dec(opnumsv);
1432           }
1433         }
1434     }
1435     else if (len > 1) {
1436 #ifndef EBCDIC
1437         if (*name > 'V' ) {
1438             NOOP;
1439             /* Nothing else to do.
1440                The compiler will probably turn the switch statement into a
1441                branch table. Make sure we avoid even that small overhead for
1442                the common case of lower case variable names.  */
1443         } else
1444 #endif
1445         {
1446             const char * const name2 = name + 1;
1447             switch (*name) {
1448             case 'A':
1449                 if (strEQ(name2, "RGV")) {
1450                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1451                 }
1452                 else if (strEQ(name2, "RGVOUT")) {
1453                     GvMULTI_on(gv);
1454                 }
1455                 break;
1456             case 'E':
1457                 if (strnEQ(name2, "XPORT", 5))
1458                     GvMULTI_on(gv);
1459                 break;
1460             case 'I':
1461                 if (strEQ(name2, "SA")) {
1462                     gv_magicalize_isa(gv);
1463                 }
1464                 break;
1465             case 'O':
1466                 if (strEQ(name2, "VERLOAD")) {
1467                     gv_magicalize_overload(gv);
1468                 }
1469                 break;
1470             case 'S':
1471                 if (strEQ(name2, "IG")) {
1472                     HV *hv;
1473                     I32 i;
1474                     if (!PL_psig_name) {
1475                         Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1476                         Newxz(PL_psig_pend, SIG_SIZE, int);
1477                         PL_psig_ptr = PL_psig_name + SIG_SIZE;
1478                     } else {
1479                         /* I think that the only way to get here is to re-use an
1480                            embedded perl interpreter, where the previous
1481                            use didn't clean up fully because
1482                            PL_perl_destruct_level was 0. I'm not sure that we
1483                            "support" that, in that I suspect in that scenario
1484                            there are sufficient other garbage values left in the
1485                            interpreter structure that something else will crash
1486                            before we get here. I suspect that this is one of
1487                            those "doctor, it hurts when I do this" bugs.  */
1488                         Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1489                         Zero(PL_psig_pend, SIG_SIZE, int);
1490                     }
1491                     GvMULTI_on(gv);
1492                     hv = GvHVn(gv);
1493                     hv_magic(hv, NULL, PERL_MAGIC_sig);
1494                     for (i = 1; i < SIG_SIZE; i++) {
1495                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1496                         if (init)
1497                             sv_setsv(*init, &PL_sv_undef);
1498                     }
1499                 }
1500                 break;
1501             case 'V':
1502                 if (strEQ(name2, "ERSION"))
1503                     GvMULTI_on(gv);
1504                 break;
1505             case '\003':        /* $^CHILD_ERROR_NATIVE */
1506                 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1507                     goto magicalize;
1508                 break;
1509             case '\005':        /* $^ENCODING */
1510                 if (strEQ(name2, "NCODING"))
1511                     goto magicalize;
1512                 break;
1513             case '\007':        /* $^GLOBAL_PHASE */
1514                 if (strEQ(name2, "LOBAL_PHASE"))
1515                     goto ro_magicalize;
1516                 break;
1517             case '\015':        /* $^MATCH */
1518                 if (strEQ(name2, "ATCH"))
1519                     goto magicalize;
1520             case '\017':        /* $^OPEN */
1521                 if (strEQ(name2, "PEN"))
1522                     goto magicalize;
1523                 break;
1524             case '\020':        /* $^PREMATCH  $^POSTMATCH */
1525                 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1526                     goto magicalize;
1527                 break;
1528             case '\024':        /* ${^TAINT} */
1529                 if (strEQ(name2, "AINT"))
1530                     goto ro_magicalize;
1531                 break;
1532             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
1533                 if (strEQ(name2, "NICODE"))
1534                     goto ro_magicalize;
1535                 if (strEQ(name2, "TF8LOCALE"))
1536                     goto ro_magicalize;
1537                 if (strEQ(name2, "TF8CACHE"))
1538                     goto magicalize;
1539                 break;
1540             case '\027':        /* $^WARNING_BITS */
1541                 if (strEQ(name2, "ARNING_BITS"))
1542                     goto magicalize;
1543                 break;
1544             case '1':
1545             case '2':
1546             case '3':
1547             case '4':
1548             case '5':
1549             case '6':
1550             case '7':
1551             case '8':
1552             case '9':
1553             {
1554                 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1555                    this test  */
1556                 /* This snippet is taken from is_gv_magical */
1557                 const char *end = name + len;
1558                 while (--end > name) {
1559                     if (!isDIGIT(*end)) return gv;
1560                 }
1561                 goto magicalize;
1562             }
1563             }
1564         }
1565     } else {
1566         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
1567            be case '\0' in this switch statement (ie a default case)  */
1568         switch (*name) {
1569         case '&':               /* $& */
1570         case '`':               /* $` */
1571         case '\'':              /* $' */
1572             if (
1573                 sv_type == SVt_PVAV ||
1574                 sv_type == SVt_PVHV ||
1575                 sv_type == SVt_PVCV ||
1576                 sv_type == SVt_PVFM ||
1577                 sv_type == SVt_PVIO
1578                 ) { break; }
1579             PL_sawampersand = TRUE;
1580             goto magicalize;
1581
1582         case ':':               /* $: */
1583             sv_setpv(GvSVn(gv),PL_chopset);
1584             goto magicalize;
1585
1586         case '?':               /* $? */
1587 #ifdef COMPLEX_STATUS
1588             SvUPGRADE(GvSVn(gv), SVt_PVLV);
1589 #endif
1590             goto magicalize;
1591
1592         case '!':               /* $! */
1593             GvMULTI_on(gv);
1594             /* If %! has been used, automatically load Errno.pm. */
1595
1596             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1597
1598             /* magicalization must be done before require_tie_mod is called */
1599             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1600                 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1601
1602             break;
1603         case '-':               /* $- */
1604         case '+':               /* $+ */
1605         GvMULTI_on(gv); /* no used once warnings here */
1606         {
1607             AV* const av = GvAVn(gv);
1608             SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1609
1610             sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1611             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1612             if (avc)
1613                 SvREADONLY_on(GvSVn(gv));
1614             SvREADONLY_on(av);
1615
1616             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1617                 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1618
1619             break;
1620         }
1621         case '*':               /* $* */
1622         case '#':               /* $# */
1623             if (sv_type == SVt_PV)
1624                 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1625                                  "$%c is no longer supported", *name);
1626             break;
1627         case '|':               /* $| */
1628             sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1629             goto magicalize;
1630
1631         case '\010':    /* $^H */
1632             {
1633                 HV *const hv = GvHVn(gv);
1634                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1635             }
1636             goto magicalize;
1637         case '\023':    /* $^S */
1638         ro_magicalize:
1639             SvREADONLY_on(GvSVn(gv));
1640             /* FALL THROUGH */
1641         case '0':               /* $0 */
1642         case '1':               /* $1 */
1643         case '2':               /* $2 */
1644         case '3':               /* $3 */
1645         case '4':               /* $4 */
1646         case '5':               /* $5 */
1647         case '6':               /* $6 */
1648         case '7':               /* $7 */
1649         case '8':               /* $8 */
1650         case '9':               /* $9 */
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 '$':               /* $$ */
1664         case '\001':    /* $^A */
1665         case '\003':    /* $^C */
1666         case '\004':    /* $^D */
1667         case '\005':    /* $^E */
1668         case '\006':    /* $^F */
1669         case '\011':    /* $^I, NOT \t in EBCDIC */
1670         case '\016':    /* $^N */
1671         case '\017':    /* $^O */
1672         case '\020':    /* $^P */
1673         case '\024':    /* $^T */
1674         case '\027':    /* $^W */
1675         magicalize:
1676             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1677             break;
1678
1679         case '\014':    /* $^L */
1680             sv_setpvs(GvSVn(gv),"\f");
1681             PL_formfeed = GvSVn(gv);
1682             break;
1683         case ';':               /* $; */
1684             sv_setpvs(GvSVn(gv),"\034");
1685             break;
1686         case ']':               /* $] */
1687         {
1688             SV * const sv = GvSVn(gv);
1689             if (!sv_derived_from(PL_patchlevel, "version"))
1690                 upg_version(PL_patchlevel, TRUE);
1691             GvSV(gv) = vnumify(PL_patchlevel);
1692             SvREADONLY_on(GvSV(gv));
1693             SvREFCNT_dec(sv);
1694         }
1695         break;
1696         case '\026':    /* $^V */
1697         {
1698             SV * const sv = GvSVn(gv);
1699             GvSV(gv) = new_version(PL_patchlevel);
1700             SvREADONLY_on(GvSV(gv));
1701             SvREFCNT_dec(sv);
1702         }
1703         break;
1704         }
1705     }
1706     return gv;
1707 }
1708
1709 void
1710 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1711 {
1712     const char *name;
1713     STRLEN namelen;
1714     const HV * const hv = GvSTASH(gv);
1715
1716     PERL_ARGS_ASSERT_GV_FULLNAME4;
1717
1718     if (!hv) {
1719         SvOK_off(sv);
1720         return;
1721     }
1722     sv_setpv(sv, prefix ? prefix : "");
1723
1724     name = HvNAME_get(hv);
1725     if (name) {
1726         namelen = HvNAMELEN_get(hv);
1727     } else {
1728         name = "__ANON__";
1729         namelen = 8;
1730     }
1731
1732     if (keepmain || strNE(name, "main")) {
1733         sv_catpvn(sv,name,namelen);
1734         sv_catpvs(sv,"::");
1735     }
1736     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1737 }
1738
1739 void
1740 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1741 {
1742     const GV * const egv = GvEGVx(gv);
1743
1744     PERL_ARGS_ASSERT_GV_EFULLNAME4;
1745
1746     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1747 }
1748
1749 void
1750 Perl_gv_check(pTHX_ const HV *stash)
1751 {
1752     dVAR;
1753     register I32 i;
1754
1755     PERL_ARGS_ASSERT_GV_CHECK;
1756
1757     if (!HvARRAY(stash))
1758         return;
1759     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1760         const HE *entry;
1761         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1762             register GV *gv;
1763             HV *hv;
1764             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1765                 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
1766             {
1767                 if (hv != PL_defstash && hv != stash)
1768                      gv_check(hv);              /* nested package */
1769             }
1770             else if (isALPHA(*HeKEY(entry))) {
1771                 const char *file;
1772                 gv = MUTABLE_GV(HeVAL(entry));
1773                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1774                     continue;
1775                 file = GvFILE(gv);
1776                 CopLINE_set(PL_curcop, GvLINE(gv));
1777 #ifdef USE_ITHREADS
1778                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
1779 #else
1780                 CopFILEGV(PL_curcop)
1781                     = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
1782 #endif
1783                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1784                         "Name \"%s::%s\" used only once: possible typo",
1785                         HvNAME_get(stash), GvNAME(gv));
1786             }
1787         }
1788     }
1789 }
1790
1791 GV *
1792 Perl_newGVgen(pTHX_ const char *pack)
1793 {
1794     dVAR;
1795
1796     PERL_ARGS_ASSERT_NEWGVGEN;
1797
1798     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1799                       GV_ADD, SVt_PVGV);
1800 }
1801
1802 /* hopefully this is only called on local symbol table entries */
1803
1804 GP*
1805 Perl_gp_ref(pTHX_ GP *gp)
1806 {
1807     dVAR;
1808     if (!gp)
1809         return NULL;
1810     gp->gp_refcnt++;
1811     if (gp->gp_cv) {
1812         if (gp->gp_cvgen) {
1813             /* If the GP they asked for a reference to contains
1814                a method cache entry, clear it first, so that we
1815                don't infect them with our cached entry */
1816             SvREFCNT_dec(gp->gp_cv);
1817             gp->gp_cv = NULL;
1818             gp->gp_cvgen = 0;
1819         }
1820     }
1821     return gp;
1822 }
1823
1824 void
1825 Perl_gp_free(pTHX_ GV *gv)
1826 {
1827     dVAR;
1828     GP* gp;
1829     int attempts = 100;
1830
1831     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1832         return;
1833     if (gp->gp_refcnt == 0) {
1834         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1835                          "Attempt to free unreferenced glob pointers"
1836                          pTHX__FORMAT pTHX__VALUE);
1837         return;
1838     }
1839     if (--gp->gp_refcnt > 0) {
1840         if (gp->gp_egv == gv)
1841             gp->gp_egv = 0;
1842         GvGP_set(gv, NULL);
1843         return;
1844     }
1845
1846     while (1) {
1847       /* Copy and null out all the glob slots, so destructors do not see
1848          freed SVs. */
1849       HEK * const file_hek = gp->gp_file_hek;
1850       SV  * const sv       = gp->gp_sv;
1851       AV  * const av       = gp->gp_av;
1852       HV  * const hv       = gp->gp_hv;
1853       IO  * const io       = gp->gp_io;
1854       CV  * const cv       = gp->gp_cv;
1855       CV  * const form     = gp->gp_form;
1856
1857       gp->gp_file_hek = NULL;
1858       gp->gp_sv       = NULL;
1859       gp->gp_av       = NULL;
1860       gp->gp_hv       = NULL;
1861       gp->gp_io       = NULL;
1862       gp->gp_cv       = NULL;
1863       gp->gp_form     = NULL;
1864
1865       if (file_hek)
1866         unshare_hek(file_hek);
1867
1868       SvREFCNT_dec(sv);
1869       SvREFCNT_dec(av);
1870       /* FIXME - another reference loop GV -> symtab -> GV ?
1871          Somehow gp->gp_hv can end up pointing at freed garbage.  */
1872       if (hv && SvTYPE(hv) == SVt_PVHV) {
1873         const char *hvname = HvNAME_get(hv);
1874         if (PL_stashcache && hvname)
1875             (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(hv),
1876                       G_DISCARD);
1877         SvREFCNT_dec(hv);
1878       }
1879       SvREFCNT_dec(io);
1880       SvREFCNT_dec(cv);
1881       SvREFCNT_dec(form);
1882
1883       if (!gp->gp_file_hek
1884        && !gp->gp_sv
1885        && !gp->gp_av
1886        && !gp->gp_hv
1887        && !gp->gp_io
1888        && !gp->gp_cv
1889        && !gp->gp_form) break;
1890
1891       if (--attempts == 0) {
1892         Perl_die(aTHX_
1893           "panic: gp_free failed to free glob pointer - "
1894           "something is repeatedly re-creating entries"
1895         );
1896       }
1897     }
1898
1899     Safefree(gp);
1900     GvGP_set(gv, NULL);
1901 }
1902
1903 int
1904 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1905 {
1906     AMT * const amtp = (AMT*)mg->mg_ptr;
1907     PERL_UNUSED_ARG(sv);
1908
1909     PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
1910
1911     if (amtp && AMT_AMAGIC(amtp)) {
1912         int i;
1913         for (i = 1; i < NofAMmeth; i++) {
1914             CV * const cv = amtp->table[i];
1915             if (cv) {
1916                 SvREFCNT_dec(MUTABLE_SV(cv));
1917                 amtp->table[i] = NULL;
1918             }
1919         }
1920     }
1921  return 0;
1922 }
1923
1924 /* Updates and caches the CV's */
1925 /* Returns:
1926  * 1 on success and there is some overload
1927  * 0 if there is no overload
1928  * -1 if some error occurred and it couldn't croak
1929  */
1930
1931 int
1932 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
1933 {
1934   dVAR;
1935   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
1936   AMT amt;
1937   const struct mro_meta* stash_meta = HvMROMETA(stash);
1938   U32 newgen;
1939
1940   PERL_ARGS_ASSERT_GV_AMUPDATE;
1941
1942   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
1943   if (mg) {
1944       const AMT * const amtp = (AMT*)mg->mg_ptr;
1945       if (amtp->was_ok_am == PL_amagic_generation
1946           && amtp->was_ok_sub == newgen) {
1947           return AMT_OVERLOADED(amtp) ? 1 : 0;
1948       }
1949       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
1950   }
1951
1952   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1953
1954   Zero(&amt,1,AMT);
1955   amt.was_ok_am = PL_amagic_generation;
1956   amt.was_ok_sub = newgen;
1957   amt.fallback = AMGfallNO;
1958   amt.flags = 0;
1959
1960   {
1961     int filled = 0, have_ovl = 0;
1962     int i, lim = 1;
1963
1964     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1965
1966     /* Try to find via inheritance. */
1967     GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1968     SV * const sv = gv ? GvSV(gv) : NULL;
1969     CV* cv;
1970
1971     if (!gv)
1972         lim = DESTROY_amg;              /* Skip overloading entries. */
1973 #ifdef PERL_DONT_CREATE_GVSV
1974     else if (!sv) {
1975         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
1976     }
1977 #endif
1978     else if (SvTRUE(sv))
1979         amt.fallback=AMGfallYES;
1980     else if (SvOK(sv))
1981         amt.fallback=AMGfallNEVER;
1982
1983     for (i = 1; i < lim; i++)
1984         amt.table[i] = NULL;
1985     for (; i < NofAMmeth; i++) {
1986         const char * const cooky = PL_AMG_names[i];
1987         /* Human-readable form, for debugging: */
1988         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1989         const STRLEN l = PL_AMG_namelens[i];
1990
1991         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1992                      cp, HvNAME_get(stash)) );
1993         /* don't fill the cache while looking up!
1994            Creation of inheritance stubs in intermediate packages may
1995            conflict with the logic of runtime method substitution.
1996            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1997            then we could have created stubs for "(+0" in A and C too.
1998            But if B overloads "bool", we may want to use it for
1999            numifying instead of C's "+0". */
2000         if (i >= DESTROY_amg)
2001             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
2002         else                            /* Autoload taken care of below */
2003             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
2004         cv = 0;
2005         if (gv && (cv = GvCV(gv))) {
2006             const char *hvname;
2007             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
2008                 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
2009                 /* This is a hack to support autoloading..., while
2010                    knowing *which* methods were declared as overloaded. */
2011                 /* GvSV contains the name of the method. */
2012                 GV *ngv = NULL;
2013                 SV *gvsv = GvSV(gv);
2014
2015                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2016                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
2017                              (void*)GvSV(gv), cp, hvname) );
2018                 if (!gvsv || !SvPOK(gvsv)
2019                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
2020                                                        FALSE)))
2021                 {
2022                     /* Can be an import stub (created by "can"). */
2023                     if (destructing) {
2024                         return -1;
2025                     }
2026                     else {
2027                         const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
2028                         Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
2029                                     "in package \"%.256s\"",
2030                                    (GvCVGEN(gv) ? "Stub found while resolving"
2031                                     : "Can't resolve"),
2032                                    name, cp, hvname);
2033                     }
2034                 }
2035                 cv = GvCV(gv = ngv);
2036             }
2037             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2038                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2039                          GvNAME(CvGV(cv))) );
2040             filled = 1;
2041             if (i < DESTROY_amg)
2042                 have_ovl = 1;
2043         } else if (gv) {                /* Autoloaded... */
2044             cv = MUTABLE_CV(gv);
2045             filled = 1;
2046         }
2047         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2048     }
2049     if (filled) {
2050       AMT_AMAGIC_on(&amt);
2051       if (have_ovl)
2052           AMT_OVERLOADED_on(&amt);
2053       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2054                                                 (char*)&amt, sizeof(AMT));
2055       return have_ovl;
2056     }
2057   }
2058   /* Here we have no table: */
2059   /* no_table: */
2060   AMT_AMAGIC_off(&amt);
2061   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2062                                                 (char*)&amt, sizeof(AMTS));
2063   return 0;
2064 }
2065
2066
2067 CV*
2068 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2069 {
2070     dVAR;
2071     MAGIC *mg;
2072     AMT *amtp;
2073     U32 newgen;
2074     struct mro_meta* stash_meta;
2075
2076     if (!stash || !HvNAME_get(stash))
2077         return NULL;
2078
2079     stash_meta = HvMROMETA(stash);
2080     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2081
2082     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2083     if (!mg) {
2084       do_update:
2085         /* If we're looking up a destructor to invoke, we must avoid
2086          * that Gv_AMupdate croaks, because we might be dying already */
2087         if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
2088             /* and if it didn't found a destructor, we fall back
2089              * to a simpler method that will only look for the
2090              * destructor instead of the whole magic */
2091             if (id == DESTROY_amg) {
2092                 GV * const gv = gv_fetchmethod(stash, "DESTROY");
2093                 if (gv)
2094                     return GvCV(gv);
2095             }
2096             return NULL;
2097         }
2098         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2099     }
2100     assert(mg);
2101     amtp = (AMT*)mg->mg_ptr;
2102     if ( amtp->was_ok_am != PL_amagic_generation
2103          || amtp->was_ok_sub != newgen )
2104         goto do_update;
2105     if (AMT_AMAGIC(amtp)) {
2106         CV * const ret = amtp->table[id];
2107         if (ret && isGV(ret)) {         /* Autoloading stab */
2108             /* Passing it through may have resulted in a warning
2109                "Inherited AUTOLOAD for a non-method deprecated", since
2110                our caller is going through a function call, not a method call.
2111                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2112             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2113
2114             if (gv && GvCV(gv))
2115                 return GvCV(gv);
2116         }
2117         return ret;
2118     }
2119
2120     return NULL;
2121 }
2122
2123
2124 /* Implement tryAMAGICun_MG macro.
2125    Do get magic, then see if the stack arg is overloaded and if so call it.
2126    Flags:
2127         AMGf_set     return the arg using SETs rather than assigning to
2128                      the targ
2129         AMGf_numeric apply sv_2num to the stack arg.
2130 */
2131
2132 bool
2133 Perl_try_amagic_un(pTHX_ int method, int flags) {
2134     dVAR;
2135     dSP;
2136     SV* tmpsv;
2137     SV* const arg = TOPs;
2138
2139     SvGETMAGIC(arg);
2140
2141     if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2142                                               AMGf_noright | AMGf_unary))) {
2143         if (flags & AMGf_set) {
2144             SETs(tmpsv);
2145         }
2146         else {
2147             dTARGET;
2148             if (SvPADMY(TARG)) {
2149                 sv_setsv(TARG, tmpsv);
2150                 SETTARG;
2151             }
2152             else
2153                 SETs(tmpsv);
2154         }
2155         PUTBACK;
2156         return TRUE;
2157     }
2158
2159     if ((flags & AMGf_numeric) && SvROK(arg))
2160         *sp = sv_2num(arg);
2161     return FALSE;
2162 }
2163
2164
2165 /* Implement tryAMAGICbin_MG macro.
2166    Do get magic, then see if the two stack args are overloaded and if so
2167    call it.
2168    Flags:
2169         AMGf_set     return the arg using SETs rather than assigning to
2170                      the targ
2171         AMGf_assign  op may be called as mutator (eg +=)
2172         AMGf_numeric apply sv_2num to the stack arg.
2173 */
2174
2175 bool
2176 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2177     dVAR;
2178     dSP;
2179     SV* const left = TOPm1s;
2180     SV* const right = TOPs;
2181
2182     SvGETMAGIC(left);
2183     if (left != right)
2184         SvGETMAGIC(right);
2185
2186     if (SvAMAGIC(left) || SvAMAGIC(right)) {
2187         SV * const tmpsv = amagic_call(left, right, method,
2188                     ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2189         if (tmpsv) {
2190             if (flags & AMGf_set) {
2191                 (void)POPs;
2192                 SETs(tmpsv);
2193             }
2194             else {
2195                 dATARGET;
2196                 (void)POPs;
2197                 if (opASSIGN || SvPADMY(TARG)) {
2198                     sv_setsv(TARG, tmpsv);
2199                     SETTARG;
2200                 }
2201                 else
2202                     SETs(tmpsv);
2203             }
2204             PUTBACK;
2205             return TRUE;
2206         }
2207     }
2208     if(left==right && SvGMAGICAL(left)) {
2209         SV * const left = sv_newmortal();
2210         *(sp-1) = left;
2211         /* Print the uninitialized warning now, so it includes the vari-
2212            able name. */
2213         if (!SvOK(right)) {
2214             if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2215             sv_setsv_flags(left, &PL_sv_no, 0);
2216         }
2217         else sv_setsv_flags(left, right, 0);
2218         SvGETMAGIC(right);
2219     }
2220     if (flags & AMGf_numeric) {
2221         if (SvROK(TOPm1s))
2222             *(sp-1) = sv_2num(TOPm1s);
2223         if (SvROK(right))
2224             *sp     = sv_2num(right);
2225     }
2226     return FALSE;
2227 }
2228
2229 SV *
2230 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2231     SV *tmpsv = NULL;
2232
2233     PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2234
2235     while (SvAMAGIC(ref) && 
2236            (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2237                                 AMGf_noright | AMGf_unary))) { 
2238         if (!SvROK(tmpsv))
2239             Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2240         if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2241             /* Bail out if it returns us the same reference.  */
2242             return tmpsv;
2243         }
2244         ref = tmpsv;
2245     }
2246     return tmpsv ? tmpsv : ref;
2247 }
2248
2249 SV*
2250 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2251 {
2252   dVAR;
2253   MAGIC *mg;
2254   CV *cv=NULL;
2255   CV **cvp=NULL, **ocvp=NULL;
2256   AMT *amtp=NULL, *oamtp=NULL;
2257   int off = 0, off1, lr = 0, notfound = 0;
2258   int postpr = 0, force_cpy = 0;
2259   int assign = AMGf_assign & flags;
2260   const int assignshift = assign ? 1 : 0;
2261   int use_default_op = 0;
2262 #ifdef DEBUGGING
2263   int fl=0;
2264 #endif
2265   HV* stash=NULL;
2266
2267   PERL_ARGS_ASSERT_AMAGIC_CALL;
2268
2269   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2270       SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2271
2272       if ( !lex_mask || !SvOK(lex_mask) )
2273           /* overloading lexically disabled */
2274           return NULL;
2275       else if ( lex_mask && SvPOK(lex_mask) ) {
2276           /* we have an entry in the hints hash, check if method has been
2277            * masked by overloading.pm */
2278           STRLEN len;
2279           const int offset = method / 8;
2280           const int bit    = method % 8;
2281           char *pv = SvPV(lex_mask, len);
2282
2283           /* Bit set, so this overloading operator is disabled */
2284           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2285               return NULL;
2286       }
2287   }
2288
2289   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2290       && (stash = SvSTASH(SvRV(left)))
2291       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2292       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2293                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2294                         : NULL))
2295       && ((cv = cvp[off=method+assignshift])
2296           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2297                                                           * usual method */
2298                   (
2299 #ifdef DEBUGGING
2300                    fl = 1,
2301 #endif
2302                    cv = cvp[off=method])))) {
2303     lr = -1;                    /* Call method for left argument */
2304   } else {
2305     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2306       int logic;
2307
2308       /* look for substituted methods */
2309       /* In all the covered cases we should be called with assign==0. */
2310          switch (method) {
2311          case inc_amg:
2312            force_cpy = 1;
2313            if ((cv = cvp[off=add_ass_amg])
2314                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2315              right = &PL_sv_yes; lr = -1; assign = 1;
2316            }
2317            break;
2318          case dec_amg:
2319            force_cpy = 1;
2320            if ((cv = cvp[off = subtr_ass_amg])
2321                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2322              right = &PL_sv_yes; lr = -1; assign = 1;
2323            }
2324            break;
2325          case bool__amg:
2326            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2327            break;
2328          case numer_amg:
2329            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2330            break;
2331          case string_amg:
2332            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2333            break;
2334          case not_amg:
2335            (void)((cv = cvp[off=bool__amg])
2336                   || (cv = cvp[off=numer_amg])
2337                   || (cv = cvp[off=string_amg]));
2338            if (cv)
2339                postpr = 1;
2340            break;
2341          case copy_amg:
2342            {
2343              /*
2344                   * SV* ref causes confusion with the interpreter variable of
2345                   * the same name
2346                   */
2347              SV* const tmpRef=SvRV(left);
2348              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2349                 /*
2350                  * Just to be extra cautious.  Maybe in some
2351                  * additional cases sv_setsv is safe, too.
2352                  */
2353                 SV* const newref = newSVsv(tmpRef);
2354                 SvOBJECT_on(newref);
2355                 /* As a bit of a source compatibility hack, SvAMAGIC() and
2356                    friends dereference an RV, to behave the same was as when
2357                    overloading was stored on the reference, not the referant.
2358                    Hence we can't use SvAMAGIC_on()
2359                 */
2360                 SvFLAGS(newref) |= SVf_AMAGIC;
2361                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2362                 return newref;
2363              }
2364            }
2365            break;
2366          case abs_amg:
2367            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2368                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2369              SV* const nullsv=sv_2mortal(newSViv(0));
2370              if (off1==lt_amg) {
2371                SV* const lessp = amagic_call(left,nullsv,
2372                                        lt_amg,AMGf_noright);
2373                logic = SvTRUE(lessp);
2374              } else {
2375                SV* const lessp = amagic_call(left,nullsv,
2376                                        ncmp_amg,AMGf_noright);
2377                logic = (SvNV(lessp) < 0);
2378              }
2379              if (logic) {
2380                if (off==subtr_amg) {
2381                  right = left;
2382                  left = nullsv;
2383                  lr = 1;
2384                }
2385              } else {
2386                return left;
2387              }
2388            }
2389            break;
2390          case neg_amg:
2391            if ((cv = cvp[off=subtr_amg])) {
2392              right = left;
2393              left = sv_2mortal(newSViv(0));
2394              lr = 1;
2395            }
2396            break;
2397          case int_amg:
2398          case iter_amg:                 /* XXXX Eventually should do to_gv. */
2399          case ftest_amg:                /* XXXX Eventually should do to_gv. */
2400          case regexp_amg:
2401              /* FAIL safe */
2402              return NULL;       /* Delegate operation to standard mechanisms. */
2403              break;
2404          case to_sv_amg:
2405          case to_av_amg:
2406          case to_hv_amg:
2407          case to_gv_amg:
2408          case to_cv_amg:
2409              /* FAIL safe */
2410              return left;       /* Delegate operation to standard mechanisms. */
2411              break;
2412          default:
2413            goto not_found;
2414          }
2415          if (!cv) goto not_found;
2416     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2417                && (stash = SvSTASH(SvRV(right)))
2418                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2419                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2420                           ? (amtp = (AMT*)mg->mg_ptr)->table
2421                           : NULL))
2422                && (cv = cvp[off=method])) { /* Method for right
2423                                              * argument found */
2424       lr=1;
2425     } else if (((cvp && amtp->fallback > AMGfallNEVER)
2426                 || (ocvp && oamtp->fallback > AMGfallNEVER))
2427                && !(flags & AMGf_unary)) {
2428                                 /* We look for substitution for
2429                                  * comparison operations and
2430                                  * concatenation */
2431       if (method==concat_amg || method==concat_ass_amg
2432           || method==repeat_amg || method==repeat_ass_amg) {
2433         return NULL;            /* Delegate operation to string conversion */
2434       }
2435       off = -1;
2436       switch (method) {
2437          case lt_amg:
2438          case le_amg:
2439          case gt_amg:
2440          case ge_amg:
2441          case eq_amg:
2442          case ne_amg:
2443              off = ncmp_amg;
2444              break;
2445          case slt_amg:
2446          case sle_amg:
2447          case sgt_amg:
2448          case sge_amg:
2449          case seq_amg:
2450          case sne_amg:
2451              off = scmp_amg;
2452              break;
2453          }
2454       if (off != -1) {
2455           if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2456               cv = ocvp[off];
2457               lr = -1;
2458           }
2459           if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2460               cv = cvp[off];
2461               lr = 1;
2462           }
2463       }
2464       if (cv)
2465           postpr = 1;
2466       else
2467           goto not_found;
2468     } else {
2469     not_found:                  /* No method found, either report or croak */
2470       switch (method) {
2471          case to_sv_amg:
2472          case to_av_amg:
2473          case to_hv_amg:
2474          case to_gv_amg:
2475          case to_cv_amg:
2476              /* FAIL safe */
2477              return left;       /* Delegate operation to standard mechanisms. */
2478              break;
2479       }
2480       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2481         notfound = 1; lr = -1;
2482       } else if (cvp && (cv=cvp[nomethod_amg])) {
2483         notfound = 1; lr = 1;
2484       } else if ((use_default_op =
2485                   (!ocvp || oamtp->fallback >= AMGfallYES)
2486                   && (!cvp || amtp->fallback >= AMGfallYES))
2487                  && !DEBUG_o_TEST) {
2488         /* Skip generating the "no method found" message.  */
2489         return NULL;
2490       } else {
2491         SV *msg;
2492         if (off==-1) off=method;
2493         msg = sv_2mortal(Perl_newSVpvf(aTHX_
2494                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
2495                       AMG_id2name(method + assignshift),
2496                       (flags & AMGf_unary ? " " : "\n\tleft "),
2497                       SvAMAGIC(left)?
2498                         "in overloaded package ":
2499                         "has no overloaded magic",
2500                       SvAMAGIC(left)?
2501                         HvNAME_get(SvSTASH(SvRV(left))):
2502                         "",
2503                       SvAMAGIC(right)?
2504                         ",\n\tright argument in overloaded package ":
2505                         (flags & AMGf_unary
2506                          ? ""
2507                          : ",\n\tright argument has no overloaded magic"),
2508                       SvAMAGIC(right)?
2509                         HvNAME_get(SvSTASH(SvRV(right))):
2510                         ""));
2511         if (use_default_op) {
2512           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
2513         } else {
2514           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2515         }
2516         return NULL;
2517       }
2518       force_cpy = force_cpy || assign;
2519     }
2520   }
2521 #ifdef DEBUGGING
2522   if (!notfound) {
2523     DEBUG_o(Perl_deb(aTHX_
2524                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
2525                      AMG_id2name(off),
2526                      method+assignshift==off? "" :
2527                      " (initially \"",
2528                      method+assignshift==off? "" :
2529                      AMG_id2name(method+assignshift),
2530                      method+assignshift==off? "" : "\")",
2531                      flags & AMGf_unary? "" :
2532                      lr==1 ? " for right argument": " for left argument",
2533                      flags & AMGf_unary? " for argument" : "",
2534                      stash ? HvNAME_get(stash) : "null",
2535                      fl? ",\n\tassignment variant used": "") );
2536   }
2537 #endif
2538     /* Since we use shallow copy during assignment, we need
2539      * to dublicate the contents, probably calling user-supplied
2540      * version of copy operator
2541      */
2542     /* We need to copy in following cases:
2543      * a) Assignment form was called.
2544      *          assignshift==1,  assign==T, method + 1 == off
2545      * b) Increment or decrement, called directly.
2546      *          assignshift==0,  assign==0, method + 0 == off
2547      * c) Increment or decrement, translated to assignment add/subtr.
2548      *          assignshift==0,  assign==T,
2549      *          force_cpy == T
2550      * d) Increment or decrement, translated to nomethod.
2551      *          assignshift==0,  assign==0,
2552      *          force_cpy == T
2553      * e) Assignment form translated to nomethod.
2554      *          assignshift==1,  assign==T, method + 1 != off
2555      *          force_cpy == T
2556      */
2557     /*  off is method, method+assignshift, or a result of opcode substitution.
2558      *  In the latter case assignshift==0, so only notfound case is important.
2559      */
2560   if (( (method + assignshift == off)
2561         && (assign || (method == inc_amg) || (method == dec_amg)))
2562       || force_cpy)
2563   {
2564       /* newSVsv does not behave as advertised, so we copy missing
2565        * information by hand */
2566       SV *tmpRef = SvRV(left);
2567       SV *rv_copy;
2568       if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
2569           SvRV_set(left, rv_copy);
2570           SvSETMAGIC(left);
2571           SvREFCNT_dec(tmpRef);  
2572       }
2573   }
2574
2575   {
2576     dSP;
2577     BINOP myop;
2578     SV* res;
2579     const bool oldcatch = CATCH_GET;
2580
2581     CATCH_SET(TRUE);
2582     Zero(&myop, 1, BINOP);
2583     myop.op_last = (OP *) &myop;
2584     myop.op_next = NULL;
2585     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
2586
2587     PUSHSTACKi(PERLSI_OVERLOAD);
2588     ENTER;
2589     SAVEOP();
2590     PL_op = (OP *) &myop;
2591     if (PERLDB_SUB && PL_curstash != PL_debstash)
2592         PL_op->op_private |= OPpENTERSUB_DB;
2593     PUTBACK;
2594     Perl_pp_pushmark(aTHX);
2595
2596     EXTEND(SP, notfound + 5);
2597     PUSHs(lr>0? right: left);
2598     PUSHs(lr>0? left: right);
2599     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
2600     if (notfound) {
2601       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
2602                            AMG_id2namelen(method + assignshift), SVs_TEMP));
2603     }
2604     PUSHs(MUTABLE_SV(cv));
2605     PUTBACK;
2606
2607     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
2608       CALLRUNOPS(aTHX);
2609     LEAVE;
2610     SPAGAIN;
2611
2612     res=POPs;
2613     PUTBACK;
2614     POPSTACK;
2615     CATCH_SET(oldcatch);
2616
2617     if (postpr) {
2618       int ans;
2619       switch (method) {
2620       case le_amg:
2621       case sle_amg:
2622         ans=SvIV(res)<=0; break;
2623       case lt_amg:
2624       case slt_amg:
2625         ans=SvIV(res)<0; break;
2626       case ge_amg:
2627       case sge_amg:
2628         ans=SvIV(res)>=0; break;
2629       case gt_amg:
2630       case sgt_amg:
2631         ans=SvIV(res)>0; break;
2632       case eq_amg:
2633       case seq_amg:
2634         ans=SvIV(res)==0; break;
2635       case ne_amg:
2636       case sne_amg:
2637         ans=SvIV(res)!=0; break;
2638       case inc_amg:
2639       case dec_amg:
2640         SvSetSV(left,res); return left;
2641       case not_amg:
2642         ans=!SvTRUE(res); break;
2643       default:
2644         ans=0; break;
2645       }
2646       return boolSV(ans);
2647     } else if (method==copy_amg) {
2648       if (!SvROK(res)) {
2649         Perl_croak(aTHX_ "Copy method did not return a reference");
2650       }
2651       return SvREFCNT_inc(SvRV(res));
2652     } else {
2653       return res;
2654     }
2655   }
2656 }
2657
2658 /*
2659 =for apidoc is_gv_magical_sv
2660
2661 Returns C<TRUE> if given the name of a magical GV.  Any get-magic that
2662 C<name_sv> has is ignored.
2663
2664 Currently only useful internally when determining if a GV should be
2665 created even in rvalue contexts.
2666
2667 C<flags> is not used at present but available for future extension to
2668 allow selecting particular classes of magical variable.
2669
2670 =cut
2671 */
2672
2673 bool
2674 Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags)
2675 {
2676     STRLEN len;
2677     const char *const name = SvPV_nomg_const(name_sv, len);
2678
2679     PERL_UNUSED_ARG(flags);
2680     PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV;
2681
2682     if (len > 1) {
2683         const char * const name1 = name + 1;
2684         switch (*name) {
2685         case 'I':
2686             if (len == 3 && name[1] == 'S' && name[2] == 'A')
2687                 goto yes;
2688             break;
2689         case 'O':
2690             if (len == 8 && strEQ(name1, "VERLOAD"))
2691                 goto yes;
2692             break;
2693         case 'S':
2694             if (len == 3 && name[1] == 'I' && name[2] == 'G')
2695                 goto yes;
2696             break;
2697             /* Using ${^...} variables is likely to be sufficiently rare that
2698                it seems sensible to avoid the space hit of also checking the
2699                length.  */
2700         case '\017':   /* ${^OPEN} */
2701             if (strEQ(name1, "PEN"))
2702                 goto yes;
2703             break;
2704         case '\024':   /* ${^TAINT} */
2705             if (strEQ(name1, "AINT"))
2706                 goto yes;
2707             break;
2708         case '\025':    /* ${^UNICODE} */
2709             if (strEQ(name1, "NICODE"))
2710                 goto yes;
2711             if (strEQ(name1, "TF8LOCALE"))
2712                 goto yes;
2713             break;
2714         case '\027':   /* ${^WARNING_BITS} */
2715             if (strEQ(name1, "ARNING_BITS"))
2716                 goto yes;
2717             break;
2718         case '1':
2719         case '2':
2720         case '3':
2721         case '4':
2722         case '5':
2723         case '6':
2724         case '7':
2725         case '8':
2726         case '9':
2727         {
2728             const char *end = name + len;
2729             while (--end > name) {
2730                 if (!isDIGIT(*end))
2731                     return FALSE;
2732             }
2733             goto yes;
2734         }
2735         }
2736     } else {
2737         /* Because we're already assuming that name is NUL terminated
2738            below, we can treat an empty name as "\0"  */
2739         switch (*name) {
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 ']':
2765         case '\001':   /* $^A */
2766         case '\003':   /* $^C */
2767         case '\004':   /* $^D */
2768         case '\005':   /* $^E */
2769         case '\006':   /* $^F */
2770         case '\010':   /* $^H */
2771         case '\011':   /* $^I, NOT \t in EBCDIC */
2772         case '\014':   /* $^L */
2773         case '\016':   /* $^N */
2774         case '\017':   /* $^O */
2775         case '\020':   /* $^P */
2776         case '\023':   /* $^S */
2777         case '\024':   /* $^T */
2778         case '\026':   /* $^V */
2779         case '\027':   /* $^W */
2780         case '1':
2781         case '2':
2782         case '3':
2783         case '4':
2784         case '5':
2785         case '6':
2786         case '7':
2787         case '8':
2788         case '9':
2789         yes:
2790             return TRUE;
2791         default:
2792             break;
2793         }
2794     }
2795     return FALSE;
2796 }
2797
2798 void
2799 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2800 {
2801     dVAR;
2802     U32 hash;
2803
2804     PERL_ARGS_ASSERT_GV_NAME_SET;
2805     PERL_UNUSED_ARG(flags);
2806
2807     if (len > I32_MAX)
2808         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2809
2810     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2811         unshare_hek(GvNAME_HEK(gv));
2812     }
2813
2814     PERL_HASH(hash, name, len);
2815     GvNAME_HEK(gv) = share_hek(name, len, hash);
2816 }
2817
2818 /*
2819 =for apidoc gv_try_downgrade
2820
2821 If the typeglob C<gv> can be expressed more succinctly, by having
2822 something other than a real GV in its place in the stash, replace it
2823 with the optimised form.  Basic requirements for this are that C<gv>
2824 is a real typeglob, is sufficiently ordinary, and is only referenced
2825 from its package.  This function is meant to be used when a GV has been
2826 looked up in part to see what was there, causing upgrading, but based
2827 on what was found it turns out that the real GV isn't required after all.
2828
2829 If C<gv> is a completely empty typeglob, it is deleted from the stash.
2830
2831 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
2832 sub, the typeglob is replaced with a scalar-reference placeholder that
2833 more compactly represents the same thing.
2834
2835 =cut
2836 */
2837
2838 void
2839 Perl_gv_try_downgrade(pTHX_ GV *gv)
2840 {
2841     HV *stash;
2842     CV *cv;
2843     HEK *namehek;
2844     SV **gvp;
2845     PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
2846
2847     /* XXX Why and where does this leave dangling pointers during global
2848        destruction? */
2849     if (PL_phase == PERL_PHASE_DESTRUCT) return;
2850
2851     if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
2852             !SvOBJECT(gv) && !SvREADONLY(gv) &&
2853             isGV_with_GP(gv) && GvGP(gv) &&
2854             !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
2855             !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
2856             GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
2857         return;
2858     if (SvMAGICAL(gv)) {
2859         MAGIC *mg;
2860         /* only backref magic is allowed */
2861         if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
2862             return;
2863         for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
2864             if (mg->mg_type != PERL_MAGIC_backref)
2865                 return;
2866         }
2867     }
2868     cv = GvCV(gv);
2869     if (!cv) {
2870         HEK *gvnhek = GvNAME_HEK(gv);
2871         (void)hv_delete(stash, HEK_KEY(gvnhek),
2872             HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
2873     } else if (GvMULTI(gv) && cv &&
2874             !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
2875             CvSTASH(cv) == stash && CvGV(cv) == gv &&
2876             CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
2877             !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
2878             (namehek = GvNAME_HEK(gv)) &&
2879             (gvp = hv_fetch(stash, HEK_KEY(namehek),
2880                         HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
2881             *gvp == (SV*)gv) {
2882         SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
2883         SvREFCNT(gv) = 0;
2884         sv_clear((SV*)gv);
2885         SvREFCNT(gv) = 1;
2886         SvFLAGS(gv) = SVt_IV|SVf_ROK;
2887         SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
2888                                 STRUCT_OFFSET(XPVIV, xiv_iv));
2889         SvRV_set(gv, value);
2890     }
2891 }
2892
2893 #include "XSUB.h"
2894
2895 static void
2896 core_xsub(pTHX_ CV* cv)
2897 {
2898     Perl_croak(aTHX_
2899        "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
2900     );
2901 }
2902
2903 /*
2904  * Local variables:
2905  * c-indentation-style: bsd
2906  * c-basic-offset: 4
2907  * indent-tabs-mode: t
2908  * End:
2909  *
2910  * ex: set ts=8 sts=4 sw=4 noet:
2911  */