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