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