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