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