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 Handling and Stashes 24 A GV is a structure which corresponds to to a Perl typeglob, ie *foo. 25 It is a structure that holds a pointer to a scalar, an array, a hash etc, 26 corresponding to $foo, @foo, %foo. 27 28 GVs are usually found as values in stashes (symbol table hashes) where 29 Perl stores its global variables. 30 31 A B<stash> is a hash that contains all variables that are defined 32 within a package. See L<perlguts/Stashes and Globs> 33 34 =for apidoc Ayh||GV 35 36 =cut 37 */ 38 39 #include "EXTERN.h" 40 #define PERL_IN_GV_C 41 #include "perl.h" 42 #include "overload.inc" 43 #include "keywords.h" 44 #include "feature.h" 45 46 static const char S_autoload[] = "AUTOLOAD"; 47 #define S_autolen (sizeof("AUTOLOAD")-1) 48 49 /* 50 =for apidoc gv_add_by_type 51 52 Make sure there is a slot of type C<type> in the GV C<gv>. 53 54 =cut 55 */ 56 57 GV * 58 Perl_gv_add_by_type(pTHX_ GV *gv, svtype type) 59 { 60 SV **where; 61 62 if ( 63 !gv 64 || ( 65 SvTYPE((const SV *)gv) != SVt_PVGV 66 && SvTYPE((const SV *)gv) != SVt_PVLV 67 ) 68 ) { 69 const char *what; 70 if (type == SVt_PVIO) { 71 /* 72 * if it walks like a dirhandle, then let's assume that 73 * this is a dirhandle. 74 */ 75 what = OP_IS_DIRHOP(PL_op->op_type) ? 76 "dirhandle" : "filehandle"; 77 } else if (type == SVt_PVHV) { 78 what = "hash"; 79 } else { 80 what = type == SVt_PVAV ? "array" : "scalar"; 81 } 82 Perl_croak(aTHX_ "Bad symbol for %s", what); 83 } 84 85 if (type == SVt_PVHV) { 86 where = (SV **)&GvHV(gv); 87 } else if (type == SVt_PVAV) { 88 where = (SV **)&GvAV(gv); 89 } else if (type == SVt_PVIO) { 90 where = (SV **)&GvIOp(gv); 91 } else { 92 where = &GvSV(gv); 93 } 94 95 if (!*where) 96 { 97 *where = newSV_type(type); 98 if ( type == SVt_PVAV 99 && memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA")) 100 { 101 sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0); 102 } 103 } 104 return gv; 105 } 106 107 /* 108 =for apidoc gv_fetchfile 109 =for apidoc_item gv_fetchfile_flags 110 111 These return the debugger glob for the file (compiled by Perl) whose name is 112 given by the C<name> parameter. 113 114 There are currently exactly two differences between these functions. 115 116 The C<name> parameter to C<gv_fetchfile> is a C string, meaning it is 117 C<NUL>-terminated; whereas the C<name> parameter to C<gv_fetchfile_flags> is a 118 Perl string, whose length (in bytes) is passed in via the C<namelen> parameter 119 This means the name may contain embedded C<NUL> characters. 120 C<namelen> doesn't exist in plain C<gv_fetchfile>). 121 122 The other difference is that C<gv_fetchfile_flags> has an extra C<flags> 123 parameter, which is currently completely ignored, but allows for possible 124 future extensions. 125 126 =cut 127 */ 128 GV * 129 Perl_gv_fetchfile(pTHX_ const char *name) 130 { 131 PERL_ARGS_ASSERT_GV_FETCHFILE; 132 return gv_fetchfile_flags(name, strlen(name), 0); 133 } 134 135 GV * 136 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, 137 const U32 flags) 138 { 139 char smallbuf[128]; 140 char *tmpbuf; 141 const STRLEN tmplen = namelen + 2; 142 GV *gv; 143 144 PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS; 145 PERL_UNUSED_ARG(flags); 146 147 if (!PL_defstash) 148 return NULL; 149 150 if (tmplen <= sizeof smallbuf) 151 tmpbuf = smallbuf; 152 else 153 Newx(tmpbuf, tmplen, char); 154 /* This is where the debugger's %{"::_<$filename"} hash is created */ 155 tmpbuf[0] = '_'; 156 tmpbuf[1] = '<'; 157 memcpy(tmpbuf + 2, name, namelen); 158 GV **gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, (flags & GVF_NOADD) ? FALSE : TRUE); 159 if (gvp) { 160 gv = *gvp; 161 if (!isGV(gv)) { 162 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE); 163 #ifdef PERL_DONT_CREATE_GVSV 164 GvSV(gv) = newSVpvn(name, namelen); 165 #else 166 sv_setpvn(GvSV(gv), name, namelen); 167 #endif 168 } 169 if (PERLDB_LINE_OR_SAVESRC && !GvAV(gv)) 170 hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile); 171 } 172 else { 173 gv = NULL; 174 } 175 if (tmpbuf != smallbuf) 176 Safefree(tmpbuf); 177 return gv; 178 } 179 180 /* 181 =for apidoc gv_const_sv 182 183 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for 184 inlining, or C<gv> is a placeholder reference that would be promoted to such 185 a typeglob, then returns the value returned by the sub. Otherwise, returns 186 C<NULL>. 187 188 =cut 189 */ 190 191 SV * 192 Perl_gv_const_sv(pTHX_ GV *gv) 193 { 194 PERL_ARGS_ASSERT_GV_CONST_SV; 195 PERL_UNUSED_CONTEXT; 196 197 if (SvTYPE(gv) == SVt_PVGV) 198 return cv_const_sv(GvCVu(gv)); 199 return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV && SvTYPE(SvRV(gv)) != SVt_PVCV ? SvRV(gv) : NULL; 200 } 201 202 GP * 203 Perl_newGP(pTHX_ GV *const gv) 204 { 205 GP *gp; 206 U32 hash; 207 const char *file; 208 STRLEN len; 209 210 PERL_ARGS_ASSERT_NEWGP; 211 Newxz(gp, 1, GP); 212 gp->gp_egv = gv; /* allow compiler to reuse gv after this */ 213 #ifndef PERL_DONT_CREATE_GVSV 214 gp->gp_sv = newSV_type(SVt_NULL); 215 #endif 216 217 /* PL_curcop may be null here. E.g., 218 INIT { bless {} and exit } 219 frees INIT before looking up DESTROY (and creating *DESTROY) 220 */ 221 if (PL_curcop) { 222 char *tmp= CopFILE(PL_curcop); 223 gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */ 224 225 if (tmp) { 226 file = tmp; 227 len = CopFILE_LEN(PL_curcop); 228 } 229 else goto no_file; 230 } 231 else { 232 no_file: 233 file = ""; 234 len = 0; 235 } 236 237 PERL_HASH(hash, file, len); 238 gp->gp_file_hek = share_hek(file, len, hash); 239 gp->gp_refcnt = 1; 240 241 return gp; 242 } 243 244 /* Assign CvGV(cv) = gv, handling weak references. 245 * See also S_anonymise_cv_maybe */ 246 247 void 248 Perl_cvgv_set(pTHX_ CV* cv, GV* gv) 249 { 250 GV * const oldgv = CvNAMED(cv) ? NULL : SvANY(cv)->xcv_gv_u.xcv_gv; 251 HEK *hek; 252 PERL_ARGS_ASSERT_CVGV_SET; 253 254 if (oldgv == gv) 255 return; 256 257 if (oldgv) { 258 if (CvCVGV_RC(cv)) { 259 SvREFCNT_dec_NN(oldgv); 260 CvCVGV_RC_off(cv); 261 } 262 else { 263 sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv)); 264 } 265 } 266 else if ((hek = CvNAME_HEK(cv))) { 267 unshare_hek(hek); 268 CvLEXICAL_off(cv); 269 } 270 271 CvNAMED_off(cv); 272 SvANY(cv)->xcv_gv_u.xcv_gv = gv; 273 assert(!CvCVGV_RC(cv)); 274 275 if (!gv) 276 return; 277 278 if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv)) 279 Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv)); 280 else { 281 CvCVGV_RC_on(cv); 282 SvREFCNT_inc_simple_void_NN(gv); 283 } 284 } 285 286 /* Convert CvSTASH + CvNAME_HEK into a GV. Conceptually, all subs have a 287 GV, but for efficiency that GV may not in fact exist. This function, 288 called by CvGV, reifies it. */ 289 290 GV * 291 Perl_cvgv_from_hek(pTHX_ CV *cv) 292 { 293 GV *gv; 294 SV **svp; 295 PERL_ARGS_ASSERT_CVGV_FROM_HEK; 296 assert(SvTYPE(cv) == SVt_PVCV); 297 if (!CvSTASH(cv)) return NULL; 298 ASSUME(CvNAME_HEK(cv)); 299 svp = hv_fetchhek(CvSTASH(cv), CvNAME_HEK(cv), 0); 300 gv = MUTABLE_GV(svp && *svp ? *svp : newSV_type(SVt_NULL)); 301 if (!isGV(gv)) 302 gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)), 303 HEK_LEN(CvNAME_HEK(cv)), 304 SVf_UTF8 * cBOOL(HEK_UTF8(CvNAME_HEK(cv)))); 305 if (!CvNAMED(cv)) { /* gv_init took care of it */ 306 assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv); 307 return gv; 308 } 309 unshare_hek(CvNAME_HEK(cv)); 310 CvNAMED_off(cv); 311 SvANY(cv)->xcv_gv_u.xcv_gv = gv; 312 if (svp && *svp) SvREFCNT_inc_simple_void_NN(gv); 313 CvCVGV_RC_on(cv); 314 return gv; 315 } 316 317 /* Assign CvSTASH(cv) = st, handling weak references. */ 318 319 void 320 Perl_cvstash_set(pTHX_ CV *cv, HV *st) 321 { 322 HV *oldst = CvSTASH(cv); 323 PERL_ARGS_ASSERT_CVSTASH_SET; 324 if (oldst == st) 325 return; 326 if (oldst) 327 sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv)); 328 SvANY(cv)->xcv_stash = st; 329 if (st) 330 Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv)); 331 } 332 333 /* 334 =for apidoc gv_init_pvn 335 336 Converts a scalar into a typeglob. This is an incoercible typeglob; 337 assigning a reference to it will assign to one of its slots, instead of 338 overwriting it as happens with typeglobs created by C<SvSetSV>. Converting 339 any scalar that is C<SvOK()> may produce unpredictable results and is reserved 340 for perl's internal use. 341 342 C<gv> is the scalar to be converted. 343 344 C<stash> is the parent stash/package, if any. 345 346 C<name> and C<len> give the name. The name must be unqualified; 347 that is, it must not include the package name. If C<gv> is a 348 stash element, it is the caller's responsibility to ensure that the name 349 passed to this function matches the name of the element. If it does not 350 match, perl's internal bookkeeping will get out of sync. 351 352 C<flags> can be set to C<SVf_UTF8> if C<name> is a UTF-8 string, or 353 the return value of SvUTF8(sv). It can also take the 354 C<GV_ADDMULTI> flag, which means to pretend that the GV has been 355 seen before (i.e., suppress "Used once" warnings). 356 357 =for apidoc Amnh||GV_ADDMULTI 358 359 =for apidoc gv_init 360 361 The old form of C<gv_init_pvn()>. It does not work with UTF-8 strings, as it 362 has no flags parameter. If the C<multi> parameter is set, the 363 C<GV_ADDMULTI> flag will be passed to C<gv_init_pvn()>. 364 365 =for apidoc gv_init_pv 366 367 Same as C<gv_init_pvn()>, but takes a nul-terminated string for the name 368 instead of separate char * and length parameters. 369 370 =for apidoc gv_init_sv 371 372 Same as C<gv_init_pvn()>, but takes an SV * for the name instead of separate 373 char * and length parameters. C<flags> is currently unused. 374 375 =cut 376 */ 377 378 void 379 Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags) 380 { 381 char *namepv; 382 STRLEN namelen; 383 PERL_ARGS_ASSERT_GV_INIT_SV; 384 namepv = SvPV(namesv, namelen); 385 if (SvUTF8(namesv)) 386 flags |= SVf_UTF8; 387 gv_init_pvn(gv, stash, namepv, namelen, flags); 388 } 389 390 void 391 Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags) 392 { 393 PERL_ARGS_ASSERT_GV_INIT_PV; 394 gv_init_pvn(gv, stash, name, strlen(name), flags); 395 } 396 397 /* Packages in the symbol table are "stashes" - hashes where the keys are symbol 398 names and the values are typeglobs. The value $foo::bar is actually found 399 by looking up the typeglob *foo::{bar} and then reading its SCALAR slot. 400 401 At least, that's what you see in Perl space if you use typeglob syntax. 402 Usually it's also what's actually stored in the stash, but for some cases 403 different values are stored (as a space optimisation) and converted to full 404 typeglobs "on demand" - if a typeglob syntax is used to read a value. It's 405 the job of this function, Perl_gv_init_pvn(), to undo any trickery and 406 replace the SV stored in the stash with the regular PVGV structure that it is 407 a shorthand for. This has to be done "in-place" by upgrading the actual SV 408 that is already stored in the stash to a PVGV. 409 410 As the public documentation above says: 411 Converting any scalar that is C<SvOK()> may produce unpredictable 412 results and is reserved for perl's internal use. 413 414 Values that can be stored: 415 416 * plain scalar - a subroutine declaration 417 The scalar's string value is the subroutine prototype; the integer -1 is 418 "no prototype". ie shorthand for sub foo ($$); or sub bar; 419 * reference to a scalar - a constant. ie shorthand for sub PI() { 4; } 420 * reference to a sub - a subroutine (avoids allocating a PVGV) 421 422 The earliest optimisation was subroutine declarations, implemented in 1998 423 by commit 8472ac73d6d80294: 424 "Sub declaration cost reduced from ~500 to ~100 bytes" 425 426 This space optimisation needs to be invisible to regular Perl code. For this 427 code: 428 429 sub foo ($$); 430 *foo = []; 431 432 When the first line is compiled, the optimisation is used, and $::{foo} is 433 assigned the scalar '$$'. No PVGV or PVCV is created. 434 435 When the second line encountered, the typeglob lookup on foo needs to 436 "upgrade" the symbol table entry to a PVGV, and then create a PVCV in the 437 {CODE} slot with the prototype $$ and no body. The typeglob is then available 438 so that [] can be assigned to the {ARRAY} slot. For the code above the 439 upgrade happens at compile time, the assignment at runtime. 440 441 Analogous code unwinds the other optimisations. 442 */ 443 void 444 Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags) 445 { 446 const U32 old_type = SvTYPE(gv); 447 const bool doproto = old_type > SVt_NULL; 448 char * const proto = (doproto && SvPOK(gv)) 449 ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv)) 450 : NULL; 451 const STRLEN protolen = proto ? SvCUR(gv) : 0; 452 const U32 proto_utf8 = proto ? SvUTF8(gv) : 0; 453 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL; 454 const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0; 455 const bool really_sub = 456 has_constant && SvTYPE(has_constant) == SVt_PVCV; 457 COP * const old = PL_curcop; 458 459 PERL_ARGS_ASSERT_GV_INIT_PVN; 460 assert (!(proto && has_constant)); 461 462 if (has_constant) { 463 /* The constant has to be a scalar, array or subroutine. */ 464 switch (SvTYPE(has_constant)) { 465 case SVt_PVHV: 466 case SVt_PVFM: 467 case SVt_PVIO: 468 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob", 469 sv_reftype(has_constant, 0)); 470 NOT_REACHED; /* NOTREACHED */ 471 break; 472 473 default: NOOP; 474 } 475 SvRV_set(gv, NULL); 476 SvROK_off(gv); 477 } 478 479 480 if (old_type < SVt_PVGV) { 481 if (old_type >= SVt_PV) 482 SvCUR_set(gv, 0); 483 sv_upgrade(MUTABLE_SV(gv), SVt_PVGV); 484 } 485 if (SvLEN(gv)) { 486 if (proto) { 487 /* For this case, we are "stealing" the buffer from the SvPV and 488 re-attaching to an SV below with the call to sv_usepvn_flags(). 489 Hence we don't free it. */ 490 SvPV_set(gv, NULL); 491 } 492 else { 493 /* There is no valid prototype. (SvPOK() must be true for a valid 494 prototype.) Hence we free the memory. */ 495 Safefree(SvPVX_mutable(gv)); 496 } 497 SvLEN_set(gv, 0); 498 SvPOK_off(gv); 499 } 500 SvIOK_off(gv); 501 isGV_with_GP_on(gv); 502 503 if (really_sub && !CvISXSUB(has_constant) && CvSTART(has_constant) 504 && ( CvSTART(has_constant)->op_type == OP_NEXTSTATE 505 || CvSTART(has_constant)->op_type == OP_DBSTATE)) 506 PL_curcop = (COP *)CvSTART(has_constant); 507 GvGP_set(gv, Perl_newGP(aTHX_ gv)); 508 PL_curcop = old; 509 GvSTASH(gv) = stash; 510 if (stash) 511 Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv)); 512 gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 )); 513 if (flags & GV_ADDMULTI || doproto) /* doproto means it */ 514 GvMULTI_on(gv); /* _was_ mentioned */ 515 if (really_sub) { 516 /* Not actually a constant. Just a regular sub. */ 517 CV * const cv = (CV *)has_constant; 518 GvCV_set(gv,cv); 519 if (CvNAMED(cv) && CvSTASH(cv) == stash && ( 520 CvNAME_HEK(cv) == GvNAME_HEK(gv) 521 || ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv)) 522 && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv)) 523 && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv)) 524 && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv)) 525 ) 526 )) 527 CvGV_set(cv,gv); 528 } 529 else if (doproto) { 530 CV *cv; 531 if (has_constant) { 532 /* newCONSTSUB takes ownership of the reference from us. */ 533 cv = newCONSTSUB_flags(stash, name, len, flags, has_constant); 534 /* In case op.c:S_process_special_blocks stole it: */ 535 if (!GvCV(gv)) 536 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv)); 537 assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */ 538 /* If this reference was a copy of another, then the subroutine 539 must have been "imported", by a Perl space assignment to a GV 540 from a reference to CV. */ 541 if (exported_constant) 542 GvIMPORTED_CV_on(gv); 543 CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */ 544 } else { 545 cv = newSTUB(gv,1); 546 } 547 if (proto) { 548 sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen, 549 SV_HAS_TRAILING_NUL); 550 if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv)); 551 } 552 } 553 } 554 555 STATIC void 556 S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type) 557 { 558 PERL_ARGS_ASSERT_GV_INIT_SVTYPE; 559 560 switch (sv_type) { 561 case SVt_PVIO: 562 (void)GvIOn(gv); 563 break; 564 case SVt_PVAV: 565 (void)GvAVn(gv); 566 break; 567 case SVt_PVHV: 568 (void)GvHVn(gv); 569 break; 570 #ifdef PERL_DONT_CREATE_GVSV 571 case SVt_NULL: 572 case SVt_PVCV: 573 case SVt_PVFM: 574 case SVt_PVGV: 575 break; 576 default: 577 if(GvSVn(gv)) { 578 /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13 579 If we just cast GvSVn(gv) to void, it ignores evaluating it for 580 its side effect */ 581 } 582 #endif 583 } 584 } 585 586 static void core_xsub(pTHX_ CV* cv); 587 588 static GV * 589 S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, 590 const char * const name, const STRLEN len) 591 { 592 const int code = keyword(name, len, 1); 593 static const char file[] = __FILE__; 594 CV *cv, *oldcompcv = NULL; 595 int opnum = 0; 596 bool ampable = TRUE; /* &{}-able */ 597 COP *oldcurcop = NULL; 598 yy_parser *oldparser = NULL; 599 I32 oldsavestack_ix = 0; 600 601 assert(gv || stash); 602 assert(name); 603 604 if (!code) return NULL; /* Not a keyword */ 605 switch (code < 0 ? -code : code) { 606 /* no support for \&CORE::infix; 607 no support for funcs that do not parse like funcs */ 608 case KEY___DATA__: case KEY___END__ : 609 case KEY_ADJUST : case KEY_AUTOLOAD: case KEY_BEGIN : case KEY_CHECK : 610 case KEY_DESTROY : case KEY_END : case KEY_INIT : case KEY_UNITCHECK: 611 case KEY_and : case KEY_catch : case KEY_class : 612 case KEY_cmp : case KEY_default: case KEY_defer : 613 case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif : 614 case KEY_eq : case KEY_eval : case KEY_field : 615 case KEY_finally: 616 case KEY_for : case KEY_foreach: case KEY_format: case KEY_ge : 617 case KEY_given : case KEY_goto : case KEY_grep : case KEY_gt : 618 case KEY_if : case KEY_isa : 619 case KEY_last : 620 case KEY_le : case KEY_local : case KEY_lt : case KEY_m : 621 case KEY_map : case KEY_method : case KEY_my : 622 case KEY_ne : case KEY_next : case KEY_no: case KEY_or: case KEY_our: 623 case KEY_package: case KEY_print: case KEY_printf: 624 case KEY_q : case KEY_qq : case KEY_qr : case KEY_qw : 625 case KEY_qx : case KEY_redo : case KEY_require: case KEY_return: 626 case KEY_s : case KEY_say : case KEY_sort : 627 case KEY_state: case KEY_sub : 628 case KEY_tr : case KEY_try : 629 case KEY_unless: 630 case KEY_until: case KEY_use : case KEY_when : case KEY_while : 631 case KEY_x : case KEY_xor : case KEY_y : 632 return NULL; 633 case KEY_chdir: 634 case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete: 635 case KEY_eof : case KEY_exec: case KEY_exists : 636 case KEY_lstat: 637 case KEY_split: 638 case KEY_stat: 639 case KEY_system: 640 case KEY_truncate: case KEY_unlink: 641 ampable = FALSE; 642 } 643 if (!gv) { 644 gv = (GV *)newSV_type(SVt_NULL); 645 gv_init(gv, stash, name, len, TRUE); 646 } 647 GvMULTI_on(gv); 648 if (ampable) { 649 ENTER; 650 oldcurcop = PL_curcop; 651 oldparser = PL_parser; 652 lex_start(NULL, NULL, 0); 653 oldcompcv = PL_compcv; 654 PL_compcv = NULL; /* Prevent start_subparse from setting 655 CvOUTSIDE. */ 656 oldsavestack_ix = start_subparse(FALSE,0); 657 cv = PL_compcv; 658 } 659 else { 660 /* Avoid calling newXS, as it calls us, and things start to 661 get hairy. */ 662 cv = MUTABLE_CV(newSV_type(SVt_PVCV)); 663 GvCV_set(gv,cv); 664 GvCVGEN(gv) = 0; 665 CvISXSUB_on(cv); 666 CvXSUB(cv) = core_xsub; 667 PoisonPADLIST(cv); 668 } 669 CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE 670 from PL_curcop. */ 671 /* XSUBs can't be perl lang/perl5db.pl debugged 672 if (PERLDB_LINE_OR_SAVESRC) 673 (void)gv_fetchfile(file); */ 674 CvFILE(cv) = (char *)file; 675 /* XXX This is inefficient, as doing things this order causes 676 a prototype check in newATTRSUB. But we have to do 677 it this order as we need an op number before calling 678 new ATTRSUB. */ 679 (void)core_prototype((SV *)cv, name, code, &opnum); 680 if (stash) 681 (void)hv_store(stash,name,len,(SV *)gv,0); 682 if (ampable) { 683 #ifdef DEBUGGING 684 CV *orig_cv = cv; 685 #endif 686 CvLVALUE_on(cv); 687 /* newATTRSUB will free the CV and return NULL if we're still 688 compiling after a syntax error */ 689 if ((cv = newATTRSUB_x( 690 oldsavestack_ix, (OP *)gv, 691 NULL,NULL, 692 coresub_op( 693 opnum 694 ? newSVuv((UV)opnum) 695 : newSVpvn(name,len), 696 code, opnum 697 ), 698 TRUE 699 )) != NULL) { 700 assert(GvCV(gv) == orig_cv); 701 if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS 702 && opnum != OP_UNDEF && opnum != OP_KEYS) 703 CvLVALUE_off(cv); /* Now *that* was a neat trick. */ 704 } 705 LEAVE; 706 PL_parser = oldparser; 707 PL_curcop = oldcurcop; 708 PL_compcv = oldcompcv; 709 } 710 if (cv) { 711 SV *opnumsv = newSViv( 712 (opnum == OP_ENTEREVAL && len == 9 && memEQ(name, "evalbytes", 9)) ? 713 (OP_ENTEREVAL | (1<<16)) 714 : opnum ? opnum : (((I32)name[2]) << 16)); 715 cv_set_call_checker_flags(cv, Perl_ck_entersub_args_core, opnumsv, 0); 716 SvREFCNT_dec_NN(opnumsv); 717 } 718 719 return gv; 720 } 721 722 /* 723 =for apidoc gv_fetchmeth 724 =for apidoc_item gv_fetchmeth_pv 725 =for apidoc_item gv_fetchmeth_pvn 726 =for apidoc_item gv_fetchmeth_sv 727 728 These each look for a glob with name C<name>, containing a defined subroutine, 729 returning the GV of that glob if found, or C<NULL> if not. 730 731 C<stash> is always searched (first), unless it is C<NULL>. 732 733 If C<stash> is NULL, or was searched but nothing was found in it, and the 734 C<GV_SUPER> bit is set in C<flags>, stashes accessible via C<@ISA> are searched 735 next. Searching is conducted according to L<C<MRO> order|perlmroapi>. 736 737 Finally, if no matches were found so far, and the C<GV_NOUNIVERSAL> flag in 738 C<flags> is not set, C<UNIVERSAL::> is searched. 739 740 The argument C<level> should be either 0 or -1. If -1, the function will 741 return without any side effects or caching. If 0, the function makes sure 742 there is a glob named C<name> in C<stash>, creating one if necessary. 743 The subroutine slot in the glob will be set to any subroutine found in the 744 C<stash> and C<SUPER::> search, hence caching any C<SUPER::> result. Note that 745 subroutines found in C<UNIVERSAL::> are not cached. 746 747 The GV returned from these may be a method cache entry, which is not visible to 748 Perl code. So when calling C<call_sv>, you should not use the GV directly; 749 instead, you should use the method's CV, which can be obtained from the GV with 750 the C<GvCV> macro. 751 752 The only other significant value for C<flags> is C<SVf_UTF8>, indicating that 753 C<name> is to be treated as being encoded in UTF-8. 754 755 Plain C<gv_fetchmeth> lacks a C<flags> parameter, hence always searches in 756 C<stash>, then C<UNIVERSAL::>, and C<name> is never UTF-8. Otherwise it is 757 exactly like C<gv_fetchmeth_pvn>. 758 759 The other forms do have a C<flags> parameter, and differ only in how the glob 760 name is specified. 761 762 In C<gv_fetchmeth_pv>, C<name> is a C language NUL-terminated string. 763 764 In C<gv_fetchmeth_pvn>, C<name> points to the first byte of the name, and an 765 additional parameter, C<len>, specifies its length in bytes. Hence, the name 766 may contain embedded-NUL characters. 767 768 In C<gv_fetchmeth_sv>, C<*name> is an SV, and the name is the PV extracted from 769 that, using L</C<SvPV>>. If the SV is marked as being in UTF-8, the extracted 770 PV will also be. 771 772 =for apidoc Amnh||GV_SUPER 773 774 =cut 775 */ 776 777 GV * 778 Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags) 779 { 780 char *namepv; 781 STRLEN namelen; 782 PERL_ARGS_ASSERT_GV_FETCHMETH_SV; 783 if (LIKELY(SvPOK_nog(namesv))) /* common case */ 784 return gv_fetchmeth_internal(stash, namesv, NULL, 0, level, 785 flags | SvUTF8(namesv)); 786 namepv = SvPV(namesv, namelen); 787 if (SvUTF8(namesv)) flags |= SVf_UTF8; 788 return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags); 789 } 790 791 792 GV * 793 Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags) 794 { 795 PERL_ARGS_ASSERT_GV_FETCHMETH_PV; 796 return gv_fetchmeth_internal(stash, NULL, name, strlen(name), level, flags); 797 } 798 799 /* NOTE: No support for tied ISA */ 800 801 PERL_STATIC_INLINE GV* 802 S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, I32 level, U32 flags) 803 { 804 GV** gvp; 805 HE* he; 806 AV* linear_av; 807 SV** linear_svp; 808 SV* linear_sv; 809 HV* cstash, *cachestash; 810 GV* candidate = NULL; 811 CV* cand_cv = NULL; 812 GV* topgv = NULL; 813 const char *hvname; 814 STRLEN hvnamelen; 815 I32 create = (level >= 0) ? HV_FETCH_LVALUE : 0; 816 I32 items; 817 U32 topgen_cmp; 818 U32 is_utf8 = flags & SVf_UTF8; 819 820 /* UNIVERSAL methods should be callable without a stash */ 821 if (!stash) { 822 create = 0; /* probably appropriate */ 823 if(!(stash = gv_stashpvs("UNIVERSAL", 0))) 824 return 0; 825 } 826 827 assert(stash); 828 829 hvname = HvNAME_get(stash); 830 hvnamelen = HvNAMELEN_get(stash); 831 if (!hvname) 832 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); 833 834 assert(hvname); 835 assert(name || meth); 836 837 DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n", 838 flags & GV_SUPER ? "SUPER " : "", 839 name ? name : SvPV_nolen(meth), hvname) ); 840 841 topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation; 842 843 if (flags & GV_SUPER) { 844 if (!HvAUX(stash)->xhv_mro_meta->super) 845 HvAUX(stash)->xhv_mro_meta->super = newHV(); 846 cachestash = HvAUX(stash)->xhv_mro_meta->super; 847 } 848 else cachestash = stash; 849 850 /* check locally for a real method or a cache entry */ 851 he = (HE*)hv_common( 852 cachestash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, create, NULL, 0 853 ); 854 if (he) gvp = (GV**)&HeVAL(he); 855 else gvp = NULL; 856 857 if(gvp) { 858 topgv = *gvp; 859 have_gv: 860 assert(topgv); 861 if (SvTYPE(topgv) != SVt_PVGV) 862 { 863 if (!name) 864 name = SvPV_nomg(meth, len); 865 gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8); 866 } 867 if ((cand_cv = GvCV(topgv))) { 868 /* If genuine method or valid cache entry, use it */ 869 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) { 870 return topgv; 871 } 872 else { 873 /* stale cache entry, junk it and move on */ 874 SvREFCNT_dec_NN(cand_cv); 875 GvCV_set(topgv, NULL); 876 cand_cv = NULL; 877 GvCVGEN(topgv) = 0; 878 } 879 } 880 else if (GvCVGEN(topgv) == topgen_cmp) { 881 /* cache indicates no such method definitively */ 882 return 0; 883 } 884 else if (stash == cachestash 885 && len > 1 /* shortest is uc */ 886 && memEQs(hvname, HvNAMELEN_get(stash), "CORE") 887 && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len)) 888 goto have_gv; 889 } 890 891 linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */ 892 linear_svp = AvARRAY(linear_av) + 1; /* skip over self */ 893 items = AvFILLp(linear_av); /* no +1, to skip over self */ 894 while (items--) { 895 linear_sv = *linear_svp++; 896 assert(linear_sv); 897 cstash = gv_stashsv(linear_sv, 0); 898 899 if (!cstash) { 900 if ( ckWARN(WARN_SYNTAX)) { 901 if( /* these are loaded from Perl_Gv_AMupdate() one way or another */ 902 ( len && name[0] == '(' ) /* overload.pm related, in particular "()" */ 903 || ( memEQs( name, len, "DESTROY") ) 904 ) { 905 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), 906 "Can't locate package %" SVf " for @%" HEKf "::ISA", 907 SVfARG(linear_sv), 908 HEKfARG(HvNAME_HEK(stash))); 909 910 } else if( memEQs( name, len, "AUTOLOAD") ) { 911 /* gobble this warning */ 912 } else { 913 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), 914 "While trying to resolve method call %.*s->%.*s()" 915 " can not locate package %" SVf_QUOTEDPREFIX " yet it is mentioned in @%.*s::ISA" 916 " (perhaps you forgot to load %" SVf_QUOTEDPREFIX "?)", 917 (int) hvnamelen, hvname, 918 (int) len, name, 919 SVfARG(linear_sv), 920 (int) hvnamelen, hvname, 921 SVfARG(linear_sv)); 922 } 923 } 924 continue; 925 } 926 927 assert(cstash); 928 929 gvp = (GV**)hv_common( 930 cstash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, HV_FETCH_JUST_SV, NULL, 0 931 ); 932 if (!gvp) { 933 if (len > 1 && HvNAMELEN_get(cstash) == 4) { 934 const char *hvname = HvNAME(cstash); assert(hvname); 935 if (strBEGINs(hvname, "CORE") 936 && (candidate = 937 S_maybe_add_coresub(aTHX_ cstash,NULL,name,len) 938 )) 939 goto have_candidate; 940 } 941 continue; 942 } 943 else candidate = *gvp; 944 have_candidate: 945 assert(candidate); 946 if (SvTYPE(candidate) != SVt_PVGV) 947 gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8); 948 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { 949 /* 950 * Found real method, cache method in topgv if: 951 * 1. topgv has no synonyms (else inheritance crosses wires) 952 * 2. method isn't a stub (else AUTOLOAD fails spectacularly) 953 */ 954 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { 955 CV *old_cv = GvCV(topgv); 956 SvREFCNT_dec(old_cv); 957 SvREFCNT_inc_simple_void_NN(cand_cv); 958 GvCV_set(topgv, cand_cv); 959 GvCVGEN(topgv) = topgen_cmp; 960 } 961 return candidate; 962 } 963 } 964 965 /* Check UNIVERSAL without caching */ 966 if((level == 0 || level == -1) && !(flags & GV_NOUNIVERSAL)) { 967 candidate = gv_fetchmeth_internal(NULL, meth, name, len, 1, 968 flags &~GV_SUPER); 969 if(candidate) { 970 cand_cv = GvCV(candidate); 971 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { 972 CV *old_cv = GvCV(topgv); 973 SvREFCNT_dec(old_cv); 974 SvREFCNT_inc_simple_void_NN(cand_cv); 975 GvCV_set(topgv, cand_cv); 976 GvCVGEN(topgv) = topgen_cmp; 977 } 978 return candidate; 979 } 980 } 981 982 if (topgv && GvREFCNT(topgv) == 1 && !(flags & GV_NOUNIVERSAL)) { 983 /* cache the fact that the method is not defined */ 984 GvCVGEN(topgv) = topgen_cmp; 985 } 986 987 return 0; 988 } 989 990 GV * 991 Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags) 992 { 993 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN; 994 return gv_fetchmeth_internal(stash, NULL, name, len, level, flags); 995 } 996 997 /* 998 =for apidoc gv_fetchmeth_autoload 999 1000 This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags 1001 parameter. 1002 1003 =for apidoc gv_fetchmeth_sv_autoload 1004 1005 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form 1006 of an SV instead of a string/length pair. 1007 1008 =cut 1009 */ 1010 1011 GV * 1012 Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags) 1013 { 1014 char *namepv; 1015 STRLEN namelen; 1016 PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD; 1017 namepv = SvPV(namesv, namelen); 1018 if (SvUTF8(namesv)) 1019 flags |= SVf_UTF8; 1020 return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags); 1021 } 1022 1023 /* 1024 =for apidoc gv_fetchmeth_pv_autoload 1025 1026 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string 1027 instead of a string/length pair. 1028 1029 =cut 1030 */ 1031 1032 GV * 1033 Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags) 1034 { 1035 PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD; 1036 return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags); 1037 } 1038 1039 /* 1040 =for apidoc gv_fetchmeth_pvn_autoload 1041 1042 Same as C<gv_fetchmeth_pvn()>, but looks for autoloaded subroutines too. 1043 Returns a glob for the subroutine. 1044 1045 For an autoloaded subroutine without a GV, will create a GV even 1046 if C<level < 0>. For an autoloaded subroutine without a stub, C<GvCV()> 1047 of the result may be zero. 1048 1049 Currently, the only significant value for C<flags> is C<SVf_UTF8>. 1050 1051 =cut 1052 */ 1053 1054 GV * 1055 Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags) 1056 { 1057 GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags); 1058 1059 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD; 1060 1061 if (!gv) { 1062 CV *cv; 1063 GV **gvp; 1064 1065 if (!stash) 1066 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */ 1067 if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) 1068 return NULL; 1069 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags))) 1070 return NULL; 1071 cv = GvCV(gv); 1072 if (!(CvROOT(cv) || CvXSUB(cv))) 1073 return NULL; 1074 /* Have an autoload */ 1075 if (level < 0) /* Cannot do without a stub */ 1076 gv_fetchmeth_pvn(stash, name, len, 0, flags); 1077 gvp = (GV**)hv_fetch(stash, name, 1078 (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0)); 1079 if (!gvp) 1080 return NULL; 1081 return *gvp; 1082 } 1083 return gv; 1084 } 1085 1086 /* 1087 =for apidoc gv_fetchmethod_autoload 1088 1089 Returns the glob which contains the subroutine to call to invoke the method 1090 on the C<stash>. In fact in the presence of autoloading this may be the 1091 glob for "AUTOLOAD". In this case the corresponding variable C<$AUTOLOAD> is 1092 already setup. 1093 1094 The third parameter of C<gv_fetchmethod_autoload> determines whether 1095 AUTOLOAD lookup is performed if the given method is not present: non-zero 1096 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD. 1097 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload> 1098 with a non-zero C<autoload> parameter. 1099 1100 These functions grant C<"SUPER"> token 1101 as a prefix of the method name. Note 1102 that if you want to keep the returned glob for a long time, you need to 1103 check for it being "AUTOLOAD", since at the later time the call may load a 1104 different subroutine due to C<$AUTOLOAD> changing its value. Use the glob 1105 created as a side effect to do this. 1106 1107 These functions have the same side-effects as C<gv_fetchmeth> with 1108 C<level==0>. The warning against passing the GV returned by 1109 C<gv_fetchmeth> to C<call_sv> applies equally to these functions. 1110 1111 =cut 1112 */ 1113 1114 GV * 1115 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) 1116 { 1117 PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD; 1118 1119 return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0); 1120 } 1121 1122 GV * 1123 Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags) 1124 { 1125 char *namepv; 1126 STRLEN namelen; 1127 PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS; 1128 namepv = SvPV(namesv, namelen); 1129 if (SvUTF8(namesv)) 1130 flags |= SVf_UTF8; 1131 return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags); 1132 } 1133 1134 GV * 1135 Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags) 1136 { 1137 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS; 1138 return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags); 1139 } 1140 1141 GV * 1142 Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags) 1143 { 1144 const char * const origname = name; 1145 const char * const name_end = name + len; 1146 const char *last_separator = NULL; 1147 GV* gv; 1148 HV* ostash = stash; 1149 SV *const error_report = MUTABLE_SV(stash); 1150 const U32 autoload = flags & GV_AUTOLOAD; 1151 const U32 do_croak = flags & GV_CROAK; 1152 const U32 is_utf8 = flags & SVf_UTF8; 1153 1154 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS; 1155 1156 if (SvTYPE(stash) < SVt_PVHV) 1157 stash = NULL; 1158 else { 1159 /* The only way stash can become NULL later on is if last_separator is set, 1160 which in turn means that there is no need for a SVt_PVHV case 1161 the error reporting code. */ 1162 } 1163 1164 { 1165 /* check if the method name is fully qualified or 1166 * not, and separate the package name from the actual 1167 * method name. 1168 * 1169 * leaves last_separator pointing to the beginning of the 1170 * last package separator (either ' or ::) or 0 1171 * if none was found. 1172 * 1173 * leaves name pointing at the beginning of the 1174 * method name. 1175 */ 1176 const char *name_cursor = name; 1177 const char * const name_em1 = name_end - 1; /* name_end minus 1 */ 1178 for (name_cursor = name; name_cursor < name_end ; name_cursor++) { 1179 if (*name_cursor == '\'') { 1180 last_separator = name_cursor; 1181 name = name_cursor + 1; 1182 } 1183 else if (name_cursor < name_em1 && *name_cursor == ':' && name_cursor[1] == ':') { 1184 last_separator = name_cursor++; 1185 name = name_cursor + 1; 1186 } 1187 } 1188 } 1189 1190 /* did we find a separator? */ 1191 if (last_separator) { 1192 STRLEN sep_len= last_separator - origname; 1193 if ( memEQs(origname, sep_len, "SUPER")) { 1194 /* ->SUPER::method should really be looked up in original stash */ 1195 stash = CopSTASH(PL_curcop); 1196 flags |= GV_SUPER; 1197 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", 1198 origname, HvENAME_get(stash), name) ); 1199 } 1200 else if ( sep_len >= 7 && 1201 strBEGINs(last_separator - 7, "::SUPER")) { 1202 /* don't autovivify if ->NoSuchStash::SUPER::method */ 1203 stash = gv_stashpvn(origname, sep_len - 7, is_utf8); 1204 if (stash) flags |= GV_SUPER; 1205 } 1206 else { 1207 /* don't autovivify if ->NoSuchStash::method */ 1208 stash = gv_stashpvn(origname, sep_len, is_utf8); 1209 } 1210 ostash = stash; 1211 } 1212 1213 gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags); 1214 if (!gv) { 1215 /* This is the special case that exempts Foo->import and 1216 Foo->unimport from being an error even if there's no 1217 import/unimport subroutine */ 1218 if (strEQ(name,"import") || strEQ(name,"unimport")) { 1219 gv = (GV*)sv_2mortal((SV*)newCONSTSUB_flags(NULL, 1220 NULL, 0, 0, NULL)); 1221 } else if (autoload) 1222 gv = gv_autoload_pvn( 1223 ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags 1224 ); 1225 if (!gv && do_croak) { 1226 /* Right now this is exclusively for the benefit of S_method_common 1227 in pp_hot.c */ 1228 if (stash) { 1229 /* If we can't find an IO::File method, it might be a call on 1230 * a filehandle. If IO:File has not been loaded, try to 1231 * require it first instead of croaking */ 1232 const char *stash_name = HvNAME_get(stash); 1233 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File") 1234 && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL, 1235 STR_WITH_LEN("IO/File.pm"), 0, 1236 HV_FETCH_ISEXISTS, NULL, 0) 1237 ) { 1238 require_pv("IO/File.pm"); 1239 gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags); 1240 if (gv) 1241 return gv; 1242 } 1243 Perl_croak(aTHX_ 1244 "Can't locate object method %" UTF8f_QUOTEDPREFIX "" 1245 " via package %" HEKf_QUOTEDPREFIX, 1246 UTF8fARG(is_utf8, name_end - name, name), 1247 HEKfARG(HvNAME_HEK(stash))); 1248 } 1249 else { 1250 SV* packnamesv; 1251 1252 if (last_separator) { 1253 packnamesv = newSVpvn_flags(origname, last_separator - origname, 1254 SVs_TEMP | is_utf8); 1255 } else { 1256 packnamesv = error_report; 1257 } 1258 1259 Perl_croak(aTHX_ 1260 "Can't locate object method %" UTF8f_QUOTEDPREFIX "" 1261 " via package %" SVf_QUOTEDPREFIX "" 1262 " (perhaps you forgot to load %" SVf_QUOTEDPREFIX "?)", 1263 UTF8fARG(is_utf8, name_end - name, name), 1264 SVfARG(packnamesv), SVfARG(packnamesv)); 1265 } 1266 } 1267 } 1268 else if (autoload) { 1269 CV* const cv = GvCV(gv); 1270 if (!CvROOT(cv) && !CvXSUB(cv)) { 1271 GV* stubgv; 1272 GV* autogv; 1273 1274 if (CvANON(cv) || CvLEXICAL(cv)) 1275 stubgv = gv; 1276 else { 1277 stubgv = CvGV(cv); 1278 if (GvCV(stubgv) != cv) /* orphaned import */ 1279 stubgv = gv; 1280 } 1281 autogv = gv_autoload_pvn(GvSTASH(stubgv), 1282 GvNAME(stubgv), GvNAMELEN(stubgv), 1283 GV_AUTOLOAD_ISMETHOD 1284 | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0)); 1285 if (autogv) 1286 gv = autogv; 1287 } 1288 } 1289 1290 return gv; 1291 } 1292 1293 1294 /* 1295 =for apidoc gv_autoload_pv 1296 =for apidoc_item gv_autoload_pvn 1297 =for apidoc_item gv_autoload_sv 1298 1299 These each search for an C<AUTOLOAD> method, returning NULL if not found, or 1300 else returning a pointer to its GV, while setting the package 1301 L<C<$AUTOLOAD>|perlobj/AUTOLOAD> variable to C<name> (fully qualified). Also, 1302 if found and the GV's CV is an XSUB, the CV's PV will be set to C<name>, and 1303 its stash will be set to the stash of the GV. 1304 1305 Searching is done in L<C<MRO> order|perlmroapi>, as specified in 1306 L</C<gv_fetchmeth>>, beginning with C<stash> if it isn't NULL. 1307 1308 The forms differ only in how C<name> is specified. 1309 1310 In C<gv_autoload_pv>, C<namepv> is a C language NUL-terminated string. 1311 1312 In C<gv_autoload_pvn>, C<name> points to the first byte of the name, and an 1313 additional parameter, C<len>, specifies its length in bytes. Hence, C<*name> 1314 may contain embedded-NUL characters. 1315 1316 In C<gv_autoload_sv>, C<*namesv> is an SV, and the name is the PV extracted 1317 from that using L</C<SvPV>>. If the SV is marked as being in UTF-8, the 1318 extracted PV will also be. 1319 1320 =cut 1321 */ 1322 1323 GV* 1324 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags) 1325 { 1326 char *namepv; 1327 STRLEN namelen; 1328 PERL_ARGS_ASSERT_GV_AUTOLOAD_SV; 1329 namepv = SvPV(namesv, namelen); 1330 if (SvUTF8(namesv)) 1331 flags |= SVf_UTF8; 1332 return gv_autoload_pvn(stash, namepv, namelen, flags); 1333 } 1334 1335 GV* 1336 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags) 1337 { 1338 PERL_ARGS_ASSERT_GV_AUTOLOAD_PV; 1339 return gv_autoload_pvn(stash, namepv, strlen(namepv), flags); 1340 } 1341 1342 GV* 1343 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) 1344 { 1345 GV* gv; 1346 CV* cv; 1347 HV* varstash; 1348 GV* vargv; 1349 SV* varsv; 1350 SV *packname = NULL; 1351 U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0; 1352 1353 PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN; 1354 1355 if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) 1356 return NULL; 1357 if (stash) { 1358 if (SvTYPE(stash) < SVt_PVHV) { 1359 STRLEN packname_len = 0; 1360 const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len); 1361 packname = newSVpvn_flags(packname_ptr, packname_len, 1362 SVs_TEMP | SvUTF8(stash)); 1363 stash = NULL; 1364 } 1365 else 1366 packname = newSVhek_mortal(HvNAME_HEK(stash)); 1367 if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER"); 1368 } 1369 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, 1370 is_utf8 | (flags & GV_SUPER)))) 1371 return NULL; 1372 cv = GvCV(gv); 1373 1374 if (!(CvROOT(cv) || CvXSUB(cv))) 1375 return NULL; 1376 1377 /* 1378 * Inheriting AUTOLOAD for non-methods no longer works 1379 */ 1380 if ( 1381 !(flags & GV_AUTOLOAD_ISMETHOD) 1382 && (GvCVGEN(gv) || GvSTASH(gv) != stash) 1383 ) 1384 Perl_croak(aTHX_ "Use of inherited AUTOLOAD for non-method %" SVf 1385 "::%" UTF8f "() is no longer allowed", 1386 SVfARG(packname), 1387 UTF8fARG(is_utf8, len, name)); 1388 1389 if (CvISXSUB(cv)) { 1390 /* Instead of forcing the XSUB to do another lookup for $AUTOLOAD 1391 * and split that value on the last '::', pass along the same data 1392 * via the SvPVX field in the CV, and the stash in CvSTASH. 1393 * 1394 * Due to an unfortunate accident of history, the SvPVX field 1395 * serves two purposes. It is also used for the subroutine's 1396 * prototype. Since SvPVX has been documented as returning the sub 1397 * name for a long time, but not as returning the prototype, we have to 1398 * preserve the SvPVX AUTOLOAD behaviour and put the prototype 1399 * elsewhere. 1400 * 1401 * We put the prototype in the same allocated buffer, but after 1402 * the sub name. The SvPOK flag indicates the presence of a proto- 1403 * type. The CvAUTOLOAD flag indicates the presence of a sub name. 1404 * If both flags are on, then SvLEN is used to indicate the end of 1405 * the prototype (artificially lower than what is actually allo- 1406 * cated), at the risk of having to reallocate a few bytes unneces- 1407 * sarily--but that should happen very rarely, if ever. 1408 * 1409 * We use SvUTF8 for both prototypes and sub names, so if one is 1410 * UTF8, the other must be upgraded. 1411 */ 1412 CvSTASH_set(cv, stash); 1413 if (SvPOK(cv)) { /* Ouch! */ 1414 SV * const tmpsv = newSVpvn_flags(name, len, is_utf8); 1415 STRLEN ulen; 1416 const char *proto = CvPROTO(cv); 1417 assert(proto); 1418 if (SvUTF8(cv)) 1419 sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2); 1420 ulen = SvCUR(tmpsv); 1421 SvCUR_set(tmpsv, SvCUR(tmpsv) + 1); /* include null in string */ 1422 sv_catpvn_flags( 1423 tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv) 1424 ); 1425 SvTEMP_on(tmpsv); /* Allow theft */ 1426 sv_setsv_nomg((SV *)cv, tmpsv); 1427 SvTEMP_off(tmpsv); 1428 SvREFCNT_dec_NN(tmpsv); 1429 SvLEN_set(cv, SvCUR(cv) + 1); 1430 SvCUR_set(cv, ulen); 1431 } 1432 else { 1433 sv_setpvn((SV *)cv, name, len); 1434 SvPOK_off(cv); 1435 if (is_utf8) 1436 SvUTF8_on(cv); 1437 else SvUTF8_off(cv); 1438 } 1439 CvAUTOLOAD_on(cv); 1440 } 1441 1442 /* 1443 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name. 1444 * The subroutine's original name may not be "AUTOLOAD", so we don't 1445 * use that, but for lack of anything better we will use the sub's 1446 * original package to look up $AUTOLOAD. 1447 */ 1448 varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv)); 1449 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE); 1450 ENTER; 1451 1452 if (!isGV(vargv)) { 1453 gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0); 1454 #ifdef PERL_DONT_CREATE_GVSV 1455 GvSV(vargv) = newSV_type(SVt_NULL); 1456 #endif 1457 } 1458 LEAVE; 1459 varsv = GvSVn(vargv); 1460 SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */ 1461 /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */ 1462 sv_setsv(varsv, packname); 1463 sv_catpvs(varsv, "::"); 1464 /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear 1465 tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */ 1466 sv_catpvn_flags( 1467 varsv, name, len, 1468 SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES) 1469 ); 1470 if (is_utf8) 1471 SvUTF8_on(varsv); 1472 return gv; 1473 } 1474 1475 1476 /* require_tie_mod() internal routine for requiring a module 1477 * that implements the logic of automatic ties like %! and %- 1478 * It loads the module and then calls the _tie_it subroutine 1479 * with the passed gv as an argument. 1480 * 1481 * The "gv" parameter should be the glob. 1482 * "varname" holds the 1-char name of the var, used for error messages. 1483 * "namesv" holds the module name. Its refcount will be decremented. 1484 * "flags": if flag & 1 then save the scalar before loading. 1485 * For the protection of $! to work (it is set by this routine) 1486 * the sv slot must already be magicalized. 1487 */ 1488 STATIC void 1489 S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name, 1490 STRLEN len, const U32 flags) 1491 { 1492 const SV * const target = varname == '[' ? GvSV(gv) : (SV *)GvHV(gv); 1493 1494 PERL_ARGS_ASSERT_REQUIRE_TIE_MOD; 1495 1496 /* If it is not tied */ 1497 if (!target || !SvRMAGICAL(target) 1498 || !mg_find(target, 1499 varname == '[' ? PERL_MAGIC_tiedscalar : PERL_MAGIC_tied)) 1500 { 1501 HV *stash; 1502 GV **gvp; 1503 dSP; 1504 1505 PUSHSTACKi(PERLSI_MAGIC); 1506 ENTER; 1507 1508 #define GET_HV_FETCH_TIE_FUNC \ 1509 ( (gvp = (GV **)hv_fetchs(stash, "_tie_it", 0)) \ 1510 && *gvp \ 1511 && ( (isGV(*gvp) && GvCV(*gvp)) \ 1512 || (SvROK(*gvp) && SvTYPE(SvRV(*gvp)) == SVt_PVCV) ) \ 1513 ) 1514 1515 /* Load the module if it is not loaded. */ 1516 if (!(stash = gv_stashpvn(name, len, 0)) 1517 || ! GET_HV_FETCH_TIE_FUNC) 1518 { 1519 SV * const module = newSVpvn(name, len); 1520 const char type = varname == '[' ? '$' : '%'; 1521 if ( flags & 1 ) 1522 save_scalar(gv); 1523 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL); 1524 assert(sp == PL_stack_sp); 1525 stash = gv_stashpvn(name, len, 0); 1526 if (!stash) 1527 Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available", 1528 type, varname, name); 1529 else if (! GET_HV_FETCH_TIE_FUNC) 1530 Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it", 1531 type, varname, name); 1532 } 1533 /* Now call the tie function. It should be in *gvp. */ 1534 assert(gvp); assert(*gvp); 1535 PUSHMARK(SP); 1536 XPUSHs((SV *)gv); 1537 PUTBACK; 1538 call_sv((SV *)*gvp, G_VOID|G_DISCARD); 1539 LEAVE; 1540 POPSTACK; 1541 } 1542 } 1543 1544 /* add a require_tie_mod_s - the _s suffix is similar to pvs type suffixes, 1545 * IOW it means we do STR_WITH_LEN() ourselves and the user should pass in 1546 * a true string WITHOUT a len. 1547 */ 1548 #define require_tie_mod_s(gv, varname, name, flags) \ 1549 S_require_tie_mod(aTHX_ gv, varname, STR_WITH_LEN(name), flags) 1550 1551 /* 1552 =for apidoc gv_stashpv 1553 1554 Returns a pointer to the stash for a specified package. Uses C<strlen> to 1555 determine the length of C<name>, then calls C<gv_stashpvn()>. 1556 1557 =cut 1558 */ 1559 1560 HV* 1561 Perl_gv_stashpv(pTHX_ const char *name, I32 create) 1562 { 1563 PERL_ARGS_ASSERT_GV_STASHPV; 1564 return gv_stashpvn(name, strlen(name), create); 1565 } 1566 1567 /* 1568 =for apidoc gv_stashpvn 1569 1570 Returns a pointer to the stash for a specified package. The C<namelen> 1571 parameter indicates the length of the C<name>, in bytes. C<flags> is passed 1572 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be 1573 created if it does not already exist. If the package does not exist and 1574 C<flags> is 0 (or any other setting that does not create packages) then C<NULL> 1575 is returned. 1576 1577 Flags may be one of: 1578 1579 GV_ADD Create and initialize the package if doesn't 1580 already exist 1581 GV_NOADD_NOINIT Don't create the package, 1582 GV_ADDMG GV_ADD iff the GV is magical 1583 GV_NOINIT GV_ADD, but don't initialize 1584 GV_NOEXPAND Don't expand SvOK() entries to PVGV 1585 SVf_UTF8 The name is in UTF-8 1586 1587 The most important of which are probably C<GV_ADD> and C<SVf_UTF8>. 1588 1589 Note, use of C<gv_stashsv> instead of C<gv_stashpvn> where possible is strongly 1590 recommended for performance reasons. 1591 1592 =for apidoc Amnh||GV_ADD 1593 =for apidoc Amnh||GV_NOADD_NOINIT 1594 =for apidoc Amnh||GV_NOINIT 1595 =for apidoc Amnh||GV_NOEXPAND 1596 =for apidoc Amnh||GV_ADDMG 1597 =for apidoc Amnh||SVf_UTF8 1598 1599 =cut 1600 */ 1601 1602 /* 1603 gv_stashpvn_internal 1604 1605 Perform the internal bits of gv_stashsvpvn_cached. You could think of this 1606 as being one half of the logic. Not to be called except from gv_stashsvpvn_cached(). 1607 1608 */ 1609 1610 PERL_STATIC_INLINE HV* 1611 S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags) 1612 { 1613 char smallbuf[128]; 1614 char *tmpbuf; 1615 HV *stash; 1616 GV *tmpgv; 1617 U32 tmplen = namelen + 2; 1618 1619 PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL; 1620 1621 if (tmplen <= sizeof smallbuf) 1622 tmpbuf = smallbuf; 1623 else 1624 Newx(tmpbuf, tmplen, char); 1625 Copy(name, tmpbuf, namelen, char); 1626 tmpbuf[namelen] = ':'; 1627 tmpbuf[namelen+1] = ':'; 1628 tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV); 1629 if (tmpbuf != smallbuf) 1630 Safefree(tmpbuf); 1631 if (!tmpgv || !isGV_with_GP(tmpgv)) 1632 return NULL; 1633 stash = GvHV(tmpgv); 1634 if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL; 1635 assert(stash); 1636 if (!HvHasNAME(stash)) { 1637 hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 ); 1638 1639 /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */ 1640 /* If the containing stash has multiple effective 1641 names, see that this one gets them, too. */ 1642 if (HvAUX(GvSTASH(tmpgv))->xhv_name_count) 1643 mro_package_moved(stash, NULL, tmpgv, 1); 1644 } 1645 return stash; 1646 } 1647 1648 /* 1649 =for apidoc gv_stashsvpvn_cached 1650 1651 Returns a pointer to the stash for a specified package, possibly 1652 cached. Implements both L<perlapi/C<gv_stashpvn>> and 1653 L<perlapi/C<gv_stashsv>>. 1654 1655 Requires one of either C<namesv> or C<namepv> to be non-null. 1656 1657 If the flag C<GV_CACHE_ONLY> is set, return the stash only if found in the 1658 cache; see L<perlapi/C<gv_stashpvn>> for details on the other C<flags>. 1659 1660 Note it is strongly preferred for C<namesv> to be non-null, for performance 1661 reasons. 1662 1663 =for apidoc Emnh||GV_CACHE_ONLY 1664 1665 =cut 1666 */ 1667 1668 #define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \ 1669 assert(namesv || name) 1670 1671 HV* 1672 Perl_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags) 1673 { 1674 HV* stash; 1675 HE* he; 1676 1677 PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED; 1678 1679 he = (HE *)hv_common( 1680 PL_stashcache, namesv, name, namelen, 1681 (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0 1682 ); 1683 1684 if (he) { 1685 SV *sv = HeVAL(he); 1686 HV *hv; 1687 assert(SvIOK(sv)); 1688 hv = INT2PTR(HV*, SvIVX(sv)); 1689 assert(SvTYPE(hv) == SVt_PVHV); 1690 return hv; 1691 } 1692 else if (flags & GV_CACHE_ONLY) return NULL; 1693 1694 if (namesv) { 1695 if (SvOK(namesv)) { /* prevent double uninit warning */ 1696 STRLEN len; 1697 name = SvPV_const(namesv, len); 1698 namelen = len; 1699 flags |= SvUTF8(namesv); 1700 } else { 1701 name = ""; namelen = 0; 1702 } 1703 } 1704 stash = gv_stashpvn_internal(name, namelen, flags); 1705 1706 if (stash && namelen) { 1707 SV* const ref = newSViv(PTR2IV(stash)); 1708 (void)hv_store(PL_stashcache, name, 1709 (flags & SVf_UTF8) ? -(I32)namelen : (I32)namelen, ref, 0); 1710 } 1711 1712 return stash; 1713 } 1714 1715 HV* 1716 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) 1717 { 1718 PERL_ARGS_ASSERT_GV_STASHPVN; 1719 return gv_stashsvpvn_cached(NULL, name, namelen, flags); 1720 } 1721 1722 /* 1723 =for apidoc gv_stashsv 1724 1725 Returns a pointer to the stash for a specified package. See 1726 C<L</gv_stashpvn>>. 1727 1728 Note this interface is strongly preferred over C<gv_stashpvn> for performance 1729 reasons. 1730 1731 =cut 1732 */ 1733 1734 HV* 1735 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags) 1736 { 1737 PERL_ARGS_ASSERT_GV_STASHSV; 1738 return gv_stashsvpvn_cached(sv, NULL, 0, flags); 1739 } 1740 GV * 1741 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 flags, const svtype sv_type) { 1742 PERL_ARGS_ASSERT_GV_FETCHPV; 1743 return gv_fetchpvn_flags(nambeg, strlen(nambeg), flags, sv_type); 1744 } 1745 1746 GV * 1747 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) { 1748 STRLEN len; 1749 const char * const nambeg = 1750 SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC); 1751 PERL_ARGS_ASSERT_GV_FETCHSV; 1752 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type); 1753 } 1754 1755 PERL_STATIC_INLINE void 1756 S_gv_magicalize_isa(pTHX_ GV *gv) 1757 { 1758 AV* av; 1759 1760 PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA; 1761 1762 av = GvAVn(gv); 1763 GvMULTI_on(gv); 1764 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa, 1765 NULL, 0); 1766 1767 if(HvSTASH_IS_CLASS(GvSTASH(gv))) { 1768 /* Don't permit modification of @ISA outside of the class management 1769 * code. This is temporarily undone by class.c when fiddling with the 1770 * array, so it knows it can be done safely. 1771 */ 1772 SvREADONLY_on((SV *)av); 1773 } 1774 } 1775 1776 /* This function grabs name and tries to split a stash and glob 1777 * from its contents. TODO better description, comments 1778 * 1779 * If the function returns TRUE and 'name == name_end', then 1780 * 'gv' can be directly returned to the caller of gv_fetchpvn_flags 1781 */ 1782 PERL_STATIC_INLINE bool 1783 S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, 1784 STRLEN *len, const char *nambeg, STRLEN full_len, 1785 const U32 is_utf8, const I32 add) 1786 { 1787 char *tmpfullbuf = NULL; /* only malloc one big chunk of memory when the smallbuff is not large enough */ 1788 const char *name_cursor; 1789 const char *const name_end = nambeg + full_len; 1790 const char *const name_em1 = name_end - 1; 1791 char smallbuf[64]; /* small buffer to avoid a malloc when possible */ 1792 1793 PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME; 1794 1795 if ( full_len > 2 1796 && **name == '*' 1797 && isIDFIRST_lazy_if_safe(*name + 1, name_end, is_utf8)) 1798 { 1799 /* accidental stringify on a GV? */ 1800 (*name)++; 1801 } 1802 1803 for (name_cursor = *name; name_cursor < name_end; name_cursor++) { 1804 if (name_cursor < name_em1 && 1805 ((*name_cursor == ':' && name_cursor[1] == ':') 1806 || *name_cursor == '\'')) 1807 { 1808 if (!*stash) 1809 *stash = PL_defstash; 1810 if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */ 1811 goto notok; 1812 1813 *len = name_cursor - *name; 1814 if (name_cursor > nambeg) { /* Skip for initial :: or ' */ 1815 const char *key; 1816 GV**gvp; 1817 if (*name_cursor == ':') { 1818 key = *name; 1819 *len += 2; 1820 } 1821 else { /* using ' for package separator */ 1822 /* use our pre-allocated buffer when possible to save a malloc */ 1823 char *tmpbuf; 1824 if ( *len+2 <= sizeof smallbuf) 1825 tmpbuf = smallbuf; 1826 else { 1827 /* only malloc once if needed */ 1828 if (tmpfullbuf == NULL) /* only malloc&free once, a little more than needed */ 1829 Newx(tmpfullbuf, full_len+2, char); 1830 tmpbuf = tmpfullbuf; 1831 } 1832 Copy(*name, tmpbuf, *len, char); 1833 tmpbuf[(*len)++] = ':'; 1834 tmpbuf[(*len)++] = ':'; 1835 key = tmpbuf; 1836 } 1837 gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add); 1838 *gv = gvp ? *gvp : NULL; 1839 if (!*gv || *gv == (const GV *)&PL_sv_undef) { 1840 goto notok; 1841 } 1842 /* here we know that *gv && *gv != &PL_sv_undef */ 1843 if (SvTYPE(*gv) != SVt_PVGV) 1844 gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8); 1845 else 1846 GvMULTI_on(*gv); 1847 1848 if (!(*stash = GvHV(*gv))) { 1849 *stash = GvHV(*gv) = newHV(); 1850 if (!HvHasNAME(*stash)) { 1851 if (GvSTASH(*gv) == PL_defstash && *len == 6 1852 && strBEGINs(*name, "CORE")) 1853 hv_name_sets(*stash, "CORE", 0); 1854 else 1855 hv_name_set( 1856 *stash, nambeg, name_cursor-nambeg, is_utf8 1857 ); 1858 /* If the containing stash has multiple effective 1859 names, see that this one gets them, too. */ 1860 if (HvAUX(GvSTASH(*gv))->xhv_name_count) 1861 mro_package_moved(*stash, NULL, *gv, 1); 1862 } 1863 } 1864 else if (!HvHasNAME(*stash)) 1865 hv_name_set(*stash, nambeg, name_cursor - nambeg, is_utf8); 1866 } 1867 1868 if (*name_cursor == ':') 1869 name_cursor++; 1870 *name = name_cursor+1; 1871 if (*name == name_end) { 1872 if (!*gv) { 1873 *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE)); 1874 if (SvTYPE(*gv) != SVt_PVGV) { 1875 gv_init_pvn(*gv, PL_defstash, "main::", 6, 1876 GV_ADDMULTI); 1877 GvHV(*gv) = 1878 MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash)); 1879 } 1880 } 1881 goto ok; 1882 } 1883 } 1884 } 1885 *len = name_cursor - *name; 1886 ok: 1887 Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */ 1888 return TRUE; 1889 notok: 1890 Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */ 1891 return FALSE; 1892 } 1893 1894 1895 /* Checks if an unqualified name is in the main stash */ 1896 PERL_STATIC_INLINE bool 1897 S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8) 1898 { 1899 PERL_ARGS_ASSERT_GV_IS_IN_MAIN; 1900 1901 /* If it's an alphanumeric variable */ 1902 if ( len && isIDFIRST_lazy_if_safe(name, name + len, is_utf8) ) { 1903 /* Some "normal" variables are always in main::, 1904 * like INC or STDOUT. 1905 */ 1906 switch (len) { 1907 case 1: 1908 if (*name == '_') 1909 return TRUE; 1910 break; 1911 case 3: 1912 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C') 1913 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V') 1914 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G')) 1915 return TRUE; 1916 break; 1917 case 4: 1918 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G' 1919 && name[3] == 'V') 1920 return TRUE; 1921 break; 1922 case 5: 1923 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D' 1924 && name[3] == 'I' && name[4] == 'N') 1925 return TRUE; 1926 break; 1927 case 6: 1928 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D') 1929 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T') 1930 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R'))) 1931 return TRUE; 1932 break; 1933 case 7: 1934 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G' 1935 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U' 1936 && name[6] == 'T') 1937 return TRUE; 1938 break; 1939 } 1940 } 1941 /* *{""}, or a special variable like $@ */ 1942 else 1943 return TRUE; 1944 1945 return FALSE; 1946 } 1947 1948 1949 /* This function is called if parse_gv_stash_name() failed to 1950 * find a stash, or if GV_NOTQUAL or an empty name was passed 1951 * to gv_fetchpvn_flags. 1952 * 1953 * It returns FALSE if the default stash can't be found nor created, 1954 * which might happen during global destruction. 1955 */ 1956 PERL_STATIC_INLINE bool 1957 S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len, 1958 const U32 is_utf8, const I32 add, 1959 const svtype sv_type) 1960 { 1961 PERL_ARGS_ASSERT_FIND_DEFAULT_STASH; 1962 1963 /* No stash in name, so see how we can default */ 1964 1965 if ( gv_is_in_main(name, len, is_utf8) ) { 1966 *stash = PL_defstash; 1967 } 1968 else { 1969 if (IN_PERL_COMPILETIME) { 1970 *stash = PL_curstash; 1971 if (add && (PL_hints & HINT_STRICT_VARS) && 1972 sv_type != SVt_PVCV && 1973 sv_type != SVt_PVGV && 1974 sv_type != SVt_PVFM && 1975 sv_type != SVt_PVIO && 1976 !(len == 1 && sv_type == SVt_PV && 1977 (*name == 'a' || *name == 'b')) ) 1978 { 1979 GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -(I32)len : (I32)len,0); 1980 if (!gvp || *gvp == (const GV *)&PL_sv_undef || 1981 SvTYPE(*gvp) != SVt_PVGV) 1982 { 1983 *stash = NULL; 1984 } 1985 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) || 1986 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) || 1987 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) ) 1988 { 1989 /* diag_listed_as: Variable "%s" is not imported%s */ 1990 Perl_ck_warner_d( 1991 aTHX_ packWARN(WARN_MISC), 1992 "Variable \"%c%" UTF8f "\" is not imported", 1993 sv_type == SVt_PVAV ? '@' : 1994 sv_type == SVt_PVHV ? '%' : '$', 1995 UTF8fARG(is_utf8, len, name)); 1996 if (GvCVu(*gvp)) 1997 Perl_ck_warner_d( 1998 aTHX_ packWARN(WARN_MISC), 1999 "\t(Did you mean &%" UTF8f " instead?)\n", 2000 UTF8fARG(is_utf8, len, name) 2001 ); 2002 *stash = NULL; 2003 } 2004 } 2005 } 2006 else { 2007 /* Use the current op's stash */ 2008 *stash = CopSTASH(PL_curcop); 2009 } 2010 } 2011 2012 if (!*stash) { 2013 if (add && !PL_in_clean_all) { 2014 GV *gv; 2015 qerror(Perl_mess(aTHX_ 2016 "Global symbol \"%s%" UTF8f 2017 "\" requires explicit package name (did you forget to " 2018 "declare \"my %s%" UTF8f "\"?)", 2019 (sv_type == SVt_PV ? "$" 2020 : sv_type == SVt_PVAV ? "@" 2021 : sv_type == SVt_PVHV ? "%" 2022 : ""), UTF8fARG(is_utf8, len, name), 2023 (sv_type == SVt_PV ? "$" 2024 : sv_type == SVt_PVAV ? "@" 2025 : sv_type == SVt_PVHV ? "%" 2026 : ""), UTF8fARG(is_utf8, len, name))); 2027 /* To maintain the output of errors after the strict exception 2028 * above, and to keep compat with older releases, rather than 2029 * placing the variables in the pad, we place 2030 * them in the <none>:: stash. 2031 */ 2032 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV); 2033 if (!gv) { 2034 /* symbol table under destruction */ 2035 return FALSE; 2036 } 2037 *stash = GvHV(gv); 2038 } 2039 else 2040 return FALSE; 2041 } 2042 2043 if (!SvREFCNT(*stash)) /* symbol table under destruction */ 2044 return FALSE; 2045 2046 return TRUE; 2047 } 2048 2049 /* gv_magicalize only turns on the SVf_READONLY flag, not SVf_PROTECT. So 2050 redefine SvREADONLY_on for that purpose. We don’t use it later on in 2051 this file. */ 2052 #undef SvREADONLY_on 2053 #define SvREADONLY_on(sv) (SvFLAGS(sv) |= SVf_READONLY) 2054 2055 /* gv_magicalize() is called by gv_fetchpvn_flags when creating 2056 * a new GV. 2057 * Note that it does not insert the GV into the stash prior to 2058 * magicalization, which some variables require need in order 2059 * to work (like %+, %-, %!), so callers must take care of 2060 * that. 2061 * 2062 * It returns true if the gv did turn out to be magical one; i.e., 2063 * if gv_magicalize actually did something. 2064 */ 2065 PERL_STATIC_INLINE bool 2066 S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, 2067 const svtype sv_type) 2068 { 2069 SSize_t paren; 2070 2071 PERL_ARGS_ASSERT_GV_MAGICALIZE; 2072 2073 if (stash != PL_defstash) { /* not the main stash */ 2074 /* We only have to check for a few names here: a, b, EXPORT, ISA 2075 and VERSION. All the others apply only to the main stash or to 2076 CORE (which is checked right after this). */ 2077 if (len) { 2078 switch (*name) { 2079 case 'E': 2080 if ( 2081 len >= 6 && name[1] == 'X' && 2082 (memEQs(name, len, "EXPORT") 2083 ||memEQs(name, len, "EXPORT_OK") 2084 ||memEQs(name, len, "EXPORT_FAIL") 2085 ||memEQs(name, len, "EXPORT_TAGS")) 2086 ) 2087 GvMULTI_on(gv); 2088 break; 2089 case 'I': 2090 if (memEQs(name, len, "ISA")) 2091 gv_magicalize_isa(gv); 2092 break; 2093 case 'V': 2094 if (memEQs(name, len, "VERSION")) 2095 GvMULTI_on(gv); 2096 break; 2097 case 'a': 2098 if (stash == PL_debstash && memEQs(name, len, "args")) { 2099 GvMULTI_on(gv_AVadd(gv)); 2100 break; 2101 } 2102 /* FALLTHROUGH */ 2103 case 'b': 2104 if (len == 1 && sv_type == SVt_PV) 2105 GvMULTI_on(gv); 2106 /* FALLTHROUGH */ 2107 default: 2108 goto try_core; 2109 } 2110 goto ret; 2111 } 2112 try_core: 2113 if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) { 2114 /* Avoid null warning: */ 2115 const char * const stashname = HvNAME(stash); assert(stashname); 2116 if (strBEGINs(stashname, "CORE")) 2117 S_maybe_add_coresub(aTHX_ 0, gv, name, len); 2118 } 2119 } 2120 else if (len > 1) { 2121 #ifndef EBCDIC 2122 if (*name > 'V' ) { 2123 NOOP; 2124 /* Nothing else to do. 2125 The compiler will probably turn the switch statement into a 2126 branch table. Make sure we avoid even that small overhead for 2127 the common case of lower case variable names. (On EBCDIC 2128 platforms, we can't just do: 2129 if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) { 2130 because cases like '\027' in the switch statement below are 2131 C1 (non-ASCII) controls on those platforms, so the remapping 2132 would make them larger than 'V') 2133 */ 2134 } else 2135 #endif 2136 { 2137 switch (*name) { 2138 case 'A': 2139 if (memEQs(name, len, "ARGV")) { 2140 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; 2141 } 2142 else if (memEQs(name, len, "ARGVOUT")) { 2143 GvMULTI_on(gv); 2144 } 2145 break; 2146 case 'E': 2147 if ( 2148 len >= 6 && name[1] == 'X' && 2149 (memEQs(name, len, "EXPORT") 2150 ||memEQs(name, len, "EXPORT_OK") 2151 ||memEQs(name, len, "EXPORT_FAIL") 2152 ||memEQs(name, len, "EXPORT_TAGS")) 2153 ) 2154 GvMULTI_on(gv); 2155 break; 2156 case 'I': 2157 if (memEQs(name, len, "ISA")) { 2158 gv_magicalize_isa(gv); 2159 } 2160 break; 2161 case 'S': 2162 if (memEQs(name, len, "SIG")) { 2163 HV *hv; 2164 I32 i; 2165 if (!PL_psig_name) { 2166 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*); 2167 Newxz(PL_psig_pend, SIG_SIZE, int); 2168 PL_psig_ptr = PL_psig_name + SIG_SIZE; 2169 } else { 2170 /* I think that the only way to get here is to re-use an 2171 embedded perl interpreter, where the previous 2172 use didn't clean up fully because 2173 PL_perl_destruct_level was 0. I'm not sure that we 2174 "support" that, in that I suspect in that scenario 2175 there are sufficient other garbage values left in the 2176 interpreter structure that something else will crash 2177 before we get here. I suspect that this is one of 2178 those "doctor, it hurts when I do this" bugs. */ 2179 Zero(PL_psig_name, 2 * SIG_SIZE, SV*); 2180 Zero(PL_psig_pend, SIG_SIZE, int); 2181 } 2182 GvMULTI_on(gv); 2183 hv = GvHVn(gv); 2184 hv_magic(hv, NULL, PERL_MAGIC_sig); 2185 for (i = 1; i < SIG_SIZE; i++) { 2186 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1); 2187 if (init) 2188 sv_setsv(*init, &PL_sv_undef); 2189 } 2190 } 2191 break; 2192 case 'V': 2193 if (memEQs(name, len, "VERSION")) 2194 GvMULTI_on(gv); 2195 break; 2196 case '\003': /* $^CHILD_ERROR_NATIVE */ 2197 if (memEQs(name, len, "\003HILD_ERROR_NATIVE")) 2198 goto magicalize; 2199 /* @{^CAPTURE} %{^CAPTURE} */ 2200 if (memEQs(name, len, "\003APTURE")) { 2201 AV* const av = GvAVn(gv); 2202 const Size_t n = *name; 2203 2204 sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0); 2205 SvREADONLY_on(av); 2206 2207 require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0); 2208 2209 } else /* %{^CAPTURE_ALL} */ 2210 if (memEQs(name, len, "\003APTURE_ALL")) { 2211 require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0); 2212 } 2213 break; 2214 case '\005': /* ${^ENCODING} */ 2215 if (memEQs(name, len, "\005NCODING")) 2216 goto magicalize; 2217 break; 2218 case '\007': /* ${^GLOBAL_PHASE} */ 2219 if (memEQs(name, len, "\007LOBAL_PHASE")) 2220 goto ro_magicalize; 2221 break; 2222 case '\010': /* %{^HOOK} */ 2223 if (memEQs(name, len, "\010OOK")) { 2224 GvMULTI_on(gv); 2225 HV *hv = GvHVn(gv); 2226 hv_magic(hv, NULL, PERL_MAGIC_hook); 2227 } 2228 break; 2229 case '\014': 2230 if ( memEQs(name, len, "\014AST_FH") || /* ${^LAST_FH} */ 2231 memEQs(name, len, "\014AST_SUCCESSFUL_PATTERN")) /* ${^LAST_SUCCESSFUL_PATTERN} */ 2232 goto ro_magicalize; 2233 break; 2234 case '\015': /* ${^MATCH} */ 2235 if (memEQs(name, len, "\015ATCH")) { 2236 paren = RX_BUFF_IDX_CARET_FULLMATCH; 2237 goto storeparen; 2238 } 2239 break; 2240 case '\017': /* ${^OPEN} */ 2241 if (memEQs(name, len, "\017PEN")) 2242 goto magicalize; 2243 break; 2244 case '\020': /* ${^PREMATCH} ${^POSTMATCH} */ 2245 if (memEQs(name, len, "\020REMATCH")) { 2246 paren = RX_BUFF_IDX_CARET_PREMATCH; 2247 goto storeparen; 2248 } 2249 if (memEQs(name, len, "\020OSTMATCH")) { 2250 paren = RX_BUFF_IDX_CARET_POSTMATCH; 2251 goto storeparen; 2252 } 2253 break; 2254 case '\023': 2255 if (memEQs(name, len, "\023AFE_LOCALES")) 2256 goto ro_magicalize; 2257 break; 2258 case '\024': /* ${^TAINT} */ 2259 if (memEQs(name, len, "\024AINT")) 2260 goto ro_magicalize; 2261 break; 2262 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */ 2263 if (memEQs(name, len, "\025NICODE")) 2264 goto ro_magicalize; 2265 if (memEQs(name, len, "\025TF8LOCALE")) 2266 goto ro_magicalize; 2267 if (memEQs(name, len, "\025TF8CACHE")) 2268 goto magicalize; 2269 break; 2270 case '\027': /* $^WARNING_BITS */ 2271 if (memEQs(name, len, "\027ARNING_BITS")) 2272 goto magicalize; 2273 #ifdef WIN32 2274 else if (memEQs(name, len, "\027IN32_SLOPPY_STAT")) 2275 goto magicalize; 2276 #endif 2277 break; 2278 case '1': 2279 case '2': 2280 case '3': 2281 case '4': 2282 case '5': 2283 case '6': 2284 case '7': 2285 case '8': 2286 case '9': 2287 { 2288 /* Ensures that we have an all-digit variable, ${"1foo"} fails 2289 this test */ 2290 UV uv; 2291 if (!grok_atoUV(name, &uv, NULL) || uv > I32_MAX) 2292 goto ret; 2293 /* XXX why are we using a SSize_t? */ 2294 paren = (SSize_t)(I32)uv; 2295 goto storeparen; 2296 } 2297 } 2298 } 2299 } else { 2300 /* Names of length 1. (Or 0. But name is NUL terminated, so that will 2301 be case '\0' in this switch statement (ie a default case) */ 2302 switch (*name) { 2303 case '&': /* $& */ 2304 paren = RX_BUFF_IDX_FULLMATCH; 2305 goto sawampersand; 2306 case '`': /* $` */ 2307 paren = RX_BUFF_IDX_PREMATCH; 2308 goto sawampersand; 2309 case '\'': /* $' */ 2310 paren = RX_BUFF_IDX_POSTMATCH; 2311 sawampersand: 2312 #ifdef PERL_SAWAMPERSAND 2313 if (!( 2314 sv_type == SVt_PVAV || 2315 sv_type == SVt_PVHV || 2316 sv_type == SVt_PVCV || 2317 sv_type == SVt_PVFM || 2318 sv_type == SVt_PVIO 2319 )) { PL_sawampersand |= 2320 (*name == '`') 2321 ? SAWAMPERSAND_LEFT 2322 : (*name == '&') 2323 ? SAWAMPERSAND_MIDDLE 2324 : SAWAMPERSAND_RIGHT; 2325 } 2326 #endif 2327 goto storeparen; 2328 case '1': /* $1 */ 2329 case '2': /* $2 */ 2330 case '3': /* $3 */ 2331 case '4': /* $4 */ 2332 case '5': /* $5 */ 2333 case '6': /* $6 */ 2334 case '7': /* $7 */ 2335 case '8': /* $8 */ 2336 case '9': /* $9 */ 2337 paren = *name - '0'; 2338 2339 storeparen: 2340 /* Flag the capture variables with a NULL mg_ptr 2341 Use mg_len for the array index to lookup. */ 2342 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren); 2343 break; 2344 2345 case ':': /* $: */ 2346 sv_setpv(GvSVn(gv),PL_chopset); 2347 goto magicalize; 2348 2349 case '?': /* $? */ 2350 #ifdef COMPLEX_STATUS 2351 SvUPGRADE(GvSVn(gv), SVt_PVLV); 2352 #endif 2353 goto magicalize; 2354 2355 case '!': /* $! */ 2356 GvMULTI_on(gv); 2357 /* If %! has been used, automatically load Errno.pm. */ 2358 2359 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); 2360 2361 /* magicalization must be done before require_tie_mod_s is called */ 2362 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) 2363 require_tie_mod_s(gv, '!', "Errno", 1); 2364 2365 break; 2366 case '-': /* $-, %-, @- */ 2367 case '+': /* $+, %+, @+ */ 2368 GvMULTI_on(gv); /* no used once warnings here */ 2369 { /* $- $+ */ 2370 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); 2371 if (*name == '+') 2372 SvREADONLY_on(GvSVn(gv)); 2373 } 2374 { /* %- %+ */ 2375 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) 2376 require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture",0); 2377 } 2378 { /* @- @+ */ 2379 AV* const av = GvAVn(gv); 2380 const Size_t n = *name; 2381 2382 sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0); 2383 SvREADONLY_on(av); 2384 } 2385 break; 2386 case '*': /* $* */ 2387 case '#': /* $# */ 2388 if (sv_type == SVt_PV) 2389 /* diag_listed_as: $* is no longer supported as of Perl 5.30 */ 2390 Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name); 2391 break; 2392 case '\010': /* $^H */ 2393 { 2394 HV *const hv = GvHVn(gv); 2395 hv_magic(hv, NULL, PERL_MAGIC_hints); 2396 } 2397 goto magicalize; 2398 case '\023': /* $^S */ 2399 ro_magicalize: 2400 SvREADONLY_on(GvSVn(gv)); 2401 /* FALLTHROUGH */ 2402 case '0': /* $0 */ 2403 case '^': /* $^ */ 2404 case '~': /* $~ */ 2405 case '=': /* $= */ 2406 case '%': /* $% */ 2407 case '.': /* $. */ 2408 case '(': /* $( */ 2409 case ')': /* $) */ 2410 case '<': /* $< */ 2411 case '>': /* $> */ 2412 case '\\': /* $\ */ 2413 case '/': /* $/ */ 2414 case '|': /* $| */ 2415 case '$': /* $$ */ 2416 case '[': /* $[ */ 2417 case '\001': /* $^A */ 2418 case '\003': /* $^C */ 2419 case '\004': /* $^D */ 2420 case '\005': /* $^E */ 2421 case '\006': /* $^F */ 2422 case '\011': /* $^I, NOT \t in EBCDIC */ 2423 case '\016': /* $^N */ 2424 case '\017': /* $^O */ 2425 case '\020': /* $^P */ 2426 case '\024': /* $^T */ 2427 case '\027': /* $^W */ 2428 magicalize: 2429 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); 2430 break; 2431 2432 case '\014': /* $^L */ 2433 sv_setpvs(GvSVn(gv),"\f"); 2434 break; 2435 case ';': /* $; */ 2436 sv_setpvs(GvSVn(gv),"\034"); 2437 break; 2438 case ']': /* $] */ 2439 { 2440 SV * const sv = GvSV(gv); 2441 if (!sv_derived_from(PL_patchlevel, "version")) 2442 upg_version(PL_patchlevel, TRUE); 2443 GvSV(gv) = vnumify(PL_patchlevel); 2444 SvREADONLY_on(GvSV(gv)); 2445 SvREFCNT_dec(sv); 2446 } 2447 break; 2448 case '\026': /* $^V */ 2449 { 2450 SV * const sv = GvSV(gv); 2451 GvSV(gv) = new_version(PL_patchlevel); 2452 SvREADONLY_on(GvSV(gv)); 2453 SvREFCNT_dec(sv); 2454 } 2455 break; 2456 case 'a': 2457 case 'b': 2458 if (sv_type == SVt_PV) 2459 GvMULTI_on(gv); 2460 } 2461 } 2462 2463 ret: 2464 /* Return true if we actually did something. */ 2465 return GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) 2466 || ( GvSV(gv) && ( 2467 SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)) 2468 ) 2469 ); 2470 } 2471 2472 /* If we do ever start using this later on in the file, we need to make 2473 sure we don’t accidentally use the wrong definition. */ 2474 #undef SvREADONLY_on 2475 2476 /* This function is called when the stash already holds the GV of the magic 2477 * variable we're looking for, but we need to check that it has the correct 2478 * kind of magic. For example, if someone first uses $! and then %!, the 2479 * latter would end up here, and we add the Errno tie to the HASH slot of 2480 * the *! glob. 2481 */ 2482 PERL_STATIC_INLINE void 2483 S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type) 2484 { 2485 PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV; 2486 2487 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) { 2488 if (*name == '!') 2489 require_tie_mod_s(gv, '!', "Errno", 1); 2490 else if (*name == '-' || *name == '+') 2491 require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture", 0); 2492 } else if (sv_type == SVt_PV) { 2493 if (*name == '*' || *name == '#') { 2494 /* diag_listed_as: $* is no longer supported as of Perl 5.30 */ 2495 Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name); 2496 } 2497 } 2498 if (sv_type==SVt_PV || sv_type==SVt_PVGV) { 2499 switch (*name) { 2500 #ifdef PERL_SAWAMPERSAND 2501 case '`': 2502 PL_sawampersand |= SAWAMPERSAND_LEFT; 2503 (void)GvSVn(gv); 2504 break; 2505 case '&': 2506 PL_sawampersand |= SAWAMPERSAND_MIDDLE; 2507 (void)GvSVn(gv); 2508 break; 2509 case '\'': 2510 PL_sawampersand |= SAWAMPERSAND_RIGHT; 2511 (void)GvSVn(gv); 2512 break; 2513 #endif 2514 } 2515 } 2516 } 2517 2518 /* 2519 =for apidoc gv_fetchpv 2520 =for apidoc_item |GV *|gv_fetchpvn|const char * nambeg|STRLEN full_len|I32 flags|const svtype sv_type 2521 =for apidoc_item ||gv_fetchpvn_flags 2522 =for apidoc_item |GV *|gv_fetchpvs|"name"|I32 flags|const svtype sv_type 2523 =for apidoc_item ||gv_fetchsv 2524 =for apidoc_item |GV *|gv_fetchsv_nomg|SV *name|I32 flags|const svtype sv_type 2525 2526 These all return the GV of type C<sv_type> whose name is given by the inputs, 2527 or NULL if no GV of that name and type could be found. See L<perlguts/Stashes 2528 and Globs>. 2529 2530 The only differences are how the input name is specified, and if 'get' magic is 2531 normally used in getting that name. 2532 2533 Don't be fooled by the fact that only one form has C<flags> in its name. They 2534 all have a C<flags> parameter in fact, and all the flag bits have the same 2535 meanings for all 2536 2537 If any of the flags C<GV_ADD>, C<GV_ADDMG>, C<GV_ADDWARN>, C<GV_ADDMULTI>, or 2538 C<GV_NOINIT> is set, a GV is created if none already exists for the input name 2539 and type. However, C<GV_ADDMG> will only do the creation for magical GV's. 2540 For all of these flags except C<GV_NOINIT>, C<L</gv_init_pvn>> is called after 2541 the addition. C<GV_ADDWARN> is used when the caller expects that adding won't 2542 be necessary because the symbol should already exist; but if not, add it 2543 anyway, with a warning that it was unexpectedly absent. The C<GV_ADDMULTI> 2544 flag means to pretend that the GV has been seen before (I<i.e.>, suppress "Used 2545 once" warnings). 2546 2547 The flag C<GV_NOADD_NOINIT> causes C<L</gv_init_pvn>> not be to called if the 2548 GV existed but isn't PVGV. 2549 2550 If the C<SVf_UTF8> bit is set, the name is treated as being encoded in UTF-8; 2551 otherwise the name won't be considered to be UTF-8 in the C<pv>-named forms, 2552 and the UTF-8ness of the underlying SVs will be used in the C<sv> forms. 2553 2554 If the flag C<GV_NOTQUAL> is set, the caller warrants that the input name is a 2555 plain symbol name, not qualified with a package, otherwise the name is checked 2556 for being a qualified one. 2557 2558 In C<gv_fetchpv>, C<nambeg> is a C string, NUL-terminated with no intermediate 2559 NULs. 2560 2561 In C<gv_fetchpvs>, C<name> is a literal C string, hence is enclosed in 2562 double quotes. 2563 2564 C<gv_fetchpvn> and C<gv_fetchpvn_flags> are identical. In these, <nambeg> is 2565 a Perl string whose byte length is given by C<full_len>, and may contain 2566 embedded NULs. 2567 2568 In C<gv_fetchsv> and C<gv_fetchsv_nomg>, the name is extracted from the PV of 2569 the input C<name> SV. The only difference between these two forms is that 2570 'get' magic is normally done on C<name> in C<gv_fetchsv>, and always skipped 2571 with C<gv_fetchsv_nomg>. Including C<GV_NO_SVGMAGIC> in the C<flags> parameter 2572 to C<gv_fetchsv> makes it behave identically to C<gv_fetchsv_nomg>. 2573 2574 =for apidoc Amnh||GV_ADD 2575 =for apidoc Amnh||GV_ADDMG 2576 =for apidoc Amnh||GV_ADDMULTI 2577 =for apidoc Amnh||GV_ADDWARN 2578 =for apidoc Amnh||GV_NOINIT 2579 =for apidoc Amnh||GV_NOADD_NOINIT 2580 =for apidoc Amnh||GV_NOTQUAL 2581 =for apidoc Amnh||GV_NO_SVGMAGIC 2582 =for apidoc Amnh||SVf_UTF8 2583 2584 =cut 2585 */ 2586 2587 GV * 2588 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, 2589 const svtype sv_type) 2590 { 2591 const char *name = nambeg; 2592 GV *gv = NULL; 2593 GV**gvp; 2594 STRLEN len; 2595 HV *stash = NULL; 2596 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT); 2597 const I32 no_expand = flags & GV_NOEXPAND; 2598 const I32 add = flags & ~GV_NOADD_MASK; 2599 const U32 is_utf8 = flags & SVf_UTF8; 2600 bool addmg = cBOOL(flags & GV_ADDMG); 2601 const char *const name_end = nambeg + full_len; 2602 U32 faking_it; 2603 2604 PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS; 2605 2606 /* If we have GV_NOTQUAL, the caller promised that 2607 * there is no stash, so we can skip the check. 2608 * Similarly if full_len is 0, since then we're 2609 * dealing with something like *{""} or ""->foo() 2610 */ 2611 if ((flags & GV_NOTQUAL) || !full_len) { 2612 len = full_len; 2613 } 2614 else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) { 2615 if (name == name_end) return gv; 2616 } 2617 else { 2618 return NULL; 2619 } 2620 2621 if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) { 2622 return NULL; 2623 } 2624 2625 /* By this point we should have a stash and a name */ 2626 gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add); 2627 if (!gvp || *gvp == (const GV *)&PL_sv_undef) { 2628 if (addmg) gv = (GV *)newSV_type(SVt_NULL); /* tentatively */ 2629 else return NULL; 2630 } 2631 else gv = *gvp, addmg = 0; 2632 /* From this point on, addmg means gv has not been inserted in the 2633 symtab yet. */ 2634 2635 if (SvTYPE(gv) == SVt_PVGV) { 2636 /* The GV already exists, so return it, but check if we need to do 2637 * anything else with it before that. 2638 */ 2639 if (add) { 2640 /* This is the heuristic that handles if a variable triggers the 2641 * 'used only once' warning. If there's already a GV in the stash 2642 * with this name, then we assume that the variable has been used 2643 * before and turn its MULTI flag on. 2644 * It's a heuristic because it can easily be "tricked", like with 2645 * BEGIN { $a = 1; $::{foo} = *a }; () = $foo 2646 * not warning about $main::foo being used just once 2647 */ 2648 GvMULTI_on(gv); 2649 gv_init_svtype(gv, sv_type); 2650 /* You reach this path once the typeglob has already been created, 2651 either by the same or a different sigil. If this path didn't 2652 exist, then (say) referencing $! first, and %! second would 2653 mean that %! was not handled correctly. */ 2654 if (len == 1 && stash == PL_defstash) { 2655 maybe_multimagic_gv(gv, name, sv_type); 2656 } 2657 else if (sv_type == SVt_PVAV 2658 && memEQs(name, len, "ISA") 2659 && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv)))) 2660 gv_magicalize_isa(gv); 2661 } 2662 return gv; 2663 } else if (no_init) { 2664 assert(!addmg); 2665 return gv; 2666 } 2667 /* If GV_NOEXPAND is true and what we got off the stash is a ref, 2668 * don't expand it to a glob. This is an optimization so that things 2669 * copying constants over, like Exporter, don't have to be rewritten 2670 * to take into account that you can store more than just globs in 2671 * stashes. 2672 */ 2673 else if (no_expand && SvROK(gv)) { 2674 assert(!addmg); 2675 return gv; 2676 } 2677 2678 /* Adding a new symbol. 2679 Unless of course there was already something non-GV here, in which case 2680 we want to behave as if there was always a GV here, containing some sort 2681 of subroutine. 2682 Otherwise we run the risk of creating things like GvIO, which can cause 2683 subtle bugs. eg the one that tripped up SQL::Translator */ 2684 2685 faking_it = SvOK(gv); 2686 2687 if (add & GV_ADDWARN) 2688 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), 2689 "Had to create %" UTF8f " unexpectedly", 2690 UTF8fARG(is_utf8, name_end-nambeg, nambeg)); 2691 gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8); 2692 2693 if ( full_len != 0 2694 && isIDFIRST_lazy_if_safe(name, name + full_len, is_utf8) 2695 && !ckWARN(WARN_ONCE) ) 2696 { 2697 GvMULTI_on(gv) ; 2698 } 2699 2700 /* set up magic where warranted */ 2701 if ( gv_magicalize(gv, stash, name, len, sv_type) ) { 2702 /* See 23496c6 */ 2703 if (addmg) { 2704 /* gv_magicalize magicalised this gv, so we want it 2705 * stored in the symtab. 2706 * Effectively the caller is asking, ‘Does this gv exist?’ 2707 * And we respond, ‘Er, *now* it does!’ 2708 */ 2709 (void)hv_store(stash,name,len,(SV *)gv,0); 2710 } 2711 } 2712 else if (addmg) { 2713 /* The temporary GV created above */ 2714 SvREFCNT_dec_NN(gv); 2715 gv = NULL; 2716 } 2717 2718 if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type); 2719 return gv; 2720 } 2721 2722 /* 2723 =for apidoc gv_efullname3 2724 =for apidoc_item gv_efullname4 2725 =for apidoc_item gv_fullname3 2726 =for apidoc_item gv_fullname4 2727 2728 Place the full package name of C<gv> into C<sv>. The C<gv_e*> forms return 2729 instead the effective package name (see L</HvENAME>). 2730 2731 If C<prefix> is non-NULL, it is considered to be a C language NUL-terminated 2732 string, and the stored name will be prefaced with it. 2733 2734 The other difference between the functions is that the C<*4> forms have an 2735 extra parameter, C<keepmain>. If C<true> an initial C<main::> in the name is 2736 kept; if C<false> it is stripped. With the C<*3> forms, it is always kept. 2737 2738 =cut 2739 */ 2740 2741 void 2742 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) 2743 { 2744 const char *name; 2745 const HV * const hv = GvSTASH(gv); 2746 2747 PERL_ARGS_ASSERT_GV_FULLNAME4; 2748 2749 sv_setpv(sv, prefix ? prefix : ""); 2750 2751 if (hv && (name = HvNAME(hv))) { 2752 const STRLEN len = HvNAMELEN(hv); 2753 if (keepmain || ! memBEGINs(name, len, "main")) { 2754 sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES); 2755 sv_catpvs(sv,"::"); 2756 } 2757 } 2758 else sv_catpvs(sv,"__ANON__::"); 2759 sv_catsv(sv,newSVhek_mortal(GvNAME_HEK(gv))); 2760 } 2761 2762 void 2763 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) 2764 { 2765 const GV * const egv = GvEGVx(gv); 2766 2767 PERL_ARGS_ASSERT_GV_EFULLNAME4; 2768 2769 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain); 2770 } 2771 2772 2773 /* recursively scan a stash and any nested stashes looking for entries 2774 * that need the "only used once" warning raised 2775 */ 2776 2777 void 2778 Perl_gv_check(pTHX_ HV *stash) 2779 { 2780 I32 i; 2781 2782 PERL_ARGS_ASSERT_GV_CHECK; 2783 2784 if (!HvHasAUX(stash)) 2785 return; 2786 2787 assert(HvARRAY(stash)); 2788 2789 /* mark stash is being scanned, to avoid recursing */ 2790 HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH; 2791 for (i = 0; i <= (I32) HvMAX(stash); i++) { 2792 const HE *entry; 2793 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { 2794 GV *gv; 2795 HV *hv; 2796 STRLEN keylen = HeKLEN(entry); 2797 const char * const key = HeKEY(entry); 2798 2799 if (keylen >= 2 && key[keylen-2] == ':' && key[keylen-1] == ':' && 2800 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv))) 2801 { 2802 if (hv != PL_defstash && hv != stash 2803 && !(HvHasAUX(hv) 2804 && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH)) 2805 ) 2806 gv_check(hv); /* nested package */ 2807 } 2808 else if ( HeKLEN(entry) != 0 2809 && *HeKEY(entry) != '_' 2810 && isIDFIRST_lazy_if_safe(HeKEY(entry), 2811 HeKEY(entry) + HeKLEN(entry), 2812 HeUTF8(entry)) ) 2813 { 2814 const char *file; 2815 gv = MUTABLE_GV(HeVAL(entry)); 2816 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) 2817 continue; 2818 file = GvFILE(gv); 2819 assert(PL_curcop == &PL_compiling); 2820 CopLINE_set(PL_curcop, GvLINE(gv)); 2821 #ifdef USE_ITHREADS 2822 SAVECOPFILE_FREE(PL_curcop); 2823 CopFILE_set(PL_curcop, (char *)file); /* set for warning */ 2824 #else 2825 CopFILEGV(PL_curcop) 2826 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0); 2827 #endif 2828 Perl_warner(aTHX_ packWARN(WARN_ONCE), 2829 "Name \"%" HEKf "::%" HEKf 2830 "\" used only once: possible typo", 2831 HEKfARG(HvNAME_HEK(stash)), 2832 HEKfARG(GvNAME_HEK(gv))); 2833 } 2834 } 2835 } 2836 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH; 2837 } 2838 2839 /* 2840 =for apidoc newGVgen 2841 =for apidoc_item newGVgen_flags 2842 2843 Create a new, guaranteed to be unique, GV in the package given by the 2844 NUL-terminated C language string C<pack>, and return a pointer to it. 2845 2846 For C<newGVgen> or if C<flags> in C<newGVgen_flags> is 0, C<pack> is to be 2847 considered to be encoded in Latin-1. The only other legal C<flags> value is 2848 C<SVf_UTF8>, which indicates C<pack> is to be considered to be encoded in 2849 UTF-8. 2850 2851 =cut 2852 */ 2853 2854 GV * 2855 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags) 2856 { 2857 PERL_ARGS_ASSERT_NEWGVGEN_FLAGS; 2858 assert(!(flags & ~SVf_UTF8)); 2859 2860 return gv_fetchpv(Perl_form(aTHX_ "%" UTF8f "::_GEN_%ld", 2861 UTF8fARG(flags, strlen(pack), pack), 2862 (long)PL_gensym++), 2863 GV_ADD, SVt_PVGV); 2864 } 2865 2866 /* hopefully this is only called on local symbol table entries */ 2867 2868 GP* 2869 Perl_gp_ref(pTHX_ GP *gp) 2870 { 2871 if (!gp) 2872 return NULL; 2873 gp->gp_refcnt++; 2874 if (gp->gp_cv) { 2875 if (gp->gp_cvgen) { 2876 /* If the GP they asked for a reference to contains 2877 a method cache entry, clear it first, so that we 2878 don't infect them with our cached entry */ 2879 SvREFCNT_dec_NN(gp->gp_cv); 2880 gp->gp_cv = NULL; 2881 gp->gp_cvgen = 0; 2882 } 2883 } 2884 return gp; 2885 } 2886 2887 void 2888 Perl_gp_free(pTHX_ GV *gv) 2889 { 2890 GP* gp; 2891 int attempts = 100; 2892 bool in_global_destruction = PL_phase == PERL_PHASE_DESTRUCT; 2893 2894 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv))) 2895 return; 2896 if (gp->gp_refcnt == 0) { 2897 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), 2898 "Attempt to free unreferenced glob pointers" 2899 pTHX__FORMAT pTHX__VALUE); 2900 return; 2901 } 2902 if (gp->gp_refcnt > 1) { 2903 borrowed: 2904 if (gp->gp_egv == gv) 2905 gp->gp_egv = 0; 2906 gp->gp_refcnt--; 2907 GvGP_set(gv, NULL); 2908 return; 2909 } 2910 2911 while (1) { 2912 /* Copy and null out all the glob slots, so destructors do not see 2913 freed SVs. */ 2914 HEK * const file_hek = gp->gp_file_hek; 2915 SV * sv = gp->gp_sv; 2916 AV * av = gp->gp_av; 2917 HV * hv = gp->gp_hv; 2918 IO * io = gp->gp_io; 2919 CV * cv = gp->gp_cv; 2920 CV * form = gp->gp_form; 2921 2922 int need = 0; 2923 2924 gp->gp_file_hek = NULL; 2925 gp->gp_sv = NULL; 2926 gp->gp_av = NULL; 2927 gp->gp_hv = NULL; 2928 gp->gp_io = NULL; 2929 gp->gp_cv = NULL; 2930 gp->gp_form = NULL; 2931 2932 if (file_hek) 2933 unshare_hek(file_hek); 2934 2935 /* Storing the SV on the temps stack (instead of freeing it immediately) 2936 is an admitted bodge that attempt to compensate for the lack of 2937 reference counting on the stack. The motivation is that typeglob syntax 2938 is extremely short hence programs such as '$a += (*a = 2)' are often 2939 found randomly by researchers running fuzzers. Previously these 2940 programs would trigger errors, that the researchers would 2941 (legitimately) report, and then we would spend time figuring out that 2942 the cause was "stack not reference counted" and so not a dangerous 2943 security hole. This consumed a lot of researcher time, our time, and 2944 prevents "interesting" security holes being uncovered. 2945 2946 Typeglob assignment is rarely used in performance critical production 2947 code, so we aren't causing much slowdown by doing extra work here. 2948 2949 In turn, the need to check for SvOBJECT (and references to objects) is 2950 because we have regression tests that rely on timely destruction that 2951 happens *within this while loop* to demonstrate behaviour, and 2952 potentially there is also *working* code in the wild that relies on 2953 such behaviour. 2954 2955 And we need to avoid doing this in global destruction else we can end 2956 up with "Attempt to free temp prematurely ... Unbalanced string table 2957 refcount". 2958 2959 Hence the whole thing is a heuristic intended to mitigate against 2960 simple problems likely found by fuzzers but never written by humans, 2961 whilst leaving working code unchanged. */ 2962 if (sv) { 2963 SV *referent; 2964 if (SvREFCNT(sv) > 1 || SvOBJECT(sv) || UNLIKELY(in_global_destruction)) { 2965 SvREFCNT_dec_NN(sv); 2966 sv = NULL; 2967 } else if (SvROK(sv) && (referent = SvRV(sv)) 2968 && (SvREFCNT(referent) > 1 || SvOBJECT(referent))) { 2969 SvREFCNT_dec_NN(sv); 2970 sv = NULL; 2971 } else { 2972 ++need; 2973 } 2974 } 2975 if (av) { 2976 if (SvREFCNT(av) > 1 || SvOBJECT(av) || UNLIKELY(in_global_destruction)) { 2977 SvREFCNT_dec_NN(av); 2978 av = NULL; 2979 } else { 2980 ++need; 2981 } 2982 } 2983 /* FIXME - another reference loop GV -> symtab -> GV ? 2984 Somehow gp->gp_hv can end up pointing at freed garbage. */ 2985 if (hv && SvTYPE(hv) == SVt_PVHV) { 2986 const HEK *hvname_hek = HvNAME_HEK(hv); 2987 if (PL_stashcache && hvname_hek) { 2988 DEBUG_o(Perl_deb(aTHX_ 2989 "gp_free clearing PL_stashcache for '%" HEKf "'\n", 2990 HEKfARG(hvname_hek))); 2991 (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD); 2992 } 2993 if (SvREFCNT(hv) > 1 || SvOBJECT(hv) || UNLIKELY(in_global_destruction)) { 2994 SvREFCNT_dec_NN(hv); 2995 hv = NULL; 2996 } else { 2997 ++need; 2998 } 2999 } 3000 if (io && SvREFCNT(io) == 1 && IoIFP(io) 3001 && (IoTYPE(io) == IoTYPE_WRONLY || 3002 IoTYPE(io) == IoTYPE_RDWR || 3003 IoTYPE(io) == IoTYPE_APPEND) 3004 && ckWARN_d(WARN_IO) 3005 && IoIFP(io) != PerlIO_stdin() 3006 && IoIFP(io) != PerlIO_stdout() 3007 && IoIFP(io) != PerlIO_stderr() 3008 && !(IoFLAGS(io) & IOf_FAKE_DIRP)) 3009 io_close(io, gv, FALSE, TRUE); 3010 if (io) { 3011 if (SvREFCNT(io) > 1 || SvOBJECT(io) || UNLIKELY(in_global_destruction)) { 3012 SvREFCNT_dec_NN(io); 3013 io = NULL; 3014 } else { 3015 ++need; 3016 } 3017 } 3018 if (cv) { 3019 if (SvREFCNT(cv) > 1 || SvOBJECT(cv) || UNLIKELY(in_global_destruction)) { 3020 SvREFCNT_dec_NN(cv); 3021 cv = NULL; 3022 } else { 3023 ++need; 3024 } 3025 } 3026 if (form) { 3027 if (SvREFCNT(form) > 1 || SvOBJECT(form) || UNLIKELY(in_global_destruction)) { 3028 SvREFCNT_dec_NN(form); 3029 form = NULL; 3030 } else { 3031 ++need; 3032 } 3033 } 3034 3035 if (need) { 3036 /* We don't strictly need to defer all this to the end, but it's 3037 easiest to do so. The subtle problems we have are 3038 1) any of the actions triggered by the various SvREFCNT_dec()s in 3039 any of the intermediate blocks can cause more items to be added 3040 to the temps stack. So we can't "cache" its state locally 3041 2) We'd have to re-check the "extend by 1?" for each time. 3042 Whereas if we don't NULL out the values that we want to put onto 3043 the save stack until here, we can do it in one go, with one 3044 one size check. */ 3045 3046 SSize_t max_ix = PL_tmps_ix + need; 3047 3048 if (max_ix >= PL_tmps_max) { 3049 tmps_grow_p(max_ix); 3050 } 3051 3052 if (sv) { 3053 PL_tmps_stack[++PL_tmps_ix] = sv; 3054 } 3055 if (av) { 3056 PL_tmps_stack[++PL_tmps_ix] = (SV *) av; 3057 } 3058 if (hv) { 3059 PL_tmps_stack[++PL_tmps_ix] = (SV *) hv; 3060 } 3061 if (io) { 3062 PL_tmps_stack[++PL_tmps_ix] = (SV *) io; 3063 } 3064 if (cv) { 3065 PL_tmps_stack[++PL_tmps_ix] = (SV *) cv; 3066 } 3067 if (form) { 3068 PL_tmps_stack[++PL_tmps_ix] = (SV *) form; 3069 } 3070 } 3071 3072 /* Possibly reallocated by a destructor */ 3073 gp = GvGP(gv); 3074 3075 if (!gp->gp_file_hek 3076 && !gp->gp_sv 3077 && !gp->gp_av 3078 && !gp->gp_hv 3079 && !gp->gp_io 3080 && !gp->gp_cv 3081 && !gp->gp_form) break; 3082 3083 if (--attempts == 0) { 3084 Perl_die(aTHX_ 3085 "panic: gp_free failed to free glob pointer - " 3086 "something is repeatedly re-creating entries" 3087 ); 3088 } 3089 } 3090 3091 /* Possibly incremented by a destructor doing glob assignment */ 3092 if (gp->gp_refcnt > 1) goto borrowed; 3093 Safefree(gp); 3094 GvGP_set(gv, NULL); 3095 } 3096 3097 int 3098 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) 3099 { 3100 AMT * const amtp = (AMT*)mg->mg_ptr; 3101 PERL_UNUSED_ARG(sv); 3102 3103 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD; 3104 3105 if (amtp && AMT_AMAGIC(amtp)) { 3106 int i; 3107 for (i = 1; i < NofAMmeth; i++) { 3108 CV * const cv = amtp->table[i]; 3109 if (cv) { 3110 SvREFCNT_dec_NN(MUTABLE_SV(cv)); 3111 amtp->table[i] = NULL; 3112 } 3113 } 3114 } 3115 return 0; 3116 } 3117 3118 /* 3119 =for apidoc Gv_AMupdate 3120 3121 Recalculates overload magic in the package given by C<stash>. 3122 3123 Returns: 3124 3125 =over 3126 3127 =item 1 on success and there is some overload 3128 3129 =item 0 if there is no overload 3130 3131 =item -1 if some error occurred and it couldn't croak (because C<destructing> 3132 is true). 3133 3134 =back 3135 3136 =cut 3137 */ 3138 3139 int 3140 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) 3141 { 3142 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); 3143 AMT amt; 3144 const struct mro_meta* stash_meta = HvMROMETA(stash); 3145 U32 newgen; 3146 3147 PERL_ARGS_ASSERT_GV_AMUPDATE; 3148 3149 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen; 3150 if (mg) { 3151 const AMT * const amtp = (AMT*)mg->mg_ptr; 3152 if (amtp->was_ok_sub == newgen) { 3153 return AMT_AMAGIC(amtp) ? 1 : 0; 3154 } 3155 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table); 3156 } 3157 3158 DEBUG_o( Perl_deb(aTHX_ "Recalculating overload magic in package %s\n",HvNAME_get(stash)) ); 3159 3160 Zero(&amt,1,AMT); 3161 amt.was_ok_sub = newgen; 3162 amt.fallback = AMGfallNO; 3163 amt.flags = 0; 3164 3165 { 3166 int filled = 0; 3167 int i; 3168 bool deref_seen = 0; 3169 3170 3171 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ 3172 3173 /* Try to find via inheritance. */ 3174 GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0); 3175 SV * const sv = gv ? GvSV(gv) : NULL; 3176 CV* cv; 3177 3178 if (!gv) 3179 { 3180 if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0)) 3181 goto no_table; 3182 } 3183 #ifdef PERL_DONT_CREATE_GVSV 3184 else if (!sv) { 3185 NOOP; /* Equivalent to !SvTRUE and !SvOK */ 3186 } 3187 #endif 3188 else if (SvTRUE(sv)) 3189 /* don't need to set overloading here because fallback => 1 3190 * is the default setting for classes without overloading */ 3191 amt.fallback=AMGfallYES; 3192 else if (SvOK(sv)) { 3193 amt.fallback=AMGfallNEVER; 3194 filled = 1; 3195 } 3196 else { 3197 filled = 1; 3198 } 3199 3200 assert(HvHasAUX(stash)); 3201 /* initially assume the worst */ 3202 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF; 3203 3204 for (i = 1; i < NofAMmeth; i++) { 3205 const char * const cooky = PL_AMG_names[i]; 3206 /* Human-readable form, for debugging: */ 3207 const char * const cp = AMG_id2name(i); 3208 const STRLEN l = PL_AMG_namelens[i]; 3209 3210 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n", 3211 cp, HvNAME_get(stash)) ); 3212 /* don't fill the cache while looking up! 3213 Creation of inheritance stubs in intermediate packages may 3214 conflict with the logic of runtime method substitution. 3215 Indeed, for inheritance A -> B -> C, if C overloads "+0", 3216 then we could have created stubs for "(+0" in A and C too. 3217 But if B overloads "bool", we may want to use it for 3218 numifying instead of C's "+0". */ 3219 gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0); 3220 cv = 0; 3221 if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) { 3222 const HEK * const gvhek = CvGvNAME_HEK(cv); 3223 const HEK * const stashek = 3224 HvNAME_HEK(CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv))); 3225 if (memEQs(HEK_KEY(gvhek), HEK_LEN(gvhek), "nil") 3226 && stashek 3227 && memEQs(HEK_KEY(stashek), HEK_LEN(stashek), "overload")) { 3228 /* This is a hack to support autoloading..., while 3229 knowing *which* methods were declared as overloaded. */ 3230 /* GvSV contains the name of the method. */ 3231 GV *ngv = NULL; 3232 SV *gvsv = GvSV(gv); 3233 3234 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%" SVf256\ 3235 "\" for overloaded \"%s\" in package \"%.256s\"\n", 3236 (void*)GvSV(gv), cp, HvNAME(stash)) ); 3237 if (!gvsv || !SvPOK(gvsv) 3238 || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0))) 3239 { 3240 /* Can be an import stub (created by "can"). */ 3241 if (destructing) { 3242 return -1; 3243 } 3244 else { 3245 const SV * const name = (gvsv && SvPOK(gvsv)) 3246 ? gvsv 3247 : newSVpvs_flags("???", SVs_TEMP); 3248 /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */ 3249 Perl_croak(aTHX_ "%s method \"%" SVf256 3250 "\" overloading \"%s\" "\ 3251 "in package \"%" HEKf256 "\"", 3252 (GvCVGEN(gv) ? "Stub found while resolving" 3253 : "Can't resolve"), 3254 SVfARG(name), cp, 3255 HEKfARG( 3256 HvNAME_HEK(stash) 3257 )); 3258 } 3259 } 3260 cv = GvCV(gv = ngv); 3261 } 3262 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n", 3263 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))), 3264 GvNAME(CvGV(cv))) ); 3265 filled = 1; 3266 } else if (gv) { /* Autoloaded... */ 3267 cv = MUTABLE_CV(gv); 3268 filled = 1; 3269 } 3270 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv)); 3271 3272 if (gv) { 3273 switch (i) { 3274 case to_sv_amg: 3275 case to_av_amg: 3276 case to_hv_amg: 3277 case to_gv_amg: 3278 case to_cv_amg: 3279 case nomethod_amg: 3280 deref_seen = 1; 3281 break; 3282 } 3283 } 3284 } 3285 if (!deref_seen) 3286 /* none of @{} etc overloaded; we can do $obj->[N] quicker. 3287 * NB - aux var invalid here, HvARRAY() could have been 3288 * reallocated since it was assigned to */ 3289 HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF; 3290 3291 if (filled) { 3292 AMT_AMAGIC_on(&amt); 3293 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, 3294 (char*)&amt, sizeof(AMT)); 3295 return TRUE; 3296 } 3297 } 3298 /* Here we have no table: */ 3299 no_table: 3300 AMT_AMAGIC_off(&amt); 3301 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, 3302 (char*)&amt, sizeof(AMTS)); 3303 return 0; 3304 } 3305 3306 /* 3307 =for apidoc gv_handler 3308 3309 Implements C<StashHANDLER>, which you should use instead 3310 3311 =cut 3312 */ 3313 3314 CV* 3315 Perl_gv_handler(pTHX_ HV *stash, I32 id) 3316 { 3317 MAGIC *mg; 3318 AMT *amtp; 3319 U32 newgen; 3320 struct mro_meta* stash_meta; 3321 3322 if (!stash || !HvHasNAME(stash)) 3323 return NULL; 3324 3325 stash_meta = HvMROMETA(stash); 3326 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen; 3327 3328 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); 3329 if (!mg) { 3330 do_update: 3331 if (Gv_AMupdate(stash, 0) == -1) 3332 return NULL; 3333 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); 3334 } 3335 assert(mg); 3336 amtp = (AMT*)mg->mg_ptr; 3337 if ( amtp->was_ok_sub != newgen ) 3338 goto do_update; 3339 if (AMT_AMAGIC(amtp)) { 3340 CV * const ret = amtp->table[id]; 3341 if (ret && isGV(ret)) { /* Autoloading stab */ 3342 /* Passing it through may have resulted in a warning 3343 "Inherited AUTOLOAD for a non-method deprecated", since 3344 our caller is going through a function call, not a method call. 3345 So return the CV for AUTOLOAD, setting $AUTOLOAD. */ 3346 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]); 3347 3348 if (gv && GvCV(gv)) 3349 return GvCV(gv); 3350 } 3351 return ret; 3352 } 3353 3354 return NULL; 3355 } 3356 3357 3358 /* Implement tryAMAGICun_MG macro. 3359 Do get magic, then see if the stack arg is overloaded and if so call it. 3360 Flags: 3361 AMGf_numeric apply sv_2num to the stack arg. 3362 */ 3363 3364 bool 3365 Perl_try_amagic_un(pTHX_ int method, int flags) { 3366 dSP; 3367 SV* tmpsv; 3368 SV* const arg = TOPs; 3369 3370 SvGETMAGIC(arg); 3371 3372 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method, 3373 AMGf_noright | AMGf_unary 3374 | (flags & AMGf_numarg)))) 3375 { 3376 /* where the op is of the form: 3377 * $lex = $x op $y (where the assign is optimised away) 3378 * then assign the returned value to targ and return that; 3379 * otherwise return the value directly 3380 */ 3381 if ( (PL_opargs[PL_op->op_type] & OA_TARGLEX) 3382 && (PL_op->op_private & OPpTARGET_MY)) 3383 { 3384 dTARGET; 3385 sv_setsv(TARG, tmpsv); 3386 SETTARG; 3387 } 3388 else 3389 SETs(tmpsv); 3390 3391 PUTBACK; 3392 return TRUE; 3393 } 3394 3395 if ((flags & AMGf_numeric) && SvROK(arg)) 3396 *sp = sv_2num(arg); 3397 return FALSE; 3398 } 3399 3400 3401 /* 3402 =for apidoc amagic_applies 3403 3404 Check C<sv> to see if the overloaded (active magic) operation C<method> 3405 applies to it. If the sv is not SvROK or it is not an object then returns 3406 false, otherwise checks if the object is blessed into a class supporting 3407 overloaded operations, and returns true if a call to amagic_call() with 3408 this SV and the given method would trigger an amagic operation, including 3409 via the overload fallback rules or via nomethod. Thus a call like: 3410 3411 amagic_applies(sv, string_amg, AMG_unary) 3412 3413 would return true for an object with overloading set up in any of the 3414 following ways: 3415 3416 use overload q("") => sub { ... }; 3417 use overload q(0+) => sub { ... }, fallback => 1; 3418 3419 and could be used to tell if a given object would stringify to something 3420 other than the normal default ref stringification. 3421 3422 Note that the fact that this function returns TRUE does not mean you 3423 can succesfully perform the operation with amagic_call(), for instance 3424 any overloaded method might throw a fatal exception, however if this 3425 function returns FALSE you can be confident that it will NOT perform 3426 the given overload operation. 3427 3428 C<method> is an integer enum, one of the values found in F<overload.h>, 3429 for instance C<string_amg>. 3430 3431 C<flags> should be set to AMG_unary for unary operations. 3432 3433 =cut 3434 */ 3435 bool 3436 Perl_amagic_applies(pTHX_ SV *sv, int method, int flags) 3437 { 3438 PERL_ARGS_ASSERT_AMAGIC_APPLIES; 3439 PERL_UNUSED_VAR(flags); 3440 3441 assert(method >= 0 && method < NofAMmeth); 3442 3443 if (!SvAMAGIC(sv)) 3444 return FALSE; 3445 3446 HV *stash = SvSTASH(SvRV(sv)); 3447 if (!Gv_AMG(stash)) 3448 return FALSE; 3449 3450 MAGIC *mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); 3451 if (!mg) 3452 return FALSE; 3453 3454 CV **cvp = NULL; 3455 AMT *amtp = NULL; 3456 if (AMT_AMAGIC((AMT *)mg->mg_ptr)) { 3457 amtp = (AMT *)mg->mg_ptr; 3458 cvp = amtp->table; 3459 } 3460 if (!cvp) 3461 return FALSE; 3462 3463 if (cvp[method]) 3464 return TRUE; 3465 3466 /* Note this logic should be kept in sync with amagic_call() */ 3467 if (amtp->fallback > AMGfallNEVER && flags & AMGf_unary) { 3468 CV *cv; /* This makes it easier to kee ... */ 3469 int off,off1; /* ... in sync with amagic_call() */ 3470 3471 /* look for substituted methods */ 3472 /* In all the covered cases we should be called with assign==0. */ 3473 switch (method) { 3474 case inc_amg: 3475 if ((cv = cvp[off=add_ass_amg]) || ((cv = cvp[off = add_amg]))) 3476 return TRUE; 3477 break; 3478 case dec_amg: 3479 if((cv = cvp[off = subtr_ass_amg]) || ((cv = cvp[off = subtr_amg]))) 3480 return TRUE; 3481 break; 3482 case bool__amg: 3483 if ((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])) 3484 return TRUE; 3485 break; 3486 case numer_amg: 3487 if((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg])) 3488 return TRUE; 3489 break; 3490 case string_amg: 3491 if((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])) 3492 return TRUE; 3493 break; 3494 case not_amg: 3495 if((cv = cvp[off=bool__amg]) 3496 || (cv = cvp[off=numer_amg]) 3497 || (cv = cvp[off=string_amg])) 3498 return TRUE; 3499 break; 3500 case abs_amg: 3501 if((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) 3502 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) 3503 return TRUE; 3504 break; 3505 case neg_amg: 3506 if ((cv = cvp[off=subtr_amg])) 3507 return TRUE; 3508 break; 3509 } 3510 } else if (((cvp && amtp->fallback > AMGfallNEVER)) 3511 && !(flags & AMGf_unary)) { 3512 /* We look for substitution for 3513 * comparison operations and 3514 * concatenation */ 3515 if (method==concat_amg || method==concat_ass_amg 3516 || method==repeat_amg || method==repeat_ass_amg) { 3517 return FALSE; /* Delegate operation to string conversion */ 3518 } 3519 switch (method) { 3520 case lt_amg: 3521 case le_amg: 3522 case gt_amg: 3523 case ge_amg: 3524 case eq_amg: 3525 case ne_amg: 3526 if (cvp[ncmp_amg]) 3527 return TRUE; 3528 break; 3529 case slt_amg: 3530 case sle_amg: 3531 case sgt_amg: 3532 case sge_amg: 3533 case seq_amg: 3534 case sne_amg: 3535 if (cvp[scmp_amg]) 3536 return TRUE; 3537 break; 3538 } 3539 } 3540 3541 if (cvp[nomethod_amg]) 3542 return TRUE; 3543 3544 return FALSE; 3545 } 3546 3547 3548 /* Implement tryAMAGICbin_MG macro. 3549 Do get magic, then see if the two stack args are overloaded and if so 3550 call it. 3551 Flags: 3552 AMGf_assign op may be called as mutator (eg +=) 3553 AMGf_numeric apply sv_2num to the stack arg. 3554 */ 3555 3556 bool 3557 Perl_try_amagic_bin(pTHX_ int method, int flags) { 3558 dSP; 3559 SV* const left = TOPm1s; 3560 SV* const right = TOPs; 3561 3562 SvGETMAGIC(left); 3563 if (left != right) 3564 SvGETMAGIC(right); 3565 3566 if (SvAMAGIC(left) || SvAMAGIC(right)) { 3567 SV * tmpsv; 3568 /* STACKED implies mutator variant, e.g. $x += 1 */ 3569 bool mutator = (flags & AMGf_assign) && (PL_op->op_flags & OPf_STACKED); 3570 3571 tmpsv = amagic_call(left, right, method, 3572 (mutator ? AMGf_assign: 0) 3573 | (flags & AMGf_numarg)); 3574 if (tmpsv) { 3575 (void)POPs; 3576 /* where the op is one of the two forms: 3577 * $x op= $y 3578 * $lex = $x op $y (where the assign is optimised away) 3579 * then assign the returned value to targ and return that; 3580 * otherwise return the value directly 3581 */ 3582 if ( mutator 3583 || ( (PL_opargs[PL_op->op_type] & OA_TARGLEX) 3584 && (PL_op->op_private & OPpTARGET_MY))) 3585 { 3586 dTARG; 3587 TARG = mutator ? *SP : PAD_SV(PL_op->op_targ); 3588 sv_setsv(TARG, tmpsv); 3589 SETTARG; 3590 } 3591 else 3592 SETs(tmpsv); 3593 3594 PUTBACK; 3595 return TRUE; 3596 } 3597 } 3598 3599 if(left==right && SvGMAGICAL(left)) { 3600 SV * const left = sv_newmortal(); 3601 *(sp-1) = left; 3602 /* Print the uninitialized warning now, so it includes the vari- 3603 able name. */ 3604 if (!SvOK(right)) { 3605 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right); 3606 sv_setbool(left, FALSE); 3607 } 3608 else sv_setsv_flags(left, right, 0); 3609 SvGETMAGIC(right); 3610 } 3611 if (flags & AMGf_numeric) { 3612 if (SvROK(TOPm1s)) 3613 *(sp-1) = sv_2num(TOPm1s); 3614 if (SvROK(right)) 3615 *sp = sv_2num(right); 3616 } 3617 return FALSE; 3618 } 3619 3620 /* 3621 =for apidoc amagic_deref_call 3622 3623 Perform C<method> overloading dereferencing on C<ref>, returning the 3624 dereferenced result. C<method> must be one of the dereference operations given 3625 in F<overload.h>. 3626 3627 If overloading is inactive on C<ref>, returns C<ref> itself. 3628 3629 =cut 3630 */ 3631 3632 SV * 3633 Perl_amagic_deref_call(pTHX_ SV *ref, int method) { 3634 SV *tmpsv = NULL; 3635 HV *stash; 3636 3637 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL; 3638 3639 if (!SvAMAGIC(ref)) 3640 return ref; 3641 /* return quickly if none of the deref ops are overloaded */ 3642 stash = SvSTASH(SvRV(ref)); 3643 assert(HvHasAUX(stash)); 3644 if (HvAUX(stash)->xhv_aux_flags & HvAUXf_NO_DEREF) 3645 return ref; 3646 3647 while ((tmpsv = amagic_call(ref, &PL_sv_undef, method, 3648 AMGf_noright | AMGf_unary))) { 3649 if (!SvROK(tmpsv)) 3650 Perl_croak(aTHX_ "Overloaded dereference did not return a reference"); 3651 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) { 3652 /* Bail out if it returns us the same reference. */ 3653 return tmpsv; 3654 } 3655 ref = tmpsv; 3656 if (!SvAMAGIC(ref)) 3657 break; 3658 } 3659 return tmpsv ? tmpsv : ref; 3660 } 3661 3662 bool 3663 Perl_amagic_is_enabled(pTHX_ int method) 3664 { 3665 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0); 3666 3667 assert(PL_curcop->cop_hints & HINT_NO_AMAGIC); 3668 3669 if ( !lex_mask || !SvOK(lex_mask) ) 3670 /* overloading lexically disabled */ 3671 return FALSE; 3672 else if ( lex_mask && SvPOK(lex_mask) ) { 3673 /* we have an entry in the hints hash, check if method has been 3674 * masked by overloading.pm */ 3675 STRLEN len; 3676 const int offset = method / 8; 3677 const int bit = method % 8; 3678 char *pv = SvPV(lex_mask, len); 3679 3680 /* Bit set, so this overloading operator is disabled */ 3681 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) ) 3682 return FALSE; 3683 } 3684 return TRUE; 3685 } 3686 3687 /* 3688 =for apidoc amagic_call 3689 3690 Perform the overloaded (active magic) operation given by C<method>. 3691 C<method> is one of the values found in F<overload.h>. 3692 3693 C<flags> affects how the operation is performed, as follows: 3694 3695 =over 3696 3697 =item C<AMGf_noleft> 3698 3699 C<left> is not to be used in this operation. 3700 3701 =item C<AMGf_noright> 3702 3703 C<right> is not to be used in this operation. 3704 3705 =item C<AMGf_unary> 3706 3707 The operation is done only on just one operand. 3708 3709 =item C<AMGf_assign> 3710 3711 The operation changes one of the operands, e.g., $x += 1 3712 3713 =back 3714 3715 =cut 3716 */ 3717 3718 SV* 3719 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) 3720 { 3721 MAGIC *mg; 3722 CV *cv=NULL; 3723 CV **cvp=NULL, **ocvp=NULL; 3724 AMT *amtp=NULL, *oamtp=NULL; 3725 int off = 0, off1, lr = 0, notfound = 0; 3726 int postpr = 0, force_cpy = 0; 3727 int assign = AMGf_assign & flags; 3728 const int assignshift = assign ? 1 : 0; 3729 int use_default_op = 0; 3730 int force_scalar = 0; 3731 #ifdef DEBUGGING 3732 int fl=0; 3733 #endif 3734 HV* stash=NULL; 3735 3736 PERL_ARGS_ASSERT_AMAGIC_CALL; 3737 3738 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) { 3739 if (!amagic_is_enabled(method)) return NULL; 3740 } 3741 3742 if (!(AMGf_noleft & flags) && SvAMAGIC(left) 3743 && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash) 3744 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) 3745 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) 3746 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table 3747 : NULL)) 3748 && ((cv = cvp[off=method+assignshift]) 3749 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to 3750 * usual method */ 3751 ( 3752 #ifdef DEBUGGING 3753 fl = 1, 3754 #endif 3755 cv = cvp[off=method])))) 3756 { 3757 lr = -1; /* Call method for left argument */ 3758 } else { 3759 /* Note this logic should be kept in sync with amagic_applies() */ 3760 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) { 3761 int logic; 3762 3763 /* look for substituted methods */ 3764 /* In all the covered cases we should be called with assign==0. */ 3765 switch (method) { 3766 case inc_amg: 3767 force_cpy = 1; 3768 if ((cv = cvp[off=add_ass_amg]) 3769 || ((cv = cvp[off = add_amg]) 3770 && (force_cpy = 0, (postpr = 1)))) { 3771 right = &PL_sv_yes; lr = -1; assign = 1; 3772 } 3773 break; 3774 case dec_amg: 3775 force_cpy = 1; 3776 if ((cv = cvp[off = subtr_ass_amg]) 3777 || ((cv = cvp[off = subtr_amg]) 3778 && (force_cpy = 0, (postpr=1)))) { 3779 right = &PL_sv_yes; lr = -1; assign = 1; 3780 } 3781 break; 3782 case bool__amg: 3783 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); 3784 break; 3785 case numer_amg: 3786 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg])); 3787 break; 3788 case string_amg: 3789 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); 3790 break; 3791 case not_amg: 3792 (void)((cv = cvp[off=bool__amg]) 3793 || (cv = cvp[off=numer_amg]) 3794 || (cv = cvp[off=string_amg])); 3795 if (cv) 3796 postpr = 1; 3797 break; 3798 case copy_amg: 3799 { 3800 /* 3801 * SV* ref causes confusion with the interpreter variable of 3802 * the same name 3803 */ 3804 SV* const tmpRef=SvRV(left); 3805 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) { 3806 /* 3807 * Just to be extra cautious. Maybe in some 3808 * additional cases sv_setsv is safe, too. 3809 */ 3810 SV* const newref = newSVsv(tmpRef); 3811 SvOBJECT_on(newref); 3812 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros 3813 delegate to the stash. */ 3814 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef)))); 3815 return newref; 3816 } 3817 } 3818 break; 3819 case abs_amg: 3820 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) 3821 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { 3822 SV* const nullsv=&PL_sv_zero; 3823 if (off1==lt_amg) { 3824 SV* const lessp = amagic_call(left,nullsv, 3825 lt_amg,AMGf_noright); 3826 logic = SvTRUE_NN(lessp); 3827 } else { 3828 SV* const lessp = amagic_call(left,nullsv, 3829 ncmp_amg,AMGf_noright); 3830 logic = (SvNV(lessp) < 0); 3831 } 3832 if (logic) { 3833 if (off==subtr_amg) { 3834 right = left; 3835 left = nullsv; 3836 lr = 1; 3837 } 3838 } else { 3839 return left; 3840 } 3841 } 3842 break; 3843 case neg_amg: 3844 if ((cv = cvp[off=subtr_amg])) { 3845 right = left; 3846 left = &PL_sv_zero; 3847 lr = 1; 3848 } 3849 break; 3850 case int_amg: 3851 case iter_amg: /* XXXX Eventually should do to_gv. */ 3852 case ftest_amg: /* XXXX Eventually should do to_gv. */ 3853 case regexp_amg: 3854 /* FAIL safe */ 3855 return NULL; /* Delegate operation to standard mechanisms. */ 3856 3857 case to_sv_amg: 3858 case to_av_amg: 3859 case to_hv_amg: 3860 case to_gv_amg: 3861 case to_cv_amg: 3862 /* FAIL safe */ 3863 return left; /* Delegate operation to standard mechanisms. */ 3864 3865 default: 3866 goto not_found; 3867 } 3868 if (!cv) goto not_found; 3869 } else if (!(AMGf_noright & flags) && SvAMAGIC(right) 3870 && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash) 3871 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) 3872 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) 3873 ? (amtp = (AMT*)mg->mg_ptr)->table 3874 : NULL)) 3875 && (cv = cvp[off=method])) { /* Method for right 3876 * argument found */ 3877 lr=1; 3878 } else if (((cvp && amtp->fallback > AMGfallNEVER) 3879 || (ocvp && oamtp->fallback > AMGfallNEVER)) 3880 && !(flags & AMGf_unary)) { 3881 /* We look for substitution for 3882 * comparison operations and 3883 * concatenation */ 3884 if (method==concat_amg || method==concat_ass_amg 3885 || method==repeat_amg || method==repeat_ass_amg) { 3886 return NULL; /* Delegate operation to string conversion */ 3887 } 3888 off = -1; 3889 switch (method) { 3890 case lt_amg: 3891 case le_amg: 3892 case gt_amg: 3893 case ge_amg: 3894 case eq_amg: 3895 case ne_amg: 3896 off = ncmp_amg; 3897 break; 3898 case slt_amg: 3899 case sle_amg: 3900 case sgt_amg: 3901 case sge_amg: 3902 case seq_amg: 3903 case sne_amg: 3904 off = scmp_amg; 3905 break; 3906 } 3907 if (off != -1) { 3908 if (ocvp && (oamtp->fallback > AMGfallNEVER)) { 3909 cv = ocvp[off]; 3910 lr = -1; 3911 } 3912 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) { 3913 cv = cvp[off]; 3914 lr = 1; 3915 } 3916 } 3917 if (cv) 3918 postpr = 1; 3919 else 3920 goto not_found; 3921 } else { 3922 not_found: /* No method found, either report or croak */ 3923 switch (method) { 3924 case to_sv_amg: 3925 case to_av_amg: 3926 case to_hv_amg: 3927 case to_gv_amg: 3928 case to_cv_amg: 3929 /* FAIL safe */ 3930 return left; /* Delegate operation to standard mechanisms. */ 3931 } 3932 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */ 3933 notfound = 1; lr = -1; 3934 } else if (cvp && (cv=cvp[nomethod_amg])) { 3935 notfound = 1; lr = 1; 3936 } else if ((use_default_op = 3937 (!ocvp || oamtp->fallback >= AMGfallYES) 3938 && (!cvp || amtp->fallback >= AMGfallYES)) 3939 && !DEBUG_o_TEST) { 3940 /* Skip generating the "no method found" message. */ 3941 return NULL; 3942 } else { 3943 SV *msg; 3944 if (off==-1) off=method; 3945 msg = sv_2mortal(Perl_newSVpvf(aTHX_ 3946 "Operation \"%s\": no method found,%sargument %s%" SVf "%s%" SVf, 3947 AMG_id2name(method + assignshift), 3948 (flags & AMGf_unary ? " " : "\n\tleft "), 3949 SvAMAGIC(left)? 3950 "in overloaded package ": 3951 "has no overloaded magic", 3952 SvAMAGIC(left)? 3953 SVfARG(newSVhek_mortal(HvNAME_HEK(SvSTASH(SvRV(left))))): 3954 SVfARG(&PL_sv_no), 3955 SvAMAGIC(right)? 3956 ",\n\tright argument in overloaded package ": 3957 (flags & AMGf_unary 3958 ? "" 3959 : ",\n\tright argument has no overloaded magic"), 3960 SvAMAGIC(right)? 3961 SVfARG(newSVhek_mortal(HvNAME_HEK(SvSTASH(SvRV(right))))): 3962 SVfARG(&PL_sv_no))); 3963 if (use_default_op) { 3964 DEBUG_o( Perl_deb(aTHX_ "%" SVf, SVfARG(msg)) ); 3965 } else { 3966 Perl_croak(aTHX_ "%" SVf, SVfARG(msg)); 3967 } 3968 return NULL; 3969 } 3970 force_cpy = force_cpy || assign; 3971 } 3972 } 3973 3974 switch (method) { 3975 /* in these cases, we're calling '+' or '-' as a fallback for a ++ or -- 3976 * operation. we need this to return a value, so that it can be assigned 3977 * later on, in the postpr block (case inc_amg/dec_amg), even if the 3978 * increment or decrement was itself called in void context */ 3979 case inc_amg: 3980 if (off == add_amg) 3981 force_scalar = 1; 3982 break; 3983 case dec_amg: 3984 if (off == subtr_amg) 3985 force_scalar = 1; 3986 break; 3987 /* in these cases, we're calling an assignment variant of an operator 3988 * (+= rather than +, for instance). regardless of whether it's a 3989 * fallback or not, it always has to return a value, which will be 3990 * assigned to the proper variable later */ 3991 case add_amg: 3992 case subtr_amg: 3993 case mult_amg: 3994 case div_amg: 3995 case modulo_amg: 3996 case pow_amg: 3997 case lshift_amg: 3998 case rshift_amg: 3999 case repeat_amg: 4000 case concat_amg: 4001 case band_amg: 4002 case bor_amg: 4003 case bxor_amg: 4004 case sband_amg: 4005 case sbor_amg: 4006 case sbxor_amg: 4007 if (assign) 4008 force_scalar = 1; 4009 break; 4010 /* the copy constructor always needs to return a value */ 4011 case copy_amg: 4012 force_scalar = 1; 4013 break; 4014 /* because of the way these are implemented (they don't perform the 4015 * dereferencing themselves, they return a reference that perl then 4016 * dereferences later), they always have to be in scalar context */ 4017 case to_sv_amg: 4018 case to_av_amg: 4019 case to_hv_amg: 4020 case to_gv_amg: 4021 case to_cv_amg: 4022 force_scalar = 1; 4023 break; 4024 /* these don't have an op of their own; they're triggered by their parent 4025 * op, so the context there isn't meaningful ('$a and foo()' in void 4026 * context still needs to pass scalar context on to $a's bool overload) */ 4027 case bool__amg: 4028 case numer_amg: 4029 case string_amg: 4030 force_scalar = 1; 4031 break; 4032 } 4033 4034 #ifdef DEBUGGING 4035 if (!notfound) { 4036 DEBUG_o(Perl_deb(aTHX_ 4037 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %" SVf "%s\n", 4038 AMG_id2name(off), 4039 method+assignshift==off? "" : 4040 " (initially \"", 4041 method+assignshift==off? "" : 4042 AMG_id2name(method+assignshift), 4043 method+assignshift==off? "" : "\")", 4044 flags & AMGf_unary? "" : 4045 lr==1 ? " for right argument": " for left argument", 4046 flags & AMGf_unary? " for argument" : "", 4047 stash ? SVfARG(newSVhek_mortal(HvNAME_HEK(stash))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)), 4048 fl? ",\n\tassignment variant used": "") ); 4049 } 4050 #endif 4051 /* Since we use shallow copy during assignment, we need 4052 * to duplicate the contents, probably calling user-supplied 4053 * version of copy operator 4054 */ 4055 /* We need to copy in following cases: 4056 * a) Assignment form was called. 4057 * assignshift==1, assign==T, method + 1 == off 4058 * b) Increment or decrement, called directly. 4059 * assignshift==0, assign==0, method + 0 == off 4060 * c) Increment or decrement, translated to assignment add/subtr. 4061 * assignshift==0, assign==T, 4062 * force_cpy == T 4063 * d) Increment or decrement, translated to nomethod. 4064 * assignshift==0, assign==0, 4065 * force_cpy == T 4066 * e) Assignment form translated to nomethod. 4067 * assignshift==1, assign==T, method + 1 != off 4068 * force_cpy == T 4069 */ 4070 /* off is method, method+assignshift, or a result of opcode substitution. 4071 * In the latter case assignshift==0, so only notfound case is important. 4072 */ 4073 if ( (lr == -1) && ( ( (method + assignshift == off) 4074 && (assign || (method == inc_amg) || (method == dec_amg))) 4075 || force_cpy) ) 4076 { 4077 /* newSVsv does not behave as advertised, so we copy missing 4078 * information by hand */ 4079 SV *tmpRef = SvRV(left); 4080 SV *rv_copy; 4081 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) { 4082 SvRV_set(left, rv_copy); 4083 SvSETMAGIC(left); 4084 SvREFCNT_dec_NN(tmpRef); 4085 } 4086 } 4087 4088 { 4089 dSP; 4090 UNOP myop; 4091 SV* res; 4092 const bool oldcatch = CATCH_GET; 4093 I32 oldmark, nret; 4094 /* for multiconcat, we may call overload several times, 4095 * with the context of individual concats being scalar, 4096 * regardless of the overall context of the multiconcat op 4097 */ 4098 U8 gimme = (force_scalar || PL_op->op_type == OP_MULTICONCAT) 4099 ? G_SCALAR : GIMME_V; 4100 4101 CATCH_SET(TRUE); 4102 Zero(&myop, 1, UNOP); 4103 myop.op_flags = OPf_STACKED; 4104 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB]; 4105 myop.op_type = OP_ENTERSUB; 4106 4107 4108 switch (gimme) { 4109 case G_VOID: 4110 myop.op_flags |= OPf_WANT_VOID; 4111 break; 4112 case G_LIST: 4113 if (flags & AMGf_want_list) { 4114 myop.op_flags |= OPf_WANT_LIST; 4115 break; 4116 } 4117 /* FALLTHROUGH */ 4118 default: 4119 myop.op_flags |= OPf_WANT_SCALAR; 4120 break; 4121 } 4122 4123 PUSHSTACKi(PERLSI_OVERLOAD); 4124 ENTER; 4125 SAVEOP(); 4126 PL_op = (OP *) &myop; 4127 if (PERLDB_SUB && PL_curstash != PL_debstash) 4128 PL_op->op_private |= OPpENTERSUB_DB; 4129 Perl_pp_pushmark(aTHX); 4130 4131 EXTEND(SP, notfound + 5); 4132 PUSHs(lr>0? right: left); 4133 PUSHs(lr>0? left: right); 4134 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no )); 4135 if (notfound) { 4136 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift), 4137 AMG_id2namelen(method + assignshift), SVs_TEMP)); 4138 } 4139 else if (flags & AMGf_numarg) 4140 PUSHs(&PL_sv_undef); 4141 if (flags & AMGf_numarg) 4142 PUSHs(&PL_sv_yes); 4143 PUSHs(MUTABLE_SV(cv)); 4144 PUTBACK; 4145 oldmark = TOPMARK; 4146 CALLRUNOPS(aTHX); 4147 LEAVE; 4148 SPAGAIN; 4149 nret = SP - (PL_stack_base + oldmark); 4150 4151 switch (gimme) { 4152 case G_VOID: 4153 /* returning NULL has another meaning, and we check the context 4154 * at the call site too, so this can be differentiated from the 4155 * scalar case */ 4156 res = &PL_sv_undef; 4157 SP = PL_stack_base + oldmark; 4158 break; 4159 case G_LIST: 4160 if (flags & AMGf_want_list) { 4161 res = newSV_type_mortal(SVt_PVAV); 4162 av_extend((AV *)res, nret); 4163 while (nret--) 4164 av_store((AV *)res, nret, POPs); 4165 break; 4166 } 4167 /* FALLTHROUGH */ 4168 default: 4169 res = POPs; 4170 break; 4171 } 4172 4173 PUTBACK; 4174 POPSTACK; 4175 CATCH_SET(oldcatch); 4176 4177 if (postpr) { 4178 int ans; 4179 switch (method) { 4180 case le_amg: 4181 case sle_amg: 4182 ans=SvIV(res)<=0; break; 4183 case lt_amg: 4184 case slt_amg: 4185 ans=SvIV(res)<0; break; 4186 case ge_amg: 4187 case sge_amg: 4188 ans=SvIV(res)>=0; break; 4189 case gt_amg: 4190 case sgt_amg: 4191 ans=SvIV(res)>0; break; 4192 case eq_amg: 4193 case seq_amg: 4194 ans=SvIV(res)==0; break; 4195 case ne_amg: 4196 case sne_amg: 4197 ans=SvIV(res)!=0; break; 4198 case inc_amg: 4199 case dec_amg: 4200 SvSetSV(left,res); return left; 4201 case not_amg: 4202 ans=!SvTRUE_NN(res); break; 4203 default: 4204 ans=0; break; 4205 } 4206 return boolSV(ans); 4207 } else if (method==copy_amg) { 4208 if (!SvROK(res)) { 4209 Perl_croak(aTHX_ "Copy method did not return a reference"); 4210 } 4211 return SvREFCNT_inc(SvRV(res)); 4212 } else { 4213 return res; 4214 } 4215 } 4216 } 4217 4218 /* 4219 =for apidoc gv_name_set 4220 4221 Set the name for GV C<gv> to C<name> which is C<len> bytes long. Thus it may 4222 contain embedded NUL characters. 4223 4224 If C<flags> contains C<SVf_UTF8>, the name is treated as being encoded in 4225 UTF-8; otherwise not. 4226 4227 =cut 4228 */ 4229 4230 void 4231 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) 4232 { 4233 U32 hash; 4234 4235 PERL_ARGS_ASSERT_GV_NAME_SET; 4236 4237 if (len > I32_MAX) 4238 Perl_croak(aTHX_ "panic: gv name too long (%" UVuf ")", (UV) len); 4239 4240 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) { 4241 unshare_hek(GvNAME_HEK(gv)); 4242 } 4243 4244 PERL_HASH(hash, name, len); 4245 GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash); 4246 } 4247 4248 /* 4249 =for apidoc gv_try_downgrade 4250 4251 If the typeglob C<gv> can be expressed more succinctly, by having 4252 something other than a real GV in its place in the stash, replace it 4253 with the optimised form. Basic requirements for this are that C<gv> 4254 is a real typeglob, is sufficiently ordinary, and is only referenced 4255 from its package. This function is meant to be used when a GV has been 4256 looked up in part to see what was there, causing upgrading, but based 4257 on what was found it turns out that the real GV isn't required after all. 4258 4259 If C<gv> is a completely empty typeglob, it is deleted from the stash. 4260 4261 If C<gv> is a typeglob containing only a sufficiently-ordinary constant 4262 sub, the typeglob is replaced with a scalar-reference placeholder that 4263 more compactly represents the same thing. 4264 4265 =cut 4266 */ 4267 4268 void 4269 Perl_gv_try_downgrade(pTHX_ GV *gv) 4270 { 4271 HV *stash; 4272 CV *cv; 4273 HEK *namehek; 4274 SV **gvp; 4275 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE; 4276 4277 /* XXX Why and where does this leave dangling pointers during global 4278 destruction? */ 4279 if (PL_phase == PERL_PHASE_DESTRUCT) return; 4280 4281 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) && 4282 !SvOBJECT(gv) && !SvREADONLY(gv) && 4283 isGV_with_GP(gv) && GvGP(gv) && 4284 !GvINTRO(gv) && GvREFCNT(gv) == 1 && 4285 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) && 4286 GvEGVx(gv) == gv && (stash = GvSTASH(gv)))) 4287 return; 4288 if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv) 4289 return; 4290 if (SvMAGICAL(gv)) { 4291 MAGIC *mg; 4292 /* only backref magic is allowed */ 4293 if (SvGMAGICAL(gv) || SvSMAGICAL(gv)) 4294 return; 4295 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) { 4296 if (mg->mg_type != PERL_MAGIC_backref) 4297 return; 4298 } 4299 } 4300 cv = GvCV(gv); 4301 if (!cv) { 4302 HEK *gvnhek = GvNAME_HEK(gv); 4303 (void)hv_deletehek(stash, gvnhek, G_DISCARD); 4304 } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 && 4305 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) && 4306 CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv && 4307 CvCONST(cv) && !CvNOWARN_AMBIGUOUS(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) && 4308 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) && 4309 (namehek = GvNAME_HEK(gv)) && 4310 (gvp = hv_fetchhek(stash, namehek, 0)) && 4311 *gvp == (SV*)gv) { 4312 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr); 4313 const bool imported = cBOOL(GvIMPORTED_CV(gv)); 4314 SvREFCNT(gv) = 0; 4315 sv_clear((SV*)gv); 4316 SvREFCNT(gv) = 1; 4317 SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported; 4318 4319 /* See also: 'SET_SVANY_FOR_BODYLESS_IV' in sv.c */ 4320 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) - 4321 STRUCT_OFFSET(XPVIV, xiv_iv)); 4322 SvRV_set(gv, value); 4323 } 4324 } 4325 4326 GV * 4327 Perl_gv_override(pTHX_ const char * const name, const STRLEN len) 4328 { 4329 GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV); 4330 GV * const *gvp; 4331 PERL_ARGS_ASSERT_GV_OVERRIDE; 4332 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv; 4333 gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE); 4334 gv = gvp ? *gvp : NULL; 4335 if (gv && !isGV(gv)) { 4336 if (!SvPCS_IMPORTED(gv)) return NULL; 4337 gv_init(gv, PL_globalstash, name, len, 0); 4338 return gv; 4339 } 4340 return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL; 4341 } 4342 4343 #include "XSUB.h" 4344 4345 static void 4346 core_xsub(pTHX_ CV* cv) 4347 { 4348 Perl_croak(aTHX_ 4349 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv)) 4350 ); 4351 } 4352 4353 /* 4354 * ex: set ts=8 sts=4 sw=4 et: 4355 */ 4356