1 /* mg.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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 * Sam sat on the ground and put his head in his hands. 'I wish I had never 13 * come here, and I don't want to see no more magic,' he said, and fell silent. 14 * 15 * [p.363 of _The Lord of the Rings_, II/vii: "The Mirror of Galadriel"] 16 */ 17 18 /* 19 =head1 Magic 20 "Magic" is special data attached to SV structures in order to give them 21 "magical" properties. When any Perl code tries to read from, or assign to, 22 an SV marked as magical, it calls the 'get' or 'set' function associated 23 with that SV's magic. A get is called prior to reading an SV, in order to 24 give it a chance to update its internal value (get on $. writes the line 25 number of the last read filehandle into the SV's IV slot), while 26 set is called after an SV has been written to, in order to allow it to make 27 use of its changed value (set on $/ copies the SV's new value to the 28 PL_rs global variable). 29 30 Magic is implemented as a linked list of MAGIC structures attached to the 31 SV. Each MAGIC struct holds the type of the magic, a pointer to an array 32 of functions that implement the get(), set(), length() etc functions, 33 plus space for some flags and pointers. For example, a tied variable has 34 a MAGIC structure that contains a pointer to the object associated with the 35 tie. 36 37 =for apidoc Ayh||MAGIC 38 39 =cut 40 41 */ 42 43 #include "EXTERN.h" 44 #define PERL_IN_MG_C 45 #include "perl.h" 46 #include "feature.h" 47 48 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) 49 # ifdef I_GRP 50 # include <grp.h> 51 # endif 52 #endif 53 54 #if defined(HAS_SETGROUPS) 55 # ifndef NGROUPS 56 # define NGROUPS 32 57 # endif 58 #endif 59 60 #ifdef __hpux 61 # include <sys/pstat.h> 62 #endif 63 64 #ifdef HAS_PRCTL_SET_NAME 65 # include <sys/prctl.h> 66 #endif 67 68 #ifdef __Lynx__ 69 /* Missing protos on LynxOS */ 70 void setruid(uid_t id); 71 void seteuid(uid_t id); 72 void setrgid(uid_t id); 73 void setegid(uid_t id); 74 #endif 75 76 /* 77 * Pre-magic setup and post-magic takedown. 78 * Use the "DESTRUCTOR" scope cleanup to reinstate magic. 79 */ 80 81 struct magic_state { 82 SV* mgs_sv; 83 I32 mgs_ss_ix; 84 U32 mgs_flags; 85 bool mgs_bumped; 86 }; 87 /* MGS is typedef'ed to struct magic_state in perl.h */ 88 89 STATIC void 90 S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags) 91 { 92 MGS* mgs; 93 bool bumped = FALSE; 94 95 PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS; 96 97 assert(SvMAGICAL(sv)); 98 99 /* we shouldn't really be called here with RC==0, but it can sometimes 100 * happen via mg_clear() (which also shouldn't be called when RC==0, 101 * but it can happen). Handle this case gracefully(ish) by not RC++ 102 * and thus avoiding the resultant double free */ 103 if (SvREFCNT(sv) > 0) { 104 /* guard against sv getting freed midway through the mg clearing, 105 * by holding a private reference for the duration. */ 106 SvREFCNT_inc_simple_void_NN(sv); 107 bumped = TRUE; 108 } 109 110 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix)); 111 112 mgs = SSPTR(mgs_ix, MGS*); 113 mgs->mgs_sv = sv; 114 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv); 115 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */ 116 mgs->mgs_bumped = bumped; 117 118 SvFLAGS(sv) &= ~flags; 119 SvREADONLY_off(sv); 120 } 121 122 #define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG) 123 124 /* 125 =for apidoc mg_magical 126 127 Turns on the magical status of an SV. See C<L</sv_magic>>. 128 129 =cut 130 */ 131 132 void 133 Perl_mg_magical(SV *sv) 134 { 135 const MAGIC* mg; 136 PERL_ARGS_ASSERT_MG_MAGICAL; 137 138 SvMAGICAL_off(sv); 139 if ((mg = SvMAGIC(sv))) { 140 do { 141 const MGVTBL* const vtbl = mg->mg_virtual; 142 if (vtbl) { 143 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP)) 144 SvGMAGICAL_on(sv); 145 if (vtbl->svt_set) 146 SvSMAGICAL_on(sv); 147 if (vtbl->svt_clear) 148 SvRMAGICAL_on(sv); 149 } 150 } while ((mg = mg->mg_moremagic)); 151 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG))) 152 SvRMAGICAL_on(sv); 153 } 154 } 155 156 /* 157 =for apidoc mg_get 158 159 Do magic before a value is retrieved from the SV. The type of SV must 160 be >= C<SVt_PVMG>. See C<L</sv_magic>>. 161 162 =cut 163 */ 164 165 int 166 Perl_mg_get(pTHX_ SV *sv) 167 { 168 const I32 mgs_ix = SSNEW(sizeof(MGS)); 169 bool saved = FALSE; 170 bool have_new = 0; 171 bool taint_only = TRUE; /* the only get method seen is taint */ 172 MAGIC *newmg, *head, *cur, *mg; 173 174 PERL_ARGS_ASSERT_MG_GET; 175 176 if (PL_localizing == 1 && sv == DEFSV) return 0; 177 178 /* We must call svt_get(sv, mg) for each valid entry in the linked 179 list of magic. svt_get() may delete the current entry, add new 180 magic to the head of the list, or upgrade the SV. AMS 20010810 */ 181 182 newmg = cur = head = mg = SvMAGIC(sv); 183 while (mg) { 184 const MGVTBL * const vtbl = mg->mg_virtual; 185 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */ 186 187 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { 188 189 /* taint's mg get is so dumb it doesn't need flag saving */ 190 if (mg->mg_type != PERL_MAGIC_taint) { 191 taint_only = FALSE; 192 if (!saved) { 193 save_magic(mgs_ix, sv); 194 saved = TRUE; 195 } 196 } 197 198 vtbl->svt_get(aTHX_ sv, mg); 199 200 /* guard against magic having been deleted - eg FETCH calling 201 * untie */ 202 if (!SvMAGIC(sv)) { 203 /* recalculate flags */ 204 (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); 205 break; 206 } 207 208 /* recalculate flags if this entry was deleted. */ 209 if (mg->mg_flags & MGf_GSKIP) 210 (SSPTR(mgs_ix, MGS *))->mgs_flags &= 211 ~(SVs_GMG|SVs_SMG|SVs_RMG); 212 } 213 else if (vtbl == &PL_vtbl_utf8) { 214 /* get-magic can reallocate the PV, unless there's only taint 215 * magic */ 216 if (taint_only) { 217 MAGIC *mg2; 218 for (mg2 = nextmg; mg2; mg2 = mg2->mg_moremagic) { 219 if ( mg2->mg_type != PERL_MAGIC_taint 220 && !(mg2->mg_flags & MGf_GSKIP) 221 && mg2->mg_virtual 222 && mg2->mg_virtual->svt_get 223 ) { 224 taint_only = FALSE; 225 break; 226 } 227 } 228 } 229 if (!taint_only) 230 magic_setutf8(sv, mg); 231 } 232 233 mg = nextmg; 234 235 if (have_new) { 236 /* Have we finished with the new entries we saw? Start again 237 where we left off (unless there are more new entries). */ 238 if (mg == head) { 239 have_new = 0; 240 mg = cur; 241 head = newmg; 242 } 243 } 244 245 /* Were any new entries added? */ 246 if (!have_new && (newmg = SvMAGIC(sv)) != head) { 247 have_new = 1; 248 cur = mg; 249 mg = newmg; 250 /* recalculate flags */ 251 (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); 252 } 253 } 254 255 if (saved) 256 restore_magic(INT2PTR(void *, (IV)mgs_ix)); 257 258 return 0; 259 } 260 261 /* 262 =for apidoc mg_set 263 264 Do magic after a value is assigned to the SV. See C<L</sv_magic>>. 265 266 =cut 267 */ 268 269 int 270 Perl_mg_set(pTHX_ SV *sv) 271 { 272 const I32 mgs_ix = SSNEW(sizeof(MGS)); 273 MAGIC* mg; 274 MAGIC* nextmg; 275 276 PERL_ARGS_ASSERT_MG_SET; 277 278 if (PL_localizing == 2 && sv == DEFSV) return 0; 279 280 save_magic_flags(mgs_ix, sv, SVs_GMG|SVs_SMG); /* leave SVs_RMG on */ 281 282 for (mg = SvMAGIC(sv); mg; mg = nextmg) { 283 const MGVTBL* vtbl = mg->mg_virtual; 284 nextmg = mg->mg_moremagic; /* it may delete itself */ 285 if (mg->mg_flags & MGf_GSKIP) { 286 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */ 287 (SSPTR(mgs_ix, MGS*))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); 288 } 289 if (PL_localizing == 2 290 && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type)) 291 continue; 292 if (vtbl && vtbl->svt_set) 293 vtbl->svt_set(aTHX_ sv, mg); 294 } 295 296 restore_magic(INT2PTR(void*, (IV)mgs_ix)); 297 return 0; 298 } 299 300 /* 301 =for apidoc mg_length 302 303 Reports on the SV's length in bytes, calling length magic if available, 304 but does not set the UTF8 flag on C<sv>. It will fall back to 'get' 305 magic if there is no 'length' magic, but with no indication as to 306 whether it called 'get' magic. It assumes C<sv> is a C<PVMG> or 307 higher. Use C<sv_len()> instead. 308 309 =cut 310 */ 311 312 U32 313 Perl_mg_length(pTHX_ SV *sv) 314 { 315 MAGIC* mg; 316 STRLEN len; 317 318 PERL_ARGS_ASSERT_MG_LENGTH; 319 320 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 321 const MGVTBL * const vtbl = mg->mg_virtual; 322 if (vtbl && vtbl->svt_len) { 323 const I32 mgs_ix = SSNEW(sizeof(MGS)); 324 save_magic(mgs_ix, sv); 325 /* omit MGf_GSKIP -- not changed here */ 326 len = vtbl->svt_len(aTHX_ sv, mg); 327 restore_magic(INT2PTR(void*, (IV)mgs_ix)); 328 return len; 329 } 330 } 331 332 (void)SvPV_const(sv, len); 333 return len; 334 } 335 336 I32 337 Perl_mg_size(pTHX_ SV *sv) 338 { 339 MAGIC* mg; 340 341 PERL_ARGS_ASSERT_MG_SIZE; 342 343 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 344 const MGVTBL* const vtbl = mg->mg_virtual; 345 if (vtbl && vtbl->svt_len) { 346 const I32 mgs_ix = SSNEW(sizeof(MGS)); 347 I32 len; 348 save_magic(mgs_ix, sv); 349 /* omit MGf_GSKIP -- not changed here */ 350 len = vtbl->svt_len(aTHX_ sv, mg); 351 restore_magic(INT2PTR(void*, (IV)mgs_ix)); 352 return len; 353 } 354 } 355 356 switch(SvTYPE(sv)) { 357 case SVt_PVAV: 358 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */ 359 case SVt_PVHV: 360 /* FIXME */ 361 default: 362 Perl_croak(aTHX_ "Size magic not implemented"); 363 364 } 365 NOT_REACHED; /* NOTREACHED */ 366 } 367 368 /* 369 =for apidoc mg_clear 370 371 Clear something magical that the SV represents. See C<L</sv_magic>>. 372 373 =cut 374 */ 375 376 int 377 Perl_mg_clear(pTHX_ SV *sv) 378 { 379 const I32 mgs_ix = SSNEW(sizeof(MGS)); 380 MAGIC* mg; 381 MAGIC *nextmg; 382 383 PERL_ARGS_ASSERT_MG_CLEAR; 384 385 save_magic(mgs_ix, sv); 386 387 for (mg = SvMAGIC(sv); mg; mg = nextmg) { 388 const MGVTBL* const vtbl = mg->mg_virtual; 389 /* omit GSKIP -- never set here */ 390 391 nextmg = mg->mg_moremagic; /* it may delete itself */ 392 393 if (vtbl && vtbl->svt_clear) 394 vtbl->svt_clear(aTHX_ sv, mg); 395 } 396 397 restore_magic(INT2PTR(void*, (IV)mgs_ix)); 398 return 0; 399 } 400 401 static MAGIC* 402 S_mg_findext_flags(const SV *sv, int type, const MGVTBL *vtbl, U32 flags) 403 { 404 assert(flags <= 1); 405 406 if (sv) { 407 MAGIC *mg; 408 409 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 410 if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) { 411 return mg; 412 } 413 } 414 } 415 416 return NULL; 417 } 418 419 /* 420 =for apidoc mg_find 421 422 Finds the magic pointer for C<type> matching the SV. See C<L</sv_magic>>. 423 424 =cut 425 */ 426 427 MAGIC* 428 Perl_mg_find(const SV *sv, int type) 429 { 430 return S_mg_findext_flags(sv, type, NULL, 0); 431 } 432 433 /* 434 =for apidoc mg_findext 435 436 Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See 437 C<L</sv_magicext>>. 438 439 =cut 440 */ 441 442 MAGIC* 443 Perl_mg_findext(const SV *sv, int type, const MGVTBL *vtbl) 444 { 445 return S_mg_findext_flags(sv, type, vtbl, 1); 446 } 447 448 MAGIC * 449 Perl_mg_find_mglob(pTHX_ SV *sv) 450 { 451 PERL_ARGS_ASSERT_MG_FIND_MGLOB; 452 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') { 453 /* This sv is only a delegate. //g magic must be attached to 454 its target. */ 455 vivify_defelem(sv); 456 sv = LvTARG(sv); 457 } 458 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) 459 return S_mg_findext_flags(sv, PERL_MAGIC_regex_global, 0, 0); 460 return NULL; 461 } 462 463 /* 464 =for apidoc mg_copy 465 466 Copies the magic from one SV to another. See C<L</sv_magic>>. 467 468 =cut 469 */ 470 471 int 472 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) 473 { 474 int count = 0; 475 MAGIC* mg; 476 477 PERL_ARGS_ASSERT_MG_COPY; 478 479 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 480 const MGVTBL* const vtbl = mg->mg_virtual; 481 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){ 482 count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen); 483 } 484 else { 485 const char type = mg->mg_type; 486 if (isUPPER(type) && type != PERL_MAGIC_uvar) { 487 sv_magic(nsv, 488 (type == PERL_MAGIC_tied) 489 ? SvTIED_obj(sv, mg) 490 : mg->mg_obj, 491 toLOWER(type), key, klen); 492 count++; 493 } 494 } 495 } 496 return count; 497 } 498 499 /* 500 =for apidoc mg_localize 501 502 Copy some of the magic from an existing SV to new localized version of that 503 SV. Container magic (I<e.g.>, C<%ENV>, C<$1>, C<tie>) 504 gets copied, value magic doesn't (I<e.g.>, 505 C<taint>, C<pos>). 506 507 If C<setmagic> is false then no set magic will be called on the new (empty) SV. 508 This typically means that assignment will soon follow (e.g. S<C<'local $x = $y'>>), 509 and that will handle the magic. 510 511 =cut 512 */ 513 514 void 515 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic) 516 { 517 MAGIC *mg; 518 519 PERL_ARGS_ASSERT_MG_LOCALIZE; 520 521 if (nsv == DEFSV) 522 return; 523 524 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 525 const MGVTBL* const vtbl = mg->mg_virtual; 526 if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type)) 527 continue; 528 529 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local) 530 (void)vtbl->svt_local(aTHX_ nsv, mg); 531 else 532 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl, 533 mg->mg_ptr, mg->mg_len); 534 535 /* container types should remain read-only across localization */ 536 SvFLAGS(nsv) |= SvREADONLY(sv); 537 } 538 539 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) { 540 SvFLAGS(nsv) |= SvMAGICAL(sv); 541 if (setmagic) { 542 PL_localizing = 1; 543 SvSETMAGIC(nsv); 544 PL_localizing = 0; 545 } 546 } 547 } 548 549 #define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg) 550 static void 551 S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg) 552 { 553 const MGVTBL* const vtbl = mg->mg_virtual; 554 if (vtbl && vtbl->svt_free) 555 vtbl->svt_free(aTHX_ sv, mg); 556 557 if (mg->mg_len > 0) 558 Safefree(mg->mg_ptr); 559 else if (mg->mg_len == HEf_SVKEY) 560 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); 561 562 if (mg->mg_flags & MGf_REFCOUNTED) 563 SvREFCNT_dec(mg->mg_obj); 564 Safefree(mg); 565 } 566 567 /* 568 =for apidoc mg_free 569 570 Free any magic storage used by the SV. See C<L</sv_magic>>. 571 572 =cut 573 */ 574 575 int 576 Perl_mg_free(pTHX_ SV *sv) 577 { 578 MAGIC* mg; 579 MAGIC* moremagic; 580 581 PERL_ARGS_ASSERT_MG_FREE; 582 583 for (mg = SvMAGIC(sv); mg; mg = moremagic) { 584 moremagic = mg->mg_moremagic; 585 mg_free_struct(sv, mg); 586 SvMAGIC_set(sv, moremagic); 587 } 588 SvMAGIC_set(sv, NULL); 589 SvMAGICAL_off(sv); 590 return 0; 591 } 592 593 /* 594 =for apidoc mg_free_type 595 596 Remove any magic of type C<how> from the SV C<sv>. See L</sv_magic>. 597 598 =cut 599 */ 600 601 void 602 Perl_mg_free_type(pTHX_ SV *sv, int how) 603 { 604 MAGIC *mg, *prevmg, *moremg; 605 PERL_ARGS_ASSERT_MG_FREE_TYPE; 606 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) { 607 moremg = mg->mg_moremagic; 608 if (mg->mg_type == how) { 609 MAGIC *newhead; 610 /* temporarily move to the head of the magic chain, in case 611 custom free code relies on this historical aspect of mg_free */ 612 if (prevmg) { 613 prevmg->mg_moremagic = moremg; 614 mg->mg_moremagic = SvMAGIC(sv); 615 SvMAGIC_set(sv, mg); 616 } 617 newhead = mg->mg_moremagic; 618 mg_free_struct(sv, mg); 619 SvMAGIC_set(sv, newhead); 620 mg = prevmg; 621 } 622 } 623 mg_magical(sv); 624 } 625 626 /* 627 =for apidoc mg_freeext 628 629 Remove any magic of type C<how> using virtual table C<vtbl> from the 630 SV C<sv>. See L</sv_magic>. 631 632 C<mg_freeext(sv, how, NULL)> is equivalent to C<mg_free_type(sv, how)>. 633 634 =cut 635 */ 636 637 void 638 Perl_mg_freeext(pTHX_ SV *sv, int how, const MGVTBL *vtbl) 639 { 640 MAGIC *mg, *prevmg, *moremg; 641 PERL_ARGS_ASSERT_MG_FREEEXT; 642 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) { 643 MAGIC *newhead; 644 moremg = mg->mg_moremagic; 645 if (mg->mg_type == how && (vtbl == NULL || mg->mg_virtual == vtbl)) { 646 /* temporarily move to the head of the magic chain, in case 647 custom free code relies on this historical aspect of mg_free */ 648 if (prevmg) { 649 prevmg->mg_moremagic = moremg; 650 mg->mg_moremagic = SvMAGIC(sv); 651 SvMAGIC_set(sv, mg); 652 } 653 newhead = mg->mg_moremagic; 654 mg_free_struct(sv, mg); 655 SvMAGIC_set(sv, newhead); 656 mg = prevmg; 657 } 658 } 659 mg_magical(sv); 660 } 661 662 #include <signal.h> 663 664 U32 665 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) 666 { 667 PERL_UNUSED_ARG(sv); 668 669 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT; 670 671 if (PL_curpm) { 672 REGEXP * const rx = PM_GETRE(PL_curpm); 673 if (rx) { 674 const SSize_t n = (SSize_t)mg->mg_obj; 675 if (n == '+') { /* @+ */ 676 /* return the number possible */ 677 return RX_NPARENS(rx); 678 } else { /* @- @^CAPTURE @{^CAPTURE} */ 679 I32 paren = RX_LASTPAREN(rx); 680 681 /* return the last filled */ 682 while ( paren >= 0 683 && (RX_OFFS(rx)[paren].start == -1 684 || RX_OFFS(rx)[paren].end == -1) ) 685 paren--; 686 if (n == '-') { 687 /* @- */ 688 return (U32)paren; 689 } else { 690 /* @^CAPTURE @{^CAPTURE} */ 691 return paren >= 0 ? (U32)(paren-1) : (U32)-1; 692 } 693 } 694 } 695 } 696 697 return (U32)-1; 698 } 699 700 /* @-, @+ */ 701 702 int 703 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) 704 { 705 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET; 706 707 if (PL_curpm) { 708 REGEXP * const rx = PM_GETRE(PL_curpm); 709 if (rx) { 710 const SSize_t n = (SSize_t)mg->mg_obj; 711 /* @{^CAPTURE} does not contain $&, so we need to increment by 1 */ 712 const I32 paren = mg->mg_len 713 + (n == '\003' ? 1 : 0); 714 SSize_t s; 715 SSize_t t; 716 if (paren < 0) 717 return 0; 718 if (paren <= (I32)RX_NPARENS(rx) && 719 (s = RX_OFFS(rx)[paren].start) != -1 && 720 (t = RX_OFFS(rx)[paren].end) != -1) 721 { 722 SSize_t i; 723 724 if (n == '+') /* @+ */ 725 i = t; 726 else if (n == '-') /* @- */ 727 i = s; 728 else { /* @^CAPTURE @{^CAPTURE} */ 729 CALLREG_NUMBUF_FETCH(rx,paren,sv); 730 return 0; 731 } 732 733 if (RX_MATCH_UTF8(rx)) { 734 const char * const b = RX_SUBBEG(rx); 735 if (b) 736 i = RX_SUBCOFFSET(rx) + 737 utf8_length((U8*)b, 738 (U8*)(b-RX_SUBOFFSET(rx)+i)); 739 } 740 741 sv_setuv(sv, i); 742 return 0; 743 } 744 } 745 } 746 sv_set_undef(sv); 747 return 0; 748 } 749 750 /* @-, @+ */ 751 752 int 753 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg) 754 { 755 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET; 756 PERL_UNUSED_CONTEXT; 757 PERL_UNUSED_ARG(sv); 758 PERL_UNUSED_ARG(mg); 759 Perl_croak_no_modify(); 760 NORETURN_FUNCTION_END; 761 } 762 763 #define SvRTRIM(sv) STMT_START { \ 764 if (SvPOK(sv)) { \ 765 STRLEN len = SvCUR(sv); \ 766 char * const p = SvPVX(sv); \ 767 while (len > 0 && isSPACE(p[len-1])) \ 768 --len; \ 769 SvCUR_set(sv, len); \ 770 p[len] = '\0'; \ 771 } \ 772 } STMT_END 773 774 void 775 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv) 776 { 777 PERL_ARGS_ASSERT_EMULATE_COP_IO; 778 779 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT))) 780 sv_set_undef(sv); 781 else { 782 SvPVCLEAR(sv); 783 SvUTF8_off(sv); 784 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) { 785 SV *const value = cop_hints_fetch_pvs(c, "open<", 0); 786 assert(value); 787 sv_catsv(sv, value); 788 } 789 sv_catpvs(sv, "\0"); 790 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) { 791 SV *const value = cop_hints_fetch_pvs(c, "open>", 0); 792 assert(value); 793 sv_catsv(sv, value); 794 } 795 } 796 } 797 798 STATIC void 799 S_fixup_errno_string(pTHX_ SV* sv) 800 { 801 /* Do what is necessary to fixup the non-empty string in 'sv' for return to 802 * Perl space. */ 803 804 PERL_ARGS_ASSERT_FIXUP_ERRNO_STRING; 805 806 assert(SvOK(sv)); 807 808 if(strEQ(SvPVX(sv), "")) { 809 sv_catpv(sv, UNKNOWN_ERRNO_MSG); 810 } 811 else { 812 813 /* In some locales the error string may come back as UTF-8, in which 814 * case we should turn on that flag. This didn't use to happen, and to 815 * avoid as many possible backward compatibility issues as possible, we 816 * don't turn on the flag unless we have to. So the flag stays off for 817 * an entirely invariant string. We assume that if the string looks 818 * like UTF-8 in a single script, it really is UTF-8: "text in any 819 * other encoding that uses bytes with the high bit set is extremely 820 * unlikely to pass a UTF-8 validity test" 821 * (http://en.wikipedia.org/wiki/Charset_detection). There is a 822 * potential that we will get it wrong however, especially on short 823 * error message text, so do an additional check. */ 824 if ( ! IN_BYTES /* respect 'use bytes' */ 825 && is_utf8_non_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv)) 826 827 #ifdef USE_LOCALE_MESSAGES 828 829 && _is_cur_LC_category_utf8(LC_MESSAGES) 830 831 #else /* If can't check directly, at least can see if script is consistent, 832 under UTF-8, which gives us an extra measure of confidence. */ 833 834 && isSCRIPT_RUN((const U8 *) SvPVX_const(sv), (U8 *) SvEND(sv), 835 TRUE) /* Means assume UTF-8 */ 836 #endif 837 838 ) { 839 SvUTF8_on(sv); 840 } 841 } 842 } 843 844 /* 845 =for apidoc_section $errno 846 =for apidoc sv_string_from_errnum 847 848 Generates the message string describing an OS error and returns it as 849 an SV. C<errnum> must be a value that C<errno> could take, identifying 850 the type of error. 851 852 If C<tgtsv> is non-null then the string will be written into that SV 853 (overwriting existing content) and it will be returned. If C<tgtsv> 854 is a null pointer then the string will be written into a new mortal SV 855 which will be returned. 856 857 The message will be taken from whatever locale would be used by C<$!>, 858 and will be encoded in the SV in whatever manner would be used by C<$!>. 859 The details of this process are subject to future change. Currently, 860 the message is taken from the C locale by default (usually producing an 861 English message), and from the currently selected locale when in the scope 862 of the C<use locale> pragma. A heuristic attempt is made to decode the 863 message from the locale's character encoding, but it will only be decoded 864 as either UTF-8 or ISO-8859-1. It is always correctly decoded in a UTF-8 865 locale, usually in an ISO-8859-1 locale, and never in any other locale. 866 867 The SV is always returned containing an actual string, and with no other 868 OK bits set. Unlike C<$!>, a message is even yielded for C<errnum> zero 869 (meaning success), and if no useful message is available then a useless 870 string (currently empty) is returned. 871 872 =cut 873 */ 874 875 SV * 876 Perl_sv_string_from_errnum(pTHX_ int errnum, SV *tgtsv) 877 { 878 char const *errstr; 879 if(!tgtsv) 880 tgtsv = newSV_type_mortal(SVt_PV); 881 errstr = my_strerror(errnum); 882 if(errstr) { 883 sv_setpv(tgtsv, errstr); 884 fixup_errno_string(tgtsv); 885 } else { 886 SvPVCLEAR(tgtsv); 887 } 888 return tgtsv; 889 } 890 891 #ifdef VMS 892 #include <descrip.h> 893 #include <starlet.h> 894 #endif 895 896 int 897 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) 898 { 899 I32 paren; 900 const char *s = NULL; 901 REGEXP *rx; 902 const char * const remaining = mg->mg_ptr + 1; 903 char nextchar; 904 905 PERL_ARGS_ASSERT_MAGIC_GET; 906 907 if (!mg->mg_ptr) { 908 paren = mg->mg_len; 909 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 910 do_numbuf_fetch: 911 CALLREG_NUMBUF_FETCH(rx,paren,sv); 912 } 913 else 914 goto set_undef; 915 return 0; 916 } 917 918 nextchar = *remaining; 919 switch (*mg->mg_ptr) { 920 case '\001': /* ^A */ 921 if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget); 922 else 923 sv_set_undef(sv); 924 if (SvTAINTED(PL_bodytarget)) 925 SvTAINTED_on(sv); 926 break; 927 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */ 928 if (nextchar == '\0') { 929 sv_setiv(sv, (IV)PL_minus_c); 930 } 931 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) { 932 sv_setiv(sv, (IV)STATUS_NATIVE); 933 } 934 break; 935 936 case '\004': /* ^D */ 937 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK)); 938 break; 939 case '\005': /* ^E */ 940 if (nextchar != '\0') { 941 if (strEQ(remaining, "NCODING")) 942 sv_set_undef(sv); 943 break; 944 } 945 946 #if defined(VMS) || defined(OS2) || defined(WIN32) 947 # if defined(VMS) 948 { 949 char msg[255]; 950 $DESCRIPTOR(msgdsc,msg); 951 sv_setnv(sv,(NV) vaxc$errno); 952 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1) 953 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length); 954 else 955 SvPVCLEAR(sv); 956 } 957 #elif defined(OS2) 958 if (!(_emx_env & 0x200)) { /* Under DOS */ 959 sv_setnv(sv, (NV)errno); 960 sv_setpv(sv, errno ? my_strerror(errno) : ""); 961 } else { 962 if (errno != errno_isOS2) { 963 const int tmp = _syserrno(); 964 if (tmp) /* 2nd call to _syserrno() makes it 0 */ 965 Perl_rc = tmp; 966 } 967 sv_setnv(sv, (NV)Perl_rc); 968 sv_setpv(sv, os2error(Perl_rc)); 969 } 970 if (SvOK(sv) && strNE(SvPVX(sv), "")) { 971 fixup_errno_string(sv); 972 } 973 # elif defined(WIN32) 974 { 975 const DWORD dwErr = GetLastError(); 976 sv_setnv(sv, (NV)dwErr); 977 if (dwErr) { 978 PerlProc_GetOSError(sv, dwErr); 979 fixup_errno_string(sv); 980 } 981 else 982 SvPVCLEAR(sv); 983 SetLastError(dwErr); 984 } 985 # else 986 # error Missing code for platform 987 # endif 988 SvRTRIM(sv); 989 SvNOK_on(sv); /* what a wonderful hack! */ 990 break; 991 #endif /* End of platforms with special handling for $^E; others just fall 992 through to $! */ 993 /* FALLTHROUGH */ 994 995 case '!': 996 { 997 dSAVE_ERRNO; 998 #ifdef VMS 999 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno)); 1000 #else 1001 sv_setnv(sv, (NV)errno); 1002 #endif 1003 #ifdef OS2 1004 if (errno == errno_isOS2 || errno == errno_isOS2_set) 1005 sv_setpv(sv, os2error(Perl_rc)); 1006 else 1007 #endif 1008 if (! errno) { 1009 SvPVCLEAR(sv); 1010 } 1011 else { 1012 sv_string_from_errnum(errno, sv); 1013 /* If no useful string is available, don't 1014 * claim to have a string part. The SvNOK_on() 1015 * below will cause just the number part to be valid */ 1016 if (!SvCUR(sv)) 1017 SvPOK_off(sv); 1018 } 1019 RESTORE_ERRNO; 1020 } 1021 1022 SvRTRIM(sv); 1023 SvNOK_on(sv); /* what a wonderful hack! */ 1024 break; 1025 1026 case '\006': /* ^F */ 1027 if (nextchar == '\0') { 1028 sv_setiv(sv, (IV)PL_maxsysfd); 1029 } 1030 break; 1031 case '\007': /* ^GLOBAL_PHASE */ 1032 if (strEQ(remaining, "LOBAL_PHASE")) { 1033 sv_setpvn(sv, PL_phase_names[PL_phase], 1034 strlen(PL_phase_names[PL_phase])); 1035 } 1036 break; 1037 case '\010': /* ^H */ 1038 sv_setuv(sv, PL_hints); 1039 break; 1040 case '\011': /* ^I */ /* NOT \t in EBCDIC */ 1041 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */ 1042 break; 1043 case '\014': /* ^LAST_FH */ 1044 if (strEQ(remaining, "AST_FH")) { 1045 if (PL_last_in_gv && (SV*)PL_last_in_gv != &PL_sv_undef) { 1046 assert(isGV_with_GP(PL_last_in_gv)); 1047 sv_setrv_inc(sv, MUTABLE_SV(PL_last_in_gv)); 1048 sv_rvweaken(sv); 1049 } 1050 else 1051 sv_set_undef(sv); 1052 } 1053 break; 1054 case '\017': /* ^O & ^OPEN */ 1055 if (nextchar == '\0') { 1056 sv_setpv(sv, PL_osname); 1057 SvTAINTED_off(sv); 1058 } 1059 else if (strEQ(remaining, "PEN")) { 1060 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv); 1061 } 1062 break; 1063 case '\020': 1064 sv_setiv(sv, (IV)PL_perldb); 1065 break; 1066 case '\023': /* ^S */ 1067 if (nextchar == '\0') { 1068 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING) 1069 SvOK_off(sv); 1070 else if (PL_in_eval) 1071 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE)); 1072 else 1073 sv_setiv(sv, 0); 1074 } 1075 else if (strEQ(remaining, "AFE_LOCALES")) { 1076 1077 #if ! defined(USE_ITHREADS) || defined(USE_THREAD_SAFE_LOCALE) 1078 1079 sv_setuv(sv, (UV) 1); 1080 1081 #else 1082 sv_setuv(sv, (UV) 0); 1083 1084 #endif 1085 1086 } 1087 break; 1088 case '\024': /* ^T */ 1089 if (nextchar == '\0') { 1090 #ifdef BIG_TIME 1091 sv_setnv(sv, PL_basetime); 1092 #else 1093 sv_setiv(sv, (IV)PL_basetime); 1094 #endif 1095 } 1096 else if (strEQ(remaining, "AINT")) 1097 sv_setiv(sv, TAINTING_get 1098 ? (TAINT_WARN_get || PL_unsafe ? -1 : 1) 1099 : 0); 1100 break; 1101 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */ 1102 if (strEQ(remaining, "NICODE")) 1103 sv_setuv(sv, (UV) PL_unicode); 1104 else if (strEQ(remaining, "TF8LOCALE")) 1105 sv_setuv(sv, (UV) PL_utf8locale); 1106 else if (strEQ(remaining, "TF8CACHE")) 1107 sv_setiv(sv, (IV) PL_utf8cache); 1108 break; 1109 case '\027': /* ^W & $^WARNING_BITS */ 1110 if (nextchar == '\0') 1111 sv_setiv(sv, (IV)cBOOL(PL_dowarn & G_WARN_ON)); 1112 else if (strEQ(remaining, "ARNING_BITS")) { 1113 if (PL_compiling.cop_warnings == pWARN_NONE) { 1114 sv_setpvn(sv, WARN_NONEstring, WARNsize) ; 1115 } 1116 else if (PL_compiling.cop_warnings == pWARN_STD) { 1117 goto set_undef; 1118 } 1119 else if (PL_compiling.cop_warnings == pWARN_ALL) { 1120 sv_setpvn(sv, WARN_ALLstring, WARNsize); 1121 } 1122 else { 1123 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1), 1124 *PL_compiling.cop_warnings); 1125 } 1126 } 1127 break; 1128 case '+': 1129 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 1130 paren = RX_LASTPAREN(rx); 1131 if (paren) 1132 goto do_numbuf_fetch; 1133 } 1134 goto set_undef; 1135 case '\016': /* ^N */ 1136 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 1137 paren = RX_LASTCLOSEPAREN(rx); 1138 if (paren) 1139 goto do_numbuf_fetch; 1140 } 1141 goto set_undef; 1142 case '.': 1143 if (GvIO(PL_last_in_gv)) { 1144 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv))); 1145 } 1146 break; 1147 case '?': 1148 { 1149 sv_setiv(sv, (IV)STATUS_CURRENT); 1150 #ifdef COMPLEX_STATUS 1151 SvUPGRADE(sv, SVt_PVLV); 1152 LvTARGOFF(sv) = PL_statusvalue; 1153 LvTARGLEN(sv) = PL_statusvalue_vms; 1154 #endif 1155 } 1156 break; 1157 case '^': 1158 if (GvIOp(PL_defoutgv)) 1159 s = IoTOP_NAME(GvIOp(PL_defoutgv)); 1160 if (s) 1161 sv_setpv(sv,s); 1162 else { 1163 sv_setpv(sv,GvENAME(PL_defoutgv)); 1164 sv_catpvs(sv,"_TOP"); 1165 } 1166 break; 1167 case '~': 1168 if (GvIOp(PL_defoutgv)) 1169 s = IoFMT_NAME(GvIOp(PL_defoutgv)); 1170 if (!s) 1171 s = GvENAME(PL_defoutgv); 1172 sv_setpv(sv,s); 1173 break; 1174 case '=': 1175 if (GvIO(PL_defoutgv)) 1176 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv))); 1177 break; 1178 case '-': 1179 if (GvIO(PL_defoutgv)) 1180 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv))); 1181 break; 1182 case '%': 1183 if (GvIO(PL_defoutgv)) 1184 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv))); 1185 break; 1186 case ':': 1187 case '/': 1188 break; 1189 case '[': 1190 sv_setiv(sv, 0); 1191 break; 1192 case '|': 1193 if (GvIO(PL_defoutgv)) 1194 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 ); 1195 break; 1196 case '\\': 1197 if (PL_ors_sv) 1198 sv_copypv(sv, PL_ors_sv); 1199 else 1200 goto set_undef; 1201 break; 1202 case '$': /* $$ */ 1203 { 1204 IV const pid = (IV)PerlProc_getpid(); 1205 if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) { 1206 /* never set manually, or at least not since last fork */ 1207 sv_setiv(sv, pid); 1208 /* never unsafe, even if reading in a tainted expression */ 1209 SvTAINTED_off(sv); 1210 } 1211 /* else a value has been assigned manually, so do nothing */ 1212 } 1213 break; 1214 case '<': 1215 sv_setuid(sv, PerlProc_getuid()); 1216 break; 1217 case '>': 1218 sv_setuid(sv, PerlProc_geteuid()); 1219 break; 1220 case '(': 1221 sv_setgid(sv, PerlProc_getgid()); 1222 goto add_groups; 1223 case ')': 1224 sv_setgid(sv, PerlProc_getegid()); 1225 add_groups: 1226 #ifdef HAS_GETGROUPS 1227 { 1228 Groups_t *gary = NULL; 1229 I32 num_groups = getgroups(0, gary); 1230 if (num_groups > 0) { 1231 I32 i; 1232 Newx(gary, num_groups, Groups_t); 1233 num_groups = getgroups(num_groups, gary); 1234 for (i = 0; i < num_groups; i++) 1235 Perl_sv_catpvf(aTHX_ sv, " %" IVdf, (IV)gary[i]); 1236 Safefree(gary); 1237 } 1238 } 1239 1240 /* 1241 Set this to avoid warnings when the SV is used as a number. 1242 Avoid setting the public IOK flag so that serializers will 1243 use the PV. 1244 */ 1245 (void)SvIOKp_on(sv); /* what a wonderful hack! */ 1246 #endif 1247 break; 1248 case '0': 1249 break; 1250 } 1251 return 0; 1252 1253 set_undef: 1254 sv_set_undef(sv); 1255 return 0; 1256 } 1257 1258 int 1259 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg) 1260 { 1261 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr; 1262 1263 PERL_ARGS_ASSERT_MAGIC_GETUVAR; 1264 1265 if (uf && uf->uf_val) 1266 (*uf->uf_val)(aTHX_ uf->uf_index, sv); 1267 return 0; 1268 } 1269 1270 int 1271 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) 1272 { 1273 STRLEN len = 0, klen; 1274 1275 const char *key; 1276 const char *s = ""; 1277 1278 SV *keysv = MgSV(mg); 1279 1280 if (keysv == NULL) { 1281 key = mg->mg_ptr; 1282 klen = mg->mg_len; 1283 } 1284 else { 1285 if (!sv_utf8_downgrade(keysv, /* fail_ok */ TRUE)) { 1286 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv key (encoding to utf8)"); 1287 } 1288 1289 key = SvPV_const(keysv,klen); 1290 } 1291 1292 PERL_ARGS_ASSERT_MAGIC_SETENV; 1293 1294 SvGETMAGIC(sv); 1295 if (SvOK(sv)) { 1296 /* defined environment variables are byte strings; unfortunately 1297 there is no SvPVbyte_force_nomg(), so we must do this piecewise */ 1298 (void)SvPV_force_nomg_nolen(sv); 1299 sv_utf8_downgrade(sv, /* fail_ok */ TRUE); 1300 if (SvUTF8(sv)) { 1301 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv"); 1302 SvUTF8_off(sv); 1303 } 1304 s = SvPVX(sv); 1305 len = SvCUR(sv); 1306 } 1307 my_setenv(key, s); /* does the deed */ 1308 1309 #ifdef DYNAMIC_ENV_FETCH 1310 /* We just undefd an environment var. Is a replacement */ 1311 /* waiting in the wings? */ 1312 if (!len) { 1313 SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE); 1314 if (valp) 1315 s = SvOK(*valp) ? SvPV_const(*valp, len) : ""; 1316 } 1317 #endif 1318 1319 #if !defined(OS2) && !defined(WIN32) 1320 /* And you'll never guess what the dog had */ 1321 /* in its mouth... */ 1322 if (TAINTING_get) { 1323 MgTAINTEDDIR_off(mg); 1324 #ifdef VMS 1325 if (s && memEQs(key, klen, "DCL$PATH")) { 1326 char pathbuf[256], eltbuf[256], *cp, *elt; 1327 int i = 0, j = 0; 1328 1329 my_strlcpy(eltbuf, s, sizeof(eltbuf)); 1330 elt = eltbuf; 1331 do { /* DCL$PATH may be a search list */ 1332 while (1) { /* as may dev portion of any element */ 1333 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) { 1334 if ( *(cp+1) == '.' || *(cp+1) == '-' || 1335 cando_by_name(S_IWUSR,0,elt) ) { 1336 MgTAINTEDDIR_on(mg); 1337 return 0; 1338 } 1339 } 1340 if ((cp = strchr(elt, ':')) != NULL) 1341 *cp = '\0'; 1342 if (my_trnlnm(elt, eltbuf, j++)) 1343 elt = eltbuf; 1344 else 1345 break; 1346 } 1347 j = 0; 1348 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf)); 1349 } 1350 #endif /* VMS */ 1351 if (s && memEQs(key, klen, "PATH")) { 1352 const char * const strend = s + len; 1353 #ifdef __VMS /* Hmm. How do we get $Config{path_sep} from C? */ 1354 const char path_sep = PL_perllib_sep; 1355 #else 1356 const char path_sep = ':'; 1357 #endif 1358 1359 /* set MGf_TAINTEDDIR if any component of the new path is 1360 * relative or world-writeable */ 1361 while (s < strend) { 1362 char tmpbuf[256]; 1363 Stat_t st; 1364 I32 i; 1365 s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, 1366 s, strend, path_sep, &i); 1367 s++; 1368 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */ 1369 #ifdef __VMS 1370 /* no colon thus no device name -- assume relative path */ 1371 || (PL_perllib_sep != ':' && !strchr(tmpbuf, ':')) 1372 /* Using Unix separator, e.g. under bash, so act line Unix */ 1373 || (PL_perllib_sep == ':' && *tmpbuf != '/') 1374 #else 1375 || *tmpbuf != '/' /* no starting slash -- assume relative path */ 1376 #endif 1377 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) { 1378 MgTAINTEDDIR_on(mg); 1379 return 0; 1380 } 1381 } 1382 } 1383 } 1384 #endif /* neither OS2 nor WIN32 */ 1385 1386 return 0; 1387 } 1388 1389 int 1390 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg) 1391 { 1392 PERL_ARGS_ASSERT_MAGIC_CLEARENV; 1393 PERL_UNUSED_ARG(sv); 1394 my_setenv(MgPV_nolen_const(mg),NULL); 1395 return 0; 1396 } 1397 1398 int 1399 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) 1400 { 1401 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV; 1402 PERL_UNUSED_ARG(mg); 1403 #if defined(VMS) 1404 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); 1405 #else 1406 if (PL_localizing) { 1407 HE* entry; 1408 my_clearenv(); 1409 hv_iterinit(MUTABLE_HV(sv)); 1410 while ((entry = hv_iternext(MUTABLE_HV(sv)))) { 1411 I32 keylen; 1412 my_setenv(hv_iterkey(entry, &keylen), 1413 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry))); 1414 } 1415 } 1416 #endif 1417 return 0; 1418 } 1419 1420 int 1421 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) 1422 { 1423 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV; 1424 PERL_UNUSED_ARG(sv); 1425 PERL_UNUSED_ARG(mg); 1426 #if defined(VMS) 1427 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); 1428 #else 1429 my_clearenv(); 1430 #endif 1431 return 0; 1432 } 1433 1434 #ifndef PERL_MICRO 1435 #ifdef HAS_SIGPROCMASK 1436 static void 1437 restore_sigmask(pTHX_ SV *save_sv) 1438 { 1439 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv ); 1440 (void)sigprocmask(SIG_SETMASK, ossetp, NULL); 1441 } 1442 #endif 1443 int 1444 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) 1445 { 1446 /* Are we fetching a signal entry? */ 1447 int i = (I16)mg->mg_private; 1448 1449 PERL_ARGS_ASSERT_MAGIC_GETSIG; 1450 1451 if (!i) { 1452 STRLEN siglen; 1453 const char * sig = MgPV_const(mg, siglen); 1454 mg->mg_private = i = whichsig_pvn(sig, siglen); 1455 } 1456 1457 if (i > 0) { 1458 if(PL_psig_ptr[i]) 1459 sv_setsv(sv,PL_psig_ptr[i]); 1460 else { 1461 Sighandler_t sigstate = rsignal_state(i); 1462 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS 1463 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) 1464 sigstate = SIG_IGN; 1465 #endif 1466 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS 1467 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) 1468 sigstate = SIG_DFL; 1469 #endif 1470 /* cache state so we don't fetch it again */ 1471 if(sigstate == (Sighandler_t) SIG_IGN) 1472 sv_setpvs(sv,"IGNORE"); 1473 else 1474 sv_set_undef(sv); 1475 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv); 1476 SvTEMP_off(sv); 1477 } 1478 } 1479 return 0; 1480 } 1481 int 1482 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg) 1483 { 1484 PERL_ARGS_ASSERT_MAGIC_CLEARSIG; 1485 1486 magic_setsig(NULL, mg); 1487 return sv_unmagic(sv, mg->mg_type); 1488 } 1489 1490 1491 #ifdef PERL_USE_3ARG_SIGHANDLER 1492 Signal_t 1493 Perl_csighandler(int sig, Siginfo_t *sip, void *uap) 1494 { 1495 Perl_csighandler3(sig, sip, uap); 1496 } 1497 #else 1498 Signal_t 1499 Perl_csighandler(int sig) 1500 { 1501 Perl_csighandler3(sig, NULL, NULL); 1502 } 1503 #endif 1504 1505 Signal_t 1506 Perl_csighandler1(int sig) 1507 { 1508 Perl_csighandler3(sig, NULL, NULL); 1509 } 1510 1511 /* Handler intended to directly handle signal calls from the kernel. 1512 * (Depending on configuration, the kernel may actually call one of the 1513 * wrappers csighandler() or csighandler1() instead.) 1514 * It either queues up the signal or dispatches it immediately depending 1515 * on whether safe signals are enabled and whether the signal is capable 1516 * of being deferred (e.g. SEGV isn't). 1517 */ 1518 1519 Signal_t 1520 Perl_csighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL) 1521 { 1522 #ifdef PERL_GET_SIG_CONTEXT 1523 dTHXa(PERL_GET_SIG_CONTEXT); 1524 #else 1525 dTHX; 1526 #endif 1527 1528 #ifdef PERL_USE_3ARG_SIGHANDLER 1529 #if defined(__cplusplus) && defined(__GNUC__) 1530 /* g++ doesn't support PERL_UNUSED_DECL, so the sip and uap 1531 * parameters would be warned about. */ 1532 PERL_UNUSED_ARG(sip); 1533 PERL_UNUSED_ARG(uap); 1534 #endif 1535 #endif 1536 1537 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS 1538 (void) rsignal(sig, PL_csighandlerp); 1539 if (PL_sig_ignoring[sig]) return; 1540 #endif 1541 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS 1542 if (PL_sig_defaulting[sig]) 1543 #ifdef KILL_BY_SIGPRC 1544 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG); 1545 #else 1546 exit(1); 1547 #endif 1548 #endif 1549 if ( 1550 #ifdef SIGILL 1551 sig == SIGILL || 1552 #endif 1553 #ifdef SIGBUS 1554 sig == SIGBUS || 1555 #endif 1556 #ifdef SIGSEGV 1557 sig == SIGSEGV || 1558 #endif 1559 #ifdef SIGFPE 1560 sig == SIGFPE || 1561 #endif 1562 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)) 1563 /* Call the perl level handler now-- 1564 * with risk we may be in malloc() or being destructed etc. */ 1565 { 1566 if (PL_sighandlerp == Perl_sighandler) 1567 /* default handler, so can call perly_sighandler() directly 1568 * rather than via Perl_sighandler, passing the extra 1569 * 'safe = false' arg 1570 */ 1571 Perl_perly_sighandler(sig, NULL, NULL, 0 /* unsafe */); 1572 else 1573 #ifdef PERL_USE_3ARG_SIGHANDLER 1574 (*PL_sighandlerp)(sig, NULL, NULL); 1575 #else 1576 (*PL_sighandlerp)(sig); 1577 #endif 1578 } 1579 else { 1580 if (!PL_psig_pend) return; 1581 /* Set a flag to say this signal is pending, that is awaiting delivery after 1582 * the current Perl opcode completes */ 1583 PL_psig_pend[sig]++; 1584 1585 #ifndef SIG_PENDING_DIE_COUNT 1586 # define SIG_PENDING_DIE_COUNT 120 1587 #endif 1588 /* Add one to say _a_ signal is pending */ 1589 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT) 1590 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded", 1591 (unsigned long)SIG_PENDING_DIE_COUNT); 1592 } 1593 } 1594 1595 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) 1596 void 1597 Perl_csighandler_init(void) 1598 { 1599 int sig; 1600 if (PL_sig_handlers_initted) return; 1601 1602 for (sig = 1; sig < SIG_SIZE; sig++) { 1603 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS 1604 dTHX; 1605 PL_sig_defaulting[sig] = 1; 1606 (void) rsignal(sig, PL_csighandlerp); 1607 #endif 1608 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS 1609 PL_sig_ignoring[sig] = 0; 1610 #endif 1611 } 1612 PL_sig_handlers_initted = 1; 1613 } 1614 #endif 1615 1616 #if defined HAS_SIGPROCMASK 1617 static void 1618 unblock_sigmask(pTHX_ void* newset) 1619 { 1620 PERL_UNUSED_CONTEXT; 1621 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL); 1622 } 1623 #endif 1624 1625 void 1626 Perl_despatch_signals(pTHX) 1627 { 1628 int sig; 1629 PL_sig_pending = 0; 1630 for (sig = 1; sig < SIG_SIZE; sig++) { 1631 if (PL_psig_pend[sig]) { 1632 dSAVE_ERRNO; 1633 #ifdef HAS_SIGPROCMASK 1634 /* From sigaction(2) (FreeBSD man page): 1635 * | Signal routines normally execute with the signal that 1636 * | caused their invocation blocked, but other signals may 1637 * | yet occur. 1638 * Emulation of this behavior (from within Perl) is enabled 1639 * using sigprocmask 1640 */ 1641 int was_blocked; 1642 sigset_t newset, oldset; 1643 1644 sigemptyset(&newset); 1645 sigaddset(&newset, sig); 1646 sigprocmask(SIG_BLOCK, &newset, &oldset); 1647 was_blocked = sigismember(&oldset, sig); 1648 if (!was_blocked) { 1649 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t)); 1650 ENTER; 1651 SAVEFREESV(save_sv); 1652 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv)); 1653 } 1654 #endif 1655 PL_psig_pend[sig] = 0; 1656 if (PL_sighandlerp == Perl_sighandler) 1657 /* default handler, so can call perly_sighandler() directly 1658 * rather than via Perl_sighandler, passing the extra 1659 * 'safe = true' arg 1660 */ 1661 Perl_perly_sighandler(sig, NULL, NULL, 1 /* safe */); 1662 else 1663 #ifdef PERL_USE_3ARG_SIGHANDLER 1664 (*PL_sighandlerp)(sig, NULL, NULL); 1665 #else 1666 (*PL_sighandlerp)(sig); 1667 #endif 1668 1669 #ifdef HAS_SIGPROCMASK 1670 if (!was_blocked) 1671 LEAVE; 1672 #endif 1673 RESTORE_ERRNO; 1674 } 1675 } 1676 } 1677 1678 /* sv of NULL signifies that we're acting as magic_clearsig. */ 1679 int 1680 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) 1681 { 1682 I32 i; 1683 SV** svp = NULL; 1684 /* Need to be careful with SvREFCNT_dec(), because that can have side 1685 * effects (due to closures). We must make sure that the new disposition 1686 * is in place before it is called. 1687 */ 1688 SV* to_dec = NULL; 1689 STRLEN len; 1690 #ifdef HAS_SIGPROCMASK 1691 sigset_t set, save; 1692 SV* save_sv; 1693 #endif 1694 const char *s = MgPV_const(mg,len); 1695 1696 PERL_ARGS_ASSERT_MAGIC_SETSIG; 1697 1698 if (*s == '_') { 1699 if (memEQs(s, len, "__DIE__")) 1700 svp = &PL_diehook; 1701 else if (memEQs(s, len, "__WARN__") 1702 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) { 1703 /* Merge the existing behaviours, which are as follows: 1704 magic_setsig, we always set svp to &PL_warnhook 1705 (hence we always change the warnings handler) 1706 For magic_clearsig, we don't change the warnings handler if it's 1707 set to the &PL_warnhook. */ 1708 svp = &PL_warnhook; 1709 } else if (sv) { 1710 SV *tmp = sv_newmortal(); 1711 Perl_croak(aTHX_ "No such hook: %s", 1712 pv_pretty(tmp, s, len, 0, NULL, NULL, 0)); 1713 } 1714 i = 0; 1715 if (svp && *svp) { 1716 if (*svp != PERL_WARNHOOK_FATAL) 1717 to_dec = *svp; 1718 *svp = NULL; 1719 } 1720 } 1721 else { 1722 i = (I16)mg->mg_private; 1723 if (!i) { 1724 i = whichsig_pvn(s, len); /* ...no, a brick */ 1725 mg->mg_private = (U16)i; 1726 } 1727 if (i <= 0) { 1728 if (sv) { 1729 SV *tmp = sv_newmortal(); 1730 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", 1731 pv_pretty(tmp, s, len, 0, NULL, NULL, 0)); 1732 } 1733 return 0; 1734 } 1735 #ifdef HAS_SIGPROCMASK 1736 /* Avoid having the signal arrive at a bad time, if possible. */ 1737 sigemptyset(&set); 1738 sigaddset(&set,i); 1739 sigprocmask(SIG_BLOCK, &set, &save); 1740 ENTER; 1741 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t)); 1742 SAVEFREESV(save_sv); 1743 SAVEDESTRUCTOR_X(restore_sigmask, save_sv); 1744 #endif 1745 PERL_ASYNC_CHECK(); 1746 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) 1747 if (!PL_sig_handlers_initted) Perl_csighandler_init(); 1748 #endif 1749 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS 1750 PL_sig_ignoring[i] = 0; 1751 #endif 1752 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS 1753 PL_sig_defaulting[i] = 0; 1754 #endif 1755 to_dec = PL_psig_ptr[i]; 1756 if (sv) { 1757 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv); 1758 SvTEMP_off(sv); /* Make sure it doesn't go away on us */ 1759 1760 /* Signals don't change name during the program's execution, so once 1761 they're cached in the appropriate slot of PL_psig_name, they can 1762 stay there. 1763 1764 Ideally we'd find some way of making SVs at (C) compile time, or 1765 at least, doing most of the work. */ 1766 if (!PL_psig_name[i]) { 1767 const char* name = PL_sig_name[i]; 1768 PL_psig_name[i] = newSVpvn(name, strlen(name)); 1769 SvREADONLY_on(PL_psig_name[i]); 1770 } 1771 } else { 1772 SvREFCNT_dec(PL_psig_name[i]); 1773 PL_psig_name[i] = NULL; 1774 PL_psig_ptr[i] = NULL; 1775 } 1776 } 1777 if (sv && (isGV_with_GP(sv) || SvROK(sv))) { 1778 if (i) { 1779 (void)rsignal(i, PL_csighandlerp); 1780 } 1781 else 1782 *svp = SvREFCNT_inc_simple_NN(sv); 1783 } else { 1784 if (sv && SvOK(sv)) { 1785 s = SvPV_force(sv, len); 1786 } else { 1787 sv = NULL; 1788 } 1789 if (sv && memEQs(s, len,"IGNORE")) { 1790 if (i) { 1791 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS 1792 PL_sig_ignoring[i] = 1; 1793 (void)rsignal(i, PL_csighandlerp); 1794 #else 1795 (void)rsignal(i, (Sighandler_t) SIG_IGN); 1796 #endif 1797 } 1798 } 1799 else if (!sv || memEQs(s, len,"DEFAULT") || !len) { 1800 if (i) { 1801 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS 1802 PL_sig_defaulting[i] = 1; 1803 (void)rsignal(i, PL_csighandlerp); 1804 #else 1805 (void)rsignal(i, (Sighandler_t) SIG_DFL); 1806 #endif 1807 } 1808 } 1809 else { 1810 /* 1811 * We should warn if HINT_STRICT_REFS, but without 1812 * access to a known hint bit in a known OP, we can't 1813 * tell whether HINT_STRICT_REFS is in force or not. 1814 */ 1815 if (!memchr(s, ':', len) && !memchr(s, '\'', len)) 1816 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"), 1817 SV_GMAGIC); 1818 if (i) 1819 (void)rsignal(i, PL_csighandlerp); 1820 else 1821 *svp = SvREFCNT_inc_simple_NN(sv); 1822 } 1823 } 1824 1825 #ifdef HAS_SIGPROCMASK 1826 if(i) 1827 LEAVE; 1828 #endif 1829 SvREFCNT_dec(to_dec); 1830 return 0; 1831 } 1832 #endif /* !PERL_MICRO */ 1833 1834 int 1835 Perl_magic_setsigall(pTHX_ SV* sv, MAGIC* mg) 1836 { 1837 PERL_ARGS_ASSERT_MAGIC_SETSIGALL; 1838 PERL_UNUSED_ARG(mg); 1839 1840 if (PL_localizing == 2) { 1841 HV* hv = (HV*)sv; 1842 HE* current; 1843 hv_iterinit(hv); 1844 while ((current = hv_iternext(hv))) { 1845 SV* sigelem = hv_iterval(hv, current); 1846 mg_set(sigelem); 1847 } 1848 } 1849 return 0; 1850 } 1851 1852 int 1853 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg) 1854 { 1855 PERL_ARGS_ASSERT_MAGIC_SETISA; 1856 PERL_UNUSED_ARG(sv); 1857 1858 /* Skip _isaelem because _isa will handle it shortly */ 1859 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem) 1860 return 0; 1861 1862 return magic_clearisa(NULL, mg); 1863 } 1864 1865 /* sv of NULL signifies that we're acting as magic_setisa. */ 1866 int 1867 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg) 1868 { 1869 HV* stash; 1870 PERL_ARGS_ASSERT_MAGIC_CLEARISA; 1871 1872 /* Bail out if destruction is going on */ 1873 if(PL_phase == PERL_PHASE_DESTRUCT) return 0; 1874 1875 if (sv) 1876 av_clear(MUTABLE_AV(sv)); 1877 1878 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj)) 1879 /* This occurs with setisa_elem magic, which calls this 1880 same function. */ 1881 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa); 1882 1883 assert(mg); 1884 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */ 1885 SV **svp = AvARRAY((AV *)mg->mg_obj); 1886 I32 items = AvFILLp((AV *)mg->mg_obj) + 1; 1887 while (items--) { 1888 stash = GvSTASH((GV *)*svp++); 1889 if (stash && HvENAME(stash)) mro_isa_changed_in(stash); 1890 } 1891 1892 return 0; 1893 } 1894 1895 stash = GvSTASH( 1896 (const GV *)mg->mg_obj 1897 ); 1898 1899 /* The stash may have been detached from the symbol table, so check its 1900 name before doing anything. */ 1901 if (stash && HvENAME_get(stash)) 1902 mro_isa_changed_in(stash); 1903 1904 return 0; 1905 } 1906 1907 int 1908 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg) 1909 { 1910 HV * const hv = MUTABLE_HV(LvTARG(sv)); 1911 I32 i = 0; 1912 1913 PERL_ARGS_ASSERT_MAGIC_GETNKEYS; 1914 PERL_UNUSED_ARG(mg); 1915 1916 if (hv) { 1917 (void) hv_iterinit(hv); 1918 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) 1919 i = HvUSEDKEYS(hv); 1920 else { 1921 while (hv_iternext(hv)) 1922 i++; 1923 } 1924 } 1925 1926 sv_setiv(sv, (IV)i); 1927 return 0; 1928 } 1929 1930 int 1931 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg) 1932 { 1933 PERL_ARGS_ASSERT_MAGIC_SETNKEYS; 1934 PERL_UNUSED_ARG(mg); 1935 if (LvTARG(sv)) { 1936 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv)); 1937 } 1938 return 0; 1939 } 1940 1941 /* 1942 =for apidoc_section $magic 1943 =for apidoc magic_methcall 1944 1945 Invoke a magic method (like FETCH). 1946 1947 C<sv> and C<mg> are the tied thingy and the tie magic. 1948 1949 C<meth> is the name of the method to call. 1950 1951 C<argc> is the number of args (in addition to $self) to pass to the method. 1952 1953 The C<flags> can be: 1954 1955 G_DISCARD invoke method with G_DISCARD flag and don't 1956 return a value 1957 G_UNDEF_FILL fill the stack with argc pointers to 1958 PL_sv_undef 1959 1960 The arguments themselves are any values following the C<flags> argument. 1961 1962 Returns the SV (if any) returned by the method, or C<NULL> on failure. 1963 1964 1965 =cut 1966 */ 1967 1968 SV* 1969 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, 1970 U32 argc, ...) 1971 { 1972 dSP; 1973 SV* ret = NULL; 1974 1975 PERL_ARGS_ASSERT_MAGIC_METHCALL; 1976 1977 ENTER; 1978 1979 if (flags & G_WRITING_TO_STDERR) { 1980 SAVETMPS; 1981 1982 save_re_context(); 1983 SAVESPTR(PL_stderrgv); 1984 PL_stderrgv = NULL; 1985 } 1986 1987 PUSHSTACKi(PERLSI_MAGIC); 1988 PUSHMARK(SP); 1989 1990 /* EXTEND() expects a signed argc; don't wrap when casting */ 1991 assert(argc <= I32_MAX); 1992 EXTEND(SP, (I32)argc+1); 1993 PUSHs(SvTIED_obj(sv, mg)); 1994 if (flags & G_UNDEF_FILL) { 1995 while (argc--) { 1996 PUSHs(&PL_sv_undef); 1997 } 1998 } else if (argc > 0) { 1999 va_list args; 2000 va_start(args, argc); 2001 2002 do { 2003 SV *const this_sv = va_arg(args, SV *); 2004 PUSHs(this_sv); 2005 } while (--argc); 2006 2007 va_end(args); 2008 } 2009 PUTBACK; 2010 if (flags & G_DISCARD) { 2011 call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED); 2012 } 2013 else { 2014 if (call_sv(meth, G_SCALAR|G_METHOD_NAMED)) 2015 ret = *PL_stack_sp--; 2016 } 2017 POPSTACK; 2018 if (flags & G_WRITING_TO_STDERR) 2019 FREETMPS; 2020 LEAVE; 2021 return ret; 2022 } 2023 2024 /* wrapper for magic_methcall that creates the first arg */ 2025 2026 STATIC SV* 2027 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, 2028 int n, SV *val) 2029 { 2030 SV* arg1 = NULL; 2031 2032 PERL_ARGS_ASSERT_MAGIC_METHCALL1; 2033 2034 if (mg->mg_ptr) { 2035 if (mg->mg_len >= 0) { 2036 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP); 2037 } 2038 else if (mg->mg_len == HEf_SVKEY) 2039 arg1 = MUTABLE_SV(mg->mg_ptr); 2040 } 2041 else if (mg->mg_type == PERL_MAGIC_tiedelem) { 2042 arg1 = newSViv((IV)(mg->mg_len)); 2043 sv_2mortal(arg1); 2044 } 2045 if (!arg1) { 2046 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val); 2047 } 2048 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val); 2049 } 2050 2051 STATIC int 2052 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth) 2053 { 2054 SV* ret; 2055 2056 PERL_ARGS_ASSERT_MAGIC_METHPACK; 2057 2058 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL); 2059 if (ret) 2060 sv_setsv(sv, ret); 2061 return 0; 2062 } 2063 2064 int 2065 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg) 2066 { 2067 PERL_ARGS_ASSERT_MAGIC_GETPACK; 2068 2069 if (mg->mg_type == PERL_MAGIC_tiedelem) 2070 mg->mg_flags |= MGf_GSKIP; 2071 magic_methpack(sv,mg,SV_CONST(FETCH)); 2072 return 0; 2073 } 2074 2075 int 2076 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg) 2077 { 2078 MAGIC *tmg; 2079 SV *val; 2080 2081 PERL_ARGS_ASSERT_MAGIC_SETPACK; 2082 2083 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to 2084 * STORE() is not $val, but rather a PVLV (the sv in this call), whose 2085 * public flags indicate its value based on copying from $val. Doing 2086 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us. 2087 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes 2088 * wrong if $val happened to be tainted, as sv hasn't got magic 2089 * enabled, even though taint magic is in the chain. In which case, 2090 * fake up a temporary tainted value (this is easier than temporarily 2091 * re-enabling magic on sv). */ 2092 2093 if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint)) 2094 && (tmg->mg_len & 1)) 2095 { 2096 val = sv_mortalcopy(sv); 2097 SvTAINTED_on(val); 2098 } 2099 else 2100 val = sv; 2101 2102 magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val); 2103 return 0; 2104 } 2105 2106 int 2107 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg) 2108 { 2109 PERL_ARGS_ASSERT_MAGIC_CLEARPACK; 2110 2111 if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0; 2112 return magic_methpack(sv,mg,SV_CONST(DELETE)); 2113 } 2114 2115 2116 U32 2117 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg) 2118 { 2119 I32 retval = 0; 2120 SV* retsv; 2121 2122 PERL_ARGS_ASSERT_MAGIC_SIZEPACK; 2123 2124 retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL); 2125 if (retsv) { 2126 retval = SvIV(retsv)-1; 2127 if (retval < -1) 2128 Perl_croak(aTHX_ "FETCHSIZE returned a negative value"); 2129 } 2130 return (U32) retval; 2131 } 2132 2133 int 2134 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg) 2135 { 2136 PERL_ARGS_ASSERT_MAGIC_WIPEPACK; 2137 2138 Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0); 2139 return 0; 2140 } 2141 2142 int 2143 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key) 2144 { 2145 SV* ret; 2146 2147 PERL_ARGS_ASSERT_MAGIC_NEXTPACK; 2148 2149 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key) 2150 : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0); 2151 if (ret) 2152 sv_setsv(key,ret); 2153 return 0; 2154 } 2155 2156 int 2157 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg) 2158 { 2159 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK; 2160 2161 return magic_methpack(sv,mg,SV_CONST(EXISTS)); 2162 } 2163 2164 SV * 2165 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) 2166 { 2167 SV *retval; 2168 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg); 2169 HV * const pkg = SvSTASH((const SV *)SvRV(tied)); 2170 2171 PERL_ARGS_ASSERT_MAGIC_SCALARPACK; 2172 2173 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) { 2174 SV *key; 2175 if (HvEITER_get(hv)) 2176 /* we are in an iteration so the hash cannot be empty */ 2177 return &PL_sv_yes; 2178 /* no xhv_eiter so now use FIRSTKEY */ 2179 key = sv_newmortal(); 2180 magic_nextpack(MUTABLE_SV(hv), mg, key); 2181 HvEITER_set(hv, NULL); /* need to reset iterator */ 2182 return SvOK(key) ? &PL_sv_yes : &PL_sv_no; 2183 } 2184 2185 /* there is a SCALAR method that we can call */ 2186 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0); 2187 if (!retval) 2188 retval = &PL_sv_undef; 2189 return retval; 2190 } 2191 2192 int 2193 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) 2194 { 2195 SV **svp; 2196 2197 PERL_ARGS_ASSERT_MAGIC_SETDBLINE; 2198 2199 /* The magic ptr/len for the debugger's hash should always be an SV. */ 2200 if (UNLIKELY(mg->mg_len != HEf_SVKEY)) { 2201 Perl_croak(aTHX_ "panic: magic_setdbline len=%" IVdf ", ptr='%s'", 2202 (IV)mg->mg_len, mg->mg_ptr); 2203 } 2204 2205 /* Use sv_2iv instead of SvIV() as the former generates smaller code, and 2206 setting/clearing debugger breakpoints is not a hot path. */ 2207 svp = av_fetch(MUTABLE_AV(mg->mg_obj), 2208 sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE); 2209 2210 if (svp && SvIOKp(*svp)) { 2211 OP * const o = INT2PTR(OP*,SvIVX(*svp)); 2212 if (o) { 2213 #ifdef PERL_DEBUG_READONLY_OPS 2214 Slab_to_rw(OpSLAB(o)); 2215 #endif 2216 /* set or clear breakpoint in the relevant control op */ 2217 if (SvTRUE(sv)) 2218 o->op_flags |= OPf_SPECIAL; 2219 else 2220 o->op_flags &= ~OPf_SPECIAL; 2221 #ifdef PERL_DEBUG_READONLY_OPS 2222 Slab_to_ro(OpSLAB(o)); 2223 #endif 2224 } 2225 } 2226 return 0; 2227 } 2228 2229 int 2230 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg) 2231 { 2232 AV * const obj = MUTABLE_AV(mg->mg_obj); 2233 2234 PERL_ARGS_ASSERT_MAGIC_GETARYLEN; 2235 2236 if (obj) { 2237 sv_setiv(sv, AvFILL(obj)); 2238 } else { 2239 sv_set_undef(sv); 2240 } 2241 return 0; 2242 } 2243 2244 int 2245 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg) 2246 { 2247 AV * const obj = MUTABLE_AV(mg->mg_obj); 2248 2249 PERL_ARGS_ASSERT_MAGIC_SETARYLEN; 2250 2251 if (obj) { 2252 av_fill(obj, SvIV(sv)); 2253 } else { 2254 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 2255 "Attempt to set length of freed array"); 2256 } 2257 return 0; 2258 } 2259 2260 int 2261 Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg) 2262 { 2263 PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P; 2264 PERL_UNUSED_ARG(sv); 2265 PERL_UNUSED_CONTEXT; 2266 2267 /* Reset the iterator when the array is cleared */ 2268 if (sizeof(IV) == sizeof(SSize_t)) { 2269 *((IV *) &(mg->mg_len)) = 0; 2270 } else { 2271 if (mg->mg_ptr) 2272 *((IV *) mg->mg_ptr) = 0; 2273 } 2274 2275 return 0; 2276 } 2277 2278 int 2279 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg) 2280 { 2281 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P; 2282 PERL_UNUSED_ARG(sv); 2283 2284 /* during global destruction, mg_obj may already have been freed */ 2285 if (PL_in_clean_all) 2286 return 0; 2287 2288 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen); 2289 2290 if (mg) { 2291 /* arylen scalar holds a pointer back to the array, but doesn't own a 2292 reference. Hence the we (the array) are about to go away with it 2293 still pointing at us. Clear its pointer, else it would be pointing 2294 at free memory. See the comment in sv_magic about reference loops, 2295 and why it can't own a reference to us. */ 2296 mg->mg_obj = 0; 2297 } 2298 return 0; 2299 } 2300 2301 int 2302 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) 2303 { 2304 SV* const lsv = LvTARG(sv); 2305 MAGIC * const found = mg_find_mglob(lsv); 2306 2307 PERL_ARGS_ASSERT_MAGIC_GETPOS; 2308 PERL_UNUSED_ARG(mg); 2309 2310 if (found && found->mg_len != -1) { 2311 STRLEN i = found->mg_len; 2312 if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv)) 2313 i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN); 2314 sv_setuv(sv, i); 2315 return 0; 2316 } 2317 sv_set_undef(sv); 2318 return 0; 2319 } 2320 2321 int 2322 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) 2323 { 2324 SV* const lsv = LvTARG(sv); 2325 SSize_t pos; 2326 STRLEN len; 2327 MAGIC* found; 2328 const char *s; 2329 2330 PERL_ARGS_ASSERT_MAGIC_SETPOS; 2331 PERL_UNUSED_ARG(mg); 2332 2333 found = mg_find_mglob(lsv); 2334 if (!found) { 2335 if (!SvOK(sv)) 2336 return 0; 2337 found = sv_magicext_mglob(lsv); 2338 } 2339 else if (!SvOK(sv)) { 2340 found->mg_len = -1; 2341 return 0; 2342 } 2343 s = SvPV_const(lsv, len); 2344 2345 pos = SvIV(sv); 2346 2347 if (DO_UTF8(lsv)) { 2348 const STRLEN ulen = sv_or_pv_len_utf8(lsv, s, len); 2349 if (ulen) 2350 len = ulen; 2351 } 2352 2353 if (pos < 0) { 2354 pos += len; 2355 if (pos < 0) 2356 pos = 0; 2357 } 2358 else if (pos > (SSize_t)len) 2359 pos = len; 2360 2361 found->mg_len = pos; 2362 found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES); 2363 2364 return 0; 2365 } 2366 2367 int 2368 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) 2369 { 2370 STRLEN len; 2371 SV * const lsv = LvTARG(sv); 2372 const char * const tmps = SvPV_const(lsv,len); 2373 STRLEN offs = LvTARGOFF(sv); 2374 STRLEN rem = LvTARGLEN(sv); 2375 const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF; 2376 const bool negrem = LvFLAGS(sv) & LVf_NEG_LEN; 2377 2378 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR; 2379 PERL_UNUSED_ARG(mg); 2380 2381 if (!translate_substr_offsets( 2382 SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len, 2383 negoff ? -(IV)offs : (IV)offs, !negoff, 2384 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem 2385 )) { 2386 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); 2387 sv_set_undef(sv); 2388 return 0; 2389 } 2390 2391 if (SvUTF8(lsv)) 2392 offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem); 2393 sv_setpvn(sv, tmps + offs, rem); 2394 if (SvUTF8(lsv)) 2395 SvUTF8_on(sv); 2396 return 0; 2397 } 2398 2399 int 2400 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) 2401 { 2402 STRLEN len, lsv_len, oldtarglen, newtarglen; 2403 const char * const tmps = SvPV_const(sv, len); 2404 SV * const lsv = LvTARG(sv); 2405 STRLEN lvoff = LvTARGOFF(sv); 2406 STRLEN lvlen = LvTARGLEN(sv); 2407 const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF; 2408 const bool neglen = LvFLAGS(sv) & LVf_NEG_LEN; 2409 2410 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR; 2411 PERL_UNUSED_ARG(mg); 2412 2413 SvGETMAGIC(lsv); 2414 if (SvROK(lsv)) 2415 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), 2416 "Attempt to use reference as lvalue in substr" 2417 ); 2418 SvPV_force_nomg(lsv,lsv_len); 2419 if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv); 2420 if (!translate_substr_offsets( 2421 lsv_len, 2422 negoff ? -(IV)lvoff : (IV)lvoff, !negoff, 2423 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen 2424 )) 2425 Perl_croak(aTHX_ "substr outside of string"); 2426 oldtarglen = lvlen; 2427 if (DO_UTF8(sv)) { 2428 sv_utf8_upgrade_nomg(lsv); 2429 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); 2430 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0); 2431 newtarglen = sv_or_pv_len_utf8(sv, tmps, len); 2432 SvUTF8_on(lsv); 2433 } 2434 else if (SvUTF8(lsv)) { 2435 const char *utf8; 2436 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); 2437 newtarglen = len; 2438 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len); 2439 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0); 2440 Safefree(utf8); 2441 } 2442 else { 2443 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0); 2444 newtarglen = len; 2445 } 2446 if (!neglen) LvTARGLEN(sv) = newtarglen; 2447 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen; 2448 2449 return 0; 2450 } 2451 2452 int 2453 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg) 2454 { 2455 PERL_ARGS_ASSERT_MAGIC_GETTAINT; 2456 PERL_UNUSED_ARG(sv); 2457 #ifdef NO_TAINT_SUPPORT 2458 PERL_UNUSED_ARG(mg); 2459 #endif 2460 2461 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1) && IN_PERL_RUNTIME); 2462 return 0; 2463 } 2464 2465 int 2466 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg) 2467 { 2468 PERL_ARGS_ASSERT_MAGIC_SETTAINT; 2469 PERL_UNUSED_ARG(sv); 2470 2471 /* update taint status */ 2472 if (TAINT_get) 2473 mg->mg_len |= 1; 2474 else 2475 mg->mg_len &= ~1; 2476 return 0; 2477 } 2478 2479 int 2480 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg) 2481 { 2482 SV * const lsv = LvTARG(sv); 2483 char errflags = LvFLAGS(sv); 2484 2485 PERL_ARGS_ASSERT_MAGIC_GETVEC; 2486 PERL_UNUSED_ARG(mg); 2487 2488 /* non-zero errflags implies deferred out-of-range condition */ 2489 assert(!(errflags & ~(LVf_NEG_OFF|LVf_OUT_OF_RANGE))); 2490 sv_setuv(sv, errflags ? 0 : do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv))); 2491 2492 return 0; 2493 } 2494 2495 int 2496 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg) 2497 { 2498 PERL_ARGS_ASSERT_MAGIC_SETVEC; 2499 PERL_UNUSED_ARG(mg); 2500 do_vecset(sv); /* XXX slurp this routine */ 2501 return 0; 2502 } 2503 2504 SV * 2505 Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg) 2506 { 2507 SV *targ = NULL; 2508 PERL_ARGS_ASSERT_DEFELEM_TARGET; 2509 if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem); 2510 assert(mg); 2511 if (LvTARGLEN(sv)) { 2512 if (mg->mg_obj) { 2513 SV * const ahv = LvTARG(sv); 2514 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0); 2515 if (he) 2516 targ = HeVAL(he); 2517 } 2518 else if (LvSTARGOFF(sv) >= 0) { 2519 AV *const av = MUTABLE_AV(LvTARG(sv)); 2520 if (LvSTARGOFF(sv) <= AvFILL(av)) 2521 { 2522 if (SvRMAGICAL(av)) { 2523 SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0); 2524 targ = svp ? *svp : NULL; 2525 } 2526 else 2527 targ = AvARRAY(av)[LvSTARGOFF(sv)]; 2528 } 2529 } 2530 if (targ && (targ != &PL_sv_undef)) { 2531 /* somebody else defined it for us */ 2532 SvREFCNT_dec(LvTARG(sv)); 2533 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ); 2534 LvTARGLEN(sv) = 0; 2535 SvREFCNT_dec(mg->mg_obj); 2536 mg->mg_obj = NULL; 2537 mg->mg_flags &= ~MGf_REFCOUNTED; 2538 } 2539 return targ; 2540 } 2541 else 2542 return LvTARG(sv); 2543 } 2544 2545 int 2546 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg) 2547 { 2548 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM; 2549 2550 sv_setsv(sv, defelem_target(sv, mg)); 2551 return 0; 2552 } 2553 2554 int 2555 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg) 2556 { 2557 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM; 2558 PERL_UNUSED_ARG(mg); 2559 if (LvTARGLEN(sv)) 2560 vivify_defelem(sv); 2561 if (LvTARG(sv)) { 2562 sv_setsv(LvTARG(sv), sv); 2563 SvSETMAGIC(LvTARG(sv)); 2564 } 2565 return 0; 2566 } 2567 2568 void 2569 Perl_vivify_defelem(pTHX_ SV *sv) 2570 { 2571 MAGIC *mg; 2572 SV *value = NULL; 2573 2574 PERL_ARGS_ASSERT_VIVIFY_DEFELEM; 2575 2576 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem))) 2577 return; 2578 if (mg->mg_obj) { 2579 SV * const ahv = LvTARG(sv); 2580 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0); 2581 if (he) 2582 value = HeVAL(he); 2583 if (!value || value == &PL_sv_undef) 2584 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj)); 2585 } 2586 else if (LvSTARGOFF(sv) < 0) 2587 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv)); 2588 else { 2589 AV *const av = MUTABLE_AV(LvTARG(sv)); 2590 if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av)) 2591 LvTARG(sv) = NULL; /* array can't be extended */ 2592 else { 2593 SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE); 2594 if (!svp || !(value = *svp)) 2595 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv)); 2596 } 2597 } 2598 SvREFCNT_inc_simple_void(value); 2599 SvREFCNT_dec(LvTARG(sv)); 2600 LvTARG(sv) = value; 2601 LvTARGLEN(sv) = 0; 2602 SvREFCNT_dec(mg->mg_obj); 2603 mg->mg_obj = NULL; 2604 mg->mg_flags &= ~MGf_REFCOUNTED; 2605 } 2606 2607 int 2608 Perl_magic_setnonelem(pTHX_ SV *sv, MAGIC *mg) 2609 { 2610 PERL_ARGS_ASSERT_MAGIC_SETNONELEM; 2611 PERL_UNUSED_ARG(mg); 2612 sv_unmagic(sv, PERL_MAGIC_nonelem); 2613 return 0; 2614 } 2615 2616 int 2617 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg) 2618 { 2619 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS; 2620 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj)); 2621 return 0; 2622 } 2623 2624 int 2625 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg) 2626 { 2627 PERL_ARGS_ASSERT_MAGIC_SETMGLOB; 2628 PERL_UNUSED_CONTEXT; 2629 PERL_UNUSED_ARG(sv); 2630 mg->mg_len = -1; 2631 return 0; 2632 } 2633 2634 2635 int 2636 Perl_magic_freemglob(pTHX_ SV *sv, MAGIC *mg) 2637 { 2638 PERL_ARGS_ASSERT_MAGIC_FREEMGLOB; 2639 PERL_UNUSED_ARG(sv); 2640 2641 /* pos() magic uses mg_len as a string position rather than a buffer 2642 * length, and mg_ptr is currently unused, so skip freeing. 2643 */ 2644 assert(mg->mg_type == PERL_MAGIC_regex_global && mg->mg_len >= -1); 2645 mg->mg_ptr = NULL; 2646 return 0; 2647 } 2648 2649 2650 int 2651 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg) 2652 { 2653 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr; 2654 2655 PERL_ARGS_ASSERT_MAGIC_SETUVAR; 2656 2657 if (uf && uf->uf_set) 2658 (*uf->uf_set)(aTHX_ uf->uf_index, sv); 2659 return 0; 2660 } 2661 2662 int 2663 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg) 2664 { 2665 const char type = mg->mg_type; 2666 2667 PERL_ARGS_ASSERT_MAGIC_SETREGEXP; 2668 2669 assert( type == PERL_MAGIC_fm 2670 || type == PERL_MAGIC_qr 2671 || type == PERL_MAGIC_bm); 2672 return sv_unmagic(sv, type); 2673 } 2674 2675 #ifdef USE_LOCALE_COLLATE 2676 int 2677 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg) 2678 { 2679 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM; 2680 2681 /* 2682 * RenE<eacute> Descartes said "I think not." 2683 * and vanished with a faint plop. 2684 */ 2685 PERL_UNUSED_CONTEXT; 2686 PERL_UNUSED_ARG(sv); 2687 if (mg->mg_ptr) { 2688 Safefree(mg->mg_ptr); 2689 mg->mg_ptr = NULL; 2690 mg->mg_len = -1; 2691 } 2692 return 0; 2693 } 2694 2695 int 2696 Perl_magic_freecollxfrm(pTHX_ SV *sv, MAGIC *mg) 2697 { 2698 PERL_ARGS_ASSERT_MAGIC_FREECOLLXFRM; 2699 PERL_UNUSED_ARG(sv); 2700 2701 /* Collate magic uses mg_len as a string length rather than a buffer 2702 * length, so we need to free even with mg_len == 0: hence we can't 2703 * rely on standard magic free handling */ 2704 if (mg->mg_len >= 0) { 2705 assert(mg->mg_type == PERL_MAGIC_collxfrm); 2706 Safefree(mg->mg_ptr); 2707 mg->mg_ptr = NULL; 2708 } 2709 2710 return 0; 2711 } 2712 #endif /* USE_LOCALE_COLLATE */ 2713 2714 /* Just clear the UTF-8 cache data. */ 2715 int 2716 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg) 2717 { 2718 PERL_ARGS_ASSERT_MAGIC_SETUTF8; 2719 PERL_UNUSED_CONTEXT; 2720 PERL_UNUSED_ARG(sv); 2721 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */ 2722 mg->mg_ptr = NULL; 2723 mg->mg_len = -1; /* The mg_len holds the len cache. */ 2724 return 0; 2725 } 2726 2727 int 2728 Perl_magic_freeutf8(pTHX_ SV *sv, MAGIC *mg) 2729 { 2730 PERL_ARGS_ASSERT_MAGIC_FREEUTF8; 2731 PERL_UNUSED_ARG(sv); 2732 2733 /* utf8 magic uses mg_len as a string length rather than a buffer 2734 * length, so we need to free even with mg_len == 0: hence we can't 2735 * rely on standard magic free handling */ 2736 assert(mg->mg_type == PERL_MAGIC_utf8 && mg->mg_len >= -1); 2737 Safefree(mg->mg_ptr); 2738 mg->mg_ptr = NULL; 2739 return 0; 2740 } 2741 2742 2743 int 2744 Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg) 2745 { 2746 const char *bad = NULL; 2747 PERL_ARGS_ASSERT_MAGIC_SETLVREF; 2748 if (!SvROK(sv)) Perl_croak(aTHX_ "Assigned value is not a reference"); 2749 switch (mg->mg_private & OPpLVREF_TYPE) { 2750 case OPpLVREF_SV: 2751 if (SvTYPE(SvRV(sv)) > SVt_PVLV) 2752 bad = " SCALAR"; 2753 break; 2754 case OPpLVREF_AV: 2755 if (SvTYPE(SvRV(sv)) != SVt_PVAV) 2756 bad = "n ARRAY"; 2757 break; 2758 case OPpLVREF_HV: 2759 if (SvTYPE(SvRV(sv)) != SVt_PVHV) 2760 bad = " HASH"; 2761 break; 2762 case OPpLVREF_CV: 2763 if (SvTYPE(SvRV(sv)) != SVt_PVCV) 2764 bad = " CODE"; 2765 } 2766 if (bad) 2767 /* diag_listed_as: Assigned value is not %s reference */ 2768 Perl_croak(aTHX_ "Assigned value is not a%s reference", bad); 2769 switch (mg->mg_obj ? SvTYPE(mg->mg_obj) : 0) { 2770 case 0: 2771 { 2772 SV * const old = PAD_SV(mg->mg_len); 2773 PAD_SETSV(mg->mg_len, SvREFCNT_inc_NN(SvRV(sv))); 2774 SvREFCNT_dec(old); 2775 break; 2776 } 2777 case SVt_PVGV: 2778 gv_setref(mg->mg_obj, sv); 2779 SvSETMAGIC(mg->mg_obj); 2780 break; 2781 case SVt_PVAV: 2782 av_store((AV *)mg->mg_obj, SvIV((SV *)mg->mg_ptr), 2783 SvREFCNT_inc_simple_NN(SvRV(sv))); 2784 break; 2785 case SVt_PVHV: 2786 (void)hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr, 2787 SvREFCNT_inc_simple_NN(SvRV(sv)), 0); 2788 } 2789 if (mg->mg_flags & MGf_PERSIST) 2790 NOOP; /* This sv is in use as an iterator var and will be reused, 2791 so we must leave the magic. */ 2792 else 2793 /* This sv could be returned by the assignment op, so clear the 2794 magic, as lvrefs are an implementation detail that must not be 2795 leaked to the user. */ 2796 sv_unmagic(sv, PERL_MAGIC_lvref); 2797 return 0; 2798 } 2799 2800 static void 2801 S_set_dollarzero(pTHX_ SV *sv) 2802 PERL_TSA_REQUIRES(PL_dollarzero_mutex) 2803 { 2804 const char *s; 2805 STRLEN len; 2806 #ifdef HAS_SETPROCTITLE 2807 /* The BSDs don't show the argv[] in ps(1) output, they 2808 * show a string from the process struct and provide 2809 * the setproctitle() routine to manipulate that. */ 2810 if (PL_origalen != 1) { 2811 s = SvPV_const(sv, len); 2812 # if __FreeBSD_version > 410001 || defined(__DragonFly__) 2813 /* The leading "-" removes the "perl: " prefix, 2814 * but not the "(perl) suffix from the ps(1) 2815 * output, because that's what ps(1) shows if the 2816 * argv[] is modified. */ 2817 setproctitle("-%s", s); 2818 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */ 2819 /* This doesn't really work if you assume that 2820 * $0 = 'foobar'; will wipe out 'perl' from the $0 2821 * because in ps(1) output the result will be like 2822 * sprintf("perl: %s (perl)", s) 2823 * I guess this is a security feature: 2824 * one (a user process) cannot get rid of the original name. 2825 * --jhi */ 2826 setproctitle("%s", s); 2827 # endif 2828 } 2829 #elif defined(__hpux) && defined(PSTAT_SETCMD) 2830 if (PL_origalen != 1) { 2831 union pstun un; 2832 s = SvPV_const(sv, len); 2833 un.pst_command = (char *)s; 2834 pstat(PSTAT_SETCMD, un, len, 0, 0); 2835 } 2836 #else 2837 if (PL_origalen > 1) { 2838 I32 i; 2839 /* PL_origalen is set in perl_parse(). */ 2840 s = SvPV_force(sv,len); 2841 if (len >= (STRLEN)PL_origalen-1) { 2842 /* Longer than original, will be truncated. We assume that 2843 * PL_origalen bytes are available. */ 2844 Copy(s, PL_origargv[0], PL_origalen-1, char); 2845 } 2846 else { 2847 /* Shorter than original, will be padded. */ 2848 #ifdef PERL_DARWIN 2849 /* Special case for Mac OS X: see [perl #38868] */ 2850 const int pad = 0; 2851 #else 2852 /* Is the space counterintuitive? Yes. 2853 * (You were expecting \0?) 2854 * Does it work? Seems to. (In Linux 2.4.20 at least.) 2855 * --jhi */ 2856 const int pad = ' '; 2857 #endif 2858 Copy(s, PL_origargv[0], len, char); 2859 PL_origargv[0][len] = 0; 2860 memset(PL_origargv[0] + len + 1, 2861 pad, PL_origalen - len - 1); 2862 } 2863 PL_origargv[0][PL_origalen-1] = 0; 2864 for (i = 1; i < PL_origargc; i++) 2865 PL_origargv[i] = 0; 2866 #ifdef HAS_PRCTL_SET_NAME 2867 /* Set the legacy process name in addition to the POSIX name on Linux */ 2868 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) { 2869 /* diag_listed_as: SKIPME */ 2870 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno)); 2871 } 2872 #endif 2873 } 2874 #endif 2875 } 2876 2877 int 2878 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) 2879 { 2880 I32 paren; 2881 const REGEXP * rx; 2882 I32 i; 2883 STRLEN len; 2884 MAGIC *tmg; 2885 2886 PERL_ARGS_ASSERT_MAGIC_SET; 2887 2888 if (!mg->mg_ptr) { 2889 paren = mg->mg_len; 2890 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 2891 setparen_got_rx: 2892 CALLREG_NUMBUF_STORE((REGEXP *)rx,paren,sv); 2893 } else { 2894 /* Croak with a READONLY error when a numbered match var is 2895 * set without a previous pattern match. Unless it's C<local $1> 2896 */ 2897 croakparen: 2898 if (!PL_localizing) { 2899 Perl_croak_no_modify(); 2900 } 2901 } 2902 return 0; 2903 } 2904 2905 switch (*mg->mg_ptr) { 2906 case '\001': /* ^A */ 2907 if (SvOK(sv)) sv_copypv(PL_bodytarget, sv); 2908 else SvOK_off(PL_bodytarget); 2909 FmLINES(PL_bodytarget) = 0; 2910 if (SvPOK(PL_bodytarget)) { 2911 char *s = SvPVX(PL_bodytarget); 2912 char *e = SvEND(PL_bodytarget); 2913 while ( ((s = (char *) memchr(s, '\n', e - s))) ) { 2914 FmLINES(PL_bodytarget)++; 2915 s++; 2916 } 2917 } 2918 /* mg_set() has temporarily made sv non-magical */ 2919 if (TAINTING_get) { 2920 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1) 2921 SvTAINTED_on(PL_bodytarget); 2922 else 2923 SvTAINTED_off(PL_bodytarget); 2924 } 2925 break; 2926 case '\003': /* ^C */ 2927 PL_minus_c = cBOOL(SvIV(sv)); 2928 break; 2929 2930 case '\004': /* ^D */ 2931 #ifdef DEBUGGING 2932 { 2933 const char *s = SvPV_nolen_const(sv); 2934 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG; 2935 if (DEBUG_x_TEST || DEBUG_B_TEST) 2936 dump_all_perl(!DEBUG_B_TEST); 2937 } 2938 #else 2939 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG; 2940 #endif 2941 break; 2942 case '\005': /* ^E */ 2943 if (*(mg->mg_ptr+1) == '\0') { 2944 #ifdef VMS 2945 set_vaxc_errno(SvIV(sv)); 2946 #elif defined(WIN32) 2947 SetLastError( SvIV(sv) ); 2948 #elif defined(OS2) 2949 os2_setsyserrno(SvIV(sv)); 2950 #else 2951 /* will anyone ever use this? */ 2952 SETERRNO(SvIV(sv), 4); 2953 #endif 2954 } 2955 else if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv)) 2956 Perl_croak(aTHX_ "${^ENCODING} is no longer supported"); 2957 break; 2958 case '\006': /* ^F */ 2959 if (mg->mg_ptr[1] == '\0') { 2960 PL_maxsysfd = SvIV(sv); 2961 } 2962 break; 2963 case '\010': /* ^H */ 2964 { 2965 U32 save_hints = PL_hints; 2966 PL_hints = SvUV(sv); 2967 2968 /* If wasn't UTF-8, and now is, notify the parser */ 2969 if ((PL_hints & HINT_UTF8) && ! (save_hints & HINT_UTF8)) { 2970 notify_parser_that_changed_to_utf8(); 2971 } 2972 } 2973 break; 2974 case '\011': /* ^I */ /* NOT \t in EBCDIC */ 2975 Safefree(PL_inplace); 2976 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL; 2977 break; 2978 case '\016': /* ^N */ 2979 if (PL_curpm && (rx = PM_GETRE(PL_curpm)) 2980 && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx; 2981 goto croakparen; 2982 case '\017': /* ^O */ 2983 if (*(mg->mg_ptr+1) == '\0') { 2984 Safefree(PL_osname); 2985 PL_osname = NULL; 2986 if (SvOK(sv)) { 2987 TAINT_PROPER("assigning to $^O"); 2988 PL_osname = savesvpv(sv); 2989 } 2990 } 2991 else if (strEQ(mg->mg_ptr, "\017PEN")) { 2992 STRLEN len; 2993 const char *const start = SvPV(sv, len); 2994 const char *out = (const char*)memchr(start, '\0', len); 2995 SV *tmp; 2996 2997 2998 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; 2999 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; 3000 3001 /* Opening for input is more common than opening for output, so 3002 ensure that hints for input are sooner on linked list. */ 3003 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1, 3004 SvUTF8(sv)) 3005 : newSVpvs_flags("", SvUTF8(sv)); 3006 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp); 3007 mg_set(tmp); 3008 3009 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len, 3010 SvUTF8(sv)); 3011 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp); 3012 mg_set(tmp); 3013 } 3014 break; 3015 case '\020': /* ^P */ 3016 PL_perldb = SvIV(sv); 3017 if (PL_perldb && !PL_DBsingle) 3018 init_debugger(); 3019 break; 3020 case '\024': /* ^T */ 3021 #ifdef BIG_TIME 3022 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv)); 3023 #else 3024 PL_basetime = (Time_t)SvIV(sv); 3025 #endif 3026 break; 3027 case '\025': /* ^UTF8CACHE */ 3028 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) { 3029 PL_utf8cache = (signed char) sv_2iv(sv); 3030 } 3031 break; 3032 case '\027': /* ^W & $^WARNING_BITS */ 3033 if (*(mg->mg_ptr+1) == '\0') { 3034 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { 3035 i = SvIV(sv); 3036 PL_dowarn = (PL_dowarn & ~G_WARN_ON) 3037 | (i ? G_WARN_ON : G_WARN_OFF) ; 3038 } 3039 } 3040 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) { 3041 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { 3042 if (!SvPOK(sv)) { 3043 free_and_set_cop_warnings(&PL_compiling, pWARN_STD); 3044 break; 3045 } 3046 { 3047 STRLEN len, i; 3048 int not_none = 0, not_all = 0; 3049 const U8 * const ptr = (const U8 *)SvPV_const(sv, len) ; 3050 for (i = 0 ; i < len ; ++i) { 3051 not_none |= ptr[i]; 3052 not_all |= ptr[i] ^ 0x55; 3053 } 3054 if (!not_none) { 3055 free_and_set_cop_warnings(&PL_compiling, pWARN_NONE); 3056 } else if (len >= WARNsize && !not_all) { 3057 free_and_set_cop_warnings(&PL_compiling, pWARN_ALL); 3058 PL_dowarn |= G_WARN_ONCE ; 3059 } 3060 else { 3061 STRLEN len; 3062 const char *const p = SvPV_const(sv, len); 3063 3064 PL_compiling.cop_warnings 3065 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings, 3066 p, len); 3067 3068 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE)) 3069 PL_dowarn |= G_WARN_ONCE ; 3070 } 3071 3072 } 3073 } 3074 } 3075 break; 3076 case '.': 3077 if (PL_localizing) { 3078 if (PL_localizing == 1) 3079 SAVESPTR(PL_last_in_gv); 3080 } 3081 else if (SvOK(sv) && GvIO(PL_last_in_gv)) 3082 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv); 3083 break; 3084 case '^': 3085 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv))); 3086 IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); 3087 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); 3088 break; 3089 case '~': 3090 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv))); 3091 IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); 3092 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); 3093 break; 3094 case '=': 3095 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv)); 3096 break; 3097 case '-': 3098 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv)); 3099 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L) 3100 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L; 3101 break; 3102 case '%': 3103 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv)); 3104 break; 3105 case '|': 3106 { 3107 IO * const io = GvIO(PL_defoutgv); 3108 if(!io) 3109 break; 3110 if ((SvIV(sv)) == 0) 3111 IoFLAGS(io) &= ~IOf_FLUSH; 3112 else { 3113 if (!(IoFLAGS(io) & IOf_FLUSH)) { 3114 PerlIO *ofp = IoOFP(io); 3115 if (ofp) 3116 (void)PerlIO_flush(ofp); 3117 IoFLAGS(io) |= IOf_FLUSH; 3118 } 3119 } 3120 } 3121 break; 3122 case '/': 3123 { 3124 if (SvROK(sv)) { 3125 SV *referent = SvRV(sv); 3126 const char *reftype = sv_reftype(referent, 0); 3127 /* XXX: dodgy type check: This leaves me feeling dirty, but 3128 * the alternative is to copy pretty much the entire 3129 * sv_reftype() into this routine, or to do a full string 3130 * comparison on the return of sv_reftype() both of which 3131 * make me feel worse! NOTE, do not modify this comment 3132 * without reviewing the corresponding comment in 3133 * sv_reftype(). - Yves */ 3134 if (reftype[0] == 'S' || reftype[0] == 'L') { 3135 IV val = SvIV(referent); 3136 if (val <= 0) { 3137 sv_setsv(sv, PL_rs); 3138 Perl_croak(aTHX_ "Setting $/ to a reference to %s is forbidden", 3139 val < 0 ? "a negative integer" : "zero"); 3140 } 3141 } else { 3142 sv_setsv(sv, PL_rs); 3143 /* diag_listed_as: Setting $/ to %s reference is forbidden */ 3144 Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden", 3145 *reftype == 'A' ? "n" : "", reftype); 3146 } 3147 } 3148 SvREFCNT_dec(PL_rs); 3149 PL_rs = newSVsv(sv); 3150 } 3151 break; 3152 case '\\': 3153 SvREFCNT_dec(PL_ors_sv); 3154 if (SvOK(sv)) { 3155 PL_ors_sv = newSVsv(sv); 3156 } 3157 else { 3158 PL_ors_sv = NULL; 3159 } 3160 break; 3161 case '[': 3162 if (SvIV(sv) != 0) 3163 Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible"); 3164 break; 3165 case '?': 3166 #ifdef COMPLEX_STATUS 3167 if (PL_localizing == 2) { 3168 SvUPGRADE(sv, SVt_PVLV); 3169 PL_statusvalue = LvTARGOFF(sv); 3170 PL_statusvalue_vms = LvTARGLEN(sv); 3171 } 3172 else 3173 #endif 3174 #ifdef VMSISH_STATUS 3175 if (VMSISH_STATUS) 3176 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv)); 3177 else 3178 #endif 3179 STATUS_UNIX_EXIT_SET(SvIV(sv)); 3180 break; 3181 case '!': 3182 { 3183 #ifdef VMS 3184 # define PERL_VMS_BANG vaxc$errno 3185 #else 3186 # define PERL_VMS_BANG 0 3187 #endif 3188 #if defined(WIN32) 3189 SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0), 3190 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG); 3191 #else 3192 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0, 3193 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG); 3194 #endif 3195 } 3196 break; 3197 case '<': 3198 { 3199 /* XXX $< currently silently ignores failures */ 3200 const Uid_t new_uid = SvUID(sv); 3201 PL_delaymagic_uid = new_uid; 3202 if (PL_delaymagic) { 3203 PL_delaymagic |= DM_RUID; 3204 break; /* don't do magic till later */ 3205 } 3206 #ifdef HAS_SETRUID 3207 PERL_UNUSED_RESULT(setruid(new_uid)); 3208 #elif defined(HAS_SETREUID) 3209 PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1)); 3210 #elif defined(HAS_SETRESUID) 3211 PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1)); 3212 #else 3213 if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */ 3214 # ifdef PERL_DARWIN 3215 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */ 3216 if (new_uid != 0 && PerlProc_getuid() == 0) 3217 PERL_UNUSED_RESULT(PerlProc_setuid(0)); 3218 # endif 3219 PERL_UNUSED_RESULT(PerlProc_setuid(new_uid)); 3220 } else { 3221 Perl_croak(aTHX_ "setruid() not implemented"); 3222 } 3223 #endif 3224 break; 3225 } 3226 case '>': 3227 { 3228 /* XXX $> currently silently ignores failures */ 3229 const Uid_t new_euid = SvUID(sv); 3230 PL_delaymagic_euid = new_euid; 3231 if (PL_delaymagic) { 3232 PL_delaymagic |= DM_EUID; 3233 break; /* don't do magic till later */ 3234 } 3235 #ifdef HAS_SETEUID 3236 PERL_UNUSED_RESULT(seteuid(new_euid)); 3237 #elif defined(HAS_SETREUID) 3238 PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid)); 3239 #elif defined(HAS_SETRESUID) 3240 PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1)); 3241 #else 3242 if (new_euid == PerlProc_getuid()) /* special case $> = $< */ 3243 PERL_UNUSED_RESULT(PerlProc_setuid(new_euid)); 3244 else { 3245 Perl_croak(aTHX_ "seteuid() not implemented"); 3246 } 3247 #endif 3248 break; 3249 } 3250 case '(': 3251 { 3252 /* XXX $( currently silently ignores failures */ 3253 const Gid_t new_gid = SvGID(sv); 3254 PL_delaymagic_gid = new_gid; 3255 if (PL_delaymagic) { 3256 PL_delaymagic |= DM_RGID; 3257 break; /* don't do magic till later */ 3258 } 3259 #ifdef HAS_SETRGID 3260 PERL_UNUSED_RESULT(setrgid(new_gid)); 3261 #elif defined(HAS_SETREGID) 3262 PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1)); 3263 #elif defined(HAS_SETRESGID) 3264 PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1)); 3265 #else 3266 if (new_gid == PerlProc_getegid()) /* special case $( = $) */ 3267 PERL_UNUSED_RESULT(PerlProc_setgid(new_gid)); 3268 else { 3269 Perl_croak(aTHX_ "setrgid() not implemented"); 3270 } 3271 #endif 3272 break; 3273 } 3274 case ')': 3275 { 3276 /* (hv) best guess: maybe we'll need configure probes to do a better job, 3277 * but you can override it if you need to. 3278 */ 3279 #ifndef INVALID_GID 3280 #define INVALID_GID ((Gid_t)-1) 3281 #endif 3282 /* XXX $) currently silently ignores failures */ 3283 Gid_t new_egid; 3284 #ifdef HAS_SETGROUPS 3285 { 3286 const char *p = SvPV_const(sv, len); 3287 Groups_t *gary = NULL; 3288 const char* p_end = p + len; 3289 const char* endptr = p_end; 3290 UV uv; 3291 #ifdef _SC_NGROUPS_MAX 3292 int maxgrp = sysconf(_SC_NGROUPS_MAX); 3293 3294 if (maxgrp < 0) 3295 maxgrp = NGROUPS; 3296 #else 3297 int maxgrp = NGROUPS; 3298 #endif 3299 3300 while (isSPACE(*p)) 3301 ++p; 3302 if (grok_atoUV(p, &uv, &endptr)) 3303 new_egid = (Gid_t)uv; 3304 else { 3305 new_egid = INVALID_GID; 3306 endptr = NULL; 3307 } 3308 for (i = 0; i < maxgrp; ++i) { 3309 if (endptr == NULL) 3310 break; 3311 p = endptr; 3312 endptr = p_end; 3313 while (isSPACE(*p)) 3314 ++p; 3315 if (!*p) 3316 break; 3317 if (!gary) 3318 Newx(gary, i + 1, Groups_t); 3319 else 3320 Renew(gary, i + 1, Groups_t); 3321 if (grok_atoUV(p, &uv, &endptr)) 3322 gary[i] = (Groups_t)uv; 3323 else { 3324 gary[i] = INVALID_GID; 3325 endptr = NULL; 3326 } 3327 } 3328 if (i) 3329 PERL_UNUSED_RESULT(setgroups(i, gary)); 3330 Safefree(gary); 3331 } 3332 #else /* HAS_SETGROUPS */ 3333 new_egid = SvGID(sv); 3334 #endif /* HAS_SETGROUPS */ 3335 PL_delaymagic_egid = new_egid; 3336 if (PL_delaymagic) { 3337 PL_delaymagic |= DM_EGID; 3338 break; /* don't do magic till later */ 3339 } 3340 #ifdef HAS_SETEGID 3341 PERL_UNUSED_RESULT(setegid(new_egid)); 3342 #elif defined(HAS_SETREGID) 3343 PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid)); 3344 #elif defined(HAS_SETRESGID) 3345 PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1)); 3346 #else 3347 if (new_egid == PerlProc_getgid()) /* special case $) = $( */ 3348 PERL_UNUSED_RESULT(PerlProc_setgid(new_egid)); 3349 else { 3350 Perl_croak(aTHX_ "setegid() not implemented"); 3351 } 3352 #endif 3353 break; 3354 } 3355 case ':': 3356 PL_chopset = SvPV_force(sv,len); 3357 break; 3358 case '$': /* $$ */ 3359 /* Store the pid in mg->mg_obj so we can tell when a fork has 3360 occurred. mg->mg_obj points to *$ by default, so clear it. */ 3361 if (isGV(mg->mg_obj)) { 3362 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */ 3363 SvREFCNT_dec(mg->mg_obj); 3364 mg->mg_flags |= MGf_REFCOUNTED; 3365 mg->mg_obj = newSViv((IV)PerlProc_getpid()); 3366 } 3367 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid()); 3368 break; 3369 case '0': 3370 if (!sv_utf8_downgrade(sv, /* fail_ok */ TRUE)) { 3371 3372 /* Since we are going to set the string's UTF8-encoded form 3373 as the process name we should update $0 itself to contain 3374 that same (UTF8-encoded) value. */ 3375 sv_utf8_encode(GvSV(mg->mg_obj)); 3376 3377 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "$0"); 3378 } 3379 3380 LOCK_DOLLARZERO_MUTEX; 3381 S_set_dollarzero(aTHX_ sv); 3382 UNLOCK_DOLLARZERO_MUTEX; 3383 break; 3384 } 3385 return 0; 3386 } 3387 3388 /* 3389 =for apidoc_section $signals 3390 =for apidoc whichsig 3391 =for apidoc_item whichsig_pv 3392 =for apidoc_item whichsig_pvn 3393 =for apidoc_item whichsig_sv 3394 3395 These all convert a signal name into its corresponding signal number; 3396 returning -1 if no corresponding number was found. 3397 3398 They differ only in the source of the signal name: 3399 3400 C<whichsig_pv> takes the name from the C<NUL>-terminated string starting at 3401 C<sig>. 3402 3403 C<whichsig> is merely a different spelling, a synonym, of C<whichsig_pv>. 3404 3405 C<whichsig_pvn> takes the name from the string starting at C<sig>, with length 3406 C<len> bytes. 3407 3408 C<whichsig_sv> takes the name from the PV stored in the SV C<sigsv>. 3409 3410 =cut 3411 */ 3412 3413 I32 3414 Perl_whichsig_sv(pTHX_ SV *sigsv) 3415 { 3416 const char *sigpv; 3417 STRLEN siglen; 3418 PERL_ARGS_ASSERT_WHICHSIG_SV; 3419 sigpv = SvPV_const(sigsv, siglen); 3420 return whichsig_pvn(sigpv, siglen); 3421 } 3422 3423 I32 3424 Perl_whichsig_pv(pTHX_ const char *sig) 3425 { 3426 PERL_ARGS_ASSERT_WHICHSIG_PV; 3427 return whichsig_pvn(sig, strlen(sig)); 3428 } 3429 3430 I32 3431 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len) 3432 { 3433 char* const* sigv; 3434 3435 PERL_ARGS_ASSERT_WHICHSIG_PVN; 3436 PERL_UNUSED_CONTEXT; 3437 3438 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++) 3439 if (strlen(*sigv) == len && memEQ(sig,*sigv, len)) 3440 return PL_sig_num[sigv - (char* const*)PL_sig_name]; 3441 #ifdef SIGCLD 3442 if (memEQs(sig, len, "CHLD")) 3443 return SIGCLD; 3444 #endif 3445 #ifdef SIGCHLD 3446 if (memEQs(sig, len, "CLD")) 3447 return SIGCHLD; 3448 #endif 3449 return -1; 3450 } 3451 3452 3453 /* Perl_sighandler(), Perl_sighandler1(), Perl_sighandler3(): 3454 * these three function are intended to be called by the OS as 'C' level 3455 * signal handler functions in the case where unsafe signals are being 3456 * used - i.e. they immediately invoke Perl_perly_sighandler() to call the 3457 * perl-level sighandler, rather than deferring. 3458 * In fact, the core itself will normally use Perl_csighandler as the 3459 * OS-level handler; that function will then decide whether to queue the 3460 * signal or call Perl_sighandler / Perl_perly_sighandler itself. So these 3461 * functions are more useful for e.g. POSIX.xs when it wants explicit 3462 * control of what's happening. 3463 */ 3464 3465 3466 #ifdef PERL_USE_3ARG_SIGHANDLER 3467 3468 Signal_t 3469 Perl_sighandler(int sig, Siginfo_t *sip, void *uap) 3470 { 3471 Perl_perly_sighandler(sig, sip, uap, 0); 3472 } 3473 3474 #else 3475 3476 Signal_t 3477 Perl_sighandler(int sig) 3478 { 3479 Perl_perly_sighandler(sig, NULL, NULL, 0); 3480 } 3481 3482 #endif 3483 3484 Signal_t 3485 Perl_sighandler1(int sig) 3486 { 3487 Perl_perly_sighandler(sig, NULL, NULL, 0); 3488 } 3489 3490 Signal_t 3491 Perl_sighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL) 3492 { 3493 Perl_perly_sighandler(sig, sip, uap, 0); 3494 } 3495 3496 3497 /* Invoke the perl-level signal handler. This function is called either 3498 * directly from one of the C-level signals handlers (Perl_sighandler or 3499 * Perl_csighandler), or for safe signals, later from 3500 * Perl_despatch_signals() at a suitable safe point during execution. 3501 * 3502 * 'safe' is a boolean indicating the latter call path. 3503 */ 3504 3505 Signal_t 3506 Perl_perly_sighandler(int sig, Siginfo_t *sip PERL_UNUSED_DECL, 3507 void *uap PERL_UNUSED_DECL, bool safe) 3508 { 3509 #ifdef PERL_GET_SIG_CONTEXT 3510 dTHXa(PERL_GET_SIG_CONTEXT); 3511 #else 3512 dTHX; 3513 #endif 3514 dSP; 3515 GV *gv = NULL; 3516 SV *sv = NULL; 3517 SV * const tSv = PL_Sv; 3518 CV *cv = NULL; 3519 OP *myop = PL_op; 3520 U32 flags = 0; 3521 XPV * const tXpv = PL_Xpv; 3522 I32 old_ss_ix = PL_savestack_ix; 3523 SV *errsv_save = NULL; 3524 3525 3526 if (!PL_psig_ptr[sig]) { 3527 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n", 3528 PL_sig_name[sig]); 3529 exit(sig); 3530 } 3531 3532 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) { 3533 /* Max number of items pushed there is 3*n or 4. We cannot fix 3534 infinity, so we fix 4 (in fact 5): */ 3535 if (PL_savestack_ix + 15 <= PL_savestack_max) { 3536 flags |= 1; 3537 PL_savestack_ix += 5; /* Protect save in progress. */ 3538 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL); 3539 } 3540 } 3541 /* sv_2cv is too complicated, try a simpler variant first: */ 3542 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig]))) 3543 || SvTYPE(cv) != SVt_PVCV) { 3544 HV *st; 3545 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD); 3546 } 3547 3548 if (!cv || !CvROOT(cv)) { 3549 const HEK * const hek = gv 3550 ? GvENAME_HEK(gv) 3551 : cv && CvNAMED(cv) 3552 ? CvNAME_HEK(cv) 3553 : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL; 3554 if (hek) 3555 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), 3556 "SIG%s handler \"%" HEKf "\" not defined.\n", 3557 PL_sig_name[sig], HEKfARG(hek)); 3558 /* diag_listed_as: SIG%s handler "%s" not defined */ 3559 else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), 3560 "SIG%s handler \"__ANON__\" not defined.\n", 3561 PL_sig_name[sig]); 3562 goto cleanup; 3563 } 3564 3565 sv = PL_psig_name[sig] 3566 ? SvREFCNT_inc_NN(PL_psig_name[sig]) 3567 : newSVpv(PL_sig_name[sig],0); 3568 flags |= 8; 3569 SAVEFREESV(sv); 3570 3571 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) { 3572 /* make sure our assumption about the size of the SAVEs are correct: 3573 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */ 3574 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix); 3575 } 3576 3577 PUSHSTACKi(PERLSI_SIGNAL); 3578 PUSHMARK(SP); 3579 PUSHs(sv); 3580 3581 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) 3582 { 3583 struct sigaction oact; 3584 3585 if (sip && sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) { 3586 HV *sih = newHV(); 3587 SV *rv = newRV_noinc(MUTABLE_SV(sih)); 3588 /* The siginfo fields signo, code, errno, pid, uid, 3589 * addr, status, and band are defined by POSIX/SUSv3. */ 3590 (void)hv_stores(sih, "signo", newSViv(sip->si_signo)); 3591 (void)hv_stores(sih, "code", newSViv(sip->si_code)); 3592 # ifdef HAS_SIGINFO_SI_ERRNO 3593 (void)hv_stores(sih, "errno", newSViv(sip->si_errno)); 3594 # endif 3595 # ifdef HAS_SIGINFO_SI_STATUS 3596 (void)hv_stores(sih, "status", newSViv(sip->si_status)); 3597 # endif 3598 # ifdef HAS_SIGINFO_SI_UID 3599 { 3600 SV *uid = newSV(0); 3601 sv_setuid(uid, sip->si_uid); 3602 (void)hv_stores(sih, "uid", uid); 3603 } 3604 # endif 3605 # ifdef HAS_SIGINFO_SI_PID 3606 (void)hv_stores(sih, "pid", newSViv(sip->si_pid)); 3607 # endif 3608 # ifdef HAS_SIGINFO_SI_ADDR 3609 (void)hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr))); 3610 # endif 3611 # ifdef HAS_SIGINFO_SI_BAND 3612 (void)hv_stores(sih, "band", newSViv(sip->si_band)); 3613 # endif 3614 EXTEND(SP, 2); 3615 PUSHs(rv); 3616 mPUSHp((char *)sip, sizeof(*sip)); 3617 3618 } 3619 } 3620 #endif 3621 3622 PUTBACK; 3623 3624 errsv_save = newSVsv(ERRSV); 3625 3626 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL); 3627 3628 POPSTACK; 3629 { 3630 SV * const errsv = ERRSV; 3631 if (SvTRUE_NN(errsv)) { 3632 SvREFCNT_dec(errsv_save); 3633 3634 #ifndef PERL_MICRO 3635 /* Handler "died", for example to get out of a restart-able read(). 3636 * Before we re-do that on its behalf re-enable the signal which was 3637 * blocked by the system when we entered. 3638 */ 3639 # ifdef HAS_SIGPROCMASK 3640 if (!safe) { 3641 /* safe signals called via dispatch_signals() set up a 3642 * savestack destructor, unblock_sigmask(), to 3643 * automatically unblock the handler at the end. If 3644 * instead we get here directly, we have to do it 3645 * ourselves 3646 */ 3647 sigset_t set; 3648 sigemptyset(&set); 3649 sigaddset(&set,sig); 3650 sigprocmask(SIG_UNBLOCK, &set, NULL); 3651 } 3652 # else 3653 /* Not clear if this will work */ 3654 /* XXX not clear if this should be protected by 'if (safe)' 3655 * too */ 3656 3657 (void)rsignal(sig, SIG_IGN); 3658 (void)rsignal(sig, PL_csighandlerp); 3659 # endif 3660 #endif /* !PERL_MICRO */ 3661 3662 die_sv(errsv); 3663 } 3664 else { 3665 sv_setsv(errsv, errsv_save); 3666 SvREFCNT_dec(errsv_save); 3667 } 3668 } 3669 3670 cleanup: 3671 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */ 3672 PL_savestack_ix = old_ss_ix; 3673 if (flags & 8) 3674 SvREFCNT_dec_NN(sv); 3675 PL_op = myop; /* Apparently not needed... */ 3676 3677 PL_Sv = tSv; /* Restore global temporaries. */ 3678 PL_Xpv = tXpv; 3679 return; 3680 } 3681 3682 3683 static void 3684 S_restore_magic(pTHX_ const void *p) 3685 { 3686 MGS* const mgs = SSPTR(PTR2IV(p), MGS*); 3687 SV* const sv = mgs->mgs_sv; 3688 bool bumped; 3689 3690 if (!sv) 3691 return; 3692 3693 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { 3694 SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */ 3695 if (mgs->mgs_flags) 3696 SvFLAGS(sv) |= mgs->mgs_flags; 3697 else 3698 mg_magical(sv); 3699 } 3700 3701 bumped = mgs->mgs_bumped; 3702 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */ 3703 3704 /* If we're still on top of the stack, pop us off. (That condition 3705 * will be satisfied if restore_magic was called explicitly, but *not* 3706 * if it's being called via leave_scope.) 3707 * The reason for doing this is that otherwise, things like sv_2cv() 3708 * may leave alloc gunk on the savestack, and some code 3709 * (e.g. sighandler) doesn't expect that... 3710 */ 3711 if (PL_savestack_ix == mgs->mgs_ss_ix) 3712 { 3713 UV popval = SSPOPUV; 3714 assert(popval == SAVEt_DESTRUCTOR_X); 3715 PL_savestack_ix -= 2; 3716 popval = SSPOPUV; 3717 assert((popval & SAVE_MASK) == SAVEt_ALLOC); 3718 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT; 3719 } 3720 if (bumped) { 3721 if (SvREFCNT(sv) == 1) { 3722 /* We hold the last reference to this SV, which implies that the 3723 SV was deleted as a side effect of the routines we called. 3724 So artificially keep it alive a bit longer. 3725 We avoid turning on the TEMP flag, which can cause the SV's 3726 buffer to get stolen (and maybe other stuff). */ 3727 sv_2mortal(sv); 3728 SvTEMP_off(sv); 3729 } 3730 else 3731 SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */ 3732 } 3733 } 3734 3735 /* clean up the mess created by Perl_sighandler(). 3736 * Note that this is only called during an exit in a signal handler; 3737 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually 3738 * skipped over. */ 3739 3740 static void 3741 S_unwind_handler_stack(pTHX_ const void *p) 3742 { 3743 PERL_UNUSED_ARG(p); 3744 3745 PL_savestack_ix -= 5; /* Unprotect save in progress. */ 3746 } 3747 3748 /* 3749 =for apidoc_section $magic 3750 =for apidoc magic_sethint 3751 3752 Triggered by a store to C<%^H>, records the key/value pair to 3753 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing 3754 anything that would need a deep copy. Maybe we should warn if we find a 3755 reference. 3756 3757 =cut 3758 */ 3759 int 3760 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg) 3761 { 3762 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr) 3763 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP); 3764 3765 PERL_ARGS_ASSERT_MAGIC_SETHINT; 3766 3767 /* mg->mg_obj isn't being used. If needed, it would be possible to store 3768 an alternative leaf in there, with PL_compiling.cop_hints being used if 3769 it's NULL. If needed for threads, the alternative could lock a mutex, 3770 or take other more complex action. */ 3771 3772 /* Something changed in %^H, so it will need to be restored on scope exit. 3773 Doing this here saves a lot of doing it manually in perl code (and 3774 forgetting to do it, and consequent subtle errors. */ 3775 PL_hints |= HINT_LOCALIZE_HH; 3776 CopHINTHASH_set(&PL_compiling, 3777 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0)); 3778 magic_sethint_feature(key, NULL, 0, sv, 0); 3779 return 0; 3780 } 3781 3782 /* 3783 =for apidoc magic_clearhint 3784 3785 Triggered by a delete from C<%^H>, records the key to 3786 C<PL_compiling.cop_hints_hash>. 3787 3788 =cut 3789 */ 3790 int 3791 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg) 3792 { 3793 PERL_ARGS_ASSERT_MAGIC_CLEARHINT; 3794 PERL_UNUSED_ARG(sv); 3795 3796 PL_hints |= HINT_LOCALIZE_HH; 3797 CopHINTHASH_set(&PL_compiling, 3798 mg->mg_len == HEf_SVKEY 3799 ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling), 3800 MUTABLE_SV(mg->mg_ptr), 0, 0) 3801 : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling), 3802 mg->mg_ptr, mg->mg_len, 0, 0)); 3803 if (mg->mg_len == HEf_SVKEY) 3804 magic_sethint_feature(MUTABLE_SV(mg->mg_ptr), NULL, 0, NULL, FALSE); 3805 else 3806 magic_sethint_feature(NULL, mg->mg_ptr, mg->mg_len, NULL, FALSE); 3807 return 0; 3808 } 3809 3810 /* 3811 =for apidoc magic_clearhints 3812 3813 Triggered by clearing C<%^H>, resets C<PL_compiling.cop_hints_hash>. 3814 3815 =cut 3816 */ 3817 int 3818 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg) 3819 { 3820 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS; 3821 PERL_UNUSED_ARG(sv); 3822 PERL_UNUSED_ARG(mg); 3823 cophh_free(CopHINTHASH_get(&PL_compiling)); 3824 CopHINTHASH_set(&PL_compiling, cophh_new_empty()); 3825 CLEARFEATUREBITS(); 3826 return 0; 3827 } 3828 3829 int 3830 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv, 3831 const char *name, I32 namlen) 3832 { 3833 MAGIC *nmg; 3834 3835 PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER; 3836 PERL_UNUSED_ARG(sv); 3837 PERL_UNUSED_ARG(name); 3838 PERL_UNUSED_ARG(namlen); 3839 3840 sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0); 3841 nmg = mg_find(nsv, mg->mg_type); 3842 assert(nmg); 3843 if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj); 3844 nmg->mg_ptr = mg->mg_ptr; 3845 nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj); 3846 nmg->mg_flags |= MGf_REFCOUNTED; 3847 return 1; 3848 } 3849 3850 int 3851 Perl_magic_setdebugvar(pTHX_ SV *sv, MAGIC *mg) { 3852 PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR; 3853 3854 #if DBVARMG_SINGLE != 0 3855 assert(mg->mg_private >= DBVARMG_SINGLE); 3856 #endif 3857 assert(mg->mg_private < DBVARMG_COUNT); 3858 3859 PL_DBcontrol[mg->mg_private] = SvIV_nomg(sv); 3860 3861 return 1; 3862 } 3863 3864 int 3865 Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) { 3866 PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR; 3867 3868 #if DBVARMG_SINGLE != 0 3869 assert(mg->mg_private >= DBVARMG_SINGLE); 3870 #endif 3871 assert(mg->mg_private < DBVARMG_COUNT); 3872 sv_setiv(sv, PL_DBcontrol[mg->mg_private]); 3873 3874 return 0; 3875 } 3876 3877 /* 3878 * ex: set ts=8 sts=4 sw=4 et: 3879 */ 3880