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