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