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