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