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