source: trunk/third/perl/gv.c @ 18450

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