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 #ifdef NO_TAINT_SUPPORT
2224     PERL_UNUSED_ARG(mg);
2225 #endif
2226
2227     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2228     return 0;
2229 }
2230
2231 int
2232 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2233 {
2234     dVAR;
2235
2236     PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2237     PERL_UNUSED_ARG(sv);
2238
2239     /* update taint status */
2240     if (TAINT_get)
2241         mg->mg_len |= 1;
2242     else
2243         mg->mg_len &= ~1;
2244     return 0;
2245 }
2246
2247 int
2248 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2249 {
2250     SV * const lsv = LvTARG(sv);
2251
2252     PERL_ARGS_ASSERT_MAGIC_GETVEC;
2253     PERL_UNUSED_ARG(mg);
2254
2255     if (lsv)
2256         sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2257     else
2258         SvOK_off(sv);
2259
2260     return 0;
2261 }
2262
2263 int
2264 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2265 {
2266     PERL_ARGS_ASSERT_MAGIC_SETVEC;
2267     PERL_UNUSED_ARG(mg);
2268     do_vecset(sv);      /* XXX slurp this routine */
2269     return 0;
2270 }
2271
2272 int
2273 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2274 {
2275     dVAR;
2276     SV *targ = NULL;
2277
2278     PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2279
2280     if (LvTARGLEN(sv)) {
2281         if (mg->mg_obj) {
2282             SV * const ahv = LvTARG(sv);
2283             HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2284             if (he)
2285                 targ = HeVAL(he);
2286         }
2287         else {
2288             AV *const av = MUTABLE_AV(LvTARG(sv));
2289             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2290                 targ = AvARRAY(av)[LvTARGOFF(sv)];
2291         }
2292         if (targ && (targ != &PL_sv_undef)) {
2293             /* somebody else defined it for us */
2294             SvREFCNT_dec(LvTARG(sv));
2295             LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2296             LvTARGLEN(sv) = 0;
2297             SvREFCNT_dec(mg->mg_obj);
2298             mg->mg_obj = NULL;
2299             mg->mg_flags &= ~MGf_REFCOUNTED;
2300         }
2301     }
2302     else
2303         targ = LvTARG(sv);
2304     sv_setsv(sv, targ ? targ : &PL_sv_undef);
2305     return 0;
2306 }
2307
2308 int
2309 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2310 {
2311     PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2312     PERL_UNUSED_ARG(mg);
2313     if (LvTARGLEN(sv))
2314         vivify_defelem(sv);
2315     if (LvTARG(sv)) {
2316         sv_setsv(LvTARG(sv), sv);
2317         SvSETMAGIC(LvTARG(sv));
2318     }
2319     return 0;
2320 }
2321
2322 void
2323 Perl_vivify_defelem(pTHX_ SV *sv)
2324 {
2325     dVAR;
2326     MAGIC *mg;
2327     SV *value = NULL;
2328
2329     PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2330
2331     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2332         return;
2333     if (mg->mg_obj) {
2334         SV * const ahv = LvTARG(sv);
2335         HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2336         if (he)
2337             value = HeVAL(he);
2338         if (!value || value == &PL_sv_undef)
2339             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2340     }
2341     else {
2342         AV *const av = MUTABLE_AV(LvTARG(sv));
2343         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2344             LvTARG(sv) = NULL;  /* array can't be extended */
2345         else {
2346             SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2347             if (!svp || (value = *svp) == &PL_sv_undef)
2348                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2349         }
2350     }
2351     SvREFCNT_inc_simple_void(value);
2352     SvREFCNT_dec(LvTARG(sv));
2353     LvTARG(sv) = value;
2354     LvTARGLEN(sv) = 0;
2355     SvREFCNT_dec(mg->mg_obj);
2356     mg->mg_obj = NULL;
2357     mg->mg_flags &= ~MGf_REFCOUNTED;
2358 }
2359
2360 int
2361 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2362 {
2363     PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2364     Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2365     return 0;
2366 }
2367
2368 int
2369 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2370 {
2371     PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2372     PERL_UNUSED_CONTEXT;
2373     PERL_UNUSED_ARG(sv);
2374     mg->mg_len = -1;
2375     return 0;
2376 }
2377
2378 int
2379 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2380 {
2381     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2382
2383     PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2384
2385     if (uf && uf->uf_set)
2386         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2387     return 0;
2388 }
2389
2390 int
2391 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2392 {
2393     const char type = mg->mg_type;
2394
2395     PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2396
2397     if (type == PERL_MAGIC_qr) {
2398     } else if (type == PERL_MAGIC_bm) {
2399         SvTAIL_off(sv);
2400         SvVALID_off(sv);
2401     } else {
2402         assert(type == PERL_MAGIC_fm);
2403     }
2404     return sv_unmagic(sv, type);
2405 }
2406
2407 #ifdef USE_LOCALE_COLLATE
2408 int
2409 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2410 {
2411     PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2412
2413     /*
2414      * RenE<eacute> Descartes said "I think not."
2415      * and vanished with a faint plop.
2416      */
2417     PERL_UNUSED_CONTEXT;
2418     PERL_UNUSED_ARG(sv);
2419     if (mg->mg_ptr) {
2420         Safefree(mg->mg_ptr);
2421         mg->mg_ptr = NULL;
2422         mg->mg_len = -1;
2423     }
2424     return 0;
2425 }
2426 #endif /* USE_LOCALE_COLLATE */
2427
2428 /* Just clear the UTF-8 cache data. */
2429 int
2430 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2431 {
2432     PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2433     PERL_UNUSED_CONTEXT;
2434     PERL_UNUSED_ARG(sv);
2435     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2436     mg->mg_ptr = NULL;
2437     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2438     return 0;
2439 }
2440
2441 int
2442 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2443 {
2444     dVAR;
2445     const char *s;
2446     I32 paren;
2447     const REGEXP * rx;
2448     const char * const remaining = mg->mg_ptr + 1;
2449     I32 i;
2450     STRLEN len;
2451     MAGIC *tmg;
2452
2453     PERL_ARGS_ASSERT_MAGIC_SET;
2454
2455     switch (*mg->mg_ptr) {
2456     case '\015': /* $^MATCH */
2457       if (strEQ(remaining, "ATCH"))
2458           goto do_match;
2459     case '`': /* ${^PREMATCH} caught below */
2460       do_prematch:
2461       paren = RX_BUFF_IDX_PREMATCH;
2462       goto setparen;
2463     case '\'': /* ${^POSTMATCH} caught below */
2464       do_postmatch:
2465       paren = RX_BUFF_IDX_POSTMATCH;
2466       goto setparen;
2467     case '&':
2468       do_match:
2469       paren = RX_BUFF_IDX_FULLMATCH;
2470       goto setparen;
2471     case '1': case '2': case '3': case '4':
2472     case '5': case '6': case '7': case '8': case '9':
2473       paren = atoi(mg->mg_ptr);
2474       setparen:
2475         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2476       setparen_got_rx:
2477             CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2478         } else {
2479             /* Croak with a READONLY error when a numbered match var is
2480              * set without a previous pattern match. Unless it's C<local $1>
2481              */
2482       croakparen:
2483             if (!PL_localizing) {
2484                 Perl_croak_no_modify();
2485             }
2486         }
2487         break;
2488     case '\001':        /* ^A */
2489         if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2490         else SvOK_off(PL_bodytarget);
2491         FmLINES(PL_bodytarget) = 0;
2492         if (SvPOK(PL_bodytarget)) {
2493             char *s = SvPVX(PL_bodytarget);
2494             while ( ((s = strchr(s, '\n'))) ) {
2495                 FmLINES(PL_bodytarget)++;
2496                 s++;
2497             }
2498         }
2499         /* mg_set() has temporarily made sv non-magical */
2500         if (TAINTING_get) {
2501             if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2502                 SvTAINTED_on(PL_bodytarget);
2503             else
2504                 SvTAINTED_off(PL_bodytarget);
2505         }
2506         break;
2507     case '\003':        /* ^C */
2508         PL_minus_c = cBOOL(SvIV(sv));
2509         break;
2510
2511     case '\004':        /* ^D */
2512 #ifdef DEBUGGING
2513         s = SvPV_nolen_const(sv);
2514         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2515         if (DEBUG_x_TEST || DEBUG_B_TEST)
2516             dump_all_perl(!DEBUG_B_TEST);
2517 #else
2518         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2519 #endif
2520         break;
2521     case '\005':  /* ^E */
2522         if (*(mg->mg_ptr+1) == '\0') {
2523 #ifdef VMS
2524             set_vaxc_errno(SvIV(sv));
2525 #else
2526 #  ifdef WIN32
2527             SetLastError( SvIV(sv) );
2528 #  else
2529 #    ifdef OS2
2530             os2_setsyserrno(SvIV(sv));
2531 #    else
2532             /* will anyone ever use this? */
2533             SETERRNO(SvIV(sv), 4);
2534 #    endif
2535 #  endif
2536 #endif
2537         }
2538         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2539             SvREFCNT_dec(PL_encoding);
2540             if (SvOK(sv) || SvGMAGICAL(sv)) {
2541                 PL_encoding = newSVsv(sv);
2542             }
2543             else {
2544                 PL_encoding = NULL;
2545             }
2546         }
2547         break;
2548     case '\006':        /* ^F */
2549         PL_maxsysfd = SvIV(sv);
2550         break;
2551     case '\010':        /* ^H */
2552         PL_hints = SvIV(sv);
2553         break;
2554     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2555         Safefree(PL_inplace);
2556         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2557         break;
2558     case '\016':        /* ^N */
2559         if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2560          && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2561         goto croakparen;
2562     case '\017':        /* ^O */
2563         if (*(mg->mg_ptr+1) == '\0') {
2564             Safefree(PL_osname);
2565             PL_osname = NULL;
2566             if (SvOK(sv)) {
2567                 TAINT_PROPER("assigning to $^O");
2568                 PL_osname = savesvpv(sv);
2569             }
2570         }
2571         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2572             STRLEN len;
2573             const char *const start = SvPV(sv, len);
2574             const char *out = (const char*)memchr(start, '\0', len);
2575             SV *tmp;
2576
2577
2578             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2579             PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2580
2581             /* Opening for input is more common than opening for output, so
2582                ensure that hints for input are sooner on linked list.  */
2583             tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2584                                        SvUTF8(sv))
2585                 : newSVpvs_flags("", SvUTF8(sv));
2586             (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2587             mg_set(tmp);
2588
2589             tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2590                                         SvUTF8(sv));
2591             (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2592             mg_set(tmp);
2593         }
2594         break;
2595     case '\020':        /* ^P */
2596       if (*remaining == '\0') { /* ^P */
2597           PL_perldb = SvIV(sv);
2598           if (PL_perldb && !PL_DBsingle)
2599               init_debugger();
2600           break;
2601       } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2602           goto do_prematch;
2603       } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2604           goto do_postmatch;
2605       }
2606       break;
2607     case '\024':        /* ^T */
2608 #ifdef BIG_TIME
2609         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2610 #else
2611         PL_basetime = (Time_t)SvIV(sv);
2612 #endif
2613         break;
2614     case '\025':        /* ^UTF8CACHE */
2615          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2616              PL_utf8cache = (signed char) sv_2iv(sv);
2617          }
2618          break;
2619     case '\027':        /* ^W & $^WARNING_BITS */
2620         if (*(mg->mg_ptr+1) == '\0') {
2621             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2622                 i = SvIV(sv);
2623                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2624                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2625             }
2626         }
2627         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2628             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2629                 if (!SvPOK(sv)) {
2630                     PL_compiling.cop_warnings = pWARN_STD;
2631                     break;
2632                 }
2633                 {
2634                     STRLEN len, i;
2635                     int accumulate = 0 ;
2636                     int any_fatals = 0 ;
2637                     const char * const ptr = SvPV_const(sv, len) ;
2638                     for (i = 0 ; i < len ; ++i) {
2639                         accumulate |= ptr[i] ;
2640                         any_fatals |= (ptr[i] & 0xAA) ;
2641                     }
2642                     if (!accumulate) {
2643                         if (!specialWARN(PL_compiling.cop_warnings))
2644                             PerlMemShared_free(PL_compiling.cop_warnings);
2645                         PL_compiling.cop_warnings = pWARN_NONE;
2646                     }
2647                     /* Yuck. I can't see how to abstract this:  */
2648                     else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2649                                        WARN_ALL) && !any_fatals) {
2650                         if (!specialWARN(PL_compiling.cop_warnings))
2651                             PerlMemShared_free(PL_compiling.cop_warnings);
2652                         PL_compiling.cop_warnings = pWARN_ALL;
2653                         PL_dowarn |= G_WARN_ONCE ;
2654                     }
2655                     else {
2656                         STRLEN len;
2657                         const char *const p = SvPV_const(sv, len);
2658
2659                         PL_compiling.cop_warnings
2660                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2661                                                          p, len);
2662
2663                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2664                             PL_dowarn |= G_WARN_ONCE ;
2665                     }
2666
2667                 }
2668             }
2669         }
2670         break;
2671     case '.':
2672         if (PL_localizing) {
2673             if (PL_localizing == 1)
2674                 SAVESPTR(PL_last_in_gv);
2675         }
2676         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2677             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2678         break;
2679     case '^':
2680         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2681         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2682         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2683         break;
2684     case '~':
2685         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2686         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2687         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2688         break;
2689     case '=':
2690         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2691         break;
2692     case '-':
2693         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2694         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2695                 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2696         break;
2697     case '%':
2698         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2699         break;
2700     case '|':
2701         {
2702             IO * const io = GvIO(PL_defoutgv);
2703             if(!io)
2704               break;
2705             if ((SvIV(sv)) == 0)
2706                 IoFLAGS(io) &= ~IOf_FLUSH;
2707             else {
2708                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2709                     PerlIO *ofp = IoOFP(io);
2710                     if (ofp)
2711                         (void)PerlIO_flush(ofp);
2712                     IoFLAGS(io) |= IOf_FLUSH;
2713                 }
2714             }
2715         }
2716         break;
2717     case '/':
2718         SvREFCNT_dec(PL_rs);
2719         PL_rs = newSVsv(sv);
2720         break;
2721     case '\\':
2722         SvREFCNT_dec(PL_ors_sv);
2723         if (SvOK(sv)) {
2724             PL_ors_sv = newSVsv(sv);
2725         }
2726         else {
2727             PL_ors_sv = NULL;
2728         }
2729         break;
2730     case '[':
2731         if (SvIV(sv) != 0)
2732             Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
2733         break;
2734     case '?':
2735 #ifdef COMPLEX_STATUS
2736         if (PL_localizing == 2) {
2737             SvUPGRADE(sv, SVt_PVLV);
2738             PL_statusvalue = LvTARGOFF(sv);
2739             PL_statusvalue_vms = LvTARGLEN(sv);
2740         }
2741         else
2742 #endif
2743 #ifdef VMSISH_STATUS
2744         if (VMSISH_STATUS)
2745             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2746         else
2747 #endif
2748             STATUS_UNIX_EXIT_SET(SvIV(sv));
2749         break;
2750     case '!':
2751         {
2752 #ifdef VMS
2753 #   define PERL_VMS_BANG vaxc$errno
2754 #else
2755 #   define PERL_VMS_BANG 0
2756 #endif
2757         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2758                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2759         }
2760         break;
2761     case '<':
2762         {
2763         const IV new_uid = SvIV(sv);
2764         PL_delaymagic_uid = new_uid;
2765         if (PL_delaymagic) {
2766             PL_delaymagic |= DM_RUID;
2767             break;                              /* don't do magic till later */
2768         }
2769 #ifdef HAS_SETRUID
2770         (void)setruid((Uid_t)new_uid);
2771 #else
2772 #ifdef HAS_SETREUID
2773         (void)setreuid((Uid_t)new_uid, (Uid_t)-1);
2774 #else
2775 #ifdef HAS_SETRESUID
2776       (void)setresuid((Uid_t)new_uid, (Uid_t)-1, (Uid_t)-1);
2777 #else
2778         if (new_uid == PerlProc_geteuid()) {            /* special case $< = $> */
2779 #ifdef PERL_DARWIN
2780             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2781             if (new_uid != 0 && PerlProc_getuid() == 0)
2782                 (void)PerlProc_setuid(0);
2783 #endif
2784             (void)PerlProc_setuid(new_uid);
2785         } else {
2786             Perl_croak(aTHX_ "setruid() not implemented");
2787         }
2788 #endif
2789 #endif
2790 #endif
2791         break;
2792         }
2793     case '>':
2794         {
2795         const UV new_euid = SvIV(sv);
2796         PL_delaymagic_euid = new_euid;
2797         if (PL_delaymagic) {
2798             PL_delaymagic |= DM_EUID;
2799             break;                              /* don't do magic till later */
2800         }
2801 #ifdef HAS_SETEUID
2802         (void)seteuid((Uid_t)new_euid);
2803 #else
2804 #ifdef HAS_SETREUID
2805         (void)setreuid((Uid_t)-1, (Uid_t)new_euid);
2806 #else
2807 #ifdef HAS_SETRESUID
2808         (void)setresuid((Uid_t)-1, (Uid_t)new_euid, (Uid_t)-1);
2809 #else
2810         if (new_euid == PerlProc_getuid())              /* special case $> = $< */
2811             PerlProc_setuid(new_euid);
2812         else {
2813             Perl_croak(aTHX_ "seteuid() not implemented");
2814         }
2815 #endif
2816 #endif
2817 #endif
2818         break;
2819         }
2820     case '(':
2821         {
2822         const UV new_gid = SvIV(sv);
2823         PL_delaymagic_gid = new_gid;
2824         if (PL_delaymagic) {
2825             PL_delaymagic |= DM_RGID;
2826             break;                              /* don't do magic till later */
2827         }
2828 #ifdef HAS_SETRGID
2829         (void)setrgid((Gid_t)new_gid);
2830 #else
2831 #ifdef HAS_SETREGID
2832         (void)setregid((Gid_t)new_gid, (Gid_t)-1);
2833 #else
2834 #ifdef HAS_SETRESGID
2835       (void)setresgid((Gid_t)new_gid, (Gid_t)-1, (Gid_t) -1);
2836 #else
2837         if (new_gid == PerlProc_getegid())                      /* special case $( = $) */
2838             (void)PerlProc_setgid(new_gid);
2839         else {
2840             Perl_croak(aTHX_ "setrgid() not implemented");
2841         }
2842 #endif
2843 #endif
2844 #endif
2845         break;
2846         }
2847     case ')':
2848         {
2849         UV new_egid;
2850 #ifdef HAS_SETGROUPS
2851         {
2852             const char *p = SvPV_const(sv, len);
2853             Groups_t *gary = NULL;
2854 #ifdef _SC_NGROUPS_MAX
2855            int maxgrp = sysconf(_SC_NGROUPS_MAX);
2856
2857            if (maxgrp < 0)
2858                maxgrp = NGROUPS;
2859 #else
2860            int maxgrp = NGROUPS;
2861 #endif
2862
2863             while (isSPACE(*p))
2864                 ++p;
2865             new_egid = Atol(p);
2866             for (i = 0; i < maxgrp; ++i) {
2867                 while (*p && !isSPACE(*p))
2868                     ++p;
2869                 while (isSPACE(*p))
2870                     ++p;
2871                 if (!*p)
2872                     break;
2873                 if(!gary)
2874                     Newx(gary, i + 1, Groups_t);
2875                 else
2876                     Renew(gary, i + 1, Groups_t);
2877                 gary[i] = Atol(p);
2878             }
2879             if (i)
2880                 (void)setgroups(i, gary);
2881             Safefree(gary);
2882         }
2883 #else  /* HAS_SETGROUPS */
2884         new_egid = SvIV(sv);
2885 #endif /* HAS_SETGROUPS */
2886         PL_delaymagic_egid = new_egid;
2887         if (PL_delaymagic) {
2888             PL_delaymagic |= DM_EGID;
2889             break;                              /* don't do magic till later */
2890         }
2891 #ifdef HAS_SETEGID
2892         (void)setegid((Gid_t)new_egid);
2893 #else
2894 #ifdef HAS_SETREGID
2895         (void)setregid((Gid_t)-1, (Gid_t)new_egid);
2896 #else
2897 #ifdef HAS_SETRESGID
2898         (void)setresgid((Gid_t)-1, (Gid_t)new_egid, (Gid_t)-1);
2899 #else
2900         if (new_egid == PerlProc_getgid())                      /* special case $) = $( */
2901             (void)PerlProc_setgid(new_egid);
2902         else {
2903             Perl_croak(aTHX_ "setegid() not implemented");
2904         }
2905 #endif
2906 #endif
2907 #endif
2908         break;
2909         }
2910     case ':':
2911         PL_chopset = SvPV_force(sv,len);
2912         break;
2913     case '$': /* $$ */
2914         /* Store the pid in mg->mg_obj so we can tell when a fork has
2915            occurred.  mg->mg_obj points to *$ by default, so clear it. */
2916         if (isGV(mg->mg_obj)) {
2917             if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
2918                 SvREFCNT_dec(mg->mg_obj);
2919             mg->mg_flags |= MGf_REFCOUNTED;
2920             mg->mg_obj = newSViv((IV)PerlProc_getpid());
2921         }
2922         else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
2923         break;
2924     case '0':
2925         LOCK_DOLLARZERO_MUTEX;
2926 #ifdef HAS_SETPROCTITLE
2927         /* The BSDs don't show the argv[] in ps(1) output, they
2928          * show a string from the process struct and provide
2929          * the setproctitle() routine to manipulate that. */
2930         if (PL_origalen != 1) {
2931             s = SvPV_const(sv, len);
2932 #   if __FreeBSD_version > 410001
2933             /* The leading "-" removes the "perl: " prefix,
2934              * but not the "(perl) suffix from the ps(1)
2935              * output, because that's what ps(1) shows if the
2936              * argv[] is modified. */
2937             setproctitle("-%s", s);
2938 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2939             /* This doesn't really work if you assume that
2940              * $0 = 'foobar'; will wipe out 'perl' from the $0
2941              * because in ps(1) output the result will be like
2942              * sprintf("perl: %s (perl)", s)
2943              * I guess this is a security feature:
2944              * one (a user process) cannot get rid of the original name.
2945              * --jhi */
2946             setproctitle("%s", s);
2947 #   endif
2948         }
2949 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2950         if (PL_origalen != 1) {
2951              union pstun un;
2952              s = SvPV_const(sv, len);
2953              un.pst_command = (char *)s;
2954              pstat(PSTAT_SETCMD, un, len, 0, 0);
2955         }
2956 #else
2957         if (PL_origalen > 1) {
2958             /* PL_origalen is set in perl_parse(). */
2959             s = SvPV_force(sv,len);
2960             if (len >= (STRLEN)PL_origalen-1) {
2961                 /* Longer than original, will be truncated. We assume that
2962                  * PL_origalen bytes are available. */
2963                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2964             }
2965             else {
2966                 /* Shorter than original, will be padded. */
2967 #ifdef PERL_DARWIN
2968                 /* Special case for Mac OS X: see [perl #38868] */
2969                 const int pad = 0;
2970 #else
2971                 /* Is the space counterintuitive?  Yes.
2972                  * (You were expecting \0?)
2973                  * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2974                  * --jhi */
2975                 const int pad = ' ';
2976 #endif
2977                 Copy(s, PL_origargv[0], len, char);
2978                 PL_origargv[0][len] = 0;
2979                 memset(PL_origargv[0] + len + 1,
2980                        pad,  PL_origalen - len - 1);
2981             }
2982             PL_origargv[0][PL_origalen-1] = 0;
2983             for (i = 1; i < PL_origargc; i++)
2984                 PL_origargv[i] = 0;
2985 #ifdef HAS_PRCTL_SET_NAME
2986             /* Set the legacy process name in addition to the POSIX name on Linux */
2987             if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2988                 /* diag_listed_as: SKIPME */
2989                 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2990             }
2991 #endif
2992         }
2993 #endif
2994         UNLOCK_DOLLARZERO_MUTEX;
2995         break;
2996     }
2997     return 0;
2998 }
2999
3000 I32
3001 Perl_whichsig_sv(pTHX_ SV *sigsv)
3002 {
3003     const char *sigpv;
3004     STRLEN siglen;
3005     PERL_ARGS_ASSERT_WHICHSIG_SV;
3006     PERL_UNUSED_CONTEXT;
3007     sigpv = SvPV_const(sigsv, siglen);
3008     return whichsig_pvn(sigpv, siglen);
3009 }
3010
3011 I32
3012 Perl_whichsig_pv(pTHX_ const char *sig)
3013 {
3014     PERL_ARGS_ASSERT_WHICHSIG_PV;
3015     PERL_UNUSED_CONTEXT;
3016     return whichsig_pvn(sig, strlen(sig));
3017 }
3018
3019 I32
3020 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3021 {
3022     char* const* sigv;
3023
3024     PERL_ARGS_ASSERT_WHICHSIG_PVN;
3025     PERL_UNUSED_CONTEXT;
3026
3027     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3028         if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3029             return PL_sig_num[sigv - (char* const*)PL_sig_name];
3030 #ifdef SIGCLD
3031     if (memEQs(sig, len, "CHLD"))
3032         return SIGCLD;
3033 #endif
3034 #ifdef SIGCHLD
3035     if (memEQs(sig, len, "CLD"))
3036         return SIGCHLD;
3037 #endif
3038     return -1;
3039 }
3040
3041 Signal_t
3042 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3043 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3044 #else
3045 Perl_sighandler(int sig)
3046 #endif
3047 {
3048 #ifdef PERL_GET_SIG_CONTEXT
3049     dTHXa(PERL_GET_SIG_CONTEXT);
3050 #else
3051     dTHX;
3052 #endif
3053     dSP;
3054     GV *gv = NULL;
3055     SV *sv = NULL;
3056     SV * const tSv = PL_Sv;
3057     CV *cv = NULL;
3058     OP *myop = PL_op;
3059     U32 flags = 0;
3060     XPV * const tXpv = PL_Xpv;
3061     I32 old_ss_ix = PL_savestack_ix;
3062     SV *errsv_save = NULL;
3063
3064
3065     if (!PL_psig_ptr[sig]) {
3066                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3067                                  PL_sig_name[sig]);
3068                 exit(sig);
3069         }
3070
3071     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3072         /* Max number of items pushed there is 3*n or 4. We cannot fix
3073            infinity, so we fix 4 (in fact 5): */
3074         if (PL_savestack_ix + 15 <= PL_savestack_max) {
3075             flags |= 1;
3076             PL_savestack_ix += 5;               /* Protect save in progress. */
3077             SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3078         }
3079     }
3080     /* sv_2cv is too complicated, try a simpler variant first: */
3081     if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3082         || SvTYPE(cv) != SVt_PVCV) {
3083         HV *st;
3084         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3085     }
3086
3087     if (!cv || !CvROOT(cv)) {
3088         Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3089                        PL_sig_name[sig], (gv ? GvENAME(gv)
3090                                           : ((cv && CvGV(cv))
3091                                              ? GvENAME(CvGV(cv))
3092                                              : "__ANON__")));
3093         goto cleanup;
3094     }
3095
3096     sv = PL_psig_name[sig]
3097             ? SvREFCNT_inc_NN(PL_psig_name[sig])
3098             : newSVpv(PL_sig_name[sig],0);
3099     flags |= 8;
3100     SAVEFREESV(sv);
3101
3102     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3103         /* make sure our assumption about the size of the SAVEs are correct:
3104          * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3105         assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0)  == PL_savestack_ix);
3106     }
3107
3108     PUSHSTACKi(PERLSI_SIGNAL);
3109     PUSHMARK(SP);
3110     PUSHs(sv);
3111 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3112     {
3113          struct sigaction oact;
3114
3115          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3116               if (sip) {
3117                    HV *sih = newHV();
3118                    SV *rv  = newRV_noinc(MUTABLE_SV(sih));
3119                    /* The siginfo fields signo, code, errno, pid, uid,
3120                     * addr, status, and band are defined by POSIX/SUSv3. */
3121                    (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3122                    (void)hv_stores(sih, "code", newSViv(sip->si_code));
3123 #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. */
3124                    hv_stores(sih, "errno",      newSViv(sip->si_errno));
3125                    hv_stores(sih, "status",     newSViv(sip->si_status));
3126                    hv_stores(sih, "uid",        newSViv(sip->si_uid));
3127                    hv_stores(sih, "pid",        newSViv(sip->si_pid));
3128                    hv_stores(sih, "addr",       newSVuv(PTR2UV(sip->si_addr)));
3129                    hv_stores(sih, "band",       newSViv(sip->si_band));
3130 #endif
3131                    EXTEND(SP, 2);
3132                    PUSHs(rv);
3133                    mPUSHp((char *)sip, sizeof(*sip));
3134               }
3135
3136          }
3137     }
3138 #endif
3139     PUTBACK;
3140
3141     errsv_save = newSVsv(ERRSV);
3142
3143     call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3144
3145     POPSTACK;
3146     {
3147         SV * const errsv = ERRSV;
3148         if (SvTRUE_NN(errsv)) {
3149             SvREFCNT_dec(errsv_save);
3150 #ifndef PERL_MICRO
3151         /* Handler "died", for example to get out of a restart-able read().
3152          * Before we re-do that on its behalf re-enable the signal which was
3153          * blocked by the system when we entered.
3154          */
3155 #ifdef HAS_SIGPROCMASK
3156 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3157             if (sip || uap)
3158 #endif
3159             {
3160                 sigset_t set;
3161                 sigemptyset(&set);
3162                 sigaddset(&set,sig);
3163                 sigprocmask(SIG_UNBLOCK, &set, NULL);
3164             }
3165 #else
3166             /* Not clear if this will work */
3167             (void)rsignal(sig, SIG_IGN);
3168             (void)rsignal(sig, PL_csighandlerp);
3169 #endif
3170 #endif /* !PERL_MICRO */
3171             die_sv(errsv);
3172         }
3173         else {
3174             sv_setsv(errsv, errsv_save);
3175             SvREFCNT_dec(errsv_save);
3176         }
3177     }
3178
3179 cleanup:
3180     /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3181     PL_savestack_ix = old_ss_ix;
3182     if (flags & 8)
3183         SvREFCNT_dec(sv);
3184     PL_op = myop;                       /* Apparently not needed... */
3185
3186     PL_Sv = tSv;                        /* Restore global temporaries. */
3187     PL_Xpv = tXpv;
3188     return;
3189 }
3190
3191
3192 static void
3193 S_restore_magic(pTHX_ const void *p)
3194 {
3195     dVAR;
3196     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3197     SV* const sv = mgs->mgs_sv;
3198     bool bumped;
3199
3200     if (!sv)
3201         return;
3202
3203     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3204         SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3205 #ifdef PERL_OLD_COPY_ON_WRITE
3206         /* While magic was saved (and off) sv_setsv may well have seen
3207            this SV as a prime candidate for COW.  */
3208         if (SvIsCOW(sv))
3209             sv_force_normal_flags(sv, 0);
3210 #endif
3211         if (mgs->mgs_readonly)
3212             SvREADONLY_on(sv);
3213         if (mgs->mgs_magical)
3214             SvFLAGS(sv) |= mgs->mgs_magical;
3215         else
3216             mg_magical(sv);
3217     }
3218
3219     bumped = mgs->mgs_bumped;
3220     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
3221
3222     /* If we're still on top of the stack, pop us off.  (That condition
3223      * will be satisfied if restore_magic was called explicitly, but *not*
3224      * if it's being called via leave_scope.)
3225      * The reason for doing this is that otherwise, things like sv_2cv()
3226      * may leave alloc gunk on the savestack, and some code
3227      * (e.g. sighandler) doesn't expect that...
3228      */
3229     if (PL_savestack_ix == mgs->mgs_ss_ix)
3230     {
3231         UV popval = SSPOPUV;
3232         assert(popval == SAVEt_DESTRUCTOR_X);
3233         PL_savestack_ix -= 2;
3234         popval = SSPOPUV;
3235         assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3236         PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3237     }
3238     if (bumped) {
3239         if (SvREFCNT(sv) == 1) {
3240             /* We hold the last reference to this SV, which implies that the
3241                SV was deleted as a side effect of the routines we called.
3242                So artificially keep it alive a bit longer.
3243                We avoid turning on the TEMP flag, which can cause the SV's
3244                buffer to get stolen (and maybe other stuff). */
3245             sv_2mortal(sv);
3246             SvTEMP_off(sv);
3247         }
3248         else
3249             SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */
3250     }
3251 }
3252
3253 /* clean up the mess created by Perl_sighandler().
3254  * Note that this is only called during an exit in a signal handler;
3255  * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3256  * skipped over. */
3257
3258 static void
3259 S_unwind_handler_stack(pTHX_ const void *p)
3260 {
3261     dVAR;
3262     PERL_UNUSED_ARG(p);
3263
3264     PL_savestack_ix -= 5; /* Unprotect save in progress. */
3265 }
3266
3267 /*
3268 =for apidoc magic_sethint
3269
3270 Triggered by a store to %^H, records the key/value pair to
3271 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
3272 anything that would need a deep copy.  Maybe we should warn if we find a
3273 reference.
3274
3275 =cut
3276 */
3277 int
3278 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3279 {
3280     dVAR;
3281     SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3282         : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3283
3284     PERL_ARGS_ASSERT_MAGIC_SETHINT;
3285
3286     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
3287        an alternative leaf in there, with PL_compiling.cop_hints being used if
3288        it's NULL. If needed for threads, the alternative could lock a mutex,
3289        or take other more complex action.  */
3290
3291     /* Something changed in %^H, so it will need to be restored on scope exit.
3292        Doing this here saves a lot of doing it manually in perl code (and
3293        forgetting to do it, and consequent subtle errors.  */
3294     PL_hints |= HINT_LOCALIZE_HH;
3295     CopHINTHASH_set(&PL_compiling,
3296         cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3297     return 0;
3298 }
3299
3300 /*
3301 =for apidoc magic_clearhint
3302
3303 Triggered by a delete from %^H, records the key to
3304 C<PL_compiling.cop_hints_hash>.
3305
3306 =cut
3307 */
3308 int
3309 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3310 {
3311     dVAR;
3312
3313     PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3314     PERL_UNUSED_ARG(sv);
3315
3316     PL_hints |= HINT_LOCALIZE_HH;
3317     CopHINTHASH_set(&PL_compiling,
3318         mg->mg_len == HEf_SVKEY
3319          ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3320                                  MUTABLE_SV(mg->mg_ptr), 0, 0)
3321          : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3322                                  mg->mg_ptr, mg->mg_len, 0, 0));
3323     return 0;
3324 }
3325
3326 /*
3327 =for apidoc magic_clearhints
3328
3329 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3330
3331 =cut
3332 */
3333 int
3334 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3335 {
3336     PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3337     PERL_UNUSED_ARG(sv);
3338     PERL_UNUSED_ARG(mg);
3339     cophh_free(CopHINTHASH_get(&PL_compiling));
3340     CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3341     return 0;
3342 }
3343
3344 int
3345 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3346                                  const char *name, I32 namlen)
3347 {
3348     MAGIC *nmg;
3349
3350     PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3351     PERL_UNUSED_ARG(sv);
3352     PERL_UNUSED_ARG(name);
3353     PERL_UNUSED_ARG(namlen);
3354
3355     sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3356     nmg = mg_find(nsv, mg->mg_type);
3357     if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3358     nmg->mg_ptr = mg->mg_ptr;
3359     nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3360     nmg->mg_flags |= MGf_REFCOUNTED;
3361     return 1;
3362 }
3363
3364 /*
3365  * Local variables:
3366  * c-indentation-style: bsd
3367  * c-basic-offset: 4
3368  * indent-tabs-mode: nil
3369  * End:
3370  *
3371  * ex: set ts=8 sts=4 sw=4 et:
3372  */