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 40 static const char S_autoload[] = "AUTOLOAD"; 41 static const STRLEN S_autolen = sizeof(S_autoload)-1; 42 43 44 #ifdef PERL_DONT_CREATE_GVSV 45 GV * 46 Perl_gv_SVadd(pTHX_ GV *gv) 47 { 48 PERL_ARGS_ASSERT_GV_SVADD; 49 50 if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) 51 Perl_croak(aTHX_ "Bad symbol for scalar"); 52 if (!GvSV(gv)) 53 GvSV(gv) = newSV(0); 54 return gv; 55 } 56 #endif 57 58 GV * 59 Perl_gv_AVadd(pTHX_ register GV *gv) 60 { 61 PERL_ARGS_ASSERT_GV_AVADD; 62 63 if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) 64 Perl_croak(aTHX_ "Bad symbol for array"); 65 if (!GvAV(gv)) 66 GvAV(gv) = newAV(); 67 return gv; 68 } 69 70 GV * 71 Perl_gv_HVadd(pTHX_ register GV *gv) 72 { 73 PERL_ARGS_ASSERT_GV_HVADD; 74 75 if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) 76 Perl_croak(aTHX_ "Bad symbol for hash"); 77 if (!GvHV(gv)) 78 GvHV(gv) = newHV(); 79 return gv; 80 } 81 82 GV * 83 Perl_gv_IOadd(pTHX_ register GV *gv) 84 { 85 dVAR; 86 87 PERL_ARGS_ASSERT_GV_IOADD; 88 89 if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) { 90 91 /* 92 * if it walks like a dirhandle, then let's assume that 93 * this is a dirhandle. 94 */ 95 const char * const fh = 96 PL_op->op_type == OP_READDIR || 97 PL_op->op_type == OP_TELLDIR || 98 PL_op->op_type == OP_SEEKDIR || 99 PL_op->op_type == OP_REWINDDIR || 100 PL_op->op_type == OP_CLOSEDIR ? 101 "dirhandle" : "filehandle"; 102 Perl_croak(aTHX_ "Bad symbol for %s", fh); 103 } 104 105 if (!GvIOp(gv)) { 106 #ifdef GV_UNIQUE_CHECK 107 if (GvUNIQUE(gv)) { 108 Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)"); 109 } 110 #endif 111 GvIOp(gv) = newIO(); 112 } 113 return gv; 114 } 115 116 GV * 117 Perl_gv_fetchfile(pTHX_ const char *name) 118 { 119 PERL_ARGS_ASSERT_GV_FETCHFILE; 120 return gv_fetchfile_flags(name, strlen(name), 0); 121 } 122 123 GV * 124 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, 125 const U32 flags) 126 { 127 dVAR; 128 char smallbuf[128]; 129 char *tmpbuf; 130 const STRLEN tmplen = namelen + 2; 131 GV *gv; 132 133 PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS; 134 PERL_UNUSED_ARG(flags); 135 136 if (!PL_defstash) 137 return NULL; 138 139 if (tmplen <= sizeof smallbuf) 140 tmpbuf = smallbuf; 141 else 142 Newx(tmpbuf, tmplen, char); 143 /* This is where the debugger's %{"::_<$filename"} hash is created */ 144 tmpbuf[0] = '_'; 145 tmpbuf[1] = '<'; 146 memcpy(tmpbuf + 2, name, namelen); 147 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE); 148 if (!isGV(gv)) { 149 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE); 150 #ifdef PERL_DONT_CREATE_GVSV 151 GvSV(gv) = newSVpvn(name, namelen); 152 #else 153 sv_setpvn(GvSV(gv), name, namelen); 154 #endif 155 if (PERLDB_LINE || PERLDB_SAVESRC) 156 hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile); 157 } 158 if (tmpbuf != smallbuf) 159 Safefree(tmpbuf); 160 return gv; 161 } 162 163 /* 164 =for apidoc gv_const_sv 165 166 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for 167 inlining, or C<gv> is a placeholder reference that would be promoted to such 168 a typeglob, then returns the value returned by the sub. Otherwise, returns 169 NULL. 170 171 =cut 172 */ 173 174 SV * 175 Perl_gv_const_sv(pTHX_ GV *gv) 176 { 177 PERL_ARGS_ASSERT_GV_CONST_SV; 178 179 if (SvTYPE(gv) == SVt_PVGV) 180 return cv_const_sv(GvCVu(gv)); 181 return SvROK(gv) ? SvRV(gv) : NULL; 182 } 183 184 GP * 185 Perl_newGP(pTHX_ GV *const gv) 186 { 187 GP *gp; 188 U32 hash; 189 #ifdef USE_ITHREADS 190 const char *const file 191 = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : ""; 192 const STRLEN len = strlen(file); 193 #else 194 SV *const temp_sv = CopFILESV(PL_curcop); 195 const char *file; 196 STRLEN len; 197 198 PERL_ARGS_ASSERT_NEWGP; 199 200 if (temp_sv) { 201 file = SvPVX(temp_sv); 202 len = SvCUR(temp_sv); 203 } else { 204 file = ""; 205 len = 0; 206 } 207 #endif 208 209 PERL_HASH(hash, file, len); 210 211 Newxz(gp, 1, GP); 212 213 #ifndef PERL_DONT_CREATE_GVSV 214 gp->gp_sv = newSV(0); 215 #endif 216 217 gp->gp_line = PL_curcop ? CopLINE(PL_curcop) : 0; 218 /* XXX Ideally this cast would be replaced with a change to const char* 219 in the struct. */ 220 gp->gp_file_hek = share_hek(file, len, hash); 221 gp->gp_egv = gv; 222 gp->gp_refcnt = 1; 223 224 return gp; 225 } 226 227 void 228 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) 229 { 230 dVAR; 231 const U32 old_type = SvTYPE(gv); 232 const bool doproto = old_type > SVt_NULL; 233 char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL; 234 const STRLEN protolen = proto ? SvCUR(gv) : 0; 235 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL; 236 const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0; 237 238 PERL_ARGS_ASSERT_GV_INIT; 239 assert (!(proto && has_constant)); 240 241 if (has_constant) { 242 /* The constant has to be a simple scalar type. */ 243 switch (SvTYPE(has_constant)) { 244 case SVt_PVAV: 245 case SVt_PVHV: 246 case SVt_PVCV: 247 case SVt_PVFM: 248 case SVt_PVIO: 249 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob", 250 sv_reftype(has_constant, 0)); 251 default: NOOP; 252 } 253 SvRV_set(gv, NULL); 254 SvROK_off(gv); 255 } 256 257 258 if (old_type < SVt_PVGV) { 259 if (old_type >= SVt_PV) 260 SvCUR_set(gv, 0); 261 sv_upgrade(MUTABLE_SV(gv), SVt_PVGV); 262 } 263 if (SvLEN(gv)) { 264 if (proto) { 265 SvPV_set(gv, NULL); 266 SvLEN_set(gv, 0); 267 SvPOK_off(gv); 268 } else 269 Safefree(SvPVX_mutable(gv)); 270 } 271 SvIOK_off(gv); 272 isGV_with_GP_on(gv); 273 274 GvGP(gv) = Perl_newGP(aTHX_ gv); 275 GvSTASH(gv) = stash; 276 if (stash) 277 Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv)); 278 gv_name_set(gv, name, len, GV_ADD); 279 if (multi || doproto) /* doproto means it _was_ mentioned */ 280 GvMULTI_on(gv); 281 if (doproto) { /* Replicate part of newSUB here. */ 282 ENTER; 283 if (has_constant) { 284 /* newCONSTSUB takes ownership of the reference from us. */ 285 GvCV(gv) = newCONSTSUB(stash, name, has_constant); 286 /* If this reference was a copy of another, then the subroutine 287 must have been "imported", by a Perl space assignment to a GV 288 from a reference to CV. */ 289 if (exported_constant) 290 GvIMPORTED_CV_on(gv); 291 } else { 292 (void) start_subparse(0,0); /* Create empty CV in compcv. */ 293 GvCV(gv) = PL_compcv; 294 } 295 LEAVE; 296 297 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */ 298 CvGV(GvCV(gv)) = gv; 299 CvFILE_set_from_cop(GvCV(gv), PL_curcop); 300 CvSTASH(GvCV(gv)) = PL_curstash; 301 if (proto) { 302 sv_usepvn_flags(MUTABLE_SV(GvCV(gv)), proto, protolen, 303 SV_HAS_TRAILING_NUL); 304 } 305 } 306 } 307 308 STATIC void 309 S_gv_init_sv(pTHX_ GV *gv, I32 sv_type) 310 { 311 PERL_ARGS_ASSERT_GV_INIT_SV; 312 313 switch (sv_type) { 314 case SVt_PVIO: 315 (void)GvIOn(gv); 316 break; 317 case SVt_PVAV: 318 (void)GvAVn(gv); 319 break; 320 case SVt_PVHV: 321 (void)GvHVn(gv); 322 break; 323 #ifdef PERL_DONT_CREATE_GVSV 324 case SVt_NULL: 325 case SVt_PVCV: 326 case SVt_PVFM: 327 case SVt_PVGV: 328 break; 329 default: 330 if(GvSVn(gv)) { 331 /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13 332 If we just cast GvSVn(gv) to void, it ignores evaluating it for 333 its side effect */ 334 } 335 #endif 336 } 337 } 338 339 /* 340 =for apidoc gv_fetchmeth 341 342 Returns the glob with the given C<name> and a defined subroutine or 343 C<NULL>. The glob lives in the given C<stash>, or in the stashes 344 accessible via @ISA and UNIVERSAL::. 345 346 The argument C<level> should be either 0 or -1. If C<level==0>, as a 347 side-effect creates a glob with the given C<name> in the given C<stash> 348 which in the case of success contains an alias for the subroutine, and sets 349 up caching info for this glob. 350 351 This function grants C<"SUPER"> token as a postfix of the stash name. The 352 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not 353 visible to Perl code. So when calling C<call_sv>, you should not use 354 the GV directly; instead, you should use the method's CV, which can be 355 obtained from the GV with the C<GvCV> macro. 356 357 =cut 358 */ 359 360 /* NOTE: No support for tied ISA */ 361 362 GV * 363 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) 364 { 365 dVAR; 366 GV** gvp; 367 AV* linear_av; 368 SV** linear_svp; 369 SV* linear_sv; 370 HV* cstash; 371 GV* candidate = NULL; 372 CV* cand_cv = NULL; 373 CV* old_cv; 374 GV* topgv = NULL; 375 const char *hvname; 376 I32 create = (level >= 0) ? 1 : 0; 377 I32 items; 378 STRLEN packlen; 379 U32 topgen_cmp; 380 381 PERL_ARGS_ASSERT_GV_FETCHMETH; 382 383 /* UNIVERSAL methods should be callable without a stash */ 384 if (!stash) { 385 create = 0; /* probably appropriate */ 386 if(!(stash = gv_stashpvs("UNIVERSAL", 0))) 387 return 0; 388 } 389 390 assert(stash); 391 392 hvname = HvNAME_get(stash); 393 if (!hvname) 394 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); 395 396 assert(hvname); 397 assert(name); 398 399 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) ); 400 401 topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation; 402 403 /* check locally for a real method or a cache entry */ 404 gvp = (GV**)hv_fetch(stash, name, len, create); 405 if(gvp) { 406 topgv = *gvp; 407 assert(topgv); 408 if (SvTYPE(topgv) != SVt_PVGV) 409 gv_init(topgv, stash, name, len, TRUE); 410 if ((cand_cv = GvCV(topgv))) { 411 /* If genuine method or valid cache entry, use it */ 412 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) { 413 return topgv; 414 } 415 else { 416 /* stale cache entry, junk it and move on */ 417 SvREFCNT_dec(cand_cv); 418 GvCV(topgv) = cand_cv = NULL; 419 GvCVGEN(topgv) = 0; 420 } 421 } 422 else if (GvCVGEN(topgv) == topgen_cmp) { 423 /* cache indicates no such method definitively */ 424 return 0; 425 } 426 } 427 428 packlen = HvNAMELEN_get(stash); 429 if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) { 430 HV* basestash; 431 packlen -= 7; 432 basestash = gv_stashpvn(hvname, packlen, GV_ADD); 433 linear_av = mro_get_linear_isa(basestash); 434 } 435 else { 436 linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */ 437 } 438 439 linear_svp = AvARRAY(linear_av) + 1; /* skip over self */ 440 items = AvFILLp(linear_av); /* no +1, to skip over self */ 441 while (items--) { 442 linear_sv = *linear_svp++; 443 assert(linear_sv); 444 cstash = gv_stashsv(linear_sv, 0); 445 446 if (!cstash) { 447 if (ckWARN(WARN_SYNTAX)) 448 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA", 449 SVfARG(linear_sv), hvname); 450 continue; 451 } 452 453 assert(cstash); 454 455 gvp = (GV**)hv_fetch(cstash, name, len, 0); 456 if (!gvp) continue; 457 candidate = *gvp; 458 assert(candidate); 459 if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, name, len, TRUE); 460 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { 461 /* 462 * Found real method, cache method in topgv if: 463 * 1. topgv has no synonyms (else inheritance crosses wires) 464 * 2. method isn't a stub (else AUTOLOAD fails spectacularly) 465 */ 466 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { 467 if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv); 468 SvREFCNT_inc_simple_void_NN(cand_cv); 469 GvCV(topgv) = cand_cv; 470 GvCVGEN(topgv) = topgen_cmp; 471 } 472 return candidate; 473 } 474 } 475 476 /* Check UNIVERSAL without caching */ 477 if(level == 0 || level == -1) { 478 candidate = gv_fetchmeth(NULL, name, len, 1); 479 if(candidate) { 480 cand_cv = GvCV(candidate); 481 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { 482 if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv); 483 SvREFCNT_inc_simple_void_NN(cand_cv); 484 GvCV(topgv) = cand_cv; 485 GvCVGEN(topgv) = topgen_cmp; 486 } 487 return candidate; 488 } 489 } 490 491 if (topgv && GvREFCNT(topgv) == 1) { 492 /* cache the fact that the method is not defined */ 493 GvCVGEN(topgv) = topgen_cmp; 494 } 495 496 return 0; 497 } 498 499 /* 500 =for apidoc gv_fetchmeth_autoload 501 502 Same as gv_fetchmeth(), but looks for autoloaded subroutines too. 503 Returns a glob for the subroutine. 504 505 For an autoloaded subroutine without a GV, will create a GV even 506 if C<level < 0>. For an autoloaded subroutine without a stub, GvCV() 507 of the result may be zero. 508 509 =cut 510 */ 511 512 GV * 513 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) 514 { 515 GV *gv = gv_fetchmeth(stash, name, len, level); 516 517 PERL_ARGS_ASSERT_GV_FETCHMETH_AUTOLOAD; 518 519 if (!gv) { 520 CV *cv; 521 GV **gvp; 522 523 if (!stash) 524 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */ 525 if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) 526 return NULL; 527 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE))) 528 return NULL; 529 cv = GvCV(gv); 530 if (!(CvROOT(cv) || CvXSUB(cv))) 531 return NULL; 532 /* Have an autoload */ 533 if (level < 0) /* Cannot do without a stub */ 534 gv_fetchmeth(stash, name, len, 0); 535 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); 536 if (!gvp) 537 return NULL; 538 return *gvp; 539 } 540 return gv; 541 } 542 543 /* 544 =for apidoc gv_fetchmethod_autoload 545 546 Returns the glob which contains the subroutine to call to invoke the method 547 on the C<stash>. In fact in the presence of autoloading this may be the 548 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is 549 already setup. 550 551 The third parameter of C<gv_fetchmethod_autoload> determines whether 552 AUTOLOAD lookup is performed if the given method is not present: non-zero 553 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD. 554 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload> 555 with a non-zero C<autoload> parameter. 556 557 These functions grant C<"SUPER"> token as a prefix of the method name. Note 558 that if you want to keep the returned glob for a long time, you need to 559 check for it being "AUTOLOAD", since at the later time the call may load a 560 different subroutine due to $AUTOLOAD changing its value. Use the glob 561 created via a side effect to do this. 562 563 These functions have the same side-effects and as C<gv_fetchmeth> with 564 C<level==0>. C<name> should be writable if contains C<':'> or C<' 565 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to 566 C<call_sv> apply equally to these functions. 567 568 =cut 569 */ 570 571 STATIC HV* 572 S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen) 573 { 574 AV* superisa; 575 GV** gvp; 576 GV* gv; 577 HV* stash; 578 579 PERL_ARGS_ASSERT_GV_GET_SUPER_PKG; 580 581 stash = gv_stashpvn(name, namelen, 0); 582 if(stash) return stash; 583 584 /* If we must create it, give it an @ISA array containing 585 the real package this SUPER is for, so that it's tied 586 into the cache invalidation code correctly */ 587 stash = gv_stashpvn(name, namelen, GV_ADD); 588 gvp = (GV**)hv_fetchs(stash, "ISA", TRUE); 589 gv = *gvp; 590 gv_init(gv, stash, "ISA", 3, TRUE); 591 superisa = GvAVn(gv); 592 GvMULTI_on(gv); 593 sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0); 594 #ifdef USE_ITHREADS 595 av_push(superisa, newSVpv(CopSTASHPV(PL_curcop), 0)); 596 #else 597 av_push(superisa, newSVhek(CopSTASH(PL_curcop) 598 ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL)); 599 #endif 600 601 return stash; 602 } 603 604 /* FIXME. If changing this function note the comment in pp_hot's 605 S_method_common: 606 607 This code tries to figure out just what went wrong with 608 gv_fetchmethod. It therefore needs to duplicate a lot of 609 the internals of that function. ... 610 611 I'd guess that with one more flag bit that could all be moved inside 612 here. 613 */ 614 615 GV * 616 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) 617 { 618 dVAR; 619 register const char *nend; 620 const char *nsplit = NULL; 621 GV* gv; 622 HV* ostash = stash; 623 const char * const origname = name; 624 625 PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD; 626 627 if (stash && SvTYPE(stash) < SVt_PVHV) 628 stash = NULL; 629 630 for (nend = name; *nend; nend++) { 631 if (*nend == '\'') { 632 nsplit = nend; 633 name = nend + 1; 634 } 635 else if (*nend == ':' && *(nend + 1) == ':') { 636 nsplit = nend++; 637 name = nend + 1; 638 } 639 } 640 if (nsplit) { 641 if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) { 642 /* ->SUPER::method should really be looked up in original stash */ 643 SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", 644 CopSTASHPV(PL_curcop))); 645 /* __PACKAGE__::SUPER stash should be autovivified */ 646 stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr)); 647 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", 648 origname, HvNAME_get(stash), name) ); 649 } 650 else { 651 /* don't autovifify if ->NoSuchStash::method */ 652 stash = gv_stashpvn(origname, nsplit - origname, 0); 653 654 /* however, explicit calls to Pkg::SUPER::method may 655 happen, and may require autovivification to work */ 656 if (!stash && (nsplit - origname) >= 7 && 657 strnEQ(nsplit - 7, "::SUPER", 7) && 658 gv_stashpvn(origname, nsplit - origname - 7, 0)) 659 stash = gv_get_super_pkg(origname, nsplit - origname); 660 } 661 ostash = stash; 662 } 663 664 gv = gv_fetchmeth(stash, name, nend - name, 0); 665 if (!gv) { 666 if (strEQ(name,"import") || strEQ(name,"unimport")) 667 gv = MUTABLE_GV(&PL_sv_yes); 668 else if (autoload) 669 gv = gv_autoload4(ostash, name, nend - name, TRUE); 670 } 671 else if (autoload) { 672 CV* const cv = GvCV(gv); 673 if (!CvROOT(cv) && !CvXSUB(cv)) { 674 GV* stubgv; 675 GV* autogv; 676 677 if (CvANON(cv)) 678 stubgv = gv; 679 else { 680 stubgv = CvGV(cv); 681 if (GvCV(stubgv) != cv) /* orphaned import */ 682 stubgv = gv; 683 } 684 autogv = gv_autoload4(GvSTASH(stubgv), 685 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE); 686 if (autogv) 687 gv = autogv; 688 } 689 } 690 691 return gv; 692 } 693 694 GV* 695 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) 696 { 697 dVAR; 698 GV* gv; 699 CV* cv; 700 HV* varstash; 701 GV* vargv; 702 SV* varsv; 703 const char *packname = ""; 704 STRLEN packname_len = 0; 705 706 PERL_ARGS_ASSERT_GV_AUTOLOAD4; 707 708 if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) 709 return NULL; 710 if (stash) { 711 if (SvTYPE(stash) < SVt_PVHV) { 712 packname = SvPV_const(MUTABLE_SV(stash), packname_len); 713 stash = NULL; 714 } 715 else { 716 packname = HvNAME_get(stash); 717 packname_len = HvNAMELEN_get(stash); 718 } 719 } 720 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE))) 721 return NULL; 722 cv = GvCV(gv); 723 724 if (!(CvROOT(cv) || CvXSUB(cv))) 725 return NULL; 726 727 /* 728 * Inheriting AUTOLOAD for non-methods works ... for now. 729 */ 730 if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash) 731 && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) 732 ) 733 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), 734 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", 735 packname, (int)len, name); 736 737 if (CvISXSUB(cv)) { 738 /* rather than lookup/init $AUTOLOAD here 739 * only to have the XSUB do another lookup for $AUTOLOAD 740 * and split that value on the last '::', 741 * pass along the same data via some unused fields in the CV 742 */ 743 CvSTASH(cv) = stash; 744 SvPV_set(cv, (char *)name); /* cast to lose constness warning */ 745 SvCUR_set(cv, len); 746 return gv; 747 } 748 749 /* 750 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name. 751 * The subroutine's original name may not be "AUTOLOAD", so we don't 752 * use that, but for lack of anything better we will use the sub's 753 * original package to look up $AUTOLOAD. 754 */ 755 varstash = GvSTASH(CvGV(cv)); 756 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE); 757 ENTER; 758 759 if (!isGV(vargv)) { 760 gv_init(vargv, varstash, S_autoload, S_autolen, FALSE); 761 #ifdef PERL_DONT_CREATE_GVSV 762 GvSV(vargv) = newSV(0); 763 #endif 764 } 765 LEAVE; 766 varsv = GvSVn(vargv); 767 sv_setpvn(varsv, packname, packname_len); 768 sv_catpvs(varsv, "::"); 769 sv_catpvn(varsv, name, len); 770 return gv; 771 } 772 773 774 /* require_tie_mod() internal routine for requiring a module 775 * that implements the logic of automatical ties like %! and %- 776 * 777 * The "gv" parameter should be the glob. 778 * "varpv" holds the name of the var, used for error messages. 779 * "namesv" holds the module name. Its refcount will be decremented. 780 * "methpv" holds the method name to test for to check that things 781 * are working reasonably close to as expected. 782 * "flags": if flag & 1 then save the scalar before loading. 783 * For the protection of $! to work (it is set by this routine) 784 * the sv slot must already be magicalized. 785 */ 786 STATIC HV* 787 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags) 788 { 789 dVAR; 790 HV* stash = gv_stashsv(namesv, 0); 791 792 PERL_ARGS_ASSERT_REQUIRE_TIE_MOD; 793 794 if (!stash || !(gv_fetchmethod(stash, methpv))) { 795 SV *module = newSVsv(namesv); 796 char varname = *varpv; /* varpv might be clobbered by load_module, 797 so save it. For the moment it's always 798 a single char. */ 799 dSP; 800 ENTER; 801 if ( flags & 1 ) 802 save_scalar(gv); 803 PUSHSTACKi(PERLSI_MAGIC); 804 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL); 805 POPSTACK; 806 LEAVE; 807 SPAGAIN; 808 stash = gv_stashsv(namesv, 0); 809 if (!stash) 810 Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available", 811 varname, SVfARG(namesv)); 812 else if (!gv_fetchmethod(stash, methpv)) 813 Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s", 814 varname, SVfARG(namesv), methpv); 815 } 816 SvREFCNT_dec(namesv); 817 return stash; 818 } 819 820 /* 821 =for apidoc gv_stashpv 822 823 Returns a pointer to the stash for a specified package. Uses C<strlen> to 824 determine the length of C<name>, then calls C<gv_stashpvn()>. 825 826 =cut 827 */ 828 829 HV* 830 Perl_gv_stashpv(pTHX_ const char *name, I32 create) 831 { 832 PERL_ARGS_ASSERT_GV_STASHPV; 833 return gv_stashpvn(name, strlen(name), create); 834 } 835 836 /* 837 =for apidoc gv_stashpvn 838 839 Returns a pointer to the stash for a specified package. The C<namelen> 840 parameter indicates the length of the C<name>, in bytes. C<flags> is passed 841 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be 842 created if it does not already exist. If the package does not exist and 843 C<flags> is 0 (or any other setting that does not create packages) then NULL 844 is returned. 845 846 847 =cut 848 */ 849 850 HV* 851 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) 852 { 853 char smallbuf[128]; 854 char *tmpbuf; 855 HV *stash; 856 GV *tmpgv; 857 858 PERL_ARGS_ASSERT_GV_STASHPVN; 859 860 if (namelen + 2 <= sizeof smallbuf) 861 tmpbuf = smallbuf; 862 else 863 Newx(tmpbuf, namelen + 2, char); 864 Copy(name,tmpbuf,namelen,char); 865 tmpbuf[namelen++] = ':'; 866 tmpbuf[namelen++] = ':'; 867 tmpgv = gv_fetchpvn_flags(tmpbuf, namelen, flags, SVt_PVHV); 868 if (tmpbuf != smallbuf) 869 Safefree(tmpbuf); 870 if (!tmpgv) 871 return NULL; 872 if (!GvHV(tmpgv)) 873 GvHV(tmpgv) = newHV(); 874 stash = GvHV(tmpgv); 875 if (!HvNAME_get(stash)) 876 hv_name_set(stash, name, namelen, 0); 877 return stash; 878 } 879 880 /* 881 =for apidoc gv_stashsv 882 883 Returns a pointer to the stash for a specified package. See C<gv_stashpvn>. 884 885 =cut 886 */ 887 888 HV* 889 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags) 890 { 891 STRLEN len; 892 const char * const ptr = SvPV_const(sv,len); 893 894 PERL_ARGS_ASSERT_GV_STASHSV; 895 896 return gv_stashpvn(ptr, len, flags); 897 } 898 899 900 GV * 901 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) { 902 PERL_ARGS_ASSERT_GV_FETCHPV; 903 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type); 904 } 905 906 GV * 907 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) { 908 STRLEN len; 909 const char * const nambeg = SvPV_const(name, len); 910 PERL_ARGS_ASSERT_GV_FETCHSV; 911 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type); 912 } 913 914 GV * 915 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, 916 I32 sv_type) 917 { 918 dVAR; 919 register const char *name = nambeg; 920 register GV *gv = NULL; 921 GV**gvp; 922 I32 len; 923 register const char *name_cursor; 924 HV *stash = NULL; 925 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT); 926 const I32 no_expand = flags & GV_NOEXPAND; 927 const I32 add = flags & ~GV_NOADD_MASK; 928 const char *const name_end = nambeg + full_len; 929 const char *const name_em1 = name_end - 1; 930 U32 faking_it; 931 932 PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS; 933 934 if (flags & GV_NOTQUAL) { 935 /* Caller promised that there is no stash, so we can skip the check. */ 936 len = full_len; 937 goto no_stash; 938 } 939 940 if (full_len > 2 && *name == '*' && isALPHA(name[1])) { 941 /* accidental stringify on a GV? */ 942 name++; 943 } 944 945 for (name_cursor = name; name_cursor < name_end; name_cursor++) { 946 if ((*name_cursor == ':' && name_cursor < name_em1 947 && name_cursor[1] == ':') 948 || (*name_cursor == '\'' && name_cursor[1])) 949 { 950 if (!stash) 951 stash = PL_defstash; 952 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */ 953 return NULL; 954 955 len = name_cursor - name; 956 if (len > 0) { 957 char smallbuf[128]; 958 char *tmpbuf; 959 960 if (len + 2 <= (I32)sizeof (smallbuf)) 961 tmpbuf = smallbuf; 962 else 963 Newx(tmpbuf, len+2, char); 964 Copy(name, tmpbuf, len, char); 965 tmpbuf[len++] = ':'; 966 tmpbuf[len++] = ':'; 967 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add); 968 gv = gvp ? *gvp : NULL; 969 if (gv && gv != (const GV *)&PL_sv_undef) { 970 if (SvTYPE(gv) != SVt_PVGV) 971 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI)); 972 else 973 GvMULTI_on(gv); 974 } 975 if (tmpbuf != smallbuf) 976 Safefree(tmpbuf); 977 if (!gv || gv == (const GV *)&PL_sv_undef) 978 return NULL; 979 980 if (!(stash = GvHV(gv))) 981 stash = GvHV(gv) = newHV(); 982 983 if (!HvNAME_get(stash)) 984 hv_name_set(stash, nambeg, name_cursor - nambeg, 0); 985 } 986 987 if (*name_cursor == ':') 988 name_cursor++; 989 name_cursor++; 990 name = name_cursor; 991 if (name == name_end) 992 return gv 993 ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE)); 994 } 995 } 996 len = name_cursor - name; 997 998 /* No stash in name, so see how we can default */ 999 1000 if (!stash) { 1001 no_stash: 1002 if (len && isIDFIRST_lazy(name)) { 1003 bool global = FALSE; 1004 1005 switch (len) { 1006 case 1: 1007 if (*name == '_') 1008 global = TRUE; 1009 break; 1010 case 3: 1011 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C') 1012 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V') 1013 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G')) 1014 global = TRUE; 1015 break; 1016 case 4: 1017 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G' 1018 && name[3] == 'V') 1019 global = TRUE; 1020 break; 1021 case 5: 1022 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D' 1023 && name[3] == 'I' && name[4] == 'N') 1024 global = TRUE; 1025 break; 1026 case 6: 1027 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D') 1028 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T') 1029 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R'))) 1030 global = TRUE; 1031 break; 1032 case 7: 1033 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G' 1034 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U' 1035 && name[6] == 'T') 1036 global = TRUE; 1037 break; 1038 } 1039 1040 if (global) 1041 stash = PL_defstash; 1042 else if (IN_PERL_COMPILETIME) { 1043 stash = PL_curstash; 1044 if (add && (PL_hints & HINT_STRICT_VARS) && 1045 sv_type != SVt_PVCV && 1046 sv_type != SVt_PVGV && 1047 sv_type != SVt_PVFM && 1048 sv_type != SVt_PVIO && 1049 !(len == 1 && sv_type == SVt_PV && 1050 (*name == 'a' || *name == 'b')) ) 1051 { 1052 gvp = (GV**)hv_fetch(stash,name,len,0); 1053 if (!gvp || 1054 *gvp == (const GV *)&PL_sv_undef || 1055 SvTYPE(*gvp) != SVt_PVGV) 1056 { 1057 stash = NULL; 1058 } 1059 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) || 1060 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) || 1061 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) ) 1062 { 1063 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported", 1064 sv_type == SVt_PVAV ? '@' : 1065 sv_type == SVt_PVHV ? '%' : '$', 1066 name); 1067 if (GvCVu(*gvp)) 1068 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name); 1069 stash = NULL; 1070 } 1071 } 1072 } 1073 else 1074 stash = CopSTASH(PL_curcop); 1075 } 1076 else 1077 stash = PL_defstash; 1078 } 1079 1080 /* By this point we should have a stash and a name */ 1081 1082 if (!stash) { 1083 if (add) { 1084 SV * const err = Perl_mess(aTHX_ 1085 "Global symbol \"%s%s\" requires explicit package name", 1086 (sv_type == SVt_PV ? "$" 1087 : sv_type == SVt_PVAV ? "@" 1088 : sv_type == SVt_PVHV ? "%" 1089 : ""), name); 1090 GV *gv; 1091 if (USE_UTF8_IN_NAMES) 1092 SvUTF8_on(err); 1093 qerror(err); 1094 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV); 1095 if(!gv) { 1096 /* symbol table under destruction */ 1097 return NULL; 1098 } 1099 stash = GvHV(gv); 1100 } 1101 else 1102 return NULL; 1103 } 1104 1105 if (!SvREFCNT(stash)) /* symbol table under destruction */ 1106 return NULL; 1107 1108 gvp = (GV**)hv_fetch(stash,name,len,add); 1109 if (!gvp || *gvp == (const GV *)&PL_sv_undef) 1110 return NULL; 1111 gv = *gvp; 1112 if (SvTYPE(gv) == SVt_PVGV) { 1113 if (add) { 1114 GvMULTI_on(gv); 1115 gv_init_sv(gv, sv_type); 1116 if (len == 1 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) { 1117 if (*name == '!') 1118 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); 1119 else if (*name == '-' || *name == '+') 1120 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0); 1121 } 1122 } 1123 return gv; 1124 } else if (no_init) { 1125 return gv; 1126 } else if (no_expand && SvROK(gv)) { 1127 return gv; 1128 } 1129 1130 /* Adding a new symbol. 1131 Unless of course there was already something non-GV here, in which case 1132 we want to behave as if there was always a GV here, containing some sort 1133 of subroutine. 1134 Otherwise we run the risk of creating things like GvIO, which can cause 1135 subtle bugs. eg the one that tripped up SQL::Translator */ 1136 1137 faking_it = SvOK(gv); 1138 1139 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL)) 1140 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg); 1141 gv_init(gv, stash, name, len, add & GV_ADDMULTI); 1142 gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type); 1143 1144 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) 1145 : (PL_dowarn & G_WARN_ON ) ) ) 1146 GvMULTI_on(gv) ; 1147 1148 /* set up magic where warranted */ 1149 if (len > 1) { 1150 #ifndef EBCDIC 1151 if (*name > 'V' ) { 1152 NOOP; 1153 /* Nothing else to do. 1154 The compiler will probably turn the switch statement into a 1155 branch table. Make sure we avoid even that small overhead for 1156 the common case of lower case variable names. */ 1157 } else 1158 #endif 1159 { 1160 const char * const name2 = name + 1; 1161 switch (*name) { 1162 case 'A': 1163 if (strEQ(name2, "RGV")) { 1164 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; 1165 } 1166 else if (strEQ(name2, "RGVOUT")) { 1167 GvMULTI_on(gv); 1168 } 1169 break; 1170 case 'E': 1171 if (strnEQ(name2, "XPORT", 5)) 1172 GvMULTI_on(gv); 1173 break; 1174 case 'I': 1175 if (strEQ(name2, "SA")) { 1176 AV* const av = GvAVn(gv); 1177 GvMULTI_on(gv); 1178 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa, 1179 NULL, 0); 1180 /* NOTE: No support for tied ISA */ 1181 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA") 1182 && AvFILLp(av) == -1) 1183 { 1184 av_push(av, newSVpvs("NDBM_File")); 1185 gv_stashpvs("NDBM_File", GV_ADD); 1186 av_push(av, newSVpvs("DB_File")); 1187 gv_stashpvs("DB_File", GV_ADD); 1188 av_push(av, newSVpvs("GDBM_File")); 1189 gv_stashpvs("GDBM_File", GV_ADD); 1190 av_push(av, newSVpvs("SDBM_File")); 1191 gv_stashpvs("SDBM_File", GV_ADD); 1192 av_push(av, newSVpvs("ODBM_File")); 1193 gv_stashpvs("ODBM_File", GV_ADD); 1194 } 1195 } 1196 break; 1197 case 'O': 1198 if (strEQ(name2, "VERLOAD")) { 1199 HV* const hv = GvHVn(gv); 1200 GvMULTI_on(gv); 1201 hv_magic(hv, NULL, PERL_MAGIC_overload); 1202 } 1203 break; 1204 case 'S': 1205 if (strEQ(name2, "IG")) { 1206 HV *hv; 1207 I32 i; 1208 if (!PL_psig_ptr) { 1209 Newxz(PL_psig_ptr, SIG_SIZE, SV*); 1210 Newxz(PL_psig_name, SIG_SIZE, SV*); 1211 Newxz(PL_psig_pend, SIG_SIZE, int); 1212 } 1213 GvMULTI_on(gv); 1214 hv = GvHVn(gv); 1215 hv_magic(hv, NULL, PERL_MAGIC_sig); 1216 for (i = 1; i < SIG_SIZE; i++) { 1217 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1); 1218 if (init) 1219 sv_setsv(*init, &PL_sv_undef); 1220 PL_psig_ptr[i] = 0; 1221 PL_psig_name[i] = 0; 1222 PL_psig_pend[i] = 0; 1223 } 1224 } 1225 break; 1226 case 'V': 1227 if (strEQ(name2, "ERSION")) 1228 GvMULTI_on(gv); 1229 break; 1230 case '\003': /* $^CHILD_ERROR_NATIVE */ 1231 if (strEQ(name2, "HILD_ERROR_NATIVE")) 1232 goto magicalize; 1233 break; 1234 case '\005': /* $^ENCODING */ 1235 if (strEQ(name2, "NCODING")) 1236 goto magicalize; 1237 break; 1238 case '\015': /* $^MATCH */ 1239 if (strEQ(name2, "ATCH")) 1240 goto magicalize; 1241 case '\017': /* $^OPEN */ 1242 if (strEQ(name2, "PEN")) 1243 goto magicalize; 1244 break; 1245 case '\020': /* $^PREMATCH $^POSTMATCH */ 1246 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH")) 1247 goto magicalize; 1248 case '\024': /* ${^TAINT} */ 1249 if (strEQ(name2, "AINT")) 1250 goto ro_magicalize; 1251 break; 1252 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */ 1253 if (strEQ(name2, "NICODE")) 1254 goto ro_magicalize; 1255 if (strEQ(name2, "TF8LOCALE")) 1256 goto ro_magicalize; 1257 if (strEQ(name2, "TF8CACHE")) 1258 goto magicalize; 1259 break; 1260 case '\027': /* $^WARNING_BITS */ 1261 if (strEQ(name2, "ARNING_BITS")) 1262 goto magicalize; 1263 break; 1264 case '1': 1265 case '2': 1266 case '3': 1267 case '4': 1268 case '5': 1269 case '6': 1270 case '7': 1271 case '8': 1272 case '9': 1273 { 1274 /* Ensures that we have an all-digit variable, ${"1foo"} fails 1275 this test */ 1276 /* This snippet is taken from is_gv_magical */ 1277 const char *end = name + len; 1278 while (--end > name) { 1279 if (!isDIGIT(*end)) return gv; 1280 } 1281 goto magicalize; 1282 } 1283 } 1284 } 1285 } else { 1286 /* Names of length 1. (Or 0. But name is NUL terminated, so that will 1287 be case '\0' in this switch statement (ie a default case) */ 1288 switch (*name) { 1289 case '&': 1290 case '`': 1291 case '\'': 1292 if ( 1293 sv_type == SVt_PVAV || 1294 sv_type == SVt_PVHV || 1295 sv_type == SVt_PVCV || 1296 sv_type == SVt_PVFM || 1297 sv_type == SVt_PVIO 1298 ) { break; } 1299 PL_sawampersand = TRUE; 1300 goto magicalize; 1301 1302 case ':': 1303 sv_setpv(GvSVn(gv),PL_chopset); 1304 goto magicalize; 1305 1306 case '?': 1307 #ifdef COMPLEX_STATUS 1308 SvUPGRADE(GvSVn(gv), SVt_PVLV); 1309 #endif 1310 goto magicalize; 1311 1312 case '!': 1313 GvMULTI_on(gv); 1314 /* If %! has been used, automatically load Errno.pm. */ 1315 1316 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); 1317 1318 /* magicalization must be done before require_tie_mod is called */ 1319 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) 1320 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); 1321 1322 break; 1323 case '-': 1324 case '+': 1325 GvMULTI_on(gv); /* no used once warnings here */ 1326 { 1327 AV* const av = GvAVn(gv); 1328 SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL; 1329 1330 sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0); 1331 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); 1332 if (avc) 1333 SvREADONLY_on(GvSVn(gv)); 1334 SvREADONLY_on(av); 1335 1336 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) 1337 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0); 1338 1339 break; 1340 } 1341 case '*': 1342 case '#': 1343 if (sv_type == SVt_PV && ckWARN2_d(WARN_DEPRECATED, WARN_SYNTAX)) 1344 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), 1345 "$%c is no longer supported", *name); 1346 break; 1347 case '|': 1348 sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0); 1349 goto magicalize; 1350 1351 case '\010': /* $^H */ 1352 { 1353 HV *const hv = GvHVn(gv); 1354 hv_magic(hv, NULL, PERL_MAGIC_hints); 1355 } 1356 goto magicalize; 1357 case '\023': /* $^S */ 1358 ro_magicalize: 1359 SvREADONLY_on(GvSVn(gv)); 1360 /* FALL THROUGH */ 1361 case '1': 1362 case '2': 1363 case '3': 1364 case '4': 1365 case '5': 1366 case '6': 1367 case '7': 1368 case '8': 1369 case '9': 1370 case '[': 1371 case '^': 1372 case '~': 1373 case '=': 1374 case '%': 1375 case '.': 1376 case '(': 1377 case ')': 1378 case '<': 1379 case '>': 1380 case ',': 1381 case '\\': 1382 case '/': 1383 case '\001': /* $^A */ 1384 case '\003': /* $^C */ 1385 case '\004': /* $^D */ 1386 case '\005': /* $^E */ 1387 case '\006': /* $^F */ 1388 case '\011': /* $^I, NOT \t in EBCDIC */ 1389 case '\016': /* $^N */ 1390 case '\017': /* $^O */ 1391 case '\020': /* $^P */ 1392 case '\024': /* $^T */ 1393 case '\027': /* $^W */ 1394 magicalize: 1395 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); 1396 break; 1397 1398 case '\014': /* $^L */ 1399 sv_setpvs(GvSVn(gv),"\f"); 1400 PL_formfeed = GvSVn(gv); 1401 break; 1402 case ';': 1403 sv_setpvs(GvSVn(gv),"\034"); 1404 break; 1405 case ']': 1406 { 1407 SV * const sv = GvSVn(gv); 1408 if (!sv_derived_from(PL_patchlevel, "version")) 1409 upg_version(PL_patchlevel, TRUE); 1410 GvSV(gv) = vnumify(PL_patchlevel); 1411 SvREADONLY_on(GvSV(gv)); 1412 SvREFCNT_dec(sv); 1413 } 1414 break; 1415 case '\026': /* $^V */ 1416 { 1417 SV * const sv = GvSVn(gv); 1418 GvSV(gv) = new_version(PL_patchlevel); 1419 SvREADONLY_on(GvSV(gv)); 1420 SvREFCNT_dec(sv); 1421 } 1422 break; 1423 } 1424 } 1425 return gv; 1426 } 1427 1428 void 1429 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) 1430 { 1431 const char *name; 1432 STRLEN namelen; 1433 const HV * const hv = GvSTASH(gv); 1434 1435 PERL_ARGS_ASSERT_GV_FULLNAME4; 1436 1437 if (!hv) { 1438 SvOK_off(sv); 1439 return; 1440 } 1441 sv_setpv(sv, prefix ? prefix : ""); 1442 1443 name = HvNAME_get(hv); 1444 if (name) { 1445 namelen = HvNAMELEN_get(hv); 1446 } else { 1447 name = "__ANON__"; 1448 namelen = 8; 1449 } 1450 1451 if (keepmain || strNE(name, "main")) { 1452 sv_catpvn(sv,name,namelen); 1453 sv_catpvs(sv,"::"); 1454 } 1455 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv)); 1456 } 1457 1458 void 1459 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) 1460 { 1461 const GV * const egv = GvEGV(gv); 1462 1463 PERL_ARGS_ASSERT_GV_EFULLNAME4; 1464 1465 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain); 1466 } 1467 1468 IO * 1469 Perl_newIO(pTHX) 1470 { 1471 dVAR; 1472 GV *iogv; 1473 IO * const io = MUTABLE_IO(newSV_type(SVt_PVIO)); 1474 /* This used to read SvREFCNT(io) = 1; 1475 It's not clear why the reference count needed an explicit reset. NWC 1476 */ 1477 assert (SvREFCNT(io) == 1); 1478 SvOBJECT_on(io); 1479 /* Clear the stashcache because a new IO could overrule a package name */ 1480 hv_clear(PL_stashcache); 1481 iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV); 1482 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */ 1483 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv)))) 1484 iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV); 1485 SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); 1486 return io; 1487 } 1488 1489 void 1490 Perl_gv_check(pTHX_ const HV *stash) 1491 { 1492 dVAR; 1493 register I32 i; 1494 1495 PERL_ARGS_ASSERT_GV_CHECK; 1496 1497 if (!HvARRAY(stash)) 1498 return; 1499 for (i = 0; i <= (I32) HvMAX(stash); i++) { 1500 const HE *entry; 1501 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { 1502 register GV *gv; 1503 HV *hv; 1504 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && 1505 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv))) 1506 { 1507 if (hv != PL_defstash && hv != stash) 1508 gv_check(hv); /* nested package */ 1509 } 1510 else if (isALPHA(*HeKEY(entry))) { 1511 const char *file; 1512 gv = MUTABLE_GV(HeVAL(entry)); 1513 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) 1514 continue; 1515 file = GvFILE(gv); 1516 CopLINE_set(PL_curcop, GvLINE(gv)); 1517 #ifdef USE_ITHREADS 1518 CopFILE(PL_curcop) = (char *)file; /* set for warning */ 1519 #else 1520 CopFILEGV(PL_curcop) 1521 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0); 1522 #endif 1523 Perl_warner(aTHX_ packWARN(WARN_ONCE), 1524 "Name \"%s::%s\" used only once: possible typo", 1525 HvNAME_get(stash), GvNAME(gv)); 1526 } 1527 } 1528 } 1529 } 1530 1531 GV * 1532 Perl_newGVgen(pTHX_ const char *pack) 1533 { 1534 dVAR; 1535 1536 PERL_ARGS_ASSERT_NEWGVGEN; 1537 1538 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++), 1539 GV_ADD, SVt_PVGV); 1540 } 1541 1542 /* hopefully this is only called on local symbol table entries */ 1543 1544 GP* 1545 Perl_gp_ref(pTHX_ GP *gp) 1546 { 1547 dVAR; 1548 if (!gp) 1549 return NULL; 1550 gp->gp_refcnt++; 1551 if (gp->gp_cv) { 1552 if (gp->gp_cvgen) { 1553 /* If the GP they asked for a reference to contains 1554 a method cache entry, clear it first, so that we 1555 don't infect them with our cached entry */ 1556 SvREFCNT_dec(gp->gp_cv); 1557 gp->gp_cv = NULL; 1558 gp->gp_cvgen = 0; 1559 } 1560 } 1561 return gp; 1562 } 1563 1564 void 1565 Perl_gp_free(pTHX_ GV *gv) 1566 { 1567 dVAR; 1568 GP* gp; 1569 1570 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv))) 1571 return; 1572 if (gp->gp_refcnt == 0) { 1573 if (ckWARN_d(WARN_INTERNAL)) 1574 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), 1575 "Attempt to free unreferenced glob pointers" 1576 pTHX__FORMAT pTHX__VALUE); 1577 return; 1578 } 1579 if (--gp->gp_refcnt > 0) { 1580 if (gp->gp_egv == gv) 1581 gp->gp_egv = 0; 1582 GvGP(gv) = 0; 1583 return; 1584 } 1585 1586 if (gp->gp_file_hek) 1587 unshare_hek(gp->gp_file_hek); 1588 SvREFCNT_dec(gp->gp_sv); 1589 SvREFCNT_dec(gp->gp_av); 1590 /* FIXME - another reference loop GV -> symtab -> GV ? 1591 Somehow gp->gp_hv can end up pointing at freed garbage. */ 1592 if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) { 1593 const char *hvname = HvNAME_get(gp->gp_hv); 1594 if (PL_stashcache && hvname) 1595 (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv), 1596 G_DISCARD); 1597 SvREFCNT_dec(gp->gp_hv); 1598 } 1599 SvREFCNT_dec(gp->gp_io); 1600 SvREFCNT_dec(gp->gp_cv); 1601 SvREFCNT_dec(gp->gp_form); 1602 1603 Safefree(gp); 1604 GvGP(gv) = 0; 1605 } 1606 1607 int 1608 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) 1609 { 1610 AMT * const amtp = (AMT*)mg->mg_ptr; 1611 PERL_UNUSED_ARG(sv); 1612 1613 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD; 1614 1615 if (amtp && AMT_AMAGIC(amtp)) { 1616 int i; 1617 for (i = 1; i < NofAMmeth; i++) { 1618 CV * const cv = amtp->table[i]; 1619 if (cv) { 1620 SvREFCNT_dec(MUTABLE_SV(cv)); 1621 amtp->table[i] = NULL; 1622 } 1623 } 1624 } 1625 return 0; 1626 } 1627 1628 /* Updates and caches the CV's */ 1629 1630 bool 1631 Perl_Gv_AMupdate(pTHX_ HV *stash) 1632 { 1633 dVAR; 1634 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); 1635 AMT amt; 1636 const struct mro_meta* stash_meta = HvMROMETA(stash); 1637 U32 newgen; 1638 1639 PERL_ARGS_ASSERT_GV_AMUPDATE; 1640 1641 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen; 1642 if (mg) { 1643 const AMT * const amtp = (AMT*)mg->mg_ptr; 1644 if (amtp->was_ok_am == PL_amagic_generation 1645 && amtp->was_ok_sub == newgen) { 1646 return (bool)AMT_OVERLOADED(amtp); 1647 } 1648 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table); 1649 } 1650 1651 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) ); 1652 1653 Zero(&amt,1,AMT); 1654 amt.was_ok_am = PL_amagic_generation; 1655 amt.was_ok_sub = newgen; 1656 amt.fallback = AMGfallNO; 1657 amt.flags = 0; 1658 1659 { 1660 int filled = 0, have_ovl = 0; 1661 int i, lim = 1; 1662 1663 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ 1664 1665 /* Try to find via inheritance. */ 1666 GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1); 1667 SV * const sv = gv ? GvSV(gv) : NULL; 1668 CV* cv; 1669 1670 if (!gv) 1671 lim = DESTROY_amg; /* Skip overloading entries. */ 1672 #ifdef PERL_DONT_CREATE_GVSV 1673 else if (!sv) { 1674 NOOP; /* Equivalent to !SvTRUE and !SvOK */ 1675 } 1676 #endif 1677 else if (SvTRUE(sv)) 1678 amt.fallback=AMGfallYES; 1679 else if (SvOK(sv)) 1680 amt.fallback=AMGfallNEVER; 1681 1682 for (i = 1; i < lim; i++) 1683 amt.table[i] = NULL; 1684 for (; i < NofAMmeth; i++) { 1685 const char * const cooky = PL_AMG_names[i]; 1686 /* Human-readable form, for debugging: */ 1687 const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i)); 1688 const STRLEN l = PL_AMG_namelens[i]; 1689 1690 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n", 1691 cp, HvNAME_get(stash)) ); 1692 /* don't fill the cache while looking up! 1693 Creation of inheritance stubs in intermediate packages may 1694 conflict with the logic of runtime method substitution. 1695 Indeed, for inheritance A -> B -> C, if C overloads "+0", 1696 then we could have created stubs for "(+0" in A and C too. 1697 But if B overloads "bool", we may want to use it for 1698 numifying instead of C's "+0". */ 1699 if (i >= DESTROY_amg) 1700 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0); 1701 else /* Autoload taken care of below */ 1702 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1); 1703 cv = 0; 1704 if (gv && (cv = GvCV(gv))) { 1705 const char *hvname; 1706 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil") 1707 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) { 1708 /* This is a hack to support autoloading..., while 1709 knowing *which* methods were declared as overloaded. */ 1710 /* GvSV contains the name of the method. */ 1711 GV *ngv = NULL; 1712 SV *gvsv = GvSV(gv); 1713 1714 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\ 1715 "\" for overloaded \"%s\" in package \"%.256s\"\n", 1716 (void*)GvSV(gv), cp, hvname) ); 1717 if (!gvsv || !SvPOK(gvsv) 1718 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv), 1719 FALSE))) 1720 { 1721 /* Can be an import stub (created by "can"). */ 1722 const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???"; 1723 Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\ 1724 "in package \"%.256s\"", 1725 (GvCVGEN(gv) ? "Stub found while resolving" 1726 : "Can't resolve"), 1727 name, cp, hvname); 1728 } 1729 cv = GvCV(gv = ngv); 1730 } 1731 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n", 1732 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))), 1733 GvNAME(CvGV(cv))) ); 1734 filled = 1; 1735 if (i < DESTROY_amg) 1736 have_ovl = 1; 1737 } else if (gv) { /* Autoloaded... */ 1738 cv = MUTABLE_CV(gv); 1739 filled = 1; 1740 } 1741 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv)); 1742 } 1743 if (filled) { 1744 AMT_AMAGIC_on(&amt); 1745 if (have_ovl) 1746 AMT_OVERLOADED_on(&amt); 1747 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, 1748 (char*)&amt, sizeof(AMT)); 1749 return have_ovl; 1750 } 1751 } 1752 /* Here we have no table: */ 1753 /* no_table: */ 1754 AMT_AMAGIC_off(&amt); 1755 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, 1756 (char*)&amt, sizeof(AMTS)); 1757 return FALSE; 1758 } 1759 1760 1761 CV* 1762 Perl_gv_handler(pTHX_ HV *stash, I32 id) 1763 { 1764 dVAR; 1765 MAGIC *mg; 1766 AMT *amtp; 1767 U32 newgen; 1768 struct mro_meta* stash_meta; 1769 1770 if (!stash || !HvNAME_get(stash)) 1771 return NULL; 1772 1773 stash_meta = HvMROMETA(stash); 1774 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen; 1775 1776 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); 1777 if (!mg) { 1778 do_update: 1779 Gv_AMupdate(stash); 1780 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); 1781 } 1782 assert(mg); 1783 amtp = (AMT*)mg->mg_ptr; 1784 if ( amtp->was_ok_am != PL_amagic_generation 1785 || amtp->was_ok_sub != newgen ) 1786 goto do_update; 1787 if (AMT_AMAGIC(amtp)) { 1788 CV * const ret = amtp->table[id]; 1789 if (ret && isGV(ret)) { /* Autoloading stab */ 1790 /* Passing it through may have resulted in a warning 1791 "Inherited AUTOLOAD for a non-method deprecated", since 1792 our caller is going through a function call, not a method call. 1793 So return the CV for AUTOLOAD, setting $AUTOLOAD. */ 1794 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]); 1795 1796 if (gv && GvCV(gv)) 1797 return GvCV(gv); 1798 } 1799 return ret; 1800 } 1801 1802 return NULL; 1803 } 1804 1805 1806 SV* 1807 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) 1808 { 1809 dVAR; 1810 MAGIC *mg; 1811 CV *cv=NULL; 1812 CV **cvp=NULL, **ocvp=NULL; 1813 AMT *amtp=NULL, *oamtp=NULL; 1814 int off = 0, off1, lr = 0, notfound = 0; 1815 int postpr = 0, force_cpy = 0; 1816 int assign = AMGf_assign & flags; 1817 const int assignshift = assign ? 1 : 0; 1818 #ifdef DEBUGGING 1819 int fl=0; 1820 #endif 1821 HV* stash=NULL; 1822 1823 PERL_ARGS_ASSERT_AMAGIC_CALL; 1824 1825 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) { 1826 SV *lex_mask = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 1827 0, "overloading", 11, 0, 0); 1828 1829 if ( !lex_mask || !SvOK(lex_mask) ) 1830 /* overloading lexically disabled */ 1831 return NULL; 1832 else if ( lex_mask && SvPOK(lex_mask) ) { 1833 /* we have an entry in the hints hash, check if method has been 1834 * masked by overloading.pm */ 1835 STRLEN len; 1836 const int offset = method / 8; 1837 const int bit = method % 8; 1838 char *pv = SvPV(lex_mask, len); 1839 1840 /* Bit set, so this overloading operator is disabled */ 1841 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) ) 1842 return NULL; 1843 } 1844 } 1845 1846 if (!(AMGf_noleft & flags) && SvAMAGIC(left) 1847 && (stash = SvSTASH(SvRV(left))) 1848 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) 1849 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) 1850 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table 1851 : NULL)) 1852 && ((cv = cvp[off=method+assignshift]) 1853 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to 1854 * usual method */ 1855 ( 1856 #ifdef DEBUGGING 1857 fl = 1, 1858 #endif 1859 cv = cvp[off=method])))) { 1860 lr = -1; /* Call method for left argument */ 1861 } else { 1862 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) { 1863 int logic; 1864 1865 /* look for substituted methods */ 1866 /* In all the covered cases we should be called with assign==0. */ 1867 switch (method) { 1868 case inc_amg: 1869 force_cpy = 1; 1870 if ((cv = cvp[off=add_ass_amg]) 1871 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) { 1872 right = &PL_sv_yes; lr = -1; assign = 1; 1873 } 1874 break; 1875 case dec_amg: 1876 force_cpy = 1; 1877 if ((cv = cvp[off = subtr_ass_amg]) 1878 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) { 1879 right = &PL_sv_yes; lr = -1; assign = 1; 1880 } 1881 break; 1882 case bool__amg: 1883 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); 1884 break; 1885 case numer_amg: 1886 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg])); 1887 break; 1888 case string_amg: 1889 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); 1890 break; 1891 case not_amg: 1892 (void)((cv = cvp[off=bool__amg]) 1893 || (cv = cvp[off=numer_amg]) 1894 || (cv = cvp[off=string_amg])); 1895 postpr = 1; 1896 break; 1897 case copy_amg: 1898 { 1899 /* 1900 * SV* ref causes confusion with the interpreter variable of 1901 * the same name 1902 */ 1903 SV* const tmpRef=SvRV(left); 1904 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) { 1905 /* 1906 * Just to be extra cautious. Maybe in some 1907 * additional cases sv_setsv is safe, too. 1908 */ 1909 SV* const newref = newSVsv(tmpRef); 1910 SvOBJECT_on(newref); 1911 /* As a bit of a source compatibility hack, SvAMAGIC() and 1912 friends dereference an RV, to behave the same was as when 1913 overloading was stored on the reference, not the referant. 1914 Hence we can't use SvAMAGIC_on() 1915 */ 1916 SvFLAGS(newref) |= SVf_AMAGIC; 1917 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef)))); 1918 return newref; 1919 } 1920 } 1921 break; 1922 case abs_amg: 1923 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) 1924 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { 1925 SV* const nullsv=sv_2mortal(newSViv(0)); 1926 if (off1==lt_amg) { 1927 SV* const lessp = amagic_call(left,nullsv, 1928 lt_amg,AMGf_noright); 1929 logic = SvTRUE(lessp); 1930 } else { 1931 SV* const lessp = amagic_call(left,nullsv, 1932 ncmp_amg,AMGf_noright); 1933 logic = (SvNV(lessp) < 0); 1934 } 1935 if (logic) { 1936 if (off==subtr_amg) { 1937 right = left; 1938 left = nullsv; 1939 lr = 1; 1940 } 1941 } else { 1942 return left; 1943 } 1944 } 1945 break; 1946 case neg_amg: 1947 if ((cv = cvp[off=subtr_amg])) { 1948 right = left; 1949 left = sv_2mortal(newSViv(0)); 1950 lr = 1; 1951 } 1952 break; 1953 case int_amg: 1954 case iter_amg: /* XXXX Eventually should do to_gv. */ 1955 /* FAIL safe */ 1956 return NULL; /* Delegate operation to standard mechanisms. */ 1957 break; 1958 case to_sv_amg: 1959 case to_av_amg: 1960 case to_hv_amg: 1961 case to_gv_amg: 1962 case to_cv_amg: 1963 /* FAIL safe */ 1964 return left; /* Delegate operation to standard mechanisms. */ 1965 break; 1966 default: 1967 goto not_found; 1968 } 1969 if (!cv) goto not_found; 1970 } else if (!(AMGf_noright & flags) && SvAMAGIC(right) 1971 && (stash = SvSTASH(SvRV(right))) 1972 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) 1973 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) 1974 ? (amtp = (AMT*)mg->mg_ptr)->table 1975 : NULL)) 1976 && (cv = cvp[off=method])) { /* Method for right 1977 * argument found */ 1978 lr=1; 1979 } else if (((ocvp && oamtp->fallback > AMGfallNEVER 1980 && (cvp=ocvp) && (lr = -1)) 1981 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1))) 1982 && !(flags & AMGf_unary)) { 1983 /* We look for substitution for 1984 * comparison operations and 1985 * concatenation */ 1986 if (method==concat_amg || method==concat_ass_amg 1987 || method==repeat_amg || method==repeat_ass_amg) { 1988 return NULL; /* Delegate operation to string conversion */ 1989 } 1990 off = -1; 1991 switch (method) { 1992 case lt_amg: 1993 case le_amg: 1994 case gt_amg: 1995 case ge_amg: 1996 case eq_amg: 1997 case ne_amg: 1998 postpr = 1; off=ncmp_amg; break; 1999 case slt_amg: 2000 case sle_amg: 2001 case sgt_amg: 2002 case sge_amg: 2003 case seq_amg: 2004 case sne_amg: 2005 postpr = 1; off=scmp_amg; break; 2006 } 2007 if (off != -1) cv = cvp[off]; 2008 if (!cv) { 2009 goto not_found; 2010 } 2011 } else { 2012 not_found: /* No method found, either report or croak */ 2013 switch (method) { 2014 case lt_amg: 2015 case le_amg: 2016 case gt_amg: 2017 case ge_amg: 2018 case eq_amg: 2019 case ne_amg: 2020 case slt_amg: 2021 case sle_amg: 2022 case sgt_amg: 2023 case sge_amg: 2024 case seq_amg: 2025 case sne_amg: 2026 postpr = 0; break; 2027 case to_sv_amg: 2028 case to_av_amg: 2029 case to_hv_amg: 2030 case to_gv_amg: 2031 case to_cv_amg: 2032 /* FAIL safe */ 2033 return left; /* Delegate operation to standard mechanisms. */ 2034 break; 2035 } 2036 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */ 2037 notfound = 1; lr = -1; 2038 } else if (cvp && (cv=cvp[nomethod_amg])) { 2039 notfound = 1; lr = 1; 2040 } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) { 2041 /* Skip generating the "no method found" message. */ 2042 return NULL; 2043 } else { 2044 SV *msg; 2045 if (off==-1) off=method; 2046 msg = sv_2mortal(Perl_newSVpvf(aTHX_ 2047 "Operation \"%s\": no method found,%sargument %s%s%s%s", 2048 AMG_id2name(method + assignshift), 2049 (flags & AMGf_unary ? " " : "\n\tleft "), 2050 SvAMAGIC(left)? 2051 "in overloaded package ": 2052 "has no overloaded magic", 2053 SvAMAGIC(left)? 2054 HvNAME_get(SvSTASH(SvRV(left))): 2055 "", 2056 SvAMAGIC(right)? 2057 ",\n\tright argument in overloaded package ": 2058 (flags & AMGf_unary 2059 ? "" 2060 : ",\n\tright argument has no overloaded magic"), 2061 SvAMAGIC(right)? 2062 HvNAME_get(SvSTASH(SvRV(right))): 2063 "")); 2064 if (amtp && amtp->fallback >= AMGfallYES) { 2065 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) ); 2066 } else { 2067 Perl_croak(aTHX_ "%"SVf, SVfARG(msg)); 2068 } 2069 return NULL; 2070 } 2071 force_cpy = force_cpy || assign; 2072 } 2073 } 2074 #ifdef DEBUGGING 2075 if (!notfound) { 2076 DEBUG_o(Perl_deb(aTHX_ 2077 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n", 2078 AMG_id2name(off), 2079 method+assignshift==off? "" : 2080 " (initially \"", 2081 method+assignshift==off? "" : 2082 AMG_id2name(method+assignshift), 2083 method+assignshift==off? "" : "\")", 2084 flags & AMGf_unary? "" : 2085 lr==1 ? " for right argument": " for left argument", 2086 flags & AMGf_unary? " for argument" : "", 2087 stash ? HvNAME_get(stash) : "null", 2088 fl? ",\n\tassignment variant used": "") ); 2089 } 2090 #endif 2091 /* Since we use shallow copy during assignment, we need 2092 * to dublicate the contents, probably calling user-supplied 2093 * version of copy operator 2094 */ 2095 /* We need to copy in following cases: 2096 * a) Assignment form was called. 2097 * assignshift==1, assign==T, method + 1 == off 2098 * b) Increment or decrement, called directly. 2099 * assignshift==0, assign==0, method + 0 == off 2100 * c) Increment or decrement, translated to assignment add/subtr. 2101 * assignshift==0, assign==T, 2102 * force_cpy == T 2103 * d) Increment or decrement, translated to nomethod. 2104 * assignshift==0, assign==0, 2105 * force_cpy == T 2106 * e) Assignment form translated to nomethod. 2107 * assignshift==1, assign==T, method + 1 != off 2108 * force_cpy == T 2109 */ 2110 /* off is method, method+assignshift, or a result of opcode substitution. 2111 * In the latter case assignshift==0, so only notfound case is important. 2112 */ 2113 if (( (method + assignshift == off) 2114 && (assign || (method == inc_amg) || (method == dec_amg))) 2115 || force_cpy) 2116 RvDEEPCP(left); 2117 { 2118 dSP; 2119 BINOP myop; 2120 SV* res; 2121 const bool oldcatch = CATCH_GET; 2122 2123 CATCH_SET(TRUE); 2124 Zero(&myop, 1, BINOP); 2125 myop.op_last = (OP *) &myop; 2126 myop.op_next = NULL; 2127 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED; 2128 2129 PUSHSTACKi(PERLSI_OVERLOAD); 2130 ENTER; 2131 SAVEOP(); 2132 PL_op = (OP *) &myop; 2133 if (PERLDB_SUB && PL_curstash != PL_debstash) 2134 PL_op->op_private |= OPpENTERSUB_DB; 2135 PUTBACK; 2136 pp_pushmark(); 2137 2138 EXTEND(SP, notfound + 5); 2139 PUSHs(lr>0? right: left); 2140 PUSHs(lr>0? left: right); 2141 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no )); 2142 if (notfound) { 2143 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift), 2144 AMG_id2namelen(method + assignshift), SVs_TEMP)); 2145 } 2146 PUSHs(MUTABLE_SV(cv)); 2147 PUTBACK; 2148 2149 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) 2150 CALLRUNOPS(aTHX); 2151 LEAVE; 2152 SPAGAIN; 2153 2154 res=POPs; 2155 PUTBACK; 2156 POPSTACK; 2157 CATCH_SET(oldcatch); 2158 2159 if (postpr) { 2160 int ans; 2161 switch (method) { 2162 case le_amg: 2163 case sle_amg: 2164 ans=SvIV(res)<=0; break; 2165 case lt_amg: 2166 case slt_amg: 2167 ans=SvIV(res)<0; break; 2168 case ge_amg: 2169 case sge_amg: 2170 ans=SvIV(res)>=0; break; 2171 case gt_amg: 2172 case sgt_amg: 2173 ans=SvIV(res)>0; break; 2174 case eq_amg: 2175 case seq_amg: 2176 ans=SvIV(res)==0; break; 2177 case ne_amg: 2178 case sne_amg: 2179 ans=SvIV(res)!=0; break; 2180 case inc_amg: 2181 case dec_amg: 2182 SvSetSV(left,res); return left; 2183 case not_amg: 2184 ans=!SvTRUE(res); break; 2185 default: 2186 ans=0; break; 2187 } 2188 return boolSV(ans); 2189 } else if (method==copy_amg) { 2190 if (!SvROK(res)) { 2191 Perl_croak(aTHX_ "Copy method did not return a reference"); 2192 } 2193 return SvREFCNT_inc(SvRV(res)); 2194 } else { 2195 return res; 2196 } 2197 } 2198 } 2199 2200 /* 2201 =for apidoc is_gv_magical_sv 2202 2203 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical. 2204 2205 =cut 2206 */ 2207 2208 bool 2209 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags) 2210 { 2211 STRLEN len; 2212 const char * const temp = SvPV_const(name, len); 2213 2214 PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV; 2215 2216 return is_gv_magical(temp, len, flags); 2217 } 2218 2219 /* 2220 =for apidoc is_gv_magical 2221 2222 Returns C<TRUE> if given the name of a magical GV. 2223 2224 Currently only useful internally when determining if a GV should be 2225 created even in rvalue contexts. 2226 2227 C<flags> is not used at present but available for future extension to 2228 allow selecting particular classes of magical variable. 2229 2230 Currently assumes that C<name> is NUL terminated (as well as len being valid). 2231 This assumption is met by all callers within the perl core, which all pass 2232 pointers returned by SvPV. 2233 2234 =cut 2235 */ 2236 bool 2237 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags) 2238 { 2239 PERL_UNUSED_CONTEXT; 2240 PERL_UNUSED_ARG(flags); 2241 2242 PERL_ARGS_ASSERT_IS_GV_MAGICAL; 2243 2244 if (len > 1) { 2245 const char * const name1 = name + 1; 2246 switch (*name) { 2247 case 'I': 2248 if (len == 3 && name[1] == 'S' && name[2] == 'A') 2249 goto yes; 2250 break; 2251 case 'O': 2252 if (len == 8 && strEQ(name1, "VERLOAD")) 2253 goto yes; 2254 break; 2255 case 'S': 2256 if (len == 3 && name[1] == 'I' && name[2] == 'G') 2257 goto yes; 2258 break; 2259 /* Using ${^...} variables is likely to be sufficiently rare that 2260 it seems sensible to avoid the space hit of also checking the 2261 length. */ 2262 case '\017': /* ${^OPEN} */ 2263 if (strEQ(name1, "PEN")) 2264 goto yes; 2265 break; 2266 case '\024': /* ${^TAINT} */ 2267 if (strEQ(name1, "AINT")) 2268 goto yes; 2269 break; 2270 case '\025': /* ${^UNICODE} */ 2271 if (strEQ(name1, "NICODE")) 2272 goto yes; 2273 if (strEQ(name1, "TF8LOCALE")) 2274 goto yes; 2275 break; 2276 case '\027': /* ${^WARNING_BITS} */ 2277 if (strEQ(name1, "ARNING_BITS")) 2278 goto yes; 2279 break; 2280 case '1': 2281 case '2': 2282 case '3': 2283 case '4': 2284 case '5': 2285 case '6': 2286 case '7': 2287 case '8': 2288 case '9': 2289 { 2290 const char *end = name + len; 2291 while (--end > name) { 2292 if (!isDIGIT(*end)) 2293 return FALSE; 2294 } 2295 goto yes; 2296 } 2297 } 2298 } else { 2299 /* Because we're already assuming that name is NUL terminated 2300 below, we can treat an empty name as "\0" */ 2301 switch (*name) { 2302 case '&': 2303 case '`': 2304 case '\'': 2305 case ':': 2306 case '?': 2307 case '!': 2308 case '-': 2309 case '#': 2310 case '[': 2311 case '^': 2312 case '~': 2313 case '=': 2314 case '%': 2315 case '.': 2316 case '(': 2317 case ')': 2318 case '<': 2319 case '>': 2320 case ',': 2321 case '\\': 2322 case '/': 2323 case '|': 2324 case '+': 2325 case ';': 2326 case ']': 2327 case '\001': /* $^A */ 2328 case '\003': /* $^C */ 2329 case '\004': /* $^D */ 2330 case '\005': /* $^E */ 2331 case '\006': /* $^F */ 2332 case '\010': /* $^H */ 2333 case '\011': /* $^I, NOT \t in EBCDIC */ 2334 case '\014': /* $^L */ 2335 case '\016': /* $^N */ 2336 case '\017': /* $^O */ 2337 case '\020': /* $^P */ 2338 case '\023': /* $^S */ 2339 case '\024': /* $^T */ 2340 case '\026': /* $^V */ 2341 case '\027': /* $^W */ 2342 case '1': 2343 case '2': 2344 case '3': 2345 case '4': 2346 case '5': 2347 case '6': 2348 case '7': 2349 case '8': 2350 case '9': 2351 yes: 2352 return TRUE; 2353 default: 2354 break; 2355 } 2356 } 2357 return FALSE; 2358 } 2359 2360 void 2361 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) 2362 { 2363 dVAR; 2364 U32 hash; 2365 2366 PERL_ARGS_ASSERT_GV_NAME_SET; 2367 PERL_UNUSED_ARG(flags); 2368 2369 if (len > I32_MAX) 2370 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len); 2371 2372 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) { 2373 unshare_hek(GvNAME_HEK(gv)); 2374 } 2375 2376 PERL_HASH(hash, name, len); 2377 GvNAME_HEK(gv) = share_hek(name, len, hash); 2378 } 2379 2380 /* 2381 * Local variables: 2382 * c-indentation-style: bsd 2383 * c-basic-offset: 4 2384 * indent-tabs-mode: t 2385 * End: 2386 * 2387 * ex: set ts=8 sts=4 sw=4 noet: 2388 */ 2389