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