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

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