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