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