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