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