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