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