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 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 if (autoload) 1216 gv = gv_autoload_pvn( 1217 ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags 1218 ); 1219 if (!gv && do_croak) { 1220 /* Right now this is exclusively for the benefit of S_method_common 1221 in pp_hot.c */ 1222 if (stash) { 1223 /* If we can't find an IO::File method, it might be a call on 1224 * a filehandle. If IO:File has not been loaded, try to 1225 * require it first instead of croaking */ 1226 const char *stash_name = HvNAME_get(stash); 1227 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File") 1228 && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL, 1229 STR_WITH_LEN("IO/File.pm"), 0, 1230 HV_FETCH_ISEXISTS, NULL, 0) 1231 ) { 1232 require_pv("IO/File.pm"); 1233 gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags); 1234 if (gv) 1235 return gv; 1236 } 1237 Perl_croak(aTHX_ 1238 "Can't locate object method %" UTF8f_QUOTEDPREFIX "" 1239 " via package %" HEKf_QUOTEDPREFIX, 1240 UTF8fARG(is_utf8, name_end - name, name), 1241 HEKfARG(HvNAME_HEK(stash))); 1242 } 1243 else { 1244 SV* packnamesv; 1245 1246 if (last_separator) { 1247 packnamesv = newSVpvn_flags(origname, last_separator - origname, 1248 SVs_TEMP | is_utf8); 1249 } else { 1250 packnamesv = error_report; 1251 } 1252 1253 Perl_croak(aTHX_ 1254 "Can't locate object method %" UTF8f_QUOTEDPREFIX "" 1255 " via package %" SVf_QUOTEDPREFIX "" 1256 " (perhaps you forgot to load %" SVf_QUOTEDPREFIX "?)", 1257 UTF8fARG(is_utf8, name_end - name, name), 1258 SVfARG(packnamesv), SVfARG(packnamesv)); 1259 } 1260 } 1261 } 1262 else if (autoload) { 1263 CV* const cv = GvCV(gv); 1264 if (!CvROOT(cv) && !CvXSUB(cv)) { 1265 GV* stubgv; 1266 GV* autogv; 1267 1268 if (CvANON(cv) || CvLEXICAL(cv)) 1269 stubgv = gv; 1270 else { 1271 stubgv = CvGV(cv); 1272 if (GvCV(stubgv) != cv) /* orphaned import */ 1273 stubgv = gv; 1274 } 1275 autogv = gv_autoload_pvn(GvSTASH(stubgv), 1276 GvNAME(stubgv), GvNAMELEN(stubgv), 1277 GV_AUTOLOAD_ISMETHOD 1278 | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0)); 1279 if (autogv) 1280 gv = autogv; 1281 } 1282 } 1283 1284 return gv; 1285 } 1286 1287 1288 /* 1289 =for apidoc gv_autoload_pv 1290 =for apidoc_item gv_autoload_pvn 1291 =for apidoc_item gv_autoload_sv 1292 1293 These each search for an C<AUTOLOAD> method, returning NULL if not found, or 1294 else returning a pointer to its GV, while setting the package 1295 L<C<$AUTOLOAD>|perlobj/AUTOLOAD> variable to C<name> (fully qualified). Also, 1296 if found and the GV's CV is an XSUB, the CV's PV will be set to C<name>, and 1297 its stash will be set to the stash of the GV. 1298 1299 Searching is done in L<C<MRO> order|perlmroapi>, as specified in 1300 L</C<gv_fetchmeth>>, beginning with C<stash> if it isn't NULL. 1301 1302 The forms differ only in how C<name> is specified. 1303 1304 In C<gv_autoload_pv>, C<namepv> is a C language NUL-terminated string. 1305 1306 In C<gv_autoload_pvn>, C<name> points to the first byte of the name, and an 1307 additional parameter, C<len>, specifies its length in bytes. Hence, C<*name> 1308 may contain embedded-NUL characters. 1309 1310 In C<gv_autoload_sv>, C<*namesv> is an SV, and the name is the PV extracted 1311 from that using L</C<SvPV>>. If the SV is marked as being in UTF-8, the 1312 extracted PV will also be. 1313 1314 =cut 1315 */ 1316 1317 GV* 1318 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags) 1319 { 1320 char *namepv; 1321 STRLEN namelen; 1322 PERL_ARGS_ASSERT_GV_AUTOLOAD_SV; 1323 namepv = SvPV(namesv, namelen); 1324 if (SvUTF8(namesv)) 1325 flags |= SVf_UTF8; 1326 return gv_autoload_pvn(stash, namepv, namelen, flags); 1327 } 1328 1329 GV* 1330 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags) 1331 { 1332 PERL_ARGS_ASSERT_GV_AUTOLOAD_PV; 1333 return gv_autoload_pvn(stash, namepv, strlen(namepv), flags); 1334 } 1335 1336 GV* 1337 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) 1338 { 1339 GV* gv; 1340 CV* cv; 1341 HV* varstash; 1342 GV* vargv; 1343 SV* varsv; 1344 SV *packname = NULL; 1345 U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0; 1346 1347 PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN; 1348 1349 if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) 1350 return NULL; 1351 if (stash) { 1352 if (SvTYPE(stash) < SVt_PVHV) { 1353 STRLEN packname_len = 0; 1354 const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len); 1355 packname = newSVpvn_flags(packname_ptr, packname_len, 1356 SVs_TEMP | SvUTF8(stash)); 1357 stash = NULL; 1358 } 1359 else 1360 packname = newSVhek_mortal(HvNAME_HEK(stash)); 1361 if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER"); 1362 } 1363 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, 1364 is_utf8 | (flags & GV_SUPER)))) 1365 return NULL; 1366 cv = GvCV(gv); 1367 1368 if (!(CvROOT(cv) || CvXSUB(cv))) 1369 return NULL; 1370 1371 /* 1372 * Inheriting AUTOLOAD for non-methods no longer works 1373 */ 1374 if ( 1375 !(flags & GV_AUTOLOAD_ISMETHOD) 1376 && (GvCVGEN(gv) || GvSTASH(gv) != stash) 1377 ) 1378 Perl_croak(aTHX_ "Use of inherited AUTOLOAD for non-method %" SVf 1379 "::%" UTF8f "() is no longer allowed", 1380 SVfARG(packname), 1381 UTF8fARG(is_utf8, len, name)); 1382 1383 if (CvISXSUB(cv)) { 1384 /* Instead of forcing the XSUB to do another lookup for $AUTOLOAD 1385 * and split that value on the last '::', pass along the same data 1386 * via the SvPVX field in the CV, and the stash in CvSTASH. 1387 * 1388 * Due to an unfortunate accident of history, the SvPVX field 1389 * serves two purposes. It is also used for the subroutine's 1390 * prototype. Since SvPVX has been documented as returning the sub 1391 * name for a long time, but not as returning the prototype, we have to 1392 * preserve the SvPVX AUTOLOAD behaviour and put the prototype 1393 * elsewhere. 1394 * 1395 * We put the prototype in the same allocated buffer, but after 1396 * the sub name. The SvPOK flag indicates the presence of a proto- 1397 * type. The CvAUTOLOAD flag indicates the presence of a sub name. 1398 * If both flags are on, then SvLEN is used to indicate the end of 1399 * the prototype (artificially lower than what is actually allo- 1400 * cated), at the risk of having to reallocate a few bytes unneces- 1401 * sarily--but that should happen very rarely, if ever. 1402 * 1403 * We use SvUTF8 for both prototypes and sub names, so if one is 1404 * UTF8, the other must be upgraded. 1405 */ 1406 CvSTASH_set(cv, stash); 1407 if (SvPOK(cv)) { /* Ouch! */ 1408 SV * const tmpsv = newSVpvn_flags(name, len, is_utf8); 1409 STRLEN ulen; 1410 const char *proto = CvPROTO(cv); 1411 assert(proto); 1412 if (SvUTF8(cv)) 1413 sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2); 1414 ulen = SvCUR(tmpsv); 1415 SvCUR_set(tmpsv, SvCUR(tmpsv) + 1); /* include null in string */ 1416 sv_catpvn_flags( 1417 tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv) 1418 ); 1419 SvTEMP_on(tmpsv); /* Allow theft */ 1420 sv_setsv_nomg((SV *)cv, tmpsv); 1421 SvTEMP_off(tmpsv); 1422 SvREFCNT_dec_NN(tmpsv); 1423 SvLEN_set(cv, SvCUR(cv) + 1); 1424 SvCUR_set(cv, ulen); 1425 } 1426 else { 1427 sv_setpvn((SV *)cv, name, len); 1428 SvPOK_off(cv); 1429 if (is_utf8) 1430 SvUTF8_on(cv); 1431 else SvUTF8_off(cv); 1432 } 1433 CvAUTOLOAD_on(cv); 1434 } 1435 1436 /* 1437 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name. 1438 * The subroutine's original name may not be "AUTOLOAD", so we don't 1439 * use that, but for lack of anything better we will use the sub's 1440 * original package to look up $AUTOLOAD. 1441 */ 1442 varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv)); 1443 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE); 1444 ENTER; 1445 1446 if (!isGV(vargv)) { 1447 gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0); 1448 #ifdef PERL_DONT_CREATE_GVSV 1449 GvSV(vargv) = newSV_type(SVt_NULL); 1450 #endif 1451 } 1452 LEAVE; 1453 varsv = GvSVn(vargv); 1454 SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */ 1455 /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */ 1456 sv_setsv(varsv, packname); 1457 sv_catpvs(varsv, "::"); 1458 /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear 1459 tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */ 1460 sv_catpvn_flags( 1461 varsv, name, len, 1462 SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES) 1463 ); 1464 if (is_utf8) 1465 SvUTF8_on(varsv); 1466 return gv; 1467 } 1468 1469 1470 /* require_tie_mod() internal routine for requiring a module 1471 * that implements the logic of automatic ties like %! and %- 1472 * It loads the module and then calls the _tie_it subroutine 1473 * with the passed gv as an argument. 1474 * 1475 * The "gv" parameter should be the glob. 1476 * "varname" holds the 1-char name of the var, used for error messages. 1477 * "namesv" holds the module name. Its refcount will be decremented. 1478 * "flags": if flag & 1 then save the scalar before loading. 1479 * For the protection of $! to work (it is set by this routine) 1480 * the sv slot must already be magicalized. 1481 */ 1482 STATIC void 1483 S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name, 1484 STRLEN len, const U32 flags) 1485 { 1486 const SV * const target = varname == '[' ? GvSV(gv) : (SV *)GvHV(gv); 1487 1488 PERL_ARGS_ASSERT_REQUIRE_TIE_MOD; 1489 1490 /* If it is not tied */ 1491 if (!target || !SvRMAGICAL(target) 1492 || !mg_find(target, 1493 varname == '[' ? PERL_MAGIC_tiedscalar : PERL_MAGIC_tied)) 1494 { 1495 HV *stash; 1496 GV **gvp; 1497 dSP; 1498 1499 PUSHSTACKi(PERLSI_MAGIC); 1500 ENTER; 1501 1502 #define GET_HV_FETCH_TIE_FUNC \ 1503 ( (gvp = (GV **)hv_fetchs(stash, "_tie_it", 0)) \ 1504 && *gvp \ 1505 && ( (isGV(*gvp) && GvCV(*gvp)) \ 1506 || (SvROK(*gvp) && SvTYPE(SvRV(*gvp)) == SVt_PVCV) ) \ 1507 ) 1508 1509 /* Load the module if it is not loaded. */ 1510 if (!(stash = gv_stashpvn(name, len, 0)) 1511 || ! GET_HV_FETCH_TIE_FUNC) 1512 { 1513 SV * const module = newSVpvn(name, len); 1514 const char type = varname == '[' ? '$' : '%'; 1515 if ( flags & 1 ) 1516 save_scalar(gv); 1517 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL); 1518 assert(sp == PL_stack_sp); 1519 stash = gv_stashpvn(name, len, 0); 1520 if (!stash) 1521 Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available", 1522 type, varname, name); 1523 else if (! GET_HV_FETCH_TIE_FUNC) 1524 Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it", 1525 type, varname, name); 1526 } 1527 /* Now call the tie function. It should be in *gvp. */ 1528 assert(gvp); assert(*gvp); 1529 PUSHMARK(SP); 1530 XPUSHs((SV *)gv); 1531 PUTBACK; 1532 call_sv((SV *)*gvp, G_VOID|G_DISCARD); 1533 LEAVE; 1534 POPSTACK; 1535 } 1536 } 1537 1538 /* add a require_tie_mod_s - the _s suffix is similar to pvs type suffixes, 1539 * IOW it means we do STR_WITH_LEN() ourselves and the user should pass in 1540 * a true string WITHOUT a len. 1541 */ 1542 #define require_tie_mod_s(gv, varname, name, flags) \ 1543 S_require_tie_mod(aTHX_ gv, varname, STR_WITH_LEN(name), flags) 1544 1545 /* 1546 =for apidoc gv_stashpv 1547 1548 Returns a pointer to the stash for a specified package. Uses C<strlen> to 1549 determine the length of C<name>, then calls C<gv_stashpvn()>. 1550 1551 =cut 1552 */ 1553 1554 HV* 1555 Perl_gv_stashpv(pTHX_ const char *name, I32 create) 1556 { 1557 PERL_ARGS_ASSERT_GV_STASHPV; 1558 return gv_stashpvn(name, strlen(name), create); 1559 } 1560 1561 /* 1562 =for apidoc gv_stashpvn 1563 1564 Returns a pointer to the stash for a specified package. The C<namelen> 1565 parameter indicates the length of the C<name>, in bytes. C<flags> is passed 1566 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be 1567 created if it does not already exist. If the package does not exist and 1568 C<flags> is 0 (or any other setting that does not create packages) then C<NULL> 1569 is returned. 1570 1571 Flags may be one of: 1572 1573 GV_ADD Create and initialize the package if doesn't 1574 already exist 1575 GV_NOADD_NOINIT Don't create the package, 1576 GV_ADDMG GV_ADD iff the GV is magical 1577 GV_NOINIT GV_ADD, but don't initialize 1578 GV_NOEXPAND Don't expand SvOK() entries to PVGV 1579 SVf_UTF8 The name is in UTF-8 1580 1581 The most important of which are probably C<GV_ADD> and C<SVf_UTF8>. 1582 1583 Note, use of C<gv_stashsv> instead of C<gv_stashpvn> where possible is strongly 1584 recommended for performance reasons. 1585 1586 =for apidoc Amnh||GV_ADD 1587 =for apidoc Amnh||GV_NOADD_NOINIT 1588 =for apidoc Amnh||GV_NOINIT 1589 =for apidoc Amnh||GV_NOEXPAND 1590 =for apidoc Amnh||GV_ADDMG 1591 =for apidoc Amnh||SVf_UTF8 1592 1593 =cut 1594 */ 1595 1596 /* 1597 gv_stashpvn_internal 1598 1599 Perform the internal bits of gv_stashsvpvn_cached. You could think of this 1600 as being one half of the logic. Not to be called except from gv_stashsvpvn_cached(). 1601 1602 */ 1603 1604 PERL_STATIC_INLINE HV* 1605 S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags) 1606 { 1607 char smallbuf[128]; 1608 char *tmpbuf; 1609 HV *stash; 1610 GV *tmpgv; 1611 U32 tmplen = namelen + 2; 1612 1613 PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL; 1614 1615 if (tmplen <= sizeof smallbuf) 1616 tmpbuf = smallbuf; 1617 else 1618 Newx(tmpbuf, tmplen, char); 1619 Copy(name, tmpbuf, namelen, char); 1620 tmpbuf[namelen] = ':'; 1621 tmpbuf[namelen+1] = ':'; 1622 tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV); 1623 if (tmpbuf != smallbuf) 1624 Safefree(tmpbuf); 1625 if (!tmpgv || !isGV_with_GP(tmpgv)) 1626 return NULL; 1627 stash = GvHV(tmpgv); 1628 if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL; 1629 assert(stash); 1630 if (!HvHasNAME(stash)) { 1631 hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 ); 1632 1633 /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */ 1634 /* If the containing stash has multiple effective 1635 names, see that this one gets them, too. */ 1636 if (HvAUX(GvSTASH(tmpgv))->xhv_name_count) 1637 mro_package_moved(stash, NULL, tmpgv, 1); 1638 } 1639 return stash; 1640 } 1641 1642 /* 1643 =for apidoc gv_stashsvpvn_cached 1644 1645 Returns a pointer to the stash for a specified package, possibly 1646 cached. Implements both L<perlapi/C<gv_stashpvn>> and 1647 L<perlapi/C<gv_stashsv>>. 1648 1649 Requires one of either C<namesv> or C<namepv> to be non-null. 1650 1651 If the flag C<GV_CACHE_ONLY> is set, return the stash only if found in the 1652 cache; see L<perlapi/C<gv_stashpvn>> for details on the other C<flags>. 1653 1654 Note it is strongly preferred for C<namesv> to be non-null, for performance 1655 reasons. 1656 1657 =for apidoc Emnh||GV_CACHE_ONLY 1658 1659 =cut 1660 */ 1661 1662 #define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \ 1663 assert(namesv || name) 1664 1665 HV* 1666 Perl_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags) 1667 { 1668 HV* stash; 1669 HE* he; 1670 1671 PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED; 1672 1673 he = (HE *)hv_common( 1674 PL_stashcache, namesv, name, namelen, 1675 (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0 1676 ); 1677 1678 if (he) { 1679 SV *sv = HeVAL(he); 1680 HV *hv; 1681 assert(SvIOK(sv)); 1682 hv = INT2PTR(HV*, SvIVX(sv)); 1683 assert(SvTYPE(hv) == SVt_PVHV); 1684 return hv; 1685 } 1686 else if (flags & GV_CACHE_ONLY) return NULL; 1687 1688 if (namesv) { 1689 if (SvOK(namesv)) { /* prevent double uninit warning */ 1690 STRLEN len; 1691 name = SvPV_const(namesv, len); 1692 namelen = len; 1693 flags |= SvUTF8(namesv); 1694 } else { 1695 name = ""; namelen = 0; 1696 } 1697 } 1698 stash = gv_stashpvn_internal(name, namelen, flags); 1699 1700 if (stash && namelen) { 1701 SV* const ref = newSViv(PTR2IV(stash)); 1702 (void)hv_store(PL_stashcache, name, 1703 (flags & SVf_UTF8) ? -(I32)namelen : (I32)namelen, ref, 0); 1704 } 1705 1706 return stash; 1707 } 1708 1709 HV* 1710 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) 1711 { 1712 PERL_ARGS_ASSERT_GV_STASHPVN; 1713 return gv_stashsvpvn_cached(NULL, name, namelen, flags); 1714 } 1715 1716 /* 1717 =for apidoc gv_stashsv 1718 1719 Returns a pointer to the stash for a specified package. See 1720 C<L</gv_stashpvn>>. 1721 1722 Note this interface is strongly preferred over C<gv_stashpvn> for performance 1723 reasons. 1724 1725 =cut 1726 */ 1727 1728 HV* 1729 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags) 1730 { 1731 PERL_ARGS_ASSERT_GV_STASHSV; 1732 return gv_stashsvpvn_cached(sv, NULL, 0, flags); 1733 } 1734 GV * 1735 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 flags, const svtype sv_type) { 1736 PERL_ARGS_ASSERT_GV_FETCHPV; 1737 return gv_fetchpvn_flags(nambeg, strlen(nambeg), flags, sv_type); 1738 } 1739 1740 GV * 1741 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) { 1742 STRLEN len; 1743 const char * const nambeg = 1744 SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC); 1745 PERL_ARGS_ASSERT_GV_FETCHSV; 1746 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type); 1747 } 1748 1749 PERL_STATIC_INLINE void 1750 S_gv_magicalize_isa(pTHX_ GV *gv) 1751 { 1752 AV* av; 1753 1754 PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA; 1755 1756 av = GvAVn(gv); 1757 GvMULTI_on(gv); 1758 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa, 1759 NULL, 0); 1760 1761 if(HvSTASH_IS_CLASS(GvSTASH(gv))) { 1762 /* Don't permit modification of @ISA outside of the class management 1763 * code. This is temporarily undone by class.c when fiddling with the 1764 * array, so it knows it can be done safely. 1765 */ 1766 SvREADONLY_on((SV *)av); 1767 } 1768 } 1769 1770 /* This function grabs name and tries to split a stash and glob 1771 * from its contents. TODO better description, comments 1772 * 1773 * If the function returns TRUE and 'name == name_end', then 1774 * 'gv' can be directly returned to the caller of gv_fetchpvn_flags 1775 */ 1776 PERL_STATIC_INLINE bool 1777 S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, 1778 STRLEN *len, const char *nambeg, STRLEN full_len, 1779 const U32 is_utf8, const I32 add) 1780 { 1781 char *tmpfullbuf = NULL; /* only malloc one big chunk of memory when the smallbuff is not large enough */ 1782 const char *name_cursor; 1783 const char *const name_end = nambeg + full_len; 1784 const char *const name_em1 = name_end - 1; 1785 char smallbuf[64]; /* small buffer to avoid a malloc when possible */ 1786 1787 PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME; 1788 1789 if ( full_len > 2 1790 && **name == '*' 1791 && isIDFIRST_lazy_if_safe(*name + 1, name_end, is_utf8)) 1792 { 1793 /* accidental stringify on a GV? */ 1794 (*name)++; 1795 } 1796 1797 for (name_cursor = *name; name_cursor < name_end; name_cursor++) { 1798 if (name_cursor < name_em1 && 1799 ((*name_cursor == ':' && name_cursor[1] == ':') 1800 || *name_cursor == '\'')) 1801 { 1802 if (!*stash) 1803 *stash = PL_defstash; 1804 if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */ 1805 goto notok; 1806 1807 *len = name_cursor - *name; 1808 if (name_cursor > nambeg) { /* Skip for initial :: or ' */ 1809 const char *key; 1810 GV**gvp; 1811 if (*name_cursor == ':') { 1812 key = *name; 1813 *len += 2; 1814 } 1815 else { /* using ' for package separator */ 1816 /* use our pre-allocated buffer when possible to save a malloc */ 1817 char *tmpbuf; 1818 if ( *len+2 <= sizeof smallbuf) 1819 tmpbuf = smallbuf; 1820 else { 1821 /* only malloc once if needed */ 1822 if (tmpfullbuf == NULL) /* only malloc&free once, a little more than needed */ 1823 Newx(tmpfullbuf, full_len+2, char); 1824 tmpbuf = tmpfullbuf; 1825 } 1826 Copy(*name, tmpbuf, *len, char); 1827 tmpbuf[(*len)++] = ':'; 1828 tmpbuf[(*len)++] = ':'; 1829 key = tmpbuf; 1830 } 1831 gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add); 1832 *gv = gvp ? *gvp : NULL; 1833 if (!*gv || *gv == (const GV *)&PL_sv_undef) { 1834 goto notok; 1835 } 1836 /* here we know that *gv && *gv != &PL_sv_undef */ 1837 if (SvTYPE(*gv) != SVt_PVGV) 1838 gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8); 1839 else 1840 GvMULTI_on(*gv); 1841 1842 if (!(*stash = GvHV(*gv))) { 1843 *stash = GvHV(*gv) = newHV(); 1844 if (!HvHasNAME(*stash)) { 1845 if (GvSTASH(*gv) == PL_defstash && *len == 6 1846 && strBEGINs(*name, "CORE")) 1847 hv_name_sets(*stash, "CORE", 0); 1848 else 1849 hv_name_set( 1850 *stash, nambeg, name_cursor-nambeg, is_utf8 1851 ); 1852 /* If the containing stash has multiple effective 1853 names, see that this one gets them, too. */ 1854 if (HvAUX(GvSTASH(*gv))->xhv_name_count) 1855 mro_package_moved(*stash, NULL, *gv, 1); 1856 } 1857 } 1858 else if (!HvHasNAME(*stash)) 1859 hv_name_set(*stash, nambeg, name_cursor - nambeg, is_utf8); 1860 } 1861 1862 if (*name_cursor == ':') 1863 name_cursor++; 1864 *name = name_cursor+1; 1865 if (*name == name_end) { 1866 if (!*gv) { 1867 *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE)); 1868 if (SvTYPE(*gv) != SVt_PVGV) { 1869 gv_init_pvn(*gv, PL_defstash, "main::", 6, 1870 GV_ADDMULTI); 1871 GvHV(*gv) = 1872 MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash)); 1873 } 1874 } 1875 goto ok; 1876 } 1877 } 1878 } 1879 *len = name_cursor - *name; 1880 ok: 1881 Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */ 1882 return TRUE; 1883 notok: 1884 Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */ 1885 return FALSE; 1886 } 1887 1888 1889 /* Checks if an unqualified name is in the main stash */ 1890 PERL_STATIC_INLINE bool 1891 S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8) 1892 { 1893 PERL_ARGS_ASSERT_GV_IS_IN_MAIN; 1894 1895 /* If it's an alphanumeric variable */ 1896 if ( len && isIDFIRST_lazy_if_safe(name, name + len, is_utf8) ) { 1897 /* Some "normal" variables are always in main::, 1898 * like INC or STDOUT. 1899 */ 1900 switch (len) { 1901 case 1: 1902 if (*name == '_') 1903 return TRUE; 1904 break; 1905 case 3: 1906 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C') 1907 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V') 1908 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G')) 1909 return TRUE; 1910 break; 1911 case 4: 1912 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G' 1913 && name[3] == 'V') 1914 return TRUE; 1915 break; 1916 case 5: 1917 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D' 1918 && name[3] == 'I' && name[4] == 'N') 1919 return TRUE; 1920 break; 1921 case 6: 1922 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D') 1923 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T') 1924 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R'))) 1925 return TRUE; 1926 break; 1927 case 7: 1928 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G' 1929 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U' 1930 && name[6] == 'T') 1931 return TRUE; 1932 break; 1933 } 1934 } 1935 /* *{""}, or a special variable like $@ */ 1936 else 1937 return TRUE; 1938 1939 return FALSE; 1940 } 1941 1942 1943 /* This function is called if parse_gv_stash_name() failed to 1944 * find a stash, or if GV_NOTQUAL or an empty name was passed 1945 * to gv_fetchpvn_flags. 1946 * 1947 * It returns FALSE if the default stash can't be found nor created, 1948 * which might happen during global destruction. 1949 */ 1950 PERL_STATIC_INLINE bool 1951 S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len, 1952 const U32 is_utf8, const I32 add, 1953 const svtype sv_type) 1954 { 1955 PERL_ARGS_ASSERT_FIND_DEFAULT_STASH; 1956 1957 /* No stash in name, so see how we can default */ 1958 1959 if ( gv_is_in_main(name, len, is_utf8) ) { 1960 *stash = PL_defstash; 1961 } 1962 else { 1963 if (IN_PERL_COMPILETIME) { 1964 *stash = PL_curstash; 1965 if (add && (PL_hints & HINT_STRICT_VARS) && 1966 sv_type != SVt_PVCV && 1967 sv_type != SVt_PVGV && 1968 sv_type != SVt_PVFM && 1969 sv_type != SVt_PVIO && 1970 !(len == 1 && sv_type == SVt_PV && 1971 (*name == 'a' || *name == 'b')) ) 1972 { 1973 GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -(I32)len : (I32)len,0); 1974 if (!gvp || *gvp == (const GV *)&PL_sv_undef || 1975 SvTYPE(*gvp) != SVt_PVGV) 1976 { 1977 *stash = NULL; 1978 } 1979 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) || 1980 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) || 1981 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) ) 1982 { 1983 /* diag_listed_as: Variable "%s" is not imported%s */ 1984 Perl_ck_warner_d( 1985 aTHX_ packWARN(WARN_MISC), 1986 "Variable \"%c%" UTF8f "\" is not imported", 1987 sv_type == SVt_PVAV ? '@' : 1988 sv_type == SVt_PVHV ? '%' : '$', 1989 UTF8fARG(is_utf8, len, name)); 1990 if (GvCVu(*gvp)) 1991 Perl_ck_warner_d( 1992 aTHX_ packWARN(WARN_MISC), 1993 "\t(Did you mean &%" UTF8f " instead?)\n", 1994 UTF8fARG(is_utf8, len, name) 1995 ); 1996 *stash = NULL; 1997 } 1998 } 1999 } 2000 else { 2001 /* Use the current op's stash */ 2002 *stash = CopSTASH(PL_curcop); 2003 } 2004 } 2005 2006 if (!*stash) { 2007 if (add && !PL_in_clean_all) { 2008 GV *gv; 2009 qerror(Perl_mess(aTHX_ 2010 "Global symbol \"%s%" UTF8f 2011 "\" requires explicit package name (did you forget to " 2012 "declare \"my %s%" UTF8f "\"?)", 2013 (sv_type == SVt_PV ? "$" 2014 : sv_type == SVt_PVAV ? "@" 2015 : sv_type == SVt_PVHV ? "%" 2016 : ""), UTF8fARG(is_utf8, len, name), 2017 (sv_type == SVt_PV ? "$" 2018 : sv_type == SVt_PVAV ? "@" 2019 : sv_type == SVt_PVHV ? "%" 2020 : ""), UTF8fARG(is_utf8, len, name))); 2021 /* To maintain the output of errors after the strict exception 2022 * above, and to keep compat with older releases, rather than 2023 * placing the variables in the pad, we place 2024 * them in the <none>:: stash. 2025 */ 2026 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV); 2027 if (!gv) { 2028 /* symbol table under destruction */ 2029 return FALSE; 2030 } 2031 *stash = GvHV(gv); 2032 } 2033 else 2034 return FALSE; 2035 } 2036 2037 if (!SvREFCNT(*stash)) /* symbol table under destruction */ 2038 return FALSE; 2039 2040 return TRUE; 2041 } 2042 2043 /* gv_magicalize only turns on the SVf_READONLY flag, not SVf_PROTECT. So 2044 redefine SvREADONLY_on for that purpose. We don’t use it later on in 2045 this file. */ 2046 #undef SvREADONLY_on 2047 #define SvREADONLY_on(sv) (SvFLAGS(sv) |= SVf_READONLY) 2048 2049 /* gv_magicalize() is called by gv_fetchpvn_flags when creating 2050 * a new GV. 2051 * Note that it does not insert the GV into the stash prior to 2052 * magicalization, which some variables require need in order 2053 * to work (like %+, %-, %!), so callers must take care of 2054 * that. 2055 * 2056 * It returns true if the gv did turn out to be magical one; i.e., 2057 * if gv_magicalize actually did something. 2058 */ 2059 PERL_STATIC_INLINE bool 2060 S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, 2061 const svtype sv_type) 2062 { 2063 SSize_t paren; 2064 2065 PERL_ARGS_ASSERT_GV_MAGICALIZE; 2066 2067 if (stash != PL_defstash) { /* not the main stash */ 2068 /* We only have to check for a few names here: a, b, EXPORT, ISA 2069 and VERSION. All the others apply only to the main stash or to 2070 CORE (which is checked right after this). */ 2071 if (len) { 2072 switch (*name) { 2073 case 'E': 2074 if ( 2075 len >= 6 && name[1] == 'X' && 2076 (memEQs(name, len, "EXPORT") 2077 ||memEQs(name, len, "EXPORT_OK") 2078 ||memEQs(name, len, "EXPORT_FAIL") 2079 ||memEQs(name, len, "EXPORT_TAGS")) 2080 ) 2081 GvMULTI_on(gv); 2082 break; 2083 case 'I': 2084 if (memEQs(name, len, "ISA")) 2085 gv_magicalize_isa(gv); 2086 break; 2087 case 'V': 2088 if (memEQs(name, len, "VERSION")) 2089 GvMULTI_on(gv); 2090 break; 2091 case 'a': 2092 if (stash == PL_debstash && memEQs(name, len, "args")) { 2093 GvMULTI_on(gv_AVadd(gv)); 2094 break; 2095 } 2096 /* FALLTHROUGH */ 2097 case 'b': 2098 if (len == 1 && sv_type == SVt_PV) 2099 GvMULTI_on(gv); 2100 /* FALLTHROUGH */ 2101 default: 2102 goto try_core; 2103 } 2104 goto ret; 2105 } 2106 try_core: 2107 if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) { 2108 /* Avoid null warning: */ 2109 const char * const stashname = HvNAME(stash); assert(stashname); 2110 if (strBEGINs(stashname, "CORE")) 2111 S_maybe_add_coresub(aTHX_ 0, gv, name, len); 2112 } 2113 } 2114 else if (len > 1) { 2115 #ifndef EBCDIC 2116 if (*name > 'V' ) { 2117 NOOP; 2118 /* Nothing else to do. 2119 The compiler will probably turn the switch statement into a 2120 branch table. Make sure we avoid even that small overhead for 2121 the common case of lower case variable names. (On EBCDIC 2122 platforms, we can't just do: 2123 if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) { 2124 because cases like '\027' in the switch statement below are 2125 C1 (non-ASCII) controls on those platforms, so the remapping 2126 would make them larger than 'V') 2127 */ 2128 } else 2129 #endif 2130 { 2131 switch (*name) { 2132 case 'A': 2133 if (memEQs(name, len, "ARGV")) { 2134 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; 2135 } 2136 else if (memEQs(name, len, "ARGVOUT")) { 2137 GvMULTI_on(gv); 2138 } 2139 break; 2140 case 'E': 2141 if ( 2142 len >= 6 && name[1] == 'X' && 2143 (memEQs(name, len, "EXPORT") 2144 ||memEQs(name, len, "EXPORT_OK") 2145 ||memEQs(name, len, "EXPORT_FAIL") 2146 ||memEQs(name, len, "EXPORT_TAGS")) 2147 ) 2148 GvMULTI_on(gv); 2149 break; 2150 case 'I': 2151 if (memEQs(name, len, "ISA")) { 2152 gv_magicalize_isa(gv); 2153 } 2154 break; 2155 case 'S': 2156 if (memEQs(name, len, "SIG")) { 2157 HV *hv; 2158 I32 i; 2159 if (!PL_psig_name) { 2160 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*); 2161 Newxz(PL_psig_pend, SIG_SIZE, int); 2162 PL_psig_ptr = PL_psig_name + SIG_SIZE; 2163 } else { 2164 /* I think that the only way to get here is to re-use an 2165 embedded perl interpreter, where the previous 2166 use didn't clean up fully because 2167 PL_perl_destruct_level was 0. I'm not sure that we 2168 "support" that, in that I suspect in that scenario 2169 there are sufficient other garbage values left in the 2170 interpreter structure that something else will crash 2171 before we get here. I suspect that this is one of 2172 those "doctor, it hurts when I do this" bugs. */ 2173 Zero(PL_psig_name, 2 * SIG_SIZE, SV*); 2174 Zero(PL_psig_pend, SIG_SIZE, int); 2175 } 2176 GvMULTI_on(gv); 2177 hv = GvHVn(gv); 2178 hv_magic(hv, NULL, PERL_MAGIC_sig); 2179 for (i = 1; i < SIG_SIZE; i++) { 2180 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1); 2181 if (init) 2182 sv_setsv(*init, &PL_sv_undef); 2183 } 2184 } 2185 break; 2186 case 'V': 2187 if (memEQs(name, len, "VERSION")) 2188 GvMULTI_on(gv); 2189 break; 2190 case '\003': /* $^CHILD_ERROR_NATIVE */ 2191 if (memEQs(name, len, "\003HILD_ERROR_NATIVE")) 2192 goto magicalize; 2193 /* @{^CAPTURE} %{^CAPTURE} */ 2194 if (memEQs(name, len, "\003APTURE")) { 2195 AV* const av = GvAVn(gv); 2196 const Size_t n = *name; 2197 2198 sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0); 2199 SvREADONLY_on(av); 2200 2201 require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0); 2202 2203 } else /* %{^CAPTURE_ALL} */ 2204 if (memEQs(name, len, "\003APTURE_ALL")) { 2205 require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0); 2206 } 2207 break; 2208 case '\005': /* ${^ENCODING} */ 2209 if (memEQs(name, len, "\005NCODING")) 2210 goto magicalize; 2211 break; 2212 case '\007': /* ${^GLOBAL_PHASE} */ 2213 if (memEQs(name, len, "\007LOBAL_PHASE")) 2214 goto ro_magicalize; 2215 break; 2216 case '\010': /* %{^HOOK} */ 2217 if (memEQs(name, len, "\010OOK")) { 2218 GvMULTI_on(gv); 2219 HV *hv = GvHVn(gv); 2220 hv_magic(hv, NULL, PERL_MAGIC_hook); 2221 } 2222 break; 2223 case '\014': 2224 if ( memEQs(name, len, "\014AST_FH") || /* ${^LAST_FH} */ 2225 memEQs(name, len, "\014AST_SUCCESSFUL_PATTERN")) /* ${^LAST_SUCCESSFUL_PATTERN} */ 2226 goto ro_magicalize; 2227 break; 2228 case '\015': /* ${^MATCH} */ 2229 if (memEQs(name, len, "\015ATCH")) { 2230 paren = RX_BUFF_IDX_CARET_FULLMATCH; 2231 goto storeparen; 2232 } 2233 break; 2234 case '\017': /* ${^OPEN} */ 2235 if (memEQs(name, len, "\017PEN")) 2236 goto magicalize; 2237 break; 2238 case '\020': /* ${^PREMATCH} ${^POSTMATCH} */ 2239 if (memEQs(name, len, "\020REMATCH")) { 2240 paren = RX_BUFF_IDX_CARET_PREMATCH; 2241 goto storeparen; 2242 } 2243 if (memEQs(name, len, "\020OSTMATCH")) { 2244 paren = RX_BUFF_IDX_CARET_POSTMATCH; 2245 goto storeparen; 2246 } 2247 break; 2248 case '\023': 2249 if (memEQs(name, len, "\023AFE_LOCALES")) 2250 goto ro_magicalize; 2251 break; 2252 case '\024': /* ${^TAINT} */ 2253 if (memEQs(name, len, "\024AINT")) 2254 goto ro_magicalize; 2255 break; 2256 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */ 2257 if (memEQs(name, len, "\025NICODE")) 2258 goto ro_magicalize; 2259 if (memEQs(name, len, "\025TF8LOCALE")) 2260 goto ro_magicalize; 2261 if (memEQs(name, len, "\025TF8CACHE")) 2262 goto magicalize; 2263 break; 2264 case '\027': /* $^WARNING_BITS */ 2265 if (memEQs(name, len, "\027ARNING_BITS")) 2266 goto magicalize; 2267 #ifdef WIN32 2268 else if (memEQs(name, len, "\027IN32_SLOPPY_STAT")) 2269 goto magicalize; 2270 #endif 2271 break; 2272 case '1': 2273 case '2': 2274 case '3': 2275 case '4': 2276 case '5': 2277 case '6': 2278 case '7': 2279 case '8': 2280 case '9': 2281 { 2282 /* Ensures that we have an all-digit variable, ${"1foo"} fails 2283 this test */ 2284 UV uv; 2285 if (!grok_atoUV(name, &uv, NULL) || uv > I32_MAX) 2286 goto ret; 2287 /* XXX why are we using a SSize_t? */ 2288 paren = (SSize_t)(I32)uv; 2289 goto storeparen; 2290 } 2291 } 2292 } 2293 } else { 2294 /* Names of length 1. (Or 0. But name is NUL terminated, so that will 2295 be case '\0' in this switch statement (ie a default case) */ 2296 switch (*name) { 2297 case '&': /* $& */ 2298 paren = RX_BUFF_IDX_FULLMATCH; 2299 goto sawampersand; 2300 case '`': /* $` */ 2301 paren = RX_BUFF_IDX_PREMATCH; 2302 goto sawampersand; 2303 case '\'': /* $' */ 2304 paren = RX_BUFF_IDX_POSTMATCH; 2305 sawampersand: 2306 #ifdef PERL_SAWAMPERSAND 2307 if (!( 2308 sv_type == SVt_PVAV || 2309 sv_type == SVt_PVHV || 2310 sv_type == SVt_PVCV || 2311 sv_type == SVt_PVFM || 2312 sv_type == SVt_PVIO 2313 )) { PL_sawampersand |= 2314 (*name == '`') 2315 ? SAWAMPERSAND_LEFT 2316 : (*name == '&') 2317 ? SAWAMPERSAND_MIDDLE 2318 : SAWAMPERSAND_RIGHT; 2319 } 2320 #endif 2321 goto storeparen; 2322 case '1': /* $1 */ 2323 case '2': /* $2 */ 2324 case '3': /* $3 */ 2325 case '4': /* $4 */ 2326 case '5': /* $5 */ 2327 case '6': /* $6 */ 2328 case '7': /* $7 */ 2329 case '8': /* $8 */ 2330 case '9': /* $9 */ 2331 paren = *name - '0'; 2332 2333 storeparen: 2334 /* Flag the capture variables with a NULL mg_ptr 2335 Use mg_len for the array index to lookup. */ 2336 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren); 2337 break; 2338 2339 case ':': /* $: */ 2340 sv_setpv(GvSVn(gv),PL_chopset); 2341 goto magicalize; 2342 2343 case '?': /* $? */ 2344 #ifdef COMPLEX_STATUS 2345 SvUPGRADE(GvSVn(gv), SVt_PVLV); 2346 #endif 2347 goto magicalize; 2348 2349 case '!': /* $! */ 2350 GvMULTI_on(gv); 2351 /* If %! has been used, automatically load Errno.pm. */ 2352 2353 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); 2354 2355 /* magicalization must be done before require_tie_mod_s is called */ 2356 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) 2357 require_tie_mod_s(gv, '!', "Errno", 1); 2358 2359 break; 2360 case '-': /* $-, %-, @- */ 2361 case '+': /* $+, %+, @+ */ 2362 GvMULTI_on(gv); /* no used once warnings here */ 2363 { /* $- $+ */ 2364 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); 2365 if (*name == '+') 2366 SvREADONLY_on(GvSVn(gv)); 2367 } 2368 { /* %- %+ */ 2369 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) 2370 require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture",0); 2371 } 2372 { /* @- @+ */ 2373 AV* const av = GvAVn(gv); 2374 const Size_t n = *name; 2375 2376 sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0); 2377 SvREADONLY_on(av); 2378 } 2379 break; 2380 case '*': /* $* */ 2381 case '#': /* $# */ 2382 if (sv_type == SVt_PV) 2383 /* diag_listed_as: $* is no longer supported as of Perl 5.30 */ 2384 Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name); 2385 break; 2386 case '\010': /* $^H */ 2387 { 2388 HV *const hv = GvHVn(gv); 2389 hv_magic(hv, NULL, PERL_MAGIC_hints); 2390 } 2391 goto magicalize; 2392 case '\023': /* $^S */ 2393 ro_magicalize: 2394 SvREADONLY_on(GvSVn(gv)); 2395 /* FALLTHROUGH */ 2396 case '0': /* $0 */ 2397 case '^': /* $^ */ 2398 case '~': /* $~ */ 2399 case '=': /* $= */ 2400 case '%': /* $% */ 2401 case '.': /* $. */ 2402 case '(': /* $( */ 2403 case ')': /* $) */ 2404 case '<': /* $< */ 2405 case '>': /* $> */ 2406 case '\\': /* $\ */ 2407 case '/': /* $/ */ 2408 case '|': /* $| */ 2409 case '$': /* $$ */ 2410 case '[': /* $[ */ 2411 case '\001': /* $^A */ 2412 case '\003': /* $^C */ 2413 case '\004': /* $^D */ 2414 case '\005': /* $^E */ 2415 case '\006': /* $^F */ 2416 case '\011': /* $^I, NOT \t in EBCDIC */ 2417 case '\016': /* $^N */ 2418 case '\017': /* $^O */ 2419 case '\020': /* $^P */ 2420 case '\024': /* $^T */ 2421 case '\027': /* $^W */ 2422 magicalize: 2423 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); 2424 break; 2425 2426 case '\014': /* $^L */ 2427 sv_setpvs(GvSVn(gv),"\f"); 2428 break; 2429 case ';': /* $; */ 2430 sv_setpvs(GvSVn(gv),"\034"); 2431 break; 2432 case ']': /* $] */ 2433 { 2434 SV * const sv = GvSV(gv); 2435 if (!sv_derived_from(PL_patchlevel, "version")) 2436 upg_version(PL_patchlevel, TRUE); 2437 GvSV(gv) = vnumify(PL_patchlevel); 2438 SvREADONLY_on(GvSV(gv)); 2439 SvREFCNT_dec(sv); 2440 } 2441 break; 2442 case '\026': /* $^V */ 2443 { 2444 SV * const sv = GvSV(gv); 2445 GvSV(gv) = new_version(PL_patchlevel); 2446 SvREADONLY_on(GvSV(gv)); 2447 SvREFCNT_dec(sv); 2448 } 2449 break; 2450 case 'a': 2451 case 'b': 2452 if (sv_type == SVt_PV) 2453 GvMULTI_on(gv); 2454 } 2455 } 2456 2457 ret: 2458 /* Return true if we actually did something. */ 2459 return GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) 2460 || ( GvSV(gv) && ( 2461 SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)) 2462 ) 2463 ); 2464 } 2465 2466 /* If we do ever start using this later on in the file, we need to make 2467 sure we don’t accidentally use the wrong definition. */ 2468 #undef SvREADONLY_on 2469 2470 /* This function is called when the stash already holds the GV of the magic 2471 * variable we're looking for, but we need to check that it has the correct 2472 * kind of magic. For example, if someone first uses $! and then %!, the 2473 * latter would end up here, and we add the Errno tie to the HASH slot of 2474 * the *! glob. 2475 */ 2476 PERL_STATIC_INLINE void 2477 S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type) 2478 { 2479 PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV; 2480 2481 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) { 2482 if (*name == '!') 2483 require_tie_mod_s(gv, '!', "Errno", 1); 2484 else if (*name == '-' || *name == '+') 2485 require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture", 0); 2486 } else if (sv_type == SVt_PV) { 2487 if (*name == '*' || *name == '#') { 2488 /* diag_listed_as: $* is no longer supported as of Perl 5.30 */ 2489 Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name); 2490 } 2491 } 2492 if (sv_type==SVt_PV || sv_type==SVt_PVGV) { 2493 switch (*name) { 2494 #ifdef PERL_SAWAMPERSAND 2495 case '`': 2496 PL_sawampersand |= SAWAMPERSAND_LEFT; 2497 (void)GvSVn(gv); 2498 break; 2499 case '&': 2500 PL_sawampersand |= SAWAMPERSAND_MIDDLE; 2501 (void)GvSVn(gv); 2502 break; 2503 case '\'': 2504 PL_sawampersand |= SAWAMPERSAND_RIGHT; 2505 (void)GvSVn(gv); 2506 break; 2507 #endif 2508 } 2509 } 2510 } 2511 2512 /* 2513 =for apidoc gv_fetchpv 2514 =for apidoc_item |GV *|gv_fetchpvn|const char * nambeg|STRLEN full_len|I32 flags|const svtype sv_type 2515 =for apidoc_item ||gv_fetchpvn_flags 2516 =for apidoc_item |GV *|gv_fetchpvs|"name"|I32 flags|const svtype sv_type 2517 =for apidoc_item ||gv_fetchsv 2518 =for apidoc_item |GV *|gv_fetchsv_nomg|SV *name|I32 flags|const svtype sv_type 2519 2520 These all return the GV of type C<sv_type> whose name is given by the inputs, 2521 or NULL if no GV of that name and type could be found. See L<perlguts/Stashes 2522 and Globs>. 2523 2524 The only differences are how the input name is specified, and if 'get' magic is 2525 normally used in getting that name. 2526 2527 Don't be fooled by the fact that only one form has C<flags> in its name. They 2528 all have a C<flags> parameter in fact, and all the flag bits have the same 2529 meanings for all 2530 2531 If any of the flags C<GV_ADD>, C<GV_ADDMG>, C<GV_ADDWARN>, C<GV_ADDMULTI>, or 2532 C<GV_NOINIT> is set, a GV is created if none already exists for the input name 2533 and type. However, C<GV_ADDMG> will only do the creation for magical GV's. 2534 For all of these flags except C<GV_NOINIT>, C<L</gv_init_pvn>> is called after 2535 the addition. C<GV_ADDWARN> is used when the caller expects that adding won't 2536 be necessary because the symbol should already exist; but if not, add it 2537 anyway, with a warning that it was unexpectedly absent. The C<GV_ADDMULTI> 2538 flag means to pretend that the GV has been seen before (I<i.e.>, suppress "Used 2539 once" warnings). 2540 2541 The flag C<GV_NOADD_NOINIT> causes C<L</gv_init_pvn>> not be to called if the 2542 GV existed but isn't PVGV. 2543 2544 If the C<SVf_UTF8> bit is set, the name is treated as being encoded in UTF-8; 2545 otherwise the name won't be considered to be UTF-8 in the C<pv>-named forms, 2546 and the UTF-8ness of the underlying SVs will be used in the C<sv> forms. 2547 2548 If the flag C<GV_NOTQUAL> is set, the caller warrants that the input name is a 2549 plain symbol name, not qualified with a package, otherwise the name is checked 2550 for being a qualified one. 2551 2552 In C<gv_fetchpv>, C<nambeg> is a C string, NUL-terminated with no intermediate 2553 NULs. 2554 2555 In C<gv_fetchpvs>, C<name> is a literal C string, hence is enclosed in 2556 double quotes. 2557 2558 C<gv_fetchpvn> and C<gv_fetchpvn_flags> are identical. In these, <nambeg> is 2559 a Perl string whose byte length is given by C<full_len>, and may contain 2560 embedded NULs. 2561 2562 In C<gv_fetchsv> and C<gv_fetchsv_nomg>, the name is extracted from the PV of 2563 the input C<name> SV. The only difference between these two forms is that 2564 'get' magic is normally done on C<name> in C<gv_fetchsv>, and always skipped 2565 with C<gv_fetchsv_nomg>. Including C<GV_NO_SVGMAGIC> in the C<flags> parameter 2566 to C<gv_fetchsv> makes it behave identically to C<gv_fetchsv_nomg>. 2567 2568 =for apidoc Amnh||GV_ADD 2569 =for apidoc Amnh||GV_ADDMG 2570 =for apidoc Amnh||GV_ADDMULTI 2571 =for apidoc Amnh||GV_ADDWARN 2572 =for apidoc Amnh||GV_NOINIT 2573 =for apidoc Amnh||GV_NOADD_NOINIT 2574 =for apidoc Amnh||GV_NOTQUAL 2575 =for apidoc Amnh||GV_NO_SVGMAGIC 2576 =for apidoc Amnh||SVf_UTF8 2577 2578 =cut 2579 */ 2580 2581 GV * 2582 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, 2583 const svtype sv_type) 2584 { 2585 const char *name = nambeg; 2586 GV *gv = NULL; 2587 GV**gvp; 2588 STRLEN len; 2589 HV *stash = NULL; 2590 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT); 2591 const I32 no_expand = flags & GV_NOEXPAND; 2592 const I32 add = flags & ~GV_NOADD_MASK; 2593 const U32 is_utf8 = flags & SVf_UTF8; 2594 bool addmg = cBOOL(flags & GV_ADDMG); 2595 const char *const name_end = nambeg + full_len; 2596 U32 faking_it; 2597 2598 PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS; 2599 2600 /* If we have GV_NOTQUAL, the caller promised that 2601 * there is no stash, so we can skip the check. 2602 * Similarly if full_len is 0, since then we're 2603 * dealing with something like *{""} or ""->foo() 2604 */ 2605 if ((flags & GV_NOTQUAL) || !full_len) { 2606 len = full_len; 2607 } 2608 else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) { 2609 if (name == name_end) return gv; 2610 } 2611 else { 2612 return NULL; 2613 } 2614 2615 if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) { 2616 return NULL; 2617 } 2618 2619 /* By this point we should have a stash and a name */ 2620 gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add); 2621 if (!gvp || *gvp == (const GV *)&PL_sv_undef) { 2622 if (addmg) gv = (GV *)newSV_type(SVt_NULL); /* tentatively */ 2623 else return NULL; 2624 } 2625 else gv = *gvp, addmg = 0; 2626 /* From this point on, addmg means gv has not been inserted in the 2627 symtab yet. */ 2628 2629 if (SvTYPE(gv) == SVt_PVGV) { 2630 /* The GV already exists, so return it, but check if we need to do 2631 * anything else with it before that. 2632 */ 2633 if (add) { 2634 /* This is the heuristic that handles if a variable triggers the 2635 * 'used only once' warning. If there's already a GV in the stash 2636 * with this name, then we assume that the variable has been used 2637 * before and turn its MULTI flag on. 2638 * It's a heuristic because it can easily be "tricked", like with 2639 * BEGIN { $a = 1; $::{foo} = *a }; () = $foo 2640 * not warning about $main::foo being used just once 2641 */ 2642 GvMULTI_on(gv); 2643 gv_init_svtype(gv, sv_type); 2644 /* You reach this path once the typeglob has already been created, 2645 either by the same or a different sigil. If this path didn't 2646 exist, then (say) referencing $! first, and %! second would 2647 mean that %! was not handled correctly. */ 2648 if (len == 1 && stash == PL_defstash) { 2649 maybe_multimagic_gv(gv, name, sv_type); 2650 } 2651 else if (sv_type == SVt_PVAV 2652 && memEQs(name, len, "ISA") 2653 && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv)))) 2654 gv_magicalize_isa(gv); 2655 } 2656 return gv; 2657 } else if (no_init) { 2658 assert(!addmg); 2659 return gv; 2660 } 2661 /* If GV_NOEXPAND is true and what we got off the stash is a ref, 2662 * don't expand it to a glob. This is an optimization so that things 2663 * copying constants over, like Exporter, don't have to be rewritten 2664 * to take into account that you can store more than just globs in 2665 * stashes. 2666 */ 2667 else if (no_expand && SvROK(gv)) { 2668 assert(!addmg); 2669 return gv; 2670 } 2671 2672 /* Adding a new symbol. 2673 Unless of course there was already something non-GV here, in which case 2674 we want to behave as if there was always a GV here, containing some sort 2675 of subroutine. 2676 Otherwise we run the risk of creating things like GvIO, which can cause 2677 subtle bugs. eg the one that tripped up SQL::Translator */ 2678 2679 faking_it = SvOK(gv); 2680 2681 if (add & GV_ADDWARN) 2682 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), 2683 "Had to create %" UTF8f " unexpectedly", 2684 UTF8fARG(is_utf8, name_end-nambeg, nambeg)); 2685 gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8); 2686 2687 if ( full_len != 0 2688 && isIDFIRST_lazy_if_safe(name, name + full_len, is_utf8)) { 2689 if (ckWARN(WARN_ONCE)) { 2690 if (ckDEAD(WARN_ONCE)) 2691 GvONCE_FATAL_on(gv); 2692 } 2693 else { 2694 GvMULTI_on(gv) ; 2695 } 2696 } 2697 2698 /* set up magic where warranted */ 2699 if ( gv_magicalize(gv, stash, name, len, sv_type) ) { 2700 /* See 23496c6 */ 2701 if (addmg) { 2702 /* gv_magicalize magicalised this gv, so we want it 2703 * stored in the symtab. 2704 * Effectively the caller is asking, ‘Does this gv exist?’ 2705 * And we respond, ‘Er, *now* it does!’ 2706 */ 2707 (void)hv_store(stash,name,len,(SV *)gv,0); 2708 } 2709 } 2710 else if (addmg) { 2711 /* The temporary GV created above */ 2712 SvREFCNT_dec_NN(gv); 2713 gv = NULL; 2714 } 2715 2716 if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type); 2717 return gv; 2718 } 2719 2720 /* 2721 =for apidoc gv_efullname3 2722 =for apidoc_item gv_efullname4 2723 =for apidoc_item gv_fullname3 2724 =for apidoc_item gv_fullname4 2725 2726 Place the full package name of C<gv> into C<sv>. The C<gv_e*> forms return 2727 instead the effective package name (see L</HvENAME>). 2728 2729 If C<prefix> is non-NULL, it is considered to be a C language NUL-terminated 2730 string, and the stored name will be prefaced with it. 2731 2732 The other difference between the functions is that the C<*4> forms have an 2733 extra parameter, C<keepmain>. If C<true> an initial C<main::> in the name is 2734 kept; if C<false> it is stripped. With the C<*3> forms, it is always kept. 2735 2736 =cut 2737 */ 2738 2739 void 2740 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) 2741 { 2742 const char *name; 2743 const HV * const hv = GvSTASH(gv); 2744 2745 PERL_ARGS_ASSERT_GV_FULLNAME4; 2746 2747 sv_setpv(sv, prefix ? prefix : ""); 2748 2749 if (hv && (name = HvNAME(hv))) { 2750 const STRLEN len = HvNAMELEN(hv); 2751 if (keepmain || ! memBEGINs(name, len, "main")) { 2752 sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES); 2753 sv_catpvs(sv,"::"); 2754 } 2755 } 2756 else sv_catpvs(sv,"__ANON__::"); 2757 sv_catsv(sv,newSVhek_mortal(GvNAME_HEK(gv))); 2758 } 2759 2760 void 2761 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) 2762 { 2763 const GV * const egv = GvEGVx(gv); 2764 2765 PERL_ARGS_ASSERT_GV_EFULLNAME4; 2766 2767 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain); 2768 } 2769 2770 2771 /* recursively scan a stash and any nested stashes looking for entries 2772 * that need the "only used once" warning raised 2773 */ 2774 2775 void 2776 Perl_gv_check(pTHX_ HV *stash) 2777 { 2778 I32 i; 2779 2780 PERL_ARGS_ASSERT_GV_CHECK; 2781 2782 if (!HvHasAUX(stash)) 2783 return; 2784 2785 assert(HvARRAY(stash)); 2786 2787 /* mark stash is being scanned, to avoid recursing */ 2788 HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH; 2789 for (i = 0; i <= (I32) HvMAX(stash); i++) { 2790 const HE *entry; 2791 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { 2792 GV *gv; 2793 HV *hv; 2794 STRLEN keylen = HeKLEN(entry); 2795 const char * const key = HeKEY(entry); 2796 2797 if (keylen >= 2 && key[keylen-2] == ':' && key[keylen-1] == ':' && 2798 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv))) 2799 { 2800 if (hv != PL_defstash && hv != stash 2801 && !(HvHasAUX(hv) 2802 && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH)) 2803 ) 2804 gv_check(hv); /* nested package */ 2805 } 2806 else if ( HeKLEN(entry) != 0 2807 && *HeKEY(entry) != '_' 2808 && isIDFIRST_lazy_if_safe(HeKEY(entry), 2809 HeKEY(entry) + HeKLEN(entry), 2810 HeUTF8(entry)) ) 2811 { 2812 const char *file; 2813 gv = MUTABLE_GV(HeVAL(entry)); 2814 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) 2815 continue; 2816 file = GvFILE(gv); 2817 assert(PL_curcop == &PL_compiling); 2818 CopLINE_set(PL_curcop, GvLINE(gv)); 2819 #ifdef USE_ITHREADS 2820 SAVECOPFILE_FREE(PL_curcop); 2821 CopFILE_set(PL_curcop, (char *)file); /* set for warning */ 2822 #else 2823 CopFILEGV(PL_curcop) 2824 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0); 2825 #endif 2826 if (GvONCE_FATAL(gv)) { 2827 fatal_warner(packWARN(WARN_ONCE), 2828 "Name \"%" HEKf "::%" HEKf 2829 "\" used only once: possible typo", 2830 HEKfARG(HvNAME_HEK(stash)), 2831 HEKfARG(GvNAME_HEK(gv))); 2832 } 2833 else { 2834 warner(packWARN(WARN_ONCE), 2835 "Name \"%" HEKf "::%" HEKf 2836 "\" used only once: possible typo", 2837 HEKfARG(HvNAME_HEK(stash)), 2838 HEKfARG(GvNAME_HEK(gv))); 2839 } 2840 } 2841 } 2842 } 2843 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH; 2844 } 2845 2846 /* 2847 =for apidoc newGVgen 2848 =for apidoc_item newGVgen_flags 2849 2850 Create a new, guaranteed to be unique, GV in the package given by the 2851 NUL-terminated C language string C<pack>, and return a pointer to it. 2852 2853 For C<newGVgen> or if C<flags> in C<newGVgen_flags> is 0, C<pack> is to be 2854 considered to be encoded in Latin-1. The only other legal C<flags> value is 2855 C<SVf_UTF8>, which indicates C<pack> is to be considered to be encoded in 2856 UTF-8. 2857 2858 =cut 2859 */ 2860 2861 GV * 2862 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags) 2863 { 2864 PERL_ARGS_ASSERT_NEWGVGEN_FLAGS; 2865 assert(!(flags & ~SVf_UTF8)); 2866 2867 return gv_fetchpv(Perl_form(aTHX_ "%" UTF8f "::_GEN_%ld", 2868 UTF8fARG(flags, strlen(pack), pack), 2869 (long)PL_gensym++), 2870 GV_ADD, SVt_PVGV); 2871 } 2872 2873 /* hopefully this is only called on local symbol table entries */ 2874 2875 GP* 2876 Perl_gp_ref(pTHX_ GP *gp) 2877 { 2878 if (!gp) 2879 return NULL; 2880 gp->gp_refcnt++; 2881 if (gp->gp_cv) { 2882 if (gp->gp_cvgen) { 2883 /* If the GP they asked for a reference to contains 2884 a method cache entry, clear it first, so that we 2885 don't infect them with our cached entry */ 2886 SvREFCNT_dec_NN(gp->gp_cv); 2887 gp->gp_cv = NULL; 2888 gp->gp_cvgen = 0; 2889 } 2890 } 2891 return gp; 2892 } 2893 2894 void 2895 Perl_gp_free(pTHX_ GV *gv) 2896 { 2897 GP* gp; 2898 int attempts = 100; 2899 bool in_global_destruction = PL_phase == PERL_PHASE_DESTRUCT; 2900 2901 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv))) 2902 return; 2903 if (gp->gp_refcnt == 0) { 2904 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), 2905 "Attempt to free unreferenced glob pointers" 2906 pTHX__FORMAT pTHX__VALUE); 2907 return; 2908 } 2909 if (gp->gp_refcnt > 1) { 2910 borrowed: 2911 if (gp->gp_egv == gv) 2912 gp->gp_egv = 0; 2913 gp->gp_refcnt--; 2914 GvGP_set(gv, NULL); 2915 return; 2916 } 2917 2918 while (1) { 2919 /* Copy and null out all the glob slots, so destructors do not see 2920 freed SVs. */ 2921 HEK * const file_hek = gp->gp_file_hek; 2922 SV * sv = gp->gp_sv; 2923 AV * av = gp->gp_av; 2924 HV * hv = gp->gp_hv; 2925 IO * io = gp->gp_io; 2926 CV * cv = gp->gp_cv; 2927 CV * form = gp->gp_form; 2928 2929 int need = 0; 2930 2931 gp->gp_file_hek = NULL; 2932 gp->gp_sv = NULL; 2933 gp->gp_av = NULL; 2934 gp->gp_hv = NULL; 2935 gp->gp_io = NULL; 2936 gp->gp_cv = NULL; 2937 gp->gp_form = NULL; 2938 2939 if (file_hek) 2940 unshare_hek(file_hek); 2941 2942 /* Storing the SV on the temps stack (instead of freeing it immediately) 2943 is an admitted bodge that attempt to compensate for the lack of 2944 reference counting on the stack. The motivation is that typeglob syntax 2945 is extremely short hence programs such as '$a += (*a = 2)' are often 2946 found randomly by researchers running fuzzers. Previously these 2947 programs would trigger errors, that the researchers would 2948 (legitimately) report, and then we would spend time figuring out that 2949 the cause was "stack not reference counted" and so not a dangerous 2950 security hole. This consumed a lot of researcher time, our time, and 2951 prevents "interesting" security holes being uncovered. 2952 2953 Typeglob assignment is rarely used in performance critical production 2954 code, so we aren't causing much slowdown by doing extra work here. 2955 2956 In turn, the need to check for SvOBJECT (and references to objects) is 2957 because we have regression tests that rely on timely destruction that 2958 happens *within this while loop* to demonstrate behaviour, and 2959 potentially there is also *working* code in the wild that relies on 2960 such behaviour. 2961 2962 And we need to avoid doing this in global destruction else we can end 2963 up with "Attempt to free temp prematurely ... Unbalanced string table 2964 refcount". 2965 2966 Hence the whole thing is a heuristic intended to mitigate against 2967 simple problems likely found by fuzzers but never written by humans, 2968 whilst leaving working code unchanged. */ 2969 if (sv) { 2970 SV *referent; 2971 if (SvREFCNT(sv) > 1 || SvOBJECT(sv) || UNLIKELY(in_global_destruction)) { 2972 SvREFCNT_dec_NN(sv); 2973 sv = NULL; 2974 } else if (SvROK(sv) && (referent = SvRV(sv)) 2975 && (SvREFCNT(referent) > 1 || SvOBJECT(referent))) { 2976 SvREFCNT_dec_NN(sv); 2977 sv = NULL; 2978 } else { 2979 ++need; 2980 } 2981 } 2982 if (av) { 2983 if (SvREFCNT(av) > 1 || SvOBJECT(av) || UNLIKELY(in_global_destruction)) { 2984 SvREFCNT_dec_NN(av); 2985 av = NULL; 2986 } else { 2987 ++need; 2988 } 2989 } 2990 /* FIXME - another reference loop GV -> symtab -> GV ? 2991 Somehow gp->gp_hv can end up pointing at freed garbage. */ 2992 if (hv && SvTYPE(hv) == SVt_PVHV) { 2993 const HEK *hvname_hek = HvNAME_HEK(hv); 2994 if (PL_stashcache && hvname_hek) { 2995 DEBUG_o(Perl_deb(aTHX_ 2996 "gp_free clearing PL_stashcache for '%" HEKf "'\n", 2997 HEKfARG(hvname_hek))); 2998 (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD); 2999 } 3000 if (SvREFCNT(hv) > 1 || SvOBJECT(hv) || UNLIKELY(in_global_destruction)) { 3001 SvREFCNT_dec_NN(hv); 3002 hv = NULL; 3003 } else { 3004 ++need; 3005 } 3006 } 3007 if (io && SvREFCNT(io) == 1 && IoIFP(io) 3008 && (IoTYPE(io) == IoTYPE_WRONLY || 3009 IoTYPE(io) == IoTYPE_RDWR || 3010 IoTYPE(io) == IoTYPE_APPEND) 3011 && ckWARN_d(WARN_IO) 3012 && IoIFP(io) != PerlIO_stdin() 3013 && IoIFP(io) != PerlIO_stdout() 3014 && IoIFP(io) != PerlIO_stderr() 3015 && !(IoFLAGS(io) & IOf_FAKE_DIRP)) 3016 io_close(io, gv, FALSE, TRUE); 3017 if (io) { 3018 if (SvREFCNT(io) > 1 || SvOBJECT(io) || UNLIKELY(in_global_destruction)) { 3019 SvREFCNT_dec_NN(io); 3020 io = NULL; 3021 } else { 3022 ++need; 3023 } 3024 } 3025 if (cv) { 3026 if (SvREFCNT(cv) > 1 || SvOBJECT(cv) || UNLIKELY(in_global_destruction)) { 3027 SvREFCNT_dec_NN(cv); 3028 cv = NULL; 3029 } else { 3030 ++need; 3031 } 3032 } 3033 if (form) { 3034 if (SvREFCNT(form) > 1 || SvOBJECT(form) || UNLIKELY(in_global_destruction)) { 3035 SvREFCNT_dec_NN(form); 3036 form = NULL; 3037 } else { 3038 ++need; 3039 } 3040 } 3041 3042 if (need) { 3043 /* We don't strictly need to defer all this to the end, but it's 3044 easiest to do so. The subtle problems we have are 3045 1) any of the actions triggered by the various SvREFCNT_dec()s in 3046 any of the intermediate blocks can cause more items to be added 3047 to the temps stack. So we can't "cache" its state locally 3048 2) We'd have to re-check the "extend by 1?" for each time. 3049 Whereas if we don't NULL out the values that we want to put onto 3050 the save stack until here, we can do it in one go, with one 3051 one size check. */ 3052 3053 SSize_t max_ix = PL_tmps_ix + need; 3054 3055 if (max_ix >= PL_tmps_max) { 3056 tmps_grow_p(max_ix); 3057 } 3058 3059 if (sv) { 3060 PL_tmps_stack[++PL_tmps_ix] = sv; 3061 } 3062 if (av) { 3063 PL_tmps_stack[++PL_tmps_ix] = (SV *) av; 3064 } 3065 if (hv) { 3066 PL_tmps_stack[++PL_tmps_ix] = (SV *) hv; 3067 } 3068 if (io) { 3069 PL_tmps_stack[++PL_tmps_ix] = (SV *) io; 3070 } 3071 if (cv) { 3072 PL_tmps_stack[++PL_tmps_ix] = (SV *) cv; 3073 } 3074 if (form) { 3075 PL_tmps_stack[++PL_tmps_ix] = (SV *) form; 3076 } 3077 } 3078 3079 /* Possibly reallocated by a destructor */ 3080 gp = GvGP(gv); 3081 3082 if (!gp->gp_file_hek 3083 && !gp->gp_sv 3084 && !gp->gp_av 3085 && !gp->gp_hv 3086 && !gp->gp_io 3087 && !gp->gp_cv 3088 && !gp->gp_form) break; 3089 3090 if (--attempts == 0) { 3091 Perl_die(aTHX_ 3092 "panic: gp_free failed to free glob pointer - " 3093 "something is repeatedly re-creating entries" 3094 ); 3095 } 3096 } 3097 3098 /* Possibly incremented by a destructor doing glob assignment */ 3099 if (gp->gp_refcnt > 1) goto borrowed; 3100 Safefree(gp); 3101 GvGP_set(gv, NULL); 3102 } 3103 3104 int 3105 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) 3106 { 3107 AMT * const amtp = (AMT*)mg->mg_ptr; 3108 PERL_UNUSED_ARG(sv); 3109 3110 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD; 3111 3112 if (amtp && AMT_AMAGIC(amtp)) { 3113 int i; 3114 for (i = 1; i < NofAMmeth; i++) { 3115 CV * const cv = amtp->table[i]; 3116 if (cv) { 3117 SvREFCNT_dec_NN(MUTABLE_SV(cv)); 3118 amtp->table[i] = NULL; 3119 } 3120 } 3121 } 3122 return 0; 3123 } 3124 3125 /* 3126 =for apidoc Gv_AMupdate 3127 3128 Recalculates overload magic in the package given by C<stash>. 3129 3130 Returns: 3131 3132 =over 3133 3134 =item 1 on success and there is some overload 3135 3136 =item 0 if there is no overload 3137 3138 =item -1 if some error occurred and it couldn't croak (because C<destructing> 3139 is true). 3140 3141 =back 3142 3143 =cut 3144 */ 3145 3146 int 3147 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) 3148 { 3149 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); 3150 AMT amt; 3151 const struct mro_meta* stash_meta = HvMROMETA(stash); 3152 U32 newgen; 3153 3154 PERL_ARGS_ASSERT_GV_AMUPDATE; 3155 3156 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen; 3157 if (mg) { 3158 const AMT * const amtp = (AMT*)mg->mg_ptr; 3159 if (amtp->was_ok_sub == newgen) { 3160 return AMT_AMAGIC(amtp) ? 1 : 0; 3161 } 3162 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table); 3163 } 3164 3165 DEBUG_o( Perl_deb(aTHX_ "Recalculating overload magic in package %s\n",HvNAME_get(stash)) ); 3166 3167 Zero(&amt,1,AMT); 3168 amt.was_ok_sub = newgen; 3169 amt.fallback = AMGfallNO; 3170 amt.flags = 0; 3171 3172 { 3173 int filled = 0; 3174 int i; 3175 bool deref_seen = 0; 3176 3177 3178 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ 3179 3180 /* Try to find via inheritance. */ 3181 GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0); 3182 SV * const sv = gv ? GvSV(gv) : NULL; 3183 CV* cv; 3184 3185 if (!gv) 3186 { 3187 if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0)) 3188 goto no_table; 3189 } 3190 #ifdef PERL_DONT_CREATE_GVSV 3191 else if (!sv) { 3192 NOOP; /* Equivalent to !SvTRUE and !SvOK */ 3193 } 3194 #endif 3195 else if (SvTRUE(sv)) 3196 /* don't need to set overloading here because fallback => 1 3197 * is the default setting for classes without overloading */ 3198 amt.fallback=AMGfallYES; 3199 else if (SvOK(sv)) { 3200 amt.fallback=AMGfallNEVER; 3201 filled = 1; 3202 } 3203 else { 3204 filled = 1; 3205 } 3206 3207 assert(HvHasAUX(stash)); 3208 /* initially assume the worst */ 3209 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF; 3210 3211 for (i = 1; i < NofAMmeth; i++) { 3212 const char * const cooky = PL_AMG_names[i]; 3213 /* Human-readable form, for debugging: */ 3214 const char * const cp = AMG_id2name(i); 3215 const STRLEN l = PL_AMG_namelens[i]; 3216 3217 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n", 3218 cp, HvNAME_get(stash)) ); 3219 /* don't fill the cache while looking up! 3220 Creation of inheritance stubs in intermediate packages may 3221 conflict with the logic of runtime method substitution. 3222 Indeed, for inheritance A -> B -> C, if C overloads "+0", 3223 then we could have created stubs for "(+0" in A and C too. 3224 But if B overloads "bool", we may want to use it for 3225 numifying instead of C's "+0". */ 3226 gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0); 3227 cv = 0; 3228 if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) { 3229 const HEK * const gvhek = CvGvNAME_HEK(cv); 3230 const HEK * const stashek = 3231 HvNAME_HEK(CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv))); 3232 if (memEQs(HEK_KEY(gvhek), HEK_LEN(gvhek), "nil") 3233 && stashek 3234 && memEQs(HEK_KEY(stashek), HEK_LEN(stashek), "overload")) { 3235 /* This is a hack to support autoloading..., while 3236 knowing *which* methods were declared as overloaded. */ 3237 /* GvSV contains the name of the method. */ 3238 GV *ngv = NULL; 3239 SV *gvsv = GvSV(gv); 3240 3241 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%" SVf256\ 3242 "\" for overloaded \"%s\" in package \"%.256s\"\n", 3243 (void*)GvSV(gv), cp, HvNAME(stash)) ); 3244 if (!gvsv || !SvPOK(gvsv) 3245 || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0))) 3246 { 3247 /* Can be an import stub (created by "can"). */ 3248 if (destructing) { 3249 return -1; 3250 } 3251 else { 3252 const SV * const name = (gvsv && SvPOK(gvsv)) 3253 ? gvsv 3254 : newSVpvs_flags("???", SVs_TEMP); 3255 /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */ 3256 Perl_croak(aTHX_ "%s method \"%" SVf256 3257 "\" overloading \"%s\" "\ 3258 "in package \"%" HEKf256 "\"", 3259 (GvCVGEN(gv) ? "Stub found while resolving" 3260 : "Can't resolve"), 3261 SVfARG(name), cp, 3262 HEKfARG( 3263 HvNAME_HEK(stash) 3264 )); 3265 } 3266 } 3267 cv = GvCV(gv = ngv); 3268 } 3269 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n", 3270 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))), 3271 GvNAME(CvGV(cv))) ); 3272 filled = 1; 3273 } else if (gv) { /* Autoloaded... */ 3274 cv = MUTABLE_CV(gv); 3275 filled = 1; 3276 } 3277 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv)); 3278 3279 if (gv) { 3280 switch (i) { 3281 case to_sv_amg: 3282 case to_av_amg: 3283 case to_hv_amg: 3284 case to_gv_amg: 3285 case to_cv_amg: 3286 case nomethod_amg: 3287 deref_seen = 1; 3288 break; 3289 } 3290 } 3291 } 3292 if (!deref_seen) 3293 /* none of @{} etc overloaded; we can do $obj->[N] quicker. 3294 * NB - aux var invalid here, HvARRAY() could have been 3295 * reallocated since it was assigned to */ 3296 HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF; 3297 3298 if (filled) { 3299 AMT_AMAGIC_on(&amt); 3300 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, 3301 (char*)&amt, sizeof(AMT)); 3302 return TRUE; 3303 } 3304 } 3305 /* Here we have no table: */ 3306 no_table: 3307 AMT_AMAGIC_off(&amt); 3308 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, 3309 (char*)&amt, sizeof(AMTS)); 3310 return 0; 3311 } 3312 3313 /* 3314 =for apidoc gv_handler 3315 3316 Implements C<StashHANDLER>, which you should use instead 3317 3318 =cut 3319 */ 3320 3321 CV* 3322 Perl_gv_handler(pTHX_ HV *stash, I32 id) 3323 { 3324 MAGIC *mg; 3325 AMT *amtp; 3326 U32 newgen; 3327 struct mro_meta* stash_meta; 3328 3329 if (!stash || !HvHasNAME(stash)) 3330 return NULL; 3331 3332 stash_meta = HvMROMETA(stash); 3333 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen; 3334 3335 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); 3336 if (!mg) { 3337 do_update: 3338 if (Gv_AMupdate(stash, 0) == -1) 3339 return NULL; 3340 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); 3341 } 3342 assert(mg); 3343 amtp = (AMT*)mg->mg_ptr; 3344 if ( amtp->was_ok_sub != newgen ) 3345 goto do_update; 3346 if (AMT_AMAGIC(amtp)) { 3347 CV * const ret = amtp->table[id]; 3348 if (ret && isGV(ret)) { /* Autoloading stab */ 3349 /* Passing it through may have resulted in a warning 3350 "Inherited AUTOLOAD for a non-method deprecated", since 3351 our caller is going through a function call, not a method call. 3352 So return the CV for AUTOLOAD, setting $AUTOLOAD. */ 3353 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]); 3354 3355 if (gv && GvCV(gv)) 3356 return GvCV(gv); 3357 } 3358 return ret; 3359 } 3360 3361 return NULL; 3362 } 3363 3364 3365 /* Implement tryAMAGICun_MG macro. 3366 Do get magic, then see if the stack arg is overloaded and if so call it. 3367 Flags: 3368 AMGf_numeric apply sv_2num to the stack arg. 3369 */ 3370 3371 bool 3372 Perl_try_amagic_un(pTHX_ int method, int flags) 3373 { 3374 SV* tmpsv; 3375 SV* const arg = PL_stack_sp[0]; 3376 bool is_rc = rpp_stack_is_rc(); 3377 3378 SvGETMAGIC(arg); 3379 3380 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method, 3381 AMGf_noright | AMGf_unary 3382 | (flags & AMGf_numarg)))) 3383 { 3384 /* where the op is of the form: 3385 * $lex = $x op $y (where the assign is optimised away) 3386 * then assign the returned value to targ and return that; 3387 * otherwise return the value directly 3388 */ 3389 SV *targ = tmpsv; 3390 if ( (PL_opargs[PL_op->op_type] & OA_TARGLEX) 3391 && (PL_op->op_private & OPpTARGET_MY)) 3392 { 3393 targ = PAD_SV(PL_op->op_targ); 3394 sv_setsv(targ, tmpsv); 3395 SvSETMAGIC(targ); 3396 } 3397 if (targ != arg) { 3398 *PL_stack_sp = targ; 3399 if (is_rc) { 3400 SvREFCNT_inc_NN(targ); 3401 SvREFCNT_dec_NN(arg); 3402 } 3403 } 3404 3405 return TRUE; 3406 } 3407 3408 if ((flags & AMGf_numeric) && SvROK(arg)) { 3409 PL_stack_sp[0] = tmpsv = sv_2num(arg); 3410 if (is_rc) { 3411 SvREFCNT_inc_NN(tmpsv); 3412 SvREFCNT_dec_NN(arg); 3413 } 3414 } 3415 3416 return FALSE; 3417 } 3418 3419 3420 /* 3421 =for apidoc amagic_applies 3422 3423 Check C<sv> to see if the overloaded (active magic) operation C<method> 3424 applies to it. If the sv is not SvROK or it is not an object then returns 3425 false, otherwise checks if the object is blessed into a class supporting 3426 overloaded operations, and returns true if a call to amagic_call() with 3427 this SV and the given method would trigger an amagic operation, including 3428 via the overload fallback rules or via nomethod. Thus a call like: 3429 3430 amagic_applies(sv, string_amg, AMG_unary) 3431 3432 would return true for an object with overloading set up in any of the 3433 following ways: 3434 3435 use overload q("") => sub { ... }; 3436 use overload q(0+) => sub { ... }, fallback => 1; 3437 3438 and could be used to tell if a given object would stringify to something 3439 other than the normal default ref stringification. 3440 3441 Note that the fact that this function returns TRUE does not mean you 3442 can succesfully perform the operation with amagic_call(), for instance 3443 any overloaded method might throw a fatal exception, however if this 3444 function returns FALSE you can be confident that it will NOT perform 3445 the given overload operation. 3446 3447 C<method> is an integer enum, one of the values found in F<overload.h>, 3448 for instance C<string_amg>. 3449 3450 C<flags> should be set to AMG_unary for unary operations. 3451 3452 =cut 3453 */ 3454 bool 3455 Perl_amagic_applies(pTHX_ SV *sv, int method, int flags) 3456 { 3457 PERL_ARGS_ASSERT_AMAGIC_APPLIES; 3458 PERL_UNUSED_VAR(flags); 3459 3460 assert(method >= 0 && method < NofAMmeth); 3461 3462 if (!SvAMAGIC(sv)) 3463 return FALSE; 3464 3465 HV *stash = SvSTASH(SvRV(sv)); 3466 if (!Gv_AMG(stash)) 3467 return FALSE; 3468 3469 MAGIC *mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); 3470 if (!mg) 3471 return FALSE; 3472 3473 CV **cvp = NULL; 3474 AMT *amtp = NULL; 3475 if (AMT_AMAGIC((AMT *)mg->mg_ptr)) { 3476 amtp = (AMT *)mg->mg_ptr; 3477 cvp = amtp->table; 3478 } 3479 if (!cvp) 3480 return FALSE; 3481 3482 if (cvp[method]) 3483 return TRUE; 3484 3485 /* Note this logic should be kept in sync with amagic_call() */ 3486 if (amtp->fallback > AMGfallNEVER && flags & AMGf_unary) { 3487 CV *cv; /* This makes it easier to kee ... */ 3488 int off,off1; /* ... in sync with amagic_call() */ 3489 3490 /* look for substituted methods */ 3491 /* In all the covered cases we should be called with assign==0. */ 3492 switch (method) { 3493 case inc_amg: 3494 if ((cv = cvp[off=add_ass_amg]) || ((cv = cvp[off = add_amg]))) 3495 return TRUE; 3496 break; 3497 case dec_amg: 3498 if((cv = cvp[off = subtr_ass_amg]) || ((cv = cvp[off = subtr_amg]))) 3499 return TRUE; 3500 break; 3501 case bool__amg: 3502 if ((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])) 3503 return TRUE; 3504 break; 3505 case numer_amg: 3506 if((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg])) 3507 return TRUE; 3508 break; 3509 case string_amg: 3510 if((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])) 3511 return TRUE; 3512 break; 3513 case not_amg: 3514 if((cv = cvp[off=bool__amg]) 3515 || (cv = cvp[off=numer_amg]) 3516 || (cv = cvp[off=string_amg])) 3517 return TRUE; 3518 break; 3519 case abs_amg: 3520 if((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) 3521 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) 3522 return TRUE; 3523 break; 3524 case neg_amg: 3525 if ((cv = cvp[off=subtr_amg])) 3526 return TRUE; 3527 break; 3528 } 3529 } else if (((cvp && amtp->fallback > AMGfallNEVER)) 3530 && !(flags & AMGf_unary)) { 3531 /* We look for substitution for 3532 * comparison operations and 3533 * concatenation */ 3534 if (method==concat_amg || method==concat_ass_amg 3535 || method==repeat_amg || method==repeat_ass_amg) { 3536 return FALSE; /* Delegate operation to string conversion */ 3537 } 3538 switch (method) { 3539 case lt_amg: 3540 case le_amg: 3541 case gt_amg: 3542 case ge_amg: 3543 case eq_amg: 3544 case ne_amg: 3545 if (cvp[ncmp_amg]) 3546 return TRUE; 3547 break; 3548 case slt_amg: 3549 case sle_amg: 3550 case sgt_amg: 3551 case sge_amg: 3552 case seq_amg: 3553 case sne_amg: 3554 if (cvp[scmp_amg]) 3555 return TRUE; 3556 break; 3557 } 3558 } 3559 3560 if (cvp[nomethod_amg]) 3561 return TRUE; 3562 3563 return FALSE; 3564 } 3565 3566 3567 /* Implement tryAMAGICbin_MG macro. 3568 Do get magic, then see if the two stack args are overloaded and if so 3569 call it. 3570 Flags: 3571 AMGf_assign op may be called as mutator (eg +=) 3572 AMGf_numeric apply sv_2num to the stack arg. 3573 */ 3574 3575 bool 3576 Perl_try_amagic_bin(pTHX_ int method, int flags) 3577 { 3578 SV* left = PL_stack_sp[-1]; 3579 SV* right = PL_stack_sp[0]; 3580 bool is_rc = rpp_stack_is_rc(); 3581 3582 SvGETMAGIC(left); 3583 if (left != right) 3584 SvGETMAGIC(right); 3585 3586 if (SvAMAGIC(left) || SvAMAGIC(right)) { 3587 SV * tmpsv; 3588 /* STACKED implies mutator variant, e.g. $x += 1 */ 3589 bool mutator = (flags & AMGf_assign) && (PL_op->op_flags & OPf_STACKED); 3590 3591 tmpsv = amagic_call(left, right, method, 3592 (mutator ? AMGf_assign: 0) 3593 | (flags & AMGf_numarg)); 3594 if (tmpsv) { 3595 PL_stack_sp--; 3596 if (is_rc) 3597 SvREFCNT_dec_NN(right); 3598 /* where the op is one of the two forms: 3599 * $x op= $y 3600 * $lex = $x op $y (where the assign is optimised away) 3601 * then assign the returned value to targ and return that; 3602 * otherwise return the value directly 3603 */ 3604 SV *targ = tmpsv;; 3605 if ( mutator 3606 || ( (PL_opargs[PL_op->op_type] & OA_TARGLEX) 3607 && (PL_op->op_private & OPpTARGET_MY))) 3608 { 3609 targ = mutator ? left : PAD_SV(PL_op->op_targ); 3610 sv_setsv(targ, tmpsv); 3611 SvSETMAGIC(targ); 3612 } 3613 if (targ != left) { 3614 *PL_stack_sp = targ; 3615 if (is_rc) { 3616 SvREFCNT_inc_NN(targ); 3617 SvREFCNT_dec_NN(left); 3618 } 3619 } 3620 3621 return TRUE; 3622 } 3623 } 3624 3625 /* if the same magic value appears on both sides, replace the LH one 3626 * with a copy and call get magic on the RH one, so that magic gets 3627 * called twice with possibly two different returned values */ 3628 if (left == right && SvGMAGICAL(left)) { 3629 SV * const tmpsv = is_rc ? newSV_type(SVt_NULL) : sv_newmortal(); 3630 /* Print the uninitialized warning now, so it includes the vari- 3631 able name. */ 3632 if (!SvOK(right)) { 3633 if (ckWARN(WARN_UNINITIALIZED)) 3634 report_uninit(right); 3635 sv_setbool(tmpsv, FALSE); 3636 } 3637 else 3638 sv_setsv_flags(tmpsv, right, 0); 3639 if (is_rc) 3640 SvREFCNT_dec_NN(left); 3641 left = PL_stack_sp[-1] = tmpsv; 3642 SvGETMAGIC(right); 3643 } 3644 3645 if (flags & AMGf_numeric) { 3646 SV *tmpsv; 3647 if (SvROK(left)) { 3648 PL_stack_sp[-1] = tmpsv = sv_2num(left); 3649 if (is_rc) { 3650 SvREFCNT_inc_NN(tmpsv); 3651 SvREFCNT_dec_NN(left); 3652 } 3653 } 3654 if (SvROK(right)) { 3655 PL_stack_sp[0] = tmpsv = sv_2num(right); 3656 if (is_rc) { 3657 SvREFCNT_inc_NN(tmpsv); 3658 SvREFCNT_dec_NN(right); 3659 } 3660 } 3661 } 3662 3663 return FALSE; 3664 } 3665 3666 3667 /* 3668 =for apidoc amagic_deref_call 3669 3670 Perform C<method> overloading dereferencing on C<ref>, returning the 3671 dereferenced result. C<method> must be one of the dereference operations given 3672 in F<overload.h>. 3673 3674 If overloading is inactive on C<ref>, returns C<ref> itself. 3675 3676 =cut 3677 */ 3678 3679 SV * 3680 Perl_amagic_deref_call(pTHX_ SV *ref, int method) { 3681 SV *tmpsv = NULL; 3682 HV *stash; 3683 3684 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL; 3685 3686 if (!SvAMAGIC(ref)) 3687 return ref; 3688 /* return quickly if none of the deref ops are overloaded */ 3689 stash = SvSTASH(SvRV(ref)); 3690 assert(HvHasAUX(stash)); 3691 if (HvAUX(stash)->xhv_aux_flags & HvAUXf_NO_DEREF) 3692 return ref; 3693 3694 while ((tmpsv = amagic_call(ref, &PL_sv_undef, method, 3695 AMGf_noright | AMGf_unary))) { 3696 if (!SvROK(tmpsv)) 3697 Perl_croak(aTHX_ "Overloaded dereference did not return a reference"); 3698 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) { 3699 /* Bail out if it returns us the same reference. */ 3700 return tmpsv; 3701 } 3702 ref = tmpsv; 3703 if (!SvAMAGIC(ref)) 3704 break; 3705 } 3706 return tmpsv ? tmpsv : ref; 3707 } 3708 3709 bool 3710 Perl_amagic_is_enabled(pTHX_ int method) 3711 { 3712 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0); 3713 3714 assert(PL_curcop->cop_hints & HINT_NO_AMAGIC); 3715 3716 if ( !lex_mask || !SvOK(lex_mask) ) 3717 /* overloading lexically disabled */ 3718 return FALSE; 3719 else if ( lex_mask && SvPOK(lex_mask) ) { 3720 /* we have an entry in the hints hash, check if method has been 3721 * masked by overloading.pm */ 3722 STRLEN len; 3723 const int offset = method / 8; 3724 const int bit = method % 8; 3725 char *pv = SvPV(lex_mask, len); 3726 3727 /* Bit set, so this overloading operator is disabled */ 3728 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) ) 3729 return FALSE; 3730 } 3731 return TRUE; 3732 } 3733 3734 /* 3735 =for apidoc amagic_call 3736 3737 Perform the overloaded (active magic) operation given by C<method>. 3738 C<method> is one of the values found in F<overload.h>. 3739 3740 C<flags> affects how the operation is performed, as follows: 3741 3742 =over 3743 3744 =item C<AMGf_noleft> 3745 3746 C<left> is not to be used in this operation. 3747 3748 =item C<AMGf_noright> 3749 3750 C<right> is not to be used in this operation. 3751 3752 =item C<AMGf_unary> 3753 3754 The operation is done only on just one operand. 3755 3756 =item C<AMGf_assign> 3757 3758 The operation changes one of the operands, e.g., $x += 1 3759 3760 =back 3761 3762 =cut 3763 */ 3764 3765 SV* 3766 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) 3767 { 3768 MAGIC *mg; 3769 CV *cv=NULL; 3770 CV **cvp=NULL, **ocvp=NULL; 3771 AMT *amtp=NULL, *oamtp=NULL; 3772 int off = 0, off1, lr = 0, notfound = 0; 3773 int postpr = 0, force_cpy = 0; 3774 int assign = AMGf_assign & flags; 3775 const int assignshift = assign ? 1 : 0; 3776 int use_default_op = 0; 3777 int force_scalar = 0; 3778 #ifdef DEBUGGING 3779 int fl=0; 3780 #endif 3781 HV* stash=NULL; 3782 3783 PERL_ARGS_ASSERT_AMAGIC_CALL; 3784 3785 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) { 3786 if (!amagic_is_enabled(method)) return NULL; 3787 } 3788 3789 if (!(AMGf_noleft & flags) && SvAMAGIC(left) 3790 && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash) 3791 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) 3792 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) 3793 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table 3794 : NULL)) 3795 && ((cv = cvp[off=method+assignshift]) 3796 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to 3797 * usual method */ 3798 ( 3799 #ifdef DEBUGGING 3800 fl = 1, 3801 #endif 3802 cv = cvp[off=method])))) 3803 { 3804 lr = -1; /* Call method for left argument */ 3805 } else { 3806 /* Note this logic should be kept in sync with amagic_applies() */ 3807 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) { 3808 int logic; 3809 3810 /* look for substituted methods */ 3811 /* In all the covered cases we should be called with assign==0. */ 3812 switch (method) { 3813 case inc_amg: 3814 force_cpy = 1; 3815 if ((cv = cvp[off=add_ass_amg]) 3816 || ((cv = cvp[off = add_amg]) 3817 && (force_cpy = 0, (postpr = 1)))) { 3818 right = &PL_sv_yes; lr = -1; assign = 1; 3819 } 3820 break; 3821 case dec_amg: 3822 force_cpy = 1; 3823 if ((cv = cvp[off = subtr_ass_amg]) 3824 || ((cv = cvp[off = subtr_amg]) 3825 && (force_cpy = 0, (postpr=1)))) { 3826 right = &PL_sv_yes; lr = -1; assign = 1; 3827 } 3828 break; 3829 case bool__amg: 3830 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); 3831 break; 3832 case numer_amg: 3833 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg])); 3834 break; 3835 case string_amg: 3836 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); 3837 break; 3838 case not_amg: 3839 (void)((cv = cvp[off=bool__amg]) 3840 || (cv = cvp[off=numer_amg]) 3841 || (cv = cvp[off=string_amg])); 3842 if (cv) 3843 postpr = 1; 3844 break; 3845 case copy_amg: 3846 { 3847 /* 3848 * SV* ref causes confusion with the interpreter variable of 3849 * the same name 3850 */ 3851 SV* const tmpRef=SvRV(left); 3852 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) { 3853 /* 3854 * Just to be extra cautious. Maybe in some 3855 * additional cases sv_setsv is safe, too. 3856 */ 3857 SV* const newref = newSVsv(tmpRef); 3858 SvOBJECT_on(newref); 3859 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros 3860 delegate to the stash. */ 3861 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef)))); 3862 return newref; 3863 } 3864 } 3865 break; 3866 case abs_amg: 3867 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) 3868 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { 3869 SV* const nullsv=&PL_sv_zero; 3870 if (off1==lt_amg) { 3871 SV* const lessp = amagic_call(left,nullsv, 3872 lt_amg,AMGf_noright); 3873 logic = SvTRUE_NN(lessp); 3874 } else { 3875 SV* const lessp = amagic_call(left,nullsv, 3876 ncmp_amg,AMGf_noright); 3877 logic = (SvNV(lessp) < 0); 3878 } 3879 if (logic) { 3880 if (off==subtr_amg) { 3881 right = left; 3882 left = nullsv; 3883 lr = 1; 3884 } 3885 } else { 3886 return left; 3887 } 3888 } 3889 break; 3890 case neg_amg: 3891 if ((cv = cvp[off=subtr_amg])) { 3892 right = left; 3893 left = &PL_sv_zero; 3894 lr = 1; 3895 } 3896 break; 3897 case int_amg: 3898 case iter_amg: /* XXXX Eventually should do to_gv. */ 3899 case ftest_amg: /* XXXX Eventually should do to_gv. */ 3900 case regexp_amg: 3901 /* FAIL safe */ 3902 return NULL; /* Delegate operation to standard mechanisms. */ 3903 3904 case to_sv_amg: 3905 case to_av_amg: 3906 case to_hv_amg: 3907 case to_gv_amg: 3908 case to_cv_amg: 3909 /* FAIL safe */ 3910 return left; /* Delegate operation to standard mechanisms. */ 3911 3912 default: 3913 goto not_found; 3914 } 3915 if (!cv) goto not_found; 3916 } else if (!(AMGf_noright & flags) && SvAMAGIC(right) 3917 && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash) 3918 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) 3919 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) 3920 ? (amtp = (AMT*)mg->mg_ptr)->table 3921 : NULL)) 3922 && (cv = cvp[off=method])) { /* Method for right 3923 * argument found */ 3924 lr=1; 3925 } else if (((cvp && amtp->fallback > AMGfallNEVER) 3926 || (ocvp && oamtp->fallback > AMGfallNEVER)) 3927 && !(flags & AMGf_unary)) { 3928 /* We look for substitution for 3929 * comparison operations and 3930 * concatenation */ 3931 if (method==concat_amg || method==concat_ass_amg 3932 || method==repeat_amg || method==repeat_ass_amg) { 3933 return NULL; /* Delegate operation to string conversion */ 3934 } 3935 off = -1; 3936 switch (method) { 3937 case lt_amg: 3938 case le_amg: 3939 case gt_amg: 3940 case ge_amg: 3941 case eq_amg: 3942 case ne_amg: 3943 off = ncmp_amg; 3944 break; 3945 case slt_amg: 3946 case sle_amg: 3947 case sgt_amg: 3948 case sge_amg: 3949 case seq_amg: 3950 case sne_amg: 3951 off = scmp_amg; 3952 break; 3953 } 3954 if (off != -1) { 3955 if (ocvp && (oamtp->fallback > AMGfallNEVER)) { 3956 cv = ocvp[off]; 3957 lr = -1; 3958 } 3959 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) { 3960 cv = cvp[off]; 3961 lr = 1; 3962 } 3963 } 3964 if (cv) 3965 postpr = 1; 3966 else 3967 goto not_found; 3968 } else { 3969 not_found: /* No method found, either report or croak */ 3970 switch (method) { 3971 case to_sv_amg: 3972 case to_av_amg: 3973 case to_hv_amg: 3974 case to_gv_amg: 3975 case to_cv_amg: 3976 /* FAIL safe */ 3977 return left; /* Delegate operation to standard mechanisms. */ 3978 } 3979 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */ 3980 notfound = 1; lr = -1; 3981 } else if (cvp && (cv=cvp[nomethod_amg])) { 3982 notfound = 1; lr = 1; 3983 } else if ((use_default_op = 3984 (!ocvp || oamtp->fallback >= AMGfallYES) 3985 && (!cvp || amtp->fallback >= AMGfallYES)) 3986 && !DEBUG_o_TEST) { 3987 /* Skip generating the "no method found" message. */ 3988 return NULL; 3989 } else { 3990 SV *msg; 3991 if (off==-1) off=method; 3992 msg = sv_2mortal(Perl_newSVpvf(aTHX_ 3993 "Operation \"%s\": no method found,%sargument %s%" SVf "%s%" SVf, 3994 AMG_id2name(method + assignshift), 3995 (flags & AMGf_unary ? " " : "\n\tleft "), 3996 SvAMAGIC(left)? 3997 "in overloaded package ": 3998 "has no overloaded magic", 3999 SvAMAGIC(left)? 4000 SVfARG(newSVhek_mortal(HvNAME_HEK(SvSTASH(SvRV(left))))): 4001 SVfARG(&PL_sv_no), 4002 SvAMAGIC(right)? 4003 ",\n\tright argument in overloaded package ": 4004 (flags & AMGf_unary 4005 ? "" 4006 : ",\n\tright argument has no overloaded magic"), 4007 SvAMAGIC(right)? 4008 SVfARG(newSVhek_mortal(HvNAME_HEK(SvSTASH(SvRV(right))))): 4009 SVfARG(&PL_sv_no))); 4010 if (use_default_op) { 4011 DEBUG_o( Perl_deb(aTHX_ "%" SVf, SVfARG(msg)) ); 4012 } else { 4013 Perl_croak(aTHX_ "%" SVf, SVfARG(msg)); 4014 } 4015 return NULL; 4016 } 4017 force_cpy = force_cpy || assign; 4018 } 4019 } 4020 4021 /* If there's an optimised-away assignment such as $lex = $a + $b, where 4022 * the operator sets the targ lexical directly and skips the sassign, 4023 * treat the op as scalar even if its marked as void */ 4024 if ( PL_op 4025 && (PL_opargs[PL_op->op_type] & OA_TARGLEX) 4026 && (PL_op->op_private & OPpTARGET_MY) 4027 ) 4028 force_scalar = 1; 4029 4030 switch (method) { 4031 /* in these cases, we're calling '+' or '-' as a fallback for a ++ or -- 4032 * operation. we need this to return a value, so that it can be assigned 4033 * later on, in the postpr block (case inc_amg/dec_amg), even if the 4034 * increment or decrement was itself called in void context */ 4035 case inc_amg: 4036 if (off == add_amg) 4037 force_scalar = 1; 4038 break; 4039 case dec_amg: 4040 if (off == subtr_amg) 4041 force_scalar = 1; 4042 break; 4043 /* in these cases, we're calling an assignment variant of an operator 4044 * (+= rather than +, for instance). regardless of whether it's a 4045 * fallback or not, it always has to return a value, which will be 4046 * assigned to the proper variable later */ 4047 case add_amg: 4048 case subtr_amg: 4049 case mult_amg: 4050 case div_amg: 4051 case modulo_amg: 4052 case pow_amg: 4053 case lshift_amg: 4054 case rshift_amg: 4055 case repeat_amg: 4056 case concat_amg: 4057 case band_amg: 4058 case bor_amg: 4059 case bxor_amg: 4060 case sband_amg: 4061 case sbor_amg: 4062 case sbxor_amg: 4063 if (assign) 4064 force_scalar = 1; 4065 break; 4066 /* the copy constructor always needs to return a value */ 4067 case copy_amg: 4068 force_scalar = 1; 4069 break; 4070 /* because of the way these are implemented (they don't perform the 4071 * dereferencing themselves, they return a reference that perl then 4072 * dereferences later), they always have to be in scalar context */ 4073 case to_sv_amg: 4074 case to_av_amg: 4075 case to_hv_amg: 4076 case to_gv_amg: 4077 case to_cv_amg: 4078 force_scalar = 1; 4079 break; 4080 /* these don't have an op of their own; they're triggered by their parent 4081 * op, so the context there isn't meaningful ('$a and foo()' in void 4082 * context still needs to pass scalar context on to $a's bool overload) */ 4083 case bool__amg: 4084 case numer_amg: 4085 case string_amg: 4086 force_scalar = 1; 4087 break; 4088 } 4089 4090 #ifdef DEBUGGING 4091 if (!notfound) { 4092 DEBUG_o(Perl_deb(aTHX_ 4093 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %" SVf "%s\n", 4094 AMG_id2name(off), 4095 method+assignshift==off? "" : 4096 " (initially \"", 4097 method+assignshift==off? "" : 4098 AMG_id2name(method+assignshift), 4099 method+assignshift==off? "" : "\")", 4100 flags & AMGf_unary? "" : 4101 lr==1 ? " for right argument": " for left argument", 4102 flags & AMGf_unary? " for argument" : "", 4103 stash ? SVfARG(newSVhek_mortal(HvNAME_HEK(stash))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)), 4104 fl? ",\n\tassignment variant used": "") ); 4105 } 4106 #endif 4107 /* Since we use shallow copy during assignment, we need 4108 * to duplicate the contents, probably calling user-supplied 4109 * version of copy operator 4110 */ 4111 /* We need to copy in following cases: 4112 * a) Assignment form was called. 4113 * assignshift==1, assign==T, method + 1 == off 4114 * b) Increment or decrement, called directly. 4115 * assignshift==0, assign==0, method + 0 == off 4116 * c) Increment or decrement, translated to assignment add/subtr. 4117 * assignshift==0, assign==T, 4118 * force_cpy == T 4119 * d) Increment or decrement, translated to nomethod. 4120 * assignshift==0, assign==0, 4121 * force_cpy == T 4122 * e) Assignment form translated to nomethod. 4123 * assignshift==1, assign==T, method + 1 != off 4124 * force_cpy == T 4125 */ 4126 /* off is method, method+assignshift, or a result of opcode substitution. 4127 * In the latter case assignshift==0, so only notfound case is important. 4128 */ 4129 if ( (lr == -1) && ( ( (method + assignshift == off) 4130 && (assign || (method == inc_amg) || (method == dec_amg))) 4131 || force_cpy) ) 4132 { 4133 /* newSVsv does not behave as advertised, so we copy missing 4134 * information by hand */ 4135 SV *tmpRef = SvRV(left); 4136 SV *rv_copy; 4137 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) { 4138 SvRV_set(left, rv_copy); 4139 SvSETMAGIC(left); 4140 SvREFCNT_dec_NN(tmpRef); 4141 } 4142 } 4143 4144 { 4145 dSP; 4146 UNOP myop; 4147 SV* res; 4148 const bool oldcatch = CATCH_GET; 4149 I32 oldmark, nret; 4150 /* for multiconcat, we may call overload several times, 4151 * with the context of individual concats being scalar, 4152 * regardless of the overall context of the multiconcat op 4153 */ 4154 U8 gimme = (force_scalar || (PL_op && PL_op->op_type == OP_MULTICONCAT)) 4155 ? G_SCALAR : GIMME_V; 4156 4157 CATCH_SET(TRUE); 4158 Zero(&myop, 1, UNOP); 4159 myop.op_flags = OPf_STACKED; 4160 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB]; 4161 myop.op_type = OP_ENTERSUB; 4162 4163 4164 switch (gimme) { 4165 case G_VOID: 4166 myop.op_flags |= OPf_WANT_VOID; 4167 break; 4168 case G_LIST: 4169 if (flags & AMGf_want_list) { 4170 myop.op_flags |= OPf_WANT_LIST; 4171 break; 4172 } 4173 /* FALLTHROUGH */ 4174 default: 4175 myop.op_flags |= OPf_WANT_SCALAR; 4176 break; 4177 } 4178 4179 PUSHSTACKi(PERLSI_OVERLOAD); 4180 ENTER; 4181 SAVEOP(); 4182 PL_op = (OP *) &myop; 4183 if (PERLDB_SUB && PL_curstash != PL_debstash) 4184 PL_op->op_private |= OPpENTERSUB_DB; 4185 Perl_pp_pushmark(aTHX); 4186 4187 EXTEND(SP, notfound + 5); 4188 PUSHs(lr>0? right: left); 4189 PUSHs(lr>0? left: right); 4190 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no )); 4191 if (notfound) { 4192 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift), 4193 AMG_id2namelen(method + assignshift), SVs_TEMP)); 4194 } 4195 else if (flags & AMGf_numarg) 4196 PUSHs(&PL_sv_undef); 4197 if (flags & AMGf_numarg) 4198 PUSHs(&PL_sv_yes); 4199 PUSHs(MUTABLE_SV(cv)); 4200 PUTBACK; 4201 oldmark = TOPMARK; 4202 CALLRUNOPS(aTHX); 4203 LEAVE; 4204 SPAGAIN; 4205 nret = SP - (PL_stack_base + oldmark); 4206 4207 switch (gimme) { 4208 case G_VOID: 4209 /* returning NULL has another meaning, and we check the context 4210 * at the call site too, so this can be differentiated from the 4211 * scalar case */ 4212 res = &PL_sv_undef; 4213 SP = PL_stack_base + oldmark; 4214 break; 4215 case G_LIST: 4216 if (flags & AMGf_want_list) { 4217 res = newSV_type_mortal(SVt_PVAV); 4218 av_extend((AV *)res, nret); 4219 while (nret--) 4220 /* Naughtily, we don't increment the ref counts 4221 * of the items we push onto the temporary array. 4222 * So we rely on the caller knowing not to decrement them, 4223 * and to empty the array before there's any chance of 4224 * it being freed. (Probably should either turn off 4225 * AvREAL or actually increment.) 4226 */ 4227 av_store((AV *)res, nret, POPs); 4228 break; 4229 } 4230 /* FALLTHROUGH */ 4231 default: 4232 res = POPs; 4233 break; 4234 } 4235 4236 PUTBACK; 4237 POPSTACK; 4238 CATCH_SET(oldcatch); 4239 4240 if (postpr) { 4241 int ans; 4242 switch (method) { 4243 case le_amg: 4244 case sle_amg: 4245 ans=SvIV(res)<=0; break; 4246 case lt_amg: 4247 case slt_amg: 4248 ans=SvIV(res)<0; break; 4249 case ge_amg: 4250 case sge_amg: 4251 ans=SvIV(res)>=0; break; 4252 case gt_amg: 4253 case sgt_amg: 4254 ans=SvIV(res)>0; break; 4255 case eq_amg: 4256 case seq_amg: 4257 ans=SvIV(res)==0; break; 4258 case ne_amg: 4259 case sne_amg: 4260 ans=SvIV(res)!=0; break; 4261 case inc_amg: 4262 case dec_amg: 4263 SvSetSV(left,res); return left; 4264 case not_amg: 4265 ans=!SvTRUE_NN(res); break; 4266 default: 4267 ans=0; break; 4268 } 4269 return boolSV(ans); 4270 } else if (method==copy_amg) { 4271 if (!SvROK(res)) { 4272 Perl_croak(aTHX_ "Copy method did not return a reference"); 4273 } 4274 return SvREFCNT_inc(SvRV(res)); 4275 } else { 4276 return res; 4277 } 4278 } 4279 } 4280 4281 /* 4282 =for apidoc gv_name_set 4283 4284 Set the name for GV C<gv> to C<name> which is C<len> bytes long. Thus it may 4285 contain embedded NUL characters. 4286 4287 If C<flags> contains C<SVf_UTF8>, the name is treated as being encoded in 4288 UTF-8; otherwise not. 4289 4290 =cut 4291 */ 4292 4293 void 4294 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) 4295 { 4296 U32 hash; 4297 4298 PERL_ARGS_ASSERT_GV_NAME_SET; 4299 4300 if (len > I32_MAX) 4301 Perl_croak(aTHX_ "panic: gv name too long (%" UVuf ")", (UV) len); 4302 4303 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) { 4304 unshare_hek(GvNAME_HEK(gv)); 4305 } 4306 4307 PERL_HASH(hash, name, len); 4308 GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash); 4309 } 4310 4311 /* 4312 =for apidoc gv_try_downgrade 4313 4314 If the typeglob C<gv> can be expressed more succinctly, by having 4315 something other than a real GV in its place in the stash, replace it 4316 with the optimised form. Basic requirements for this are that C<gv> 4317 is a real typeglob, is sufficiently ordinary, and is only referenced 4318 from its package. This function is meant to be used when a GV has been 4319 looked up in part to see what was there, causing upgrading, but based 4320 on what was found it turns out that the real GV isn't required after all. 4321 4322 If C<gv> is a completely empty typeglob, it is deleted from the stash. 4323 4324 If C<gv> is a typeglob containing only a sufficiently-ordinary constant 4325 sub, the typeglob is replaced with a scalar-reference placeholder that 4326 more compactly represents the same thing. 4327 4328 =cut 4329 */ 4330 4331 void 4332 Perl_gv_try_downgrade(pTHX_ GV *gv) 4333 { 4334 HV *stash; 4335 CV *cv; 4336 HEK *namehek; 4337 SV **gvp; 4338 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE; 4339 4340 /* XXX Why and where does this leave dangling pointers during global 4341 destruction? */ 4342 if (PL_phase == PERL_PHASE_DESTRUCT) return; 4343 4344 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) && 4345 !SvOBJECT(gv) && !SvREADONLY(gv) && 4346 isGV_with_GP(gv) && GvGP(gv) && 4347 !GvINTRO(gv) && GvREFCNT(gv) == 1 && 4348 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) && 4349 GvEGVx(gv) == gv && (stash = GvSTASH(gv)))) 4350 return; 4351 if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv) 4352 return; 4353 if (SvMAGICAL(gv)) { 4354 MAGIC *mg; 4355 /* only backref magic is allowed */ 4356 if (SvGMAGICAL(gv) || SvSMAGICAL(gv)) 4357 return; 4358 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) { 4359 if (mg->mg_type != PERL_MAGIC_backref) 4360 return; 4361 } 4362 } 4363 cv = GvCV(gv); 4364 if (!cv) { 4365 HEK *gvnhek = GvNAME_HEK(gv); 4366 (void)hv_deletehek(stash, gvnhek, G_DISCARD); 4367 } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 && 4368 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) && 4369 CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv && 4370 CvCONST(cv) && !CvNOWARN_AMBIGUOUS(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) && 4371 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) && 4372 (namehek = GvNAME_HEK(gv)) && 4373 (gvp = hv_fetchhek(stash, namehek, 0)) && 4374 *gvp == (SV*)gv) { 4375 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr); 4376 const bool imported = cBOOL(GvIMPORTED_CV(gv)); 4377 SvREFCNT(gv) = 0; 4378 sv_clear((SV*)gv); 4379 SvREFCNT(gv) = 1; 4380 SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported; 4381 4382 /* See also: 'SET_SVANY_FOR_BODYLESS_IV' in sv.c */ 4383 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) - 4384 STRUCT_OFFSET(XPVIV, xiv_iv)); 4385 SvRV_set(gv, value); 4386 } 4387 } 4388 4389 GV * 4390 Perl_gv_override(pTHX_ const char * const name, const STRLEN len) 4391 { 4392 GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV); 4393 GV * const *gvp; 4394 PERL_ARGS_ASSERT_GV_OVERRIDE; 4395 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv; 4396 gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE); 4397 gv = gvp ? *gvp : NULL; 4398 if (gv && !isGV(gv)) { 4399 if (!SvPCS_IMPORTED(gv)) return NULL; 4400 gv_init(gv, PL_globalstash, name, len, 0); 4401 return gv; 4402 } 4403 return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL; 4404 } 4405 4406 #include "XSUB.h" 4407 4408 static void 4409 core_xsub(pTHX_ CV* cv) 4410 { 4411 Perl_croak(aTHX_ 4412 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv)) 4413 ); 4414 } 4415 4416 /* 4417 * ex: set ts=8 sts=4 sw=4 et: 4418 */ 4419