1 /* gv.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 4 * 2000, 2001, 2002, 2003, 2004, 2005, 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 37 static const char S_autoload[] = "AUTOLOAD"; 38 static const STRLEN S_autolen = sizeof(S_autoload)-1; 39 40 41 #ifdef PERL_DONT_CREATE_GVSV 42 GV * 43 Perl_gv_SVadd(pTHX_ GV *gv) 44 { 45 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) 46 Perl_croak(aTHX_ "Bad symbol for scalar"); 47 if (!GvSV(gv)) 48 GvSV(gv) = NEWSV(72,0); 49 return gv; 50 } 51 #endif 52 53 GV * 54 Perl_gv_AVadd(pTHX_ register GV *gv) 55 100746 { 56 100746 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) 57 ###### Perl_croak(aTHX_ "Bad symbol for array"); 58 100746 if (!GvAV(gv)) 59 91455 GvAV(gv) = newAV(); 60 100746 return gv; 61 } 62 63 GV * 64 Perl_gv_HVadd(pTHX_ register GV *gv) 65 41379 { 66 41379 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) 67 ###### Perl_croak(aTHX_ "Bad symbol for hash"); 68 41379 if (!GvHV(gv)) 69 41037 GvHV(gv) = newHV(); 70 41379 return gv; 71 } 72 73 GV * 74 Perl_gv_IOadd(pTHX_ register GV *gv) 75 37173 { 76 37173 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) 77 ###### Perl_croak(aTHX_ "Bad symbol for filehandle"); 78 37173 if (!GvIOp(gv)) { 79 #ifdef GV_UNIQUE_CHECK 80 if (GvUNIQUE(gv)) { 81 Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)"); 82 } 83 #endif 84 37173 GvIOp(gv) = newIO(); 85 } 86 37173 return gv; 87 } 88 89 GV * 90 Perl_gv_fetchfile(pTHX_ const char *name) 91 360943 { 92 360943 char smallbuf[256]; 93 360943 char *tmpbuf; 94 360943 STRLEN tmplen; 95 360943 GV *gv; 96 97 360943 if (!PL_defstash) 98 ###### return Nullgv; 99 100 360943 tmplen = strlen(name) + 2; 101 360943 if (tmplen < sizeof smallbuf) 102 360943 tmpbuf = smallbuf; 103 else 104 ###### New(603, tmpbuf, tmplen + 1, char); 105 /* This is where the debugger's %{"::_<$filename"} hash is created */ 106 360943 tmpbuf[0] = '_'; 107 360943 tmpbuf[1] = '<'; 108 360943 memcpy(tmpbuf + 2, name, tmplen - 1); 109 360943 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE); 110 360943 if (!isGV(gv)) { 111 123384 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE); 112 #ifdef PERL_DONT_CREATE_GVSV 113 GvSV(gv) = newSVpvn(name, tmplen - 2); 114 #else 115 123384 sv_setpvn(GvSV(gv), name, tmplen - 2); 116 #endif 117 123384 if (PERLDB_LINE) 118 87 hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, PERL_MAGIC_dbfile); 119 } 120 360943 if (tmpbuf != smallbuf) 121 ###### Safefree(tmpbuf); 122 360943 return gv; 123 } 124 125 void 126 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) 127 1325649 { 128 dVAR; 129 1325649 register GP *gp; 130 1325649 const bool doproto = SvTYPE(gv) > SVt_NULL; 131 1325649 const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL; 132 133 1325649 sv_upgrade((SV*)gv, SVt_PVGV); 134 1325649 if (SvLEN(gv)) { 135 1887 if (proto) { 136 1887 SvPV_set(gv, NULL); 137 1887 SvLEN_set(gv, 0); 138 1887 SvPOK_off(gv); 139 } else 140 ###### Safefree(SvPVX_mutable(gv)); 141 } 142 1325649 Newz(602, gp, 1, GP); 143 1325649 GvGP(gv) = gp_ref(gp); 144 #ifdef PERL_DONT_CREATE_GVSV 145 GvSV(gv) = 0; 146 #else 147 1325649 GvSV(gv) = NEWSV(72,0); 148 #endif 149 1325649 GvLINE(gv) = CopLINE(PL_curcop); 150 /* XXX Ideally this cast would be replaced with a change to const char* 151 in the struct. */ 152 1325649 GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : (char *) ""; 153 1325649 GvCVGEN(gv) = 0; 154 1325649 GvEGV(gv) = gv; 155 1325649 sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0); 156 1325649 GvSTASH(gv) = stash; 157 1325649 if (stash) 158 1295260 Perl_sv_add_backref(aTHX_ (SV*)stash, (SV*)gv); 159 1325649 GvNAME(gv) = savepvn(name, len); 160 1325649 GvNAMELEN(gv) = len; 161 1325649 if (multi || doproto) /* doproto means it _was_ mentioned */ 162 873503 GvMULTI_on(gv); 163 1325649 if (doproto) { /* Replicate part of newSUB here. */ 164 7099 SvIOK_off(gv); 165 7099 ENTER; 166 /* XXX unsafe for threads if eval_owner isn't held */ 167 7099 start_subparse(0,0); /* Create CV in compcv. */ 168 7099 GvCV(gv) = PL_compcv; 169 7099 LEAVE; 170 171 7099 PL_sub_generation++; 172 7099 CvGV(GvCV(gv)) = gv; 173 7099 CvFILE_set_from_cop(GvCV(gv), PL_curcop); 174 7099 CvSTASH(GvCV(gv)) = PL_curstash; 175 7099 if (proto) { 176 1887 sv_setpv((SV*)GvCV(gv), proto); 177 1887 Safefree(proto); 178 } 179 } 180 } 181 182 STATIC void 183 S_gv_init_sv(pTHX_ GV *gv, I32 sv_type) 184 3027545 { 185 3027545 switch (sv_type) { 186 case SVt_PVIO: 187 48570 (void)GvIOn(gv); 188 21844 break; 189 case SVt_PVAV: 190 527550 (void)GvAVn(gv); 191 86889 break; 192 case SVt_PVHV: 193 189985 (void)GvHVn(gv); 194 break; 195 #ifdef PERL_DONT_CREATE_GVSV 196 case SVt_NULL: 197 case SVt_PVCV: 198 case SVt_PVFM: 199 break; 200 default: 201 (void)GvSVn(gv); 202 #endif 203 } 204 } 205 206 /* 207 =for apidoc gv_fetchmeth 208 209 Returns the glob with the given C and a defined subroutine or 210 C. The glob lives in the given C, or in the stashes 211 accessible via @ISA and UNIVERSAL::. 212 213 The argument C should be either 0 or -1. If C, as a 214 side-effect creates a glob with the given C in the given C 215 which in the case of success contains an alias for the subroutine, and sets 216 up caching info for this glob. Similarly for all the searched stashes. 217 218 This function grants C<"SUPER"> token as a postfix of the stash name. The 219 GV returned from C may be a method cache entry, which is not 220 visible to Perl code. So when calling C, you should not use 221 the GV directly; instead, you should use the method's CV, which can be 222 obtained from the GV with the C macro. 223 224 =cut 225 */ 226 227 GV * 228 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) 229 3296226 { 230 3296226 AV* av; 231 3296226 GV* topgv; 232 3296226 GV* gv; 233 3296226 GV** gvp; 234 3296226 CV* cv; 235 3296226 const char *hvname; 236 237 /* UNIVERSAL methods should be callable without a stash */ 238 3296226 if (!stash) { 239 33 level = -1; /* probably appropriate */ 240 33 if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE))) 241 ###### return 0; 242 } 243 244 3296226 hvname = HvNAME_get(stash); 245 3296226 if (!hvname) 246 1 Perl_croak(aTHX_ 247 "Can't use anonymous symbol table for method lookup"); 248 249 3296225 if ((level > 100) || (level < -100)) 250 ###### Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'", 251 name, hvname); 252 253 3296225 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) ); 254 255 3296225 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); 256 3296225 if (!gvp) 257 2187504 topgv = Nullgv; 258 else { 259 1108721 topgv = *gvp; 260 1108721 if (SvTYPE(topgv) != SVt_PVGV) 261 89645 gv_init(topgv, stash, name, len, TRUE); 262 1108721 if ((cv = GvCV(topgv))) { 263 /* If genuine method or valid cache entry, use it */ 264 811573 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation) 265 760999 return topgv; 266 /* Stale cached entry: junk it */ 267 50574 SvREFCNT_dec(cv); 268 50574 GvCV(topgv) = cv = Nullcv; 269 50574 GvCVGEN(topgv) = 0; 270 } 271 297148 else if (GvCVGEN(topgv) == PL_sub_generation) 272 53290 return 0; /* cache indicates sub doesn't exist */ 273 } 274 275 2481936 gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE); 276 2481936 av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav; 277 278 /* create and re-create @.*::SUPER::ISA on demand */ 279 2481936 if (!av || !SvMAGIC(av)) { 280 2277443 STRLEN packlen = HvNAMELEN_get(stash); 281 282 2277443 if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) { 283 423 HV* basestash; 284 285 423 packlen -= 7; 286 423 basestash = gv_stashpvn(hvname, packlen, TRUE); 287 423 gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE); 288 423 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { 289 419 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE); 290 419 if (!gvp || !(gv = *gvp)) 291 ###### Perl_croak(aTHX_ "Cannot create %s::ISA", hvname); 292 419 if (SvTYPE(gv) != SVt_PVGV) 293 419 gv_init(gv, stash, "ISA", 3, TRUE); 294 419 SvREFCNT_dec(GvAV(gv)); 295 419 GvAV(gv) = (AV*)SvREFCNT_inc(av); 296 } 297 } 298 } 299 300 2481936 if (av) { 301 204912 SV** svp = AvARRAY(av); 302 /* NOTE: No support for tied ISA */ 303 204912 I32 items = AvFILLp(av) + 1; 304 323718 while (items--) { 305 224895 SV* sv = *svp++; 306 224895 HV* basestash = gv_stashsv(sv, FALSE); 307 224895 if (!basestash) { 308 2 if (ckWARN(WARN_MISC)) 309 1 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA", 310 sv, hvname); 311 1 continue; 312 } 313 224893 gv = gv_fetchmeth(basestash, name, len, 314 (level >= 0) ? level + 1 : level - 1); 315 224893 if (gv) 316 106089 goto gotcha; 317 } 318 } 319 320 /* if at top level, try UNIVERSAL */ 321 322 2375847 if (level == 0 || level == -1) { 323 1131659 HV* lastchance; 324 325 1131659 if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) { 326 1131647 if ((gv = gv_fetchmeth(lastchance, name, len, 327 (level >= 0) ? level + 1 : level - 1))) 328 { 329 gotcha: 330 /* 331 * Cache method in topgv if: 332 * 1. topgv has no synonyms (else inheritance crosses wires) 333 * 2. method isn't a stub (else AUTOLOAD fails spectacularly) 334 */ 335 109975 if (topgv && 336 GvREFCNT(topgv) == 1 && 337 (cv = GvCV(gv)) && 338 (CvROOT(cv) || CvXSUB(cv))) 339 { 340 102197 if ((cv = GvCV(topgv))) 341 ###### SvREFCNT_dec(cv); 342 102197 GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv)); 343 102197 GvCVGEN(topgv) = PL_sub_generation; 344 } 345 109975 return gv; 346 } 347 1127761 else if (topgv && GvREFCNT(topgv) == 1) { 348 /* cache the fact that the method is not defined */ 349 62900 GvCVGEN(topgv) = PL_sub_generation; 350 } 351 } 352 } 353 354 2371961 return 0; 355 } 356 357 /* 358 =for apidoc gv_fetchmeth_autoload 359 360 Same as gv_fetchmeth(), but looks for autoloaded subroutines too. 361 Returns a glob for the subroutine. 362 363 For an autoloaded subroutine without a GV, will create a GV even 364 if C. For an autoloaded subroutine without a stub, GvCV() 365 of the result may be zero. 366 367 =cut 368 */ 369 370 GV * 371 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) 372 42809 { 373 42809 GV *gv = gv_fetchmeth(stash, name, len, level); 374 375 42809 if (!gv) { 376 28493 CV *cv; 377 28493 GV **gvp; 378 379 28493 if (!stash) 380 ###### return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */ 381 28493 if (len == S_autolen && strnEQ(name, S_autoload, S_autolen)) 382 ###### return Nullgv; 383 28493 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE))) 384 28464 return Nullgv; 385 29 cv = GvCV(gv); 386 29 if (!(CvROOT(cv) || CvXSUB(cv))) 387 ###### return Nullgv; 388 /* Have an autoload */ 389 29 if (level < 0) /* Cannot do without a stub */ 390 ###### gv_fetchmeth(stash, name, len, 0); 391 29 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); 392 29 if (!gvp) 393 ###### return Nullgv; 394 29 return *gvp; 395 } 396 14316 return gv; 397 } 398 399 /* 400 =for apidoc gv_fetchmethod 401 402 See L. 403 404 =cut 405 */ 406 407 GV * 408 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name) 409 560410 { 410 560410 return gv_fetchmethod_autoload(stash, name, TRUE); 411 } 412 413 /* 414 =for apidoc gv_fetchmethod_autoload 415 416 Returns the glob which contains the subroutine to call to invoke the method 417 on the C. In fact in the presence of autoloading this may be the 418 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is 419 already setup. 420 421 The third parameter of C determines whether 422 AUTOLOAD lookup is performed if the given method is not present: non-zero 423 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD. 424 Calling C is equivalent to calling C 425 with a non-zero C parameter. 426 427 These functions grant C<"SUPER"> token as a prefix of the method name. Note 428 that if you want to keep the returned glob for a long time, you need to 429 check for it being "AUTOLOAD", since at the later time the call may load a 430 different subroutine due to $AUTOLOAD changing its value. Use the glob 431 created via a side effect to do this. 432 433 These functions have the same side-effects and as C with 434 C. C should be writable if contains C<':'> or C<' 435 ''>. The warning against passing the GV returned by C to 436 C apply equally to these functions. 437 438 =cut 439 */ 440 441 GV * 442 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) 443 652587 { 444 652587 register const char *nend; 445 652587 const char *nsplit = 0; 446 652587 GV* gv; 447 652587 HV* ostash = stash; 448 449 652587 if (stash && SvTYPE(stash) < SVt_PVHV) 450 24 stash = Nullhv; 451 452 4712285 for (nend = name; *nend; nend++) { 453 4059698 if (*nend == '\'') 454 ###### nsplit = nend; 455 4059698 else if (*nend == ':' && *(nend + 1) == ':') 456 5105 nsplit = ++nend; 457 } 458 652587 if (nsplit) { 459 4575 const char * const origname = name; 460 4575 name = nsplit + 1; 461 4575 if (*nsplit == ':') 462 4575 --nsplit; 463 4575 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) { 464 /* ->SUPER::method should really be looked up in original stash */ 465 3781 SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", 466 3781 CopSTASHPV(PL_curcop))); 467 /* __PACKAGE__::SUPER stash should be autovivified */ 468 3781 stash = gv_stashpvn(SvPVX_const(tmpstr), SvCUR(tmpstr), TRUE); 469 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", 470 3781 origname, HvNAME_get(stash), name) ); 471 } 472 else { 473 /* don't autovifify if ->NoSuchStash::method */ 474 794 stash = gv_stashpvn(origname, nsplit - origname, FALSE); 475 476 /* however, explicit calls to Pkg::SUPER::method may 477 happen, and may require autovivification to work */ 478 794 if (!stash && (nsplit - origname) >= 7 && 479 strnEQ(nsplit - 7, "::SUPER", 7) && 480 gv_stashpvn(origname, nsplit - origname - 7, FALSE)) 481 2 stash = gv_stashpvn(origname, nsplit - origname, TRUE); 482 } 483 4575 ostash = stash; 484 } 485 486 652587 gv = gv_fetchmeth(stash, name, nend - name, 0); 487 652586 if (!gv) { 488 56783 if (strEQ(name,"import") || strEQ(name,"unimport")) 489 2692 gv = (GV*)&PL_sv_yes; 490 54091 else if (autoload) 491 1727 gv = gv_autoload4(ostash, name, nend - name, TRUE); 492 } 493 595803 else if (autoload) { 494 556002 CV* const cv = GvCV(gv); 495 556002 if (!CvROOT(cv) && !CvXSUB(cv)) { 496 143 GV* stubgv; 497 143 GV* autogv; 498 499 143 if (CvANON(cv)) 500 ###### stubgv = gv; 501 else { 502 143 stubgv = CvGV(cv); 503 143 if (GvCV(stubgv) != cv) /* orphaned import */ 504 ###### stubgv = gv; 505 } 506 143 autogv = gv_autoload4(GvSTASH(stubgv), 507 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE); 508 143 if (autogv) 509 143 gv = autogv; 510 } 511 } 512 513 652586 return gv; 514 } 515 516 GV* 517 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) 518 4957 { 519 dVAR; 520 4957 GV* gv; 521 4957 CV* cv; 522 4957 HV* varstash; 523 4957 GV* vargv; 524 4957 SV* varsv; 525 4957 const char *packname = ""; 526 4957 STRLEN packname_len; 527 528 4957 if (len == S_autolen && strnEQ(name, S_autoload, S_autolen)) 529 ###### return Nullgv; 530 4957 if (stash) { 531 4955 if (SvTYPE(stash) < SVt_PVHV) { 532 6 packname = SvPV_const((SV*)stash, packname_len); 533 6 stash = Nullhv; 534 } 535 else { 536 4949 packname = HvNAME_get(stash); 537 4949 packname_len = HvNAMELEN_get(stash); 538 } 539 } 540 4957 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE))) 541 53 return Nullgv; 542 4904 cv = GvCV(gv); 543 544 4904 if (!(CvROOT(cv) || CvXSUB(cv))) 545 1 return Nullgv; 546 547 /* 548 * Inheriting AUTOLOAD for non-methods works ... for now. 549 */ 550 4903 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method && 551 (GvCVGEN(gv) || GvSTASH(gv) != stash)) 552 1 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), 553 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", 554 packname, (int)len, name); 555 556 4903 if (CvXSUB(cv)) { 557 /* rather than lookup/init $AUTOLOAD here 558 * only to have the XSUB do another lookup for $AUTOLOAD 559 * and split that value on the last '::', 560 * pass along the same data via some unused fields in the CV 561 */ 562 ###### CvSTASH(cv) = stash; 563 ###### SvPV_set(cv, (char *)name); /* cast to lose constness warning */ 564 ###### SvCUR_set(cv, len); 565 ###### return gv; 566 } 567 568 /* 569 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name. 570 * The subroutine's original name may not be "AUTOLOAD", so we don't 571 * use that, but for lack of anything better we will use the sub's 572 * original package to look up $AUTOLOAD. 573 */ 574 4903 varstash = GvSTASH(CvGV(cv)); 575 4903 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE); 576 4903 ENTER; 577 578 4903 if (!isGV(vargv)) { 579 ###### gv_init(vargv, varstash, S_autoload, S_autolen, FALSE); 580 #ifdef PERL_DONT_CREATE_GVSV 581 GvSV(vargv) = NEWSV(72,0); 582 #endif 583 } 584 4903 LEAVE; 585 4903 varsv = GvSVn(vargv); 586 4903 sv_setpvn(varsv, packname, packname_len); 587 4903 sv_catpvn(varsv, "::", 2); 588 4903 sv_catpvn(varsv, name, len); 589 4903 SvTAINTED_off(varsv); 590 4903 return gv; 591 } 592 593 /* The "gv" parameter should be the glob known to Perl code as *! 594 * The scalar must already have been magicalized. 595 */ 596 STATIC void 597 S_require_errno(pTHX_ GV *gv) 598 82 { 599 dVAR; 600 82 HV* stash = gv_stashpvn("Errno",5,FALSE); 601 602 82 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) { 603 3 dSP; 604 3 PUTBACK; 605 3 ENTER; 606 3 save_scalar(gv); /* keep the value of $! */ 607 3 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, 608 newSVpvn("Errno",5), Nullsv); 609 3 LEAVE; 610 3 SPAGAIN; 611 3 stash = gv_stashpvn("Errno",5,FALSE); 612 3 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) 613 ###### Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available"); 614 } 615 } 616 617 /* 618 =for apidoc gv_stashpv 619 620 Returns a pointer to the stash for a specified package. C should 621 be a valid UTF-8 string and must be null-terminated. If C is set 622 then the package will be created if it does not already exist. If C 623 is not set and the package does not exist then NULL is returned. 624 625 =cut 626 */ 627 628 HV* 629 Perl_gv_stashpv(pTHX_ const char *name, I32 create) 630 1072718 { 631 1072718 return gv_stashpvn(name, strlen(name), create); 632 } 633 634 /* 635 =for apidoc gv_stashpvn 636 637 Returns a pointer to the stash for a specified package. C should 638 be a valid UTF-8 string. The C parameter indicates the length of 639 the C, in bytes. If C is set then the package will be 640 created if it does not already exist. If C is not set and the 641 package does not exist then NULL is returned. 642 643 =cut 644 */ 645 646 HV* 647 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create) 648 2898796 { 649 2898796 char smallbuf[256]; 650 2898796 char *tmpbuf; 651 2898796 HV *stash; 652 2898796 GV *tmpgv; 653 654 2898796 if (namelen + 3 < sizeof smallbuf) 655 2898796 tmpbuf = smallbuf; 656 else 657 ###### New(606, tmpbuf, namelen + 3, char); 658 2898796 Copy(name,tmpbuf,namelen,char); 659 2898796 tmpbuf[namelen++] = ':'; 660 2898796 tmpbuf[namelen++] = ':'; 661 2898796 tmpbuf[namelen] = '\0'; 662 2898796 tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV); 663 2898796 if (tmpbuf != smallbuf) 664 ###### Safefree(tmpbuf); 665 2898796 if (!tmpgv) 666 41770 return 0; 667 2857026 if (!GvHV(tmpgv)) 668 ###### GvHV(tmpgv) = newHV(); 669 2857026 stash = GvHV(tmpgv); 670 2857026 if (!HvNAME_get(stash)) 671 ###### Perl_hv_name_set(aTHX_ stash, name, namelen, 0); 672 2857026 return stash; 673 } 674 675 /* 676 =for apidoc gv_stashsv 677 678 Returns a pointer to the stash for a specified package, which must be a 679 valid UTF-8 string. See C. 680 681 =cut 682 */ 683 684 HV* 685 Perl_gv_stashsv(pTHX_ SV *sv, I32 create) 686 275798 { 687 275798 STRLEN len; 688 275798 const char * const ptr = SvPV_const(sv,len); 689 275798 return gv_stashpvn(ptr, len, create); 690 } 691 692 693 GV * 694 10333304 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) { 695 10333304 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type); 696 } 697 698 GV * 699 2898895 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) { 700 2898895 STRLEN len; 701 2898895 const char * const nambeg = SvPV_const(name, len); 702 2898895 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type); 703 } 704 705 GV * 706 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, 707 I32 sv_type) 708 13232199 { 709 13232199 register const char *name = nambeg; 710 13232199 register GV *gv = 0; 711 13232199 GV**gvp; 712 13232199 I32 len; 713 13232199 register const char *namend; 714 13232199 HV *stash = 0; 715 13232199 const I32 add = flags & ~SVf_UTF8; 716 13232199 (void)full_len; 717 718 13232199 if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */ 719 997 name++; 720 721 142300523 for (namend = name; *namend; namend++) { 722 132072066 if ((*namend == ':' && namend[1] == ':') 723 || (*namend == '\'' && namend[1])) 724 { 725 7115704 if (!stash) 726 4752169 stash = PL_defstash; 727 7115704 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */ 728 ###### return Nullgv; 729 730 7115704 len = namend - name; 731 7115704 if (len > 0) { 732 7113985 char smallbuf[256]; 733 7113985 char *tmpbuf; 734 735 7113985 if (len + 3 < sizeof (smallbuf)) 736 7113981 tmpbuf = smallbuf; 737 else 738 4 New(601, tmpbuf, len+3, char); 739 7113985 Copy(name, tmpbuf, len, char); 740 7113985 tmpbuf[len++] = ':'; 741 7113985 tmpbuf[len++] = ':'; 742 7113985 tmpbuf[len] = '\0'; 743 7113985 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add); 744 7113985 gv = gvp ? *gvp : Nullgv; 745 7113985 if (gv && gv != (GV*)&PL_sv_undef) { 746 7021129 if (SvTYPE(gv) != SVt_PVGV) 747 136681 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI)); 748 else 749 6884448 GvMULTI_on(gv); 750 } 751 7113985 if (tmpbuf != smallbuf) 752 4 Safefree(tmpbuf); 753 7113985 if (!gv || gv == (GV*)&PL_sv_undef) 754 92856 return Nullgv; 755 756 7021129 if (!(stash = GvHV(gv))) 757 136681 stash = GvHV(gv) = newHV(); 758 759 7021129 if (!HvNAME_get(stash)) 760 136682 Perl_hv_name_set(aTHX_ stash, nambeg, namend - nambeg, 0); 761 } 762 763 7022848 if (*namend == ':') 764 7021257 namend++; 765 7022848 namend++; 766 7022848 name = namend; 767 7022848 if (!*name) 768 2910886 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE); 769 } 770 } 771 10228457 len = namend - name; 772 773 /* No stash in name, so see how we can default */ 774 775 10228457 if (!stash) { 776 8480030 if (isIDFIRST_lazy(name)) { 777 3744977 bool global = FALSE; 778 779 /* name is always \0 terminated, and initial \0 wouldn't return 780 true from isIDFIRST_lazy, so we know that name[1] is defined */ 781 3744977 switch (name[1]) { 782 case '\0': 783 993103 if (*name == '_') 784 839792 global = TRUE; 785 839792 break; 786 case 'N': 787 93866 if (strEQ(name, "INC") || strEQ(name, "ENV")) 788 87044 global = TRUE; 789 87044 break; 790 case 'I': 791 29953 if (strEQ(name, "SIG")) 792 13833 global = TRUE; 793 13833 break; 794 case 'T': 795 63627 if (strEQ(name, "STDIN") || strEQ(name, "STDOUT") || 796 strEQ(name, "STDERR")) 797 51698 global = TRUE; 798 51698 break; 799 case 'R': 800 51314 if (strEQ(name, "ARGV") || strEQ(name, "ARGVOUT")) 801 35577 global = TRUE; 802 break; 803 } 804 805 3744977 if (global) 806 1027944 stash = PL_defstash; 807 2717033 else if (IN_PERL_COMPILETIME) { 808 2615581 stash = PL_curstash; 809 2615581 if (add && (PL_hints & HINT_STRICT_VARS) && 810 sv_type != SVt_PVCV && 811 sv_type != SVt_PVGV && 812 sv_type != SVt_PVFM && 813 sv_type != SVt_PVIO && 814 !(len == 1 && sv_type == SVt_PV && 815 (*name == 'a' || *name == 'b')) ) 816 { 817 138530 gvp = (GV**)hv_fetch(stash,name,len,0); 818 138530 if (!gvp || 819 *gvp == (GV*)&PL_sv_undef || 820 SvTYPE(*gvp) != SVt_PVGV) 821 { 822 35 stash = 0; 823 } 824 138495 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) || 825 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) || 826 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) ) 827 { 828 10 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported", 829 sv_type == SVt_PVAV ? '@' : 830 sv_type == SVt_PVHV ? '%' : '$', 831 name); 832 10 if (GvCVu(*gvp)) 833 ###### Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name); 834 10 stash = 0; 835 } 836 } 837 } 838 else 839 101452 stash = CopSTASH(PL_curcop); 840 } 841 else 842 4735053 stash = PL_defstash; 843 } 844 845 /* By this point we should have a stash and a name */ 846 847 10228457 if (!stash) { 848 203418 if (add) { 849 45 SV * const err = Perl_mess(aTHX_ 850 "Global symbol \"%s%s\" requires explicit package name", 851 (sv_type == SVt_PV ? "$" 852 : sv_type == SVt_PVAV ? "@" 853 : sv_type == SVt_PVHV ? "%" 854 45 : ""), name); 855 45 if (USE_UTF8_IN_NAMES) 856 1 SvUTF8_on(err); 857 45 qerror(err); 858 45 stash = GvHV(gv_fetchpv("::", GV_ADDMULTI, SVt_PVHV)); 859 } 860 else 861 203373 return Nullgv; 862 } 863 864 10025084 if (!SvREFCNT(stash)) /* symbol table under destruction */ 865 ###### return Nullgv; 866 867 10025084 gvp = (GV**)hv_fetch(stash,name,len,add); 868 10025084 if (!gvp || *gvp == (GV*)&PL_sv_undef) 869 4786894 return Nullgv; 870 5238190 gv = *gvp; 871 5238190 if (SvTYPE(gv) == SVt_PVGV) { 872 4267696 if (add) { 873 2087659 GvMULTI_on(gv); 874 2087659 gv_init_sv(gv, sv_type); 875 2087659 if (*name=='!' && sv_type == SVt_PVHV && len==1) 876 82 require_errno(gv); 877 } 878 4267696 return gv; 879 970494 } else if (add & GV_NOINIT) { 880 30608 return gv; 881 } 882 883 /* Adding a new symbol */ 884 885 939886 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL)) 886 ###### Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg); 887 939886 gv_init(gv, stash, name, len, add & GV_ADDMULTI); 888 939886 gv_init_sv(gv, sv_type); 889 890 939886 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) 891 : (PL_dowarn & G_WARN_ON ) ) ) 892 593585 GvMULTI_on(gv) ; 893 894 /* set up magic where warranted */ 895 939886 if (len > 1) { 896 #ifndef EBCDIC 897 863861 if (*name > 'V' ) { 898 /* Nothing else to do. 899 The compiler will probably turn the switch statement into a 900 branch table. Make sure we avoid even that small overhead for 901 the common case of lower case variable names. */ 902 } else 903 #endif 904 { 905 360411 const char * const name2 = name + 1; 906 360411 switch (*name) { 907 case 'A': 908 14430 if (strEQ(name2, "RGV")) { 909 4500 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; 910 } 911 4500 break; 912 case 'E': 913 40148 if (strnEQ(name2, "XPORT", 5)) 914 27079 GvMULTI_on(gv); 915 27079 break; 916 case 'I': 917 33167 if (strEQ(name2, "SA")) { 918 24556 AV* const av = GvAVn(gv); 919 24556 GvMULTI_on(gv); 920 24556 sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0); 921 /* NOTE: No support for tied ISA */ 922 24556 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA") 923 && AvFILLp(av) == -1) 924 { 925 2 const char *pname; 926 2 av_push(av, newSVpvn(pname = "NDBM_File",9)); 927 2 gv_stashpvn(pname, 9, TRUE); 928 2 av_push(av, newSVpvn(pname = "DB_File",7)); 929 2 gv_stashpvn(pname, 7, TRUE); 930 2 av_push(av, newSVpvn(pname = "GDBM_File",9)); 931 2 gv_stashpvn(pname, 9, TRUE); 932 2 av_push(av, newSVpvn(pname = "SDBM_File",9)); 933 2 gv_stashpvn(pname, 9, TRUE); 934 2 av_push(av, newSVpvn(pname = "ODBM_File",9)); 935 2 gv_stashpvn(pname, 9, TRUE); 936 } 937 } 938 2 break; 939 case 'O': 940 21421 if (strEQ(name2, "VERLOAD")) { 941 608 HV* const hv = GvHVn(gv); 942 608 GvMULTI_on(gv); 943 608 hv_magic(hv, Nullgv, PERL_MAGIC_overload); 944 } 945 608 break; 946 case 'S': 947 39368 if (strEQ(name2, "IG")) { 948 1978 HV *hv; 949 1978 I32 i; 950 1978 if (!PL_psig_ptr) { 951 1978 Newz(73, PL_psig_ptr, SIG_SIZE, SV*); 952 1978 Newz(73, PL_psig_name, SIG_SIZE, SV*); 953 1978 Newz(73, PL_psig_pend, SIG_SIZE, int); 954 } 955 1978 GvMULTI_on(gv); 956 1978 hv = GvHVn(gv); 957 1978 hv_magic(hv, Nullgv, PERL_MAGIC_sig); 958 136482 for (i = 1; i < SIG_SIZE; i++) { 959 134504 SV ** const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1); 960 134504 if (init) 961 134504 sv_setsv(*init, &PL_sv_undef); 962 134504 PL_psig_ptr[i] = 0; 963 134504 PL_psig_name[i] = 0; 964 134504 PL_psig_pend[i] = 0; 965 } 966 } 967 36783 break; 968 case 'V': 969 36783 if (strEQ(name2, "ERSION")) 970 32137 GvMULTI_on(gv); 971 32137 break; 972 case '\003': /* $^CHILD_ERROR_NATIVE */ 973 1 if (strEQ(name2, "HILD_ERROR_NATIVE")) 974 1 goto magicalize; 975 20 break; 976 case '\005': /* $^ENCODING */ 977 20 if (strEQ(name2, "NCODING")) 978 20 goto magicalize; 979 8 break; 980 case '\017': /* $^OPEN */ 981 8 if (strEQ(name2, "PEN")) 982 8 goto magicalize; 983 42 break; 984 case '\024': /* ${^TAINT} */ 985 42 if (strEQ(name2, "AINT")) 986 42 goto ro_magicalize; 987 13 break; 988 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */ 989 13 if (strEQ(name2, "NICODE")) 990 12 goto ro_magicalize; 991 1 if (strEQ(name2, "TF8LOCALE")) 992 1 goto ro_magicalize; 993 2270 break; 994 case '\027': /* $^WARNING_BITS */ 995 2270 if (strEQ(name2, "ARNING_BITS")) 996 2270 goto magicalize; 997 31 break; 998 case '1': 999 case '2': 1000 case '3': 1001 case '4': 1002 case '5': 1003 case '6': 1004 case '7': 1005 case '8': 1006 case '9': 1007 { 1008 /* ensures variable is only digits */ 1009 /* ${"1foo"} fails this test (and is thus writeable) */ 1010 /* added by japhy, but borrowed from is_gv_magical */ 1011 31 const char *end = name + len; 1012 107 while (--end > name) { 1013 94 if (!isDIGIT(*end)) return gv; 1014 } 1015 76025 goto ro_magicalize; 1016 } 1017 } 1018 } 1019 } else { 1020 /* Names of length 1. (Or 0. But name is NUL terminated, so that will 1021 be case '\0' in this switch statement (ie a default case) */ 1022 76025 switch (*name) { 1023 case '&': 1024 case '`': 1025 case '\'': 1026 63 if ( 1027 sv_type == SVt_PVAV || 1028 sv_type == SVt_PVHV || 1029 sv_type == SVt_PVCV || 1030 sv_type == SVt_PVFM || 1031 sv_type == SVt_PVIO 1032 63 ) { break; } 1033 63 PL_sawampersand = TRUE; 1034 63 goto ro_magicalize; 1035 1036 case ':': 1037 121 sv_setpv(GvSVn(gv),PL_chopset); 1038 121 goto magicalize; 1039 1040 case '?': 1041 #ifdef COMPLEX_STATUS 1042 SvUPGRADE(GvSVn(gv), SVt_PVLV); 1043 #endif 1044 2522 goto magicalize; 1045 1046 case '!': 1047 1048 /* If %! has been used, automatically load Errno.pm. 1049 The require will itself set errno, so in order to 1050 preserve its value we have to set up the magic 1051 now (rather than going to magicalize) 1052 */ 1053 1054 2522 sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len); 1055 1056 2522 if (sv_type == SVt_PVHV) 1057 ###### require_errno(gv); 1058 1059 ###### break; 1060 case '-': 1061 { 1062 4500 AV* const av = GvAVn(gv); 1063 4500 sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0); 1064 4500 SvREADONLY_on(av); 1065 4500 goto magicalize; 1066 } 1067 case '*': 1068 case '#': 1069 3 if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) 1070 2 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), 1071 "$%c is no longer supported", *name); 1072 2 break; 1073 case '|': 1074 780 sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0); 1075 780 goto magicalize; 1076 1077 case '+': 1078 { 1079 4500 AV* const av = GvAVn(gv); 1080 4500 sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0); 1081 4500 SvREADONLY_on(av); 1082 /* FALL THROUGH */ 1083 } 1084 case '\023': /* $^S */ 1085 case '1': 1086 case '2': 1087 case '3': 1088 case '4': 1089 case '5': 1090 case '6': 1091 case '7': 1092 case '8': 1093 case '9': 1094 ro_magicalize: 1095 9655 SvREADONLY_on(GvSVn(gv)); 1096 /* FALL THROUGH */ 1097 case '[': 1098 case '^': 1099 case '~': 1100 case '=': 1101 case '%': 1102 case '.': 1103 case '(': 1104 case ')': 1105 case '<': 1106 case '>': 1107 case ',': 1108 case '\\': 1109 case '/': 1110 case '\001': /* $^A */ 1111 case '\003': /* $^C */ 1112 case '\004': /* $^D */ 1113 case '\005': /* $^E */ 1114 case '\006': /* $^F */ 1115 case '\010': /* $^H */ 1116 case '\011': /* $^I, NOT \t in EBCDIC */ 1117 case '\016': /* $^N */ 1118 case '\017': /* $^O */ 1119 case '\020': /* $^P */ 1120 case '\024': /* $^T */ 1121 case '\027': /* $^W */ 1122 magicalize: 1123 34327 sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len); 1124 34327 break; 1125 1126 case '\014': /* $^L */ 1127 143 sv_setpvn(GvSVn(gv),"\f",1); 1128 143 PL_formfeed = GvSVn(gv); 1129 143 break; 1130 case ';': 1131 198 sv_setpvn(GvSVn(gv),"\034",1); 1132 198 break; 1133 case ']': 1134 { 1135 1727 SV * const sv = GvSVn(gv); 1136 1727 if (!sv_derived_from(PL_patchlevel, "version")) 1137 599 (void *)upg_version(PL_patchlevel); 1138 1727 GvSV(gv) = vnumify(PL_patchlevel); 1139 1727 SvREADONLY_on(GvSV(gv)); 1140 1727 SvREFCNT_dec(sv); 1141 } 1142 ###### break; 1143 case '\026': /* $^V */ 1144 { 1145 1514 SV * const sv = GvSVn(gv); 1146 1514 GvSV(gv) = new_version(PL_patchlevel); 1147 1514 SvREADONLY_on(GvSV(gv)); 1148 1514 SvREFCNT_dec(sv); 1149 } 1150 break; 1151 } 1152 } 1153 939868 return gv; 1154 } 1155 1156 void 1157 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) 1158 100510 { 1159 100510 const char *name; 1160 100510 STRLEN namelen; 1161 100510 const HV * const hv = GvSTASH(gv); 1162 100510 if (!hv) { 1163 ###### SvOK_off(sv); 1164 ###### return; 1165 } 1166 100510 sv_setpv(sv, prefix ? prefix : ""); 1167 1168 100510 name = HvNAME_get(hv); 1169 100510 if (name) { 1170 100510 namelen = HvNAMELEN_get(hv); 1171 } else { 1172 ###### name = "__ANON__"; 1173 ###### namelen = 8; 1174 } 1175 1176 100510 if (keepmain || strNE(name, "main")) { 1177 100509 sv_catpvn(sv,name,namelen); 1178 100509 sv_catpvn(sv,"::", 2); 1179 } 1180 100510 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv)); 1181 } 1182 1183 void 1184 Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix) 1185 ###### { 1186 ###### gv_fullname4(sv, gv, prefix, TRUE); 1187 } 1188 1189 void 1190 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) 1191 100505 { 1192 100505 const GV *egv = GvEGV(gv); 1193 100505 if (!egv) 1194 10 egv = gv; 1195 100505 gv_fullname4(sv, egv, prefix, keepmain); 1196 } 1197 1198 void 1199 Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix) 1200 ###### { 1201 ###### gv_efullname4(sv, gv, prefix, TRUE); 1202 } 1203 1204 /* compatibility with versions <= 5.003. */ 1205 void 1206 Perl_gv_fullname(pTHX_ SV *sv, const GV *gv) 1207 ###### { 1208 ###### gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : ""); 1209 } 1210 1211 /* compatibility with versions <= 5.003. */ 1212 void 1213 Perl_gv_efullname(pTHX_ SV *sv, const GV *gv) 1214 ###### { 1215 ###### gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : ""); 1216 } 1217 1218 IO * 1219 Perl_newIO(pTHX) 1220 37298 { 1221 37298 GV *iogv; 1222 37298 IO * const io = (IO*)NEWSV(0,0); 1223 1224 37298 sv_upgrade((SV *)io,SVt_PVIO); 1225 37298 SvREFCNT(io) = 1; 1226 37298 SvOBJECT_on(io); 1227 /* Clear the stashcache because a new IO could overrule a package name */ 1228 37298 hv_clear(PL_stashcache); 1229 37298 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV); 1230 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */ 1231 37298 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv)))) 1232 37027 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV); 1233 37298 SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv))); 1234 37298 return io; 1235 } 1236 1237 void 1238 Perl_gv_check(pTHX_ HV *stash) 1239 61572 { 1240 61572 register I32 i; 1241 1242 61572 if (!HvARRAY(stash)) 1243 ###### return; 1244 1225716 for (i = 0; i <= (I32) HvMAX(stash); i++) { 1245 1164144 const HE *entry; 1246 1807005 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { 1247 642861 register GV *gv; 1248 642861 HV *hv; 1249 642861 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && 1250 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv))) 1251 { 1252 61572 if (hv != PL_defstash && hv != stash) 1253 60125 gv_check(hv); /* nested package */ 1254 } 1255 581289 else if (isALPHA(*HeKEY(entry))) { 1256 474106 const char *file; 1257 474106 gv = (GV*)HeVAL(entry); 1258 474106 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) 1259 28 continue; 1260 28 file = GvFILE(gv); 1261 /* performance hack: if filename is absolute and it's a standard 1262 * module, don't bother warning */ 1263 28 if (file 1264 && PERL_FILE_IS_ABSOLUTE(file) 1265 #ifdef MACOS_TRADITIONAL 1266 && (instr(file, ":lib:") 1267 #else 1268 && (instr(file, "/lib/") 1269 #endif 1270 || instr(file, ".pm"))) 1271 { 1272 28 continue; 1273 } 1274 28 CopLINE_set(PL_curcop, GvLINE(gv)); 1275 #ifdef USE_ITHREADS 1276 CopFILE(PL_curcop) = (char *)file; /* set for warning */ 1277 #else 1278 28 CopFILEGV(PL_curcop) = gv_fetchfile(file); 1279 #endif 1280 28 Perl_warner(aTHX_ packWARN(WARN_ONCE), 1281 "Name \"%s::%s\" used only once: possible typo", 1282 HvNAME_get(stash), GvNAME(gv)); 1283 } 1284 } 1285 } 1286 } 1287 1288 GV * 1289 Perl_newGVgen(pTHX_ const char *pack) 1290 308 { 1291 308 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++), 1292 TRUE, SVt_PVGV); 1293 } 1294 1295 /* hopefully this is only called on local symbol table entries */ 1296 1297 GP* 1298 Perl_gp_ref(pTHX_ GP *gp) 1299 1367278 { 1300 1367278 if (!gp) 1301 ###### return (GP*)NULL; 1302 1367278 gp->gp_refcnt++; 1303 1367278 if (gp->gp_cv) { 1304 10719 if (gp->gp_cvgen) { 1305 /* multi-named GPs cannot be used for method cache */ 1306 4 SvREFCNT_dec(gp->gp_cv); 1307 4 gp->gp_cv = Nullcv; 1308 4 gp->gp_cvgen = 0; 1309 } 1310 else { 1311 /* Adding a new name to a subroutine invalidates method cache */ 1312 10715 PL_sub_generation++; 1313 } 1314 } 1315 1367278 return gp; 1316 } 1317 1318 void 1319 Perl_gp_free(pTHX_ GV *gv) 1320 1519911 { 1321 1519911 GP* gp; 1322 1323 1519911 if (!gv || !(gp = GvGP(gv))) 1324 137931 return; 1325 1381980 if (gp->gp_refcnt == 0) { 1326 ###### if (ckWARN_d(WARN_INTERNAL)) 1327 ###### Perl_warner(aTHX_ packWARN(WARN_INTERNAL), 1328 "Attempt to free unreferenced glob pointers" 1329 pTHX__FORMAT pTHX__VALUE); 1330 ###### return; 1331 } 1332 1381980 if (gp->gp_cv) { 1333 /* Deleting the name of a subroutine invalidates method cache */ 1334 654941 PL_sub_generation++; 1335 } 1336 1381980 if (--gp->gp_refcnt > 0) { 1337 27825 if (gp->gp_egv == gv) 1338 17262 gp->gp_egv = 0; 1339 17262 return; 1340 } 1341 1342 1354155 if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv); 1343 1354155 if (gp->gp_av) SvREFCNT_dec(gp->gp_av); 1344 /* FIXME - another reference loop GV -> symtab -> GV ? 1345 Somehow gp->gp_hv can end up pointing at freed garbage. */ 1346 1354155 if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) { 1347 155784 const char *hvname = HvNAME_get(gp->gp_hv); 1348 155784 if (PL_stashcache && hvname) 1349 337 hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv), 1350 G_DISCARD); 1351 155784 SvREFCNT_dec(gp->gp_hv); 1352 } 1353 1354155 if (gp->gp_io) SvREFCNT_dec(gp->gp_io); 1354 1354155 if (gp->gp_cv) SvREFCNT_dec(gp->gp_cv); 1355 1354155 if (gp->gp_form) SvREFCNT_dec(gp->gp_form); 1356 1357 1354155 Safefree(gp); 1358 1354155 GvGP(gv) = 0; 1359 } 1360 1361 int 1362 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) 1363 42881 { 1364 42881 AMT * const amtp = (AMT*)mg->mg_ptr; 1365 42881 PERL_UNUSED_ARG(sv); 1366 1367 42881 if (amtp && AMT_AMAGIC(amtp)) { 1368 32342 int i; 1369 2134572 for (i = 1; i < NofAMmeth; i++) { 1370 2102230 CV * const cv = amtp->table[i]; 1371 2102230 if (cv != Nullcv) { 1372 133998 SvREFCNT_dec((SV *) cv); 1373 133998 amtp->table[i] = Nullcv; 1374 } 1375 } 1376 } 1377 42881 return 0; 1378 } 1379 1380 /* Updates and caches the CV's */ 1381 1382 bool 1383 Perl_Gv_AMupdate(pTHX_ HV *stash) 1384 1459819 { 1385 1459819 MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); 1386 1459819 AMT * const amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL; 1387 1459819 AMT amt; 1388 1389 1459819 if (mg && amtp->was_ok_am == PL_amagic_generation 1390 && amtp->was_ok_sub == PL_sub_generation) 1391 1417010 return (bool)AMT_OVERLOADED(amtp); 1392 42809 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table); 1393 1394 42809 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) ); 1395 1396 42809 Zero(&amt,1,AMT); 1397 42809 amt.was_ok_am = PL_amagic_generation; 1398 42809 amt.was_ok_sub = PL_sub_generation; 1399 42809 amt.fallback = AMGfallNO; 1400 42809 amt.flags = 0; 1401 1402 { 1403 42809 int filled = 0, have_ovl = 0; 1404 42809 int i, lim = 1; 1405 1406 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ 1407 1408 /* Try to find via inheritance. */ 1409 42809 GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1); 1410 42809 SV * const sv = gv ? GvSV(gv) : NULL; 1411 42809 CV* cv; 1412 1413 42809 if (!gv) 1414 24690 lim = DESTROY_amg; /* Skip overloading entries. */ 1415 #ifdef PERL_DONT_CREATE_GVSV 1416 else if (!sv) { 1417 /* Equivalent to !SvTRUE and !SvOK */ 1418 } 1419 #endif 1420 18119 else if (SvTRUE(sv)) 1421 27 amt.fallback=AMGfallYES; 1422 18092 else if (SvOK(sv)) 1423 ###### amt.fallback=AMGfallNEVER; 1424 1425 1622969 for (i = 1; i < lim; i++) 1426 1580160 amt.table[i] = Nullcv; 1427 2447659 for (; i < NofAMmeth; i++) { 1428 1202425 const char *cooky = PL_AMG_names[i]; 1429 /* Human-readable form, for debugging: */ 1430 1202425 const char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i)); 1431 1202425 const STRLEN l = strlen(cooky); 1432 1433 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n", 1434 1202425 cp, HvNAME_get(stash)) ); 1435 /* don't fill the cache while looking up! 1436 Creation of inheritance stubs in intermediate packages may 1437 conflict with the logic of runtime method substitution. 1438 Indeed, for inheritance A -> B -> C, if C overloads "+0", 1439 then we could have created stubs for "(+0" in A and C too. 1440 But if B overloads "bool", we may want to use it for 1441 numifying instead of C's "+0". */ 1442 1202425 if (i >= DESTROY_amg) 1443 42809 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0); 1444 else /* Autoload taken care of below */ 1445 1159616 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1); 1446 1202425 cv = 0; 1447 1202425 if (gv && (cv = GvCV(gv))) { 1448 133823 const char *hvname; 1449 133823 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil") 1450 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) { 1451 /* This is a hack to support autoloading..., while 1452 knowing *which* methods were declared as overloaded. */ 1453 /* GvSV contains the name of the method. */ 1454 86 GV *ngv = Nullgv; 1455 86 SV *gvsv = GvSV(gv); 1456 1457 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\ 1458 "\" for overloaded \"%s\" in package \"%.256s\"\n", 1459 86 GvSV(gv), cp, hvname) ); 1460 86 if (!gvsv || !SvPOK(gvsv) 1461 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv), 1462 FALSE))) 1463 { 1464 /* Can be an import stub (created by "can"). */ 1465 ###### const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???"; 1466 ###### Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\ 1467 "in package \"%.256s\"", 1468 (GvCVGEN(gv) ? "Stub found while resolving" 1469 : "Can't resolve"), 1470 name, cp, hvname); 1471 } 1472 86 cv = GvCV(gv = ngv); 1473 } 1474 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n", 1475 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))), 1476 133823 GvNAME(CvGV(cv))) ); 1477 133823 filled = 1; 1478 133823 if (i < DESTROY_amg) 1479 119507 have_ovl = 1; 1480 1068602 } else if (gv) { /* Autoloaded... */ 1481 29 cv = (CV*)gv; 1482 29 filled = 1; 1483 } 1484 1202425 amt.table[i]=(CV*)SvREFCNT_inc(cv); 1485 } 1486 42809 if (filled) { 1487 32286 AMT_AMAGIC_on(&amt); 1488 32286 if (have_ovl) 1489 18117 AMT_OVERLOADED_on(&amt); 1490 32286 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table, 1491 (char*)&amt, sizeof(AMT)); 1492 32286 return have_ovl; 1493 } 1494 } 1495 /* Here we have no table: */ 1496 /* no_table: */ 1497 10523 AMT_AMAGIC_off(&amt); 1498 10523 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table, 1499 (char*)&amt, sizeof(AMTS)); 1500 10523 return FALSE; 1501 } 1502 1503 1504 CV* 1505 Perl_gv_handler(pTHX_ HV *stash, I32 id) 1506 1456874 { 1507 1456874 MAGIC *mg; 1508 1456874 AMT *amtp; 1509 1510 1456874 if (!stash || !HvNAME_get(stash)) 1511 1 return Nullcv; 1512 1456873 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); 1513 1456873 if (!mg) { 1514 do_update: 1515 14038 Gv_AMupdate(stash); 1516 14038 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); 1517 } 1518 1468707 amtp = (AMT*)mg->mg_ptr; 1519 1468707 if ( amtp->was_ok_am != PL_amagic_generation 1520 || amtp->was_ok_sub != PL_sub_generation ) 1521 1456873 goto do_update; 1522 1456873 if (AMT_AMAGIC(amtp)) { 1523 157203 CV * const ret = amtp->table[id]; 1524 157203 if (ret && isGV(ret)) { /* Autoloading stab */ 1525 /* Passing it through may have resulted in a warning 1526 "Inherited AUTOLOAD for a non-method deprecated", since 1527 our caller is going through a function call, not a method call. 1528 So return the CV for AUTOLOAD, setting $AUTOLOAD. */ 1529 24 GV *gv = gv_fetchmethod(stash, PL_AMG_names[id]); 1530 1531 24 if (gv && GvCV(gv)) 1532 24 return GvCV(gv); 1533 } 1534 157179 return ret; 1535 } 1536 1537 1299670 return Nullcv; 1538 } 1539 1540 1541 SV* 1542 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) 1543 1228344 { 1544 dVAR; 1545 1228344 MAGIC *mg; 1546 1228344 CV *cv=NULL; 1547 1228344 CV **cvp=NULL, **ocvp=NULL; 1548 1228344 AMT *amtp=NULL, *oamtp=NULL; 1549 1228344 int off = 0, off1, lr = 0, notfound = 0; 1550 1228344 int postpr = 0, force_cpy = 0; 1551 1228344 int assign = AMGf_assign & flags; 1552 1228344 const int assignshift = assign ? 1 : 0; 1553 #ifdef DEBUGGING 1554 1228344 int fl=0; 1555 #endif 1556 1228344 HV* stash=NULL; 1557 1228344 if (!(AMGf_noleft & flags) && SvAMAGIC(left) 1558 && (stash = SvSTASH(SvRV(left))) 1559 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table)) 1560 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) 1561 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table 1562 : (CV **) NULL)) 1563 && ((cv = cvp[off=method+assignshift]) 1564 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to 1565 * usual method */ 1566 ( 1567 #ifdef DEBUGGING 1568 fl = 1, 1569 #endif 1570 cv = cvp[off=method])))) { 1571 30850 lr = -1; /* Call method for left argument */ 1572 } else { 1573 1197494 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) { 1574 1179733 int logic; 1575 1576 /* look for substituted methods */ 1577 /* In all the covered cases we should be called with assign==0. */ 1578 1179733 switch (method) { 1579 case inc_amg: 1580 7 force_cpy = 1; 1581 7 if ((cv = cvp[off=add_ass_amg]) 1582 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) { 1583 2 right = &PL_sv_yes; lr = -1; assign = 1; 1584 } 1585 2 break; 1586 case dec_amg: 1587 7 force_cpy = 1; 1588 7 if ((cv = cvp[off = subtr_ass_amg]) 1589 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) { 1590 2 right = &PL_sv_yes; lr = -1; assign = 1; 1591 } 1592 2 break; 1593 case bool__amg: 1594 583 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); 1595 3 break; 1596 case numer_amg: 1597 3 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg])); 1598 ###### break; 1599 case string_amg: 1600 ###### (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); 1601 5 break; 1602 case not_amg: 1603 5 (void)((cv = cvp[off=bool__amg]) 1604 || (cv = cvp[off=numer_amg]) 1605 || (cv = cvp[off=string_amg])); 1606 5 postpr = 1; 1607 5 break; 1608 case copy_amg: 1609 { 1610 /* 1611 * SV* ref causes confusion with the interpreter variable of 1612 * the same name 1613 */ 1614 4 SV* tmpRef=SvRV(left); 1615 4 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) { 1616 /* 1617 * Just to be extra cautious. Maybe in some 1618 * additional cases sv_setsv is safe, too. 1619 */ 1620 4 SV* newref = newSVsv(tmpRef); 1621 4 SvOBJECT_on(newref); 1622 4 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef))); 1623 4 return newref; 1624 } 1625 } 1626 4 break; 1627 case abs_amg: 1628 4 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) 1629 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { 1630 2 SV* nullsv=sv_2mortal(newSViv(0)); 1631 2 if (off1==lt_amg) { 1632 ###### SV* lessp = amagic_call(left,nullsv, 1633 ###### lt_amg,AMGf_noright); 1634 ###### logic = SvTRUE(lessp); 1635 } else { 1636 2 SV* lessp = amagic_call(left,nullsv, 1637 2 ncmp_amg,AMGf_noright); 1638 2 logic = (SvNV(lessp) < 0); 1639 } 1640 2 if (logic) { 1641 1 if (off==subtr_amg) { 1642 1 right = left; 1643 1 left = nullsv; 1644 1 lr = 1; 1645 } 1646 } else { 1647 1 return left; 1648 } 1649 } 1650 1 break; 1651 case neg_amg: 1652 1 if ((cv = cvp[off=subtr_amg])) { 1653 1 right = left; 1654 1 left = sv_2mortal(newSViv(0)); 1655 1 lr = 1; 1656 } 1657 1 break; 1658 case int_amg: 1659 case iter_amg: /* XXXX Eventually should do to_gv. */ 1660 /* FAIL safe */ 1661 1 return NULL; /* Delegate operation to standard mechanisms. */ 1662 1179105 break; 1663 case to_sv_amg: 1664 case to_av_amg: 1665 case to_hv_amg: 1666 case to_gv_amg: 1667 case to_cv_amg: 1668 /* FAIL safe */ 1669 1179105 return left; /* Delegate operation to standard mechanisms. */ 1670 609 break; 1671 default: 1672 609 goto not_found; 1673 } 1674 609 if (!cv) goto not_found; 1675 17761 } else if (!(AMGf_noright & flags) && SvAMAGIC(right) 1676 && (stash = SvSTASH(SvRV(right))) 1677 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table)) 1678 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) 1679 ? (amtp = (AMT*)mg->mg_ptr)->table 1680 : (CV **) NULL)) 1681 && (cv = cvp[off=method])) { /* Method for right 1682 * argument found */ 1683 1085 lr=1; 1684 16676 } else if (((ocvp && oamtp->fallback > AMGfallNEVER 1685 && (cvp=ocvp) && (lr = -1)) 1686 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1))) 1687 && !(flags & AMGf_unary)) { 1688 /* We look for substitution for 1689 * comparison operations and 1690 * concatenation */ 1691 16676 if (method==concat_amg || method==concat_ass_amg 1692 || method==repeat_amg || method==repeat_ass_amg) { 1693 1850 return NULL; /* Delegate operation to string conversion */ 1694 } 1695 14826 off = -1; 1696 14826 switch (method) { 1697 case lt_amg: 1698 case le_amg: 1699 case gt_amg: 1700 case ge_amg: 1701 case eq_amg: 1702 case ne_amg: 1703 657 postpr = 1; off=ncmp_amg; break; 1704 case slt_amg: 1705 case sle_amg: 1706 case sgt_amg: 1707 case sge_amg: 1708 case seq_amg: 1709 case sne_amg: 1710 13054 postpr = 1; off=scmp_amg; break; 1711 } 1712 14826 if (off != -1) cv = cvp[off]; 1713 14826 if (!cv) { 1714 1867 goto not_found; 1715 } 1716 } else { 1717 not_found: /* No method found, either report or croak */ 1718 1867 switch (method) { 1719 case to_sv_amg: 1720 case to_av_amg: 1721 case to_hv_amg: 1722 case to_gv_amg: 1723 case to_cv_amg: 1724 /* FAIL safe */ 1725 ###### return left; /* Delegate operation to standard mechanisms. */ 1726 1867 break; 1727 } 1728 1867 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */ 1729 70 notfound = 1; lr = -1; 1730 1797 } else if (cvp && (cv=cvp[nomethod_amg])) { 1731 12 notfound = 1; lr = 1; 1732 } else { 1733 1785 SV *msg; 1734 1785 if (off==-1) off=method; 1735 1785 msg = sv_2mortal(Perl_newSVpvf(aTHX_ 1736 "Operation \"%s\": no method found,%sargument %s%s%s%s", 1737 AMG_id2name(method + assignshift), 1738 (flags & AMGf_unary ? " " : "\n\tleft "), 1739 SvAMAGIC(left)? 1740 "in overloaded package ": 1741 "has no overloaded magic", 1742 SvAMAGIC(left)? 1743 HvNAME_get(SvSTASH(SvRV(left))): 1744 "", 1745 SvAMAGIC(right)? 1746 ",\n\tright argument in overloaded package ": 1747 (flags & AMGf_unary 1748 ? "" 1749 : ",\n\tright argument has no overloaded magic"), 1750 SvAMAGIC(right)? 1751 HvNAME_get(SvSTASH(SvRV(right))): 1752 "")); 1753 1785 if (amtp && amtp->fallback >= AMGfallYES) { 1754 1781 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) ); 1755 } else { 1756 4 Perl_croak(aTHX_ "%"SVf, msg); 1757 } 1758 1781 return NULL; 1759 } 1760 82 force_cpy = force_cpy || assign; 1761 } 1762 } 1763 #ifdef DEBUGGING 1764 45598 if (!notfound) { 1765 DEBUG_o(Perl_deb(aTHX_ 1766 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n", 1767 AMG_id2name(off), 1768 method+assignshift==off? "" : 1769 " (initially \"", 1770 method+assignshift==off? "" : 1771 AMG_id2name(method+assignshift), 1772 method+assignshift==off? "" : "\")", 1773 flags & AMGf_unary? "" : 1774 lr==1 ? " for right argument": " for left argument", 1775 flags & AMGf_unary? " for argument" : "", 1776 stash ? HvNAME_get(stash) : "null", 1777 45516 fl? ",\n\tassignment variant used": "") ); 1778 } 1779 #endif 1780 /* Since we use shallow copy during assignment, we need 1781 * to dublicate the contents, probably calling user-supplied 1782 * version of copy operator 1783 */ 1784 /* We need to copy in following cases: 1785 * a) Assignment form was called. 1786 * assignshift==1, assign==T, method + 1 == off 1787 * b) Increment or decrement, called directly. 1788 * assignshift==0, assign==0, method + 0 == off 1789 * c) Increment or decrement, translated to assignment add/subtr. 1790 * assignshift==0, assign==T, 1791 * force_cpy == T 1792 * d) Increment or decrement, translated to nomethod. 1793 * assignshift==0, assign==0, 1794 * force_cpy == T 1795 * e) Assignment form translated to nomethod. 1796 * assignshift==1, assign==T, method + 1 != off 1797 * force_cpy == T 1798 */ 1799 /* off is method, method+assignshift, or a result of opcode substitution. 1800 * In the latter case assignshift==0, so only notfound case is important. 1801 */ 1802 45598 if (( (method + assignshift == off) 1803 && (assign || (method == inc_amg) || (method == dec_amg))) 1804 || force_cpy) 1805 3560 RvDEEPCP(left); 1806 { 1807 45597 dSP; 1808 45597 BINOP myop; 1809 45597 SV* res; 1810 45597 const bool oldcatch = CATCH_GET; 1811 1812 45597 CATCH_SET(TRUE); 1813 45597 Zero(&myop, 1, BINOP); 1814 45597 myop.op_last = (OP *) &myop; 1815 45597 myop.op_next = Nullop; 1816 45597 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED; 1817 1818 45597 PUSHSTACKi(PERLSI_OVERLOAD); 1819 45597 ENTER; 1820 45597 SAVEOP(); 1821 45597 PL_op = (OP *) &myop; 1822 45597 if (PERLDB_SUB && PL_curstash != PL_debstash) 1823 ###### PL_op->op_private |= OPpENTERSUB_DB; 1824 45597 PUTBACK; 1825 45597 pp_pushmark(); 1826 1827 45597 EXTEND(SP, notfound + 5); 1828 45597 PUSHs(lr>0? right: left); 1829 45597 PUSHs(lr>0? left: right); 1830 45597 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no )); 1831 45597 if (notfound) { 1832 82 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0))); 1833 } 1834 45597 PUSHs((SV*)cv); 1835 45597 PUTBACK; 1836 1837 45597 if ((PL_op = Perl_pp_entersub(aTHX))) 1838 42485 CALLRUNOPS(aTHX); 1839 45583 LEAVE; 1840 45583 SPAGAIN; 1841 1842 45583 res=POPs; 1843 45583 PUTBACK; 1844 45583 POPSTACK; 1845 45583 CATCH_SET(oldcatch); 1846 1847 45583 if (postpr) { 1848 12993 int ans; 1849 12993 switch (method) { 1850 case le_amg: 1851 case sle_amg: 1852 19 ans=SvIV(res)<=0; break; 1853 case lt_amg: 1854 case slt_amg: 1855 45 ans=SvIV(res)<0; break; 1856 case ge_amg: 1857 case sge_amg: 1858 34 ans=SvIV(res)>=0; break; 1859 case gt_amg: 1860 case sgt_amg: 1861 51 ans=SvIV(res)>0; break; 1862 case eq_amg: 1863 case seq_amg: 1864 12810 ans=SvIV(res)==0; break; 1865 case ne_amg: 1866 case sne_amg: 1867 25 ans=SvIV(res)!=0; break; 1868 case inc_amg: 1869 case dec_amg: 1870 4 SvSetSV(left,res); return left; 1871 case not_amg: 1872 5 ans=!SvTRUE(res); break; 1873 default: 1874 ###### ans=0; break; 1875 } 1876 12989 return boolSV(ans); 1877 32590 } else if (method==copy_amg) { 1878 17 if (!SvROK(res)) { 1879 1 Perl_croak(aTHX_ "Copy method did not return a reference"); 1880 } 1881 16 return SvREFCNT_inc(SvRV(res)); 1882 } else { 1883 32573 return res; 1884 } 1885 } 1886 } 1887 1888 /* 1889 =for apidoc is_gv_magical_sv 1890 1891 Returns C if given the name of a magical GV. Calls is_gv_magical. 1892 1893 =cut 1894 */ 1895 1896 bool 1897 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags) 1898 870 { 1899 870 STRLEN len; 1900 870 const char *temp = SvPV_const(name, len); 1901 870 return is_gv_magical(temp, len, flags); 1902 } 1903 1904 /* 1905 =for apidoc is_gv_magical 1906 1907 Returns C if given the name of a magical GV. 1908 1909 Currently only useful internally when determining if a GV should be 1910 created even in rvalue contexts. 1911 1912 C is not used at present but available for future extension to 1913 allow selecting particular classes of magical variable. 1914 1915 Currently assumes that C is NUL terminated (as well as len being valid). 1916 This assumption is met by all callers within the perl core, which all pass 1917 pointers returned by SvPV. 1918 1919 =cut 1920 */ 1921 bool 1922 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags) 1923 870 { 1924 870 PERL_UNUSED_ARG(flags); 1925 1926 870 if (len > 1) { 1927 828 const char * const name1 = name + 1; 1928 828 switch (*name) { 1929 case 'I': 1930 36 if (len == 3 && name1[1] == 'S' && name[2] == 'A') 1931 ###### goto yes; 1932 4 break; 1933 case 'O': 1934 4 if (len == 8 && strEQ(name1, "VERLOAD")) 1935 ###### goto yes; 1936 19 break; 1937 case 'S': 1938 19 if (len == 3 && name[1] == 'I' && name[2] == 'G') 1939 ###### goto yes; 1940 ###### break; 1941 /* Using ${^...} variables is likely to be sufficiently rare that 1942 it seems sensible to avoid the space hit of also checking the 1943 length. */ 1944 case '\017': /* ${^OPEN} */ 1945 ###### if (strEQ(name1, "PEN")) 1946 ###### goto yes; 1947 27 break; 1948 case '\024': /* ${^TAINT} */ 1949 27 if (strEQ(name1, "AINT")) 1950 27 goto yes; 1951 ###### break; 1952 case '\025': /* ${^UNICODE} */ 1953 ###### if (strEQ(name1, "NICODE")) 1954 ###### goto yes; 1955 ###### if (strEQ(name1, "TF8LOCALE")) 1956 ###### goto yes; 1957 ###### break; 1958 case '\027': /* ${^WARNING_BITS} */ 1959 ###### if (strEQ(name1, "ARNING_BITS")) 1960 ###### goto yes; 1961 62 break; 1962 case '1': 1963 case '2': 1964 case '3': 1965 case '4': 1966 case '5': 1967 case '6': 1968 case '7': 1969 case '8': 1970 case '9': 1971 { 1972 62 const char *end = name + len; 1973 257 while (--end > name) { 1974 251 if (!isDIGIT(*end)) 1975 56 return FALSE; 1976 } 1977 42 goto yes; 1978 } 1979 } 1980 } else { 1981 /* Because we're already assuming that name is NUL terminated 1982 below, we can treat an empty name as "\0" */ 1983 42 switch (*name) { 1984 case '&': 1985 case '`': 1986 case '\'': 1987 case ':': 1988 case '?': 1989 case '!': 1990 case '-': 1991 case '#': 1992 case '[': 1993 case '^': 1994 case '~': 1995 case '=': 1996 case '%': 1997 case '.': 1998 case '(': 1999 case ')': 2000 case '<': 2001 case '>': 2002 case ',': 2003 case '\\': 2004 case '/': 2005 case '|': 2006 case '+': 2007 case ';': 2008 case ']': 2009 case '\001': /* $^A */ 2010 case '\003': /* $^C */ 2011 case '\004': /* $^D */ 2012 case '\005': /* $^E */ 2013 case '\006': /* $^F */ 2014 case '\010': /* $^H */ 2015 case '\011': /* $^I, NOT \t in EBCDIC */ 2016 case '\014': /* $^L */ 2017 case '\016': /* $^N */ 2018 case '\017': /* $^O */ 2019 case '\020': /* $^P */ 2020 case '\023': /* $^S */ 2021 case '\024': /* $^T */ 2022 case '\026': /* $^V */ 2023 case '\027': /* $^W */ 2024 case '1': 2025 case '2': 2026 case '3': 2027 case '4': 2028 case '5': 2029 case '6': 2030 case '7': 2031 case '8': 2032 case '9': 2033 yes: 2034 35 return TRUE; 2035 default: 2036 779 break; 2037 } 2038 } 2039 779 return FALSE; 2040 } 2041 2042 /* 2043 * Local variables: 2044 * c-indentation-style: bsd 2045 * c-basic-offset: 4 2046 * indent-tabs-mode: t 2047 * End: 2048 * 2049 * ex: set ts=8 sts=4 sw=4 noet: 2050 */