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