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