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