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