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