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