projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
[fix crash in regexec.c]
[p5sagit/p5-mst-13.2.git] / gv.c
CommitLineData
a0d0e21e 1/* gv.c
79072805 2 *
a0d0e21e 3 * Copyright (c) 1991-1994, Larry Wall
79072805 4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
a0d0e21e 8 */
9
10/*
11 * 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure
12 * of your inquisitiveness, I shall spend all the rest of my days answering
13 * you. What more do you want to know?'
14 * 'The names of all the stars, and of all living things, and the whole
15 * history of Middle-earth and Over-heaven and of the Sundering Seas,'
16 * laughed Pippin.
79072805 17 */
18
19#include "EXTERN.h"
20#include "perl.h"
21
463ee0b2 22extern char rcsid[];
93a17b20 23
79072805 24GV *
25gv_AVadd(gv)
26register GV *gv;
27{
a0d0e21e 28 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
29 croak("Bad symbol for array");
79072805 30 if (!GvAV(gv))
31 GvAV(gv) = newAV();
32 return gv;
33}
34
35GV *
36gv_HVadd(gv)
37register GV *gv;
38{
a0d0e21e 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 43 return gv;
44}
45
46GV *
a0d0e21e 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 58gv_fetchfile(name)
59char *name;
60{
61 char tmpbuf[1200];
62 GV *gv;
63
8990e307 64 sprintf(tmpbuf,"::_<%s", name);
85e6fe83 65 gv = gv_fetchpv(tmpbuf, TRUE, SVt_PVGV);
79072805 66 sv_setpv(GvSV(gv), name);
a0d0e21e 67 if (*name == '/' && (instr(name,"/lib/") || instr(name,".pm")))
8990e307 68 SvMULTI_on(gv);
79072805 69 if (perldb)
93a17b20 70 hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L');
79072805 71 return gv;
72}
73
463ee0b2 74void
75gv_init(gv, stash, name, len, multi)
76GV *gv;
77HV *stash;
78char *name;
79STRLEN len;
80int multi;
81{
82 register GP *gp;
83
84 sv_upgrade(gv, SVt_PVGV);
85 if (SvLEN(gv))
86 Safefree(SvPVX(gv));
87 Newz(602,gp, 1, GP);
8990e307 88 GvGP(gv) = gp_ref(gp);
463ee0b2 89 GvREFCNT(gv) = 1;
90 GvSV(gv) = NEWSV(72,0);
91 GvLINE(gv) = curcop->cop_line;
8990e307 92 GvFILEGV(gv) = curcop->cop_filegv;
463ee0b2 93 GvEGV(gv) = gv;
94 sv_magic((SV*)gv, (SV*)gv, '*', name, len);
95 GvSTASH(gv) = stash;
a0d0e21e 96 GvNAME(gv) = savepvn(name, len);
463ee0b2 97 GvNAMELEN(gv) = len;
98 if (multi)
99 SvMULTI_on(gv);
100}
101
a0d0e21e 102static void
103gv_init_sv(gv, sv_type)
104GV* gv;
105I32 sv_type;
106{
107 switch (sv_type) {
108 case SVt_PVIO:
109 (void)GvIOn(gv);
110 break;
111 case SVt_PVAV:
112 (void)GvAVn(gv);
113 break;
114 case SVt_PVHV:
115 (void)GvHVn(gv);
116 break;
117 }
118}
119
79072805 120GV *
a0d0e21e 121gv_fetchmeth(stash, name, len, level)
79072805 122HV* stash;
123char* name;
463ee0b2 124STRLEN len;
a0d0e21e 125I32 level;
79072805 126{
127 AV* av;
463ee0b2 128 GV* topgv;
79072805 129 GV* gv;
463ee0b2 130 GV** gvp;
a0d0e21e 131 HV* lastchance;
132
133 if (!stash)
134 return 0;
135 if (level > 100)
136 croak("Recursive inheritance detected");
463ee0b2 137
138 gvp = (GV**)hv_fetch(stash, name, len, TRUE);
139
140 DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) );
141 topgv = *gvp;
142 if (SvTYPE(topgv) != SVt_PVGV)
143 gv_init(topgv, stash, name, len, TRUE);
144
145 if (GvCV(topgv)) {
146 if (!GvCVGEN(topgv) || GvCVGEN(topgv) >= sub_generation)
147 return topgv;
148 }
79072805 149
150 gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
151 if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
152 SV** svp = AvARRAY(av);
153 I32 items = AvFILL(av) + 1;
154 while (items--) {
79072805 155 SV* sv = *svp++;
a0d0e21e 156 HV* basestash = gv_stashsv(sv, FALSE);
9bbf4081 157 if (!basestash) {
79072805 158 if (dowarn)
a0d0e21e 159 warn("Can't locate package %s for @%s::ISA",
463ee0b2 160 SvPVX(sv), HvNAME(stash));
79072805 161 continue;
162 }
a0d0e21e 163 gv = gv_fetchmeth(basestash, name, len, level + 1);
463ee0b2 164 if (gv) {
165 GvCV(topgv) = GvCV(gv); /* cache the CV */
166 GvCVGEN(topgv) = sub_generation; /* valid for now */
79072805 167 return gv;
463ee0b2 168 }
79072805 169 }
170 }
a0d0e21e 171
172 if (!level) {
173 if (lastchance = gv_stashpv("UNIVERSAL", FALSE)) {
174 if (gv = gv_fetchmeth(lastchance, name, len, level + 1)) {
175 GvCV(topgv) = GvCV(gv); /* cache the CV */
176 GvCVGEN(topgv) = sub_generation; /* valid for now */
177 return gv;
178 }
179 }
180 }
181
79072805 182 return 0;
183}
184
185GV *
463ee0b2 186gv_fetchmethod(stash, name)
187HV* stash;
188char* name;
189{
190 register char *nend;
a0d0e21e 191 char *nsplit = 0;
192 GV* gv;
463ee0b2 193
194 for (nend = name; *nend; nend++) {
a0d0e21e 195 if (*nend == ':' || *nend == '\'')
196 nsplit = nend;
197 }
198 if (nsplit) {
199 char ch;
200 char *origname = name;
201 name = nsplit + 1;
202 ch = *nsplit;
203 if (*nsplit == ':')
204 --nsplit;
205 *nsplit = '\0';
206 stash = gv_stashpv(origname,TRUE);
207 *nsplit = ch;
208 }
209 gv = gv_fetchmeth(stash, name, nend - name, 0);
210 if (!gv) {
211 CV* cv;
212
213 if (strEQ(name,"import") || strEQ(name,"unimport"))
214 gv = &sv_yes;
215 else if (strNE(name, "AUTOLOAD")) {
216 gv = gv_fetchmeth(stash, "AUTOLOAD", 8, 0);
217 if (gv && (cv = GvCV(gv))) { /* One more chance... */
218 SV *tmpstr = sv_newmortal();
219 sv_catpv(tmpstr,HvNAME(stash));
220 sv_catpvn(tmpstr,"::", 2);
221 sv_catpvn(tmpstr, name, nend - name);
222 sv_setsv(GvSV(CvGV(cv)), tmpstr);
223 }
463ee0b2 224 }
225 }
a0d0e21e 226 return gv;
227}
228
229HV*
230gv_stashpv(name,create)
231char *name;
232I32 create;
233{
234 char tmpbuf[1234];
235 HV *stash;
236 GV *tmpgv;
237 sprintf(tmpbuf,"%.*s::",1200,name);
238 tmpgv = gv_fetchpv(tmpbuf,create, SVt_PVHV);
239 if (!tmpgv)
240 return 0;
241 if (!GvHV(tmpgv))
242 GvHV(tmpgv) = newHV();
243 stash = GvHV(tmpgv);
244 if (!HvNAME(stash))
245 HvNAME(stash) = savepv(name);
246 return stash;
463ee0b2 247}
248
a0d0e21e 249HV*
250gv_stashsv(sv,create)
251SV *sv;
252I32 create;
253{
254 return gv_stashpv(SvPV(sv,na), create);
255}
256
257
463ee0b2 258GV *
a0d0e21e 259gv_fetchpv(nambeg,add,sv_type)
463ee0b2 260char *nambeg;
79072805 261I32 add;
a0d0e21e 262I32 sv_type;
79072805 263{
463ee0b2 264 register char *name = nambeg;
265 register GV *gv = 0;
79072805 266 GV**gvp;
79072805 267 I32 len;
268 register char *namend;
463ee0b2 269 HV *stash = 0;
79072805 270 bool global = FALSE;
85e6fe83 271 char *tmpbuf;
79072805 272
79072805 273 for (namend = name; *namend; namend++) {
463ee0b2 274 if ((*namend == '\'' && namend[1]) ||
275 (*namend == ':' && namend[1] == ':'))
276 {
463ee0b2 277 if (!stash)
278 stash = defstash;
a0d0e21e 279 if (!SvREFCNT(stash)) /* symbol table under destruction */
280 return Nullgv;
463ee0b2 281
85e6fe83 282 len = namend - name;
283 if (len > 0) {
a0d0e21e 284 New(601, tmpbuf, len+3, char);
285 Copy(name, tmpbuf, len, char);
286 tmpbuf[len++] = ':';
287 tmpbuf[len++] = ':';
288 tmpbuf[len] = '\0';
463ee0b2 289 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
85e6fe83 290 Safefree(tmpbuf);
463ee0b2 291 if (!gvp || *gvp == (GV*)&sv_undef)
292 return Nullgv;
293 gv = *gvp;
85e6fe83 294
463ee0b2 295 if (SvTYPE(gv) == SVt_PVGV)
296 SvMULTI_on(gv);
a0d0e21e 297 else if (!add)
298 return Nullgv;
463ee0b2 299 else
300 gv_init(gv, stash, nambeg, namend - nambeg, (add & 2));
85e6fe83 301
463ee0b2 302 if (!(stash = GvHV(gv)))
303 stash = GvHV(gv) = newHV();
85e6fe83 304
463ee0b2 305 if (!HvNAME(stash))
a0d0e21e 306 HvNAME(stash) = savepvn(nambeg, namend - nambeg);
463ee0b2 307 }
308
309 if (*namend == ':')
310 namend++;
311 namend++;
312 name = namend;
313 if (!*name)
a0d0e21e 314 return gv ? gv : *hv_fetch(defstash, "main::", 6, TRUE);
79072805 315 }
79072805 316 }
a0d0e21e 317 len = namend - name;
318 if (!len)
319 len = 1;
463ee0b2 320
321 /* No stash in name, so see how we can default */
322
323 if (!stash) {
324 if (isIDFIRST(*name)) {
325 if (isUPPER(*name)) {
326 if (*name > 'I') {
327 if (*name == 'S' && (
328 strEQ(name, "SIG") ||
329 strEQ(name, "STDIN") ||
330 strEQ(name, "STDOUT") ||
331 strEQ(name, "STDERR") ))
332 global = TRUE;
333 }
334 else if (*name > 'E') {
335 if (*name == 'I' && strEQ(name, "INC"))
336 global = TRUE;
337 }
338 else if (*name > 'A') {
339 if (*name == 'E' && strEQ(name, "ENV"))
340 global = TRUE;
341 }
342 else if (*name == 'A' && (
343 strEQ(name, "ARGV") ||
344 strEQ(name, "ARGVOUT") ))
345 global = TRUE;
346 }
347 else if (*name == '_' && !name[1])
348 global = TRUE;
349 if (global)
350 stash = defstash;
85e6fe83 351 else if ((COP*)curcop == &compiling) {
a0d0e21e 352 stash = curstash;
353 if (add && (hints & HINT_STRICT_VARS) && sv_type != SVt_PVCV) {
354 if (stash && !hv_fetch(stash,name,len,0))
355 stash = 0;
356 }
85e6fe83 357 }
463ee0b2 358 else
359 stash = curcop->cop_stash;
360 }
361 else
362 stash = defstash;
363 }
364
365 /* By this point we should have a stash and a name */
366
a0d0e21e 367 if (!stash) {
368 if (add) {
369 warn("Global symbol \"%s\" requires explicit package name", name);
370 ++error_count;
371 stash = curstash ? curstash : defstash; /* avoid core dumps */
372 }
373 else
374 return Nullgv;
375 }
376
377 if (!SvREFCNT(stash)) /* symbol table under destruction */
378 return Nullgv;
379
79072805 380 gvp = (GV**)hv_fetch(stash,name,len,add);
381 if (!gvp || *gvp == (GV*)&sv_undef)
382 return Nullgv;
383 gv = *gvp;
384 if (SvTYPE(gv) == SVt_PVGV) {
a0d0e21e 385 if (add) {
386 SvMULTI_on(gv);
387 gv_init_sv(gv, sv_type);
388 }
79072805 389 return gv;
390 }
93a17b20 391
392 /* Adding a new symbol */
393
a0d0e21e 394 if (add & 4)
395 warn("Had to create %s unexpectedly", nambeg);
463ee0b2 396 gv_init(gv, stash, name, len, add & 2);
a0d0e21e 397 gv_init_sv(gv, sv_type);
93a17b20 398
399 /* set up magic where warranted */
400 switch (*name) {
a0d0e21e 401 case 'A':
402 if (strEQ(name, "ARGV")) {
403 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
404 }
405 break;
406
ed6116ce 407 case 'a':
408 case 'b':
409 if (len == 1)
410 SvMULTI_on(gv);
411 break;
a0d0e21e 412 case 'E':
413 if (strnEQ(name, "EXPORT", 6))
414 SvMULTI_on(gv);
415 break;
463ee0b2 416 case 'I':
417 if (strEQ(name, "ISA")) {
418 AV* av = GvAVn(gv);
8990e307 419 SvMULTI_on(gv);
a0d0e21e 420 sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
421 if (add & 2 && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILL(av) == -1)
85e6fe83 422 {
a0d0e21e 423 char *pname;
424 av_push(av, newSVpv(pname = "NDBM_File",0));
425 gv_stashpv(pname, TRUE);
426 av_push(av, newSVpv(pname = "DB_File",0));
427 gv_stashpv(pname, TRUE);
428 av_push(av, newSVpv(pname = "GDBM_File",0));
429 gv_stashpv(pname, TRUE);
430 av_push(av, newSVpv(pname = "SDBM_File",0));
431 gv_stashpv(pname, TRUE);
432 av_push(av, newSVpv(pname = "ODBM_File",0));
433 gv_stashpv(pname, TRUE);
85e6fe83 434 }
463ee0b2 435 }
436 break;
a0d0e21e 437#ifdef OVERLOAD
438 case 'O':
439 if (strEQ(name, "OVERLOAD")) {
440 HV* hv = GvHVn(gv);
441 SvMULTI_on(gv);
442 sv_magic((SV*)hv, (SV*)gv, 'A', 0, 0);
443 }
444 break;
445#endif /* OVERLOAD */
93a17b20 446 case 'S':
447 if (strEQ(name, "SIG")) {
448 HV *hv;
449 siggv = gv;
450 SvMULTI_on(siggv);
451 hv = GvHVn(siggv);
452 hv_magic(hv, siggv, 'S');
453
454 /* initialize signal stack */
455 signalstack = newAV();
93a17b20 456 AvREAL_off(signalstack);
a0d0e21e 457 av_extend(signalstack, 30);
458 av_fill(signalstack, 0);
93a17b20 459 }
460 break;
461
462 case '&':
463ee0b2 463 if (len > 1)
464 break;
93a17b20 465 ampergv = gv;
466 sawampersand = TRUE;
a0d0e21e 467 goto ro_magicalize;
93a17b20 468
469 case '`':
463ee0b2 470 if (len > 1)
471 break;
93a17b20 472 leftgv = gv;
473 sawampersand = TRUE;
a0d0e21e 474 goto ro_magicalize;
93a17b20 475
476 case '\'':
463ee0b2 477 if (len > 1)
478 break;
93a17b20 479 rightgv = gv;
480 sawampersand = TRUE;
a0d0e21e 481 goto ro_magicalize;
93a17b20 482
483 case ':':
463ee0b2 484 if (len > 1)
485 break;
93a17b20 486 sv_setpv(GvSV(gv),chopset);
487 goto magicalize;
488
93a17b20 489 case '#':
a0d0e21e 490 case '*':
491 if (dowarn && len == 1 && sv_type == SVt_PV)
492 warn("Use of $%s is deprecated", name);
493 /* FALL THROUGH */
494 case '[':
495 case '!':
93a17b20 496 case '?':
497 case '^':
498 case '~':
499 case '=':
500 case '-':
501 case '%':
502 case '.':
93a17b20 503 case '(':
504 case ')':
505 case '<':
506 case '>':
507 case ',':
508 case '\\':
509 case '/':
93a17b20 510 case '|':
511 case '\004':
a0d0e21e 512 case '\010':
93a17b20 513 case '\t':
514 case '\020':
515 case '\024':
516 case '\027':
517 case '\006':
463ee0b2 518 if (len > 1)
519 break;
520 goto magicalize;
521
a0d0e21e 522 case '+':
463ee0b2 523 case '1':
524 case '2':
525 case '3':
526 case '4':
527 case '5':
528 case '6':
529 case '7':
530 case '8':
531 case '9':
a0d0e21e 532 ro_magicalize:
533 SvREADONLY_on(GvSV(gv));
93a17b20 534 magicalize:
463ee0b2 535 sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
93a17b20 536 break;
537
538 case '\014':
463ee0b2 539 if (len > 1)
540 break;
93a17b20 541 sv_setpv(GvSV(gv),"\f");
542 formfeed = GvSV(gv);
543 break;
544 case ';':
463ee0b2 545 if (len > 1)
546 break;
93a17b20 547 sv_setpv(GvSV(gv),"\034");
548 break;
463ee0b2 549 case ']':
550 if (len == 1) {
93a17b20 551 SV *sv;
552 sv = GvSV(gv);
553 sv_upgrade(sv, SVt_PVNV);
a0d0e21e 554 sv_setpv(sv, patchlevel);
93a17b20 555 }
556 break;
79072805 557 }
93a17b20 558 return gv;
79072805 559}
560
561void
562gv_fullname(sv,gv)
563SV *sv;
564GV *gv;
565{
566 HV *hv = GvSTASH(gv);
567
568 if (!hv)
569 return;
570 sv_setpv(sv, sv == (SV*)gv ? "*" : "");
571 sv_catpv(sv,HvNAME(hv));
463ee0b2 572 sv_catpvn(sv,"::", 2);
79072805 573 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
574}
575
576void
577gv_efullname(sv,gv)
578SV *sv;
579GV *gv;
580{
581 GV* egv = GvEGV(gv);
582 HV *hv = GvSTASH(egv);
583
584 if (!hv)
585 return;
586 sv_setpv(sv, sv == (SV*)gv ? "*" : "");
587 sv_catpv(sv,HvNAME(hv));
463ee0b2 588 sv_catpvn(sv,"::", 2);
79072805 589 sv_catpvn(sv,GvNAME(egv),GvNAMELEN(egv));
590}
591
592IO *
593newIO()
594{
595 IO *io;
8990e307 596 GV *iogv;
597
598 io = (IO*)NEWSV(0,0);
a0d0e21e 599 sv_upgrade((SV *)io,SVt_PVIO);
8990e307 600 SvREFCNT(io) = 1;
601 SvOBJECT_on(io);
85e6fe83 602 iogv = gv_fetchpv("FileHandle::", TRUE, SVt_PVIO);
8990e307 603 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
79072805 604 return io;
605}
606
607void
463ee0b2 608gv_check(stash)
609HV* stash;
79072805 610{
611 register HE *entry;
612 register I32 i;
613 register GV *gv;
463ee0b2 614 HV *hv;
a0d0e21e 615 GV *filegv;
463ee0b2 616
8990e307 617 if (!HvARRAY(stash))
618 return;
a0d0e21e 619 for (i = 0; i <= (I32) HvMAX(stash); i++) {
463ee0b2 620 for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) {
a0d0e21e 621 if (entry->hent_key[entry->hent_klen-1] == ':' &&
622 (gv = (GV*)entry->hent_val) && (hv = GvHV(gv)) && HvNAME(hv))
623 {
624 if (hv != defstash)
625 gv_check(hv); /* nested package */
626 }
627 else if (isALPHA(*entry->hent_key)) {
463ee0b2 628 gv = (GV*)entry->hent_val;
629 if (SvMULTI(gv))
630 continue;
631 curcop->cop_line = GvLINE(gv);
a0d0e21e 632 filegv = GvFILEGV(gv);
633 curcop->cop_filegv = filegv;
634 if (filegv && SvMULTI(filegv)) /* Filename began with slash */
8990e307 635 continue;
a0d0e21e 636 warn("Identifier \"%s::%s\" used only once: possible typo",
637 HvNAME(stash), GvNAME(gv));
463ee0b2 638 }
79072805 639 }
640 }
641}
642
643GV *
a0d0e21e 644newGVgen(pack)
645char *pack;
79072805 646{
a0d0e21e 647 (void)sprintf(tokenbuf,"%s::_GEN_%ld",pack,(long)gensym++);
85e6fe83 648 return gv_fetchpv(tokenbuf,TRUE, SVt_PVGV);
79072805 649}
650
651/* hopefully this is only called on local symbol table entries */
652
653GP*
654gp_ref(gp)
655GP* gp;
656{
657 gp->gp_refcnt++;
658 return gp;
659
660}
661
662void
663gp_free(gv)
664GV* gv;
665{
666 IO *io;
667 CV *cv;
668 GP* gp;
669
670 if (!gv || !(gp = GvGP(gv)))
671 return;
672 if (gp->gp_refcnt == 0) {
673 warn("Attempt to free unreferenced glob pointers");
674 return;
675 }
676 if (--gp->gp_refcnt > 0)
677 return;
678
8990e307 679 SvREFCNT_dec(gp->gp_sv);
680 SvREFCNT_dec(gp->gp_av);
681 SvREFCNT_dec(gp->gp_hv);
682 if ((io = gp->gp_io) && SvTYPE(io) != SVTYPEMASK) {
79072805 683 do_close(gv,FALSE);
8990e307 684 SvREFCNT_dec(io);
79072805 685 }
8990e307 686 if ((cv = gp->gp_cv) && !GvCVGEN(gv))
687 SvREFCNT_dec(cv);
79072805 688 Safefree(gp);
689 GvGP(gv) = 0;
690}
691
692#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
693#define MICROPORT
694#endif
695
696#ifdef MICROPORT /* Microport 2.4 hack */
697AV *GvAVn(gv)
698register GV *gv;
699{
700 if (GvGP(gv)->gp_av)
701 return GvGP(gv)->gp_av;
702 else
703 return GvGP(gv_AVadd(gv))->gp_av;
704}
705
706HV *GvHVn(gv)
707register GV *gv;
708{
709 if (GvGP(gv)->gp_hv)
710 return GvGP(gv)->gp_hv;
711 else
712 return GvGP(gv_HVadd(gv))->gp_hv;
713}
714#endif /* Microport 2.4 hack */
a0d0e21e 715
716#ifdef OVERLOAD
717/* Updates and caches the CV's */
718
719bool
720Gv_AMupdate(stash)
721HV* stash;
722{
723 GV** gvp;
724 HV* hv;
725 GV* gv;
726 CV* cv;
727 MAGIC* mg=mg_find((SV*)stash,'c');
728 AMT *amtp;
729
730 if (mg && (amtp=((AMT*)(mg->mg_ptr)))->was_ok_am == amagic_generation &&
731 amtp->was_ok_sub == sub_generation)
732 return HV_AMAGIC(stash)? TRUE: FALSE;
733 gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE);
734 sv_unmagic((SV*)stash, 'c');
735
736 DEBUG_o( deb("Recalcing overload magic in package %s\n",HvNAME(stash)) );
737
738 if (gvp && ((gv = *gvp) != (GV*)&sv_undef && (hv = GvHV(gv)))) {
739 int filled=0;
740 int i;
741 char *cp;
742 AMT amt;
743 SV* sv;
744 SV** svp;
745
746/* if (*(svp)==(SV*)amagic_generation && *(svp+1)==(SV*)sub_generation) {
747 DEBUG_o( deb("Overload magic in package %s up-to-date\n",HvNAME(stash))
748);
749 return HV_AMAGIC(stash)? TRUE: FALSE;
750 }*/
751
752 amt.was_ok_am=amagic_generation;
753 amt.was_ok_sub=sub_generation;
754 amt.fallback=AMGfallNO;
755
756 /* Work with "fallback" key, which we assume to be first in AMG_names */
757
758 if ((cp=((char**)(*AMG_names))[0]) &&
759 (svp=(SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
760 if (SvTRUE(sv)) amt.fallback=AMGfallYES;
761 else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
762 }
763
764 for (i=1;i<NofAMmeth*2;i++) {
765 cv=0;
766
767 if ( (cp=((char**)(*AMG_names))[i]) ) {
768 svp=(SV**)hv_fetch(hv,cp,strlen(cp),FALSE);
769 if (svp && ((sv = *svp) != (GV*)&sv_undef)) {
770 switch (SvTYPE(sv)) {
771 default:
772 if (!SvROK(sv)) {
773 if (!SvOK(sv)) break;
774 gv = gv_fetchmethod(curcop->cop_stash, SvPV(sv, na));
775 if (gv) cv = GvCV(gv);
776 break;
777 }
778 cv = (CV*)SvRV(sv);
779 if (SvTYPE(cv) == SVt_PVCV)
780 break;
781 /* FALL THROUGH */
782 case SVt_PVHV:
783 case SVt_PVAV:
784 die("Not a subroutine reference in %%OVERLOAD");
785 return FALSE;
786 case SVt_PVCV:
787 cv = (CV*)sv;
788 break;
789 case SVt_PVGV:
790 if (!(cv = GvCV((GV*)sv)))
791 cv = sv_2cv(sv, &stash, &gv, TRUE);
792 break;
793 }
794 if (cv) filled=1;
795 else {
796 die("Method for operation %s not found in package %s during blessing\n",
797 cp,HvNAME(stash));
798 return FALSE;
799 }
800 }
801 }
802 amt.table[i]=cv;
803 }
804 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(amt));
805 if (filled) {
806/* HV_badAMAGIC_off(stash);*/
807 HV_AMAGIC_on(stash);
808 return TRUE;
809 }
810 }
811/*HV_badAMAGIC_off(stash);*/
812 HV_AMAGIC_off(stash);
813 return FALSE;
814}
815
816/* During call to this subroutine stack can be reallocated. It is
817 * advised to call SPAGAIN macro in your code after call */
818
819SV*
820amagic_call(left,right,method,flags)
821SV* left;
822SV* right;
823int method;
824int flags;
825{
826 MAGIC *mg;
827 CV *cv;
828 CV **cvp=NULL, **ocvp=NULL;
829 AMT *amtp, *oamtp;
830 int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
831 int postpr=0;
832 HV* stash;
833 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
834 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
835 && (ocvp = cvp = ((oamtp=amtp=(AMT*)mg->mg_ptr)->table))
836 && (assign ?
837 ((cv = cvp[off=method+1])
838 || ( amtp->fallback > AMGfallNEVER && /* fallback to
839 * usual method */
840 (fl = 1, cv = cvp[off=method]))):
841 (1 && (cv = cvp[off=method])) )) {
842 lr = -1; /* Call method for left argument */
843 } else {
844 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
845 int logic;
846
847 /* look for substituted methods */
848 switch (method) {
849 case inc_amg:
850 if ((cv = cvp[off=add_ass_amg])
851 || ((cv = cvp[off=add_amg]) && (postpr=1))) {
852 right = &sv_yes; lr = -1; assign = 1;
853 }
854 break;
855 case dec_amg:
856 if ((cv = cvp[off=subtr_ass_amg])
857 || ((cv = cvp[off=subtr_amg]) && (postpr=1))) {
858 right = &sv_yes; lr = -1; assign = 1;
859 }
860 break;
861 case bool__amg:
862 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
863 break;
864 case numer_amg:
865 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
866 break;
867 case string_amg:
868 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
869 break;
870 case abs_amg:
871 if ((cvp[off1=lt_amg] || cvp[off1=lt_amg])
872 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
873 if (off1==lt_amg) {
874 SV* lessp = amagic_call(left,
875 sv_2mortal(newSViv(0)),
876 lt_amg,AMGf_noright);
877 logic = SvTRUE(lessp);
878 } else {
879 SV* lessp = amagic_call(left,
880 sv_2mortal(newSViv(0)),
881 ncmp_amg,AMGf_noright);
882 logic = (SvNV(lessp) < 0);
883 }
884 if (logic) {
885 if (off==subtr_amg) {
886 right = left;
887 left = sv_2mortal(newSViv(0));
888 lr = 1;
889 }
890 } else {
891 return left;
892 }
893 }
894 break;
895 case neg_amg:
896 if (cv = cvp[off=subtr_amg]) {
897 right = left;
898 left = sv_2mortal(newSViv(0));
899 lr = 1;
900 }
901 break;
902 default:
903 goto not_found;
904 }
905 if (!cv) goto not_found;
906 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
907 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
908 && (cvp = ((amtp=(AMT*)mg->mg_ptr)->table))
909 && (cv = cvp[off=method])) { /* Method for right
910 * argument found */
911 lr=1;
912 } else if (((ocvp && oamtp->fallback > AMGfallNEVER && (cvp=ocvp))
913 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
914 && !(flags & AMGf_unary)) {
915 /* We look for substitution for
916 * comparison operations and
917 * concatendation */
918 if (method==concat_amg || method==concat_ass_amg
919 || method==repeat_amg || method==repeat_ass_amg) {
920 return NULL; /* Delegate operation to string conversion */
921 }
922 off = -1;
923 switch (method) {
924 case lt_amg:
925 case le_amg:
926 case gt_amg:
927 case ge_amg:
928 case eq_amg:
929 case ne_amg:
930 postpr = 1; off=ncmp_amg; break;
931 case slt_amg:
932 case sle_amg:
933 case sgt_amg:
934 case sge_amg:
935 case seq_amg:
936 case sne_amg:
937 postpr = 1; off=scmp_amg; break;
938 }
939 if (off != -1) cv = cvp[off];
940 if (!cv) {
941 goto not_found;
942 }
943 } else {
944 not_found: /* No method found, either report or die */
945 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
946 notfound = 1; lr = -1;
947 } else if (cvp && (cv=cvp[nomethod_amg])) {
948 notfound = 1; lr = 1;
949 } else {
950 char tmpstr[512];
951 sprintf(tmpstr,"Operation `%s': no method found,\n\tleft argument %s%200s,\n\tright argument %s%200s",
952 ((char**)AMG_names)[off],
953 SvAMAGIC(left)?
954 "in overloaded package ":
955 "has no overloaded magic",
956 SvAMAGIC(left)?
957 HvNAME(SvSTASH(SvRV(left))):
958 "",
959 SvAMAGIC(right)?
960 "in overloaded package ":
961 "has no overloaded magic",
962 SvAMAGIC(right)?
963 HvNAME(SvSTASH(SvRV(right))):
964 "");
965 if (amtp && amtp->fallback >= AMGfallYES) {
966 DEBUG_o( deb(tmpstr) );
967 } else {
968 die(tmpstr);
969 }
970 return NULL;
971 }
972 }
973 }
974 if (!notfound) {
975 DEBUG_o( deb("Operation `%s': method for %s argument found in package %s%s\n",
976 ((char**)AMG_names)[off],
977 (lr? "right": "left"),
978 HvNAME(stash),
979 fl? ",\n\tassignment variant used": "") );
980 /* Since we use shallow copy, we need to dublicate the contents,
981 probably we need also to use user-supplied version of coping?
982 */
983 if (assign || method==inc_amg || method==dec_amg) RvDEEPCP(left);
984 }
985 {
986 dSP;
987 BINOP myop;
988 SV* res;
989
990 Zero(&myop, 1, BINOP);
991 myop.op_last = (OP *) &myop;
992 myop.op_next = Nullop;
993 myop.op_flags = OPf_KNOW|OPf_STACKED;
994
995 ENTER;
996 SAVESPTR(op);
997 op = (OP *) &myop;
998 PUTBACK;
999 pp_pushmark();
1000
1001 EXTEND(sp, notfound + 5);
1002 PUSHs(lr>0? right: left);
1003 PUSHs(lr>0? left: right);
1004 PUSHs( assign ? &sv_undef : (lr>0? &sv_yes: &sv_no));
1005 if (notfound) {
1006 PUSHs( sv_2mortal(newSVpv(((char**)AMG_names)[off],0)) );
1007 }
1008 PUSHs((SV*)cv);
1009 PUTBACK;
1010
1011 if (op = pp_entersub())
1012 run();
1013 LEAVE;
1014 SPAGAIN;
1015
1016 res=POPs;
1017 PUTBACK;
1018
1019 if (notfound) {
1020 /* sv_2mortal(res); */
1021 return NULL;
1022 }
1023
1024 if (postpr) {
1025 int ans;
1026 switch (method) {
1027 case le_amg:
1028 case sle_amg:
1029 ans=SvIV(res)<=0; break;
1030 case lt_amg:
1031 case slt_amg:
1032 ans=SvIV(res)<0; break;
1033 case ge_amg:
1034 case sge_amg:
1035 ans=SvIV(res)>=0; break;
1036 case gt_amg:
1037 case sgt_amg:
1038 ans=SvIV(res)>0; break;
1039 case eq_amg:
1040 case seq_amg:
1041 ans=SvIV(res)==0; break;
1042 case ne_amg:
1043 case sne_amg:
1044 ans=SvIV(res)!=0; break;
1045 case inc_amg:
1046 case dec_amg:
1047 SvSetSV(left,res); return res; break;
1048 }
1049 return ans? &sv_yes: &sv_no;
1050 } else {
1051 return res;
1052 }
1053 }
1054}
1055#endif /* OVERLOAD */
Unnamed repository; edit this file to name it for gitweb.