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(
2649                                 ((STRLEN *)SvPV_nolen_const(sv)) - 1,
2650                                 WARN_ALL)
2651                             && !any_fatals)
2652                     {
2653                         if (!specialWARN(PL_compiling.cop_warnings))
2654                             PerlMemShared_free(PL_compiling.cop_warnings);
2655                         PL_compiling.cop_warnings = pWARN_ALL;
2656                         PL_dowarn |= G_WARN_ONCE ;
2657                     }
2658                     else {
2659                         STRLEN len;
2660                         const char *const p = SvPV_const(sv, len);
2661
2662                         PL_compiling.cop_warnings
2663                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2664                                                          p, len);
2665
2666                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2667                             PL_dowarn |= G_WARN_ONCE ;
2668                     }
2669
2670                 }
2671             }
2672         }
2673         break;
2674     case '.':
2675         if (PL_localizing) {
2676             if (PL_localizing == 1)
2677                 SAVESPTR(PL_last_in_gv);
2678         }
2679         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2680             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2681         break;
2682     case '^':
2683         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2684         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2685         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2686         break;
2687     case '~':
2688         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2689         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2690         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2691         break;
2692     case '=':
2693         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2694         break;
2695     case '-':
2696         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2697         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2698                 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2699         break;
2700     case '%':
2701         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2702         break;
2703     case '|':
2704         {
2705             IO * const io = GvIO(PL_defoutgv);
2706             if(!io)
2707               break;
2708             if ((SvIV(sv)) == 0)
2709                 IoFLAGS(io) &= ~IOf_FLUSH;
2710             else {
2711                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2712                     PerlIO *ofp = IoOFP(io);
2713                     if (ofp)
2714                         (void)PerlIO_flush(ofp);
2715                     IoFLAGS(io) |= IOf_FLUSH;
2716                 }
2717             }
2718         }
2719         break;
2720     case '/':
2721         SvREFCNT_dec(PL_rs);
2722         PL_rs = newSVsv(sv);
2723         break;
2724     case '\\':
2725         SvREFCNT_dec(PL_ors_sv);
2726         if (SvOK(sv)) {
2727             PL_ors_sv = newSVsv(sv);
2728         }
2729         else {
2730             PL_ors_sv = NULL;
2731         }
2732         break;
2733     case '[':
2734         if (SvIV(sv) != 0)
2735             Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
2736         break;
2737     case '?':
2738 #ifdef COMPLEX_STATUS
2739         if (PL_localizing == 2) {
2740             SvUPGRADE(sv, SVt_PVLV);
2741             PL_statusvalue = LvTARGOFF(sv);
2742             PL_statusvalue_vms = LvTARGLEN(sv);
2743         }
2744         else
2745 #endif
2746 #ifdef VMSISH_STATUS
2747         if (VMSISH_STATUS)
2748             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2749         else
2750 #endif
2751             STATUS_UNIX_EXIT_SET(SvIV(sv));
2752         break;
2753     case '!':
2754         {
2755 #ifdef VMS
2756 #   define PERL_VMS_BANG vaxc$errno
2757 #else
2758 #   define PERL_VMS_BANG 0
2759 #endif
2760         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2761                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2762         }
2763         break;
2764     case '<':
2765         {
2766         const IV new_uid = SvIV(sv);
2767         PL_delaymagic_uid = new_uid;
2768         if (PL_delaymagic) {
2769             PL_delaymagic |= DM_RUID;
2770             break;                              /* don't do magic till later */
2771         }
2772 #ifdef HAS_SETRUID
2773         (void)setruid((Uid_t)new_uid);
2774 #else
2775 #ifdef HAS_SETREUID
2776         (void)setreuid((Uid_t)new_uid, (Uid_t)-1);
2777 #else
2778 #ifdef HAS_SETRESUID
2779       (void)setresuid((Uid_t)new_uid, (Uid_t)-1, (Uid_t)-1);
2780 #else
2781         if (new_uid == PerlProc_geteuid()) {            /* special case $< = $> */
2782 #ifdef PERL_DARWIN
2783             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2784             if (new_uid != 0 && PerlProc_getuid() == 0)
2785                 (void)PerlProc_setuid(0);
2786 #endif
2787             (void)PerlProc_setuid(new_uid);
2788         } else {
2789             Perl_croak(aTHX_ "setruid() not implemented");
2790         }
2791 #endif
2792 #endif
2793 #endif
2794         break;
2795         }
2796     case '>':
2797         {
2798         const UV new_euid = SvIV(sv);
2799         PL_delaymagic_euid = new_euid;
2800         if (PL_delaymagic) {
2801             PL_delaymagic |= DM_EUID;
2802             break;                              /* don't do magic till later */
2803         }
2804 #ifdef HAS_SETEUID
2805         (void)seteuid((Uid_t)new_euid);
2806 #else
2807 #ifdef HAS_SETREUID
2808         (void)setreuid((Uid_t)-1, (Uid_t)new_euid);
2809 #else
2810 #ifdef HAS_SETRESUID
2811         (void)setresuid((Uid_t)-1, (Uid_t)new_euid, (Uid_t)-1);
2812 #else
2813         if (new_euid == PerlProc_getuid())              /* special case $> = $< */
2814             PerlProc_setuid(new_euid);
2815         else {
2816             Perl_croak(aTHX_ "seteuid() not implemented");
2817         }
2818 #endif
2819 #endif
2820 #endif
2821         break;
2822         }
2823     case '(':
2824         {
2825         const UV new_gid = SvIV(sv);
2826         PL_delaymagic_gid = new_gid;
2827         if (PL_delaymagic) {
2828             PL_delaymagic |= DM_RGID;
2829             break;                              /* don't do magic till later */
2830         }
2831 #ifdef HAS_SETRGID
2832         (void)setrgid((Gid_t)new_gid);
2833 #else
2834 #ifdef HAS_SETREGID
2835         (void)setregid((Gid_t)new_gid, (Gid_t)-1);
2836 #else
2837 #ifdef HAS_SETRESGID
2838       (void)setresgid((Gid_t)new_gid, (Gid_t)-1, (Gid_t) -1);
2839 #else
2840         if (new_gid == PerlProc_getegid())                      /* special case $( = $) */
2841             (void)PerlProc_setgid(new_gid);
2842         else {
2843             Perl_croak(aTHX_ "setrgid() not implemented");
2844         }
2845 #endif
2846 #endif
2847 #endif
2848         break;
2849         }
2850     case ')':
2851         {
2852         UV new_egid;
2853 #ifdef HAS_SETGROUPS
2854         {
2855             const char *p = SvPV_const(sv, len);
2856             Groups_t *gary = NULL;
2857 #ifdef _SC_NGROUPS_MAX
2858            int maxgrp = sysconf(_SC_NGROUPS_MAX);
2859
2860            if (maxgrp < 0)
2861                maxgrp = NGROUPS;
2862 #else
2863            int maxgrp = NGROUPS;
2864 #endif
2865
2866             while (isSPACE(*p))
2867                 ++p;
2868             new_egid = Atol(p);
2869             for (i = 0; i < maxgrp; ++i) {
2870                 while (*p && !isSPACE(*p))
2871                     ++p;
2872                 while (isSPACE(*p))
2873                     ++p;
2874                 if (!*p)
2875                     break;
2876                 if(!gary)
2877                     Newx(gary, i + 1, Groups_t);
2878                 else
2879                     Renew(gary, i + 1, Groups_t);
2880                 gary[i] = Atol(p);
2881             }
2882             if (i)
2883                 (void)setgroups(i, gary);
2884             Safefree(gary);
2885         }
2886 #else  /* HAS_SETGROUPS */
2887         new_egid = SvIV(sv);
2888 #endif /* HAS_SETGROUPS */
2889         PL_delaymagic_egid = new_egid;
2890         if (PL_delaymagic) {
2891             PL_delaymagic |= DM_EGID;
2892             break;                              /* don't do magic till later */
2893         }
2894 #ifdef HAS_SETEGID
2895         (void)setegid((Gid_t)new_egid);
2896 #else
2897 #ifdef HAS_SETREGID
2898         (void)setregid((Gid_t)-1, (Gid_t)new_egid);
2899 #else
2900 #ifdef HAS_SETRESGID
2901         (void)setresgid((Gid_t)-1, (Gid_t)new_egid, (Gid_t)-1);
2902 #else
2903         if (new_egid == PerlProc_getgid())                      /* special case $) = $( */
2904             (void)PerlProc_setgid(new_egid);
2905         else {
2906             Perl_croak(aTHX_ "setegid() not implemented");
2907         }
2908 #endif
2909 #endif
2910 #endif
2911         break;
2912         }
2913     case ':':
2914         PL_chopset = SvPV_force(sv,len);
2915         break;
2916     case '$': /* $$ */
2917         /* Store the pid in mg->mg_obj so we can tell when a fork has
2918            occurred.  mg->mg_obj points to *$ by default, so clear it. */
2919         if (isGV(mg->mg_obj)) {
2920             if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
2921                 SvREFCNT_dec(mg->mg_obj);
2922             mg->mg_flags |= MGf_REFCOUNTED;
2923             mg->mg_obj = newSViv((IV)PerlProc_getpid());
2924         }
2925         else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
2926         break;
2927     case '0':
2928         LOCK_DOLLARZERO_MUTEX;
2929 #ifdef HAS_SETPROCTITLE
2930         /* The BSDs don't show the argv[] in ps(1) output, they
2931          * show a string from the process struct and provide
2932          * the setproctitle() routine to manipulate that. */
2933         if (PL_origalen != 1) {
2934             s = SvPV_const(sv, len);
2935 #   if __FreeBSD_version > 410001
2936             /* The leading "-" removes the "perl: " prefix,
2937              * but not the "(perl) suffix from the ps(1)
2938              * output, because that's what ps(1) shows if the
2939              * argv[] is modified. */
2940             setproctitle("-%s", s);
2941 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2942             /* This doesn't really work if you assume that
2943              * $0 = 'foobar'; will wipe out 'perl' from the $0
2944              * because in ps(1) output the result will be like
2945              * sprintf("perl: %s (perl)", s)
2946              * I guess this is a security feature:
2947              * one (a user process) cannot get rid of the original name.
2948              * --jhi */
2949             setproctitle("%s", s);
2950 #   endif
2951         }
2952 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2953         if (PL_origalen != 1) {
2954              union pstun un;
2955              s = SvPV_const(sv, len);
2956              un.pst_command = (char *)s;
2957              pstat(PSTAT_SETCMD, un, len, 0, 0);
2958         }
2959 #else
2960         if (PL_origalen > 1) {
2961             /* PL_origalen is set in perl_parse(). */
2962             s = SvPV_force(sv,len);
2963             if (len >= (STRLEN)PL_origalen-1) {
2964                 /* Longer than original, will be truncated. We assume that
2965                  * PL_origalen bytes are available. */
2966                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2967             }
2968             else {
2969                 /* Shorter than original, will be padded. */
2970 #ifdef PERL_DARWIN
2971                 /* Special case for Mac OS X: see [perl #38868] */
2972                 const int pad = 0;
2973 #else
2974                 /* Is the space counterintuitive?  Yes.
2975                  * (You were expecting \0?)
2976                  * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2977                  * --jhi */
2978                 const int pad = ' ';
2979 #endif
2980                 Copy(s, PL_origargv[0], len, char);
2981                 PL_origargv[0][len] = 0;
2982                 memset(PL_origargv[0] + len + 1,
2983                        pad,  PL_origalen - len - 1);
2984             }
2985             PL_origargv[0][PL_origalen-1] = 0;
2986             for (i = 1; i < PL_origargc; i++)
2987                 PL_origargv[i] = 0;
2988 #ifdef HAS_PRCTL_SET_NAME
2989             /* Set the legacy process name in addition to the POSIX name on Linux */
2990             if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2991                 /* diag_listed_as: SKIPME */
2992                 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2993             }
2994 #endif
2995         }
2996 #endif
2997         UNLOCK_DOLLARZERO_MUTEX;
2998         break;
2999     }
3000     return 0;
3001 }
3002
3003 I32
3004 Perl_whichsig_sv(pTHX_ SV *sigsv)
3005 {
3006     const char *sigpv;
3007     STRLEN siglen;
3008     PERL_ARGS_ASSERT_WHICHSIG_SV;
3009     PERL_UNUSED_CONTEXT;
3010     sigpv = SvPV_const(sigsv, siglen);
3011     return whichsig_pvn(sigpv, siglen);
3012 }
3013
3014 I32
3015 Perl_whichsig_pv(pTHX_ const char *sig)
3016 {
3017     PERL_ARGS_ASSERT_WHICHSIG_PV;
3018     PERL_UNUSED_CONTEXT;
3019     return whichsig_pvn(sig, strlen(sig));
3020 }
3021
3022 I32
3023 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3024 {
3025     char* const* sigv;
3026
3027     PERL_ARGS_ASSERT_WHICHSIG_PVN;
3028     PERL_UNUSED_CONTEXT;
3029
3030     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3031         if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3032             return PL_sig_num[sigv - (char* const*)PL_sig_name];
3033 #ifdef SIGCLD
3034     if (memEQs(sig, len, "CHLD"))
3035         return SIGCLD;
3036 #endif
3037 #ifdef SIGCHLD
3038     if (memEQs(sig, len, "CLD"))
3039         return SIGCHLD;
3040 #endif
3041     return -1;
3042 }
3043
3044 Signal_t
3045 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3046 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3047 #else
3048 Perl_sighandler(int sig)
3049 #endif
3050 {
3051 #ifdef PERL_GET_SIG_CONTEXT
3052     dTHXa(PERL_GET_SIG_CONTEXT);
3053 #else
3054     dTHX;
3055 #endif
3056     dSP;
3057     GV *gv = NULL;
3058     SV *sv = NULL;
3059     SV * const tSv = PL_Sv;
3060     CV *cv = NULL;
3061     OP *myop = PL_op;
3062     U32 flags = 0;
3063     XPV * const tXpv = PL_Xpv;
3064     I32 old_ss_ix = PL_savestack_ix;
3065     SV *errsv_save = NULL;
3066
3067
3068     if (!PL_psig_ptr[sig]) {
3069                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3070                                  PL_sig_name[sig]);
3071                 exit(sig);
3072         }
3073
3074     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3075         /* Max number of items pushed there is 3*n or 4. We cannot fix
3076            infinity, so we fix 4 (in fact 5): */
3077         if (PL_savestack_ix + 15 <= PL_savestack_max) {
3078             flags |= 1;
3079             PL_savestack_ix += 5;               /* Protect save in progress. */
3080             SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3081         }
3082     }
3083     /* sv_2cv is too complicated, try a simpler variant first: */
3084     if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3085         || SvTYPE(cv) != SVt_PVCV) {
3086         HV *st;
3087         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3088     }
3089
3090     if (!cv || !CvROOT(cv)) {
3091         Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3092                        PL_sig_name[sig], (gv ? GvENAME(gv)
3093                                           : ((cv && CvGV(cv))
3094                                              ? GvENAME(CvGV(cv))
3095                                              : "__ANON__")));
3096         goto cleanup;
3097     }
3098
3099     sv = PL_psig_name[sig]
3100             ? SvREFCNT_inc_NN(PL_psig_name[sig])
3101             : newSVpv(PL_sig_name[sig],0);
3102     flags |= 8;
3103     SAVEFREESV(sv);
3104
3105     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3106         /* make sure our assumption about the size of the SAVEs are correct:
3107          * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3108         assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0)  == PL_savestack_ix);
3109     }
3110
3111     PUSHSTACKi(PERLSI_SIGNAL);
3112     PUSHMARK(SP);
3113     PUSHs(sv);
3114 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3115     {
3116          struct sigaction oact;
3117
3118          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3119               if (sip) {
3120                    HV *sih = newHV();
3121                    SV *rv  = newRV_noinc(MUTABLE_SV(sih));
3122                    /* The siginfo fields signo, code, errno, pid, uid,
3123                     * addr, status, and band are defined by POSIX/SUSv3. */
3124                    (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3125                    (void)hv_stores(sih, "code", newSViv(sip->si_code));
3126 #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. */
3127                    hv_stores(sih, "errno",      newSViv(sip->si_errno));
3128                    hv_stores(sih, "status",     newSViv(sip->si_status));
3129                    hv_stores(sih, "uid",        newSViv(sip->si_uid));
3130                    hv_stores(sih, "pid",        newSViv(sip->si_pid));
3131                    hv_stores(sih, "addr",       newSVuv(PTR2UV(sip->si_addr)));
3132                    hv_stores(sih, "band",       newSViv(sip->si_band));
3133 #endif
3134                    EXTEND(SP, 2);
3135                    PUSHs(rv);
3136                    mPUSHp((char *)sip, sizeof(*sip));
3137               }
3138
3139          }
3140     }
3141 #endif
3142     PUTBACK;
3143
3144     errsv_save = newSVsv(ERRSV);
3145
3146     call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3147
3148     POPSTACK;
3149     {
3150         SV * const errsv = ERRSV;
3151         if (SvTRUE_NN(errsv)) {
3152             SvREFCNT_dec(errsv_save);
3153 #ifndef PERL_MICRO
3154         /* Handler "died", for example to get out of a restart-able read().
3155          * Before we re-do that on its behalf re-enable the signal which was
3156          * blocked by the system when we entered.
3157          */
3158 #ifdef HAS_SIGPROCMASK
3159 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3160             if (sip || uap)
3161 #endif
3162             {
3163                 sigset_t set;
3164                 sigemptyset(&set);
3165                 sigaddset(&set,sig);
3166                 sigprocmask(SIG_UNBLOCK, &set, NULL);
3167             }
3168 #else
3169             /* Not clear if this will work */
3170             (void)rsignal(sig, SIG_IGN);
3171             (void)rsignal(sig, PL_csighandlerp);
3172 #endif
3173 #endif /* !PERL_MICRO */
3174             die_sv(errsv);
3175         }
3176         else {
3177             sv_setsv(errsv, errsv_save);
3178             SvREFCNT_dec(errsv_save);
3179         }
3180     }
3181
3182 cleanup:
3183     /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3184     PL_savestack_ix = old_ss_ix;
3185     if (flags & 8)
3186         SvREFCNT_dec(sv);
3187     PL_op = myop;                       /* Apparently not needed... */
3188
3189     PL_Sv = tSv;                        /* Restore global temporaries. */
3190     PL_Xpv = tXpv;
3191     return;
3192 }
3193
3194
3195 static void
3196 S_restore_magic(pTHX_ const void *p)
3197 {
3198     dVAR;
3199     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3200     SV* const sv = mgs->mgs_sv;
3201     bool bumped;
3202
3203     if (!sv)
3204         return;
3205
3206     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3207         SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3208 #ifdef PERL_OLD_COPY_ON_WRITE
3209         /* While magic was saved (and off) sv_setsv may well have seen
3210            this SV as a prime candidate for COW.  */
3211         if (SvIsCOW(sv))
3212             sv_force_normal_flags(sv, 0);
3213 #endif
3214         if (mgs->mgs_readonly)
3215             SvREADONLY_on(sv);
3216         if (mgs->mgs_magical)
3217             SvFLAGS(sv) |= mgs->mgs_magical;
3218         else
3219             mg_magical(sv);
3220     }
3221
3222     bumped = mgs->mgs_bumped;
3223     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
3224
3225     /* If we're still on top of the stack, pop us off.  (That condition
3226      * will be satisfied if restore_magic was called explicitly, but *not*
3227      * if it's being called via leave_scope.)
3228      * The reason for doing this is that otherwise, things like sv_2cv()
3229      * may leave alloc gunk on the savestack, and some code
3230      * (e.g. sighandler) doesn't expect that...
3231      */
3232     if (PL_savestack_ix == mgs->mgs_ss_ix)
3233     {
3234         UV popval = SSPOPUV;
3235         assert(popval == SAVEt_DESTRUCTOR_X);
3236         PL_savestack_ix -= 2;
3237         popval = SSPOPUV;
3238         assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3239         PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3240     }
3241     if (bumped) {
3242         if (SvREFCNT(sv) == 1) {
3243             /* We hold the last reference to this SV, which implies that the
3244                SV was deleted as a side effect of the routines we called.
3245                So artificially keep it alive a bit longer.
3246                We avoid turning on the TEMP flag, which can cause the SV's
3247                buffer to get stolen (and maybe other stuff). */
3248             sv_2mortal(sv);
3249             SvTEMP_off(sv);
3250         }
3251         else
3252             SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */
3253     }
3254 }
3255
3256 /* clean up the mess created by Perl_sighandler().
3257  * Note that this is only called during an exit in a signal handler;
3258  * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3259  * skipped over. */
3260
3261 static void
3262 S_unwind_handler_stack(pTHX_ const void *p)
3263 {
3264     dVAR;
3265     PERL_UNUSED_ARG(p);
3266
3267     PL_savestack_ix -= 5; /* Unprotect save in progress. */
3268 }
3269
3270 /*
3271 =for apidoc magic_sethint
3272
3273 Triggered by a store to %^H, records the key/value pair to
3274 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
3275 anything that would need a deep copy.  Maybe we should warn if we find a
3276 reference.
3277
3278 =cut
3279 */
3280 int
3281 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3282 {
3283     dVAR;
3284     SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3285         : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3286
3287     PERL_ARGS_ASSERT_MAGIC_SETHINT;
3288
3289     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
3290        an alternative leaf in there, with PL_compiling.cop_hints being used if
3291        it's NULL. If needed for threads, the alternative could lock a mutex,
3292        or take other more complex action.  */
3293
3294     /* Something changed in %^H, so it will need to be restored on scope exit.
3295        Doing this here saves a lot of doing it manually in perl code (and
3296        forgetting to do it, and consequent subtle errors.  */
3297     PL_hints |= HINT_LOCALIZE_HH;
3298     CopHINTHASH_set(&PL_compiling,
3299         cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3300     return 0;
3301 }
3302
3303 /*
3304 =for apidoc magic_clearhint
3305
3306 Triggered by a delete from %^H, records the key to
3307 C<PL_compiling.cop_hints_hash>.
3308
3309 =cut
3310 */
3311 int
3312 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3313 {
3314     dVAR;
3315
3316     PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3317     PERL_UNUSED_ARG(sv);
3318
3319     PL_hints |= HINT_LOCALIZE_HH;
3320     CopHINTHASH_set(&PL_compiling,
3321         mg->mg_len == HEf_SVKEY
3322          ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3323                                  MUTABLE_SV(mg->mg_ptr), 0, 0)
3324          : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3325                                  mg->mg_ptr, mg->mg_len, 0, 0));
3326     return 0;
3327 }
3328
3329 /*
3330 =for apidoc magic_clearhints
3331
3332 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3333
3334 =cut
3335 */
3336 int
3337 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3338 {
3339     PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3340     PERL_UNUSED_ARG(sv);
3341     PERL_UNUSED_ARG(mg);
3342     cophh_free(CopHINTHASH_get(&PL_compiling));
3343     CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3344     return 0;
3345 }
3346
3347 int
3348 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3349                                  const char *name, I32 namlen)
3350 {
3351     MAGIC *nmg;
3352
3353     PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3354     PERL_UNUSED_ARG(sv);
3355     PERL_UNUSED_ARG(name);
3356     PERL_UNUSED_ARG(namlen);
3357
3358     sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3359     nmg = mg_find(nsv, mg->mg_type);
3360     if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3361     nmg->mg_ptr = mg->mg_ptr;
3362     nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3363     nmg->mg_flags |= MGf_REFCOUNTED;
3364     return 1;
3365 }
3366
3367 /*
3368  * Local variables:
3369  * c-indentation-style: bsd
3370  * c-basic-offset: 4
3371  * indent-tabs-mode: nil
3372  * End:
3373  *
3374  * ex: set ts=8 sts=4 sw=4 et:
3375  */