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