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