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