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