1 /* gv.c 2 * 3 * Copyright (c) 1991-2001, Larry Wall 4 * 5 * You may distribute under the terms of either the GNU General Public 6 * License or the Artistic License, as specified in the README file. 7 * 8 */ 9 10 /* 11 * 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure 12 * of your inquisitiveness, I shall spend all the rest of my days answering 13 * you. What more do you want to know?' 14 * 'The names of all the stars, and of all living things, and the whole 15 * history of Middle-earth and Over-heaven and of the Sundering Seas,' 16 * laughed Pippin. 17 */ 18 19 #include "EXTERN.h" 20 #define PERL_IN_GV_C 21 #include "perl.h" 22 23 GV * 24 Perl_gv_AVadd(pTHX_ register GV *gv) 25 { 26 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) 27 Perl_croak(aTHX_ "Bad symbol for array"); 28 if (!GvAV(gv)) 29 GvAV(gv) = newAV(); 30 return gv; 31 } 32 33 GV * 34 Perl_gv_HVadd(pTHX_ register GV *gv) 35 { 36 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) 37 Perl_croak(aTHX_ "Bad symbol for hash"); 38 if (!GvHV(gv)) 39 GvHV(gv) = newHV(); 40 return gv; 41 } 42 43 GV * 44 Perl_gv_IOadd(pTHX_ register GV *gv) 45 { 46 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) 47 Perl_croak(aTHX_ "Bad symbol for filehandle"); 48 if (!GvIOp(gv)) 49 GvIOp(gv) = newIO(); 50 return gv; 51 } 52 53 GV * 54 Perl_gv_fetchfile(pTHX_ const char *name) 55 { 56 char smallbuf[256]; 57 char *tmpbuf; 58 STRLEN tmplen; 59 GV *gv; 60 61 if (!PL_defstash) 62 return Nullgv; 63 64 tmplen = strlen(name) + 2; 65 if (tmplen < sizeof smallbuf) 66 tmpbuf = smallbuf; 67 else 68 New(603, tmpbuf, tmplen + 1, char); 69 tmpbuf[0] = '_'; 70 tmpbuf[1] = '<'; 71 strcpy(tmpbuf + 2, name); 72 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE); 73 if (!isGV(gv)) { 74 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE); 75 sv_setpv(GvSV(gv), name); 76 if (PERLDB_LINE) 77 hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, 'L'); 78 } 79 if (tmpbuf != smallbuf) 80 Safefree(tmpbuf); 81 return gv; 82 } 83 84 void 85 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) 86 { 87 register GP *gp; 88 bool doproto = SvTYPE(gv) > SVt_NULL; 89 char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL; 90 91 sv_upgrade((SV*)gv, SVt_PVGV); 92 if (SvLEN(gv)) { 93 if (proto) { 94 SvPVX(gv) = NULL; 95 SvLEN(gv) = 0; 96 SvPOK_off(gv); 97 } else 98 Safefree(SvPVX(gv)); 99 } 100 Newz(602, gp, 1, GP); 101 GvGP(gv) = gp_ref(gp); 102 GvSV(gv) = NEWSV(72,0); 103 GvLINE(gv) = CopLINE(PL_curcop); 104 GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : ""; 105 GvCVGEN(gv) = 0; 106 GvEGV(gv) = gv; 107 sv_magic((SV*)gv, (SV*)gv, '*', Nullch, 0); 108 GvSTASH(gv) = (HV*)SvREFCNT_inc(stash); 109 GvNAME(gv) = savepvn(name, len); 110 GvNAMELEN(gv) = len; 111 if (multi || doproto) /* doproto means it _was_ mentioned */ 112 GvMULTI_on(gv); 113 if (doproto) { /* Replicate part of newSUB here. */ 114 SvIOK_off(gv); 115 ENTER; 116 /* XXX unsafe for threads if eval_owner isn't held */ 117 start_subparse(0,0); /* Create CV in compcv. */ 118 GvCV(gv) = PL_compcv; 119 LEAVE; 120 121 PL_sub_generation++; 122 CvGV(GvCV(gv)) = gv; 123 CvFILE(GvCV(gv)) = CopFILE(PL_curcop); 124 CvSTASH(GvCV(gv)) = PL_curstash; 125 #ifdef USE_THREADS 126 CvOWNER(GvCV(gv)) = 0; 127 if (!CvMUTEXP(GvCV(gv))) { 128 New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex); 129 MUTEX_INIT(CvMUTEXP(GvCV(gv))); 130 } 131 #endif /* USE_THREADS */ 132 if (proto) { 133 sv_setpv((SV*)GvCV(gv), proto); 134 Safefree(proto); 135 } 136 } 137 } 138 139 STATIC void 140 S_gv_init_sv(pTHX_ GV *gv, I32 sv_type) 141 { 142 switch (sv_type) { 143 case SVt_PVIO: 144 (void)GvIOn(gv); 145 break; 146 case SVt_PVAV: 147 (void)GvAVn(gv); 148 break; 149 case SVt_PVHV: 150 (void)GvHVn(gv); 151 break; 152 } 153 } 154 155 /* 156 =for apidoc gv_fetchmeth 157 158 Returns the glob with the given C<name> and a defined subroutine or 159 C<NULL>. The glob lives in the given C<stash>, or in the stashes 160 accessible via @ISA and @UNIVERSAL. 161 162 The argument C<level> should be either 0 or -1. If C<level==0>, as a 163 side-effect creates a glob with the given C<name> in the given C<stash> 164 which in the case of success contains an alias for the subroutine, and sets 165 up caching info for this glob. Similarly for all the searched stashes. 166 167 This function grants C<"SUPER"> token as a postfix of the stash name. The 168 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not 169 visible to Perl code. So when calling C<call_sv>, you should not use 170 the GV directly; instead, you should use the method's CV, which can be 171 obtained from the GV with the C<GvCV> macro. 172 173 =cut 174 */ 175 176 GV * 177 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) 178 { 179 AV* av; 180 GV* topgv; 181 GV* gv; 182 GV** gvp; 183 CV* cv; 184 185 if (!stash) 186 return 0; 187 if ((level > 100) || (level < -100)) 188 Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'", 189 name, HvNAME(stash)); 190 191 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) ); 192 193 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); 194 if (!gvp) 195 topgv = Nullgv; 196 else { 197 topgv = *gvp; 198 if (SvTYPE(topgv) != SVt_PVGV) 199 gv_init(topgv, stash, name, len, TRUE); 200 if ((cv = GvCV(topgv))) { 201 /* If genuine method or valid cache entry, use it */ 202 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation) 203 return topgv; 204 /* Stale cached entry: junk it */ 205 SvREFCNT_dec(cv); 206 GvCV(topgv) = cv = Nullcv; 207 GvCVGEN(topgv) = 0; 208 } 209 else if (GvCVGEN(topgv) == PL_sub_generation) 210 return 0; /* cache indicates sub doesn't exist */ 211 } 212 213 gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE); 214 av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav; 215 216 /* create and re-create @.*::SUPER::ISA on demand */ 217 if (!av || !SvMAGIC(av)) { 218 char* packname = HvNAME(stash); 219 STRLEN packlen = strlen(packname); 220 221 if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) { 222 HV* basestash; 223 224 packlen -= 7; 225 basestash = gv_stashpvn(packname, packlen, TRUE); 226 gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE); 227 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { 228 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE); 229 if (!gvp || !(gv = *gvp)) 230 Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash)); 231 if (SvTYPE(gv) != SVt_PVGV) 232 gv_init(gv, stash, "ISA", 3, TRUE); 233 SvREFCNT_dec(GvAV(gv)); 234 GvAV(gv) = (AV*)SvREFCNT_inc(av); 235 } 236 } 237 } 238 239 if (av) { 240 SV** svp = AvARRAY(av); 241 /* NOTE: No support for tied ISA */ 242 I32 items = AvFILLp(av) + 1; 243 while (items--) { 244 SV* sv = *svp++; 245 HV* basestash = gv_stashsv(sv, FALSE); 246 if (!basestash) { 247 if (ckWARN(WARN_MISC)) 248 Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA", 249 SvPVX(sv), HvNAME(stash)); 250 continue; 251 } 252 gv = gv_fetchmeth(basestash, name, len, 253 (level >= 0) ? level + 1 : level - 1); 254 if (gv) 255 goto gotcha; 256 } 257 } 258 259 /* if at top level, try UNIVERSAL */ 260 261 if (level == 0 || level == -1) { 262 HV* lastchance; 263 264 if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) { 265 if ((gv = gv_fetchmeth(lastchance, name, len, 266 (level >= 0) ? level + 1 : level - 1))) 267 { 268 gotcha: 269 /* 270 * Cache method in topgv if: 271 * 1. topgv has no synonyms (else inheritance crosses wires) 272 * 2. method isn't a stub (else AUTOLOAD fails spectacularly) 273 */ 274 if (topgv && 275 GvREFCNT(topgv) == 1 && 276 (cv = GvCV(gv)) && 277 (CvROOT(cv) || CvXSUB(cv))) 278 { 279 if ((cv = GvCV(topgv))) 280 SvREFCNT_dec(cv); 281 GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv)); 282 GvCVGEN(topgv) = PL_sub_generation; 283 } 284 return gv; 285 } 286 else if (topgv && GvREFCNT(topgv) == 1) { 287 /* cache the fact that the method is not defined */ 288 GvCVGEN(topgv) = PL_sub_generation; 289 } 290 } 291 } 292 293 return 0; 294 } 295 296 /* 297 =for apidoc gv_fetchmethod 298 299 See L<gv_fetchmethod_autoload>. 300 301 =cut 302 */ 303 304 GV * 305 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name) 306 { 307 return gv_fetchmethod_autoload(stash, name, TRUE); 308 } 309 310 /* 311 =for apidoc gv_fetchmethod_autoload 312 313 Returns the glob which contains the subroutine to call to invoke the method 314 on the C<stash>. In fact in the presence of autoloading this may be the 315 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is 316 already setup. 317 318 The third parameter of C<gv_fetchmethod_autoload> determines whether 319 AUTOLOAD lookup is performed if the given method is not present: non-zero 320 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD. 321 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload> 322 with a non-zero C<autoload> parameter. 323 324 These functions grant C<"SUPER"> token as a prefix of the method name. Note 325 that if you want to keep the returned glob for a long time, you need to 326 check for it being "AUTOLOAD", since at the later time the call may load a 327 different subroutine due to $AUTOLOAD changing its value. Use the glob 328 created via a side effect to do this. 329 330 These functions have the same side-effects and as C<gv_fetchmeth> with 331 C<level==0>. C<name> should be writable if contains C<':'> or C<' 332 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to 333 C<call_sv> apply equally to these functions. 334 335 =cut 336 */ 337 338 GV * 339 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) 340 { 341 register const char *nend; 342 const char *nsplit = 0; 343 GV* gv; 344 345 for (nend = name; *nend; nend++) { 346 if (*nend == '\'') 347 nsplit = nend; 348 else if (*nend == ':' && *(nend + 1) == ':') 349 nsplit = ++nend; 350 } 351 if (nsplit) { 352 const char *origname = name; 353 name = nsplit + 1; 354 if (*nsplit == ':') 355 --nsplit; 356 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) { 357 /* ->SUPER::method should really be looked up in original stash */ 358 SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", 359 CopSTASHPV(PL_curcop))); 360 stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE); 361 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", 362 origname, HvNAME(stash), name) ); 363 } 364 else 365 stash = gv_stashpvn(origname, nsplit - origname, TRUE); 366 } 367 368 gv = gv_fetchmeth(stash, name, nend - name, 0); 369 if (!gv) { 370 if (strEQ(name,"import") || strEQ(name,"unimport")) 371 gv = (GV*)&PL_sv_yes; 372 else if (autoload) 373 gv = gv_autoload4(stash, name, nend - name, TRUE); 374 } 375 else if (autoload) { 376 CV* cv = GvCV(gv); 377 if (!CvROOT(cv) && !CvXSUB(cv)) { 378 GV* stubgv; 379 GV* autogv; 380 381 if (CvANON(cv)) 382 stubgv = gv; 383 else { 384 stubgv = CvGV(cv); 385 if (GvCV(stubgv) != cv) /* orphaned import */ 386 stubgv = gv; 387 } 388 autogv = gv_autoload4(GvSTASH(stubgv), 389 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE); 390 if (autogv) 391 gv = autogv; 392 } 393 } 394 395 return gv; 396 } 397 398 GV* 399 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) 400 { 401 static char autoload[] = "AUTOLOAD"; 402 static STRLEN autolen = 8; 403 GV* gv; 404 CV* cv; 405 HV* varstash; 406 GV* vargv; 407 SV* varsv; 408 409 if (len == autolen && strnEQ(name, autoload, autolen)) 410 return Nullgv; 411 if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE))) 412 return Nullgv; 413 cv = GvCV(gv); 414 415 if (!CvROOT(cv)) 416 return Nullgv; 417 418 /* 419 * Inheriting AUTOLOAD for non-methods works ... for now. 420 */ 421 if (ckWARN(WARN_DEPRECATED) && !method && 422 (GvCVGEN(gv) || GvSTASH(gv) != stash)) 423 Perl_warner(aTHX_ WARN_DEPRECATED, 424 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", 425 HvNAME(stash), (int)len, name); 426 427 /* 428 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name. 429 * The subroutine's original name may not be "AUTOLOAD", so we don't 430 * use that, but for lack of anything better we will use the sub's 431 * original package to look up $AUTOLOAD. 432 */ 433 varstash = GvSTASH(CvGV(cv)); 434 vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE); 435 ENTER; 436 437 #ifdef USE_THREADS 438 sv_lock((SV *)varstash); 439 #endif 440 if (!isGV(vargv)) 441 gv_init(vargv, varstash, autoload, autolen, FALSE); 442 LEAVE; 443 varsv = GvSV(vargv); 444 #ifdef USE_THREADS 445 sv_lock(varsv); 446 #endif 447 sv_setpv(varsv, HvNAME(stash)); 448 sv_catpvn(varsv, "::", 2); 449 sv_catpvn(varsv, name, len); 450 SvTAINTED_off(varsv); 451 return gv; 452 } 453 454 /* 455 =for apidoc gv_stashpv 456 457 Returns a pointer to the stash for a specified package. C<name> should 458 be a valid UTF-8 string. If C<create> is set then the package will be 459 created if it does not already exist. If C<create> is not set and the 460 package does not exist then NULL is returned. 461 462 =cut 463 */ 464 465 HV* 466 Perl_gv_stashpv(pTHX_ const char *name, I32 create) 467 { 468 return gv_stashpvn(name, strlen(name), create); 469 } 470 471 HV* 472 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create) 473 { 474 char smallbuf[256]; 475 char *tmpbuf; 476 HV *stash; 477 GV *tmpgv; 478 479 if (namelen + 3 < sizeof smallbuf) 480 tmpbuf = smallbuf; 481 else 482 New(606, tmpbuf, namelen + 3, char); 483 Copy(name,tmpbuf,namelen,char); 484 tmpbuf[namelen++] = ':'; 485 tmpbuf[namelen++] = ':'; 486 tmpbuf[namelen] = '\0'; 487 tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV); 488 if (tmpbuf != smallbuf) 489 Safefree(tmpbuf); 490 if (!tmpgv) 491 return 0; 492 if (!GvHV(tmpgv)) 493 GvHV(tmpgv) = newHV(); 494 stash = GvHV(tmpgv); 495 if (!HvNAME(stash)) 496 HvNAME(stash) = savepv(name); 497 return stash; 498 } 499 500 /* 501 =for apidoc gv_stashsv 502 503 Returns a pointer to the stash for a specified package, which must be a 504 valid UTF-8 string. See C<gv_stashpv>. 505 506 =cut 507 */ 508 509 HV* 510 Perl_gv_stashsv(pTHX_ SV *sv, I32 create) 511 { 512 register char *ptr; 513 STRLEN len; 514 ptr = SvPV(sv,len); 515 return gv_stashpvn(ptr, len, create); 516 } 517 518 519 GV * 520 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) 521 { 522 register const char *name = nambeg; 523 register GV *gv = 0; 524 GV**gvp; 525 I32 len; 526 register const char *namend; 527 HV *stash = 0; 528 529 if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */ 530 name++; 531 532 for (namend = name; *namend; namend++) { 533 if ((*namend == ':' && namend[1] == ':') 534 || (*namend == '\'' && namend[1])) 535 { 536 if (!stash) 537 stash = PL_defstash; 538 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */ 539 return Nullgv; 540 541 len = namend - name; 542 if (len > 0) { 543 char smallbuf[256]; 544 char *tmpbuf; 545 546 if (len + 3 < sizeof smallbuf) 547 tmpbuf = smallbuf; 548 else 549 New(601, tmpbuf, len+3, char); 550 Copy(name, tmpbuf, len, char); 551 tmpbuf[len++] = ':'; 552 tmpbuf[len++] = ':'; 553 tmpbuf[len] = '\0'; 554 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add); 555 gv = gvp ? *gvp : Nullgv; 556 if (gv && gv != (GV*)&PL_sv_undef) { 557 if (SvTYPE(gv) != SVt_PVGV) 558 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI)); 559 else 560 GvMULTI_on(gv); 561 } 562 if (tmpbuf != smallbuf) 563 Safefree(tmpbuf); 564 if (!gv || gv == (GV*)&PL_sv_undef) 565 return Nullgv; 566 567 if (!(stash = GvHV(gv))) 568 stash = GvHV(gv) = newHV(); 569 570 if (!HvNAME(stash)) 571 HvNAME(stash) = savepvn(nambeg, namend - nambeg); 572 } 573 574 if (*namend == ':') 575 namend++; 576 namend++; 577 name = namend; 578 if (!*name) 579 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE); 580 } 581 } 582 len = namend - name; 583 if (!len) 584 len = 1; 585 586 /* No stash in name, so see how we can default */ 587 588 if (!stash) { 589 if (isIDFIRST_lazy(name)) { 590 bool global = FALSE; 591 592 if (isUPPER(*name)) { 593 if (*name == 'S' && ( 594 strEQ(name, "SIG") || 595 strEQ(name, "STDIN") || 596 strEQ(name, "STDOUT") || 597 strEQ(name, "STDERR"))) 598 global = TRUE; 599 else if (*name == 'I' && strEQ(name, "INC")) 600 global = TRUE; 601 else if (*name == 'E' && strEQ(name, "ENV")) 602 global = TRUE; 603 else if (*name == 'A' && ( 604 strEQ(name, "ARGV") || 605 strEQ(name, "ARGVOUT"))) 606 global = TRUE; 607 } 608 else if (*name == '_' && !name[1]) 609 global = TRUE; 610 611 if (global) 612 stash = PL_defstash; 613 else if ((COP*)PL_curcop == &PL_compiling) { 614 stash = PL_curstash; 615 if (add && (PL_hints & HINT_STRICT_VARS) && 616 sv_type != SVt_PVCV && 617 sv_type != SVt_PVGV && 618 sv_type != SVt_PVFM && 619 sv_type != SVt_PVIO && 620 !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) ) 621 { 622 gvp = (GV**)hv_fetch(stash,name,len,0); 623 if (!gvp || 624 *gvp == (GV*)&PL_sv_undef || 625 SvTYPE(*gvp) != SVt_PVGV) 626 { 627 stash = 0; 628 } 629 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) || 630 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) || 631 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) ) 632 { 633 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported", 634 sv_type == SVt_PVAV ? '@' : 635 sv_type == SVt_PVHV ? '%' : '$', 636 name); 637 if (GvCVu(*gvp)) 638 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name); 639 stash = 0; 640 } 641 } 642 } 643 else 644 stash = CopSTASH(PL_curcop); 645 } 646 else 647 stash = PL_defstash; 648 } 649 650 /* By this point we should have a stash and a name */ 651 652 if (!stash) { 653 if (add) { 654 qerror(Perl_mess(aTHX_ 655 "Global symbol \"%s%s\" requires explicit package name", 656 (sv_type == SVt_PV ? "$" 657 : sv_type == SVt_PVAV ? "@" 658 : sv_type == SVt_PVHV ? "%" 659 : ""), name)); 660 stash = PL_nullstash; 661 } 662 else 663 return Nullgv; 664 } 665 666 if (!SvREFCNT(stash)) /* symbol table under destruction */ 667 return Nullgv; 668 669 gvp = (GV**)hv_fetch(stash,name,len,add); 670 if (!gvp || *gvp == (GV*)&PL_sv_undef) 671 return Nullgv; 672 gv = *gvp; 673 if (SvTYPE(gv) == SVt_PVGV) { 674 if (add) { 675 GvMULTI_on(gv); 676 gv_init_sv(gv, sv_type); 677 } 678 return gv; 679 } else if (add & GV_NOINIT) { 680 return gv; 681 } 682 683 /* Adding a new symbol */ 684 685 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL)) 686 Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg); 687 gv_init(gv, stash, name, len, add & GV_ADDMULTI); 688 gv_init_sv(gv, sv_type); 689 690 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) 691 : (PL_dowarn & G_WARN_ON ) ) ) 692 GvMULTI_on(gv) ; 693 694 /* set up magic where warranted */ 695 switch (*name) { 696 case 'A': 697 if (strEQ(name, "ARGV")) { 698 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; 699 } 700 break; 701 case 'E': 702 if (strnEQ(name, "EXPORT", 6)) 703 GvMULTI_on(gv); 704 break; 705 case 'I': 706 if (strEQ(name, "ISA")) { 707 AV* av = GvAVn(gv); 708 GvMULTI_on(gv); 709 sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0); 710 /* NOTE: No support for tied ISA */ 711 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA") 712 && AvFILLp(av) == -1) 713 { 714 char *pname; 715 av_push(av, newSVpvn(pname = "NDBM_File",9)); 716 gv_stashpvn(pname, 9, TRUE); 717 av_push(av, newSVpvn(pname = "DB_File",7)); 718 gv_stashpvn(pname, 7, TRUE); 719 av_push(av, newSVpvn(pname = "GDBM_File",9)); 720 gv_stashpvn(pname, 9, TRUE); 721 av_push(av, newSVpvn(pname = "SDBM_File",9)); 722 gv_stashpvn(pname, 9, TRUE); 723 av_push(av, newSVpvn(pname = "ODBM_File",9)); 724 gv_stashpvn(pname, 9, TRUE); 725 } 726 } 727 break; 728 case 'O': 729 if (strEQ(name, "OVERLOAD")) { 730 HV* hv = GvHVn(gv); 731 GvMULTI_on(gv); 732 hv_magic(hv, Nullgv, 'A'); 733 } 734 break; 735 case 'S': 736 if (strEQ(name, "SIG")) { 737 HV *hv; 738 I32 i; 739 if (!PL_psig_ptr) { 740 int sig_num[] = { SIG_NUM }; 741 New(73, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*); 742 New(73, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*); 743 } 744 GvMULTI_on(gv); 745 hv = GvHVn(gv); 746 hv_magic(hv, Nullgv, 'S'); 747 for (i = 1; PL_sig_name[i]; i++) { 748 SV ** init; 749 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1); 750 if (init) 751 sv_setsv(*init, &PL_sv_undef); 752 PL_psig_ptr[i] = 0; 753 PL_psig_name[i] = 0; 754 } 755 } 756 break; 757 case 'V': 758 if (strEQ(name, "VERSION")) 759 GvMULTI_on(gv); 760 break; 761 762 case '&': 763 if (len > 1) 764 break; 765 PL_sawampersand = TRUE; 766 goto ro_magicalize; 767 768 case '`': 769 if (len > 1) 770 break; 771 PL_sawampersand = TRUE; 772 goto ro_magicalize; 773 774 case '\'': 775 if (len > 1) 776 break; 777 PL_sawampersand = TRUE; 778 goto ro_magicalize; 779 780 case ':': 781 if (len > 1) 782 break; 783 sv_setpv(GvSV(gv),PL_chopset); 784 goto magicalize; 785 786 case '?': 787 if (len > 1) 788 break; 789 #ifdef COMPLEX_STATUS 790 (void)SvUPGRADE(GvSV(gv), SVt_PVLV); 791 #endif 792 goto magicalize; 793 794 case '!': 795 if (len > 1) 796 break; 797 if (sv_type > SVt_PV && PL_curcop != &PL_compiling) { 798 HV* stash = gv_stashpvn("Errno",5,FALSE); 799 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) { 800 dSP; 801 PUTBACK; 802 require_pv("Errno.pm"); 803 SPAGAIN; 804 stash = gv_stashpvn("Errno",5,FALSE); 805 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) 806 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available"); 807 } 808 } 809 goto magicalize; 810 case '-': 811 if (len > 1) 812 break; 813 else { 814 AV* av = GvAVn(gv); 815 sv_magic((SV*)av, Nullsv, 'D', Nullch, 0); 816 SvREADONLY_on(av); 817 } 818 goto magicalize; 819 case '#': 820 case '*': 821 if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV) 822 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of $%s is deprecated", name); 823 /* FALL THROUGH */ 824 case '[': 825 case '^': 826 case '~': 827 case '=': 828 case '%': 829 case '.': 830 case '(': 831 case ')': 832 case '<': 833 case '>': 834 case ',': 835 case '\\': 836 case '/': 837 case '\001': /* $^A */ 838 case '\003': /* $^C */ 839 case '\004': /* $^D */ 840 case '\005': /* $^E */ 841 case '\006': /* $^F */ 842 case '\010': /* $^H */ 843 case '\011': /* $^I, NOT \t in EBCDIC */ 844 case '\017': /* $^O */ 845 case '\020': /* $^P */ 846 case '\024': /* $^T */ 847 if (len > 1) 848 break; 849 goto magicalize; 850 case '|': 851 if (len > 1) 852 break; 853 sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0); 854 goto magicalize; 855 case '\023': /* $^S */ 856 if (len > 1) 857 break; 858 goto ro_magicalize; 859 case '\027': /* $^W & $^WARNING_BITS */ 860 if (len > 1 && strNE(name, "\027ARNING_BITS") 861 && strNE(name, "\027IDE_SYSTEM_CALLS")) 862 break; 863 goto magicalize; 864 865 case '+': 866 if (len > 1) 867 break; 868 else { 869 AV* av = GvAVn(gv); 870 sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0); 871 SvREADONLY_on(av); 872 } 873 /* FALL THROUGH */ 874 case '1': 875 case '2': 876 case '3': 877 case '4': 878 case '5': 879 case '6': 880 case '7': 881 case '8': 882 case '9': 883 ro_magicalize: 884 SvREADONLY_on(GvSV(gv)); 885 magicalize: 886 sv_magic(GvSV(gv), (SV*)gv, 0, name, len); 887 break; 888 889 case '\014': /* $^L */ 890 if (len > 1) 891 break; 892 sv_setpv(GvSV(gv),"\f"); 893 PL_formfeed = GvSV(gv); 894 break; 895 case ';': 896 if (len > 1) 897 break; 898 sv_setpv(GvSV(gv),"\034"); 899 break; 900 case ']': 901 if (len == 1) { 902 SV *sv = GvSV(gv); 903 (void)SvUPGRADE(sv, SVt_PVNV); 904 Perl_sv_setpvf(aTHX_ sv, 905 #if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0) 906 "%8.6" 907 #else 908 "%5.3" 909 #endif 910 NVff, 911 SvNVX(PL_patchlevel)); 912 SvNVX(sv) = SvNVX(PL_patchlevel); 913 SvNOK_on(sv); 914 SvREADONLY_on(sv); 915 } 916 break; 917 case '\026': /* $^V */ 918 if (len == 1) { 919 SV *sv = GvSV(gv); 920 GvSV(gv) = SvREFCNT_inc(PL_patchlevel); 921 SvREFCNT_dec(sv); 922 } 923 break; 924 } 925 return gv; 926 } 927 928 void 929 Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain) 930 { 931 HV *hv = GvSTASH(gv); 932 if (!hv) { 933 (void)SvOK_off(sv); 934 return; 935 } 936 sv_setpv(sv, prefix ? prefix : ""); 937 if (keepmain || strNE(HvNAME(hv), "main")) { 938 sv_catpv(sv,HvNAME(hv)); 939 sv_catpvn(sv,"::", 2); 940 } 941 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv)); 942 } 943 944 void 945 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix) 946 { 947 HV *hv = GvSTASH(gv); 948 if (!hv) { 949 (void)SvOK_off(sv); 950 return; 951 } 952 sv_setpv(sv, prefix ? prefix : ""); 953 sv_catpv(sv,HvNAME(hv)); 954 sv_catpvn(sv,"::", 2); 955 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv)); 956 } 957 958 void 959 Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain) 960 { 961 GV *egv = GvEGV(gv); 962 if (!egv) 963 egv = gv; 964 gv_fullname4(sv, egv, prefix, keepmain); 965 } 966 967 void 968 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix) 969 { 970 GV *egv = GvEGV(gv); 971 if (!egv) 972 egv = gv; 973 gv_fullname3(sv, egv, prefix); 974 } 975 976 /* XXX compatibility with versions <= 5.003. */ 977 void 978 Perl_gv_fullname(pTHX_ SV *sv, GV *gv) 979 { 980 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : ""); 981 } 982 983 /* XXX compatibility with versions <= 5.003. */ 984 void 985 Perl_gv_efullname(pTHX_ SV *sv, GV *gv) 986 { 987 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : ""); 988 } 989 990 IO * 991 Perl_newIO(pTHX) 992 { 993 IO *io; 994 GV *iogv; 995 996 io = (IO*)NEWSV(0,0); 997 sv_upgrade((SV *)io,SVt_PVIO); 998 SvREFCNT(io) = 1; 999 SvOBJECT_on(io); 1000 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV); 1001 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */ 1002 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv)))) 1003 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV); 1004 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv)); 1005 return io; 1006 } 1007 1008 void 1009 Perl_gv_check(pTHX_ HV *stash) 1010 { 1011 register HE *entry; 1012 register I32 i; 1013 register GV *gv; 1014 HV *hv; 1015 1016 if (!HvARRAY(stash)) 1017 return; 1018 for (i = 0; i <= (I32) HvMAX(stash); i++) { 1019 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { 1020 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && 1021 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv)) 1022 { 1023 if (hv != PL_defstash && hv != stash) 1024 gv_check(hv); /* nested package */ 1025 } 1026 else if (isALPHA(*HeKEY(entry))) { 1027 char *file; 1028 gv = (GV*)HeVAL(entry); 1029 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) 1030 continue; 1031 file = GvFILE(gv); 1032 /* performance hack: if filename is absolute and it's a standard 1033 * module, don't bother warning */ 1034 if (file 1035 && PERL_FILE_IS_ABSOLUTE(file) 1036 && (instr(file, "/lib/") || instr(file, ".pm"))) 1037 { 1038 continue; 1039 } 1040 CopLINE_set(PL_curcop, GvLINE(gv)); 1041 #ifdef USE_ITHREADS 1042 CopFILE(PL_curcop) = file; /* set for warning */ 1043 #else 1044 CopFILEGV(PL_curcop) = gv_fetchfile(file); 1045 #endif 1046 Perl_warner(aTHX_ WARN_ONCE, 1047 "Name \"%s::%s\" used only once: possible typo", 1048 HvNAME(stash), GvNAME(gv)); 1049 } 1050 } 1051 } 1052 } 1053 1054 GV * 1055 Perl_newGVgen(pTHX_ char *pack) 1056 { 1057 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++), 1058 TRUE, SVt_PVGV); 1059 } 1060 1061 /* hopefully this is only called on local symbol table entries */ 1062 1063 GP* 1064 Perl_gp_ref(pTHX_ GP *gp) 1065 { 1066 if (!gp) 1067 return (GP*)NULL; 1068 gp->gp_refcnt++; 1069 if (gp->gp_cv) { 1070 if (gp->gp_cvgen) { 1071 /* multi-named GPs cannot be used for method cache */ 1072 SvREFCNT_dec(gp->gp_cv); 1073 gp->gp_cv = Nullcv; 1074 gp->gp_cvgen = 0; 1075 } 1076 else { 1077 /* Adding a new name to a subroutine invalidates method cache */ 1078 PL_sub_generation++; 1079 } 1080 } 1081 return gp; 1082 } 1083 1084 void 1085 Perl_gp_free(pTHX_ GV *gv) 1086 { 1087 GP* gp; 1088 1089 if (!gv || !(gp = GvGP(gv))) 1090 return; 1091 if (gp->gp_refcnt == 0) { 1092 if (ckWARN_d(WARN_INTERNAL)) 1093 Perl_warner(aTHX_ WARN_INTERNAL, 1094 "Attempt to free unreferenced glob pointers"); 1095 return; 1096 } 1097 if (gp->gp_cv) { 1098 /* Deleting the name of a subroutine invalidates method cache */ 1099 PL_sub_generation++; 1100 } 1101 if (--gp->gp_refcnt > 0) { 1102 if (gp->gp_egv == gv) 1103 gp->gp_egv = 0; 1104 return; 1105 } 1106 1107 SvREFCNT_dec(gp->gp_sv); 1108 SvREFCNT_dec(gp->gp_av); 1109 SvREFCNT_dec(gp->gp_hv); 1110 SvREFCNT_dec(gp->gp_io); 1111 SvREFCNT_dec(gp->gp_cv); 1112 SvREFCNT_dec(gp->gp_form); 1113 1114 Safefree(gp); 1115 GvGP(gv) = 0; 1116 } 1117 1118 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286)) 1119 #define MICROPORT 1120 #endif 1121 1122 #ifdef MICROPORT /* Microport 2.4 hack */ 1123 AV *GvAVn(gv) 1124 register GV *gv; 1125 { 1126 if (GvGP(gv)->gp_av) 1127 return GvGP(gv)->gp_av; 1128 else 1129 return GvGP(gv_AVadd(gv))->gp_av; 1130 } 1131 1132 HV *GvHVn(gv) 1133 register GV *gv; 1134 { 1135 if (GvGP(gv)->gp_hv) 1136 return GvGP(gv)->gp_hv; 1137 else 1138 return GvGP(gv_HVadd(gv))->gp_hv; 1139 } 1140 #endif /* Microport 2.4 hack */ 1141 1142 /* Updates and caches the CV's */ 1143 1144 bool 1145 Perl_Gv_AMupdate(pTHX_ HV *stash) 1146 { 1147 GV* gv; 1148 CV* cv; 1149 MAGIC* mg=mg_find((SV*)stash,'c'); 1150 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL; 1151 AMT amt; 1152 STRLEN n_a; 1153 #ifdef OVERLOAD_VIA_HASH 1154 GV** gvp; 1155 HV* hv; 1156 #endif 1157 1158 if (mg && amtp->was_ok_am == PL_amagic_generation 1159 && amtp->was_ok_sub == PL_sub_generation) 1160 return AMT_AMAGIC(amtp); 1161 if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */ 1162 int i; 1163 for (i=1; i<NofAMmeth; i++) { 1164 if (amtp->table[i]) { 1165 SvREFCNT_dec(amtp->table[i]); 1166 } 1167 } 1168 } 1169 sv_unmagic((SV*)stash, 'c'); 1170 1171 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) ); 1172 1173 amt.was_ok_am = PL_amagic_generation; 1174 amt.was_ok_sub = PL_sub_generation; 1175 amt.fallback = AMGfallNO; 1176 amt.flags = 0; 1177 1178 #ifdef OVERLOAD_VIA_HASH 1179 gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */ 1180 if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) { 1181 int filled=0; 1182 int i; 1183 char *cp; 1184 SV* sv; 1185 SV** svp; 1186 1187 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ 1188 1189 if (( cp = (char *)PL_AMG_names[0] ) && 1190 (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) { 1191 if (SvTRUE(sv)) amt.fallback=AMGfallYES; 1192 else if (SvOK(sv)) amt.fallback=AMGfallNEVER; 1193 } 1194 for (i = 1; i < NofAMmeth; i++) { 1195 cv = 0; 1196 cp = (char *)PL_AMG_names[i]; 1197 1198 svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE); 1199 if (svp && ((sv = *svp) != &PL_sv_undef)) { 1200 switch (SvTYPE(sv)) { 1201 default: 1202 if (!SvROK(sv)) { 1203 if (!SvOK(sv)) break; 1204 gv = gv_fetchmethod(stash, SvPV(sv, n_a)); 1205 if (gv) cv = GvCV(gv); 1206 break; 1207 } 1208 cv = (CV*)SvRV(sv); 1209 if (SvTYPE(cv) == SVt_PVCV) 1210 break; 1211 /* FALL THROUGH */ 1212 case SVt_PVHV: 1213 case SVt_PVAV: 1214 Perl_croak(aTHX_ "Not a subroutine reference in overload table"); 1215 return FALSE; 1216 case SVt_PVCV: 1217 cv = (CV*)sv; 1218 break; 1219 case SVt_PVGV: 1220 if (!(cv = GvCVu((GV*)sv))) 1221 cv = sv_2cv(sv, &stash, &gv, FALSE); 1222 break; 1223 } 1224 if (cv) filled=1; 1225 else { 1226 Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n", 1227 cp,HvNAME(stash)); 1228 return FALSE; 1229 } 1230 } 1231 #else 1232 { 1233 int filled = 0; 1234 int i; 1235 const char *cp; 1236 SV* sv = NULL; 1237 1238 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ 1239 1240 if ((cp = PL_AMG_names[0])) { 1241 /* Try to find via inheritance. */ 1242 gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */ 1243 if (gv) 1244 sv = GvSV(gv); 1245 1246 if (!gv) 1247 goto no_table; 1248 else if (SvTRUE(sv)) 1249 amt.fallback=AMGfallYES; 1250 else if (SvOK(sv)) 1251 amt.fallback=AMGfallNEVER; 1252 } 1253 1254 for (i = 1; i < NofAMmeth; i++) { 1255 SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i])); 1256 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n", 1257 cp, HvNAME(stash)) ); 1258 /* don't fill the cache while looking up! */ 1259 gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1); 1260 cv = 0; 1261 if(gv && (cv = GvCV(gv))) { 1262 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil") 1263 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) { 1264 /* GvSV contains the name of the method. */ 1265 GV *ngv; 1266 1267 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n", 1268 SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) ); 1269 if (!SvPOK(GvSV(gv)) 1270 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)), 1271 FALSE))) 1272 { 1273 /* Can be an import stub (created by `can'). */ 1274 if (GvCVGEN(gv)) { 1275 Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'", 1276 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ), 1277 cp, HvNAME(stash)); 1278 } else 1279 Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'", 1280 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ), 1281 cp, HvNAME(stash)); 1282 } 1283 cv = GvCV(gv = ngv); 1284 } 1285 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n", 1286 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))), 1287 GvNAME(CvGV(cv))) ); 1288 filled = 1; 1289 } 1290 #endif 1291 amt.table[i]=(CV*)SvREFCNT_inc(cv); 1292 } 1293 if (filled) { 1294 AMT_AMAGIC_on(&amt); 1295 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT)); 1296 return TRUE; 1297 } 1298 } 1299 /* Here we have no table: */ 1300 no_table: 1301 AMT_AMAGIC_off(&amt); 1302 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS)); 1303 return FALSE; 1304 } 1305 1306 SV* 1307 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) 1308 { 1309 MAGIC *mg; 1310 CV *cv; 1311 CV **cvp=NULL, **ocvp=NULL; 1312 AMT *amtp, *oamtp; 1313 int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0; 1314 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0; 1315 HV* stash; 1316 if (!(AMGf_noleft & flags) && SvAMAGIC(left) 1317 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c')) 1318 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) 1319 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table 1320 : (CV **) NULL)) 1321 && ((cv = cvp[off=method+assignshift]) 1322 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to 1323 * usual method */ 1324 (fl = 1, cv = cvp[off=method])))) { 1325 lr = -1; /* Call method for left argument */ 1326 } else { 1327 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) { 1328 int logic; 1329 1330 /* look for substituted methods */ 1331 /* In all the covered cases we should be called with assign==0. */ 1332 switch (method) { 1333 case inc_amg: 1334 force_cpy = 1; 1335 if ((cv = cvp[off=add_ass_amg]) 1336 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) { 1337 right = &PL_sv_yes; lr = -1; assign = 1; 1338 } 1339 break; 1340 case dec_amg: 1341 force_cpy = 1; 1342 if ((cv = cvp[off = subtr_ass_amg]) 1343 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) { 1344 right = &PL_sv_yes; lr = -1; assign = 1; 1345 } 1346 break; 1347 case bool__amg: 1348 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); 1349 break; 1350 case numer_amg: 1351 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg])); 1352 break; 1353 case string_amg: 1354 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); 1355 break; 1356 case not_amg: 1357 (void)((cv = cvp[off=bool__amg]) 1358 || (cv = cvp[off=numer_amg]) 1359 || (cv = cvp[off=string_amg])); 1360 postpr = 1; 1361 break; 1362 case copy_amg: 1363 { 1364 /* 1365 * SV* ref causes confusion with the interpreter variable of 1366 * the same name 1367 */ 1368 SV* tmpRef=SvRV(left); 1369 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) { 1370 /* 1371 * Just to be extra cautious. Maybe in some 1372 * additional cases sv_setsv is safe, too. 1373 */ 1374 SV* newref = newSVsv(tmpRef); 1375 SvOBJECT_on(newref); 1376 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef)); 1377 return newref; 1378 } 1379 } 1380 break; 1381 case abs_amg: 1382 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) 1383 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { 1384 SV* nullsv=sv_2mortal(newSViv(0)); 1385 if (off1==lt_amg) { 1386 SV* lessp = amagic_call(left,nullsv, 1387 lt_amg,AMGf_noright); 1388 logic = SvTRUE(lessp); 1389 } else { 1390 SV* lessp = amagic_call(left,nullsv, 1391 ncmp_amg,AMGf_noright); 1392 logic = (SvNV(lessp) < 0); 1393 } 1394 if (logic) { 1395 if (off==subtr_amg) { 1396 right = left; 1397 left = nullsv; 1398 lr = 1; 1399 } 1400 } else { 1401 return left; 1402 } 1403 } 1404 break; 1405 case neg_amg: 1406 if ((cv = cvp[off=subtr_amg])) { 1407 right = left; 1408 left = sv_2mortal(newSViv(0)); 1409 lr = 1; 1410 } 1411 break; 1412 case iter_amg: /* XXXX Eventually should do to_gv. */ 1413 /* FAIL safe */ 1414 return NULL; /* Delegate operation to standard mechanisms. */ 1415 break; 1416 case to_sv_amg: 1417 case to_av_amg: 1418 case to_hv_amg: 1419 case to_gv_amg: 1420 case to_cv_amg: 1421 /* FAIL safe */ 1422 return left; /* Delegate operation to standard mechanisms. */ 1423 break; 1424 default: 1425 goto not_found; 1426 } 1427 if (!cv) goto not_found; 1428 } else if (!(AMGf_noright & flags) && SvAMAGIC(right) 1429 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c')) 1430 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) 1431 ? (amtp = (AMT*)mg->mg_ptr)->table 1432 : (CV **) NULL)) 1433 && (cv = cvp[off=method])) { /* Method for right 1434 * argument found */ 1435 lr=1; 1436 } else if (((ocvp && oamtp->fallback > AMGfallNEVER 1437 && (cvp=ocvp) && (lr = -1)) 1438 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1))) 1439 && !(flags & AMGf_unary)) { 1440 /* We look for substitution for 1441 * comparison operations and 1442 * concatenation */ 1443 if (method==concat_amg || method==concat_ass_amg 1444 || method==repeat_amg || method==repeat_ass_amg) { 1445 return NULL; /* Delegate operation to string conversion */ 1446 } 1447 off = -1; 1448 switch (method) { 1449 case lt_amg: 1450 case le_amg: 1451 case gt_amg: 1452 case ge_amg: 1453 case eq_amg: 1454 case ne_amg: 1455 postpr = 1; off=ncmp_amg; break; 1456 case slt_amg: 1457 case sle_amg: 1458 case sgt_amg: 1459 case sge_amg: 1460 case seq_amg: 1461 case sne_amg: 1462 postpr = 1; off=scmp_amg; break; 1463 } 1464 if (off != -1) cv = cvp[off]; 1465 if (!cv) { 1466 goto not_found; 1467 } 1468 } else { 1469 not_found: /* No method found, either report or croak */ 1470 switch (method) { 1471 case to_sv_amg: 1472 case to_av_amg: 1473 case to_hv_amg: 1474 case to_gv_amg: 1475 case to_cv_amg: 1476 /* FAIL safe */ 1477 return left; /* Delegate operation to standard mechanisms. */ 1478 break; 1479 } 1480 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */ 1481 notfound = 1; lr = -1; 1482 } else if (cvp && (cv=cvp[nomethod_amg])) { 1483 notfound = 1; lr = 1; 1484 } else { 1485 SV *msg; 1486 if (off==-1) off=method; 1487 msg = sv_2mortal(Perl_newSVpvf(aTHX_ 1488 "Operation `%s': no method found,%sargument %s%s%s%s", 1489 PL_AMG_names[method + assignshift], 1490 (flags & AMGf_unary ? " " : "\n\tleft "), 1491 SvAMAGIC(left)? 1492 "in overloaded package ": 1493 "has no overloaded magic", 1494 SvAMAGIC(left)? 1495 HvNAME(SvSTASH(SvRV(left))): 1496 "", 1497 SvAMAGIC(right)? 1498 ",\n\tright argument in overloaded package ": 1499 (flags & AMGf_unary 1500 ? "" 1501 : ",\n\tright argument has no overloaded magic"), 1502 SvAMAGIC(right)? 1503 HvNAME(SvSTASH(SvRV(right))): 1504 "")); 1505 if (amtp && amtp->fallback >= AMGfallYES) { 1506 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) ); 1507 } else { 1508 Perl_croak(aTHX_ "%"SVf, msg); 1509 } 1510 return NULL; 1511 } 1512 force_cpy = force_cpy || assign; 1513 } 1514 } 1515 if (!notfound) { 1516 DEBUG_o( Perl_deb(aTHX_ 1517 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n", 1518 PL_AMG_names[off], 1519 method+assignshift==off? "" : 1520 " (initially `", 1521 method+assignshift==off? "" : 1522 PL_AMG_names[method+assignshift], 1523 method+assignshift==off? "" : "')", 1524 flags & AMGf_unary? "" : 1525 lr==1 ? " for right argument": " for left argument", 1526 flags & AMGf_unary? " for argument" : "", 1527 HvNAME(stash), 1528 fl? ",\n\tassignment variant used": "") ); 1529 } 1530 /* Since we use shallow copy during assignment, we need 1531 * to dublicate the contents, probably calling user-supplied 1532 * version of copy operator 1533 */ 1534 /* We need to copy in following cases: 1535 * a) Assignment form was called. 1536 * assignshift==1, assign==T, method + 1 == off 1537 * b) Increment or decrement, called directly. 1538 * assignshift==0, assign==0, method + 0 == off 1539 * c) Increment or decrement, translated to assignment add/subtr. 1540 * assignshift==0, assign==T, 1541 * force_cpy == T 1542 * d) Increment or decrement, translated to nomethod. 1543 * assignshift==0, assign==0, 1544 * force_cpy == T 1545 * e) Assignment form translated to nomethod. 1546 * assignshift==1, assign==T, method + 1 != off 1547 * force_cpy == T 1548 */ 1549 /* off is method, method+assignshift, or a result of opcode substitution. 1550 * In the latter case assignshift==0, so only notfound case is important. 1551 */ 1552 if (( (method + assignshift == off) 1553 && (assign || (method == inc_amg) || (method == dec_amg))) 1554 || force_cpy) 1555 RvDEEPCP(left); 1556 { 1557 dSP; 1558 BINOP myop; 1559 SV* res; 1560 bool oldcatch = CATCH_GET; 1561 1562 CATCH_SET(TRUE); 1563 Zero(&myop, 1, BINOP); 1564 myop.op_last = (OP *) &myop; 1565 myop.op_next = Nullop; 1566 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED; 1567 1568 PUSHSTACKi(PERLSI_OVERLOAD); 1569 ENTER; 1570 SAVEOP(); 1571 PL_op = (OP *) &myop; 1572 if (PERLDB_SUB && PL_curstash != PL_debstash) 1573 PL_op->op_private |= OPpENTERSUB_DB; 1574 PUTBACK; 1575 pp_pushmark(); 1576 1577 EXTEND(SP, notfound + 5); 1578 PUSHs(lr>0? right: left); 1579 PUSHs(lr>0? left: right); 1580 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no )); 1581 if (notfound) { 1582 PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0))); 1583 } 1584 PUSHs((SV*)cv); 1585 PUTBACK; 1586 1587 if ((PL_op = Perl_pp_entersub(aTHX))) 1588 CALLRUNOPS(aTHX); 1589 LEAVE; 1590 SPAGAIN; 1591 1592 res=POPs; 1593 PUTBACK; 1594 POPSTACK; 1595 CATCH_SET(oldcatch); 1596 1597 if (postpr) { 1598 int ans; 1599 switch (method) { 1600 case le_amg: 1601 case sle_amg: 1602 ans=SvIV(res)<=0; break; 1603 case lt_amg: 1604 case slt_amg: 1605 ans=SvIV(res)<0; break; 1606 case ge_amg: 1607 case sge_amg: 1608 ans=SvIV(res)>=0; break; 1609 case gt_amg: 1610 case sgt_amg: 1611 ans=SvIV(res)>0; break; 1612 case eq_amg: 1613 case seq_amg: 1614 ans=SvIV(res)==0; break; 1615 case ne_amg: 1616 case sne_amg: 1617 ans=SvIV(res)!=0; break; 1618 case inc_amg: 1619 case dec_amg: 1620 SvSetSV(left,res); return left; 1621 case not_amg: 1622 ans=!SvTRUE(res); break; 1623 } 1624 return boolSV(ans); 1625 } else if (method==copy_amg) { 1626 if (!SvROK(res)) { 1627 Perl_croak(aTHX_ "Copy method did not return a reference"); 1628 } 1629 return SvREFCNT_inc(SvRV(res)); 1630 } else { 1631 return res; 1632 } 1633 } 1634 } 1635 1636 /* 1637 =for apidoc is_gv_magical 1638 1639 Returns C<TRUE> if given the name of a magical GV. 1640 1641 Currently only useful internally when determining if a GV should be 1642 created even in rvalue contexts. 1643 1644 C<flags> is not used at present but available for future extension to 1645 allow selecting particular classes of magical variable. 1646 1647 =cut 1648 */ 1649 bool 1650 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags) 1651 { 1652 if (!len) 1653 return FALSE; 1654 1655 switch (*name) { 1656 case 'I': 1657 if (len == 3 && strEQ(name, "ISA")) 1658 goto yes; 1659 break; 1660 case 'O': 1661 if (len == 8 && strEQ(name, "OVERLOAD")) 1662 goto yes; 1663 break; 1664 case 'S': 1665 if (len == 3 && strEQ(name, "SIG")) 1666 goto yes; 1667 break; 1668 case '\027': /* $^W & $^WARNING_BITS */ 1669 if (len == 1 1670 || (len == 12 && strEQ(name, "\027ARNING_BITS")) 1671 || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS"))) 1672 { 1673 goto yes; 1674 } 1675 break; 1676 1677 case '&': 1678 case '`': 1679 case '\'': 1680 case ':': 1681 case '?': 1682 case '!': 1683 case '-': 1684 case '#': 1685 case '*': 1686 case '[': 1687 case '^': 1688 case '~': 1689 case '=': 1690 case '%': 1691 case '.': 1692 case '(': 1693 case ')': 1694 case '<': 1695 case '>': 1696 case ',': 1697 case '\\': 1698 case '/': 1699 case '|': 1700 case '+': 1701 case ';': 1702 case ']': 1703 case '\001': /* $^A */ 1704 case '\003': /* $^C */ 1705 case '\004': /* $^D */ 1706 case '\005': /* $^E */ 1707 case '\006': /* $^F */ 1708 case '\010': /* $^H */ 1709 case '\011': /* $^I, NOT \t in EBCDIC */ 1710 case '\014': /* $^L */ 1711 case '\017': /* $^O */ 1712 case '\020': /* $^P */ 1713 case '\023': /* $^S */ 1714 case '\024': /* $^T */ 1715 case '\026': /* $^V */ 1716 if (len == 1) 1717 goto yes; 1718 break; 1719 case '1': 1720 case '2': 1721 case '3': 1722 case '4': 1723 case '5': 1724 case '6': 1725 case '7': 1726 case '8': 1727 case '9': 1728 if (len > 1) { 1729 char *end = name + len; 1730 while (--end > name) { 1731 if (!isDIGIT(*end)) 1732 return FALSE; 1733 } 1734 } 1735 yes: 1736 return TRUE; 1737 default: 1738 break; 1739 } 1740 return FALSE; 1741 } 1742