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