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 case '/': 1081 break; 1082 case '[': 1083 sv_setiv(sv, 0); 1084 break; 1085 case '|': 1086 if (GvIO(PL_defoutgv)) 1087 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 ); 1088 break; 1089 case '\\': 1090 if (PL_ors_sv) 1091 sv_copypv(sv, PL_ors_sv); 1092 else 1093 sv_setsv(sv, &PL_sv_undef); 1094 break; 1095 case '$': /* $$ */ 1096 { 1097 IV const pid = (IV)PerlProc_getpid(); 1098 if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) { 1099 /* never set manually, or at least not since last fork */ 1100 sv_setiv(sv, pid); 1101 /* never unsafe, even if reading in a tainted expression */ 1102 SvTAINTED_off(sv); 1103 } 1104 /* else a value has been assigned manually, so do nothing */ 1105 } 1106 break; 1107 case '<': 1108 sv_setuid(sv, PerlProc_getuid()); 1109 break; 1110 case '>': 1111 sv_setuid(sv, PerlProc_geteuid()); 1112 break; 1113 case '(': 1114 sv_setgid(sv, PerlProc_getgid()); 1115 goto add_groups; 1116 case ')': 1117 sv_setgid(sv, PerlProc_getegid()); 1118 add_groups: 1119 #ifdef HAS_GETGROUPS 1120 { 1121 Groups_t *gary = NULL; 1122 I32 i, num_groups = getgroups(0, gary); 1123 Newx(gary, num_groups, Groups_t); 1124 num_groups = getgroups(num_groups, gary); 1125 for (i = 0; i < num_groups; i++) 1126 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]); 1127 Safefree(gary); 1128 } 1129 (void)SvIOK_on(sv); /* what a wonderful hack! */ 1130 #endif 1131 break; 1132 case '0': 1133 break; 1134 } 1135 return 0; 1136 } 1137 1138 int 1139 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg) 1140 { 1141 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr; 1142 1143 PERL_ARGS_ASSERT_MAGIC_GETUVAR; 1144 1145 if (uf && uf->uf_val) 1146 (*uf->uf_val)(aTHX_ uf->uf_index, sv); 1147 return 0; 1148 } 1149 1150 int 1151 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) 1152 { 1153 dVAR; 1154 STRLEN len = 0, klen; 1155 const char * const key = MgPV_const(mg,klen); 1156 const char *s = ""; 1157 1158 PERL_ARGS_ASSERT_MAGIC_SETENV; 1159 1160 SvGETMAGIC(sv); 1161 if (SvOK(sv)) { 1162 /* defined environment variables are byte strings; unfortunately 1163 there is no SvPVbyte_force_nomg(), so we must do this piecewise */ 1164 (void)SvPV_force_nomg_nolen(sv); 1165 sv_utf8_downgrade(sv, /* fail_ok */ TRUE); 1166 if (SvUTF8(sv)) { 1167 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv"); 1168 SvUTF8_off(sv); 1169 } 1170 s = SvPVX(sv); 1171 len = SvCUR(sv); 1172 } 1173 my_setenv(key, s); /* does the deed */ 1174 1175 #ifdef DYNAMIC_ENV_FETCH 1176 /* We just undefd an environment var. Is a replacement */ 1177 /* waiting in the wings? */ 1178 if (!len) { 1179 SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE); 1180 if (valp) 1181 s = SvOK(*valp) ? SvPV_const(*valp, len) : ""; 1182 } 1183 #endif 1184 1185 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS) 1186 /* And you'll never guess what the dog had */ 1187 /* in its mouth... */ 1188 if (TAINTING_get) { 1189 MgTAINTEDDIR_off(mg); 1190 #ifdef VMS 1191 if (s && klen == 8 && strEQ(key, "DCL$PATH")) { 1192 char pathbuf[256], eltbuf[256], *cp, *elt; 1193 int i = 0, j = 0; 1194 1195 my_strlcpy(eltbuf, s, sizeof(eltbuf)); 1196 elt = eltbuf; 1197 do { /* DCL$PATH may be a search list */ 1198 while (1) { /* as may dev portion of any element */ 1199 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) { 1200 if ( *(cp+1) == '.' || *(cp+1) == '-' || 1201 cando_by_name(S_IWUSR,0,elt) ) { 1202 MgTAINTEDDIR_on(mg); 1203 return 0; 1204 } 1205 } 1206 if ((cp = strchr(elt, ':')) != NULL) 1207 *cp = '\0'; 1208 if (my_trnlnm(elt, eltbuf, j++)) 1209 elt = eltbuf; 1210 else 1211 break; 1212 } 1213 j = 0; 1214 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf)); 1215 } 1216 #endif /* VMS */ 1217 if (s && klen == 4 && strEQ(key,"PATH")) { 1218 const char * const strend = s + len; 1219 1220 while (s < strend) { 1221 char tmpbuf[256]; 1222 Stat_t st; 1223 I32 i; 1224 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */ 1225 const char path_sep = '|'; 1226 #else 1227 const char path_sep = ':'; 1228 #endif 1229 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, 1230 s, strend, path_sep, &i); 1231 s++; 1232 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */ 1233 #ifdef VMS 1234 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */ 1235 #else 1236 || *tmpbuf != '/' /* no starting slash -- assume relative path */ 1237 #endif 1238 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) { 1239 MgTAINTEDDIR_on(mg); 1240 return 0; 1241 } 1242 } 1243 } 1244 } 1245 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */ 1246 1247 return 0; 1248 } 1249 1250 int 1251 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg) 1252 { 1253 PERL_ARGS_ASSERT_MAGIC_CLEARENV; 1254 PERL_UNUSED_ARG(sv); 1255 my_setenv(MgPV_nolen_const(mg),NULL); 1256 return 0; 1257 } 1258 1259 int 1260 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) 1261 { 1262 dVAR; 1263 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV; 1264 PERL_UNUSED_ARG(mg); 1265 #if defined(VMS) 1266 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); 1267 #else 1268 if (PL_localizing) { 1269 HE* entry; 1270 my_clearenv(); 1271 hv_iterinit(MUTABLE_HV(sv)); 1272 while ((entry = hv_iternext(MUTABLE_HV(sv)))) { 1273 I32 keylen; 1274 my_setenv(hv_iterkey(entry, &keylen), 1275 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry))); 1276 } 1277 } 1278 #endif 1279 return 0; 1280 } 1281 1282 int 1283 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) 1284 { 1285 dVAR; 1286 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV; 1287 PERL_UNUSED_ARG(sv); 1288 PERL_UNUSED_ARG(mg); 1289 #if defined(VMS) 1290 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); 1291 #else 1292 my_clearenv(); 1293 #endif 1294 return 0; 1295 } 1296 1297 #ifndef PERL_MICRO 1298 #ifdef HAS_SIGPROCMASK 1299 static void 1300 restore_sigmask(pTHX_ SV *save_sv) 1301 { 1302 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv ); 1303 (void)sigprocmask(SIG_SETMASK, ossetp, NULL); 1304 } 1305 #endif 1306 int 1307 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) 1308 { 1309 dVAR; 1310 /* Are we fetching a signal entry? */ 1311 int i = (I16)mg->mg_private; 1312 1313 PERL_ARGS_ASSERT_MAGIC_GETSIG; 1314 1315 if (!i) { 1316 STRLEN siglen; 1317 const char * sig = MgPV_const(mg, siglen); 1318 mg->mg_private = i = whichsig_pvn(sig, siglen); 1319 } 1320 1321 if (i > 0) { 1322 if(PL_psig_ptr[i]) 1323 sv_setsv(sv,PL_psig_ptr[i]); 1324 else { 1325 Sighandler_t sigstate = rsignal_state(i); 1326 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS 1327 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) 1328 sigstate = SIG_IGN; 1329 #endif 1330 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS 1331 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) 1332 sigstate = SIG_DFL; 1333 #endif 1334 /* cache state so we don't fetch it again */ 1335 if(sigstate == (Sighandler_t) SIG_IGN) 1336 sv_setpvs(sv,"IGNORE"); 1337 else 1338 sv_setsv(sv,&PL_sv_undef); 1339 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv); 1340 SvTEMP_off(sv); 1341 } 1342 } 1343 return 0; 1344 } 1345 int 1346 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg) 1347 { 1348 PERL_ARGS_ASSERT_MAGIC_CLEARSIG; 1349 1350 magic_setsig(NULL, mg); 1351 return sv_unmagic(sv, mg->mg_type); 1352 } 1353 1354 Signal_t 1355 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) 1356 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL) 1357 #else 1358 Perl_csighandler(int sig) 1359 #endif 1360 { 1361 #ifdef PERL_GET_SIG_CONTEXT 1362 dTHXa(PERL_GET_SIG_CONTEXT); 1363 #else 1364 dTHX; 1365 #endif 1366 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS 1367 (void) rsignal(sig, PL_csighandlerp); 1368 if (PL_sig_ignoring[sig]) return; 1369 #endif 1370 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS 1371 if (PL_sig_defaulting[sig]) 1372 #ifdef KILL_BY_SIGPRC 1373 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG); 1374 #else 1375 exit(1); 1376 #endif 1377 #endif 1378 if ( 1379 #ifdef SIGILL 1380 sig == SIGILL || 1381 #endif 1382 #ifdef SIGBUS 1383 sig == SIGBUS || 1384 #endif 1385 #ifdef SIGSEGV 1386 sig == SIGSEGV || 1387 #endif 1388 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)) 1389 /* Call the perl level handler now-- 1390 * with risk we may be in malloc() or being destructed etc. */ 1391 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) 1392 (*PL_sighandlerp)(sig, NULL, NULL); 1393 #else 1394 (*PL_sighandlerp)(sig); 1395 #endif 1396 else { 1397 if (!PL_psig_pend) return; 1398 /* Set a flag to say this signal is pending, that is awaiting delivery after 1399 * the current Perl opcode completes */ 1400 PL_psig_pend[sig]++; 1401 1402 #ifndef SIG_PENDING_DIE_COUNT 1403 # define SIG_PENDING_DIE_COUNT 120 1404 #endif 1405 /* Add one to say _a_ signal is pending */ 1406 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT) 1407 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded", 1408 (unsigned long)SIG_PENDING_DIE_COUNT); 1409 } 1410 } 1411 1412 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) 1413 void 1414 Perl_csighandler_init(void) 1415 { 1416 int sig; 1417 if (PL_sig_handlers_initted) return; 1418 1419 for (sig = 1; sig < SIG_SIZE; sig++) { 1420 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS 1421 dTHX; 1422 PL_sig_defaulting[sig] = 1; 1423 (void) rsignal(sig, PL_csighandlerp); 1424 #endif 1425 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS 1426 PL_sig_ignoring[sig] = 0; 1427 #endif 1428 } 1429 PL_sig_handlers_initted = 1; 1430 } 1431 #endif 1432 1433 #if defined HAS_SIGPROCMASK 1434 static void 1435 unblock_sigmask(pTHX_ void* newset) 1436 { 1437 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL); 1438 } 1439 #endif 1440 1441 void 1442 Perl_despatch_signals(pTHX) 1443 { 1444 dVAR; 1445 int sig; 1446 PL_sig_pending = 0; 1447 for (sig = 1; sig < SIG_SIZE; sig++) { 1448 if (PL_psig_pend[sig]) { 1449 dSAVE_ERRNO; 1450 #ifdef HAS_SIGPROCMASK 1451 /* From sigaction(2) (FreeBSD man page): 1452 * | Signal routines normally execute with the signal that 1453 * | caused their invocation blocked, but other signals may 1454 * | yet occur. 1455 * Emulation of this behavior (from within Perl) is enabled 1456 * using sigprocmask 1457 */ 1458 int was_blocked; 1459 sigset_t newset, oldset; 1460 1461 sigemptyset(&newset); 1462 sigaddset(&newset, sig); 1463 sigprocmask(SIG_BLOCK, &newset, &oldset); 1464 was_blocked = sigismember(&oldset, sig); 1465 if (!was_blocked) { 1466 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t)); 1467 ENTER; 1468 SAVEFREESV(save_sv); 1469 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv)); 1470 } 1471 #endif 1472 PL_psig_pend[sig] = 0; 1473 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) 1474 (*PL_sighandlerp)(sig, NULL, NULL); 1475 #else 1476 (*PL_sighandlerp)(sig); 1477 #endif 1478 #ifdef HAS_SIGPROCMASK 1479 if (!was_blocked) 1480 LEAVE; 1481 #endif 1482 RESTORE_ERRNO; 1483 } 1484 } 1485 } 1486 1487 /* sv of NULL signifies that we're acting as magic_clearsig. */ 1488 int 1489 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) 1490 { 1491 dVAR; 1492 I32 i; 1493 SV** svp = NULL; 1494 /* Need to be careful with SvREFCNT_dec(), because that can have side 1495 * effects (due to closures). We must make sure that the new disposition 1496 * is in place before it is called. 1497 */ 1498 SV* to_dec = NULL; 1499 STRLEN len; 1500 #ifdef HAS_SIGPROCMASK 1501 sigset_t set, save; 1502 SV* save_sv; 1503 #endif 1504 const char *s = MgPV_const(mg,len); 1505 1506 PERL_ARGS_ASSERT_MAGIC_SETSIG; 1507 1508 if (*s == '_') { 1509 if (memEQs(s, len, "__DIE__")) 1510 svp = &PL_diehook; 1511 else if (memEQs(s, len, "__WARN__") 1512 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) { 1513 /* Merge the existing behaviours, which are as follows: 1514 magic_setsig, we always set svp to &PL_warnhook 1515 (hence we always change the warnings handler) 1516 For magic_clearsig, we don't change the warnings handler if it's 1517 set to the &PL_warnhook. */ 1518 svp = &PL_warnhook; 1519 } else if (sv) { 1520 SV *tmp = sv_newmortal(); 1521 Perl_croak(aTHX_ "No such hook: %s", 1522 pv_pretty(tmp, s, len, 0, NULL, NULL, 0)); 1523 } 1524 i = 0; 1525 if (svp && *svp) { 1526 if (*svp != PERL_WARNHOOK_FATAL) 1527 to_dec = *svp; 1528 *svp = NULL; 1529 } 1530 } 1531 else { 1532 i = (I16)mg->mg_private; 1533 if (!i) { 1534 i = whichsig_pvn(s, len); /* ...no, a brick */ 1535 mg->mg_private = (U16)i; 1536 } 1537 if (i <= 0) { 1538 if (sv) { 1539 SV *tmp = sv_newmortal(); 1540 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", 1541 pv_pretty(tmp, s, len, 0, NULL, NULL, 0)); 1542 } 1543 return 0; 1544 } 1545 #ifdef HAS_SIGPROCMASK 1546 /* Avoid having the signal arrive at a bad time, if possible. */ 1547 sigemptyset(&set); 1548 sigaddset(&set,i); 1549 sigprocmask(SIG_BLOCK, &set, &save); 1550 ENTER; 1551 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t)); 1552 SAVEFREESV(save_sv); 1553 SAVEDESTRUCTOR_X(restore_sigmask, save_sv); 1554 #endif 1555 PERL_ASYNC_CHECK(); 1556 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) 1557 if (!PL_sig_handlers_initted) Perl_csighandler_init(); 1558 #endif 1559 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS 1560 PL_sig_ignoring[i] = 0; 1561 #endif 1562 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS 1563 PL_sig_defaulting[i] = 0; 1564 #endif 1565 to_dec = PL_psig_ptr[i]; 1566 if (sv) { 1567 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv); 1568 SvTEMP_off(sv); /* Make sure it doesn't go away on us */ 1569 1570 /* Signals don't change name during the program's execution, so once 1571 they're cached in the appropriate slot of PL_psig_name, they can 1572 stay there. 1573 1574 Ideally we'd find some way of making SVs at (C) compile time, or 1575 at least, doing most of the work. */ 1576 if (!PL_psig_name[i]) { 1577 PL_psig_name[i] = newSVpvn(s, len); 1578 SvREADONLY_on(PL_psig_name[i]); 1579 } 1580 } else { 1581 SvREFCNT_dec(PL_psig_name[i]); 1582 PL_psig_name[i] = NULL; 1583 PL_psig_ptr[i] = NULL; 1584 } 1585 } 1586 if (sv && (isGV_with_GP(sv) || SvROK(sv))) { 1587 if (i) { 1588 (void)rsignal(i, PL_csighandlerp); 1589 } 1590 else 1591 *svp = SvREFCNT_inc_simple_NN(sv); 1592 } else { 1593 if (sv && SvOK(sv)) { 1594 s = SvPV_force(sv, len); 1595 } else { 1596 sv = NULL; 1597 } 1598 if (sv && memEQs(s, len,"IGNORE")) { 1599 if (i) { 1600 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS 1601 PL_sig_ignoring[i] = 1; 1602 (void)rsignal(i, PL_csighandlerp); 1603 #else 1604 (void)rsignal(i, (Sighandler_t) SIG_IGN); 1605 #endif 1606 } 1607 } 1608 else if (!sv || memEQs(s, len,"DEFAULT") || !len) { 1609 if (i) { 1610 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS 1611 PL_sig_defaulting[i] = 1; 1612 (void)rsignal(i, PL_csighandlerp); 1613 #else 1614 (void)rsignal(i, (Sighandler_t) SIG_DFL); 1615 #endif 1616 } 1617 } 1618 else { 1619 /* 1620 * We should warn if HINT_STRICT_REFS, but without 1621 * access to a known hint bit in a known OP, we can't 1622 * tell whether HINT_STRICT_REFS is in force or not. 1623 */ 1624 if (!strchr(s,':') && !strchr(s,'\'')) 1625 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"), 1626 SV_GMAGIC); 1627 if (i) 1628 (void)rsignal(i, PL_csighandlerp); 1629 else 1630 *svp = SvREFCNT_inc_simple_NN(sv); 1631 } 1632 } 1633 1634 #ifdef HAS_SIGPROCMASK 1635 if(i) 1636 LEAVE; 1637 #endif 1638 SvREFCNT_dec(to_dec); 1639 return 0; 1640 } 1641 #endif /* !PERL_MICRO */ 1642 1643 int 1644 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg) 1645 { 1646 dVAR; 1647 PERL_ARGS_ASSERT_MAGIC_SETISA; 1648 PERL_UNUSED_ARG(sv); 1649 1650 /* Skip _isaelem because _isa will handle it shortly */ 1651 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem) 1652 return 0; 1653 1654 return magic_clearisa(NULL, mg); 1655 } 1656 1657 /* sv of NULL signifies that we're acting as magic_setisa. */ 1658 int 1659 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg) 1660 { 1661 dVAR; 1662 HV* stash; 1663 1664 PERL_ARGS_ASSERT_MAGIC_CLEARISA; 1665 1666 /* Bail out if destruction is going on */ 1667 if(PL_phase == PERL_PHASE_DESTRUCT) return 0; 1668 1669 if (sv) 1670 av_clear(MUTABLE_AV(sv)); 1671 1672 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj)) 1673 /* This occurs with setisa_elem magic, which calls this 1674 same function. */ 1675 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa); 1676 1677 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */ 1678 SV **svp = AvARRAY((AV *)mg->mg_obj); 1679 I32 items = AvFILLp((AV *)mg->mg_obj) + 1; 1680 while (items--) { 1681 stash = GvSTASH((GV *)*svp++); 1682 if (stash && HvENAME(stash)) mro_isa_changed_in(stash); 1683 } 1684 1685 return 0; 1686 } 1687 1688 stash = GvSTASH( 1689 (const GV *)mg->mg_obj 1690 ); 1691 1692 /* The stash may have been detached from the symbol table, so check its 1693 name before doing anything. */ 1694 if (stash && HvENAME_get(stash)) 1695 mro_isa_changed_in(stash); 1696 1697 return 0; 1698 } 1699 1700 int 1701 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg) 1702 { 1703 HV * const hv = MUTABLE_HV(LvTARG(sv)); 1704 I32 i = 0; 1705 1706 PERL_ARGS_ASSERT_MAGIC_GETNKEYS; 1707 PERL_UNUSED_ARG(mg); 1708 1709 if (hv) { 1710 (void) hv_iterinit(hv); 1711 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) 1712 i = HvUSEDKEYS(hv); 1713 else { 1714 while (hv_iternext(hv)) 1715 i++; 1716 } 1717 } 1718 1719 sv_setiv(sv, (IV)i); 1720 return 0; 1721 } 1722 1723 int 1724 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg) 1725 { 1726 PERL_ARGS_ASSERT_MAGIC_SETNKEYS; 1727 PERL_UNUSED_ARG(mg); 1728 if (LvTARG(sv)) { 1729 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv)); 1730 } 1731 return 0; 1732 } 1733 1734 /* 1735 =for apidoc magic_methcall 1736 1737 Invoke a magic method (like FETCH). 1738 1739 C<sv> and C<mg> are the tied thingy and the tie magic. 1740 1741 C<meth> is the name of the method to call. 1742 1743 C<argc> is the number of args (in addition to $self) to pass to the method. 1744 1745 The C<flags> can be: 1746 1747 G_DISCARD invoke method with G_DISCARD flag and don't 1748 return a value 1749 G_UNDEF_FILL fill the stack with argc pointers to 1750 PL_sv_undef 1751 1752 The arguments themselves are any values following the C<flags> argument. 1753 1754 Returns the SV (if any) returned by the method, or NULL on failure. 1755 1756 1757 =cut 1758 */ 1759 1760 SV* 1761 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, 1762 U32 argc, ...) 1763 { 1764 dVAR; 1765 dSP; 1766 SV* ret = NULL; 1767 1768 PERL_ARGS_ASSERT_MAGIC_METHCALL; 1769 1770 ENTER; 1771 1772 if (flags & G_WRITING_TO_STDERR) { 1773 SAVETMPS; 1774 1775 save_re_context(); 1776 SAVESPTR(PL_stderrgv); 1777 PL_stderrgv = NULL; 1778 } 1779 1780 PUSHSTACKi(PERLSI_MAGIC); 1781 PUSHMARK(SP); 1782 1783 EXTEND(SP, argc+1); 1784 PUSHs(SvTIED_obj(sv, mg)); 1785 if (flags & G_UNDEF_FILL) { 1786 while (argc--) { 1787 PUSHs(&PL_sv_undef); 1788 } 1789 } else if (argc > 0) { 1790 va_list args; 1791 va_start(args, argc); 1792 1793 do { 1794 SV *const sv = va_arg(args, SV *); 1795 PUSHs(sv); 1796 } while (--argc); 1797 1798 va_end(args); 1799 } 1800 PUTBACK; 1801 if (flags & G_DISCARD) { 1802 call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED); 1803 } 1804 else { 1805 if (call_sv(meth, G_SCALAR|G_METHOD_NAMED)) 1806 ret = *PL_stack_sp--; 1807 } 1808 POPSTACK; 1809 if (flags & G_WRITING_TO_STDERR) 1810 FREETMPS; 1811 LEAVE; 1812 return ret; 1813 } 1814 1815 /* wrapper for magic_methcall that creates the first arg */ 1816 1817 STATIC SV* 1818 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, 1819 int n, SV *val) 1820 { 1821 dVAR; 1822 SV* arg1 = NULL; 1823 1824 PERL_ARGS_ASSERT_MAGIC_METHCALL1; 1825 1826 if (mg->mg_ptr) { 1827 if (mg->mg_len >= 0) { 1828 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP); 1829 } 1830 else if (mg->mg_len == HEf_SVKEY) 1831 arg1 = MUTABLE_SV(mg->mg_ptr); 1832 } 1833 else if (mg->mg_type == PERL_MAGIC_tiedelem) { 1834 arg1 = newSViv((IV)(mg->mg_len)); 1835 sv_2mortal(arg1); 1836 } 1837 if (!arg1) { 1838 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val); 1839 } 1840 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val); 1841 } 1842 1843 STATIC int 1844 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth) 1845 { 1846 dVAR; 1847 SV* ret; 1848 1849 PERL_ARGS_ASSERT_MAGIC_METHPACK; 1850 1851 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL); 1852 if (ret) 1853 sv_setsv(sv, ret); 1854 return 0; 1855 } 1856 1857 int 1858 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg) 1859 { 1860 PERL_ARGS_ASSERT_MAGIC_GETPACK; 1861 1862 if (mg->mg_type == PERL_MAGIC_tiedelem) 1863 mg->mg_flags |= MGf_GSKIP; 1864 magic_methpack(sv,mg,SV_CONST(FETCH)); 1865 return 0; 1866 } 1867 1868 int 1869 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg) 1870 { 1871 dVAR; 1872 MAGIC *tmg; 1873 SV *val; 1874 1875 PERL_ARGS_ASSERT_MAGIC_SETPACK; 1876 1877 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to 1878 * STORE() is not $val, but rather a PVLV (the sv in this call), whose 1879 * public flags indicate its value based on copying from $val. Doing 1880 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us. 1881 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes 1882 * wrong if $val happened to be tainted, as sv hasn't got magic 1883 * enabled, even though taint magic is in the chain. In which case, 1884 * fake up a temporary tainted value (this is easier than temporarily 1885 * re-enabling magic on sv). */ 1886 1887 if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint)) 1888 && (tmg->mg_len & 1)) 1889 { 1890 val = sv_mortalcopy(sv); 1891 SvTAINTED_on(val); 1892 } 1893 else 1894 val = sv; 1895 1896 magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val); 1897 return 0; 1898 } 1899 1900 int 1901 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg) 1902 { 1903 PERL_ARGS_ASSERT_MAGIC_CLEARPACK; 1904 1905 if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0; 1906 return magic_methpack(sv,mg,SV_CONST(DELETE)); 1907 } 1908 1909 1910 U32 1911 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg) 1912 { 1913 dVAR; 1914 I32 retval = 0; 1915 SV* retsv; 1916 1917 PERL_ARGS_ASSERT_MAGIC_SIZEPACK; 1918 1919 retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL); 1920 if (retsv) { 1921 retval = SvIV(retsv)-1; 1922 if (retval < -1) 1923 Perl_croak(aTHX_ "FETCHSIZE returned a negative value"); 1924 } 1925 return (U32) retval; 1926 } 1927 1928 int 1929 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg) 1930 { 1931 dVAR; 1932 1933 PERL_ARGS_ASSERT_MAGIC_WIPEPACK; 1934 1935 Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0); 1936 return 0; 1937 } 1938 1939 int 1940 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key) 1941 { 1942 dVAR; 1943 SV* ret; 1944 1945 PERL_ARGS_ASSERT_MAGIC_NEXTPACK; 1946 1947 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key) 1948 : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0); 1949 if (ret) 1950 sv_setsv(key,ret); 1951 return 0; 1952 } 1953 1954 int 1955 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg) 1956 { 1957 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK; 1958 1959 return magic_methpack(sv,mg,SV_CONST(EXISTS)); 1960 } 1961 1962 SV * 1963 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) 1964 { 1965 dVAR; 1966 SV *retval; 1967 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg); 1968 HV * const pkg = SvSTASH((const SV *)SvRV(tied)); 1969 1970 PERL_ARGS_ASSERT_MAGIC_SCALARPACK; 1971 1972 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) { 1973 SV *key; 1974 if (HvEITER_get(hv)) 1975 /* we are in an iteration so the hash cannot be empty */ 1976 return &PL_sv_yes; 1977 /* no xhv_eiter so now use FIRSTKEY */ 1978 key = sv_newmortal(); 1979 magic_nextpack(MUTABLE_SV(hv), mg, key); 1980 HvEITER_set(hv, NULL); /* need to reset iterator */ 1981 return SvOK(key) ? &PL_sv_yes : &PL_sv_no; 1982 } 1983 1984 /* there is a SCALAR method that we can call */ 1985 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0); 1986 if (!retval) 1987 retval = &PL_sv_undef; 1988 return retval; 1989 } 1990 1991 int 1992 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) 1993 { 1994 dVAR; 1995 SV **svp; 1996 1997 PERL_ARGS_ASSERT_MAGIC_SETDBLINE; 1998 1999 /* The magic ptr/len for the debugger's hash should always be an SV. */ 2000 if (UNLIKELY(mg->mg_len != HEf_SVKEY)) { 2001 Perl_croak(aTHX_ "panic: magic_setdbline len=%"IVdf", ptr='%s'", 2002 (IV)mg->mg_len, mg->mg_ptr); 2003 } 2004 2005 /* Use sv_2iv instead of SvIV() as the former generates smaller code, and 2006 setting/clearing debugger breakpoints is not a hot path. */ 2007 svp = av_fetch(MUTABLE_AV(mg->mg_obj), 2008 sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE); 2009 2010 if (svp && SvIOKp(*svp)) { 2011 OP * const o = INT2PTR(OP*,SvIVX(*svp)); 2012 if (o) { 2013 #ifdef PERL_DEBUG_READONLY_OPS 2014 Slab_to_rw(OpSLAB(o)); 2015 #endif 2016 /* set or clear breakpoint in the relevant control op */ 2017 if (SvTRUE(sv)) 2018 o->op_flags |= OPf_SPECIAL; 2019 else 2020 o->op_flags &= ~OPf_SPECIAL; 2021 #ifdef PERL_DEBUG_READONLY_OPS 2022 Slab_to_ro(OpSLAB(o)); 2023 #endif 2024 } 2025 } 2026 return 0; 2027 } 2028 2029 int 2030 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg) 2031 { 2032 dVAR; 2033 AV * const obj = MUTABLE_AV(mg->mg_obj); 2034 2035 PERL_ARGS_ASSERT_MAGIC_GETARYLEN; 2036 2037 if (obj) { 2038 sv_setiv(sv, AvFILL(obj)); 2039 } else { 2040 sv_setsv(sv, NULL); 2041 } 2042 return 0; 2043 } 2044 2045 int 2046 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg) 2047 { 2048 dVAR; 2049 AV * const obj = MUTABLE_AV(mg->mg_obj); 2050 2051 PERL_ARGS_ASSERT_MAGIC_SETARYLEN; 2052 2053 if (obj) { 2054 av_fill(obj, SvIV(sv)); 2055 } else { 2056 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 2057 "Attempt to set length of freed array"); 2058 } 2059 return 0; 2060 } 2061 2062 int 2063 Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg) 2064 { 2065 dVAR; 2066 2067 PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P; 2068 PERL_UNUSED_ARG(sv); 2069 2070 /* Reset the iterator when the array is cleared */ 2071 #if IVSIZE == I32SIZE 2072 *((IV *) &(mg->mg_len)) = 0; 2073 #else 2074 if (mg->mg_ptr) 2075 *((IV *) mg->mg_ptr) = 0; 2076 #endif 2077 2078 return 0; 2079 } 2080 2081 int 2082 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg) 2083 { 2084 dVAR; 2085 2086 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P; 2087 PERL_UNUSED_ARG(sv); 2088 2089 /* during global destruction, mg_obj may already have been freed */ 2090 if (PL_in_clean_all) 2091 return 0; 2092 2093 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen); 2094 2095 if (mg) { 2096 /* arylen scalar holds a pointer back to the array, but doesn't own a 2097 reference. Hence the we (the array) are about to go away with it 2098 still pointing at us. Clear its pointer, else it would be pointing 2099 at free memory. See the comment in sv_magic about reference loops, 2100 and why it can't own a reference to us. */ 2101 mg->mg_obj = 0; 2102 } 2103 return 0; 2104 } 2105 2106 int 2107 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) 2108 { 2109 dVAR; 2110 SV* const lsv = LvTARG(sv); 2111 MAGIC * const found = mg_find_mglob(lsv); 2112 2113 PERL_ARGS_ASSERT_MAGIC_GETPOS; 2114 PERL_UNUSED_ARG(mg); 2115 2116 if (found && found->mg_len != -1) { 2117 STRLEN i = found->mg_len; 2118 if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv)) 2119 i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN); 2120 sv_setuv(sv, i); 2121 return 0; 2122 } 2123 sv_setsv(sv,NULL); 2124 return 0; 2125 } 2126 2127 int 2128 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) 2129 { 2130 dVAR; 2131 SV* const lsv = LvTARG(sv); 2132 SSize_t pos; 2133 STRLEN len; 2134 STRLEN ulen = 0; 2135 MAGIC* found; 2136 const char *s; 2137 2138 PERL_ARGS_ASSERT_MAGIC_SETPOS; 2139 PERL_UNUSED_ARG(mg); 2140 2141 found = mg_find_mglob(lsv); 2142 if (!found) { 2143 if (!SvOK(sv)) 2144 return 0; 2145 found = sv_magicext_mglob(lsv); 2146 } 2147 else if (!SvOK(sv)) { 2148 found->mg_len = -1; 2149 return 0; 2150 } 2151 s = SvPV_const(lsv, len); 2152 2153 pos = SvIV(sv); 2154 2155 if (DO_UTF8(lsv)) { 2156 ulen = sv_or_pv_len_utf8(lsv, s, len); 2157 if (ulen) 2158 len = ulen; 2159 } 2160 2161 if (pos < 0) { 2162 pos += len; 2163 if (pos < 0) 2164 pos = 0; 2165 } 2166 else if (pos > (SSize_t)len) 2167 pos = len; 2168 2169 found->mg_len = pos; 2170 found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES); 2171 2172 return 0; 2173 } 2174 2175 int 2176 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) 2177 { 2178 STRLEN len; 2179 SV * const lsv = LvTARG(sv); 2180 const char * const tmps = SvPV_const(lsv,len); 2181 STRLEN offs = LvTARGOFF(sv); 2182 STRLEN rem = LvTARGLEN(sv); 2183 const bool negoff = LvFLAGS(sv) & 1; 2184 const bool negrem = LvFLAGS(sv) & 2; 2185 2186 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR; 2187 PERL_UNUSED_ARG(mg); 2188 2189 if (!translate_substr_offsets( 2190 SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len, 2191 negoff ? -(IV)offs : (IV)offs, !negoff, 2192 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem 2193 )) { 2194 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); 2195 sv_setsv_nomg(sv, &PL_sv_undef); 2196 return 0; 2197 } 2198 2199 if (SvUTF8(lsv)) 2200 offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem); 2201 sv_setpvn(sv, tmps + offs, rem); 2202 if (SvUTF8(lsv)) 2203 SvUTF8_on(sv); 2204 return 0; 2205 } 2206 2207 int 2208 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) 2209 { 2210 dVAR; 2211 STRLEN len, lsv_len, oldtarglen, newtarglen; 2212 const char * const tmps = SvPV_const(sv, len); 2213 SV * const lsv = LvTARG(sv); 2214 STRLEN lvoff = LvTARGOFF(sv); 2215 STRLEN lvlen = LvTARGLEN(sv); 2216 const bool negoff = LvFLAGS(sv) & 1; 2217 const bool neglen = LvFLAGS(sv) & 2; 2218 2219 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR; 2220 PERL_UNUSED_ARG(mg); 2221 2222 SvGETMAGIC(lsv); 2223 if (SvROK(lsv)) 2224 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), 2225 "Attempt to use reference as lvalue in substr" 2226 ); 2227 SvPV_force_nomg(lsv,lsv_len); 2228 if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv); 2229 if (!translate_substr_offsets( 2230 lsv_len, 2231 negoff ? -(IV)lvoff : (IV)lvoff, !negoff, 2232 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen 2233 )) 2234 Perl_croak(aTHX_ "substr outside of string"); 2235 oldtarglen = lvlen; 2236 if (DO_UTF8(sv)) { 2237 sv_utf8_upgrade_nomg(lsv); 2238 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); 2239 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0); 2240 newtarglen = sv_or_pv_len_utf8(sv, tmps, len); 2241 SvUTF8_on(lsv); 2242 } 2243 else if (SvUTF8(lsv)) { 2244 const char *utf8; 2245 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); 2246 newtarglen = len; 2247 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len); 2248 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0); 2249 Safefree(utf8); 2250 } 2251 else { 2252 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0); 2253 newtarglen = len; 2254 } 2255 if (!neglen) LvTARGLEN(sv) = newtarglen; 2256 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen; 2257 2258 return 0; 2259 } 2260 2261 int 2262 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg) 2263 { 2264 dVAR; 2265 2266 PERL_ARGS_ASSERT_MAGIC_GETTAINT; 2267 PERL_UNUSED_ARG(sv); 2268 #ifdef NO_TAINT_SUPPORT 2269 PERL_UNUSED_ARG(mg); 2270 #endif 2271 2272 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1) && IN_PERL_RUNTIME); 2273 return 0; 2274 } 2275 2276 int 2277 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg) 2278 { 2279 dVAR; 2280 2281 PERL_ARGS_ASSERT_MAGIC_SETTAINT; 2282 PERL_UNUSED_ARG(sv); 2283 2284 /* update taint status */ 2285 if (TAINT_get) 2286 mg->mg_len |= 1; 2287 else 2288 mg->mg_len &= ~1; 2289 return 0; 2290 } 2291 2292 int 2293 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg) 2294 { 2295 SV * const lsv = LvTARG(sv); 2296 2297 PERL_ARGS_ASSERT_MAGIC_GETVEC; 2298 PERL_UNUSED_ARG(mg); 2299 2300 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv))); 2301 2302 return 0; 2303 } 2304 2305 int 2306 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg) 2307 { 2308 PERL_ARGS_ASSERT_MAGIC_SETVEC; 2309 PERL_UNUSED_ARG(mg); 2310 do_vecset(sv); /* XXX slurp this routine */ 2311 return 0; 2312 } 2313 2314 SV * 2315 Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg) 2316 { 2317 dVAR; 2318 SV *targ = NULL; 2319 PERL_ARGS_ASSERT_DEFELEM_TARGET; 2320 if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem); 2321 assert(mg); 2322 if (LvTARGLEN(sv)) { 2323 if (mg->mg_obj) { 2324 SV * const ahv = LvTARG(sv); 2325 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0); 2326 if (he) 2327 targ = HeVAL(he); 2328 } 2329 else if (LvSTARGOFF(sv) >= 0) { 2330 AV *const av = MUTABLE_AV(LvTARG(sv)); 2331 if (LvSTARGOFF(sv) <= AvFILL(av)) 2332 { 2333 if (SvRMAGICAL(av)) { 2334 SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0); 2335 targ = svp ? *svp : NULL; 2336 } 2337 else 2338 targ = AvARRAY(av)[LvSTARGOFF(sv)]; 2339 } 2340 } 2341 if (targ && (targ != &PL_sv_undef)) { 2342 /* somebody else defined it for us */ 2343 SvREFCNT_dec(LvTARG(sv)); 2344 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ); 2345 LvTARGLEN(sv) = 0; 2346 SvREFCNT_dec(mg->mg_obj); 2347 mg->mg_obj = NULL; 2348 mg->mg_flags &= ~MGf_REFCOUNTED; 2349 } 2350 return targ; 2351 } 2352 else 2353 return LvTARG(sv); 2354 } 2355 2356 int 2357 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg) 2358 { 2359 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM; 2360 2361 sv_setsv(sv, defelem_target(sv, mg)); 2362 return 0; 2363 } 2364 2365 int 2366 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg) 2367 { 2368 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM; 2369 PERL_UNUSED_ARG(mg); 2370 if (LvTARGLEN(sv)) 2371 vivify_defelem(sv); 2372 if (LvTARG(sv)) { 2373 sv_setsv(LvTARG(sv), sv); 2374 SvSETMAGIC(LvTARG(sv)); 2375 } 2376 return 0; 2377 } 2378 2379 void 2380 Perl_vivify_defelem(pTHX_ SV *sv) 2381 { 2382 dVAR; 2383 MAGIC *mg; 2384 SV *value = NULL; 2385 2386 PERL_ARGS_ASSERT_VIVIFY_DEFELEM; 2387 2388 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem))) 2389 return; 2390 if (mg->mg_obj) { 2391 SV * const ahv = LvTARG(sv); 2392 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0); 2393 if (he) 2394 value = HeVAL(he); 2395 if (!value || value == &PL_sv_undef) 2396 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj)); 2397 } 2398 else if (LvSTARGOFF(sv) < 0) 2399 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv)); 2400 else { 2401 AV *const av = MUTABLE_AV(LvTARG(sv)); 2402 if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av)) 2403 LvTARG(sv) = NULL; /* array can't be extended */ 2404 else { 2405 SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE); 2406 if (!svp || !(value = *svp)) 2407 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv)); 2408 } 2409 } 2410 SvREFCNT_inc_simple_void(value); 2411 SvREFCNT_dec(LvTARG(sv)); 2412 LvTARG(sv) = value; 2413 LvTARGLEN(sv) = 0; 2414 SvREFCNT_dec(mg->mg_obj); 2415 mg->mg_obj = NULL; 2416 mg->mg_flags &= ~MGf_REFCOUNTED; 2417 } 2418 2419 int 2420 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg) 2421 { 2422 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS; 2423 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj)); 2424 return 0; 2425 } 2426 2427 int 2428 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg) 2429 { 2430 PERL_ARGS_ASSERT_MAGIC_SETMGLOB; 2431 PERL_UNUSED_CONTEXT; 2432 PERL_UNUSED_ARG(sv); 2433 mg->mg_len = -1; 2434 return 0; 2435 } 2436 2437 int 2438 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg) 2439 { 2440 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr; 2441 2442 PERL_ARGS_ASSERT_MAGIC_SETUVAR; 2443 2444 if (uf && uf->uf_set) 2445 (*uf->uf_set)(aTHX_ uf->uf_index, sv); 2446 return 0; 2447 } 2448 2449 int 2450 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg) 2451 { 2452 const char type = mg->mg_type; 2453 2454 PERL_ARGS_ASSERT_MAGIC_SETREGEXP; 2455 2456 if (type == PERL_MAGIC_qr) { 2457 } else if (type == PERL_MAGIC_bm) { 2458 SvTAIL_off(sv); 2459 SvVALID_off(sv); 2460 } else { 2461 assert(type == PERL_MAGIC_fm); 2462 } 2463 return sv_unmagic(sv, type); 2464 } 2465 2466 #ifdef USE_LOCALE_COLLATE 2467 int 2468 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg) 2469 { 2470 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM; 2471 2472 /* 2473 * RenE<eacute> Descartes said "I think not." 2474 * and vanished with a faint plop. 2475 */ 2476 PERL_UNUSED_CONTEXT; 2477 PERL_UNUSED_ARG(sv); 2478 if (mg->mg_ptr) { 2479 Safefree(mg->mg_ptr); 2480 mg->mg_ptr = NULL; 2481 mg->mg_len = -1; 2482 } 2483 return 0; 2484 } 2485 #endif /* USE_LOCALE_COLLATE */ 2486 2487 /* Just clear the UTF-8 cache data. */ 2488 int 2489 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg) 2490 { 2491 PERL_ARGS_ASSERT_MAGIC_SETUTF8; 2492 PERL_UNUSED_CONTEXT; 2493 PERL_UNUSED_ARG(sv); 2494 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */ 2495 mg->mg_ptr = NULL; 2496 mg->mg_len = -1; /* The mg_len holds the len cache. */ 2497 return 0; 2498 } 2499 2500 int 2501 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) 2502 { 2503 dVAR; 2504 const char *s; 2505 I32 paren; 2506 const REGEXP * rx; 2507 I32 i; 2508 STRLEN len; 2509 MAGIC *tmg; 2510 2511 PERL_ARGS_ASSERT_MAGIC_SET; 2512 2513 if (!mg->mg_ptr) { 2514 paren = mg->mg_len; 2515 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 2516 setparen_got_rx: 2517 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv); 2518 } else { 2519 /* Croak with a READONLY error when a numbered match var is 2520 * set without a previous pattern match. Unless it's C<local $1> 2521 */ 2522 croakparen: 2523 if (!PL_localizing) { 2524 Perl_croak_no_modify(); 2525 } 2526 } 2527 return 0; 2528 } 2529 2530 switch (*mg->mg_ptr) { 2531 case '\001': /* ^A */ 2532 if (SvOK(sv)) sv_copypv(PL_bodytarget, sv); 2533 else SvOK_off(PL_bodytarget); 2534 FmLINES(PL_bodytarget) = 0; 2535 if (SvPOK(PL_bodytarget)) { 2536 char *s = SvPVX(PL_bodytarget); 2537 while ( ((s = strchr(s, '\n'))) ) { 2538 FmLINES(PL_bodytarget)++; 2539 s++; 2540 } 2541 } 2542 /* mg_set() has temporarily made sv non-magical */ 2543 if (TAINTING_get) { 2544 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1) 2545 SvTAINTED_on(PL_bodytarget); 2546 else 2547 SvTAINTED_off(PL_bodytarget); 2548 } 2549 break; 2550 case '\003': /* ^C */ 2551 PL_minus_c = cBOOL(SvIV(sv)); 2552 break; 2553 2554 case '\004': /* ^D */ 2555 #ifdef DEBUGGING 2556 s = SvPV_nolen_const(sv); 2557 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG; 2558 if (DEBUG_x_TEST || DEBUG_B_TEST) 2559 dump_all_perl(!DEBUG_B_TEST); 2560 #else 2561 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG; 2562 #endif 2563 break; 2564 case '\005': /* ^E */ 2565 if (*(mg->mg_ptr+1) == '\0') { 2566 #ifdef VMS 2567 set_vaxc_errno(SvIV(sv)); 2568 #else 2569 # ifdef WIN32 2570 SetLastError( SvIV(sv) ); 2571 # else 2572 # ifdef OS2 2573 os2_setsyserrno(SvIV(sv)); 2574 # else 2575 /* will anyone ever use this? */ 2576 SETERRNO(SvIV(sv), 4); 2577 # endif 2578 # endif 2579 #endif 2580 } 2581 else if (strEQ(mg->mg_ptr+1, "NCODING")) { 2582 SvREFCNT_dec(PL_encoding); 2583 if (SvOK(sv) || SvGMAGICAL(sv)) { 2584 PL_encoding = newSVsv(sv); 2585 } 2586 else { 2587 PL_encoding = NULL; 2588 } 2589 } 2590 break; 2591 case '\006': /* ^F */ 2592 PL_maxsysfd = SvIV(sv); 2593 break; 2594 case '\010': /* ^H */ 2595 PL_hints = SvIV(sv); 2596 break; 2597 case '\011': /* ^I */ /* NOT \t in EBCDIC */ 2598 Safefree(PL_inplace); 2599 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL; 2600 break; 2601 case '\016': /* ^N */ 2602 if (PL_curpm && (rx = PM_GETRE(PL_curpm)) 2603 && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx; 2604 goto croakparen; 2605 case '\017': /* ^O */ 2606 if (*(mg->mg_ptr+1) == '\0') { 2607 Safefree(PL_osname); 2608 PL_osname = NULL; 2609 if (SvOK(sv)) { 2610 TAINT_PROPER("assigning to $^O"); 2611 PL_osname = savesvpv(sv); 2612 } 2613 } 2614 else if (strEQ(mg->mg_ptr, "\017PEN")) { 2615 STRLEN len; 2616 const char *const start = SvPV(sv, len); 2617 const char *out = (const char*)memchr(start, '\0', len); 2618 SV *tmp; 2619 2620 2621 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; 2622 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; 2623 2624 /* Opening for input is more common than opening for output, so 2625 ensure that hints for input are sooner on linked list. */ 2626 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1, 2627 SvUTF8(sv)) 2628 : newSVpvs_flags("", SvUTF8(sv)); 2629 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp); 2630 mg_set(tmp); 2631 2632 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len, 2633 SvUTF8(sv)); 2634 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp); 2635 mg_set(tmp); 2636 } 2637 break; 2638 case '\020': /* ^P */ 2639 PL_perldb = SvIV(sv); 2640 if (PL_perldb && !PL_DBsingle) 2641 init_debugger(); 2642 break; 2643 case '\024': /* ^T */ 2644 #ifdef BIG_TIME 2645 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv)); 2646 #else 2647 PL_basetime = (Time_t)SvIV(sv); 2648 #endif 2649 break; 2650 case '\025': /* ^UTF8CACHE */ 2651 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) { 2652 PL_utf8cache = (signed char) sv_2iv(sv); 2653 } 2654 break; 2655 case '\027': /* ^W & $^WARNING_BITS */ 2656 if (*(mg->mg_ptr+1) == '\0') { 2657 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { 2658 i = SvIV(sv); 2659 PL_dowarn = (PL_dowarn & ~G_WARN_ON) 2660 | (i ? G_WARN_ON : G_WARN_OFF) ; 2661 } 2662 } 2663 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) { 2664 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { 2665 if (!SvPOK(sv)) { 2666 PL_compiling.cop_warnings = pWARN_STD; 2667 break; 2668 } 2669 { 2670 STRLEN len, i; 2671 int accumulate = 0 ; 2672 int any_fatals = 0 ; 2673 const char * const ptr = SvPV_const(sv, len) ; 2674 for (i = 0 ; i < len ; ++i) { 2675 accumulate |= ptr[i] ; 2676 any_fatals |= (ptr[i] & 0xAA) ; 2677 } 2678 if (!accumulate) { 2679 if (!specialWARN(PL_compiling.cop_warnings)) 2680 PerlMemShared_free(PL_compiling.cop_warnings); 2681 PL_compiling.cop_warnings = pWARN_NONE; 2682 } 2683 /* Yuck. I can't see how to abstract this: */ 2684 else if (isWARN_on( 2685 ((STRLEN *)SvPV_nolen_const(sv)) - 1, 2686 WARN_ALL) 2687 && !any_fatals) 2688 { 2689 if (!specialWARN(PL_compiling.cop_warnings)) 2690 PerlMemShared_free(PL_compiling.cop_warnings); 2691 PL_compiling.cop_warnings = pWARN_ALL; 2692 PL_dowarn |= G_WARN_ONCE ; 2693 } 2694 else { 2695 STRLEN len; 2696 const char *const p = SvPV_const(sv, len); 2697 2698 PL_compiling.cop_warnings 2699 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings, 2700 p, len); 2701 2702 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE)) 2703 PL_dowarn |= G_WARN_ONCE ; 2704 } 2705 2706 } 2707 } 2708 } 2709 break; 2710 case '.': 2711 if (PL_localizing) { 2712 if (PL_localizing == 1) 2713 SAVESPTR(PL_last_in_gv); 2714 } 2715 else if (SvOK(sv) && GvIO(PL_last_in_gv)) 2716 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv); 2717 break; 2718 case '^': 2719 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv))); 2720 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); 2721 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); 2722 break; 2723 case '~': 2724 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv))); 2725 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); 2726 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); 2727 break; 2728 case '=': 2729 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv)); 2730 break; 2731 case '-': 2732 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv)); 2733 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L) 2734 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L; 2735 break; 2736 case '%': 2737 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv)); 2738 break; 2739 case '|': 2740 { 2741 IO * const io = GvIO(PL_defoutgv); 2742 if(!io) 2743 break; 2744 if ((SvIV(sv)) == 0) 2745 IoFLAGS(io) &= ~IOf_FLUSH; 2746 else { 2747 if (!(IoFLAGS(io) & IOf_FLUSH)) { 2748 PerlIO *ofp = IoOFP(io); 2749 if (ofp) 2750 (void)PerlIO_flush(ofp); 2751 IoFLAGS(io) |= IOf_FLUSH; 2752 } 2753 } 2754 } 2755 break; 2756 case '/': 2757 { 2758 SV *tmpsv= sv; 2759 if (SvROK(sv)) { 2760 SV *referent= SvRV(sv); 2761 const char *reftype= sv_reftype(referent, 0); 2762 /* XXX: dodgy type check: This leaves me feeling dirty, but the alternative 2763 * is to copy pretty much the entire sv_reftype() into this routine, or to do 2764 * a full string comparison on the return of sv_reftype() both of which 2765 * make me feel worse! NOTE, do not modify this comment without reviewing the 2766 * corresponding comment in sv_reftype(). - Yves */ 2767 if (reftype[0] == 'S' || reftype[0] == 'L') { 2768 IV val= SvIV(referent); 2769 if (val <= 0) { 2770 tmpsv= &PL_sv_undef; 2771 Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED), 2772 "Setting $/ to a reference to %s as a form of slurp is deprecated, treating as undef", 2773 SvIV(SvRV(sv)) < 0 ? "a negative integer" : "zero" 2774 ); 2775 } 2776 } else { 2777 sv_setsv(sv, PL_rs); 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