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