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