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

Revision 10724, 31.8 KB checked in by ghudson, 27 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r10723, which included commits to RCS files with non-trunk default branches.
RevLine 
[10723]1/*    gv.c
2 *
3 *    Copyright (c) 1991-1997, 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#include "perl.h"
21
22EXT char rcsid[];
23
24GV *
25gv_AVadd(gv)
26register GV *gv;
27{
28    if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
29        croak("Bad symbol for array");
30    if (!GvAV(gv))
31        GvAV(gv) = newAV();
32    return gv;
33}
34
35GV *
36gv_HVadd(gv)
37register GV *gv;
38{
39    if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
40        croak("Bad symbol for hash");
41    if (!GvHV(gv))
42        GvHV(gv) = newHV();
43    return gv;
44}
45
46GV *
47gv_IOadd(gv)
48register GV *gv;
49{
50    if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
51        croak("Bad symbol for filehandle");
52    if (!GvIOp(gv))
53        GvIOp(gv) = newIO();
54    return gv;
55}
56
57GV *
58gv_fetchfile(name)
59char *name;
60{
61    char smallbuf[256];
62    char *tmpbuf;
63    STRLEN tmplen;
64    GV *gv;
65
66    tmplen = strlen(name) + 2;
67    if (tmplen < sizeof smallbuf)
68        tmpbuf = smallbuf;
69    else
70        New(603, tmpbuf, tmplen + 1, char);
71    tmpbuf[0] = '_';
72    tmpbuf[1] = '<';
73    strcpy(tmpbuf + 2, name);
74    gv = *(GV**)hv_fetch(defstash, tmpbuf, tmplen, TRUE);
75    if (!isGV(gv))
76        gv_init(gv, defstash, tmpbuf, tmplen, FALSE);
77    if (tmpbuf != smallbuf)
78        Safefree(tmpbuf);
79    sv_setpv(GvSV(gv), name);
80    if (*name == '/' && (instr(name, "/lib/") || instr(name, ".pm")))
81        GvMULTI_on(gv);
82    if (PERLDB_LINE)
83        hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L');
84    return gv;
85}
86
87void
88gv_init(gv, stash, name, len, multi)
89GV *gv;
90HV *stash;
91char *name;
92STRLEN len;
93int multi;
94{
95    register GP *gp;
96
97    sv_upgrade((SV*)gv, SVt_PVGV);
98    if (SvLEN(gv))
99        Safefree(SvPVX(gv));
100    Newz(602, gp, 1, GP);
101    GvGP(gv) = gp_ref(gp);
102    GvSV(gv) = NEWSV(72,0);
103    GvLINE(gv) = curcop->cop_line;
104    GvFILEGV(gv) = curcop->cop_filegv;
105    GvEGV(gv) = gv;
106    sv_magic((SV*)gv, (SV*)gv, '*', name, len);
107    GvSTASH(gv) = stash;
108    GvNAME(gv) = savepvn(name, len);
109    GvNAMELEN(gv) = len;
110    if (multi)
111        GvMULTI_on(gv);
112}
113
114static void
115gv_init_sv(gv, sv_type)
116GV* gv;
117I32 sv_type;
118{
119    switch (sv_type) {
120    case SVt_PVIO:
121        (void)GvIOn(gv);
122        break;
123    case SVt_PVAV:
124        (void)GvAVn(gv);
125        break;
126    case SVt_PVHV:
127        (void)GvHVn(gv);
128        break;
129    }
130}
131
132GV *
133gv_fetchmeth(stash, name, len, level)
134HV* stash;
135char* name;
136STRLEN len;
137I32 level;
138{
139    AV* av;
140    GV* topgv;
141    GV* gv;
142    GV** gvp;
143    CV* cv;
144
145    if (!stash)
146        return 0;
147    if ((level > 100) || (level < -100))
148        croak("Recursive inheritance detected");
149
150    DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) );
151
152    gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
153    if (!gvp)
154        topgv = Nullgv;
155    else {
156        topgv = *gvp;
157        if (SvTYPE(topgv) != SVt_PVGV)
158            gv_init(topgv, stash, name, len, TRUE);
159        if (cv = GvCV(topgv)) {
160            /* If genuine method or valid cache entry, use it */
161            if (!GvCVGEN(topgv) || GvCVGEN(topgv) >= sub_generation)
162                return topgv;
163            /* Stale cached entry: junk it */
164            SvREFCNT_dec(cv);
165            GvCV(topgv) = cv = Nullcv;
166            GvCVGEN(topgv) = 0;
167        }
168    }
169
170    gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
171    av = (gvp && (gv = *gvp) && gv != (GV*)&sv_undef) ? GvAV(gv) : Nullav;
172
173    /* create and re-create @.*::SUPER::ISA on demand */
174    if (!av || !SvMAGIC(av)) {
175        char* packname = HvNAME(stash);
176        STRLEN packlen = strlen(packname);
177
178        if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
179            HV* basestash;
180
181            packlen -= 7;
182            basestash = gv_stashpvn(packname, packlen, TRUE);
183            gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
184            if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
185                gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
186                if (!gvp || !(gv = *gvp))
187                    croak("Cannot create %s::ISA", HvNAME(stash));
188                if (SvTYPE(gv) != SVt_PVGV)
189                    gv_init(gv, stash, "ISA", 3, TRUE);
190                SvREFCNT_dec(GvAV(gv));
191                GvAV(gv) = (AV*)SvREFCNT_inc(av);
192            }
193        }
194    }
195
196    if (av) {
197        SV** svp = AvARRAY(av);
198        I32 items = AvFILL(av) + 1;
199        while (items--) {
200            SV* sv = *svp++;
201            HV* basestash = gv_stashsv(sv, FALSE);
202            if (!basestash) {
203                if (dowarn)
204                    warn("Can't locate package %s for @%s::ISA",
205                        SvPVX(sv), HvNAME(stash));
206                continue;
207            }
208            gv = gv_fetchmeth(basestash, name, len,
209                              (level >= 0) ? level + 1 : level - 1);
210            if (gv)
211                goto gotcha;
212        }
213    }
214
215    /* if at top level, try UNIVERSAL */
216
217    if (level == 0 || level == -1) {
218        HV* lastchance;
219
220        if (lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE)) {
221            if (gv = gv_fetchmeth(lastchance, name, len,
222                                  (level >= 0) ? level + 1 : level - 1)) {
223          gotcha:
224                /*
225                 * Cache method in topgv if:
226                 *  1. topgv has no synonyms (else inheritance crosses wires)
227                 *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
228                 */
229                if (topgv &&
230                    GvREFCNT(topgv) == 1 &&
231                    (cv = GvCV(gv)) &&
232                    (CvROOT(cv) || CvXSUB(cv)))
233                {
234                    if (cv = GvCV(topgv))
235                        SvREFCNT_dec(cv);
236                    GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
237                    GvCVGEN(topgv) = sub_generation;
238                }
239                return gv;
240            }
241        }
242    }
243
244    return 0;
245}
246
247GV *
248gv_fetchmethod(stash, name)
249HV* stash;
250char* name;
251{
252    return gv_fetchmethod_autoload(stash, name, TRUE);
253}
254
255GV *
256gv_fetchmethod_autoload(stash, name, autoload)
257HV* stash;
258char* name;
259I32 autoload;
260{
261    register char *nend;
262    char *nsplit = 0;
263    GV* gv;
264   
265    for (nend = name; *nend; nend++) {
266        if (*nend == '\'')
267            nsplit = nend;
268        else if (*nend == ':' && *(nend + 1) == ':')
269            nsplit = ++nend;
270    }
271    if (nsplit) {
272        char *origname = name;
273        name = nsplit + 1;
274        if (*nsplit == ':')
275            --nsplit;
276        if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
277            /* ->SUPER::method should really be looked up in original stash */
278            SV *tmpstr = sv_2mortal(newSVpvf("%s::SUPER",
279                                             HvNAME(curcop->cop_stash)));
280            stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
281            DEBUG_o( deb("Treating %s as %s::%s\n",
282                         origname, HvNAME(stash), name) );
283        }
284        else
285            stash = gv_stashpvn(origname, nsplit - origname, TRUE);
286    }
287
288    gv = gv_fetchmeth(stash, name, nend - name, 0);
289    if (!gv) {
290        if (strEQ(name,"import"))
291            gv = (GV*)&sv_yes;
292        else if (autoload)
293            gv = gv_autoload4(stash, name, nend - name, TRUE);
294    }
295    else if (autoload) {
296        CV* cv = GvCV(gv);
297        if (!CvROOT(cv) && !CvXSUB(cv)) {
298            GV* stubgv;
299            GV* autogv;
300
301            if (CvANON(cv))
302                stubgv = gv;
303            else {
304                stubgv = CvGV(cv);
305                if (GvCV(stubgv) != cv)         /* orphaned import */
306                    stubgv = gv;
307            }
308            autogv = gv_autoload4(GvSTASH(stubgv),
309                                  GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
310            if (autogv)
311                gv = autogv;
312        }
313    }
314
315    return gv;
316}
317
318GV*
319gv_autoload4(stash, name, len, method)
320HV* stash;
321char* name;
322STRLEN len;
323I32 method;
324{
325    static char autoload[] = "AUTOLOAD";
326    static STRLEN autolen = 8;
327    GV* gv;
328    CV* cv;
329    HV* varstash;
330    GV* vargv;
331    SV* varsv;
332
333    if (len == autolen && strnEQ(name, autoload, autolen))
334        return Nullgv;
335    if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
336        return Nullgv;
337    cv = GvCV(gv);
338
339    /*
340     * Inheriting AUTOLOAD for non-methods works ... for now.
341     */
342    if (dowarn && !method && (GvCVGEN(gv) || GvSTASH(gv) != stash))
343        warn(
344          "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
345             HvNAME(stash), (int)len, name);
346
347    /*
348     * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
349     * The subroutine's original name may not be "AUTOLOAD", so we don't
350     * use that, but for lack of anything better we will use the sub's
351     * original package to look up $AUTOLOAD.
352     */
353    varstash = GvSTASH(CvGV(cv));
354    vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
355    if (!isGV(vargv))
356        gv_init(vargv, varstash, autoload, autolen, FALSE);
357    varsv = GvSV(vargv);
358    sv_setpv(varsv, HvNAME(stash));
359    sv_catpvn(varsv, "::", 2);
360    sv_catpvn(varsv, name, len);
361    SvTAINTED_off(varsv);
362    return gv;
363}
364
365HV*
366gv_stashpv(name,create)
367char *name;
368I32 create;
369{
370    return gv_stashpvn(name, strlen(name), create);
371}
372
373HV*
374gv_stashpvn(name,namelen,create)
375char *name;
376U32 namelen;
377I32 create;
378{
379    char smallbuf[256];
380    char *tmpbuf;
381    HV *stash;
382    GV *tmpgv;
383
384    if (namelen + 3 < sizeof smallbuf)
385        tmpbuf = smallbuf;
386    else
387        New(606, tmpbuf, namelen + 3, char);
388    Copy(name,tmpbuf,namelen,char);
389    tmpbuf[namelen++] = ':';
390    tmpbuf[namelen++] = ':';
391    tmpbuf[namelen] = '\0';
392    tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
393    if (tmpbuf != smallbuf)
394        Safefree(tmpbuf);
395    if (!tmpgv)
396        return 0;
397    if (!GvHV(tmpgv))
398        GvHV(tmpgv) = newHV();
399    stash = GvHV(tmpgv);
400    if (!HvNAME(stash))
401        HvNAME(stash) = savepv(name);
402    return stash;
403}
404
405HV*
406gv_stashsv(sv,create)
407SV *sv;
408I32 create;
409{
410    register char *ptr;
411    STRLEN len;
412    ptr = SvPV(sv,len);
413    return gv_stashpvn(ptr, len, create);
414}
415
416
417GV *
418gv_fetchpv(nambeg,add,sv_type)
419char *nambeg;
420I32 add;
421I32 sv_type;
422{
423    register char *name = nambeg;
424    register GV *gv = 0;
425    GV**gvp;
426    I32 len;
427    register char *namend;
428    HV *stash = 0;
429    U32 add_gvflags = 0;
430    char *tmpbuf;
431
432    if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
433        name++;
434
435    for (namend = name; *namend; namend++) {
436        if ((*namend == '\'' && namend[1]) ||
437            (*namend == ':' && namend[1] == ':'))
438        {
439            if (!stash)
440                stash = defstash;
441            if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
442                return Nullgv;
443
444            len = namend - name;
445            if (len > 0) {
446                New(601, tmpbuf, len+3, char);
447                Copy(name, tmpbuf, len, char);
448                tmpbuf[len++] = ':';
449                tmpbuf[len++] = ':';
450                tmpbuf[len] = '\0';
451                gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
452                Safefree(tmpbuf);
453                if (!gvp || *gvp == (GV*)&sv_undef)
454                    return Nullgv;
455                gv = *gvp;
456
457                if (SvTYPE(gv) == SVt_PVGV)
458                    GvMULTI_on(gv);
459                else if (!add)
460                    return Nullgv;
461                else
462                    gv_init(gv, stash, nambeg, namend - nambeg, (add & 2));
463
464                if (!(stash = GvHV(gv)))
465                    stash = GvHV(gv) = newHV();
466
467                if (!HvNAME(stash))
468                    HvNAME(stash) = savepvn(nambeg, namend - nambeg);
469            }
470
471            if (*namend == ':')
472                namend++;
473            namend++;
474            name = namend;
475            if (!*name)
476                return gv ? gv : (GV*)*hv_fetch(defstash, "main::", 6, TRUE);
477        }
478    }
479    len = namend - name;
480    if (!len)
481        len = 1;
482
483    /* No stash in name, so see how we can default */
484
485    if (!stash) {
486        if (isIDFIRST(*name)) {
487            bool global = FALSE;
488
489            if (isUPPER(*name)) {
490                if (*name > 'I') {
491                    if (*name == 'S' && (
492                      strEQ(name, "SIG") ||
493                      strEQ(name, "STDIN") ||
494                      strEQ(name, "STDOUT") ||
495                      strEQ(name, "STDERR") ))
496                        global = TRUE;
497                }
498                else if (*name > 'E') {
499                    if (*name == 'I' && strEQ(name, "INC"))
500                        global = TRUE;
501                }
502                else if (*name > 'A') {
503                    if (*name == 'E' && strEQ(name, "ENV"))
504                        global = TRUE;
505                }
506                else if (*name == 'A' && (
507                  strEQ(name, "ARGV") ||
508                  strEQ(name, "ARGVOUT") ))
509                    global = TRUE;
510            }
511            else if (*name == '_' && !name[1])
512                global = TRUE;
513
514            if (global)
515                stash = defstash;
516            else if ((COP*)curcop == &compiling) {
517                stash = curstash;
518                if (add && (hints & HINT_STRICT_VARS) &&
519                    sv_type != SVt_PVCV &&
520                    sv_type != SVt_PVGV &&
521                    sv_type != SVt_PVFM &&
522                    sv_type != SVt_PVIO &&
523                    !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
524                {
525                    gvp = (GV**)hv_fetch(stash,name,len,0);
526                    if (!gvp ||
527                        *gvp == (GV*)&sv_undef ||
528                        SvTYPE(*gvp) != SVt_PVGV)
529                    {
530                        stash = 0;
531                    }
532                    else if (sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp) ||
533                             sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp) ||
534                             sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp) )
535                    {
536                        warn("Variable \"%c%s\" is not imported",
537                            sv_type == SVt_PVAV ? '@' :
538                            sv_type == SVt_PVHV ? '%' : '$',
539                            name);
540                        if (GvCVu(*gvp))
541                            warn("(Did you mean &%s instead?)\n", name);
542                        stash = 0;
543                    }
544                }
545            }
546            else
547                stash = curcop->cop_stash;
548        }
549        else
550            stash = defstash;
551    }
552
553    /* By this point we should have a stash and a name */
554
555    if (!stash) {
556        if (add) {
557            warn("Global symbol \"%s\" requires explicit package name", name);
558            ++error_count;
559            stash = curstash ? curstash : defstash;     /* avoid core dumps */
560            add_gvflags = ((sv_type == SVt_PV) ? GVf_IMPORTED_SV
561                           : (sv_type == SVt_PVAV) ? GVf_IMPORTED_AV
562                           : (sv_type == SVt_PVHV) ? GVf_IMPORTED_HV
563                           : 0);
564        }
565        else
566            return Nullgv;
567    }
568
569    if (!SvREFCNT(stash))       /* symbol table under destruction */
570        return Nullgv;
571
572    gvp = (GV**)hv_fetch(stash,name,len,add);
573    if (!gvp || *gvp == (GV*)&sv_undef)
574        return Nullgv;
575    gv = *gvp;
576    if (SvTYPE(gv) == SVt_PVGV) {
577        if (add) {
578            GvMULTI_on(gv);
579            gv_init_sv(gv, sv_type);
580        }
581        return gv;
582    }
583
584    /* Adding a new symbol */
585
586    if (add & 4)
587        warn("Had to create %s unexpectedly", nambeg);
588    gv_init(gv, stash, name, len, add & 2);
589    gv_init_sv(gv, sv_type);
590    GvFLAGS(gv) |= add_gvflags;
591
592    /* set up magic where warranted */
593    switch (*name) {
594    case 'A':
595        if (strEQ(name, "ARGV")) {
596            IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
597        }
598        break;
599
600    case 'a':
601    case 'b':
602        if (len == 1)
603            GvMULTI_on(gv);
604        break;
605    case 'E':
606        if (strnEQ(name, "EXPORT", 6))
607            GvMULTI_on(gv);
608        break;
609    case 'I':
610        if (strEQ(name, "ISA")) {
611            AV* av = GvAVn(gv);
612            GvMULTI_on(gv);
613            sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
614            if (add & 2 && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILL(av) == -1)
615            {
616                char *pname;
617                av_push(av, newSVpv(pname = "NDBM_File",0));
618                gv_stashpvn(pname, 9, TRUE);
619                av_push(av, newSVpv(pname = "DB_File",0));
620                gv_stashpvn(pname, 7, TRUE);
621                av_push(av, newSVpv(pname = "GDBM_File",0));
622                gv_stashpvn(pname, 9, TRUE);
623                av_push(av, newSVpv(pname = "SDBM_File",0));
624                gv_stashpvn(pname, 9, TRUE);
625                av_push(av, newSVpv(pname = "ODBM_File",0));
626                gv_stashpvn(pname, 9, TRUE);
627            }
628        }
629        break;
630#ifdef OVERLOAD
631    case 'O':
632        if (strEQ(name, "OVERLOAD")) {
633            HV* hv = GvHVn(gv);
634            GvMULTI_on(gv);
635            sv_magic((SV*)hv, (SV*)gv, 'A', 0, 0);
636        }
637        break;
638#endif /* OVERLOAD */
639    case 'S':
640        if (strEQ(name, "SIG")) {
641            HV *hv;
642            I32 i;
643            siggv = gv;
644            GvMULTI_on(siggv);
645            hv = GvHVn(siggv);
646            hv_magic(hv, siggv, 'S');
647            for(i=1;sig_name[i];i++) {
648                SV ** init;
649                init=hv_fetch(hv,sig_name[i],strlen(sig_name[i]),1);
650                if(init)
651                        sv_setsv(*init,&sv_undef);
652                psig_ptr[i] = 0;
653                psig_name[i] = 0;
654            }
655            /* initialize signal stack */
656            signalstack = newAV();
657            AvREAL_off(signalstack);
658            av_extend(signalstack, 30);
659            av_fill(signalstack, 0);
660        }
661        break;
662
663    case '&':
664        if (len > 1)
665            break;
666        ampergv = gv;
667        sawampersand = TRUE;
668        goto ro_magicalize;
669
670    case '`':
671        if (len > 1)
672            break;
673        leftgv = gv;
674        sawampersand = TRUE;
675        goto ro_magicalize;
676
677    case '\'':
678        if (len > 1)
679            break;
680        rightgv = gv;
681        sawampersand = TRUE;
682        goto ro_magicalize;
683
684    case ':':
685        if (len > 1)
686            break;
687        sv_setpv(GvSV(gv),chopset);
688        goto magicalize;
689
690    case '?':
691        if (len > 1)
692            break;
693#ifdef COMPLEX_STATUS
694        sv_upgrade(GvSV(gv), SVt_PVLV);
695#endif
696        goto magicalize;
697
698    case '#':
699    case '*':
700        if (dowarn && len == 1 && sv_type == SVt_PV)
701            warn("Use of $%s is deprecated", name);
702        /* FALL THROUGH */
703    case '[':
704    case '!':
705    case '^':
706    case '~':
707    case '=':
708    case '-':
709    case '%':
710    case '.':
711    case '(':
712    case ')':
713    case '<':
714    case '>':
715    case ',':
716    case '\\':
717    case '/':
718    case '|':
719    case '\001':
720    case '\004':
721    case '\005':
722    case '\006':
723    case '\010':
724    case '\017':
725    case '\t':
726    case '\020':
727    case '\024':
728    case '\027':
729        if (len > 1)
730            break;
731        goto magicalize;
732
733    case '+':
734    case '1':
735    case '2':
736    case '3':
737    case '4':
738    case '5':
739    case '6':
740    case '7':
741    case '8':
742    case '9':
743    case '\023':
744      ro_magicalize:
745        SvREADONLY_on(GvSV(gv));
746      magicalize:
747        sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
748        break;
749
750    case '\014':
751        if (len > 1)
752            break;
753        sv_setpv(GvSV(gv),"\f");
754        formfeed = GvSV(gv);
755        break;
756    case ';':
757        if (len > 1)
758            break;
759        sv_setpv(GvSV(gv),"\034");
760        break;
761    case ']':
762        if (len == 1) {
763            SV *sv = GvSV(gv);
764            sv_upgrade(sv, SVt_PVNV);
765            sv_setpv(sv, patchlevel);
766            (void)sv_2nv(sv);
767            SvREADONLY_on(sv);
768        }
769        break;
770    }
771    return gv;
772}
773
774void
775gv_fullname3(sv, gv, prefix)
776SV *sv;
777GV *gv;
778char *prefix;
779{
780    HV *hv = GvSTASH(gv);
781    if (!hv) {
782        SvOK_off(sv);
783        return;
784    }
785    sv_setpv(sv, prefix ? prefix : "");
786    sv_catpv(sv,HvNAME(hv));
787    sv_catpvn(sv,"::", 2);
788    sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
789}
790
791void
792gv_efullname3(sv, gv, prefix)
793SV *sv;
794GV *gv;
795char *prefix;
796{
797    GV *egv = GvEGV(gv);
798    if (!egv)
799        egv = gv;
800    gv_fullname3(sv, egv, prefix);
801}
802
803/* XXX compatibility with versions <= 5.003. */
804void
805gv_fullname(sv,gv)
806SV *sv;
807GV *gv;
808{
809    gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
810}
811
812/* XXX compatibility with versions <= 5.003. */
813void
814gv_efullname(sv,gv)
815SV *sv;
816GV *gv;
817{
818    gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
819}
820
821IO *
822newIO()
823{
824    IO *io;
825    GV *iogv;
826
827    io = (IO*)NEWSV(0,0);
828    sv_upgrade((SV *)io,SVt_PVIO);
829    SvREFCNT(io) = 1;
830    SvOBJECT_on(io);
831    iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
832    if (!iogv)
833      iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
834    SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
835    return io;
836}
837
838void
839gv_check(stash)
840HV* stash;
841{
842    register HE *entry;
843    register I32 i;
844    register GV *gv;
845    HV *hv;
846    GV *filegv;
847
848    if (!HvARRAY(stash))
849        return;
850    for (i = 0; i <= (I32) HvMAX(stash); i++) {
851        for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
852            if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
853                (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
854            {
855                if (hv != defstash)
856                     gv_check(hv);              /* nested package */
857            }
858            else if (isALPHA(*HeKEY(entry))) {
859                gv = (GV*)HeVAL(entry);
860                if (GvMULTI(gv))
861                    continue;
862                curcop->cop_line = GvLINE(gv);
863                filegv = GvFILEGV(gv);
864                curcop->cop_filegv = filegv;
865                if (filegv && GvMULTI(filegv))  /* Filename began with slash */
866                    continue;
867                warn("Name \"%s::%s\" used only once: possible typo",
868                        HvNAME(stash), GvNAME(gv));
869            }
870        }
871    }
872}
873
874GV *
875newGVgen(pack)
876char *pack;
877{
878    return gv_fetchpv(form("%s::_GEN_%ld", pack, (long)gensym++),
879                      TRUE, SVt_PVGV);
880}
881
882/* hopefully this is only called on local symbol table entries */
883
884GP*
885gp_ref(gp)
886GP* gp;
887{
888    gp->gp_refcnt++;
889    if (gp->gp_cv) {
890        if (gp->gp_cvgen) {
891            /* multi-named GPs cannot be used for method cache */
892            SvREFCNT_dec(gp->gp_cv);
893            gp->gp_cv = Nullcv;
894            gp->gp_cvgen = 0;
895        }
896        else {
897            /* Adding a new name to a subroutine invalidates method cache */
898            sub_generation++;
899        }
900    }
901    return gp;
902}
903
904void
905gp_free(gv)
906GV* gv;
907{
908    GP* gp;
909    CV* cv;
910
911    if (!gv || !(gp = GvGP(gv)))
912        return;
913    if (gp->gp_refcnt == 0) {
914        warn("Attempt to free unreferenced glob pointers");
915        return;
916    }
917    if (gp->gp_cv) {
918        /* Deleting the name of a subroutine invalidates method cache */
919        sub_generation++;
920    }
921    if (--gp->gp_refcnt > 0) {
922        if (gp->gp_egv == gv)
923            gp->gp_egv = 0;
924        return;
925    }
926
927    SvREFCNT_dec(gp->gp_sv);
928    SvREFCNT_dec(gp->gp_av);
929    SvREFCNT_dec(gp->gp_hv);
930    SvREFCNT_dec(gp->gp_io);
931    SvREFCNT_dec(gp->gp_cv);
932    SvREFCNT_dec(gp->gp_form);
933
934    Safefree(gp);
935    GvGP(gv) = 0;
936}
937
938#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
939#define MICROPORT
940#endif
941
942#ifdef  MICROPORT       /* Microport 2.4 hack */
943AV *GvAVn(gv)
944register GV *gv;
945{
946    if (GvGP(gv)->gp_av)
947        return GvGP(gv)->gp_av;
948    else
949        return GvGP(gv_AVadd(gv))->gp_av;
950}
951
952HV *GvHVn(gv)
953register GV *gv;
954{
955    if (GvGP(gv)->gp_hv)
956        return GvGP(gv)->gp_hv;
957    else
958        return GvGP(gv_HVadd(gv))->gp_hv;
959}
960#endif                  /* Microport 2.4 hack */
961
962#ifdef OVERLOAD
963/* Updates and caches the CV's */
964
965bool
966Gv_AMupdate(stash)
967HV* stash;
968{
969  GV** gvp;
970  HV* hv;
971  GV* gv;
972  CV* cv;
973  MAGIC* mg=mg_find((SV*)stash,'c');
974  AMT *amtp=mg ? (AMT*)mg->mg_ptr: NULL;
975  AMT amt;
976
977  if (mg && amtp->was_ok_am == amagic_generation
978      && amtp->was_ok_sub == sub_generation)
979      return AMT_AMAGIC(amtp);
980  if (amtp && AMT_AMAGIC(amtp)) {       /* Have table. */
981    int i;
982    for (i=1; i<NofAMmeth; i++) {
983      if (amtp->table[i]) {
984        SvREFCNT_dec(amtp->table[i]);
985      }
986    }
987  }
988  sv_unmagic((SV*)stash, 'c');
989
990  DEBUG_o( deb("Recalcing overload magic in package %s\n",HvNAME(stash)) );
991
992  amt.was_ok_am = amagic_generation;
993  amt.was_ok_sub = sub_generation;
994  amt.fallback = AMGfallNO;
995  amt.flags = 0;
996
997#ifdef OVERLOAD_VIA_HASH
998  gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */
999  if (gvp && ((gv = *gvp) != (GV*)&sv_undef && (hv = GvHV(gv)))) {
1000    int filled=0;
1001    int i;
1002    char *cp;
1003    SV* sv;
1004    SV** svp;
1005
1006    /* Work with "fallback" key, which we assume to be first in AMG_names */
1007
1008    if (( cp = (char *)AMG_names[0] ) &&
1009        (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
1010      if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1011      else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1012    }
1013    for (i = 1; i < NofAMmeth; i++) {
1014      cv = 0;
1015      cp = (char *)AMG_names[i];
1016     
1017        svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
1018        if (svp && ((sv = *svp) != &sv_undef)) {
1019          switch (SvTYPE(sv)) {
1020            default:
1021              if (!SvROK(sv)) {
1022                if (!SvOK(sv)) break;
1023                gv = gv_fetchmethod(stash, SvPV(sv, na));
1024                if (gv) cv = GvCV(gv);
1025                break;
1026              }
1027              cv = (CV*)SvRV(sv);
1028              if (SvTYPE(cv) == SVt_PVCV)
1029                  break;
1030                /* FALL THROUGH */
1031            case SVt_PVHV:
1032            case SVt_PVAV:
1033              croak("Not a subroutine reference in overload table");
1034              return FALSE;
1035            case SVt_PVCV:
1036              cv = (CV*)sv;
1037              break;
1038            case SVt_PVGV:
1039              if (!(cv = GvCVu((GV*)sv)))
1040                cv = sv_2cv(sv, &stash, &gv, TRUE);
1041              break;
1042          }
1043          if (cv) filled=1;
1044          else {
1045            croak("Method for operation %s not found in package %.256s during blessing\n",
1046                cp,HvNAME(stash));
1047            return FALSE;
1048          }
1049        }
1050#else
1051  {
1052    int filled = 0;
1053    int i;
1054    const char *cp;
1055    SV* sv = NULL;
1056    SV** svp;
1057
1058    /* Work with "fallback" key, which we assume to be first in AMG_names */
1059
1060    if ( cp = AMG_names[0] ) {
1061        /* Try to find via inheritance. */
1062        gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
1063        if (gv) sv = GvSV(gv);
1064
1065        if (!gv) goto no_table;
1066        else if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1067        else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1068    }
1069
1070    for (i = 1; i < NofAMmeth; i++) {
1071        SV *cookie = sv_2mortal(newSVpvf("(%s", cp = AMG_names[i]));
1072        DEBUG_o( deb("Checking overloading of `%s' in package `%.256s'\n",
1073                     cp, HvNAME(stash)) );
1074        /* don't fill the cache while looking up! */
1075        gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
1076        cv = 0;
1077        if(gv && (cv = GvCV(gv))) {
1078            if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1079                && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1080                /* GvSV contains the name of the method. */
1081                GV *ngv;
1082               
1083                DEBUG_o( deb("Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1084                             SvPV(GvSV(gv), na), cp, HvNAME(stash)) );
1085                if (!SvPOK(GvSV(gv))
1086                    || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1087                                                       FALSE)))
1088                {
1089                    /* Can be an import stub (created by `can'). */
1090                    if (GvCVGEN(gv)) {
1091                        croak("Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1092                              (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1093                              cp, HvNAME(stash));
1094                    } else
1095                        croak("Cannot resolve method `%.256s' overloading `%s' in package `%.256s'",
1096                              (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1097                              cp, HvNAME(stash));
1098                }
1099                cv = GvCV(gv = ngv);
1100            }
1101            DEBUG_o( deb("Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1102                         cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1103                         GvNAME(CvGV(cv))) );
1104            filled = 1;
1105        }
1106#endif
1107        amt.table[i]=(CV*)SvREFCNT_inc(cv);
1108    }
1109    if (filled) {
1110      AMT_AMAGIC_on(&amt);
1111      sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
1112      return TRUE;
1113    }
1114  }
1115  /* Here we have no table: */
1116 no_table:
1117  AMT_AMAGIC_off(&amt);
1118  sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
1119  return FALSE;
1120}
1121
1122/* During call to this subroutine stack can be reallocated. It is
1123 * advised to call SPAGAIN macro in your code after call */
1124
1125SV*
1126amagic_call(left,right,method,flags)
1127SV* left;
1128SV* right;
1129int method;
1130int flags;
1131{
1132  MAGIC *mg;
1133  CV *cv;
1134  CV **cvp=NULL, **ocvp=NULL;
1135  AMT *amtp, *oamtp;
1136  int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1137  int postpr=0, inc_dec_ass=0, assignshift=assign?1:0;
1138  HV* stash;
1139  if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1140      && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1141      && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1142                        ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1143                        : NULL))
1144      && ((cv = cvp[off=method+assignshift])
1145          || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1146                                                          * usual method */
1147                  (fl = 1, cv = cvp[off=method])))) {
1148    lr = -1;                    /* Call method for left argument */
1149  } else {
1150    if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1151      int logic;
1152
1153      /* look for substituted methods */
1154         switch (method) {
1155         case inc_amg:
1156           if (((cv = cvp[off=add_ass_amg]) && (inc_dec_ass=1))
1157               || ((cv = cvp[off=add_amg]) && (postpr=1))) {
1158             right = &sv_yes; lr = -1; assign = 1;
1159           }
1160           break;
1161         case dec_amg:
1162           if (((cv = cvp[off=subtr_ass_amg])  && (inc_dec_ass=1))
1163               || ((cv = cvp[off=subtr_amg]) && (postpr=1))) {
1164             right = &sv_yes; lr = -1; assign = 1;
1165           }
1166           break;
1167         case bool__amg:
1168           (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1169           break;
1170         case numer_amg:
1171           (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1172           break;
1173         case string_amg:
1174           (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1175           break;
1176 case not_amg:
1177   (void)((cv = cvp[off=bool__amg])
1178          || (cv = cvp[off=numer_amg])
1179          || (cv = cvp[off=string_amg]));
1180   postpr = 1;
1181   break;
1182         case copy_amg:
1183           {
1184             SV* ref=SvRV(left);
1185             if (!SvROK(ref) && SvTYPE(ref) <= SVt_PVMG) {
1186                /*
1187                 * Just to be extra cautious.  Maybe in some
1188                 * additional cases sv_setsv is safe, too.
1189                 */
1190                SV* newref = newSVsv(ref);
1191                SvOBJECT_on(newref);
1192                SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(ref));
1193                return newref;
1194             }
1195           }
1196           break;
1197         case abs_amg:
1198           if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1199               && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1200             SV* nullsv=sv_2mortal(newSViv(0));
1201             if (off1==lt_amg) {
1202               SV* lessp = amagic_call(left,nullsv,
1203                                       lt_amg,AMGf_noright);
1204               logic = SvTRUE(lessp);
1205             } else {
1206               SV* lessp = amagic_call(left,nullsv,
1207                                       ncmp_amg,AMGf_noright);
1208               logic = (SvNV(lessp) < 0);
1209             }
1210             if (logic) {
1211               if (off==subtr_amg) {
1212                 right = left;
1213                 left = nullsv;
1214                 lr = 1;
1215               }
1216             } else {
1217               return left;
1218             }
1219           }
1220           break;
1221         case neg_amg:
1222           if (cv = cvp[off=subtr_amg]) {
1223             right = left;
1224             left = sv_2mortal(newSViv(0));
1225             lr = 1;
1226           }
1227           break;
1228         default:
1229           goto not_found;
1230         }
1231         if (!cv) goto not_found;
1232    } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1233               && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1234               && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1235                          ? (amtp = (AMT*)mg->mg_ptr)->table
1236                          : NULL))
1237               && (cv = cvp[off=method])) { /* Method for right
1238                                             * argument found */
1239      lr=1;
1240    } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1241                 && (cvp=ocvp) && (lr = -1))
1242                || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1243               && !(flags & AMGf_unary)) {
1244                                /* We look for substitution for
1245                                 * comparison operations and
1246                                 * concatenation */
1247      if (method==concat_amg || method==concat_ass_amg
1248          || method==repeat_amg || method==repeat_ass_amg) {
1249        return NULL;            /* Delegate operation to string conversion */
1250      }
1251      off = -1;
1252      switch (method) {
1253         case lt_amg:
1254         case le_amg:
1255         case gt_amg:
1256         case ge_amg:
1257         case eq_amg:
1258         case ne_amg:
1259           postpr = 1; off=ncmp_amg; break;
1260         case slt_amg:
1261         case sle_amg:
1262         case sgt_amg:
1263         case sge_amg:
1264         case seq_amg:
1265         case sne_amg:
1266           postpr = 1; off=scmp_amg; break;
1267         }
1268      if (off != -1) cv = cvp[off];
1269      if (!cv) {
1270        goto not_found;
1271      }
1272    } else {
1273    not_found:                  /* No method found, either report or croak */
1274      if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1275        notfound = 1; lr = -1;
1276      } else if (cvp && (cv=cvp[nomethod_amg])) {
1277        notfound = 1; lr = 1;
1278      } else {
1279        SV *msg;
1280        if (off==-1) off=method;
1281        msg = sv_2mortal(newSVpvf(
1282                      "Operation `%s': no method found,%sargument %s%s%s%s",
1283                      AMG_names[method + assignshift],
1284                      (flags & AMGf_unary ? " " : "\n\tleft "),
1285                      SvAMAGIC(left)?
1286                        "in overloaded package ":
1287                        "has no overloaded magic",
1288                      SvAMAGIC(left)?
1289                        HvNAME(SvSTASH(SvRV(left))):
1290                        "",
1291                      SvAMAGIC(right)?
1292                        ",\n\tright argument in overloaded package ":
1293                        (flags & AMGf_unary
1294                         ? ""
1295                         : ",\n\tright argument has no overloaded magic"),
1296                      SvAMAGIC(right)?
1297                        HvNAME(SvSTASH(SvRV(right))):
1298                        ""));
1299        if (amtp && amtp->fallback >= AMGfallYES) {
1300          DEBUG_o( deb("%s", SvPVX(msg)) );
1301        } else {
1302          croak("%_", msg);
1303        }
1304        return NULL;
1305      }
1306    }
1307  }
1308  if (!notfound) {
1309    DEBUG_o( deb(
1310  "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1311                 AMG_names[off],
1312                 method+assignshift==off? "" :
1313                             " (initially `",
1314                 method+assignshift==off? "" :
1315                             AMG_names[method+assignshift],
1316                 method+assignshift==off? "" : "')",
1317                 flags & AMGf_unary? "" :
1318                   lr==1 ? " for right argument": " for left argument",
1319                 flags & AMGf_unary? " for argument" : "",
1320                 HvNAME(stash),
1321                 fl? ",\n\tassignment variant used": "") );
1322    /* Since we use shallow copy during assignment, we need
1323     * to dublicate the contents, probably calling user-supplied
1324     * version of copy operator
1325     */
1326    if ((method + assignshift==off
1327         && (assign || method==inc_amg || method==dec_amg))
1328        || inc_dec_ass) RvDEEPCP(left);
1329  }
1330  {
1331    dSP;
1332    BINOP myop;
1333    SV* res;
1334    bool oldcatch = CATCH_GET;
1335
1336    CATCH_SET(TRUE);
1337    Zero(&myop, 1, BINOP);
1338    myop.op_last = (OP *) &myop;
1339    myop.op_next = Nullop;
1340    myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1341
1342    ENTER;
1343    SAVESPTR(op);
1344    op = (OP *) &myop;
1345    if (PERLDB_SUB && curstash != debstash)
1346        op->op_private |= OPpENTERSUB_DB;
1347    PUTBACK;
1348    pp_pushmark();
1349
1350    EXTEND(sp, notfound + 5);
1351    PUSHs(lr>0? right: left);
1352    PUSHs(lr>0? left: right);
1353    PUSHs( lr > 0 ? &sv_yes : ( assign ? &sv_undef : &sv_no ));
1354    if (notfound) {
1355      PUSHs( sv_2mortal(newSVpv((char *)AMG_names[method + assignshift],0)) );
1356    }
1357    PUSHs((SV*)cv);
1358    PUTBACK;
1359
1360    if (op = pp_entersub())
1361      runops();
1362    LEAVE;
1363    SPAGAIN;
1364
1365    res=POPs;
1366    PUTBACK;
1367    CATCH_SET(oldcatch);
1368
1369    if (postpr) {
1370      int ans;
1371      switch (method) {
1372      case le_amg:
1373      case sle_amg:
1374        ans=SvIV(res)<=0; break;
1375      case lt_amg:
1376      case slt_amg:
1377        ans=SvIV(res)<0; break;
1378      case ge_amg:
1379      case sge_amg:
1380        ans=SvIV(res)>=0; break;
1381      case gt_amg:
1382      case sgt_amg:
1383        ans=SvIV(res)>0; break;
1384      case eq_amg:
1385      case seq_amg:
1386        ans=SvIV(res)==0; break;
1387      case ne_amg:
1388      case sne_amg:
1389        ans=SvIV(res)!=0; break;
1390      case inc_amg:
1391      case dec_amg:
1392        SvSetSV(left,res); return left;
1393      case not_amg:
1394        ans=!SvOK(res); break;
1395      }
1396      return boolSV(ans);
1397    } else if (method==copy_amg) {
1398      if (!SvROK(res)) {
1399        croak("Copy method did not return a reference");
1400      }
1401      return SvREFCNT_inc(SvRV(res));
1402    } else {
1403      return res;
1404    }
1405  }
1406}
1407#endif /* OVERLOAD */
Note: See TracBrowser for help on using the repository browser.