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