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