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 { 86 *where = newSV_type(type); 87 if (type == SVt_PVAV && GvNAMELEN(gv) == 3 88 && strnEQ(GvNAME(gv), "ISA", 3)) 89 sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0); 90 } 91 return gv; 92 } 93 94 GV * 95 Perl_gv_fetchfile(pTHX_ const char *name) 96 { 97 PERL_ARGS_ASSERT_GV_FETCHFILE; 98 return gv_fetchfile_flags(name, strlen(name), 0); 99 } 100 101 GV * 102 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, 103 const U32 flags) 104 { 105 dVAR; 106 char smallbuf[128]; 107 char *tmpbuf; 108 const STRLEN tmplen = namelen + 2; 109 GV *gv; 110 111 PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS; 112 PERL_UNUSED_ARG(flags); 113 114 if (!PL_defstash) 115 return NULL; 116 117 if (tmplen <= sizeof smallbuf) 118 tmpbuf = smallbuf; 119 else 120 Newx(tmpbuf, tmplen, char); 121 /* This is where the debugger's %{"::_<$filename"} hash is created */ 122 tmpbuf[0] = '_'; 123 tmpbuf[1] = '<'; 124 memcpy(tmpbuf + 2, name, namelen); 125 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE); 126 if (!isGV(gv)) { 127 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE); 128 #ifdef PERL_DONT_CREATE_GVSV 129 GvSV(gv) = newSVpvn(name, namelen); 130 #else 131 sv_setpvn(GvSV(gv), name, namelen); 132 #endif 133 } 134 if ((PERLDB_LINE || PERLDB_SAVESRC) && !GvAV(gv)) 135 hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile); 136 if (tmpbuf != smallbuf) 137 Safefree(tmpbuf); 138 return gv; 139 } 140 141 /* 142 =for apidoc gv_const_sv 143 144 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for 145 inlining, or C<gv> is a placeholder reference that would be promoted to such 146 a typeglob, then returns the value returned by the sub. Otherwise, returns 147 NULL. 148 149 =cut 150 */ 151 152 SV * 153 Perl_gv_const_sv(pTHX_ GV *gv) 154 { 155 PERL_ARGS_ASSERT_GV_CONST_SV; 156 157 if (SvTYPE(gv) == SVt_PVGV) 158 return cv_const_sv(GvCVu(gv)); 159 return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV ? SvRV(gv) : NULL; 160 } 161 162 GP * 163 Perl_newGP(pTHX_ GV *const gv) 164 { 165 GP *gp; 166 U32 hash; 167 const char *file; 168 STRLEN len; 169 #ifndef USE_ITHREADS 170 GV *filegv; 171 #endif 172 dVAR; 173 174 PERL_ARGS_ASSERT_NEWGP; 175 Newxz(gp, 1, GP); 176 gp->gp_egv = gv; /* allow compiler to reuse gv after this */ 177 #ifndef PERL_DONT_CREATE_GVSV 178 gp->gp_sv = newSV(0); 179 #endif 180 181 /* PL_curcop may be null here. E.g., 182 INIT { bless {} and exit } 183 frees INIT before looking up DESTROY (and creating *DESTROY) 184 */ 185 if (PL_curcop) { 186 gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */ 187 #ifdef USE_ITHREADS 188 if (CopFILE(PL_curcop)) { 189 file = CopFILE(PL_curcop); 190 len = strlen(file); 191 } 192 #else 193 filegv = CopFILEGV(PL_curcop); 194 if (filegv) { 195 file = GvNAME(filegv)+2; 196 len = GvNAMELEN(filegv)-2; 197 } 198 #endif 199 else goto no_file; 200 } 201 else { 202 no_file: 203 file = ""; 204 len = 0; 205 } 206 207 PERL_HASH(hash, file, len); 208 gp->gp_file_hek = share_hek(file, len, hash); 209 gp->gp_refcnt = 1; 210 211 return gp; 212 } 213 214 /* Assign CvGV(cv) = gv, handling weak references. 215 * See also S_anonymise_cv_maybe */ 216 217 void 218 Perl_cvgv_set(pTHX_ CV* cv, GV* gv) 219 { 220 GV * const oldgv = CvGV(cv); 221 HEK *hek; 222 PERL_ARGS_ASSERT_CVGV_SET; 223 224 if (oldgv == gv) 225 return; 226 227 if (oldgv) { 228 if (CvCVGV_RC(cv)) { 229 SvREFCNT_dec_NN(oldgv); 230 CvCVGV_RC_off(cv); 231 } 232 else { 233 sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv)); 234 } 235 } 236 else if ((hek = CvNAME_HEK(cv))) unshare_hek(hek); 237 238 SvANY(cv)->xcv_gv_u.xcv_gv = gv; 239 assert(!CvCVGV_RC(cv)); 240 241 if (!gv) 242 return; 243 244 if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv)) 245 Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv)); 246 else { 247 CvCVGV_RC_on(cv); 248 SvREFCNT_inc_simple_void_NN(gv); 249 } 250 } 251 252 /* Assign CvSTASH(cv) = st, handling weak references. */ 253 254 void 255 Perl_cvstash_set(pTHX_ CV *cv, HV *st) 256 { 257 HV *oldst = CvSTASH(cv); 258 PERL_ARGS_ASSERT_CVSTASH_SET; 259 if (oldst == st) 260 return; 261 if (oldst) 262 sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv)); 263 SvANY(cv)->xcv_stash = st; 264 if (st) 265 Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv)); 266 } 267 268 /* 269 =for apidoc gv_init_pvn 270 271 Converts a scalar into a typeglob. This is an incoercible typeglob; 272 assigning a reference to it will assign to one of its slots, instead of 273 overwriting it as happens with typeglobs created by SvSetSV. Converting 274 any scalar that is SvOK() may produce unpredictable results and is reserved 275 for perl's internal use. 276 277 C<gv> is the scalar to be converted. 278 279 C<stash> is the parent stash/package, if any. 280 281 C<name> and C<len> give the name. The name must be unqualified; 282 that is, it must not include the package name. If C<gv> is a 283 stash element, it is the caller's responsibility to ensure that the name 284 passed to this function matches the name of the element. If it does not 285 match, perl's internal bookkeeping will get out of sync. 286 287 C<flags> can be set to SVf_UTF8 if C<name> is a UTF8 string, or 288 the return value of SvUTF8(sv). It can also take the 289 GV_ADDMULTI flag, which means to pretend that the GV has been 290 seen before (i.e., suppress "Used once" warnings). 291 292 =for apidoc gv_init 293 294 The old form of gv_init_pvn(). It does not work with UTF8 strings, as it 295 has no flags parameter. If the C<multi> parameter is set, the 296 GV_ADDMULTI flag will be passed to gv_init_pvn(). 297 298 =for apidoc gv_init_pv 299 300 Same as gv_init_pvn(), but takes a nul-terminated string for the name 301 instead of separate char * and length parameters. 302 303 =for apidoc gv_init_sv 304 305 Same as gv_init_pvn(), but takes an SV * for the name instead of separate 306 char * and length parameters. C<flags> is currently unused. 307 308 =cut 309 */ 310 311 void 312 Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags) 313 { 314 char *namepv; 315 STRLEN namelen; 316 PERL_ARGS_ASSERT_GV_INIT_SV; 317 namepv = SvPV(namesv, namelen); 318 if (SvUTF8(namesv)) 319 flags |= SVf_UTF8; 320 gv_init_pvn(gv, stash, namepv, namelen, flags); 321 } 322 323 void 324 Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags) 325 { 326 PERL_ARGS_ASSERT_GV_INIT_PV; 327 gv_init_pvn(gv, stash, name, strlen(name), flags); 328 } 329 330 void 331 Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags) 332 { 333 dVAR; 334 const U32 old_type = SvTYPE(gv); 335 const bool doproto = old_type > SVt_NULL; 336 char * const proto = (doproto && SvPOK(gv)) 337 ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv)) 338 : NULL; 339 const STRLEN protolen = proto ? SvCUR(gv) : 0; 340 const U32 proto_utf8 = proto ? SvUTF8(gv) : 0; 341 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL; 342 const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0; 343 344 PERL_ARGS_ASSERT_GV_INIT_PVN; 345 assert (!(proto && has_constant)); 346 347 if (has_constant) { 348 /* The constant has to be a simple scalar type. */ 349 switch (SvTYPE(has_constant)) { 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: 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 CvISXSUB_on(cv); 523 CvXSUB(cv) = core_xsub; 524 } 525 CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE 526 from PL_curcop. */ 527 (void)gv_fetchfile(file); 528 CvFILE(cv) = (char *)file; 529 /* XXX This is inefficient, as doing things this order causes 530 a prototype check in newATTRSUB. But we have to do 531 it this order as we need an op number before calling 532 new ATTRSUB. */ 533 (void)core_prototype((SV *)cv, name, code, &opnum); 534 if (stash) 535 (void)hv_store(stash,name,len,(SV *)gv,0); 536 if (ampable) { 537 #ifdef DEBUGGING 538 CV *orig_cv = cv; 539 #endif 540 CvLVALUE_on(cv); 541 /* newATTRSUB will free the CV and return NULL if we're still 542 compiling after a syntax error */ 543 if ((cv = newATTRSUB_x( 544 oldsavestack_ix, (OP *)gv, 545 NULL,NULL, 546 coresub_op( 547 opnum 548 ? newSVuv((UV)opnum) 549 : newSVpvn(name,len), 550 code, opnum 551 ), 552 TRUE 553 )) != NULL) { 554 assert(GvCV(gv) == orig_cv); 555 if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS 556 && opnum != OP_UNDEF) 557 CvLVALUE_off(cv); /* Now *that* was a neat trick. */ 558 } 559 LEAVE; 560 PL_parser = oldparser; 561 PL_curcop = oldcurcop; 562 PL_compcv = oldcompcv; 563 } 564 if (cv) { 565 SV *opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL; 566 cv_set_call_checker( 567 cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv 568 ); 569 SvREFCNT_dec(opnumsv); 570 } 571 572 return gv; 573 } 574 575 /* 576 =for apidoc gv_fetchmeth 577 578 Like L</gv_fetchmeth_pvn>, but lacks a flags parameter. 579 580 =for apidoc gv_fetchmeth_sv 581 582 Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form 583 of an SV instead of a string/length pair. 584 585 =cut 586 */ 587 588 GV * 589 Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags) 590 { 591 char *namepv; 592 STRLEN namelen; 593 PERL_ARGS_ASSERT_GV_FETCHMETH_SV; 594 namepv = SvPV(namesv, namelen); 595 if (SvUTF8(namesv)) 596 flags |= SVf_UTF8; 597 return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags); 598 } 599 600 /* 601 =for apidoc gv_fetchmeth_pv 602 603 Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string 604 instead of a string/length pair. 605 606 =cut 607 */ 608 609 GV * 610 Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags) 611 { 612 PERL_ARGS_ASSERT_GV_FETCHMETH_PV; 613 return gv_fetchmeth_pvn(stash, name, strlen(name), level, flags); 614 } 615 616 /* 617 =for apidoc gv_fetchmeth_pvn 618 619 Returns the glob with the given C<name> and a defined subroutine or 620 C<NULL>. The glob lives in the given C<stash>, or in the stashes 621 accessible via @ISA and UNIVERSAL::. 622 623 The argument C<level> should be either 0 or -1. If C<level==0>, as a 624 side-effect creates a glob with the given C<name> in the given C<stash> 625 which in the case of success contains an alias for the subroutine, and sets 626 up caching info for this glob. 627 628 The only significant values for C<flags> are GV_SUPER and SVf_UTF8. 629 630 GV_SUPER indicates that we want to look up the method in the superclasses 631 of the C<stash>. 632 633 The 634 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not 635 visible to Perl code. So when calling C<call_sv>, you should not use 636 the GV directly; instead, you should use the method's CV, which can be 637 obtained from the GV with the C<GvCV> macro. 638 639 =cut 640 */ 641 642 /* NOTE: No support for tied ISA */ 643 644 GV * 645 Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags) 646 { 647 dVAR; 648 GV** gvp; 649 AV* linear_av; 650 SV** linear_svp; 651 SV* linear_sv; 652 HV* cstash, *cachestash; 653 GV* candidate = NULL; 654 CV* cand_cv = NULL; 655 GV* topgv = NULL; 656 const char *hvname; 657 I32 create = (level >= 0) ? 1 : 0; 658 I32 items; 659 U32 topgen_cmp; 660 U32 is_utf8 = flags & SVf_UTF8; 661 662 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN; 663 664 /* UNIVERSAL methods should be callable without a stash */ 665 if (!stash) { 666 create = 0; /* probably appropriate */ 667 if(!(stash = gv_stashpvs("UNIVERSAL", 0))) 668 return 0; 669 } 670 671 assert(stash); 672 673 hvname = HvNAME_get(stash); 674 if (!hvname) 675 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); 676 677 assert(hvname); 678 assert(name); 679 680 DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n", 681 flags & GV_SUPER ? "SUPER " : "",name,hvname) ); 682 683 topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation; 684 685 if (flags & GV_SUPER) { 686 if (!HvAUX(stash)->xhv_mro_meta->super) 687 HvAUX(stash)->xhv_mro_meta->super = newHV(); 688 cachestash = HvAUX(stash)->xhv_mro_meta->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 905 as a prefix of the method name. Note 906 that if you want to keep the returned glob for a long time, you need to 907 check for it being "AUTOLOAD", since at the later time the call may load a 908 different subroutine due to $AUTOLOAD changing its value. Use the glob 909 created as a side effect to do this. 910 911 These functions have the same side-effects as C<gv_fetchmeth> with 912 C<level==0>. The warning against passing the GV returned by 913 C<gv_fetchmeth> to C<call_sv> applies 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 \"%"UTF8f 1030 "\" via package \"%"HEKf"\"", 1031 UTF8fARG(is_utf8, nend - name, name), 1032 HEKfARG(HvNAME_HEK(stash))); 1033 } 1034 else { 1035 SV* packnamesv; 1036 1037 if (nsplit) { 1038 packnamesv = newSVpvn_flags(origname, nsplit - origname, 1039 SVs_TEMP | is_utf8); 1040 } else { 1041 packnamesv = error_report; 1042 } 1043 1044 Perl_croak(aTHX_ 1045 "Can't locate object method \"%"UTF8f 1046 "\" via package \"%"SVf"\"" 1047 " (perhaps you forgot to load \"%"SVf"\"?)", 1048 UTF8fARG(is_utf8, nend - name, name), 1049 SVfARG(packnamesv), SVfARG(packnamesv)); 1050 } 1051 } 1052 } 1053 else if (autoload) { 1054 CV* const cv = GvCV(gv); 1055 if (!CvROOT(cv) && !CvXSUB(cv)) { 1056 GV* stubgv; 1057 GV* autogv; 1058 1059 if (CvANON(cv) || !CvGV(cv)) 1060 stubgv = gv; 1061 else { 1062 stubgv = CvGV(cv); 1063 if (GvCV(stubgv) != cv) /* orphaned import */ 1064 stubgv = gv; 1065 } 1066 autogv = gv_autoload_pvn(GvSTASH(stubgv), 1067 GvNAME(stubgv), GvNAMELEN(stubgv), 1068 GV_AUTOLOAD_ISMETHOD 1069 | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0)); 1070 if (autogv) 1071 gv = autogv; 1072 } 1073 } 1074 1075 return gv; 1076 } 1077 1078 GV* 1079 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags) 1080 { 1081 char *namepv; 1082 STRLEN namelen; 1083 PERL_ARGS_ASSERT_GV_AUTOLOAD_SV; 1084 namepv = SvPV(namesv, namelen); 1085 if (SvUTF8(namesv)) 1086 flags |= SVf_UTF8; 1087 return gv_autoload_pvn(stash, namepv, namelen, flags); 1088 } 1089 1090 GV* 1091 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags) 1092 { 1093 PERL_ARGS_ASSERT_GV_AUTOLOAD_PV; 1094 return gv_autoload_pvn(stash, namepv, strlen(namepv), flags); 1095 } 1096 1097 GV* 1098 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) 1099 { 1100 dVAR; 1101 GV* gv; 1102 CV* cv; 1103 HV* varstash; 1104 GV* vargv; 1105 SV* varsv; 1106 SV *packname = NULL; 1107 U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0; 1108 1109 PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN; 1110 1111 if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) 1112 return NULL; 1113 if (stash) { 1114 if (SvTYPE(stash) < SVt_PVHV) { 1115 STRLEN packname_len = 0; 1116 const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len); 1117 packname = newSVpvn_flags(packname_ptr, packname_len, 1118 SVs_TEMP | SvUTF8(stash)); 1119 stash = NULL; 1120 } 1121 else 1122 packname = sv_2mortal(newSVhek(HvNAME_HEK(stash))); 1123 if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER"); 1124 } 1125 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, 1126 is_utf8 | (flags & GV_SUPER)))) 1127 return NULL; 1128 cv = GvCV(gv); 1129 1130 if (!(CvROOT(cv) || CvXSUB(cv))) 1131 return NULL; 1132 1133 /* 1134 * Inheriting AUTOLOAD for non-methods works ... for now. 1135 */ 1136 if ( 1137 !(flags & GV_AUTOLOAD_ISMETHOD) 1138 && (GvCVGEN(gv) || GvSTASH(gv) != stash) 1139 ) 1140 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), 1141 "Use of inherited AUTOLOAD for non-method %"SVf 1142 "::%"UTF8f"() is deprecated", 1143 SVfARG(packname), 1144 UTF8fARG(is_utf8, len, name)); 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 #ifdef DEBUGGING 1260 dSP; 1261 #endif 1262 ENTER; 1263 SAVEFREESV(namesv); 1264 if ( flags & 1 ) 1265 save_scalar(gv); 1266 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL); 1267 assert(sp == PL_stack_sp); 1268 stash = gv_stashsv(namesv, 0); 1269 if (!stash) 1270 Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available", 1271 type, varname, SVfARG(namesv)); 1272 else if (!gv_fetchmethod(stash, methpv)) 1273 Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not support method %s", 1274 type, varname, SVfARG(namesv), methpv); 1275 LEAVE; 1276 } 1277 else SvREFCNT_dec_NN(namesv); 1278 return stash; 1279 } 1280 1281 /* 1282 =for apidoc gv_stashpv 1283 1284 Returns a pointer to the stash for a specified package. Uses C<strlen> to 1285 determine the length of C<name>, then calls C<gv_stashpvn()>. 1286 1287 =cut 1288 */ 1289 1290 HV* 1291 Perl_gv_stashpv(pTHX_ const char *name, I32 create) 1292 { 1293 PERL_ARGS_ASSERT_GV_STASHPV; 1294 return gv_stashpvn(name, strlen(name), create); 1295 } 1296 1297 /* 1298 =for apidoc gv_stashpvn 1299 1300 Returns a pointer to the stash for a specified package. The C<namelen> 1301 parameter indicates the length of the C<name>, in bytes. C<flags> is passed 1302 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be 1303 created if it does not already exist. If the package does not exist and 1304 C<flags> is 0 (or any other setting that does not create packages) then NULL 1305 is returned. 1306 1307 Flags may be one of: 1308 1309 GV_ADD 1310 SVf_UTF8 1311 GV_NOADD_NOINIT 1312 GV_NOINIT 1313 GV_NOEXPAND 1314 GV_ADDMG 1315 1316 The most important of which are probably GV_ADD and SVf_UTF8. 1317 1318 =cut 1319 */ 1320 1321 HV* 1322 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) 1323 { 1324 char smallbuf[128]; 1325 char *tmpbuf; 1326 HV *stash; 1327 GV *tmpgv; 1328 U32 tmplen = namelen + 2; 1329 1330 PERL_ARGS_ASSERT_GV_STASHPVN; 1331 1332 if (tmplen <= sizeof smallbuf) 1333 tmpbuf = smallbuf; 1334 else 1335 Newx(tmpbuf, tmplen, char); 1336 Copy(name, tmpbuf, namelen, char); 1337 tmpbuf[namelen] = ':'; 1338 tmpbuf[namelen+1] = ':'; 1339 tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV); 1340 if (tmpbuf != smallbuf) 1341 Safefree(tmpbuf); 1342 if (!tmpgv) 1343 return NULL; 1344 stash = GvHV(tmpgv); 1345 if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL; 1346 assert(stash); 1347 if (!HvNAME_get(stash)) { 1348 hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 ); 1349 1350 /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */ 1351 /* If the containing stash has multiple effective 1352 names, see that this one gets them, too. */ 1353 if (HvAUX(GvSTASH(tmpgv))->xhv_name_count) 1354 mro_package_moved(stash, NULL, tmpgv, 1); 1355 } 1356 return stash; 1357 } 1358 1359 /* 1360 =for apidoc gv_stashsv 1361 1362 Returns a pointer to the stash for a specified package. See C<gv_stashpvn>. 1363 1364 =cut 1365 */ 1366 1367 HV* 1368 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags) 1369 { 1370 STRLEN len; 1371 const char * const ptr = SvPV_const(sv,len); 1372 1373 PERL_ARGS_ASSERT_GV_STASHSV; 1374 1375 return gv_stashpvn(ptr, len, flags | SvUTF8(sv)); 1376 } 1377 1378 1379 GV * 1380 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) { 1381 PERL_ARGS_ASSERT_GV_FETCHPV; 1382 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type); 1383 } 1384 1385 GV * 1386 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) { 1387 STRLEN len; 1388 const char * const nambeg = 1389 SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC); 1390 PERL_ARGS_ASSERT_GV_FETCHSV; 1391 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type); 1392 } 1393 1394 PERL_STATIC_INLINE void 1395 S_gv_magicalize_isa(pTHX_ GV *gv) 1396 { 1397 AV* av; 1398 1399 PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA; 1400 1401 av = GvAVn(gv); 1402 GvMULTI_on(gv); 1403 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa, 1404 NULL, 0); 1405 } 1406 1407 /* This function grabs name and tries to split a stash and glob 1408 * from its contents. TODO better description, comments 1409 * 1410 * If the function returns TRUE and 'name == name_end', then 1411 * 'gv' can be directly returned to the caller of gv_fetchpvn_flags 1412 */ 1413 PERL_STATIC_INLINE bool 1414 S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, 1415 STRLEN *len, const char *nambeg, STRLEN full_len, 1416 const U32 is_utf8, const I32 add) 1417 { 1418 const char *name_cursor; 1419 const char *const name_end = nambeg + full_len; 1420 const char *const name_em1 = name_end - 1; 1421 1422 PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME; 1423 1424 if (full_len > 2 && **name == '*' && isIDFIRST_lazy_if(*name + 1, is_utf8)) { 1425 /* accidental stringify on a GV? */ 1426 (*name)++; 1427 } 1428 1429 for (name_cursor = *name; name_cursor < name_end; name_cursor++) { 1430 if (name_cursor < name_em1 && 1431 ((*name_cursor == ':' && name_cursor[1] == ':') 1432 || *name_cursor == '\'')) 1433 { 1434 if (!*stash) 1435 *stash = PL_defstash; 1436 if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */ 1437 return FALSE; 1438 1439 *len = name_cursor - *name; 1440 if (name_cursor > nambeg) { /* Skip for initial :: or ' */ 1441 const char *key; 1442 GV**gvp; 1443 if (*name_cursor == ':') { 1444 key = *name; 1445 *len += 2; 1446 } 1447 else { 1448 char *tmpbuf; 1449 Newx(tmpbuf, *len+2, char); 1450 Copy(*name, tmpbuf, *len, char); 1451 tmpbuf[(*len)++] = ':'; 1452 tmpbuf[(*len)++] = ':'; 1453 key = tmpbuf; 1454 } 1455 gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add); 1456 *gv = gvp ? *gvp : NULL; 1457 if (*gv && *gv != (const GV *)&PL_sv_undef) { 1458 if (SvTYPE(*gv) != SVt_PVGV) 1459 gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8); 1460 else 1461 GvMULTI_on(*gv); 1462 } 1463 if (key != *name) 1464 Safefree(key); 1465 if (!*gv || *gv == (const GV *)&PL_sv_undef) 1466 return FALSE; 1467 1468 if (!(*stash = GvHV(*gv))) { 1469 *stash = GvHV(*gv) = newHV(); 1470 if (!HvNAME_get(*stash)) { 1471 if (GvSTASH(*gv) == PL_defstash && *len == 6 1472 && strnEQ(*name, "CORE", 4)) 1473 hv_name_set(*stash, "CORE", 4, 0); 1474 else 1475 hv_name_set( 1476 *stash, nambeg, name_cursor-nambeg, is_utf8 1477 ); 1478 /* If the containing stash has multiple effective 1479 names, see that this one gets them, too. */ 1480 if (HvAUX(GvSTASH(*gv))->xhv_name_count) 1481 mro_package_moved(*stash, NULL, *gv, 1); 1482 } 1483 } 1484 else if (!HvNAME_get(*stash)) 1485 hv_name_set(*stash, nambeg, name_cursor - nambeg, is_utf8); 1486 } 1487 1488 if (*name_cursor == ':') 1489 name_cursor++; 1490 *name = name_cursor+1; 1491 if (*name == name_end) { 1492 if (!*gv) 1493 *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE)); 1494 return TRUE; 1495 } 1496 } 1497 } 1498 *len = name_cursor - *name; 1499 return TRUE; 1500 } 1501 1502 /* Checks if an unqualified name is in the main stash */ 1503 PERL_STATIC_INLINE bool 1504 S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8) 1505 { 1506 PERL_ARGS_ASSERT_GV_IS_IN_MAIN; 1507 1508 /* If it's an alphanumeric variable */ 1509 if ( len && isIDFIRST_lazy_if(name, is_utf8) ) { 1510 /* Some "normal" variables are always in main::, 1511 * like INC or STDOUT. 1512 */ 1513 switch (len) { 1514 case 1: 1515 if (*name == '_') 1516 return TRUE; 1517 break; 1518 case 3: 1519 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C') 1520 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V') 1521 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G')) 1522 return TRUE; 1523 break; 1524 case 4: 1525 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G' 1526 && name[3] == 'V') 1527 return TRUE; 1528 break; 1529 case 5: 1530 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D' 1531 && name[3] == 'I' && name[4] == 'N') 1532 return TRUE; 1533 break; 1534 case 6: 1535 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D') 1536 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T') 1537 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R'))) 1538 return TRUE; 1539 break; 1540 case 7: 1541 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G' 1542 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U' 1543 && name[6] == 'T') 1544 return TRUE; 1545 break; 1546 } 1547 } 1548 /* *{""}, or a special variable like $@ */ 1549 else 1550 return TRUE; 1551 1552 return FALSE; 1553 } 1554 1555 1556 /* This function is called if parse_gv_stash_name() failed to 1557 * find a stash, or if GV_NOTQUAL or an empty name was passed 1558 * to gv_fetchpvn_flags. 1559 * 1560 * It returns FALSE if the default stash can't be found nor created, 1561 * which might happen during global destruction. 1562 */ 1563 PERL_STATIC_INLINE bool 1564 S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len, 1565 const U32 is_utf8, const I32 add, 1566 const svtype sv_type) 1567 { 1568 PERL_ARGS_ASSERT_FIND_DEFAULT_STASH; 1569 1570 /* No stash in name, so see how we can default */ 1571 1572 if ( gv_is_in_main(name, len, is_utf8) ) { 1573 *stash = PL_defstash; 1574 } 1575 else { 1576 if (IN_PERL_COMPILETIME) { 1577 *stash = PL_curstash; 1578 if (add && (PL_hints & HINT_STRICT_VARS) && 1579 sv_type != SVt_PVCV && 1580 sv_type != SVt_PVGV && 1581 sv_type != SVt_PVFM && 1582 sv_type != SVt_PVIO && 1583 !(len == 1 && sv_type == SVt_PV && 1584 (*name == 'a' || *name == 'b')) ) 1585 { 1586 GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -(I32)len : (I32)len,0); 1587 if (!gvp || *gvp == (const GV *)&PL_sv_undef || 1588 SvTYPE(*gvp) != SVt_PVGV) 1589 { 1590 *stash = NULL; 1591 } 1592 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) || 1593 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) || 1594 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) ) 1595 { 1596 /* diag_listed_as: Variable "%s" is not imported%s */ 1597 Perl_ck_warner_d( 1598 aTHX_ packWARN(WARN_MISC), 1599 "Variable \"%c%"UTF8f"\" is not imported", 1600 sv_type == SVt_PVAV ? '@' : 1601 sv_type == SVt_PVHV ? '%' : '$', 1602 UTF8fARG(is_utf8, len, name)); 1603 if (GvCVu(*gvp)) 1604 Perl_ck_warner_d( 1605 aTHX_ packWARN(WARN_MISC), 1606 "\t(Did you mean &%"UTF8f" instead?)\n", 1607 UTF8fARG(is_utf8, len, name) 1608 ); 1609 *stash = NULL; 1610 } 1611 } 1612 } 1613 else { 1614 /* Use the current op's stash */ 1615 *stash = CopSTASH(PL_curcop); 1616 } 1617 } 1618 1619 if (!*stash) { 1620 if (add && !PL_in_clean_all) { 1621 SV * const err = Perl_mess(aTHX_ 1622 "Global symbol \"%s%"UTF8f 1623 "\" requires explicit package name", 1624 (sv_type == SVt_PV ? "$" 1625 : sv_type == SVt_PVAV ? "@" 1626 : sv_type == SVt_PVHV ? "%" 1627 : ""), UTF8fARG(is_utf8, len, name)); 1628 GV *gv; 1629 if (is_utf8) 1630 SvUTF8_on(err); 1631 qerror(err); 1632 /* To maintain the output of errors after the strict exception 1633 * above, and to keep compat with older releases, rather than 1634 * placing the variables in the pad, we place 1635 * them in the <none>:: stash. 1636 */ 1637 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV); 1638 if (!gv) { 1639 /* symbol table under destruction */ 1640 return FALSE; 1641 } 1642 *stash = GvHV(gv); 1643 } 1644 else 1645 return FALSE; 1646 } 1647 1648 if (!SvREFCNT(*stash)) /* symbol table under destruction */ 1649 return FALSE; 1650 1651 return TRUE; 1652 } 1653 1654 /* gv_magicalize() is called by gv_fetchpvn_flags when creating 1655 * a new GV. 1656 * Note that it does not insert the GV into the stash prior to 1657 * magicalization, which some variables require need in order 1658 * to work (like $[, %+, %-, %!), so callers must take care of 1659 * that beforehand. 1660 * 1661 * The return value has a specific meaning for gv_fetchpvn_flags: 1662 * If it returns true, and the gv is empty, it indicates that its 1663 * refcount should be decreased. 1664 */ 1665 PERL_STATIC_INLINE bool 1666 S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, 1667 bool addmg, const svtype sv_type) 1668 { 1669 SSize_t paren; 1670 1671 PERL_ARGS_ASSERT_GV_MAGICALIZE; 1672 1673 if (stash != PL_defstash) { /* not the main stash */ 1674 /* We only have to check for a few names here: a, b, EXPORT, ISA 1675 and VERSION. All the others apply only to the main stash or to 1676 CORE (which is checked right after this). */ 1677 if (len) { 1678 const char * const name2 = name + 1; 1679 switch (*name) { 1680 case 'E': 1681 if (strnEQ(name2, "XPORT", 5)) 1682 GvMULTI_on(gv); 1683 break; 1684 case 'I': 1685 if (strEQ(name2, "SA")) 1686 gv_magicalize_isa(gv); 1687 break; 1688 case 'V': 1689 if (strEQ(name2, "ERSION")) 1690 GvMULTI_on(gv); 1691 break; 1692 case 'a': 1693 case 'b': 1694 if (len == 1 && sv_type == SVt_PV) 1695 GvMULTI_on(gv); 1696 /* FALL THROUGH */ 1697 default: 1698 goto try_core; 1699 } 1700 return addmg; 1701 } 1702 try_core: 1703 if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) { 1704 /* Avoid null warning: */ 1705 const char * const stashname = HvNAME(stash); assert(stashname); 1706 if (strnEQ(stashname, "CORE", 4)) 1707 S_maybe_add_coresub(aTHX_ 0, gv, name, len); 1708 } 1709 } 1710 else if (len > 1) { 1711 #ifndef EBCDIC 1712 if (*name > 'V' ) { 1713 NOOP; 1714 /* Nothing else to do. 1715 The compiler will probably turn the switch statement into a 1716 branch table. Make sure we avoid even that small overhead for 1717 the common case of lower case variable names. (On EBCDIC 1718 platforms, we can't just do: 1719 if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) { 1720 because cases like '\027' in the switch statement below are 1721 C1 (non-ASCII) controls on those platforms, so the remapping 1722 would make them larger than 'V') 1723 */ 1724 } else 1725 #endif 1726 { 1727 const char * const name2 = name + 1; 1728 switch (*name) { 1729 case 'A': 1730 if (strEQ(name2, "RGV")) { 1731 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; 1732 } 1733 else if (strEQ(name2, "RGVOUT")) { 1734 GvMULTI_on(gv); 1735 } 1736 break; 1737 case 'E': 1738 if (strnEQ(name2, "XPORT", 5)) 1739 GvMULTI_on(gv); 1740 break; 1741 case 'I': 1742 if (strEQ(name2, "SA")) { 1743 gv_magicalize_isa(gv); 1744 } 1745 break; 1746 case 'S': 1747 if (strEQ(name2, "IG")) { 1748 HV *hv; 1749 I32 i; 1750 if (!PL_psig_name) { 1751 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*); 1752 Newxz(PL_psig_pend, SIG_SIZE, int); 1753 PL_psig_ptr = PL_psig_name + SIG_SIZE; 1754 } else { 1755 /* I think that the only way to get here is to re-use an 1756 embedded perl interpreter, where the previous 1757 use didn't clean up fully because 1758 PL_perl_destruct_level was 0. I'm not sure that we 1759 "support" that, in that I suspect in that scenario 1760 there are sufficient other garbage values left in the 1761 interpreter structure that something else will crash 1762 before we get here. I suspect that this is one of 1763 those "doctor, it hurts when I do this" bugs. */ 1764 Zero(PL_psig_name, 2 * SIG_SIZE, SV*); 1765 Zero(PL_psig_pend, SIG_SIZE, int); 1766 } 1767 GvMULTI_on(gv); 1768 hv = GvHVn(gv); 1769 hv_magic(hv, NULL, PERL_MAGIC_sig); 1770 for (i = 1; i < SIG_SIZE; i++) { 1771 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1); 1772 if (init) 1773 sv_setsv(*init, &PL_sv_undef); 1774 } 1775 } 1776 break; 1777 case 'V': 1778 if (strEQ(name2, "ERSION")) 1779 GvMULTI_on(gv); 1780 break; 1781 case '\003': /* $^CHILD_ERROR_NATIVE */ 1782 if (strEQ(name2, "HILD_ERROR_NATIVE")) 1783 goto magicalize; 1784 break; 1785 case '\005': /* $^ENCODING */ 1786 if (strEQ(name2, "NCODING")) 1787 goto magicalize; 1788 break; 1789 case '\007': /* $^GLOBAL_PHASE */ 1790 if (strEQ(name2, "LOBAL_PHASE")) 1791 goto ro_magicalize; 1792 break; 1793 case '\014': /* $^LAST_FH */ 1794 if (strEQ(name2, "AST_FH")) 1795 goto ro_magicalize; 1796 break; 1797 case '\015': /* $^MATCH */ 1798 if (strEQ(name2, "ATCH")) { 1799 paren = RX_BUFF_IDX_CARET_FULLMATCH; 1800 goto storeparen; 1801 } 1802 break; 1803 case '\017': /* $^OPEN */ 1804 if (strEQ(name2, "PEN")) 1805 goto magicalize; 1806 break; 1807 case '\020': /* $^PREMATCH $^POSTMATCH */ 1808 if (strEQ(name2, "REMATCH")) { 1809 paren = RX_BUFF_IDX_CARET_PREMATCH; 1810 goto storeparen; 1811 } 1812 if (strEQ(name2, "OSTMATCH")) { 1813 paren = RX_BUFF_IDX_CARET_POSTMATCH; 1814 goto storeparen; 1815 } 1816 break; 1817 case '\024': /* ${^TAINT} */ 1818 if (strEQ(name2, "AINT")) 1819 goto ro_magicalize; 1820 break; 1821 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */ 1822 if (strEQ(name2, "NICODE")) 1823 goto ro_magicalize; 1824 if (strEQ(name2, "TF8LOCALE")) 1825 goto ro_magicalize; 1826 if (strEQ(name2, "TF8CACHE")) 1827 goto magicalize; 1828 break; 1829 case '\027': /* $^WARNING_BITS */ 1830 if (strEQ(name2, "ARNING_BITS")) 1831 goto magicalize; 1832 break; 1833 case '1': 1834 case '2': 1835 case '3': 1836 case '4': 1837 case '5': 1838 case '6': 1839 case '7': 1840 case '8': 1841 case '9': 1842 { 1843 /* Ensures that we have an all-digit variable, ${"1foo"} fails 1844 this test */ 1845 /* This snippet is taken from is_gv_magical */ 1846 const char *end = name + len; 1847 while (--end > name) { 1848 if (!isDIGIT(*end)) 1849 return addmg; 1850 } 1851 paren = strtoul(name, NULL, 10); 1852 goto storeparen; 1853 } 1854 } 1855 } 1856 } else { 1857 /* Names of length 1. (Or 0. But name is NUL terminated, so that will 1858 be case '\0' in this switch statement (ie a default case) */ 1859 switch (*name) { 1860 case '&': /* $& */ 1861 paren = RX_BUFF_IDX_FULLMATCH; 1862 goto sawampersand; 1863 case '`': /* $` */ 1864 paren = RX_BUFF_IDX_PREMATCH; 1865 goto sawampersand; 1866 case '\'': /* $' */ 1867 paren = RX_BUFF_IDX_POSTMATCH; 1868 sawampersand: 1869 #ifdef PERL_SAWAMPERSAND 1870 if (!( 1871 sv_type == SVt_PVAV || 1872 sv_type == SVt_PVHV || 1873 sv_type == SVt_PVCV || 1874 sv_type == SVt_PVFM || 1875 sv_type == SVt_PVIO 1876 )) { PL_sawampersand |= 1877 (*name == '`') 1878 ? SAWAMPERSAND_LEFT 1879 : (*name == '&') 1880 ? SAWAMPERSAND_MIDDLE 1881 : SAWAMPERSAND_RIGHT; 1882 } 1883 #endif 1884 goto storeparen; 1885 case '1': /* $1 */ 1886 case '2': /* $2 */ 1887 case '3': /* $3 */ 1888 case '4': /* $4 */ 1889 case '5': /* $5 */ 1890 case '6': /* $6 */ 1891 case '7': /* $7 */ 1892 case '8': /* $8 */ 1893 case '9': /* $9 */ 1894 paren = *name - '0'; 1895 1896 storeparen: 1897 /* Flag the capture variables with a NULL mg_ptr 1898 Use mg_len for the array index to lookup. */ 1899 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren); 1900 break; 1901 1902 case ':': /* $: */ 1903 sv_setpv(GvSVn(gv),PL_chopset); 1904 goto magicalize; 1905 1906 case '?': /* $? */ 1907 #ifdef COMPLEX_STATUS 1908 SvUPGRADE(GvSVn(gv), SVt_PVLV); 1909 #endif 1910 goto magicalize; 1911 1912 case '!': /* $! */ 1913 GvMULTI_on(gv); 1914 /* If %! has been used, automatically load Errno.pm. */ 1915 1916 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); 1917 1918 /* magicalization must be done before require_tie_mod is called */ 1919 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) 1920 { 1921 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); 1922 addmg = FALSE; 1923 } 1924 1925 break; 1926 case '-': /* $- */ 1927 case '+': /* $+ */ 1928 GvMULTI_on(gv); /* no used once warnings here */ 1929 { 1930 AV* const av = GvAVn(gv); 1931 SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL; 1932 1933 sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0); 1934 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); 1935 if (avc) 1936 SvREADONLY_on(GvSVn(gv)); 1937 SvREADONLY_on(av); 1938 1939 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) 1940 { 1941 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0); 1942 addmg = FALSE; 1943 } 1944 1945 break; 1946 } 1947 case '*': /* $* */ 1948 case '#': /* $# */ 1949 if (sv_type == SVt_PV) 1950 /* diag_listed_as: $* is no longer supported */ 1951 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), 1952 "$%c is no longer supported", *name); 1953 break; 1954 case '\010': /* $^H */ 1955 { 1956 HV *const hv = GvHVn(gv); 1957 hv_magic(hv, NULL, PERL_MAGIC_hints); 1958 } 1959 goto magicalize; 1960 case '[': /* $[ */ 1961 if ((sv_type == SVt_PV || sv_type == SVt_PVGV) 1962 && FEATURE_ARYBASE_IS_ENABLED) { 1963 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0); 1964 addmg = FALSE; 1965 } 1966 else goto magicalize; 1967 break; 1968 case '\023': /* $^S */ 1969 ro_magicalize: 1970 SvREADONLY_on(GvSVn(gv)); 1971 /* FALL THROUGH */ 1972 case '0': /* $0 */ 1973 case '^': /* $^ */ 1974 case '~': /* $~ */ 1975 case '=': /* $= */ 1976 case '%': /* $% */ 1977 case '.': /* $. */ 1978 case '(': /* $( */ 1979 case ')': /* $) */ 1980 case '<': /* $< */ 1981 case '>': /* $> */ 1982 case '\\': /* $\ */ 1983 case '/': /* $/ */ 1984 case '|': /* $| */ 1985 case '$': /* $$ */ 1986 case '\001': /* $^A */ 1987 case '\003': /* $^C */ 1988 case '\004': /* $^D */ 1989 case '\005': /* $^E */ 1990 case '\006': /* $^F */ 1991 case '\011': /* $^I, NOT \t in EBCDIC */ 1992 case '\016': /* $^N */ 1993 case '\017': /* $^O */ 1994 case '\020': /* $^P */ 1995 case '\024': /* $^T */ 1996 case '\027': /* $^W */ 1997 magicalize: 1998 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); 1999 break; 2000 2001 case '\014': /* $^L */ 2002 sv_setpvs(GvSVn(gv),"\f"); 2003 break; 2004 case ';': /* $; */ 2005 sv_setpvs(GvSVn(gv),"\034"); 2006 break; 2007 case ']': /* $] */ 2008 { 2009 SV * const sv = GvSV(gv); 2010 if (!sv_derived_from(PL_patchlevel, "version")) 2011 upg_version(PL_patchlevel, TRUE); 2012 GvSV(gv) = vnumify(PL_patchlevel); 2013 SvREADONLY_on(GvSV(gv)); 2014 SvREFCNT_dec(sv); 2015 } 2016 break; 2017 case '\026': /* $^V */ 2018 { 2019 SV * const sv = GvSV(gv); 2020 GvSV(gv) = new_version(PL_patchlevel); 2021 SvREADONLY_on(GvSV(gv)); 2022 SvREFCNT_dec(sv); 2023 } 2024 break; 2025 case 'a': 2026 case 'b': 2027 if (sv_type == SVt_PV) 2028 GvMULTI_on(gv); 2029 } 2030 } 2031 2032 return addmg; 2033 } 2034 2035 /* This function is called when the stash already holds the GV of the magic 2036 * variable we're looking for, but we need to check that it has the correct 2037 * kind of magic. For example, if someone first uses $! and then %!, the 2038 * latter would end up here, and we add the Errno tie to the HASH slot of 2039 * the *! glob. 2040 */ 2041 PERL_STATIC_INLINE void 2042 S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type) 2043 { 2044 PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV; 2045 2046 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) { 2047 if (*name == '!') 2048 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); 2049 else if (*name == '-' || *name == '+') 2050 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0); 2051 } else if (sv_type == SVt_PV) { 2052 if (*name == '*' || *name == '#') { 2053 /* diag_listed_as: $* is no longer supported */ 2054 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, 2055 WARN_SYNTAX), 2056 "$%c is no longer supported", *name); 2057 } 2058 } 2059 if (sv_type==SVt_PV || sv_type==SVt_PVGV) { 2060 switch (*name) { 2061 case '[': 2062 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0); 2063 break; 2064 #ifdef PERL_SAWAMPERSAND 2065 case '`': 2066 PL_sawampersand |= SAWAMPERSAND_LEFT; 2067 (void)GvSVn(gv); 2068 break; 2069 case '&': 2070 PL_sawampersand |= SAWAMPERSAND_MIDDLE; 2071 (void)GvSVn(gv); 2072 break; 2073 case '\'': 2074 PL_sawampersand |= SAWAMPERSAND_RIGHT; 2075 (void)GvSVn(gv); 2076 break; 2077 #endif 2078 } 2079 } 2080 } 2081 2082 GV * 2083 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, 2084 const svtype sv_type) 2085 { 2086 dVAR; 2087 const char *name = nambeg; 2088 GV *gv = NULL; 2089 GV**gvp; 2090 STRLEN len; 2091 HV *stash = NULL; 2092 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT); 2093 const I32 no_expand = flags & GV_NOEXPAND; 2094 const I32 add = flags & ~GV_NOADD_MASK; 2095 const U32 is_utf8 = flags & SVf_UTF8; 2096 bool addmg = cBOOL(flags & GV_ADDMG); 2097 const char *const name_end = nambeg + full_len; 2098 U32 faking_it; 2099 2100 PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS; 2101 2102 /* If we have GV_NOTQUAL, the caller promised that 2103 * there is no stash, so we can skip the check. 2104 * Similarly if full_len is 0, since then we're 2105 * dealing with something like *{""} or ""->foo() 2106 */ 2107 if ((flags & GV_NOTQUAL) || !full_len) { 2108 len = full_len; 2109 } 2110 else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) { 2111 if (name == name_end) return gv; 2112 } 2113 else { 2114 return NULL; 2115 } 2116 2117 if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) { 2118 return NULL; 2119 } 2120 2121 /* By this point we should have a stash and a name */ 2122 gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add); 2123 if (!gvp || *gvp == (const GV *)&PL_sv_undef) { 2124 if (addmg) gv = (GV *)newSV(0); 2125 else return NULL; 2126 } 2127 else gv = *gvp, addmg = 0; 2128 /* From this point on, addmg means gv has not been inserted in the 2129 symtab yet. */ 2130 2131 if (SvTYPE(gv) == SVt_PVGV) { 2132 /* The GV already exists, so return it, but check if we need to do 2133 * anything else with it before that. 2134 */ 2135 if (add) { 2136 /* This is the heuristic that handles if a variable triggers the 2137 * 'used only once' warning. If there's already a GV in the stash 2138 * with this name, then we assume that the variable has been used 2139 * before and turn its MULTI flag on. 2140 * It's a heuristic because it can easily be "tricked", like with 2141 * BEGIN { $a = 1; $::{foo} = *a }; () = $foo 2142 * not warning about $main::foo being used just once 2143 */ 2144 GvMULTI_on(gv); 2145 gv_init_svtype(gv, sv_type); 2146 /* You reach this path once the typeglob has already been created, 2147 either by the same or a different sigil. If this path didn't 2148 exist, then (say) referencing $! first, and %! second would 2149 mean that %! was not handled correctly. */ 2150 if (len == 1 && stash == PL_defstash) { 2151 maybe_multimagic_gv(gv, name, sv_type); 2152 } 2153 else if (len == 3 && sv_type == SVt_PVAV 2154 && strnEQ(name, "ISA", 3) 2155 && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv)))) 2156 gv_magicalize_isa(gv); 2157 } 2158 return gv; 2159 } else if (no_init) { 2160 assert(!addmg); 2161 return gv; 2162 } 2163 /* If GV_NOEXPAND is true and what we got off the stash is a ref, 2164 * don't expand it to a glob. This is an optimization so that things 2165 * copying constants over, like Exporter, don't have to be rewritten 2166 * to take into account that you can store more than just globs in 2167 * stashes. 2168 */ 2169 else if (no_expand && SvROK(gv)) { 2170 assert(!addmg); 2171 return gv; 2172 } 2173 2174 /* Adding a new symbol. 2175 Unless of course there was already something non-GV here, in which case 2176 we want to behave as if there was always a GV here, containing some sort 2177 of subroutine. 2178 Otherwise we run the risk of creating things like GvIO, which can cause 2179 subtle bugs. eg the one that tripped up SQL::Translator */ 2180 2181 faking_it = SvOK(gv); 2182 2183 if (add & GV_ADDWARN) 2184 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), 2185 "Had to create %"UTF8f" unexpectedly", 2186 UTF8fARG(is_utf8, name_end-nambeg, nambeg)); 2187 gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8); 2188 2189 if ( isIDFIRST_lazy_if(name, is_utf8) && !ckWARN(WARN_ONCE) ) 2190 GvMULTI_on(gv) ; 2191 2192 /* First, store the gv in the symtab if we're adding magic, 2193 * but only for non-empty GVs 2194 */ 2195 #define GvEMPTY(gv) !(GvAV(gv) || GvHV(gv) || GvIO(gv) \ 2196 || GvCV(gv) || (GvSV(gv) && SvOK(GvSV(gv)))) 2197 2198 if ( addmg && !GvEMPTY(gv) ) { 2199 (void)hv_store(stash,name,len,(SV *)gv,0); 2200 } 2201 2202 /* set up magic where warranted */ 2203 if ( gv_magicalize(gv, stash, name, len, addmg, sv_type) ) { 2204 /* See 23496c6 */ 2205 if (GvEMPTY(gv)) { 2206 if ( GvSV(gv) && SvMAGICAL(GvSV(gv)) ) { 2207 /* The GV was and still is "empty", except that now 2208 * it has the magic flags turned on, so we want it 2209 * stored in the symtab. 2210 */ 2211 (void)hv_store(stash,name,len,(SV *)gv,0); 2212 } 2213 else { 2214 /* Most likely the temporary GV created above */ 2215 SvREFCNT_dec_NN(gv); 2216 gv = NULL; 2217 } 2218 } 2219 } 2220 2221 if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type); 2222 return gv; 2223 } 2224 2225 void 2226 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) 2227 { 2228 const char *name; 2229 const HV * const hv = GvSTASH(gv); 2230 2231 PERL_ARGS_ASSERT_GV_FULLNAME4; 2232 2233 sv_setpv(sv, prefix ? prefix : ""); 2234 2235 if (hv && (name = HvNAME(hv))) { 2236 const STRLEN len = HvNAMELEN(hv); 2237 if (keepmain || strnNE(name, "main", len)) { 2238 sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES); 2239 sv_catpvs(sv,"::"); 2240 } 2241 } 2242 else sv_catpvs(sv,"__ANON__::"); 2243 sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv)))); 2244 } 2245 2246 void 2247 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) 2248 { 2249 const GV * const egv = GvEGVx(gv); 2250 2251 PERL_ARGS_ASSERT_GV_EFULLNAME4; 2252 2253 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain); 2254 } 2255 2256 2257 /* recursively scan a stash and any nested stashes looking for entries 2258 * that need the "only used once" warning raised 2259 */ 2260 2261 void 2262 Perl_gv_check(pTHX_ HV *stash) 2263 { 2264 dVAR; 2265 I32 i; 2266 2267 PERL_ARGS_ASSERT_GV_CHECK; 2268 2269 if (!HvARRAY(stash)) 2270 return; 2271 2272 assert(SvOOK(stash)); 2273 2274 for (i = 0; i <= (I32) HvMAX(stash); i++) { 2275 const HE *entry; 2276 /* mark stash is being scanned, to avoid recursing */ 2277 HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH; 2278 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { 2279 GV *gv; 2280 HV *hv; 2281 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && 2282 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv))) 2283 { 2284 if (hv != PL_defstash && hv != stash 2285 && !(SvOOK(hv) 2286 && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH)) 2287 ) 2288 gv_check(hv); /* nested package */ 2289 } 2290 else if ( *HeKEY(entry) != '_' 2291 && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) { 2292 const char *file; 2293 gv = MUTABLE_GV(HeVAL(entry)); 2294 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) 2295 continue; 2296 file = GvFILE(gv); 2297 CopLINE_set(PL_curcop, GvLINE(gv)); 2298 #ifdef USE_ITHREADS 2299 CopFILE(PL_curcop) = (char *)file; /* set for warning */ 2300 #else 2301 CopFILEGV(PL_curcop) 2302 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0); 2303 #endif 2304 Perl_warner(aTHX_ packWARN(WARN_ONCE), 2305 "Name \"%"HEKf"::%"HEKf 2306 "\" used only once: possible typo", 2307 HEKfARG(HvNAME_HEK(stash)), 2308 HEKfARG(GvNAME_HEK(gv))); 2309 } 2310 } 2311 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH; 2312 } 2313 } 2314 2315 GV * 2316 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags) 2317 { 2318 dVAR; 2319 PERL_ARGS_ASSERT_NEWGVGEN_FLAGS; 2320 assert(!(flags & ~SVf_UTF8)); 2321 2322 return gv_fetchpv(Perl_form(aTHX_ "%"UTF8f"::_GEN_%ld", 2323 UTF8fARG(flags, strlen(pack), pack), 2324 (long)PL_gensym++), 2325 GV_ADD, SVt_PVGV); 2326 } 2327 2328 /* hopefully this is only called on local symbol table entries */ 2329 2330 GP* 2331 Perl_gp_ref(pTHX_ GP *gp) 2332 { 2333 dVAR; 2334 if (!gp) 2335 return NULL; 2336 gp->gp_refcnt++; 2337 if (gp->gp_cv) { 2338 if (gp->gp_cvgen) { 2339 /* If the GP they asked for a reference to contains 2340 a method cache entry, clear it first, so that we 2341 don't infect them with our cached entry */ 2342 SvREFCNT_dec_NN(gp->gp_cv); 2343 gp->gp_cv = NULL; 2344 gp->gp_cvgen = 0; 2345 } 2346 } 2347 return gp; 2348 } 2349 2350 void 2351 Perl_gp_free(pTHX_ GV *gv) 2352 { 2353 dVAR; 2354 GP* gp; 2355 int attempts = 100; 2356 2357 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv))) 2358 return; 2359 if (gp->gp_refcnt == 0) { 2360 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), 2361 "Attempt to free unreferenced glob pointers" 2362 pTHX__FORMAT pTHX__VALUE); 2363 return; 2364 } 2365 if (gp->gp_refcnt > 1) { 2366 borrowed: 2367 if (gp->gp_egv == gv) 2368 gp->gp_egv = 0; 2369 gp->gp_refcnt--; 2370 GvGP_set(gv, NULL); 2371 return; 2372 } 2373 2374 while (1) { 2375 /* Copy and null out all the glob slots, so destructors do not see 2376 freed SVs. */ 2377 HEK * const file_hek = gp->gp_file_hek; 2378 SV * const sv = gp->gp_sv; 2379 AV * const av = gp->gp_av; 2380 HV * const hv = gp->gp_hv; 2381 IO * const io = gp->gp_io; 2382 CV * const cv = gp->gp_cv; 2383 CV * const form = gp->gp_form; 2384 2385 gp->gp_file_hek = NULL; 2386 gp->gp_sv = NULL; 2387 gp->gp_av = NULL; 2388 gp->gp_hv = NULL; 2389 gp->gp_io = NULL; 2390 gp->gp_cv = NULL; 2391 gp->gp_form = NULL; 2392 2393 if (file_hek) 2394 unshare_hek(file_hek); 2395 2396 SvREFCNT_dec(sv); 2397 SvREFCNT_dec(av); 2398 /* FIXME - another reference loop GV -> symtab -> GV ? 2399 Somehow gp->gp_hv can end up pointing at freed garbage. */ 2400 if (hv && SvTYPE(hv) == SVt_PVHV) { 2401 const HEK *hvname_hek = HvNAME_HEK(hv); 2402 DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", hvname_hek)); 2403 if (PL_stashcache && hvname_hek) 2404 (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD); 2405 SvREFCNT_dec(hv); 2406 } 2407 SvREFCNT_dec(io); 2408 SvREFCNT_dec(cv); 2409 SvREFCNT_dec(form); 2410 2411 /* Possibly reallocated by a destructor */ 2412 gp = GvGP(gv); 2413 2414 if (!gp->gp_file_hek 2415 && !gp->gp_sv 2416 && !gp->gp_av 2417 && !gp->gp_hv 2418 && !gp->gp_io 2419 && !gp->gp_cv 2420 && !gp->gp_form) break; 2421 2422 if (--attempts == 0) { 2423 Perl_die(aTHX_ 2424 "panic: gp_free failed to free glob pointer - " 2425 "something is repeatedly re-creating entries" 2426 ); 2427 } 2428 } 2429 2430 /* Possibly incremented by a destructor doing glob assignment */ 2431 if (gp->gp_refcnt > 1) goto borrowed; 2432 Safefree(gp); 2433 GvGP_set(gv, NULL); 2434 } 2435 2436 int 2437 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) 2438 { 2439 AMT * const amtp = (AMT*)mg->mg_ptr; 2440 PERL_UNUSED_ARG(sv); 2441 2442 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD; 2443 2444 if (amtp && AMT_AMAGIC(amtp)) { 2445 int i; 2446 for (i = 1; i < NofAMmeth; i++) { 2447 CV * const cv = amtp->table[i]; 2448 if (cv) { 2449 SvREFCNT_dec_NN(MUTABLE_SV(cv)); 2450 amtp->table[i] = NULL; 2451 } 2452 } 2453 } 2454 return 0; 2455 } 2456 2457 /* Updates and caches the CV's */ 2458 /* Returns: 2459 * 1 on success and there is some overload 2460 * 0 if there is no overload 2461 * -1 if some error occurred and it couldn't croak 2462 */ 2463 2464 int 2465 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) 2466 { 2467 dVAR; 2468 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); 2469 AMT amt; 2470 const struct mro_meta* stash_meta = HvMROMETA(stash); 2471 U32 newgen; 2472 2473 PERL_ARGS_ASSERT_GV_AMUPDATE; 2474 2475 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen; 2476 if (mg) { 2477 const AMT * const amtp = (AMT*)mg->mg_ptr; 2478 if (amtp->was_ok_sub == newgen) { 2479 return AMT_AMAGIC(amtp) ? 1 : 0; 2480 } 2481 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table); 2482 } 2483 2484 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) ); 2485 2486 Zero(&amt,1,AMT); 2487 amt.was_ok_sub = newgen; 2488 amt.fallback = AMGfallNO; 2489 amt.flags = 0; 2490 2491 { 2492 int filled = 0; 2493 int i; 2494 bool deref_seen = 0; 2495 2496 2497 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ 2498 2499 /* Try to find via inheritance. */ 2500 GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0); 2501 SV * const sv = gv ? GvSV(gv) : NULL; 2502 CV* cv; 2503 2504 if (!gv) 2505 { 2506 if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0)) 2507 goto no_table; 2508 } 2509 #ifdef PERL_DONT_CREATE_GVSV 2510 else if (!sv) { 2511 NOOP; /* Equivalent to !SvTRUE and !SvOK */ 2512 } 2513 #endif 2514 else if (SvTRUE(sv)) 2515 /* don't need to set overloading here because fallback => 1 2516 * is the default setting for classes without overloading */ 2517 amt.fallback=AMGfallYES; 2518 else if (SvOK(sv)) { 2519 amt.fallback=AMGfallNEVER; 2520 filled = 1; 2521 } 2522 else { 2523 filled = 1; 2524 } 2525 2526 assert(SvOOK(stash)); 2527 /* initially assume the worst */ 2528 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF; 2529 2530 for (i = 1; i < NofAMmeth; i++) { 2531 const char * const cooky = PL_AMG_names[i]; 2532 /* Human-readable form, for debugging: */ 2533 const char * const cp = AMG_id2name(i); 2534 const STRLEN l = PL_AMG_namelens[i]; 2535 2536 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n", 2537 cp, HvNAME_get(stash)) ); 2538 /* don't fill the cache while looking up! 2539 Creation of inheritance stubs in intermediate packages may 2540 conflict with the logic of runtime method substitution. 2541 Indeed, for inheritance A -> B -> C, if C overloads "+0", 2542 then we could have created stubs for "(+0" in A and C too. 2543 But if B overloads "bool", we may want to use it for 2544 numifying instead of C's "+0". */ 2545 gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0); 2546 cv = 0; 2547 if (gv && (cv = GvCV(gv))) { 2548 if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){ 2549 const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv))); 2550 if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8 2551 && strEQ(hvname, "overload")) { 2552 /* This is a hack to support autoloading..., while 2553 knowing *which* methods were declared as overloaded. */ 2554 /* GvSV contains the name of the method. */ 2555 GV *ngv = NULL; 2556 SV *gvsv = GvSV(gv); 2557 2558 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\ 2559 "\" for overloaded \"%s\" in package \"%.256s\"\n", 2560 (void*)GvSV(gv), cp, HvNAME(stash)) ); 2561 if (!gvsv || !SvPOK(gvsv) 2562 || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0))) 2563 { 2564 /* Can be an import stub (created by "can"). */ 2565 if (destructing) { 2566 return -1; 2567 } 2568 else { 2569 const SV * const name = (gvsv && SvPOK(gvsv)) 2570 ? gvsv 2571 : newSVpvs_flags("???", SVs_TEMP); 2572 /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */ 2573 Perl_croak(aTHX_ "%s method \"%"SVf256 2574 "\" overloading \"%s\" "\ 2575 "in package \"%"HEKf256"\"", 2576 (GvCVGEN(gv) ? "Stub found while resolving" 2577 : "Can't resolve"), 2578 SVfARG(name), cp, 2579 HEKfARG( 2580 HvNAME_HEK(stash) 2581 )); 2582 } 2583 } 2584 cv = GvCV(gv = ngv); 2585 } 2586 } 2587 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n", 2588 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))), 2589 GvNAME(CvGV(cv))) ); 2590 filled = 1; 2591 } else if (gv) { /* Autoloaded... */ 2592 cv = MUTABLE_CV(gv); 2593 filled = 1; 2594 } 2595 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv)); 2596 2597 if (gv) { 2598 switch (i) { 2599 case to_sv_amg: 2600 case to_av_amg: 2601 case to_hv_amg: 2602 case to_gv_amg: 2603 case to_cv_amg: 2604 case nomethod_amg: 2605 deref_seen = 1; 2606 break; 2607 } 2608 } 2609 } 2610 if (!deref_seen) 2611 /* none of @{} etc overloaded; we can do $obj->[N] quicker. 2612 * NB - aux var invalid here, HvARRAY() could have been 2613 * reallocated since it was assigned to */ 2614 HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF; 2615 2616 if (filled) { 2617 AMT_AMAGIC_on(&amt); 2618 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, 2619 (char*)&amt, sizeof(AMT)); 2620 return TRUE; 2621 } 2622 } 2623 /* Here we have no table: */ 2624 no_table: 2625 AMT_AMAGIC_off(&amt); 2626 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, 2627 (char*)&amt, sizeof(AMTS)); 2628 return 0; 2629 } 2630 2631 2632 CV* 2633 Perl_gv_handler(pTHX_ HV *stash, I32 id) 2634 { 2635 dVAR; 2636 MAGIC *mg; 2637 AMT *amtp; 2638 U32 newgen; 2639 struct mro_meta* stash_meta; 2640 2641 if (!stash || !HvNAME_get(stash)) 2642 return NULL; 2643 2644 stash_meta = HvMROMETA(stash); 2645 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen; 2646 2647 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); 2648 if (!mg) { 2649 do_update: 2650 if (Gv_AMupdate(stash, 0) == -1) 2651 return NULL; 2652 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); 2653 } 2654 assert(mg); 2655 amtp = (AMT*)mg->mg_ptr; 2656 if ( amtp->was_ok_sub != newgen ) 2657 goto do_update; 2658 if (AMT_AMAGIC(amtp)) { 2659 CV * const ret = amtp->table[id]; 2660 if (ret && isGV(ret)) { /* Autoloading stab */ 2661 /* Passing it through may have resulted in a warning 2662 "Inherited AUTOLOAD for a non-method deprecated", since 2663 our caller is going through a function call, not a method call. 2664 So return the CV for AUTOLOAD, setting $AUTOLOAD. */ 2665 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]); 2666 2667 if (gv && GvCV(gv)) 2668 return GvCV(gv); 2669 } 2670 return ret; 2671 } 2672 2673 return NULL; 2674 } 2675 2676 2677 /* Implement tryAMAGICun_MG macro. 2678 Do get magic, then see if the stack arg is overloaded and if so call it. 2679 Flags: 2680 AMGf_set return the arg using SETs rather than assigning to 2681 the targ 2682 AMGf_numeric apply sv_2num to the stack arg. 2683 */ 2684 2685 bool 2686 Perl_try_amagic_un(pTHX_ int method, int flags) { 2687 dVAR; 2688 dSP; 2689 SV* tmpsv; 2690 SV* const arg = TOPs; 2691 2692 SvGETMAGIC(arg); 2693 2694 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method, 2695 AMGf_noright | AMGf_unary))) { 2696 if (flags & AMGf_set) { 2697 SETs(tmpsv); 2698 } 2699 else { 2700 dTARGET; 2701 if (SvPADMY(TARG)) { 2702 sv_setsv(TARG, tmpsv); 2703 SETTARG; 2704 } 2705 else 2706 SETs(tmpsv); 2707 } 2708 PUTBACK; 2709 return TRUE; 2710 } 2711 2712 if ((flags & AMGf_numeric) && SvROK(arg)) 2713 *sp = sv_2num(arg); 2714 return FALSE; 2715 } 2716 2717 2718 /* Implement tryAMAGICbin_MG macro. 2719 Do get magic, then see if the two stack args are overloaded and if so 2720 call it. 2721 Flags: 2722 AMGf_set return the arg using SETs rather than assigning to 2723 the targ 2724 AMGf_assign op may be called as mutator (eg +=) 2725 AMGf_numeric apply sv_2num to the stack arg. 2726 */ 2727 2728 bool 2729 Perl_try_amagic_bin(pTHX_ int method, int flags) { 2730 dVAR; 2731 dSP; 2732 SV* const left = TOPm1s; 2733 SV* const right = TOPs; 2734 2735 SvGETMAGIC(left); 2736 if (left != right) 2737 SvGETMAGIC(right); 2738 2739 if (SvAMAGIC(left) || SvAMAGIC(right)) { 2740 SV * const tmpsv = amagic_call(left, right, method, 2741 ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0)); 2742 if (tmpsv) { 2743 if (flags & AMGf_set) { 2744 (void)POPs; 2745 SETs(tmpsv); 2746 } 2747 else { 2748 dATARGET; 2749 (void)POPs; 2750 if (opASSIGN || SvPADMY(TARG)) { 2751 sv_setsv(TARG, tmpsv); 2752 SETTARG; 2753 } 2754 else 2755 SETs(tmpsv); 2756 } 2757 PUTBACK; 2758 return TRUE; 2759 } 2760 } 2761 if(left==right && SvGMAGICAL(left)) { 2762 SV * const left = sv_newmortal(); 2763 *(sp-1) = left; 2764 /* Print the uninitialized warning now, so it includes the vari- 2765 able name. */ 2766 if (!SvOK(right)) { 2767 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right); 2768 sv_setsv_flags(left, &PL_sv_no, 0); 2769 } 2770 else sv_setsv_flags(left, right, 0); 2771 SvGETMAGIC(right); 2772 } 2773 if (flags & AMGf_numeric) { 2774 if (SvROK(TOPm1s)) 2775 *(sp-1) = sv_2num(TOPm1s); 2776 if (SvROK(right)) 2777 *sp = sv_2num(right); 2778 } 2779 return FALSE; 2780 } 2781 2782 SV * 2783 Perl_amagic_deref_call(pTHX_ SV *ref, int method) { 2784 SV *tmpsv = NULL; 2785 HV *stash; 2786 2787 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL; 2788 2789 if (!SvAMAGIC(ref)) 2790 return ref; 2791 /* return quickly if none of the deref ops are overloaded */ 2792 stash = SvSTASH(SvRV(ref)); 2793 assert(SvOOK(stash)); 2794 if (HvAUX(stash)->xhv_aux_flags & HvAUXf_NO_DEREF) 2795 return ref; 2796 2797 while ((tmpsv = amagic_call(ref, &PL_sv_undef, method, 2798 AMGf_noright | AMGf_unary))) { 2799 if (!SvROK(tmpsv)) 2800 Perl_croak(aTHX_ "Overloaded dereference did not return a reference"); 2801 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) { 2802 /* Bail out if it returns us the same reference. */ 2803 return tmpsv; 2804 } 2805 ref = tmpsv; 2806 if (!SvAMAGIC(ref)) 2807 break; 2808 } 2809 return tmpsv ? tmpsv : ref; 2810 } 2811 2812 bool 2813 Perl_amagic_is_enabled(pTHX_ int method) 2814 { 2815 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0); 2816 2817 assert(PL_curcop->cop_hints & HINT_NO_AMAGIC); 2818 2819 if ( !lex_mask || !SvOK(lex_mask) ) 2820 /* overloading lexically disabled */ 2821 return FALSE; 2822 else if ( lex_mask && SvPOK(lex_mask) ) { 2823 /* we have an entry in the hints hash, check if method has been 2824 * masked by overloading.pm */ 2825 STRLEN len; 2826 const int offset = method / 8; 2827 const int bit = method % 8; 2828 char *pv = SvPV(lex_mask, len); 2829 2830 /* Bit set, so this overloading operator is disabled */ 2831 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) ) 2832 return FALSE; 2833 } 2834 return TRUE; 2835 } 2836 2837 SV* 2838 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) 2839 { 2840 dVAR; 2841 MAGIC *mg; 2842 CV *cv=NULL; 2843 CV **cvp=NULL, **ocvp=NULL; 2844 AMT *amtp=NULL, *oamtp=NULL; 2845 int off = 0, off1, lr = 0, notfound = 0; 2846 int postpr = 0, force_cpy = 0; 2847 int assign = AMGf_assign & flags; 2848 const int assignshift = assign ? 1 : 0; 2849 int use_default_op = 0; 2850 int force_scalar = 0; 2851 #ifdef DEBUGGING 2852 int fl=0; 2853 #endif 2854 HV* stash=NULL; 2855 2856 PERL_ARGS_ASSERT_AMAGIC_CALL; 2857 2858 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) { 2859 if (!amagic_is_enabled(method)) return NULL; 2860 } 2861 2862 if (!(AMGf_noleft & flags) && SvAMAGIC(left) 2863 && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash) 2864 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) 2865 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) 2866 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table 2867 : NULL)) 2868 && ((cv = cvp[off=method+assignshift]) 2869 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to 2870 * usual method */ 2871 ( 2872 #ifdef DEBUGGING 2873 fl = 1, 2874 #endif 2875 cv = cvp[off=method])))) { 2876 lr = -1; /* Call method for left argument */ 2877 } else { 2878 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) { 2879 int logic; 2880 2881 /* look for substituted methods */ 2882 /* In all the covered cases we should be called with assign==0. */ 2883 switch (method) { 2884 case inc_amg: 2885 force_cpy = 1; 2886 if ((cv = cvp[off=add_ass_amg]) 2887 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) { 2888 right = &PL_sv_yes; lr = -1; assign = 1; 2889 } 2890 break; 2891 case dec_amg: 2892 force_cpy = 1; 2893 if ((cv = cvp[off = subtr_ass_amg]) 2894 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) { 2895 right = &PL_sv_yes; lr = -1; assign = 1; 2896 } 2897 break; 2898 case bool__amg: 2899 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); 2900 break; 2901 case numer_amg: 2902 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg])); 2903 break; 2904 case string_amg: 2905 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); 2906 break; 2907 case not_amg: 2908 (void)((cv = cvp[off=bool__amg]) 2909 || (cv = cvp[off=numer_amg]) 2910 || (cv = cvp[off=string_amg])); 2911 if (cv) 2912 postpr = 1; 2913 break; 2914 case copy_amg: 2915 { 2916 /* 2917 * SV* ref causes confusion with the interpreter variable of 2918 * the same name 2919 */ 2920 SV* const tmpRef=SvRV(left); 2921 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) { 2922 /* 2923 * Just to be extra cautious. Maybe in some 2924 * additional cases sv_setsv is safe, too. 2925 */ 2926 SV* const newref = newSVsv(tmpRef); 2927 SvOBJECT_on(newref); 2928 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros 2929 delegate to the stash. */ 2930 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef)))); 2931 return newref; 2932 } 2933 } 2934 break; 2935 case abs_amg: 2936 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) 2937 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { 2938 SV* const nullsv=sv_2mortal(newSViv(0)); 2939 if (off1==lt_amg) { 2940 SV* const lessp = amagic_call(left,nullsv, 2941 lt_amg,AMGf_noright); 2942 logic = SvTRUE(lessp); 2943 } else { 2944 SV* const lessp = amagic_call(left,nullsv, 2945 ncmp_amg,AMGf_noright); 2946 logic = (SvNV(lessp) < 0); 2947 } 2948 if (logic) { 2949 if (off==subtr_amg) { 2950 right = left; 2951 left = nullsv; 2952 lr = 1; 2953 } 2954 } else { 2955 return left; 2956 } 2957 } 2958 break; 2959 case neg_amg: 2960 if ((cv = cvp[off=subtr_amg])) { 2961 right = left; 2962 left = sv_2mortal(newSViv(0)); 2963 lr = 1; 2964 } 2965 break; 2966 case int_amg: 2967 case iter_amg: /* XXXX Eventually should do to_gv. */ 2968 case ftest_amg: /* XXXX Eventually should do to_gv. */ 2969 case regexp_amg: 2970 /* FAIL safe */ 2971 return NULL; /* Delegate operation to standard mechanisms. */ 2972 break; 2973 case to_sv_amg: 2974 case to_av_amg: 2975 case to_hv_amg: 2976 case to_gv_amg: 2977 case to_cv_amg: 2978 /* FAIL safe */ 2979 return left; /* Delegate operation to standard mechanisms. */ 2980 break; 2981 default: 2982 goto not_found; 2983 } 2984 if (!cv) goto not_found; 2985 } else if (!(AMGf_noright & flags) && SvAMAGIC(right) 2986 && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash) 2987 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) 2988 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) 2989 ? (amtp = (AMT*)mg->mg_ptr)->table 2990 : NULL)) 2991 && (cv = cvp[off=method])) { /* Method for right 2992 * argument found */ 2993 lr=1; 2994 } else if (((cvp && amtp->fallback > AMGfallNEVER) 2995 || (ocvp && oamtp->fallback > AMGfallNEVER)) 2996 && !(flags & AMGf_unary)) { 2997 /* We look for substitution for 2998 * comparison operations and 2999 * concatenation */ 3000 if (method==concat_amg || method==concat_ass_amg 3001 || method==repeat_amg || method==repeat_ass_amg) { 3002 return NULL; /* Delegate operation to string conversion */ 3003 } 3004 off = -1; 3005 switch (method) { 3006 case lt_amg: 3007 case le_amg: 3008 case gt_amg: 3009 case ge_amg: 3010 case eq_amg: 3011 case ne_amg: 3012 off = ncmp_amg; 3013 break; 3014 case slt_amg: 3015 case sle_amg: 3016 case sgt_amg: 3017 case sge_amg: 3018 case seq_amg: 3019 case sne_amg: 3020 off = scmp_amg; 3021 break; 3022 } 3023 if (off != -1) { 3024 if (ocvp && (oamtp->fallback > AMGfallNEVER)) { 3025 cv = ocvp[off]; 3026 lr = -1; 3027 } 3028 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) { 3029 cv = cvp[off]; 3030 lr = 1; 3031 } 3032 } 3033 if (cv) 3034 postpr = 1; 3035 else 3036 goto not_found; 3037 } else { 3038 not_found: /* No method found, either report or croak */ 3039 switch (method) { 3040 case to_sv_amg: 3041 case to_av_amg: 3042 case to_hv_amg: 3043 case to_gv_amg: 3044 case to_cv_amg: 3045 /* FAIL safe */ 3046 return left; /* Delegate operation to standard mechanisms. */ 3047 break; 3048 } 3049 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */ 3050 notfound = 1; lr = -1; 3051 } else if (cvp && (cv=cvp[nomethod_amg])) { 3052 notfound = 1; lr = 1; 3053 } else if ((use_default_op = 3054 (!ocvp || oamtp->fallback >= AMGfallYES) 3055 && (!cvp || amtp->fallback >= AMGfallYES)) 3056 && !DEBUG_o_TEST) { 3057 /* Skip generating the "no method found" message. */ 3058 return NULL; 3059 } else { 3060 SV *msg; 3061 if (off==-1) off=method; 3062 msg = sv_2mortal(Perl_newSVpvf(aTHX_ 3063 "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf, 3064 AMG_id2name(method + assignshift), 3065 (flags & AMGf_unary ? " " : "\n\tleft "), 3066 SvAMAGIC(left)? 3067 "in overloaded package ": 3068 "has no overloaded magic", 3069 SvAMAGIC(left)? 3070 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))): 3071 SVfARG(&PL_sv_no), 3072 SvAMAGIC(right)? 3073 ",\n\tright argument in overloaded package ": 3074 (flags & AMGf_unary 3075 ? "" 3076 : ",\n\tright argument has no overloaded magic"), 3077 SvAMAGIC(right)? 3078 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))): 3079 SVfARG(&PL_sv_no))); 3080 if (use_default_op) { 3081 DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) ); 3082 } else { 3083 Perl_croak(aTHX_ "%"SVf, SVfARG(msg)); 3084 } 3085 return NULL; 3086 } 3087 force_cpy = force_cpy || assign; 3088 } 3089 } 3090 3091 switch (method) { 3092 /* in these cases, we're calling '+' or '-' as a fallback for a ++ or -- 3093 * operation. we need this to return a value, so that it can be assigned 3094 * later on, in the postpr block (case inc_amg/dec_amg), even if the 3095 * increment or decrement was itself called in void context */ 3096 case inc_amg: 3097 if (off == add_amg) 3098 force_scalar = 1; 3099 break; 3100 case dec_amg: 3101 if (off == subtr_amg) 3102 force_scalar = 1; 3103 break; 3104 /* in these cases, we're calling an assignment variant of an operator 3105 * (+= rather than +, for instance). regardless of whether it's a 3106 * fallback or not, it always has to return a value, which will be 3107 * assigned to the proper variable later */ 3108 case add_amg: 3109 case subtr_amg: 3110 case mult_amg: 3111 case div_amg: 3112 case modulo_amg: 3113 case pow_amg: 3114 case lshift_amg: 3115 case rshift_amg: 3116 case repeat_amg: 3117 case concat_amg: 3118 case band_amg: 3119 case bor_amg: 3120 case bxor_amg: 3121 if (assign) 3122 force_scalar = 1; 3123 break; 3124 /* the copy constructor always needs to return a value */ 3125 case copy_amg: 3126 force_scalar = 1; 3127 break; 3128 /* because of the way these are implemented (they don't perform the 3129 * dereferencing themselves, they return a reference that perl then 3130 * dereferences later), they always have to be in scalar context */ 3131 case to_sv_amg: 3132 case to_av_amg: 3133 case to_hv_amg: 3134 case to_gv_amg: 3135 case to_cv_amg: 3136 force_scalar = 1; 3137 break; 3138 /* these don't have an op of their own; they're triggered by their parent 3139 * op, so the context there isn't meaningful ('$a and foo()' in void 3140 * context still needs to pass scalar context on to $a's bool overload) */ 3141 case bool__amg: 3142 case numer_amg: 3143 case string_amg: 3144 force_scalar = 1; 3145 break; 3146 } 3147 3148 #ifdef DEBUGGING 3149 if (!notfound) { 3150 DEBUG_o(Perl_deb(aTHX_ 3151 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n", 3152 AMG_id2name(off), 3153 method+assignshift==off? "" : 3154 " (initially \"", 3155 method+assignshift==off? "" : 3156 AMG_id2name(method+assignshift), 3157 method+assignshift==off? "" : "\")", 3158 flags & AMGf_unary? "" : 3159 lr==1 ? " for right argument": " for left argument", 3160 flags & AMGf_unary? " for argument" : "", 3161 stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)), 3162 fl? ",\n\tassignment variant used": "") ); 3163 } 3164 #endif 3165 /* Since we use shallow copy during assignment, we need 3166 * to dublicate the contents, probably calling user-supplied 3167 * version of copy operator 3168 */ 3169 /* We need to copy in following cases: 3170 * a) Assignment form was called. 3171 * assignshift==1, assign==T, method + 1 == off 3172 * b) Increment or decrement, called directly. 3173 * assignshift==0, assign==0, method + 0 == off 3174 * c) Increment or decrement, translated to assignment add/subtr. 3175 * assignshift==0, assign==T, 3176 * force_cpy == T 3177 * d) Increment or decrement, translated to nomethod. 3178 * assignshift==0, assign==0, 3179 * force_cpy == T 3180 * e) Assignment form translated to nomethod. 3181 * assignshift==1, assign==T, method + 1 != off 3182 * force_cpy == T 3183 */ 3184 /* off is method, method+assignshift, or a result of opcode substitution. 3185 * In the latter case assignshift==0, so only notfound case is important. 3186 */ 3187 if ( (lr == -1) && ( ( (method + assignshift == off) 3188 && (assign || (method == inc_amg) || (method == dec_amg))) 3189 || force_cpy) ) 3190 { 3191 /* newSVsv does not behave as advertised, so we copy missing 3192 * information by hand */ 3193 SV *tmpRef = SvRV(left); 3194 SV *rv_copy; 3195 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) { 3196 SvRV_set(left, rv_copy); 3197 SvSETMAGIC(left); 3198 SvREFCNT_dec_NN(tmpRef); 3199 } 3200 } 3201 3202 { 3203 dSP; 3204 BINOP myop; 3205 SV* res; 3206 const bool oldcatch = CATCH_GET; 3207 I32 oldmark, nret; 3208 int gimme = force_scalar ? G_SCALAR : GIMME_V; 3209 3210 CATCH_SET(TRUE); 3211 Zero(&myop, 1, BINOP); 3212 myop.op_last = (OP *) &myop; 3213 myop.op_next = NULL; 3214 myop.op_flags = OPf_STACKED; 3215 3216 switch (gimme) { 3217 case G_VOID: 3218 myop.op_flags |= OPf_WANT_VOID; 3219 break; 3220 case G_ARRAY: 3221 if (flags & AMGf_want_list) { 3222 myop.op_flags |= OPf_WANT_LIST; 3223 break; 3224 } 3225 /* FALLTHROUGH */ 3226 default: 3227 myop.op_flags |= OPf_WANT_SCALAR; 3228 break; 3229 } 3230 3231 PUSHSTACKi(PERLSI_OVERLOAD); 3232 ENTER; 3233 SAVEOP(); 3234 PL_op = (OP *) &myop; 3235 if (PERLDB_SUB && PL_curstash != PL_debstash) 3236 PL_op->op_private |= OPpENTERSUB_DB; 3237 Perl_pp_pushmark(aTHX); 3238 3239 EXTEND(SP, notfound + 5); 3240 PUSHs(lr>0? right: left); 3241 PUSHs(lr>0? left: right); 3242 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no )); 3243 if (notfound) { 3244 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift), 3245 AMG_id2namelen(method + assignshift), SVs_TEMP)); 3246 } 3247 PUSHs(MUTABLE_SV(cv)); 3248 PUTBACK; 3249 oldmark = TOPMARK; 3250 3251 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) 3252 CALLRUNOPS(aTHX); 3253 LEAVE; 3254 SPAGAIN; 3255 nret = SP - (PL_stack_base + oldmark); 3256 3257 switch (gimme) { 3258 case G_VOID: 3259 /* returning NULL has another meaning, and we check the context 3260 * at the call site too, so this can be differentiated from the 3261 * scalar case */ 3262 res = &PL_sv_undef; 3263 SP = PL_stack_base + oldmark; 3264 break; 3265 case G_ARRAY: { 3266 if (flags & AMGf_want_list) { 3267 res = sv_2mortal((SV *)newAV()); 3268 av_extend((AV *)res, nret); 3269 while (nret--) 3270 av_store((AV *)res, nret, POPs); 3271 break; 3272 } 3273 /* FALLTHROUGH */ 3274 } 3275 default: 3276 res = POPs; 3277 break; 3278 } 3279 3280 PUTBACK; 3281 POPSTACK; 3282 CATCH_SET(oldcatch); 3283 3284 if (postpr) { 3285 int ans; 3286 switch (method) { 3287 case le_amg: 3288 case sle_amg: 3289 ans=SvIV(res)<=0; break; 3290 case lt_amg: 3291 case slt_amg: 3292 ans=SvIV(res)<0; break; 3293 case ge_amg: 3294 case sge_amg: 3295 ans=SvIV(res)>=0; break; 3296 case gt_amg: 3297 case sgt_amg: 3298 ans=SvIV(res)>0; break; 3299 case eq_amg: 3300 case seq_amg: 3301 ans=SvIV(res)==0; break; 3302 case ne_amg: 3303 case sne_amg: 3304 ans=SvIV(res)!=0; break; 3305 case inc_amg: 3306 case dec_amg: 3307 SvSetSV(left,res); return left; 3308 case not_amg: 3309 ans=!SvTRUE(res); break; 3310 default: 3311 ans=0; break; 3312 } 3313 return boolSV(ans); 3314 } else if (method==copy_amg) { 3315 if (!SvROK(res)) { 3316 Perl_croak(aTHX_ "Copy method did not return a reference"); 3317 } 3318 return SvREFCNT_inc(SvRV(res)); 3319 } else { 3320 return res; 3321 } 3322 } 3323 } 3324 3325 void 3326 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) 3327 { 3328 dVAR; 3329 U32 hash; 3330 3331 PERL_ARGS_ASSERT_GV_NAME_SET; 3332 3333 if (len > I32_MAX) 3334 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len); 3335 3336 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) { 3337 unshare_hek(GvNAME_HEK(gv)); 3338 } 3339 3340 PERL_HASH(hash, name, len); 3341 GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash); 3342 } 3343 3344 /* 3345 =for apidoc gv_try_downgrade 3346 3347 If the typeglob C<gv> can be expressed more succinctly, by having 3348 something other than a real GV in its place in the stash, replace it 3349 with the optimised form. Basic requirements for this are that C<gv> 3350 is a real typeglob, is sufficiently ordinary, and is only referenced 3351 from its package. This function is meant to be used when a GV has been 3352 looked up in part to see what was there, causing upgrading, but based 3353 on what was found it turns out that the real GV isn't required after all. 3354 3355 If C<gv> is a completely empty typeglob, it is deleted from the stash. 3356 3357 If C<gv> is a typeglob containing only a sufficiently-ordinary constant 3358 sub, the typeglob is replaced with a scalar-reference placeholder that 3359 more compactly represents the same thing. 3360 3361 =cut 3362 */ 3363 3364 void 3365 Perl_gv_try_downgrade(pTHX_ GV *gv) 3366 { 3367 HV *stash; 3368 CV *cv; 3369 HEK *namehek; 3370 SV **gvp; 3371 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE; 3372 3373 /* XXX Why and where does this leave dangling pointers during global 3374 destruction? */ 3375 if (PL_phase == PERL_PHASE_DESTRUCT) return; 3376 3377 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) && 3378 !SvOBJECT(gv) && !SvREADONLY(gv) && 3379 isGV_with_GP(gv) && GvGP(gv) && 3380 !GvINTRO(gv) && GvREFCNT(gv) == 1 && 3381 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) && 3382 GvEGVx(gv) == gv && (stash = GvSTASH(gv)))) 3383 return; 3384 if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv) 3385 return; 3386 if (SvMAGICAL(gv)) { 3387 MAGIC *mg; 3388 /* only backref magic is allowed */ 3389 if (SvGMAGICAL(gv) || SvSMAGICAL(gv)) 3390 return; 3391 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) { 3392 if (mg->mg_type != PERL_MAGIC_backref) 3393 return; 3394 } 3395 } 3396 cv = GvCV(gv); 3397 if (!cv) { 3398 HEK *gvnhek = GvNAME_HEK(gv); 3399 (void)hv_deletehek(stash, gvnhek, G_DISCARD); 3400 } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 && 3401 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) && 3402 CvSTASH(cv) == stash && CvGV(cv) == gv && 3403 CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) && 3404 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) && 3405 (namehek = GvNAME_HEK(gv)) && 3406 (gvp = hv_fetchhek(stash, namehek, 0)) && 3407 *gvp == (SV*)gv) { 3408 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr); 3409 const bool imported = !!GvIMPORTED_CV(gv); 3410 SvREFCNT(gv) = 0; 3411 sv_clear((SV*)gv); 3412 SvREFCNT(gv) = 1; 3413 SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported; 3414 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) - 3415 STRUCT_OFFSET(XPVIV, xiv_iv)); 3416 SvRV_set(gv, value); 3417 } 3418 } 3419 3420 GV * 3421 Perl_gv_override(pTHX_ const char * const name, const STRLEN len) 3422 { 3423 GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV); 3424 GV * const *gvp; 3425 PERL_ARGS_ASSERT_GV_OVERRIDE; 3426 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv; 3427 gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE); 3428 gv = gvp ? *gvp : NULL; 3429 if (gv && !isGV(gv)) { 3430 if (!SvPCS_IMPORTED(gv)) return NULL; 3431 gv_init(gv, PL_globalstash, name, len, 0); 3432 return gv; 3433 } 3434 return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL; 3435 } 3436 3437 #include "XSUB.h" 3438 3439 static void 3440 core_xsub(pTHX_ CV* cv) 3441 { 3442 Perl_croak(aTHX_ 3443 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv)) 3444 ); 3445 } 3446 3447 /* 3448 * Local variables: 3449 * c-indentation-style: bsd 3450 * c-basic-offset: 4 3451 * indent-tabs-mode: nil 3452 * End: 3453 * 3454 * ex: set ts=8 sts=4 sw=4 et: 3455 */ 3456