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