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