1 /* gv.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others 5 * 6 * You may distribute under the terms of either the GNU General Public 7 * License or the Artistic License, as specified in the README file. 8 * 9 */ 10 11 /* 12 * 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure 13 * of your inquisitiveness, I shall spend all the rest of my days in answering 14 * you. What more do you want to know?' 15 * 'The names of all the stars, and of all living things, and the whole 16 * history of Middle-earth and Over-heaven and of the Sundering Seas,' 17 * laughed Pippin. 18 * 19 * [p.599 of _The Lord of the Rings_, III/xi: "The Palant�r"] 20 */ 21 22 /* 23 =head1 GV Functions 24 25 A GV is a structure which corresponds to to a Perl typeglob, ie *foo. 26 It is a structure that holds a pointer to a scalar, an array, a hash etc, 27 corresponding to $foo, @foo, %foo. 28 29 GVs are usually found as values in stashes (symbol table hashes) where 30 Perl stores its global variables. 31 32 =cut 33 */ 34 35 #include "EXTERN.h" 36 #define PERL_IN_GV_C 37 #include "perl.h" 38 #include "overload.c" 39 40 static const char S_autoload[] = "AUTOLOAD"; 41 static const STRLEN S_autolen = sizeof(S_autoload)-1; 42 43 GV * 44 Perl_gv_add_by_type(pTHX_ GV *gv, svtype type) 45 { 46 SV **where; 47 48 if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) { 49 const char *what; 50 if (type == SVt_PVIO) { 51 /* 52 * if it walks like a dirhandle, then let's assume that 53 * this is a dirhandle. 54 */ 55 what = PL_op->op_type == OP_READDIR || 56 PL_op->op_type == OP_TELLDIR || 57 PL_op->op_type == OP_SEEKDIR || 58 PL_op->op_type == OP_REWINDDIR || 59 PL_op->op_type == OP_CLOSEDIR ? 60 "dirhandle" : "filehandle"; 61 /* diag_listed_as: Bad symbol for filehandle */ 62 } else if (type == SVt_PVHV) { 63 what = "hash"; 64 } else { 65 what = type == SVt_PVAV ? "array" : "scalar"; 66 } 67 Perl_croak(aTHX_ "Bad symbol for %s", what); 68 } 69 70 if (type == SVt_PVHV) { 71 where = (SV **)&GvHV(gv); 72 } else if (type == SVt_PVAV) { 73 where = (SV **)&GvAV(gv); 74 } else if (type == SVt_PVIO) { 75 where = (SV **)&GvIOp(gv); 76 } else { 77 where = &GvSV(gv); 78 } 79 80 if (!*where) 81 *where = newSV_type(type); 82 return gv; 83 } 84 85 GV * 86 Perl_gv_fetchfile(pTHX_ const char *name) 87 { 88 PERL_ARGS_ASSERT_GV_FETCHFILE; 89 return gv_fetchfile_flags(name, strlen(name), 0); 90 } 91 92 GV * 93 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, 94 const U32 flags) 95 { 96 dVAR; 97 char smallbuf[128]; 98 char *tmpbuf; 99 const STRLEN tmplen = namelen + 2; 100 GV *gv; 101 102 PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS; 103 PERL_UNUSED_ARG(flags); 104 105 if (!PL_defstash) 106 return NULL; 107 108 if (tmplen <= sizeof smallbuf) 109 tmpbuf = smallbuf; 110 else 111 Newx(tmpbuf, tmplen, char); 112 /* This is where the debugger's %{"::_<$filename"} hash is created */ 113 tmpbuf[0] = '_'; 114 tmpbuf[1] = '<'; 115 memcpy(tmpbuf + 2, name, namelen); 116 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE); 117 if (!isGV(gv)) { 118 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE); 119 #ifdef PERL_DONT_CREATE_GVSV 120 GvSV(gv) = newSVpvn(name, namelen); 121 #else 122 sv_setpvn(GvSV(gv), name, namelen); 123 #endif 124 if (PERLDB_LINE || PERLDB_SAVESRC) 125 hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile); 126 } 127 if (tmpbuf != smallbuf) 128 Safefree(tmpbuf); 129 return gv; 130 } 131 132 /* 133 =for apidoc gv_const_sv 134 135 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for 136 inlining, or C<gv> is a placeholder reference that would be promoted to such 137 a typeglob, then returns the value returned by the sub. Otherwise, returns 138 NULL. 139 140 =cut 141 */ 142 143 SV * 144 Perl_gv_const_sv(pTHX_ GV *gv) 145 { 146 PERL_ARGS_ASSERT_GV_CONST_SV; 147 148 if (SvTYPE(gv) == SVt_PVGV) 149 return cv_const_sv(GvCVu(gv)); 150 return SvROK(gv) ? SvRV(gv) : NULL; 151 } 152 153 GP * 154 Perl_newGP(pTHX_ GV *const gv) 155 { 156 GP *gp; 157 U32 hash; 158 #ifdef USE_ITHREADS 159 const char *const file 160 = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : ""; 161 const STRLEN len = strlen(file); 162 #else 163 SV *const temp_sv = CopFILESV(PL_curcop); 164 const char *file; 165 STRLEN len; 166 167 PERL_ARGS_ASSERT_NEWGP; 168 169 if (temp_sv) { 170 file = SvPVX(temp_sv); 171 len = SvCUR(temp_sv); 172 } else { 173 file = ""; 174 len = 0; 175 } 176 #endif 177 178 PERL_HASH(hash, file, len); 179 180 Newxz(gp, 1, GP); 181 182 #ifndef PERL_DONT_CREATE_GVSV 183 gp->gp_sv = newSV(0); 184 #endif 185 186 gp->gp_line = PL_curcop ? CopLINE(PL_curcop) : 0; 187 /* XXX Ideally this cast would be replaced with a change to const char* 188 in the struct. */ 189 gp->gp_file_hek = share_hek(file, len, hash); 190 gp->gp_egv = gv; 191 gp->gp_refcnt = 1; 192 193 return gp; 194 } 195 196 void 197 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) 198 { 199 dVAR; 200 const U32 old_type = SvTYPE(gv); 201 const bool doproto = old_type > SVt_NULL; 202 char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL; 203 const STRLEN protolen = proto ? SvCUR(gv) : 0; 204 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL; 205 const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0; 206 207 PERL_ARGS_ASSERT_GV_INIT; 208 assert (!(proto && has_constant)); 209 210 if (has_constant) { 211 /* The constant has to be a simple scalar type. */ 212 switch (SvTYPE(has_constant)) { 213 case SVt_PVAV: 214 case SVt_PVHV: 215 case SVt_PVCV: 216 case SVt_PVFM: 217 case SVt_PVIO: 218 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob", 219 sv_reftype(has_constant, 0)); 220 default: NOOP; 221 } 222 SvRV_set(gv, NULL); 223 SvROK_off(gv); 224 } 225 226 227 if (old_type < SVt_PVGV) { 228 if (old_type >= SVt_PV) 229 SvCUR_set(gv, 0); 230 sv_upgrade(MUTABLE_SV(gv), SVt_PVGV); 231 } 232 if (SvLEN(gv)) { 233 if (proto) { 234 SvPV_set(gv, NULL); 235 SvLEN_set(gv, 0); 236 SvPOK_off(gv); 237 } else 238 Safefree(SvPVX_mutable(gv)); 239 } 240 SvIOK_off(gv); 241 isGV_with_GP_on(gv); 242 243 GvGP(gv) = Perl_newGP(aTHX_ gv); 244 GvSTASH(gv) = stash; 245 if (stash) 246 Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv)); 247 gv_name_set(gv, name, len, GV_ADD); 248 if (multi || doproto) /* doproto means it _was_ mentioned */ 249 GvMULTI_on(gv); 250 if (doproto) { /* Replicate part of newSUB here. */ 251 ENTER; 252 if (has_constant) { 253 /* newCONSTSUB takes ownership of the reference from us. */ 254 GvCV(gv) = newCONSTSUB(stash, name, has_constant); 255 /* If this reference was a copy of another, then the subroutine 256 must have been "imported", by a Perl space assignment to a GV 257 from a reference to CV. */ 258 if (exported_constant) 259 GvIMPORTED_CV_on(gv); 260 } else { 261 (void) start_subparse(0,0); /* Create empty CV in compcv. */ 262 GvCV(gv) = PL_compcv; 263 } 264 LEAVE; 265 266 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */ 267 CvGV(GvCV(gv)) = gv; 268 CvFILE_set_from_cop(GvCV(gv), PL_curcop); 269 CvSTASH(GvCV(gv)) = PL_curstash; 270 if (proto) { 271 sv_usepvn_flags(MUTABLE_SV(GvCV(gv)), proto, protolen, 272 SV_HAS_TRAILING_NUL); 273 } 274 } 275 } 276 277 STATIC void 278 S_gv_init_sv(pTHX_ GV *gv, const svtype sv_type) 279 { 280 PERL_ARGS_ASSERT_GV_INIT_SV; 281 282 switch (sv_type) { 283 case SVt_PVIO: 284 (void)GvIOn(gv); 285 break; 286 case SVt_PVAV: 287 (void)GvAVn(gv); 288 break; 289 case SVt_PVHV: 290 (void)GvHVn(gv); 291 break; 292 #ifdef PERL_DONT_CREATE_GVSV 293 case SVt_NULL: 294 case SVt_PVCV: 295 case SVt_PVFM: 296 case SVt_PVGV: 297 break; 298 default: 299 if(GvSVn(gv)) { 300 /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13 301 If we just cast GvSVn(gv) to void, it ignores evaluating it for 302 its side effect */ 303 } 304 #endif 305 } 306 } 307 308 /* 309 =for apidoc gv_fetchmeth 310 311 Returns the glob with the given C<name> and a defined subroutine or 312 C<NULL>. The glob lives in the given C<stash>, or in the stashes 313 accessible via @ISA and UNIVERSAL::. 314 315 The argument C<level> should be either 0 or -1. If C<level==0>, as a 316 side-effect creates a glob with the given C<name> in the given C<stash> 317 which in the case of success contains an alias for the subroutine, and sets 318 up caching info for this glob. 319 320 This function grants C<"SUPER"> token as a postfix of the stash name. The 321 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not 322 visible to Perl code. So when calling C<call_sv>, you should not use 323 the GV directly; instead, you should use the method's CV, which can be 324 obtained from the GV with the C<GvCV> macro. 325 326 =cut 327 */ 328 329 /* NOTE: No support for tied ISA */ 330 331 GV * 332 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) 333 { 334 dVAR; 335 GV** gvp; 336 AV* linear_av; 337 SV** linear_svp; 338 SV* linear_sv; 339 HV* cstash; 340 GV* candidate = NULL; 341 CV* cand_cv = NULL; 342 CV* old_cv; 343 GV* topgv = NULL; 344 const char *hvname; 345 I32 create = (level >= 0) ? 1 : 0; 346 I32 items; 347 STRLEN packlen; 348 U32 topgen_cmp; 349 350 PERL_ARGS_ASSERT_GV_FETCHMETH; 351 352 /* UNIVERSAL methods should be callable without a stash */ 353 if (!stash) { 354 create = 0; /* probably appropriate */ 355 if(!(stash = gv_stashpvs("UNIVERSAL", 0))) 356 return 0; 357 } 358 359 assert(stash); 360 361 hvname = HvNAME_get(stash); 362 if (!hvname) 363 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); 364 365 assert(hvname); 366 assert(name); 367 368 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) ); 369 370 topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation; 371 372 /* check locally for a real method or a cache entry */ 373 gvp = (GV**)hv_fetch(stash, name, len, create); 374 if(gvp) { 375 topgv = *gvp; 376 assert(topgv); 377 if (SvTYPE(topgv) != SVt_PVGV) 378 gv_init(topgv, stash, name, len, TRUE); 379 if ((cand_cv = GvCV(topgv))) { 380 /* If genuine method or valid cache entry, use it */ 381 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) { 382 return topgv; 383 } 384 else { 385 /* stale cache entry, junk it and move on */ 386 SvREFCNT_dec(cand_cv); 387 GvCV(topgv) = cand_cv = NULL; 388 GvCVGEN(topgv) = 0; 389 } 390 } 391 else if (GvCVGEN(topgv) == topgen_cmp) { 392 /* cache indicates no such method definitively */ 393 return 0; 394 } 395 } 396 397 packlen = HvNAMELEN_get(stash); 398 if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) { 399 HV* basestash; 400 packlen -= 7; 401 basestash = gv_stashpvn(hvname, packlen, GV_ADD); 402 linear_av = mro_get_linear_isa(basestash); 403 } 404 else { 405 linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */ 406 } 407 408 linear_svp = AvARRAY(linear_av) + 1; /* skip over self */ 409 items = AvFILLp(linear_av); /* no +1, to skip over self */ 410 while (items--) { 411 linear_sv = *linear_svp++; 412 assert(linear_sv); 413 cstash = gv_stashsv(linear_sv, 0); 414 415 if (!cstash) { 416 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA", 417 SVfARG(linear_sv), hvname); 418 continue; 419 } 420 421 assert(cstash); 422 423 gvp = (GV**)hv_fetch(cstash, name, len, 0); 424 if (!gvp) continue; 425 candidate = *gvp; 426 assert(candidate); 427 if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, name, len, TRUE); 428 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { 429 /* 430 * Found real method, cache method in topgv if: 431 * 1. topgv has no synonyms (else inheritance crosses wires) 432 * 2. method isn't a stub (else AUTOLOAD fails spectacularly) 433 */ 434 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { 435 if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv); 436 SvREFCNT_inc_simple_void_NN(cand_cv); 437 GvCV(topgv) = cand_cv; 438 GvCVGEN(topgv) = topgen_cmp; 439 } 440 return candidate; 441 } 442 } 443 444 /* Check UNIVERSAL without caching */ 445 if(level == 0 || level == -1) { 446 candidate = gv_fetchmeth(NULL, name, len, 1); 447 if(candidate) { 448 cand_cv = GvCV(candidate); 449 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { 450 if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv); 451 SvREFCNT_inc_simple_void_NN(cand_cv); 452 GvCV(topgv) = cand_cv; 453 GvCVGEN(topgv) = topgen_cmp; 454 } 455 return candidate; 456 } 457 } 458 459 if (topgv && GvREFCNT(topgv) == 1) { 460 /* cache the fact that the method is not defined */ 461 GvCVGEN(topgv) = topgen_cmp; 462 } 463 464 return 0; 465 } 466 467 /* 468 =for apidoc gv_fetchmeth_autoload 469 470 Same as gv_fetchmeth(), but looks for autoloaded subroutines too. 471 Returns a glob for the subroutine. 472 473 For an autoloaded subroutine without a GV, will create a GV even 474 if C<level < 0>. For an autoloaded subroutine without a stub, GvCV() 475 of the result may be zero. 476 477 =cut 478 */ 479 480 GV * 481 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) 482 { 483 GV *gv = gv_fetchmeth(stash, name, len, level); 484 485 PERL_ARGS_ASSERT_GV_FETCHMETH_AUTOLOAD; 486 487 if (!gv) { 488 CV *cv; 489 GV **gvp; 490 491 if (!stash) 492 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */ 493 if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) 494 return NULL; 495 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE))) 496 return NULL; 497 cv = GvCV(gv); 498 if (!(CvROOT(cv) || CvXSUB(cv))) 499 return NULL; 500 /* Have an autoload */ 501 if (level < 0) /* Cannot do without a stub */ 502 gv_fetchmeth(stash, name, len, 0); 503 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); 504 if (!gvp) 505 return NULL; 506 return *gvp; 507 } 508 return gv; 509 } 510 511 /* 512 =for apidoc gv_fetchmethod_autoload 513 514 Returns the glob which contains the subroutine to call to invoke the method 515 on the C<stash>. In fact in the presence of autoloading this may be the 516 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is 517 already setup. 518 519 The third parameter of C<gv_fetchmethod_autoload> determines whether 520 AUTOLOAD lookup is performed if the given method is not present: non-zero 521 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD. 522 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload> 523 with a non-zero C<autoload> parameter. 524 525 These functions grant C<"SUPER"> token as a prefix of the method name. Note 526 that if you want to keep the returned glob for a long time, you need to 527 check for it being "AUTOLOAD", since at the later time the call may load a 528 different subroutine due to $AUTOLOAD changing its value. Use the glob 529 created via a side effect to do this. 530 531 These functions have the same side-effects and as C<gv_fetchmeth> with 532 C<level==0>. C<name> should be writable if contains C<':'> or C<' 533 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to 534 C<call_sv> apply equally to these functions. 535 536 =cut 537 */ 538 539 STATIC HV* 540 S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen) 541 { 542 AV* superisa; 543 GV** gvp; 544 GV* gv; 545 HV* stash; 546 547 PERL_ARGS_ASSERT_GV_GET_SUPER_PKG; 548 549 stash = gv_stashpvn(name, namelen, 0); 550 if(stash) return stash; 551 552 /* If we must create it, give it an @ISA array containing 553 the real package this SUPER is for, so that it's tied 554 into the cache invalidation code correctly */ 555 stash = gv_stashpvn(name, namelen, GV_ADD); 556 gvp = (GV**)hv_fetchs(stash, "ISA", TRUE); 557 gv = *gvp; 558 gv_init(gv, stash, "ISA", 3, TRUE); 559 superisa = GvAVn(gv); 560 GvMULTI_on(gv); 561 sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0); 562 #ifdef USE_ITHREADS 563 av_push(superisa, newSVpv(CopSTASHPV(PL_curcop), 0)); 564 #else 565 av_push(superisa, newSVhek(CopSTASH(PL_curcop) 566 ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL)); 567 #endif 568 569 return stash; 570 } 571 572 GV * 573 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) 574 { 575 PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD; 576 577 return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0); 578 } 579 580 /* Don't merge this yet, as it's likely to get a len parameter, and possibly 581 even a U32 hash */ 582 GV * 583 Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags) 584 { 585 dVAR; 586 register const char *nend; 587 const char *nsplit = NULL; 588 GV* gv; 589 HV* ostash = stash; 590 const char * const origname = name; 591 SV *const error_report = MUTABLE_SV(stash); 592 const U32 autoload = flags & GV_AUTOLOAD; 593 const U32 do_croak = flags & GV_CROAK; 594 595 PERL_ARGS_ASSERT_GV_FETCHMETHOD_FLAGS; 596 597 if (SvTYPE(stash) < SVt_PVHV) 598 stash = NULL; 599 else { 600 /* The only way stash can become NULL later on is if nsplit is set, 601 which in turn means that there is no need for a SVt_PVHV case 602 the error reporting code. */ 603 } 604 605 for (nend = name; *nend; nend++) { 606 if (*nend == '\'') { 607 nsplit = nend; 608 name = nend + 1; 609 } 610 else if (*nend == ':' && *(nend + 1) == ':') { 611 nsplit = nend++; 612 name = nend + 1; 613 } 614 } 615 if (nsplit) { 616 if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) { 617 /* ->SUPER::method should really be looked up in original stash */ 618 SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", 619 CopSTASHPV(PL_curcop))); 620 /* __PACKAGE__::SUPER stash should be autovivified */ 621 stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr)); 622 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", 623 origname, HvNAME_get(stash), name) ); 624 } 625 else { 626 /* don't autovifify if ->NoSuchStash::method */ 627 stash = gv_stashpvn(origname, nsplit - origname, 0); 628 629 /* however, explicit calls to Pkg::SUPER::method may 630 happen, and may require autovivification to work */ 631 if (!stash && (nsplit - origname) >= 7 && 632 strnEQ(nsplit - 7, "::SUPER", 7) && 633 gv_stashpvn(origname, nsplit - origname - 7, 0)) 634 stash = gv_get_super_pkg(origname, nsplit - origname); 635 } 636 ostash = stash; 637 } 638 639 gv = gv_fetchmeth(stash, name, nend - name, 0); 640 if (!gv) { 641 if (strEQ(name,"import") || strEQ(name,"unimport")) 642 gv = MUTABLE_GV(&PL_sv_yes); 643 else if (autoload) 644 gv = gv_autoload4(ostash, name, nend - name, TRUE); 645 if (!gv && do_croak) { 646 /* Right now this is exclusively for the benefit of S_method_common 647 in pp_hot.c */ 648 if (stash) { 649 Perl_croak(aTHX_ 650 "Can't locate object method \"%s\" via package \"%.*s\"", 651 name, (int)HvNAMELEN_get(stash), HvNAME_get(stash)); 652 } 653 else { 654 STRLEN packlen; 655 const char *packname; 656 657 if (nsplit) { 658 packlen = nsplit - origname; 659 packname = origname; 660 } else { 661 packname = SvPV_const(error_report, packlen); 662 } 663 664 Perl_croak(aTHX_ 665 "Can't locate object method \"%s\" via package \"%.*s\"" 666 " (perhaps you forgot to load \"%.*s\"?)", 667 name, (int)packlen, packname, (int)packlen, packname); 668 } 669 } 670 } 671 else if (autoload) { 672 CV* const cv = GvCV(gv); 673 if (!CvROOT(cv) && !CvXSUB(cv)) { 674 GV* stubgv; 675 GV* autogv; 676 677 if (CvANON(cv)) 678 stubgv = gv; 679 else { 680 stubgv = CvGV(cv); 681 if (GvCV(stubgv) != cv) /* orphaned import */ 682 stubgv = gv; 683 } 684 autogv = gv_autoload4(GvSTASH(stubgv), 685 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE); 686 if (autogv) 687 gv = autogv; 688 } 689 } 690 691 return gv; 692 } 693 694 GV* 695 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) 696 { 697 dVAR; 698 GV* gv; 699 CV* cv; 700 HV* varstash; 701 GV* vargv; 702 SV* varsv; 703 const char *packname = ""; 704 STRLEN packname_len = 0; 705 706 PERL_ARGS_ASSERT_GV_AUTOLOAD4; 707 708 if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) 709 return NULL; 710 if (stash) { 711 if (SvTYPE(stash) < SVt_PVHV) { 712 packname = SvPV_const(MUTABLE_SV(stash), packname_len); 713 stash = NULL; 714 } 715 else { 716 packname = HvNAME_get(stash); 717 packname_len = HvNAMELEN_get(stash); 718 } 719 } 720 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE))) 721 return NULL; 722 cv = GvCV(gv); 723 724 if (!(CvROOT(cv) || CvXSUB(cv))) 725 return NULL; 726 727 /* 728 * Inheriting AUTOLOAD for non-methods works ... for now. 729 */ 730 if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash) 731 ) 732 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), 733 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", 734 packname, (int)len, name); 735 736 if (CvISXSUB(cv)) { 737 /* rather than lookup/init $AUTOLOAD here 738 * only to have the XSUB do another lookup for $AUTOLOAD 739 * and split that value on the last '::', 740 * pass along the same data via some unused fields in the CV 741 */ 742 CvSTASH(cv) = stash; 743 SvPV_set(cv, (char *)name); /* cast to lose constness warning */ 744 SvCUR_set(cv, len); 745 return gv; 746 } 747 748 /* 749 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name. 750 * The subroutine's original name may not be "AUTOLOAD", so we don't 751 * use that, but for lack of anything better we will use the sub's 752 * original package to look up $AUTOLOAD. 753 */ 754 varstash = GvSTASH(CvGV(cv)); 755 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE); 756 ENTER; 757 758 if (!isGV(vargv)) { 759 gv_init(vargv, varstash, S_autoload, S_autolen, FALSE); 760 #ifdef PERL_DONT_CREATE_GVSV 761 GvSV(vargv) = newSV(0); 762 #endif 763 } 764 LEAVE; 765 varsv = GvSVn(vargv); 766 sv_setpvn(varsv, packname, packname_len); 767 sv_catpvs(varsv, "::"); 768 sv_catpvn(varsv, name, len); 769 return gv; 770 } 771 772 773 /* require_tie_mod() internal routine for requiring a module 774 * that implements the logic of automatical ties like %! and %- 775 * 776 * The "gv" parameter should be the glob. 777 * "varpv" holds the name of the var, used for error messages. 778 * "namesv" holds the module name. Its refcount will be decremented. 779 * "methpv" holds the method name to test for to check that things 780 * are working reasonably close to as expected. 781 * "flags": if flag & 1 then save the scalar before loading. 782 * For the protection of $! to work (it is set by this routine) 783 * the sv slot must already be magicalized. 784 */ 785 STATIC HV* 786 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags) 787 { 788 dVAR; 789 HV* stash = gv_stashsv(namesv, 0); 790 791 PERL_ARGS_ASSERT_REQUIRE_TIE_MOD; 792 793 if (!stash || !(gv_fetchmethod(stash, methpv))) { 794 SV *module = newSVsv(namesv); 795 char varname = *varpv; /* varpv might be clobbered by load_module, 796 so save it. For the moment it's always 797 a single char. */ 798 dSP; 799 ENTER; 800 if ( flags & 1 ) 801 save_scalar(gv); 802 PUSHSTACKi(PERLSI_MAGIC); 803 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL); 804 POPSTACK; 805 LEAVE; 806 SPAGAIN; 807 stash = gv_stashsv(namesv, 0); 808 if (!stash) 809 Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available", 810 varname, SVfARG(namesv)); 811 else if (!gv_fetchmethod(stash, methpv)) 812 Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s", 813 varname, SVfARG(namesv), methpv); 814 } 815 SvREFCNT_dec(namesv); 816 return stash; 817 } 818 819 /* 820 =for apidoc gv_stashpv 821 822 Returns a pointer to the stash for a specified package. Uses C<strlen> to 823 determine the length of C<name>, then calls C<gv_stashpvn()>. 824 825 =cut 826 */ 827 828 HV* 829 Perl_gv_stashpv(pTHX_ const char *name, I32 create) 830 { 831 PERL_ARGS_ASSERT_GV_STASHPV; 832 return gv_stashpvn(name, strlen(name), create); 833 } 834 835 /* 836 =for apidoc gv_stashpvn 837 838 Returns a pointer to the stash for a specified package. The C<namelen> 839 parameter indicates the length of the C<name>, in bytes. C<flags> is passed 840 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be 841 created if it does not already exist. If the package does not exist and 842 C<flags> is 0 (or any other setting that does not create packages) then NULL 843 is returned. 844 845 846 =cut 847 */ 848 849 HV* 850 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) 851 { 852 char smallbuf[128]; 853 char *tmpbuf; 854 HV *stash; 855 GV *tmpgv; 856 U32 tmplen = namelen + 2; 857 858 PERL_ARGS_ASSERT_GV_STASHPVN; 859 860 if (tmplen <= sizeof smallbuf) 861 tmpbuf = smallbuf; 862 else 863 Newx(tmpbuf, tmplen, char); 864 Copy(name, tmpbuf, namelen, char); 865 tmpbuf[namelen] = ':'; 866 tmpbuf[namelen+1] = ':'; 867 tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV); 868 if (tmpbuf != smallbuf) 869 Safefree(tmpbuf); 870 if (!tmpgv) 871 return NULL; 872 if (!GvHV(tmpgv)) 873 GvHV(tmpgv) = newHV(); 874 stash = GvHV(tmpgv); 875 if (!HvNAME_get(stash)) 876 hv_name_set(stash, name, namelen, 0); 877 return stash; 878 } 879 880 /* 881 =for apidoc gv_stashsv 882 883 Returns a pointer to the stash for a specified package. See C<gv_stashpvn>. 884 885 =cut 886 */ 887 888 HV* 889 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags) 890 { 891 STRLEN len; 892 const char * const ptr = SvPV_const(sv,len); 893 894 PERL_ARGS_ASSERT_GV_STASHSV; 895 896 return gv_stashpvn(ptr, len, flags); 897 } 898 899 900 GV * 901 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) { 902 PERL_ARGS_ASSERT_GV_FETCHPV; 903 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type); 904 } 905 906 GV * 907 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) { 908 STRLEN len; 909 const char * const nambeg = SvPV_const(name, len); 910 PERL_ARGS_ASSERT_GV_FETCHSV; 911 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type); 912 } 913 914 GV * 915 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, 916 const svtype sv_type) 917 { 918 dVAR; 919 register const char *name = nambeg; 920 register GV *gv = NULL; 921 GV**gvp; 922 I32 len; 923 register const char *name_cursor; 924 HV *stash = NULL; 925 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT); 926 const I32 no_expand = flags & GV_NOEXPAND; 927 const I32 add = flags & ~GV_NOADD_MASK; 928 const char *const name_end = nambeg + full_len; 929 const char *const name_em1 = name_end - 1; 930 U32 faking_it; 931 932 PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS; 933 934 if (flags & GV_NOTQUAL) { 935 /* Caller promised that there is no stash, so we can skip the check. */ 936 len = full_len; 937 goto no_stash; 938 } 939 940 if (full_len > 2 && *name == '*' && isALPHA(name[1])) { 941 /* accidental stringify on a GV? */ 942 name++; 943 } 944 945 for (name_cursor = name; name_cursor < name_end; name_cursor++) { 946 if ((*name_cursor == ':' && name_cursor < name_em1 947 && name_cursor[1] == ':') 948 || (*name_cursor == '\'' && name_cursor[1])) 949 { 950 if (!stash) 951 stash = PL_defstash; 952 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */ 953 return NULL; 954 955 len = name_cursor - name; 956 if (len > 0) { 957 char smallbuf[128]; 958 char *tmpbuf; 959 960 if (len + 2 <= (I32)sizeof (smallbuf)) 961 tmpbuf = smallbuf; 962 else 963 Newx(tmpbuf, len+2, char); 964 Copy(name, tmpbuf, len, char); 965 tmpbuf[len++] = ':'; 966 tmpbuf[len++] = ':'; 967 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add); 968 gv = gvp ? *gvp : NULL; 969 if (gv && gv != (const GV *)&PL_sv_undef) { 970 if (SvTYPE(gv) != SVt_PVGV) 971 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI)); 972 else 973 GvMULTI_on(gv); 974 } 975 if (tmpbuf != smallbuf) 976 Safefree(tmpbuf); 977 if (!gv || gv == (const GV *)&PL_sv_undef) 978 return NULL; 979 980 if (!(stash = GvHV(gv))) 981 stash = GvHV(gv) = newHV(); 982 983 if (!HvNAME_get(stash)) 984 hv_name_set(stash, nambeg, name_cursor - nambeg, 0); 985 } 986 987 if (*name_cursor == ':') 988 name_cursor++; 989 name_cursor++; 990 name = name_cursor; 991 if (name == name_end) 992 return gv 993 ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE)); 994 } 995 } 996 len = name_cursor - name; 997 998 /* No stash in name, so see how we can default */ 999 1000 if (!stash) { 1001 no_stash: 1002 if (len && isIDFIRST_lazy(name)) { 1003 bool global = FALSE; 1004 1005 switch (len) { 1006 case 1: 1007 if (*name == '_') 1008 global = TRUE; 1009 break; 1010 case 3: 1011 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C') 1012 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V') 1013 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G')) 1014 global = TRUE; 1015 break; 1016 case 4: 1017 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G' 1018 && name[3] == 'V') 1019 global = TRUE; 1020 break; 1021 case 5: 1022 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D' 1023 && name[3] == 'I' && name[4] == 'N') 1024 global = TRUE; 1025 break; 1026 case 6: 1027 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D') 1028 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T') 1029 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R'))) 1030 global = TRUE; 1031 break; 1032 case 7: 1033 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G' 1034 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U' 1035 && name[6] == 'T') 1036 global = TRUE; 1037 break; 1038 } 1039 1040 if (global) 1041 stash = PL_defstash; 1042 else if (IN_PERL_COMPILETIME) { 1043 stash = PL_curstash; 1044 if (add && (PL_hints & HINT_STRICT_VARS) && 1045 sv_type != SVt_PVCV && 1046 sv_type != SVt_PVGV && 1047 sv_type != SVt_PVFM && 1048 sv_type != SVt_PVIO && 1049 !(len == 1 && sv_type == SVt_PV && 1050 (*name == 'a' || *name == 'b')) ) 1051 { 1052 gvp = (GV**)hv_fetch(stash,name,len,0); 1053 if (!gvp || 1054 *gvp == (const GV *)&PL_sv_undef || 1055 SvTYPE(*gvp) != SVt_PVGV) 1056 { 1057 stash = NULL; 1058 } 1059 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) || 1060 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) || 1061 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) ) 1062 { 1063 /* diag_listed_as: Variable "%s" is not imported%s */ 1064 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported", 1065 sv_type == SVt_PVAV ? '@' : 1066 sv_type == SVt_PVHV ? '%' : '$', 1067 name); 1068 if (GvCVu(*gvp)) 1069 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name); 1070 stash = NULL; 1071 } 1072 } 1073 } 1074 else 1075 stash = CopSTASH(PL_curcop); 1076 } 1077 else 1078 stash = PL_defstash; 1079 } 1080 1081 /* By this point we should have a stash and a name */ 1082 1083 if (!stash) { 1084 if (add) { 1085 SV * const err = Perl_mess(aTHX_ 1086 "Global symbol \"%s%s\" requires explicit package name", 1087 (sv_type == SVt_PV ? "$" 1088 : sv_type == SVt_PVAV ? "@" 1089 : sv_type == SVt_PVHV ? "%" 1090 : ""), name); 1091 GV *gv; 1092 if (USE_UTF8_IN_NAMES) 1093 SvUTF8_on(err); 1094 qerror(err); 1095 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV); 1096 if(!gv) { 1097 /* symbol table under destruction */ 1098 return NULL; 1099 } 1100 stash = GvHV(gv); 1101 } 1102 else 1103 return NULL; 1104 } 1105 1106 if (!SvREFCNT(stash)) /* symbol table under destruction */ 1107 return NULL; 1108 1109 gvp = (GV**)hv_fetch(stash,name,len,add); 1110 if (!gvp || *gvp == (const GV *)&PL_sv_undef) 1111 return NULL; 1112 gv = *gvp; 1113 if (SvTYPE(gv) == SVt_PVGV) { 1114 if (add) { 1115 GvMULTI_on(gv); 1116 gv_init_sv(gv, sv_type); 1117 if (len == 1 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) { 1118 if (*name == '!') 1119 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); 1120 else if (*name == '-' || *name == '+') 1121 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0); 1122 } 1123 } 1124 return gv; 1125 } else if (no_init) { 1126 return gv; 1127 } else if (no_expand && SvROK(gv)) { 1128 return gv; 1129 } 1130 1131 /* Adding a new symbol. 1132 Unless of course there was already something non-GV here, in which case 1133 we want to behave as if there was always a GV here, containing some sort 1134 of subroutine. 1135 Otherwise we run the risk of creating things like GvIO, which can cause 1136 subtle bugs. eg the one that tripped up SQL::Translator */ 1137 1138 faking_it = SvOK(gv); 1139 1140 if (add & GV_ADDWARN) 1141 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg); 1142 gv_init(gv, stash, name, len, add & GV_ADDMULTI); 1143 gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type); 1144 1145 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) 1146 : (PL_dowarn & G_WARN_ON ) ) ) 1147 GvMULTI_on(gv) ; 1148 1149 /* set up magic where warranted */ 1150 if (len > 1) { 1151 #ifndef EBCDIC 1152 if (*name > 'V' ) { 1153 NOOP; 1154 /* Nothing else to do. 1155 The compiler will probably turn the switch statement into a 1156 branch table. Make sure we avoid even that small overhead for 1157 the common case of lower case variable names. */ 1158 } else 1159 #endif 1160 { 1161 const char * const name2 = name + 1; 1162 switch (*name) { 1163 case 'A': 1164 if (strEQ(name2, "RGV")) { 1165 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; 1166 } 1167 else if (strEQ(name2, "RGVOUT")) { 1168 GvMULTI_on(gv); 1169 } 1170 break; 1171 case 'E': 1172 if (strnEQ(name2, "XPORT", 5)) 1173 GvMULTI_on(gv); 1174 break; 1175 case 'I': 1176 if (strEQ(name2, "SA")) { 1177 AV* const av = GvAVn(gv); 1178 GvMULTI_on(gv); 1179 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa, 1180 NULL, 0); 1181 /* NOTE: No support for tied ISA */ 1182 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA") 1183 && AvFILLp(av) == -1) 1184 { 1185 av_push(av, newSVpvs("NDBM_File")); 1186 gv_stashpvs("NDBM_File", GV_ADD); 1187 av_push(av, newSVpvs("DB_File")); 1188 gv_stashpvs("DB_File", GV_ADD); 1189 av_push(av, newSVpvs("GDBM_File")); 1190 gv_stashpvs("GDBM_File", GV_ADD); 1191 av_push(av, newSVpvs("SDBM_File")); 1192 gv_stashpvs("SDBM_File", GV_ADD); 1193 av_push(av, newSVpvs("ODBM_File")); 1194 gv_stashpvs("ODBM_File", GV_ADD); 1195 } 1196 } 1197 break; 1198 case 'O': 1199 if (strEQ(name2, "VERLOAD")) { 1200 HV* const hv = GvHVn(gv); 1201 GvMULTI_on(gv); 1202 hv_magic(hv, NULL, PERL_MAGIC_overload); 1203 } 1204 break; 1205 case 'S': 1206 if (strEQ(name2, "IG")) { 1207 HV *hv; 1208 I32 i; 1209 if (!PL_psig_name) { 1210 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*); 1211 Newxz(PL_psig_pend, SIG_SIZE, int); 1212 PL_psig_ptr = PL_psig_name + SIG_SIZE; 1213 } else { 1214 /* I think that the only way to get here is to re-use an 1215 embedded perl interpreter, where the previous 1216 use didn't clean up fully because 1217 PL_perl_destruct_level was 0. I'm not sure that we 1218 "support" that, in that I suspect in that scenario 1219 there are sufficient other garbage values left in the 1220 interpreter structure that something else will crash 1221 before we get here. I suspect that this is one of 1222 those "doctor, it hurts when I do this" bugs. */ 1223 Zero(PL_psig_name, 2 * SIG_SIZE, SV*); 1224 Zero(PL_psig_pend, SIG_SIZE, int); 1225 } 1226 GvMULTI_on(gv); 1227 hv = GvHVn(gv); 1228 hv_magic(hv, NULL, PERL_MAGIC_sig); 1229 for (i = 1; i < SIG_SIZE; i++) { 1230 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1); 1231 if (init) 1232 sv_setsv(*init, &PL_sv_undef); 1233 } 1234 } 1235 break; 1236 case 'V': 1237 if (strEQ(name2, "ERSION")) 1238 GvMULTI_on(gv); 1239 break; 1240 case '\003': /* $^CHILD_ERROR_NATIVE */ 1241 if (strEQ(name2, "HILD_ERROR_NATIVE")) 1242 goto magicalize; 1243 break; 1244 case '\005': /* $^ENCODING */ 1245 if (strEQ(name2, "NCODING")) 1246 goto magicalize; 1247 break; 1248 case '\015': /* $^MATCH */ 1249 if (strEQ(name2, "ATCH")) 1250 goto magicalize; 1251 case '\017': /* $^OPEN */ 1252 if (strEQ(name2, "PEN")) 1253 goto magicalize; 1254 break; 1255 case '\020': /* $^PREMATCH $^POSTMATCH */ 1256 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH")) 1257 goto magicalize; 1258 case '\024': /* ${^TAINT} */ 1259 if (strEQ(name2, "AINT")) 1260 goto ro_magicalize; 1261 break; 1262 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */ 1263 if (strEQ(name2, "NICODE")) 1264 goto ro_magicalize; 1265 if (strEQ(name2, "TF8LOCALE")) 1266 goto ro_magicalize; 1267 if (strEQ(name2, "TF8CACHE")) 1268 goto magicalize; 1269 break; 1270 case '\027': /* $^WARNING_BITS */ 1271 if (strEQ(name2, "ARNING_BITS")) 1272 goto magicalize; 1273 break; 1274 case '1': 1275 case '2': 1276 case '3': 1277 case '4': 1278 case '5': 1279 case '6': 1280 case '7': 1281 case '8': 1282 case '9': 1283 { 1284 /* Ensures that we have an all-digit variable, ${"1foo"} fails 1285 this test */ 1286 /* This snippet is taken from is_gv_magical */ 1287 const char *end = name + len; 1288 while (--end > name) { 1289 if (!isDIGIT(*end)) return gv; 1290 } 1291 goto magicalize; 1292 } 1293 } 1294 } 1295 } else { 1296 /* Names of length 1. (Or 0. But name is NUL terminated, so that will 1297 be case '\0' in this switch statement (ie a default case) */ 1298 switch (*name) { 1299 case '&': /* $& */ 1300 case '`': /* $` */ 1301 case '\'': /* $' */ 1302 if ( 1303 sv_type == SVt_PVAV || 1304 sv_type == SVt_PVHV || 1305 sv_type == SVt_PVCV || 1306 sv_type == SVt_PVFM || 1307 sv_type == SVt_PVIO 1308 ) { break; } 1309 PL_sawampersand = TRUE; 1310 goto magicalize; 1311 1312 case ':': /* $: */ 1313 sv_setpv(GvSVn(gv),PL_chopset); 1314 goto magicalize; 1315 1316 case '?': /* $? */ 1317 #ifdef COMPLEX_STATUS 1318 SvUPGRADE(GvSVn(gv), SVt_PVLV); 1319 #endif 1320 goto magicalize; 1321 1322 case '!': /* $! */ 1323 GvMULTI_on(gv); 1324 /* If %! has been used, automatically load Errno.pm. */ 1325 1326 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); 1327 1328 /* magicalization must be done before require_tie_mod is called */ 1329 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) 1330 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); 1331 1332 break; 1333 case '-': /* $- */ 1334 case '+': /* $+ */ 1335 GvMULTI_on(gv); /* no used once warnings here */ 1336 { 1337 AV* const av = GvAVn(gv); 1338 SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL; 1339 1340 sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0); 1341 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); 1342 if (avc) 1343 SvREADONLY_on(GvSVn(gv)); 1344 SvREADONLY_on(av); 1345 1346 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) 1347 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0); 1348 1349 break; 1350 } 1351 case '*': /* $* */ 1352 case '#': /* $# */ 1353 if (sv_type == SVt_PV) 1354 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), 1355 "$%c is no longer supported", *name); 1356 break; 1357 case '|': /* $| */ 1358 sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0); 1359 goto magicalize; 1360 1361 case '\010': /* $^H */ 1362 { 1363 HV *const hv = GvHVn(gv); 1364 hv_magic(hv, NULL, PERL_MAGIC_hints); 1365 } 1366 goto magicalize; 1367 case '\023': /* $^S */ 1368 ro_magicalize: 1369 SvREADONLY_on(GvSVn(gv)); 1370 /* FALL THROUGH */ 1371 case '0': /* $0 */ 1372 case '1': /* $1 */ 1373 case '2': /* $2 */ 1374 case '3': /* $3 */ 1375 case '4': /* $4 */ 1376 case '5': /* $5 */ 1377 case '6': /* $6 */ 1378 case '7': /* $7 */ 1379 case '8': /* $8 */ 1380 case '9': /* $9 */ 1381 case '[': /* $[ */ 1382 case '^': /* $^ */ 1383 case '~': /* $~ */ 1384 case '=': /* $= */ 1385 case '%': /* $% */ 1386 case '.': /* $. */ 1387 case '(': /* $( */ 1388 case ')': /* $) */ 1389 case '<': /* $< */ 1390 case '>': /* $> */ 1391 case '\\': /* $\ */ 1392 case '/': /* $/ */ 1393 case '\001': /* $^A */ 1394 case '\003': /* $^C */ 1395 case '\004': /* $^D */ 1396 case '\005': /* $^E */ 1397 case '\006': /* $^F */ 1398 case '\011': /* $^I, NOT \t in EBCDIC */ 1399 case '\016': /* $^N */ 1400 case '\017': /* $^O */ 1401 case '\020': /* $^P */ 1402 case '\024': /* $^T */ 1403 case '\027': /* $^W */ 1404 magicalize: 1405 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); 1406 break; 1407 1408 case '\014': /* $^L */ 1409 sv_setpvs(GvSVn(gv),"\f"); 1410 PL_formfeed = GvSVn(gv); 1411 break; 1412 case ';': /* $; */ 1413 sv_setpvs(GvSVn(gv),"\034"); 1414 break; 1415 case ']': /* $] */ 1416 { 1417 SV * const sv = GvSVn(gv); 1418 if (!sv_derived_from(PL_patchlevel, "version")) 1419 upg_version(PL_patchlevel, TRUE); 1420 GvSV(gv) = vnumify(PL_patchlevel); 1421 SvREADONLY_on(GvSV(gv)); 1422 SvREFCNT_dec(sv); 1423 } 1424 break; 1425 case '\026': /* $^V */ 1426 { 1427 SV * const sv = GvSVn(gv); 1428 GvSV(gv) = new_version(PL_patchlevel); 1429 SvREADONLY_on(GvSV(gv)); 1430 SvREFCNT_dec(sv); 1431 } 1432 break; 1433 } 1434 } 1435 return gv; 1436 } 1437 1438 void 1439 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) 1440 { 1441 const char *name; 1442 STRLEN namelen; 1443 const HV * const hv = GvSTASH(gv); 1444 1445 PERL_ARGS_ASSERT_GV_FULLNAME4; 1446 1447 if (!hv) { 1448 SvOK_off(sv); 1449 return; 1450 } 1451 sv_setpv(sv, prefix ? prefix : ""); 1452 1453 name = HvNAME_get(hv); 1454 if (name) { 1455 namelen = HvNAMELEN_get(hv); 1456 } else { 1457 name = "__ANON__"; 1458 namelen = 8; 1459 } 1460 1461 if (keepmain || strNE(name, "main")) { 1462 sv_catpvn(sv,name,namelen); 1463 sv_catpvs(sv,"::"); 1464 } 1465 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv)); 1466 } 1467 1468 void 1469 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) 1470 { 1471 const GV * const egv = GvEGV(gv); 1472 1473 PERL_ARGS_ASSERT_GV_EFULLNAME4; 1474 1475 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain); 1476 } 1477 1478 void 1479 Perl_gv_check(pTHX_ const HV *stash) 1480 { 1481 dVAR; 1482 register I32 i; 1483 1484 PERL_ARGS_ASSERT_GV_CHECK; 1485 1486 if (!HvARRAY(stash)) 1487 return; 1488 for (i = 0; i <= (I32) HvMAX(stash); i++) { 1489 const HE *entry; 1490 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { 1491 register GV *gv; 1492 HV *hv; 1493 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && 1494 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv))) 1495 { 1496 if (hv != PL_defstash && hv != stash) 1497 gv_check(hv); /* nested package */ 1498 } 1499 else if (isALPHA(*HeKEY(entry))) { 1500 const char *file; 1501 gv = MUTABLE_GV(HeVAL(entry)); 1502 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) 1503 continue; 1504 file = GvFILE(gv); 1505 CopLINE_set(PL_curcop, GvLINE(gv)); 1506 #ifdef USE_ITHREADS 1507 CopFILE(PL_curcop) = (char *)file; /* set for warning */ 1508 #else 1509 CopFILEGV(PL_curcop) 1510 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0); 1511 #endif 1512 Perl_warner(aTHX_ packWARN(WARN_ONCE), 1513 "Name \"%s::%s\" used only once: possible typo", 1514 HvNAME_get(stash), GvNAME(gv)); 1515 } 1516 } 1517 } 1518 } 1519 1520 GV * 1521 Perl_newGVgen(pTHX_ const char *pack) 1522 { 1523 dVAR; 1524 1525 PERL_ARGS_ASSERT_NEWGVGEN; 1526 1527 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++), 1528 GV_ADD, SVt_PVGV); 1529 } 1530 1531 /* hopefully this is only called on local symbol table entries */ 1532 1533 GP* 1534 Perl_gp_ref(pTHX_ GP *gp) 1535 { 1536 dVAR; 1537 if (!gp) 1538 return NULL; 1539 gp->gp_refcnt++; 1540 if (gp->gp_cv) { 1541 if (gp->gp_cvgen) { 1542 /* If the GP they asked for a reference to contains 1543 a method cache entry, clear it first, so that we 1544 don't infect them with our cached entry */ 1545 SvREFCNT_dec(gp->gp_cv); 1546 gp->gp_cv = NULL; 1547 gp->gp_cvgen = 0; 1548 } 1549 } 1550 return gp; 1551 } 1552 1553 void 1554 Perl_gp_free(pTHX_ GV *gv) 1555 { 1556 dVAR; 1557 GP* gp; 1558 1559 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv))) 1560 return; 1561 if (gp->gp_refcnt == 0) { 1562 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), 1563 "Attempt to free unreferenced glob pointers" 1564 pTHX__FORMAT pTHX__VALUE); 1565 return; 1566 } 1567 if (--gp->gp_refcnt > 0) { 1568 if (gp->gp_egv == gv) 1569 gp->gp_egv = 0; 1570 GvGP(gv) = 0; 1571 return; 1572 } 1573 1574 if (gp->gp_file_hek) 1575 unshare_hek(gp->gp_file_hek); 1576 SvREFCNT_dec(gp->gp_sv); 1577 SvREFCNT_dec(gp->gp_av); 1578 /* FIXME - another reference loop GV -> symtab -> GV ? 1579 Somehow gp->gp_hv can end up pointing at freed garbage. */ 1580 if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) { 1581 const char *hvname = HvNAME_get(gp->gp_hv); 1582 if (PL_stashcache && hvname) 1583 (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv), 1584 G_DISCARD); 1585 SvREFCNT_dec(gp->gp_hv); 1586 } 1587 SvREFCNT_dec(gp->gp_io); 1588 SvREFCNT_dec(gp->gp_cv); 1589 SvREFCNT_dec(gp->gp_form); 1590 1591 Safefree(gp); 1592 GvGP(gv) = 0; 1593 } 1594 1595 int 1596 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) 1597 { 1598 AMT * const amtp = (AMT*)mg->mg_ptr; 1599 PERL_UNUSED_ARG(sv); 1600 1601 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD; 1602 1603 if (amtp && AMT_AMAGIC(amtp)) { 1604 int i; 1605 for (i = 1; i < NofAMmeth; i++) { 1606 CV * const cv = amtp->table[i]; 1607 if (cv) { 1608 SvREFCNT_dec(MUTABLE_SV(cv)); 1609 amtp->table[i] = NULL; 1610 } 1611 } 1612 } 1613 return 0; 1614 } 1615 1616 /* Updates and caches the CV's */ 1617 /* Returns: 1618 * 1 on success and there is some overload 1619 * 0 if there is no overload 1620 * -1 if some error occurred and it couldn't croak 1621 */ 1622 1623 int 1624 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) 1625 { 1626 dVAR; 1627 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); 1628 AMT amt; 1629 const struct mro_meta* stash_meta = HvMROMETA(stash); 1630 U32 newgen; 1631 1632 PERL_ARGS_ASSERT_GV_AMUPDATE; 1633 1634 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen; 1635 if (mg) { 1636 const AMT * const amtp = (AMT*)mg->mg_ptr; 1637 if (amtp->was_ok_am == PL_amagic_generation 1638 && amtp->was_ok_sub == newgen) { 1639 return AMT_OVERLOADED(amtp) ? 1 : 0; 1640 } 1641 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table); 1642 } 1643 1644 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) ); 1645 1646 Zero(&amt,1,AMT); 1647 amt.was_ok_am = PL_amagic_generation; 1648 amt.was_ok_sub = newgen; 1649 amt.fallback = AMGfallNO; 1650 amt.flags = 0; 1651 1652 { 1653 int filled = 0, have_ovl = 0; 1654 int i, lim = 1; 1655 1656 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ 1657 1658 /* Try to find via inheritance. */ 1659 GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1); 1660 SV * const sv = gv ? GvSV(gv) : NULL; 1661 CV* cv; 1662 1663 if (!gv) 1664 lim = DESTROY_amg; /* Skip overloading entries. */ 1665 #ifdef PERL_DONT_CREATE_GVSV 1666 else if (!sv) { 1667 NOOP; /* Equivalent to !SvTRUE and !SvOK */ 1668 } 1669 #endif 1670 else if (SvTRUE(sv)) 1671 amt.fallback=AMGfallYES; 1672 else if (SvOK(sv)) 1673 amt.fallback=AMGfallNEVER; 1674 1675 for (i = 1; i < lim; i++) 1676 amt.table[i] = NULL; 1677 for (; i < NofAMmeth; i++) { 1678 const char * const cooky = PL_AMG_names[i]; 1679 /* Human-readable form, for debugging: */ 1680 const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i)); 1681 const STRLEN l = PL_AMG_namelens[i]; 1682 1683 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n", 1684 cp, HvNAME_get(stash)) ); 1685 /* don't fill the cache while looking up! 1686 Creation of inheritance stubs in intermediate packages may 1687 conflict with the logic of runtime method substitution. 1688 Indeed, for inheritance A -> B -> C, if C overloads "+0", 1689 then we could have created stubs for "(+0" in A and C too. 1690 But if B overloads "bool", we may want to use it for 1691 numifying instead of C's "+0". */ 1692 if (i >= DESTROY_amg) 1693 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0); 1694 else /* Autoload taken care of below */ 1695 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1); 1696 cv = 0; 1697 if (gv && (cv = GvCV(gv))) { 1698 const char *hvname; 1699 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil") 1700 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) { 1701 /* This is a hack to support autoloading..., while 1702 knowing *which* methods were declared as overloaded. */ 1703 /* GvSV contains the name of the method. */ 1704 GV *ngv = NULL; 1705 SV *gvsv = GvSV(gv); 1706 1707 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\ 1708 "\" for overloaded \"%s\" in package \"%.256s\"\n", 1709 (void*)GvSV(gv), cp, hvname) ); 1710 if (!gvsv || !SvPOK(gvsv) 1711 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv), 1712 FALSE))) 1713 { 1714 /* Can be an import stub (created by "can"). */ 1715 if (destructing) { 1716 return -1; 1717 } 1718 else { 1719 const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???"; 1720 Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\ 1721 "in package \"%.256s\"", 1722 (GvCVGEN(gv) ? "Stub found while resolving" 1723 : "Can't resolve"), 1724 name, cp, hvname); 1725 } 1726 } 1727 cv = GvCV(gv = ngv); 1728 } 1729 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n", 1730 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))), 1731 GvNAME(CvGV(cv))) ); 1732 filled = 1; 1733 if (i < DESTROY_amg) 1734 have_ovl = 1; 1735 } else if (gv) { /* Autoloaded... */ 1736 cv = MUTABLE_CV(gv); 1737 filled = 1; 1738 } 1739 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv)); 1740 } 1741 if (filled) { 1742 AMT_AMAGIC_on(&amt); 1743 if (have_ovl) 1744 AMT_OVERLOADED_on(&amt); 1745 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, 1746 (char*)&amt, sizeof(AMT)); 1747 return have_ovl; 1748 } 1749 } 1750 /* Here we have no table: */ 1751 /* no_table: */ 1752 AMT_AMAGIC_off(&amt); 1753 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, 1754 (char*)&amt, sizeof(AMTS)); 1755 return 0; 1756 } 1757 1758 1759 CV* 1760 Perl_gv_handler(pTHX_ HV *stash, I32 id) 1761 { 1762 dVAR; 1763 MAGIC *mg; 1764 AMT *amtp; 1765 U32 newgen; 1766 struct mro_meta* stash_meta; 1767 1768 if (!stash || !HvNAME_get(stash)) 1769 return NULL; 1770 1771 stash_meta = HvMROMETA(stash); 1772 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen; 1773 1774 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); 1775 if (!mg) { 1776 do_update: 1777 /* If we're looking up a destructor to invoke, we must avoid 1778 * that Gv_AMupdate croaks, because we might be dying already */ 1779 if (Gv_AMupdate(stash, id == DESTROY_amg) == -1) { 1780 /* and if it didn't found a destructor, we fall back 1781 * to a simpler method that will only look for the 1782 * destructor instead of the whole magic */ 1783 if (id == DESTROY_amg) { 1784 GV * const gv = gv_fetchmethod(stash, "DESTROY"); 1785 if (gv) 1786 return GvCV(gv); 1787 } 1788 return NULL; 1789 } 1790 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); 1791 } 1792 assert(mg); 1793 amtp = (AMT*)mg->mg_ptr; 1794 if ( amtp->was_ok_am != PL_amagic_generation 1795 || amtp->was_ok_sub != newgen ) 1796 goto do_update; 1797 if (AMT_AMAGIC(amtp)) { 1798 CV * const ret = amtp->table[id]; 1799 if (ret && isGV(ret)) { /* Autoloading stab */ 1800 /* Passing it through may have resulted in a warning 1801 "Inherited AUTOLOAD for a non-method deprecated", since 1802 our caller is going through a function call, not a method call. 1803 So return the CV for AUTOLOAD, setting $AUTOLOAD. */ 1804 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]); 1805 1806 if (gv && GvCV(gv)) 1807 return GvCV(gv); 1808 } 1809 return ret; 1810 } 1811 1812 return NULL; 1813 } 1814 1815 1816 SV* 1817 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) 1818 { 1819 dVAR; 1820 MAGIC *mg; 1821 CV *cv=NULL; 1822 CV **cvp=NULL, **ocvp=NULL; 1823 AMT *amtp=NULL, *oamtp=NULL; 1824 int off = 0, off1, lr = 0, notfound = 0; 1825 int postpr = 0, force_cpy = 0; 1826 int assign = AMGf_assign & flags; 1827 const int assignshift = assign ? 1 : 0; 1828 #ifdef DEBUGGING 1829 int fl=0; 1830 #endif 1831 HV* stash=NULL; 1832 1833 PERL_ARGS_ASSERT_AMAGIC_CALL; 1834 1835 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) { 1836 SV *lex_mask = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 1837 0, "overloading", 11, 0, 0); 1838 1839 if ( !lex_mask || !SvOK(lex_mask) ) 1840 /* overloading lexically disabled */ 1841 return NULL; 1842 else if ( lex_mask && SvPOK(lex_mask) ) { 1843 /* we have an entry in the hints hash, check if method has been 1844 * masked by overloading.pm */ 1845 STRLEN len; 1846 const int offset = method / 8; 1847 const int bit = method % 8; 1848 char *pv = SvPV(lex_mask, len); 1849 1850 /* Bit set, so this overloading operator is disabled */ 1851 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) ) 1852 return NULL; 1853 } 1854 } 1855 1856 if (!(AMGf_noleft & flags) && SvAMAGIC(left) 1857 && (stash = SvSTASH(SvRV(left))) 1858 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) 1859 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) 1860 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table 1861 : NULL)) 1862 && ((cv = cvp[off=method+assignshift]) 1863 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to 1864 * usual method */ 1865 ( 1866 #ifdef DEBUGGING 1867 fl = 1, 1868 #endif 1869 cv = cvp[off=method])))) { 1870 lr = -1; /* Call method for left argument */ 1871 } else { 1872 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) { 1873 int logic; 1874 1875 /* look for substituted methods */ 1876 /* In all the covered cases we should be called with assign==0. */ 1877 switch (method) { 1878 case inc_amg: 1879 force_cpy = 1; 1880 if ((cv = cvp[off=add_ass_amg]) 1881 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) { 1882 right = &PL_sv_yes; lr = -1; assign = 1; 1883 } 1884 break; 1885 case dec_amg: 1886 force_cpy = 1; 1887 if ((cv = cvp[off = subtr_ass_amg]) 1888 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) { 1889 right = &PL_sv_yes; lr = -1; assign = 1; 1890 } 1891 break; 1892 case bool__amg: 1893 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); 1894 break; 1895 case numer_amg: 1896 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg])); 1897 break; 1898 case string_amg: 1899 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); 1900 break; 1901 case not_amg: 1902 (void)((cv = cvp[off=bool__amg]) 1903 || (cv = cvp[off=numer_amg]) 1904 || (cv = cvp[off=string_amg])); 1905 if (cv) 1906 postpr = 1; 1907 break; 1908 case copy_amg: 1909 { 1910 /* 1911 * SV* ref causes confusion with the interpreter variable of 1912 * the same name 1913 */ 1914 SV* const tmpRef=SvRV(left); 1915 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) { 1916 /* 1917 * Just to be extra cautious. Maybe in some 1918 * additional cases sv_setsv is safe, too. 1919 */ 1920 SV* const newref = newSVsv(tmpRef); 1921 SvOBJECT_on(newref); 1922 /* As a bit of a source compatibility hack, SvAMAGIC() and 1923 friends dereference an RV, to behave the same was as when 1924 overloading was stored on the reference, not the referant. 1925 Hence we can't use SvAMAGIC_on() 1926 */ 1927 SvFLAGS(newref) |= SVf_AMAGIC; 1928 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef)))); 1929 return newref; 1930 } 1931 } 1932 break; 1933 case abs_amg: 1934 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) 1935 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { 1936 SV* const nullsv=sv_2mortal(newSViv(0)); 1937 if (off1==lt_amg) { 1938 SV* const lessp = amagic_call(left,nullsv, 1939 lt_amg,AMGf_noright); 1940 logic = SvTRUE(lessp); 1941 } else { 1942 SV* const lessp = amagic_call(left,nullsv, 1943 ncmp_amg,AMGf_noright); 1944 logic = (SvNV(lessp) < 0); 1945 } 1946 if (logic) { 1947 if (off==subtr_amg) { 1948 right = left; 1949 left = nullsv; 1950 lr = 1; 1951 } 1952 } else { 1953 return left; 1954 } 1955 } 1956 break; 1957 case neg_amg: 1958 if ((cv = cvp[off=subtr_amg])) { 1959 right = left; 1960 left = sv_2mortal(newSViv(0)); 1961 lr = 1; 1962 } 1963 break; 1964 case int_amg: 1965 case iter_amg: /* XXXX Eventually should do to_gv. */ 1966 case ftest_amg: /* XXXX Eventually should do to_gv. */ 1967 case regexp_amg: 1968 /* FAIL safe */ 1969 return NULL; /* Delegate operation to standard mechanisms. */ 1970 break; 1971 case to_sv_amg: 1972 case to_av_amg: 1973 case to_hv_amg: 1974 case to_gv_amg: 1975 case to_cv_amg: 1976 /* FAIL safe */ 1977 return left; /* Delegate operation to standard mechanisms. */ 1978 break; 1979 default: 1980 goto not_found; 1981 } 1982 if (!cv) goto not_found; 1983 } else if (!(AMGf_noright & flags) && SvAMAGIC(right) 1984 && (stash = SvSTASH(SvRV(right))) 1985 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) 1986 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) 1987 ? (amtp = (AMT*)mg->mg_ptr)->table 1988 : NULL)) 1989 && (cv = cvp[off=method])) { /* Method for right 1990 * argument found */ 1991 lr=1; 1992 } else if (((ocvp && oamtp->fallback > AMGfallNEVER 1993 && (cvp=ocvp) && (lr = -1)) 1994 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1))) 1995 && !(flags & AMGf_unary)) { 1996 /* We look for substitution for 1997 * comparison operations and 1998 * concatenation */ 1999 if (method==concat_amg || method==concat_ass_amg 2000 || method==repeat_amg || method==repeat_ass_amg) { 2001 return NULL; /* Delegate operation to string conversion */ 2002 } 2003 off = -1; 2004 switch (method) { 2005 case lt_amg: 2006 case le_amg: 2007 case gt_amg: 2008 case ge_amg: 2009 case eq_amg: 2010 case ne_amg: 2011 off = ncmp_amg; 2012 break; 2013 case slt_amg: 2014 case sle_amg: 2015 case sgt_amg: 2016 case sge_amg: 2017 case seq_amg: 2018 case sne_amg: 2019 off = scmp_amg; 2020 break; 2021 } 2022 if ((off != -1) && (cv = cvp[off])) 2023 postpr = 1; 2024 else 2025 goto not_found; 2026 } else { 2027 not_found: /* No method found, either report or croak */ 2028 switch (method) { 2029 case to_sv_amg: 2030 case to_av_amg: 2031 case to_hv_amg: 2032 case to_gv_amg: 2033 case to_cv_amg: 2034 /* FAIL safe */ 2035 return left; /* Delegate operation to standard mechanisms. */ 2036 break; 2037 } 2038 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */ 2039 notfound = 1; lr = -1; 2040 } else if (cvp && (cv=cvp[nomethod_amg])) { 2041 notfound = 1; lr = 1; 2042 } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) { 2043 /* Skip generating the "no method found" message. */ 2044 return NULL; 2045 } else { 2046 SV *msg; 2047 if (off==-1) off=method; 2048 msg = sv_2mortal(Perl_newSVpvf(aTHX_ 2049 "Operation \"%s\": no method found,%sargument %s%s%s%s", 2050 AMG_id2name(method + assignshift), 2051 (flags & AMGf_unary ? " " : "\n\tleft "), 2052 SvAMAGIC(left)? 2053 "in overloaded package ": 2054 "has no overloaded magic", 2055 SvAMAGIC(left)? 2056 HvNAME_get(SvSTASH(SvRV(left))): 2057 "", 2058 SvAMAGIC(right)? 2059 ",\n\tright argument in overloaded package ": 2060 (flags & AMGf_unary 2061 ? "" 2062 : ",\n\tright argument has no overloaded magic"), 2063 SvAMAGIC(right)? 2064 HvNAME_get(SvSTASH(SvRV(right))): 2065 "")); 2066 if (amtp && amtp->fallback >= AMGfallYES) { 2067 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) ); 2068 } else { 2069 Perl_croak(aTHX_ "%"SVf, SVfARG(msg)); 2070 } 2071 return NULL; 2072 } 2073 force_cpy = force_cpy || assign; 2074 } 2075 } 2076 #ifdef DEBUGGING 2077 if (!notfound) { 2078 DEBUG_o(Perl_deb(aTHX_ 2079 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n", 2080 AMG_id2name(off), 2081 method+assignshift==off? "" : 2082 " (initially \"", 2083 method+assignshift==off? "" : 2084 AMG_id2name(method+assignshift), 2085 method+assignshift==off? "" : "\")", 2086 flags & AMGf_unary? "" : 2087 lr==1 ? " for right argument": " for left argument", 2088 flags & AMGf_unary? " for argument" : "", 2089 stash ? HvNAME_get(stash) : "null", 2090 fl? ",\n\tassignment variant used": "") ); 2091 } 2092 #endif 2093 /* Since we use shallow copy during assignment, we need 2094 * to dublicate the contents, probably calling user-supplied 2095 * version of copy operator 2096 */ 2097 /* We need to copy in following cases: 2098 * a) Assignment form was called. 2099 * assignshift==1, assign==T, method + 1 == off 2100 * b) Increment or decrement, called directly. 2101 * assignshift==0, assign==0, method + 0 == off 2102 * c) Increment or decrement, translated to assignment add/subtr. 2103 * assignshift==0, assign==T, 2104 * force_cpy == T 2105 * d) Increment or decrement, translated to nomethod. 2106 * assignshift==0, assign==0, 2107 * force_cpy == T 2108 * e) Assignment form translated to nomethod. 2109 * assignshift==1, assign==T, method + 1 != off 2110 * force_cpy == T 2111 */ 2112 /* off is method, method+assignshift, or a result of opcode substitution. 2113 * In the latter case assignshift==0, so only notfound case is important. 2114 */ 2115 if (( (method + assignshift == off) 2116 && (assign || (method == inc_amg) || (method == dec_amg))) 2117 || force_cpy) 2118 RvDEEPCP(left); 2119 { 2120 dSP; 2121 BINOP myop; 2122 SV* res; 2123 const bool oldcatch = CATCH_GET; 2124 2125 CATCH_SET(TRUE); 2126 Zero(&myop, 1, BINOP); 2127 myop.op_last = (OP *) &myop; 2128 myop.op_next = NULL; 2129 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED; 2130 2131 PUSHSTACKi(PERLSI_OVERLOAD); 2132 ENTER; 2133 SAVEOP(); 2134 PL_op = (OP *) &myop; 2135 if (PERLDB_SUB && PL_curstash != PL_debstash) 2136 PL_op->op_private |= OPpENTERSUB_DB; 2137 PUTBACK; 2138 pp_pushmark(); 2139 2140 EXTEND(SP, notfound + 5); 2141 PUSHs(lr>0? right: left); 2142 PUSHs(lr>0? left: right); 2143 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no )); 2144 if (notfound) { 2145 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift), 2146 AMG_id2namelen(method + assignshift), SVs_TEMP)); 2147 } 2148 PUSHs(MUTABLE_SV(cv)); 2149 PUTBACK; 2150 2151 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) 2152 CALLRUNOPS(aTHX); 2153 LEAVE; 2154 SPAGAIN; 2155 2156 res=POPs; 2157 PUTBACK; 2158 POPSTACK; 2159 CATCH_SET(oldcatch); 2160 2161 if (postpr) { 2162 int ans; 2163 switch (method) { 2164 case le_amg: 2165 case sle_amg: 2166 ans=SvIV(res)<=0; break; 2167 case lt_amg: 2168 case slt_amg: 2169 ans=SvIV(res)<0; break; 2170 case ge_amg: 2171 case sge_amg: 2172 ans=SvIV(res)>=0; break; 2173 case gt_amg: 2174 case sgt_amg: 2175 ans=SvIV(res)>0; break; 2176 case eq_amg: 2177 case seq_amg: 2178 ans=SvIV(res)==0; break; 2179 case ne_amg: 2180 case sne_amg: 2181 ans=SvIV(res)!=0; break; 2182 case inc_amg: 2183 case dec_amg: 2184 SvSetSV(left,res); return left; 2185 case not_amg: 2186 ans=!SvTRUE(res); break; 2187 default: 2188 ans=0; break; 2189 } 2190 return boolSV(ans); 2191 } else if (method==copy_amg) { 2192 if (!SvROK(res)) { 2193 Perl_croak(aTHX_ "Copy method did not return a reference"); 2194 } 2195 return SvREFCNT_inc(SvRV(res)); 2196 } else { 2197 return res; 2198 } 2199 } 2200 } 2201 2202 /* 2203 =for apidoc is_gv_magical_sv 2204 2205 Returns C<TRUE> if given the name of a magical GV. 2206 2207 Currently only useful internally when determining if a GV should be 2208 created even in rvalue contexts. 2209 2210 C<flags> is not used at present but available for future extension to 2211 allow selecting particular classes of magical variable. 2212 2213 Currently assumes that C<name> is NUL terminated (as well as len being valid). 2214 This assumption is met by all callers within the perl core, which all pass 2215 pointers returned by SvPV. 2216 2217 =cut 2218 */ 2219 2220 bool 2221 Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags) 2222 { 2223 STRLEN len; 2224 const char *const name = SvPV_const(name_sv, len); 2225 2226 PERL_UNUSED_ARG(flags); 2227 PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV; 2228 2229 if (len > 1) { 2230 const char * const name1 = name + 1; 2231 switch (*name) { 2232 case 'I': 2233 if (len == 3 && name[1] == 'S' && name[2] == 'A') 2234 goto yes; 2235 break; 2236 case 'O': 2237 if (len == 8 && strEQ(name1, "VERLOAD")) 2238 goto yes; 2239 break; 2240 case 'S': 2241 if (len == 3 && name[1] == 'I' && name[2] == 'G') 2242 goto yes; 2243 break; 2244 /* Using ${^...} variables is likely to be sufficiently rare that 2245 it seems sensible to avoid the space hit of also checking the 2246 length. */ 2247 case '\017': /* ${^OPEN} */ 2248 if (strEQ(name1, "PEN")) 2249 goto yes; 2250 break; 2251 case '\024': /* ${^TAINT} */ 2252 if (strEQ(name1, "AINT")) 2253 goto yes; 2254 break; 2255 case '\025': /* ${^UNICODE} */ 2256 if (strEQ(name1, "NICODE")) 2257 goto yes; 2258 if (strEQ(name1, "TF8LOCALE")) 2259 goto yes; 2260 break; 2261 case '\027': /* ${^WARNING_BITS} */ 2262 if (strEQ(name1, "ARNING_BITS")) 2263 goto yes; 2264 break; 2265 case '1': 2266 case '2': 2267 case '3': 2268 case '4': 2269 case '5': 2270 case '6': 2271 case '7': 2272 case '8': 2273 case '9': 2274 { 2275 const char *end = name + len; 2276 while (--end > name) { 2277 if (!isDIGIT(*end)) 2278 return FALSE; 2279 } 2280 goto yes; 2281 } 2282 } 2283 } else { 2284 /* Because we're already assuming that name is NUL terminated 2285 below, we can treat an empty name as "\0" */ 2286 switch (*name) { 2287 case '&': 2288 case '`': 2289 case '\'': 2290 case ':': 2291 case '?': 2292 case '!': 2293 case '-': 2294 case '#': 2295 case '[': 2296 case '^': 2297 case '~': 2298 case '=': 2299 case '%': 2300 case '.': 2301 case '(': 2302 case ')': 2303 case '<': 2304 case '>': 2305 case '\\': 2306 case '/': 2307 case '|': 2308 case '+': 2309 case ';': 2310 case ']': 2311 case '\001': /* $^A */ 2312 case '\003': /* $^C */ 2313 case '\004': /* $^D */ 2314 case '\005': /* $^E */ 2315 case '\006': /* $^F */ 2316 case '\010': /* $^H */ 2317 case '\011': /* $^I, NOT \t in EBCDIC */ 2318 case '\014': /* $^L */ 2319 case '\016': /* $^N */ 2320 case '\017': /* $^O */ 2321 case '\020': /* $^P */ 2322 case '\023': /* $^S */ 2323 case '\024': /* $^T */ 2324 case '\026': /* $^V */ 2325 case '\027': /* $^W */ 2326 case '1': 2327 case '2': 2328 case '3': 2329 case '4': 2330 case '5': 2331 case '6': 2332 case '7': 2333 case '8': 2334 case '9': 2335 yes: 2336 return TRUE; 2337 default: 2338 break; 2339 } 2340 } 2341 return FALSE; 2342 } 2343 2344 void 2345 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) 2346 { 2347 dVAR; 2348 U32 hash; 2349 2350 PERL_ARGS_ASSERT_GV_NAME_SET; 2351 PERL_UNUSED_ARG(flags); 2352 2353 if (len > I32_MAX) 2354 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len); 2355 2356 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) { 2357 unshare_hek(GvNAME_HEK(gv)); 2358 } 2359 2360 PERL_HASH(hash, name, len); 2361 GvNAME_HEK(gv) = share_hek(name, len, hash); 2362 } 2363 2364 /* 2365 =for apidoc gv_try_downgrade 2366 2367 If the typeglob C<gv> can be expressed more succinctly, by having 2368 something other than a real GV in its place in the stash, replace it 2369 with the optimised form. Basic requirements for this are that C<gv> 2370 is a real typeglob, is sufficiently ordinary, and is only referenced 2371 from its package. This function is meant to be used when a GV has been 2372 looked up in part to see what was there, causing upgrading, but based 2373 on what was found it turns out that the real GV isn't required after all. 2374 2375 If C<gv> is a completely empty typeglob, it is deleted from the stash. 2376 2377 If C<gv> is a typeglob containing only a sufficiently-ordinary constant 2378 sub, the typeglob is replaced with a scalar-reference placeholder that 2379 more compactly represents the same thing. 2380 2381 =cut 2382 */ 2383 2384 void 2385 Perl_gv_try_downgrade(pTHX_ GV *gv) 2386 { 2387 HV *stash; 2388 CV *cv; 2389 HEK *namehek; 2390 SV **gvp; 2391 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE; 2392 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) && 2393 !SvOBJECT(gv) && !SvMAGICAL(gv) && !SvREADONLY(gv) && 2394 isGV_with_GP(gv) && GvGP(gv) && 2395 !GvINTRO(gv) && GvREFCNT(gv) == 1 && 2396 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) && 2397 GvEGV(gv) == gv && (stash = GvSTASH(gv)))) 2398 return; 2399 cv = GvCV(gv); 2400 if (!cv) { 2401 HEK *gvnhek = GvNAME_HEK(gv); 2402 (void)hv_delete(stash, HEK_KEY(gvnhek), 2403 HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD); 2404 } else if (GvMULTI(gv) && cv && 2405 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) && 2406 CvSTASH(cv) == stash && CvGV(cv) == gv && 2407 CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) && 2408 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) && 2409 (namehek = GvNAME_HEK(gv)) && 2410 (gvp = hv_fetch(stash, HEK_KEY(namehek), 2411 HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) && 2412 *gvp == (SV*)gv) { 2413 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr); 2414 SvREFCNT(gv) = 0; 2415 sv_clear((SV*)gv); 2416 SvREFCNT(gv) = 1; 2417 SvFLAGS(gv) = SVt_IV|SVf_ROK; 2418 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) - 2419 STRUCT_OFFSET(XPVIV, xiv_iv)); 2420 SvRV_set(gv, value); 2421 } 2422 } 2423 2424 /* 2425 * Local variables: 2426 * c-indentation-style: bsd 2427 * c-basic-offset: 4 2428 * indent-tabs-mode: t 2429 * End: 2430 * 2431 * ex: set ts=8 sts=4 sw=4 noet: 2432 */ 2433