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