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