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

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