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