mg.c

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