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 #ifdef PERL_USE_3ARG_SIGHANDLER
1537         (*PL_sighandlerp)(sig, NULL, NULL);
1538 #else
1539         (*PL_sighandlerp)(sig);
1540 #endif
1541     else {
1542         if (!PL_psig_pend) return;
1543         /* Set a flag to say this signal is pending, that is awaiting delivery after
1544          * the current Perl opcode completes */
1545         PL_psig_pend[sig]++;
1546
1547 #ifndef SIG_PENDING_DIE_COUNT
1548 #  define SIG_PENDING_DIE_COUNT 120
1549 #endif
1550         /* Add one to say _a_ signal is pending */
1551         if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1552             Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1553                        (unsigned long)SIG_PENDING_DIE_COUNT);
1554     }
1555 }
1556
1557 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1558 void
1559 Perl_csighandler_init(void)
1560 {
1561     int sig;
1562     if (PL_sig_handlers_initted) return;
1563
1564     for (sig = 1; sig < SIG_SIZE; sig++) {
1565 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1566         dTHX;
1567         PL_sig_defaulting[sig] = 1;
1568         (void) rsignal(sig, PL_csighandlerp);
1569 #endif
1570 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1571         PL_sig_ignoring[sig] = 0;
1572 #endif
1573     }
1574     PL_sig_handlers_initted = 1;
1575 }
1576 #endif
1577
1578 #if defined HAS_SIGPROCMASK
1579 static void
1580 unblock_sigmask(pTHX_ void* newset)
1581 {
1582     PERL_UNUSED_CONTEXT;
1583     sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1584 }
1585 #endif
1586
1587 void
1588 Perl_despatch_signals(pTHX)
1589 {
1590     int sig;
1591     PL_sig_pending = 0;
1592     for (sig = 1; sig < SIG_SIZE; sig++) {
1593         if (PL_psig_pend[sig]) {
1594             dSAVE_ERRNO;
1595 #ifdef HAS_SIGPROCMASK
1596             /* From sigaction(2) (FreeBSD man page):
1597              * | Signal routines normally execute with the signal that
1598              * | caused their invocation blocked, but other signals may
1599              * | yet occur.
1600              * Emulation of this behavior (from within Perl) is enabled
1601              * using sigprocmask
1602              */
1603             int was_blocked;
1604             sigset_t newset, oldset;
1605
1606             sigemptyset(&newset);
1607             sigaddset(&newset, sig);
1608             sigprocmask(SIG_BLOCK, &newset, &oldset);
1609             was_blocked = sigismember(&oldset, sig);
1610             if (!was_blocked) {
1611                 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1612                 ENTER;
1613                 SAVEFREESV(save_sv);
1614                 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1615             }
1616 #endif
1617             PL_psig_pend[sig] = 0;
1618 #ifdef PERL_USE_3ARG_SIGHANDLER
1619             (*PL_sighandlerp)(sig, NULL, NULL);
1620 #else
1621             (*PL_sighandlerp)(sig);
1622 #endif
1623 #ifdef HAS_SIGPROCMASK
1624             if (!was_blocked)
1625                 LEAVE;
1626 #endif
1627             RESTORE_ERRNO;
1628         }
1629     }
1630 }
1631
1632 /* sv of NULL signifies that we're acting as magic_clearsig.  */
1633 int
1634 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1635 {
1636     dVAR;
1637     I32 i;
1638     SV** svp = NULL;
1639     /* Need to be careful with SvREFCNT_dec(), because that can have side
1640      * effects (due to closures). We must make sure that the new disposition
1641      * is in place before it is called.
1642      */
1643     SV* to_dec = NULL;
1644     STRLEN len;
1645 #ifdef HAS_SIGPROCMASK
1646     sigset_t set, save;
1647     SV* save_sv;
1648 #endif
1649     const char *s = MgPV_const(mg,len);
1650
1651     PERL_ARGS_ASSERT_MAGIC_SETSIG;
1652
1653     if (*s == '_') {
1654         if (memEQs(s, len, "__DIE__"))
1655             svp = &PL_diehook;
1656         else if (memEQs(s, len, "__WARN__")
1657                  && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1658             /* Merge the existing behaviours, which are as follows:
1659                magic_setsig, we always set svp to &PL_warnhook
1660                (hence we always change the warnings handler)
1661                For magic_clearsig, we don't change the warnings handler if it's
1662                set to the &PL_warnhook.  */
1663             svp = &PL_warnhook;
1664         } else if (sv) {
1665             SV *tmp = sv_newmortal();
1666             Perl_croak(aTHX_ "No such hook: %s",
1667                                 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1668         }
1669         i = 0;
1670         if (svp && *svp) {
1671             if (*svp != PERL_WARNHOOK_FATAL)
1672                 to_dec = *svp;
1673             *svp = NULL;
1674         }
1675     }
1676     else {
1677         i = (I16)mg->mg_private;
1678         if (!i) {
1679             i = whichsig_pvn(s, len);   /* ...no, a brick */
1680             mg->mg_private = (U16)i;
1681         }
1682         if (i <= 0) {
1683             if (sv) {
1684                 SV *tmp = sv_newmortal();
1685                 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1686                                             pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1687             }
1688             return 0;
1689         }
1690 #ifdef HAS_SIGPROCMASK
1691         /* Avoid having the signal arrive at a bad time, if possible. */
1692         sigemptyset(&set);
1693         sigaddset(&set,i);
1694         sigprocmask(SIG_BLOCK, &set, &save);
1695         ENTER;
1696         save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1697         SAVEFREESV(save_sv);
1698         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1699 #endif
1700         PERL_ASYNC_CHECK();
1701 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1702         if (!PL_sig_handlers_initted) Perl_csighandler_init();
1703 #endif
1704 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1705         PL_sig_ignoring[i] = 0;
1706 #endif
1707 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1708         PL_sig_defaulting[i] = 0;
1709 #endif
1710         to_dec = PL_psig_ptr[i];
1711         if (sv) {
1712             PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1713             SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1714
1715             /* Signals don't change name during the program's execution, so once
1716                they're cached in the appropriate slot of PL_psig_name, they can
1717                stay there.
1718
1719                Ideally we'd find some way of making SVs at (C) compile time, or
1720                at least, doing most of the work.  */
1721             if (!PL_psig_name[i]) {
1722                 PL_psig_name[i] = newSVpvn(s, len);
1723                 SvREADONLY_on(PL_psig_name[i]);
1724             }
1725         } else {
1726             SvREFCNT_dec(PL_psig_name[i]);
1727             PL_psig_name[i] = NULL;
1728             PL_psig_ptr[i] = NULL;
1729         }
1730     }
1731     if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1732         if (i) {
1733             (void)rsignal(i, PL_csighandlerp);
1734         }
1735         else
1736             *svp = SvREFCNT_inc_simple_NN(sv);
1737     } else {
1738         if (sv && SvOK(sv)) {
1739             s = SvPV_force(sv, len);
1740         } else {
1741             sv = NULL;
1742         }
1743         if (sv && memEQs(s, len,"IGNORE")) {
1744             if (i) {
1745 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1746                 PL_sig_ignoring[i] = 1;
1747                 (void)rsignal(i, PL_csighandlerp);
1748 #else
1749                 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1750 #endif
1751             }
1752         }
1753         else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
1754             if (i) {
1755 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1756                 PL_sig_defaulting[i] = 1;
1757                 (void)rsignal(i, PL_csighandlerp);
1758 #else
1759                 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1760 #endif
1761             }
1762         }
1763         else {
1764             /*
1765              * We should warn if HINT_STRICT_REFS, but without
1766              * access to a known hint bit in a known OP, we can't
1767              * tell whether HINT_STRICT_REFS is in force or not.
1768              */
1769             if (!memchr(s, ':', len) && !memchr(s, '\'', len))
1770                 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1771                                      SV_GMAGIC);
1772             if (i)
1773                 (void)rsignal(i, PL_csighandlerp);
1774             else
1775                 *svp = SvREFCNT_inc_simple_NN(sv);
1776         }
1777     }
1778
1779 #ifdef HAS_SIGPROCMASK
1780     if(i)
1781         LEAVE;
1782 #endif
1783     SvREFCNT_dec(to_dec);
1784     return 0;
1785 }
1786 #endif /* !PERL_MICRO */
1787
1788 int
1789 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1790 {
1791     PERL_ARGS_ASSERT_MAGIC_SETISA;
1792     PERL_UNUSED_ARG(sv);
1793
1794     /* Skip _isaelem because _isa will handle it shortly */
1795     if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1796         return 0;
1797
1798     return magic_clearisa(NULL, mg);
1799 }
1800
1801 /* sv of NULL signifies that we're acting as magic_setisa.  */
1802 int
1803 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1804 {
1805     HV* stash;
1806     PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1807
1808     /* Bail out if destruction is going on */
1809     if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1810
1811     if (sv)
1812         av_clear(MUTABLE_AV(sv));
1813
1814     if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1815         /* This occurs with setisa_elem magic, which calls this
1816            same function. */
1817         mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1818
1819     assert(mg);
1820     if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1821         SV **svp = AvARRAY((AV *)mg->mg_obj);
1822         I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1823         while (items--) {
1824             stash = GvSTASH((GV *)*svp++);
1825             if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1826         }
1827
1828         return 0;
1829     }
1830
1831     stash = GvSTASH(
1832         (const GV *)mg->mg_obj
1833     );
1834
1835     /* The stash may have been detached from the symbol table, so check its
1836        name before doing anything. */
1837     if (stash && HvENAME_get(stash))
1838         mro_isa_changed_in(stash);
1839
1840     return 0;
1841 }
1842
1843 int
1844 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1845 {
1846     HV * const hv = MUTABLE_HV(LvTARG(sv));
1847     I32 i = 0;
1848
1849     PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1850     PERL_UNUSED_ARG(mg);
1851
1852     if (hv) {
1853          (void) hv_iterinit(hv);
1854          if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1855              i = HvUSEDKEYS(hv);
1856          else {
1857              while (hv_iternext(hv))
1858                  i++;
1859          }
1860     }
1861
1862     sv_setiv(sv, (IV)i);
1863     return 0;
1864 }
1865
1866 int
1867 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1868 {
1869     PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1870     PERL_UNUSED_ARG(mg);
1871     if (LvTARG(sv)) {
1872         hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1873     }
1874     return 0;
1875 }
1876
1877 /*
1878 =for apidoc magic_methcall
1879
1880 Invoke a magic method (like FETCH).
1881
1882 C<sv> and C<mg> are the tied thingy and the tie magic.
1883
1884 C<meth> is the name of the method to call.
1885
1886 C<argc> is the number of args (in addition to $self) to pass to the method.
1887
1888 The C<flags> can be:
1889
1890     G_DISCARD     invoke method with G_DISCARD flag and don't
1891                   return a value
1892     G_UNDEF_FILL  fill the stack with argc pointers to
1893                   PL_sv_undef
1894
1895 The arguments themselves are any values following the C<flags> argument.
1896
1897 Returns the SV (if any) returned by the method, or C<NULL> on failure.
1898
1899
1900 =cut
1901 */
1902
1903 SV*
1904 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1905                     U32 argc, ...)
1906 {
1907     dSP;
1908     SV* ret = NULL;
1909
1910     PERL_ARGS_ASSERT_MAGIC_METHCALL;
1911
1912     ENTER;
1913
1914     if (flags & G_WRITING_TO_STDERR) {
1915         SAVETMPS;
1916
1917         save_re_context();
1918         SAVESPTR(PL_stderrgv);
1919         PL_stderrgv = NULL;
1920     }
1921
1922     PUSHSTACKi(PERLSI_MAGIC);
1923     PUSHMARK(SP);
1924
1925     /* EXTEND() expects a signed argc; don't wrap when casting */
1926     assert(argc <= I32_MAX);
1927     EXTEND(SP, (I32)argc+1);
1928     PUSHs(SvTIED_obj(sv, mg));
1929     if (flags & G_UNDEF_FILL) {
1930         while (argc--) {
1931             PUSHs(&PL_sv_undef);
1932         }
1933     } else if (argc > 0) {
1934         va_list args;
1935         va_start(args, argc);
1936
1937         do {
1938             SV *const this_sv = va_arg(args, SV *);
1939             PUSHs(this_sv);
1940         } while (--argc);
1941
1942         va_end(args);
1943     }
1944     PUTBACK;
1945     if (flags & G_DISCARD) {
1946         call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED);
1947     }
1948     else {
1949         if (call_sv(meth, G_SCALAR|G_METHOD_NAMED))
1950             ret = *PL_stack_sp--;
1951     }
1952     POPSTACK;
1953     if (flags & G_WRITING_TO_STDERR)
1954         FREETMPS;
1955     LEAVE;
1956     return ret;
1957 }
1958
1959 /* wrapper for magic_methcall that creates the first arg */
1960
1961 STATIC SV*
1962 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1963     int n, SV *val)
1964 {
1965     SV* arg1 = NULL;
1966
1967     PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1968
1969     if (mg->mg_ptr) {
1970         if (mg->mg_len >= 0) {
1971             arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1972         }
1973         else if (mg->mg_len == HEf_SVKEY)
1974             arg1 = MUTABLE_SV(mg->mg_ptr);
1975     }
1976     else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1977         arg1 = newSViv((IV)(mg->mg_len));
1978         sv_2mortal(arg1);
1979     }
1980     if (!arg1) {
1981         return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1982     }
1983     return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1984 }
1985
1986 STATIC int
1987 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth)
1988 {
1989     SV* ret;
1990
1991     PERL_ARGS_ASSERT_MAGIC_METHPACK;
1992
1993     ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1994     if (ret)
1995         sv_setsv(sv, ret);
1996     return 0;
1997 }
1998
1999 int
2000 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
2001 {
2002     PERL_ARGS_ASSERT_MAGIC_GETPACK;
2003
2004     if (mg->mg_type == PERL_MAGIC_tiedelem)
2005         mg->mg_flags |= MGf_GSKIP;
2006     magic_methpack(sv,mg,SV_CONST(FETCH));
2007     return 0;
2008 }
2009
2010 int
2011 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
2012 {
2013     MAGIC *tmg;
2014     SV    *val;
2015
2016     PERL_ARGS_ASSERT_MAGIC_SETPACK;
2017
2018     /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
2019      * STORE() is not $val, but rather a PVLV (the sv in this call), whose
2020      * public flags indicate its value based on copying from $val. Doing
2021      * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
2022      * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
2023      * wrong if $val happened to be tainted, as sv hasn't got magic
2024      * enabled, even though taint magic is in the chain. In which case,
2025      * fake up a temporary tainted value (this is easier than temporarily
2026      * re-enabling magic on sv). */
2027
2028     if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint))
2029         && (tmg->mg_len & 1))
2030     {
2031         val = sv_mortalcopy(sv);
2032         SvTAINTED_on(val);
2033     }
2034     else
2035         val = sv;
2036
2037     magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val);
2038     return 0;
2039 }
2040
2041 int
2042 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
2043 {
2044     PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
2045
2046     if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
2047     return magic_methpack(sv,mg,SV_CONST(DELETE));
2048 }
2049
2050
2051 U32
2052 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
2053 {
2054     I32 retval = 0;
2055     SV* retsv;
2056
2057     PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
2058
2059     retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL);
2060     if (retsv) {
2061         retval = SvIV(retsv)-1;
2062         if (retval < -1)
2063             Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
2064     }
2065     return (U32) retval;
2066 }
2067
2068 int
2069 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
2070 {
2071     PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
2072
2073     Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0);
2074     return 0;
2075 }
2076
2077 int
2078 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
2079 {
2080     SV* ret;
2081
2082     PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
2083
2084     ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key)
2085         : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0);
2086     if (ret)
2087         sv_setsv(key,ret);
2088     return 0;
2089 }
2090
2091 int
2092 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
2093 {
2094     PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
2095
2096     return magic_methpack(sv,mg,SV_CONST(EXISTS));
2097 }
2098
2099 SV *
2100 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
2101 {
2102     SV *retval;
2103     SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
2104     HV * const pkg = SvSTASH((const SV *)SvRV(tied));
2105
2106     PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
2107
2108     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
2109         SV *key;
2110         if (HvEITER_get(hv))
2111             /* we are in an iteration so the hash cannot be empty */
2112             return &PL_sv_yes;
2113         /* no xhv_eiter so now use FIRSTKEY */
2114         key = sv_newmortal();
2115         magic_nextpack(MUTABLE_SV(hv), mg, key);
2116         HvEITER_set(hv, NULL);     /* need to reset iterator */
2117         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
2118     }
2119
2120     /* there is a SCALAR method that we can call */
2121     retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0);
2122     if (!retval)
2123         retval = &PL_sv_undef;
2124     return retval;
2125 }
2126
2127 int
2128 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
2129 {
2130     SV **svp;
2131
2132     PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
2133
2134     /* The magic ptr/len for the debugger's hash should always be an SV.  */
2135     if (UNLIKELY(mg->mg_len != HEf_SVKEY)) {
2136         Perl_croak(aTHX_ "panic: magic_setdbline len=%" IVdf ", ptr='%s'",
2137                    (IV)mg->mg_len, mg->mg_ptr);
2138     }
2139
2140     /* Use sv_2iv instead of SvIV() as the former generates smaller code, and
2141        setting/clearing debugger breakpoints is not a hot path.  */
2142     svp = av_fetch(MUTABLE_AV(mg->mg_obj),
2143                    sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE);
2144
2145     if (svp && SvIOKp(*svp)) {
2146         OP * const o = INT2PTR(OP*,SvIVX(*svp));
2147         if (o) {
2148 #ifdef PERL_DEBUG_READONLY_OPS
2149             Slab_to_rw(OpSLAB(o));
2150 #endif
2151             /* set or clear breakpoint in the relevant control op */
2152             if (SvTRUE(sv))
2153                 o->op_flags |= OPf_SPECIAL;
2154             else
2155                 o->op_flags &= ~OPf_SPECIAL;
2156 #ifdef PERL_DEBUG_READONLY_OPS
2157             Slab_to_ro(OpSLAB(o));
2158 #endif
2159         }
2160     }
2161     return 0;
2162 }
2163
2164 int
2165 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
2166 {
2167     AV * const obj = MUTABLE_AV(mg->mg_obj);
2168
2169     PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2170
2171     if (obj) {
2172         sv_setiv(sv, AvFILL(obj));
2173     } else {
2174         sv_set_undef(sv);
2175     }
2176     return 0;
2177 }
2178
2179 int
2180 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2181 {
2182     AV * const obj = MUTABLE_AV(mg->mg_obj);
2183
2184     PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2185
2186     if (obj) {
2187         av_fill(obj, SvIV(sv));
2188     } else {
2189         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2190                        "Attempt to set length of freed array");
2191     }
2192     return 0;
2193 }
2194
2195 int
2196 Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
2197 {
2198     PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
2199     PERL_UNUSED_ARG(sv);
2200     PERL_UNUSED_CONTEXT;
2201
2202     /* Reset the iterator when the array is cleared */
2203     if (sizeof(IV) == sizeof(SSize_t)) {
2204         *((IV *) &(mg->mg_len)) = 0;
2205     } else {
2206         if (mg->mg_ptr)
2207             *((IV *) mg->mg_ptr) = 0;
2208     }
2209
2210     return 0;
2211 }
2212
2213 int
2214 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2215 {
2216     PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2217     PERL_UNUSED_ARG(sv);
2218
2219     /* during global destruction, mg_obj may already have been freed */
2220     if (PL_in_clean_all)
2221         return 0;
2222
2223     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2224
2225     if (mg) {
2226         /* arylen scalar holds a pointer back to the array, but doesn't own a
2227            reference. Hence the we (the array) are about to go away with it
2228            still pointing at us. Clear its pointer, else it would be pointing
2229            at free memory. See the comment in sv_magic about reference loops,
2230            and why it can't own a reference to us.  */
2231         mg->mg_obj = 0;
2232     }
2233     return 0;
2234 }
2235
2236 int
2237 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2238 {
2239     SV* const lsv = LvTARG(sv);
2240     MAGIC * const found = mg_find_mglob(lsv);
2241
2242     PERL_ARGS_ASSERT_MAGIC_GETPOS;
2243     PERL_UNUSED_ARG(mg);
2244
2245     if (found && found->mg_len != -1) {
2246             STRLEN i = found->mg_len;
2247             if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv))
2248                 i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN);
2249             sv_setuv(sv, i);
2250             return 0;
2251     }
2252     sv_set_undef(sv);
2253     return 0;
2254 }
2255
2256 int
2257 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2258 {
2259     SV* const lsv = LvTARG(sv);
2260     SSize_t pos;
2261     STRLEN len;
2262     MAGIC* found;
2263     const char *s;
2264
2265     PERL_ARGS_ASSERT_MAGIC_SETPOS;
2266     PERL_UNUSED_ARG(mg);
2267
2268     found = mg_find_mglob(lsv);
2269     if (!found) {
2270         if (!SvOK(sv))
2271             return 0;
2272         found = sv_magicext_mglob(lsv);
2273     }
2274     else if (!SvOK(sv)) {
2275         found->mg_len = -1;
2276         return 0;
2277     }
2278     s = SvPV_const(lsv, len);
2279
2280     pos = SvIV(sv);
2281
2282     if (DO_UTF8(lsv)) {
2283         const STRLEN ulen = sv_or_pv_len_utf8(lsv, s, len);
2284         if (ulen)
2285             len = ulen;
2286     }
2287
2288     if (pos < 0) {
2289         pos += len;
2290         if (pos < 0)
2291             pos = 0;
2292     }
2293     else if (pos > (SSize_t)len)
2294         pos = len;
2295
2296     found->mg_len = pos;
2297     found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES);
2298
2299     return 0;
2300 }
2301
2302 int
2303 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2304 {
2305     STRLEN len;
2306     SV * const lsv = LvTARG(sv);
2307     const char * const tmps = SvPV_const(lsv,len);
2308     STRLEN offs = LvTARGOFF(sv);
2309     STRLEN rem = LvTARGLEN(sv);
2310     const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
2311     const bool negrem = LvFLAGS(sv) & LVf_NEG_LEN;
2312
2313     PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2314     PERL_UNUSED_ARG(mg);
2315
2316     if (!translate_substr_offsets(
2317             SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
2318             negoff ? -(IV)offs : (IV)offs, !negoff,
2319             negrem ? -(IV)rem  : (IV)rem,  !negrem, &offs, &rem
2320     )) {
2321         Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2322         sv_set_undef(sv);
2323         return 0;
2324     }
2325
2326     if (SvUTF8(lsv))
2327         offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
2328     sv_setpvn(sv, tmps + offs, rem);
2329     if (SvUTF8(lsv))
2330         SvUTF8_on(sv);
2331     return 0;
2332 }
2333
2334 int
2335 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2336 {
2337     STRLEN len, lsv_len, oldtarglen, newtarglen;
2338     const char * const tmps = SvPV_const(sv, len);
2339     SV * const lsv = LvTARG(sv);
2340     STRLEN lvoff = LvTARGOFF(sv);
2341     STRLEN lvlen = LvTARGLEN(sv);
2342     const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
2343     const bool neglen = LvFLAGS(sv) & LVf_NEG_LEN;
2344
2345     PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2346     PERL_UNUSED_ARG(mg);
2347
2348     SvGETMAGIC(lsv);
2349     if (SvROK(lsv))
2350         Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2351                             "Attempt to use reference as lvalue in substr"
2352         );
2353     SvPV_force_nomg(lsv,lsv_len);
2354     if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
2355     if (!translate_substr_offsets(
2356             lsv_len,
2357             negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2358             neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2359     ))
2360         Perl_croak(aTHX_ "substr outside of string");
2361     oldtarglen = lvlen;
2362     if (DO_UTF8(sv)) {
2363         sv_utf8_upgrade_nomg(lsv);
2364         lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2365         sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2366         newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
2367         SvUTF8_on(lsv);
2368     }
2369     else if (SvUTF8(lsv)) {
2370         const char *utf8;
2371         lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2372         newtarglen = len;
2373         utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2374         sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2375         Safefree(utf8);
2376     }
2377     else {
2378         sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2379         newtarglen = len;
2380     }
2381     if (!neglen) LvTARGLEN(sv) = newtarglen;
2382     if (negoff)  LvTARGOFF(sv) += newtarglen - oldtarglen;
2383
2384     return 0;
2385 }
2386
2387 int
2388 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2389 {
2390     PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2391     PERL_UNUSED_ARG(sv);
2392 #ifdef NO_TAINT_SUPPORT
2393     PERL_UNUSED_ARG(mg);
2394 #endif
2395
2396     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1) && IN_PERL_RUNTIME);
2397     return 0;
2398 }
2399
2400 int
2401 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2402 {
2403     PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2404     PERL_UNUSED_ARG(sv);
2405
2406     /* update taint status */
2407     if (TAINT_get)
2408         mg->mg_len |= 1;
2409     else
2410         mg->mg_len &= ~1;
2411     return 0;
2412 }
2413
2414 int
2415 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2416 {
2417     SV * const lsv = LvTARG(sv);
2418     char errflags = LvFLAGS(sv);
2419
2420     PERL_ARGS_ASSERT_MAGIC_GETVEC;
2421     PERL_UNUSED_ARG(mg);
2422
2423     /* non-zero errflags implies deferred out-of-range condition */
2424     assert(!(errflags & ~(LVf_NEG_OFF|LVf_OUT_OF_RANGE)));
2425     sv_setuv(sv, errflags ? 0 : do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2426
2427     return 0;
2428 }
2429
2430 int
2431 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2432 {
2433     PERL_ARGS_ASSERT_MAGIC_SETVEC;
2434     PERL_UNUSED_ARG(mg);
2435     do_vecset(sv);      /* XXX slurp this routine */
2436     return 0;
2437 }
2438
2439 SV *
2440 Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg)
2441 {
2442     SV *targ = NULL;
2443     PERL_ARGS_ASSERT_DEFELEM_TARGET;
2444     if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem);
2445     assert(mg);
2446     if (LvTARGLEN(sv)) {
2447         if (mg->mg_obj) {
2448             SV * const ahv = LvTARG(sv);
2449             HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2450             if (he)
2451                 targ = HeVAL(he);
2452         }
2453         else if (LvSTARGOFF(sv) >= 0) {
2454             AV *const av = MUTABLE_AV(LvTARG(sv));
2455             if (LvSTARGOFF(sv) <= AvFILL(av))
2456             {
2457               if (SvRMAGICAL(av)) {
2458                 SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0);
2459                 targ = svp ? *svp : NULL;
2460               }
2461               else
2462                 targ = AvARRAY(av)[LvSTARGOFF(sv)];
2463             }
2464         }
2465         if (targ && (targ != &PL_sv_undef)) {
2466             /* somebody else defined it for us */
2467             SvREFCNT_dec(LvTARG(sv));
2468             LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2469             LvTARGLEN(sv) = 0;
2470             SvREFCNT_dec(mg->mg_obj);
2471             mg->mg_obj = NULL;
2472             mg->mg_flags &= ~MGf_REFCOUNTED;
2473         }
2474         return targ;
2475     }
2476     else
2477         return LvTARG(sv);
2478 }
2479
2480 int
2481 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2482 {
2483     PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2484
2485     sv_setsv(sv, defelem_target(sv, mg));
2486     return 0;
2487 }
2488
2489 int
2490 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2491 {
2492     PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2493     PERL_UNUSED_ARG(mg);
2494     if (LvTARGLEN(sv))
2495         vivify_defelem(sv);
2496     if (LvTARG(sv)) {
2497         sv_setsv(LvTARG(sv), sv);
2498         SvSETMAGIC(LvTARG(sv));
2499     }
2500     return 0;
2501 }
2502
2503 void
2504 Perl_vivify_defelem(pTHX_ SV *sv)
2505 {
2506     MAGIC *mg;
2507     SV *value = NULL;
2508
2509     PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2510
2511     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2512         return;
2513     if (mg->mg_obj) {
2514         SV * const ahv = LvTARG(sv);
2515         HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2516         if (he)
2517             value = HeVAL(he);
2518         if (!value || value == &PL_sv_undef)
2519             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2520     }
2521     else if (LvSTARGOFF(sv) < 0)
2522         Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2523     else {
2524         AV *const av = MUTABLE_AV(LvTARG(sv));
2525         if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av))
2526             LvTARG(sv) = NULL;  /* array can't be extended */
2527         else {
2528             SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE);
2529             if (!svp || !(value = *svp))
2530                 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2531         }
2532     }
2533     SvREFCNT_inc_simple_void(value);
2534     SvREFCNT_dec(LvTARG(sv));
2535     LvTARG(sv) = value;
2536     LvTARGLEN(sv) = 0;
2537     SvREFCNT_dec(mg->mg_obj);
2538     mg->mg_obj = NULL;
2539     mg->mg_flags &= ~MGf_REFCOUNTED;
2540 }
2541
2542 int
2543 Perl_magic_setnonelem(pTHX_ SV *sv, MAGIC *mg)
2544 {
2545     PERL_ARGS_ASSERT_MAGIC_SETNONELEM;
2546     PERL_UNUSED_ARG(mg);
2547     sv_unmagic(sv, PERL_MAGIC_nonelem);
2548     return 0;
2549 }
2550
2551 int
2552 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2553 {
2554     PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2555     Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2556     return 0;
2557 }
2558
2559 int
2560 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2561 {
2562     PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2563     PERL_UNUSED_CONTEXT;
2564     PERL_UNUSED_ARG(sv);
2565     mg->mg_len = -1;
2566     return 0;
2567 }
2568
2569 int
2570 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2571 {
2572     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2573
2574     PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2575
2576     if (uf && uf->uf_set)
2577         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2578     return 0;
2579 }
2580
2581 int
2582 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2583 {
2584     const char type = mg->mg_type;
2585
2586     PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2587
2588     assert(    type == PERL_MAGIC_fm
2589             || type == PERL_MAGIC_qr
2590             || type == PERL_MAGIC_bm);
2591     return sv_unmagic(sv, type);
2592 }
2593
2594 #ifdef USE_LOCALE_COLLATE
2595 int
2596 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2597 {
2598     PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2599
2600     /*
2601      * RenE<eacute> Descartes said "I think not."
2602      * and vanished with a faint plop.
2603      */
2604     PERL_UNUSED_CONTEXT;
2605     PERL_UNUSED_ARG(sv);
2606     if (mg->mg_ptr) {
2607         Safefree(mg->mg_ptr);
2608         mg->mg_ptr = NULL;
2609         mg->mg_len = -1;
2610     }
2611     return 0;
2612 }
2613 #endif /* USE_LOCALE_COLLATE */
2614
2615 /* Just clear the UTF-8 cache data. */
2616 int
2617 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2618 {
2619     PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2620     PERL_UNUSED_CONTEXT;
2621     PERL_UNUSED_ARG(sv);
2622     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2623     mg->mg_ptr = NULL;
2624     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2625     return 0;
2626 }
2627
2628 int
2629 Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg)
2630 {
2631     const char *bad = NULL;
2632     PERL_ARGS_ASSERT_MAGIC_SETLVREF;
2633     if (!SvROK(sv)) Perl_croak(aTHX_ "Assigned value is not a reference");
2634     switch (mg->mg_private & OPpLVREF_TYPE) {
2635     case OPpLVREF_SV:
2636         if (SvTYPE(SvRV(sv)) > SVt_PVLV)
2637             bad = " SCALAR";
2638         break;
2639     case OPpLVREF_AV:
2640         if (SvTYPE(SvRV(sv)) != SVt_PVAV)
2641             bad = "n ARRAY";
2642         break;
2643     case OPpLVREF_HV:
2644         if (SvTYPE(SvRV(sv)) != SVt_PVHV)
2645             bad = " HASH";
2646         break;
2647     case OPpLVREF_CV:
2648         if (SvTYPE(SvRV(sv)) != SVt_PVCV)
2649             bad = " CODE";
2650     }
2651     if (bad)
2652         /* diag_listed_as: Assigned value is not %s reference */
2653         Perl_croak(aTHX_ "Assigned value is not a%s reference", bad);
2654     switch (mg->mg_obj ? SvTYPE(mg->mg_obj) : 0) {
2655     case 0:
2656     {
2657         SV * const old = PAD_SV(mg->mg_len);
2658         PAD_SETSV(mg->mg_len, SvREFCNT_inc_NN(SvRV(sv)));
2659         SvREFCNT_dec(old);
2660         break;
2661     }
2662     case SVt_PVGV:
2663         gv_setref(mg->mg_obj, sv);
2664         SvSETMAGIC(mg->mg_obj);
2665         break;
2666     case SVt_PVAV:
2667         av_store((AV *)mg->mg_obj, SvIV((SV *)mg->mg_ptr),
2668                  SvREFCNT_inc_simple_NN(SvRV(sv)));
2669         break;
2670     case SVt_PVHV:
2671         (void)hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr,
2672                            SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
2673     }
2674     if (mg->mg_flags & MGf_PERSIST)
2675         NOOP; /* This sv is in use as an iterator var and will be reused,
2676                  so we must leave the magic.  */
2677     else
2678         /* This sv could be returned by the assignment op, so clear the
2679            magic, as lvrefs are an implementation detail that must not be
2680            leaked to the user.  */
2681         sv_unmagic(sv, PERL_MAGIC_lvref);
2682     return 0;
2683 }
2684
2685 static void
2686 S_set_dollarzero(pTHX_ SV *sv)
2687     PERL_TSA_REQUIRES(PL_dollarzero_mutex)
2688 {
2689 #ifdef USE_ITHREADS
2690     dVAR;
2691 #endif
2692     const char *s;
2693     STRLEN len;
2694 #ifdef HAS_SETPROCTITLE
2695     /* The BSDs don't show the argv[] in ps(1) output, they
2696      * show a string from the process struct and provide
2697      * the setproctitle() routine to manipulate that. */
2698     if (PL_origalen != 1) {
2699         s = SvPV_const(sv, len);
2700 #   if __FreeBSD_version > 410001 || defined(__DragonFly__)
2701         /* The leading "-" removes the "perl: " prefix,
2702          * but not the "(perl) suffix from the ps(1)
2703          * output, because that's what ps(1) shows if the
2704          * argv[] is modified. */
2705         setproctitle("-%s", s);
2706 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2707         /* This doesn't really work if you assume that
2708          * $0 = 'foobar'; will wipe out 'perl' from the $0
2709          * because in ps(1) output the result will be like
2710          * sprintf("perl: %s (perl)", s)
2711          * I guess this is a security feature:
2712          * one (a user process) cannot get rid of the original name.
2713          * --jhi */
2714         setproctitle("%s", s);
2715 #   endif
2716     }
2717 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2718     if (PL_origalen != 1) {
2719         union pstun un;
2720         s = SvPV_const(sv, len);
2721         un.pst_command = (char *)s;
2722         pstat(PSTAT_SETCMD, un, len, 0, 0);
2723     }
2724 #else
2725     if (PL_origalen > 1) {
2726         I32 i;
2727         /* PL_origalen is set in perl_parse(). */
2728         s = SvPV_force(sv,len);
2729         if (len >= (STRLEN)PL_origalen-1) {
2730             /* Longer than original, will be truncated. We assume that
2731              * PL_origalen bytes are available. */
2732             Copy(s, PL_origargv[0], PL_origalen-1, char);
2733         }
2734         else {
2735             /* Shorter than original, will be padded. */
2736 #ifdef PERL_DARWIN
2737             /* Special case for Mac OS X: see [perl #38868] */
2738             const int pad = 0;
2739 #else
2740             /* Is the space counterintuitive?  Yes.
2741              * (You were expecting \0?)
2742              * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2743              * --jhi */
2744             const int pad = ' ';
2745 #endif
2746             Copy(s, PL_origargv[0], len, char);
2747             PL_origargv[0][len] = 0;
2748             memset(PL_origargv[0] + len + 1,
2749                    pad,  PL_origalen - len - 1);
2750         }
2751         PL_origargv[0][PL_origalen-1] = 0;
2752         for (i = 1; i < PL_origargc; i++)
2753             PL_origargv[i] = 0;
2754 #ifdef HAS_PRCTL_SET_NAME
2755         /* Set the legacy process name in addition to the POSIX name on Linux */
2756         if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2757             /* diag_listed_as: SKIPME */
2758             Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2759         }
2760 #endif
2761     }
2762 #endif
2763 }
2764
2765 int
2766 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2767 {
2768 #ifdef USE_ITHREADS
2769     dVAR;
2770 #endif
2771     I32 paren;
2772     const REGEXP * rx;
2773     I32 i;
2774     STRLEN len;
2775     MAGIC *tmg;
2776
2777     PERL_ARGS_ASSERT_MAGIC_SET;
2778
2779     if (!mg->mg_ptr) {
2780         paren = mg->mg_len;
2781         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2782           setparen_got_rx:
2783             CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2784         } else {
2785             /* Croak with a READONLY error when a numbered match var is
2786              * set without a previous pattern match. Unless it's C<local $1>
2787              */
2788           croakparen:
2789             if (!PL_localizing) {
2790                 Perl_croak_no_modify();
2791             }
2792         }
2793         return 0;
2794     }
2795
2796     switch (*mg->mg_ptr) {
2797     case '\001':        /* ^A */
2798         if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2799         else SvOK_off(PL_bodytarget);
2800         FmLINES(PL_bodytarget) = 0;
2801         if (SvPOK(PL_bodytarget)) {
2802             char *s = SvPVX(PL_bodytarget);
2803             char *e = SvEND(PL_bodytarget);
2804             while ( ((s = (char *) memchr(s, '\n', e - s))) ) {
2805                 FmLINES(PL_bodytarget)++;
2806                 s++;
2807             }
2808         }
2809         /* mg_set() has temporarily made sv non-magical */
2810         if (TAINTING_get) {
2811             if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2812                 SvTAINTED_on(PL_bodytarget);
2813             else
2814                 SvTAINTED_off(PL_bodytarget);
2815         }
2816         break;
2817     case '\003':        /* ^C */
2818         PL_minus_c = cBOOL(SvIV(sv));
2819         break;
2820
2821     case '\004':        /* ^D */
2822 #ifdef DEBUGGING
2823         {
2824             const char *s = SvPV_nolen_const(sv);
2825             PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2826             if (DEBUG_x_TEST || DEBUG_B_TEST)
2827                 dump_all_perl(!DEBUG_B_TEST);
2828         }
2829 #else
2830         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2831 #endif
2832         break;
2833     case '\005':  /* ^E */
2834         if (*(mg->mg_ptr+1) == '\0') {
2835 #ifdef VMS
2836             set_vaxc_errno(SvIV(sv));
2837 #elif defined(WIN32)
2838             SetLastError( SvIV(sv) );
2839 #elif defined(OS2)
2840             os2_setsyserrno(SvIV(sv));
2841 #else
2842             /* will anyone ever use this? */
2843             SETERRNO(SvIV(sv), 4);
2844 #endif
2845         }
2846         else if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv))
2847             Perl_croak(aTHX_ "${^ENCODING} is no longer supported");
2848         break;
2849     case '\006':        /* ^F */
2850         if (mg->mg_ptr[1] == '\0') {
2851             PL_maxsysfd = SvIV(sv);
2852         }
2853         else if (strEQ(mg->mg_ptr + 1, "EATURE_BITS")) {
2854             PL_compiling.cop_features = SvUV(sv);
2855         }
2856         break;
2857     case '\010':        /* ^H */
2858         {
2859             U32 save_hints = PL_hints;
2860             PL_hints = SvUV(sv);
2861
2862             /* If wasn't UTF-8, and now is, notify the parser */
2863             if ((PL_hints & HINT_UTF8) && ! (save_hints & HINT_UTF8)) {
2864                 notify_parser_that_changed_to_utf8();
2865             }
2866         }
2867         break;
2868     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2869         Safefree(PL_inplace);
2870         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2871         break;
2872     case '\016':        /* ^N */
2873         if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2874          && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2875         goto croakparen;
2876     case '\017':        /* ^O */
2877         if (*(mg->mg_ptr+1) == '\0') {
2878             Safefree(PL_osname);
2879             PL_osname = NULL;
2880             if (SvOK(sv)) {
2881                 TAINT_PROPER("assigning to $^O");
2882                 PL_osname = savesvpv(sv);
2883             }
2884         }
2885         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2886             STRLEN len;
2887             const char *const start = SvPV(sv, len);
2888             const char *out = (const char*)memchr(start, '\0', len);
2889             SV *tmp;
2890
2891
2892             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2893             PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2894
2895             /* Opening for input is more common than opening for output, so
2896                ensure that hints for input are sooner on linked list.  */
2897             tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2898                                        SvUTF8(sv))
2899                 : newSVpvs_flags("", SvUTF8(sv));
2900             (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2901             mg_set(tmp);
2902
2903             tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2904                                         SvUTF8(sv));
2905             (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2906             mg_set(tmp);
2907         }
2908         break;
2909     case '\020':        /* ^P */
2910           PL_perldb = SvIV(sv);
2911           if (PL_perldb && !PL_DBsingle)
2912               init_debugger();
2913       break;
2914     case '\024':        /* ^T */
2915 #ifdef BIG_TIME
2916         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2917 #else
2918         PL_basetime = (Time_t)SvIV(sv);
2919 #endif
2920         break;
2921     case '\025':        /* ^UTF8CACHE */
2922          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2923              PL_utf8cache = (signed char) sv_2iv(sv);
2924          }
2925          break;
2926     case '\027':        /* ^W & $^WARNING_BITS */
2927         if (*(mg->mg_ptr+1) == '\0') {
2928             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2929                 i = SvIV(sv);
2930                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2931                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2932             }
2933         }
2934         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2935             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2936                 if (!SvPOK(sv)) {
2937                     if (!specialWARN(PL_compiling.cop_warnings))
2938                         PerlMemShared_free(PL_compiling.cop_warnings);
2939                     PL_compiling.cop_warnings = pWARN_STD;
2940                     break;
2941                 }
2942                 {
2943                     STRLEN len, i;
2944                     int not_none = 0, not_all = 0;
2945                     const U8 * const ptr = (const U8 *)SvPV_const(sv, len) ;
2946                     for (i = 0 ; i < len ; ++i) {
2947                         not_none |= ptr[i];
2948                         not_all |= ptr[i] ^ 0x55;
2949                     }
2950                     if (!not_none) {
2951                         if (!specialWARN(PL_compiling.cop_warnings))
2952                             PerlMemShared_free(PL_compiling.cop_warnings);
2953                         PL_compiling.cop_warnings = pWARN_NONE;
2954                     } else if (len >= WARNsize && !not_all) {
2955                         if (!specialWARN(PL_compiling.cop_warnings))
2956                             PerlMemShared_free(PL_compiling.cop_warnings);
2957                         PL_compiling.cop_warnings = pWARN_ALL;
2958                         PL_dowarn |= G_WARN_ONCE ;
2959                     }
2960                     else {
2961                         STRLEN len;
2962                         const char *const p = SvPV_const(sv, len);
2963
2964                         PL_compiling.cop_warnings
2965                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2966                                                          p, len);
2967
2968                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2969                             PL_dowarn |= G_WARN_ONCE ;
2970                     }
2971
2972                 }
2973             }
2974         }
2975 #ifdef WIN32
2976         else if (strEQ(mg->mg_ptr+1, "IN32_SLOPPY_STAT")) {
2977             w32_sloppystat = (bool)sv_true(sv);
2978         }
2979 #endif
2980         break;
2981     case '.':
2982         if (PL_localizing) {
2983             if (PL_localizing == 1)
2984                 SAVESPTR(PL_last_in_gv);
2985         }
2986         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2987             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2988         break;
2989     case '^':
2990         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2991         IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2992         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2993         break;
2994     case '~':
2995         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2996         IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2997         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2998         break;
2999     case '=':
3000         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
3001         break;
3002     case '-':
3003         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
3004         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
3005                 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
3006         break;
3007     case '%':
3008         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
3009         break;
3010     case '|':
3011         {
3012             IO * const io = GvIO(PL_defoutgv);
3013             if(!io)
3014               break;
3015             if ((SvIV(sv)) == 0)
3016                 IoFLAGS(io) &= ~IOf_FLUSH;
3017             else {
3018                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
3019                     PerlIO *ofp = IoOFP(io);
3020                     if (ofp)
3021                         (void)PerlIO_flush(ofp);
3022                     IoFLAGS(io) |= IOf_FLUSH;
3023                 }
3024             }
3025         }
3026         break;
3027     case '/':
3028         {
3029             if (SvROK(sv)) {
3030                 SV *referent = SvRV(sv);
3031                 const char *reftype = sv_reftype(referent, 0);
3032                 /* XXX: dodgy type check: This leaves me feeling dirty, but
3033                  * the alternative is to copy pretty much the entire
3034                  * sv_reftype() into this routine, or to do a full string
3035                  * comparison on the return of sv_reftype() both of which
3036                  * make me feel worse! NOTE, do not modify this comment
3037                  * without reviewing the corresponding comment in
3038                  * sv_reftype(). - Yves */
3039                 if (reftype[0] == 'S' || reftype[0] == 'L') {
3040                     IV val = SvIV(referent);
3041                     if (val <= 0) {
3042                         sv_setsv(sv, PL_rs);
3043                         Perl_croak(aTHX_ "Setting $/ to a reference to %s is forbidden",
3044                                          val < 0 ? "a negative integer" : "zero");
3045                     }
3046                 } else {
3047                     sv_setsv(sv, PL_rs);
3048                     /* diag_listed_as: Setting $/ to %s reference is forbidden */
3049                     Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
3050                                       *reftype == 'A' ? "n" : "", reftype);
3051                 }
3052             }
3053             SvREFCNT_dec(PL_rs);
3054             PL_rs = newSVsv(sv);
3055         }
3056         break;
3057     case '\\':
3058         SvREFCNT_dec(PL_ors_sv);
3059         if (SvOK(sv)) {
3060             PL_ors_sv = newSVsv(sv);
3061         }
3062         else {
3063             PL_ors_sv = NULL;
3064         }
3065         break;
3066     case '[':
3067         if (SvIV(sv) != 0)
3068             Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
3069         break;
3070     case '?':
3071 #ifdef COMPLEX_STATUS
3072         if (PL_localizing == 2) {
3073             SvUPGRADE(sv, SVt_PVLV);
3074             PL_statusvalue = LvTARGOFF(sv);
3075             PL_statusvalue_vms = LvTARGLEN(sv);
3076         }
3077         else
3078 #endif
3079 #ifdef VMSISH_STATUS
3080         if (VMSISH_STATUS)
3081             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
3082         else
3083 #endif
3084             STATUS_UNIX_EXIT_SET(SvIV(sv));
3085         break;
3086     case '!':
3087         {
3088 #ifdef VMS
3089 #   define PERL_VMS_BANG vaxc$errno
3090 #else
3091 #   define PERL_VMS_BANG 0
3092 #endif
3093 #if defined(WIN32)
3094         SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0),
3095                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
3096 #else
3097         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
3098                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
3099 #endif
3100         }
3101         break;
3102     case '<':
3103         {
3104         /* XXX $< currently silently ignores failures */
3105         const Uid_t new_uid = SvUID(sv);
3106         PL_delaymagic_uid = new_uid;
3107         if (PL_delaymagic) {
3108             PL_delaymagic |= DM_RUID;
3109             break;                              /* don't do magic till later */
3110         }
3111 #ifdef HAS_SETRUID
3112         PERL_UNUSED_RESULT(setruid(new_uid));
3113 #elif defined(HAS_SETREUID)
3114         PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1));
3115 #elif defined(HAS_SETRESUID)
3116         PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1));
3117 #else
3118         if (new_uid == PerlProc_geteuid()) {            /* special case $< = $> */
3119 #  ifdef PERL_DARWIN
3120             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
3121             if (new_uid != 0 && PerlProc_getuid() == 0)
3122                 PERL_UNUSED_RESULT(PerlProc_setuid(0));
3123 #  endif
3124             PERL_UNUSED_RESULT(PerlProc_setuid(new_uid));
3125         } else {
3126             Perl_croak(aTHX_ "setruid() not implemented");
3127         }
3128 #endif
3129         break;
3130         }
3131     case '>':
3132         {
3133         /* XXX $> currently silently ignores failures */
3134         const Uid_t new_euid = SvUID(sv);
3135         PL_delaymagic_euid = new_euid;
3136         if (PL_delaymagic) {
3137             PL_delaymagic |= DM_EUID;
3138             break;                              /* don't do magic till later */
3139         }
3140 #ifdef HAS_SETEUID
3141         PERL_UNUSED_RESULT(seteuid(new_euid));
3142 #elif defined(HAS_SETREUID)
3143         PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid));
3144 #elif defined(HAS_SETRESUID)
3145         PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1));
3146 #else
3147         if (new_euid == PerlProc_getuid())              /* special case $> = $< */
3148             PERL_UNUSED_RESULT(PerlProc_setuid(new_euid));
3149         else {
3150             Perl_croak(aTHX_ "seteuid() not implemented");
3151         }
3152 #endif
3153         break;
3154         }
3155     case '(':
3156         {
3157         /* XXX $( currently silently ignores failures */
3158         const Gid_t new_gid = SvGID(sv);
3159         PL_delaymagic_gid = new_gid;
3160         if (PL_delaymagic) {
3161             PL_delaymagic |= DM_RGID;
3162             break;                              /* don't do magic till later */
3163         }
3164 #ifdef HAS_SETRGID
3165         PERL_UNUSED_RESULT(setrgid(new_gid));
3166 #elif defined(HAS_SETREGID)
3167         PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1));
3168 #elif defined(HAS_SETRESGID)
3169         PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1));
3170 #else
3171         if (new_gid == PerlProc_getegid())                      /* special case $( = $) */
3172             PERL_UNUSED_RESULT(PerlProc_setgid(new_gid));
3173         else {
3174             Perl_croak(aTHX_ "setrgid() not implemented");
3175         }
3176 #endif
3177         break;
3178         }
3179     case ')':
3180         {
3181 /* (hv) best guess: maybe we'll need configure probes to do a better job,
3182  * but you can override it if you need to.
3183  */
3184 #ifndef INVALID_GID
3185 #define INVALID_GID ((Gid_t)-1)
3186 #endif
3187         /* XXX $) currently silently ignores failures */
3188         Gid_t new_egid;
3189 #ifdef HAS_SETGROUPS
3190         {
3191             const char *p = SvPV_const(sv, len);
3192             Groups_t *gary = NULL;
3193             const char* p_end = p + len;
3194             const char* endptr = p_end;
3195             UV uv;
3196 #ifdef _SC_NGROUPS_MAX
3197            int maxgrp = sysconf(_SC_NGROUPS_MAX);
3198
3199            if (maxgrp < 0)
3200                maxgrp = NGROUPS;
3201 #else
3202            int maxgrp = NGROUPS;
3203 #endif
3204
3205             while (isSPACE(*p))
3206                 ++p;
3207             if (grok_atoUV(p, &uv, &endptr))
3208                 new_egid = (Gid_t)uv;
3209             else {
3210                 new_egid = INVALID_GID;
3211                 endptr = NULL;
3212             }
3213             for (i = 0; i < maxgrp; ++i) {
3214                 if (endptr == NULL)
3215                     break;
3216                 p = endptr;
3217                 endptr = p_end;
3218                 while (isSPACE(*p))
3219                     ++p;
3220                 if (!*p)
3221                     break;
3222                 if (!gary)
3223                     Newx(gary, i + 1, Groups_t);
3224                 else
3225                     Renew(gary, i + 1, Groups_t);
3226                 if (grok_atoUV(p, &uv, &endptr))
3227                     gary[i] = (Groups_t)uv;
3228                 else {
3229                     gary[i] = INVALID_GID;
3230                     endptr = NULL;
3231                 }
3232             }
3233             if (i)
3234                 PERL_UNUSED_RESULT(setgroups(i, gary));
3235             Safefree(gary);
3236         }
3237 #else  /* HAS_SETGROUPS */
3238         new_egid = SvGID(sv);
3239 #endif /* HAS_SETGROUPS */
3240         PL_delaymagic_egid = new_egid;
3241         if (PL_delaymagic) {
3242             PL_delaymagic |= DM_EGID;
3243             break;                              /* don't do magic till later */
3244         }
3245 #ifdef HAS_SETEGID
3246         PERL_UNUSED_RESULT(setegid(new_egid));
3247 #elif defined(HAS_SETREGID)
3248         PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid));
3249 #elif defined(HAS_SETRESGID)
3250         PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1));
3251 #else
3252         if (new_egid == PerlProc_getgid())                      /* special case $) = $( */
3253             PERL_UNUSED_RESULT(PerlProc_setgid(new_egid));
3254         else {
3255             Perl_croak(aTHX_ "setegid() not implemented");
3256         }
3257 #endif
3258         break;
3259         }
3260     case ':':
3261         PL_chopset = SvPV_force(sv,len);
3262         break;
3263     case '$': /* $$ */
3264         /* Store the pid in mg->mg_obj so we can tell when a fork has
3265            occurred.  mg->mg_obj points to *$ by default, so clear it. */
3266         if (isGV(mg->mg_obj)) {
3267             if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
3268                 SvREFCNT_dec(mg->mg_obj);
3269             mg->mg_flags |= MGf_REFCOUNTED;
3270             mg->mg_obj = newSViv((IV)PerlProc_getpid());
3271         }
3272         else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
3273         break;
3274     case '0':
3275         LOCK_DOLLARZERO_MUTEX;
3276         S_set_dollarzero(aTHX_ sv);
3277         UNLOCK_DOLLARZERO_MUTEX;
3278         break;
3279     }
3280     return 0;
3281 }
3282
3283 I32
3284 Perl_whichsig_sv(pTHX_ SV *sigsv)
3285 {
3286     const char *sigpv;
3287     STRLEN siglen;
3288     PERL_ARGS_ASSERT_WHICHSIG_SV;
3289     sigpv = SvPV_const(sigsv, siglen);
3290     return whichsig_pvn(sigpv, siglen);
3291 }
3292
3293 I32
3294 Perl_whichsig_pv(pTHX_ const char *sig)
3295 {
3296     PERL_ARGS_ASSERT_WHICHSIG_PV;
3297     return whichsig_pvn(sig, strlen(sig));
3298 }
3299
3300 I32
3301 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3302 {
3303     char* const* sigv;
3304
3305     PERL_ARGS_ASSERT_WHICHSIG_PVN;
3306     PERL_UNUSED_CONTEXT;
3307
3308     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3309         if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3310             return PL_sig_num[sigv - (char* const*)PL_sig_name];
3311 #ifdef SIGCLD
3312     if (memEQs(sig, len, "CHLD"))
3313         return SIGCLD;
3314 #endif
3315 #ifdef SIGCHLD
3316     if (memEQs(sig, len, "CLD"))
3317         return SIGCHLD;
3318 #endif
3319     return -1;
3320 }
3321
3322 Signal_t
3323 #ifdef PERL_USE_3ARG_SIGHANDLER
3324 Perl_sighandler(int sig, Siginfo_t *sip, void *uap)
3325 #else
3326 Perl_sighandler(int sig)
3327 #endif
3328 {
3329 #ifdef PERL_GET_SIG_CONTEXT
3330     dTHXa(PERL_GET_SIG_CONTEXT);
3331 #else
3332     dTHX;
3333 #endif
3334     dSP;
3335     GV *gv = NULL;
3336     SV *sv = NULL;
3337     SV * const tSv = PL_Sv;
3338     CV *cv = NULL;
3339     OP *myop = PL_op;
3340     U32 flags = 0;
3341     XPV * const tXpv = PL_Xpv;
3342     I32 old_ss_ix = PL_savestack_ix;
3343     SV *errsv_save = NULL;
3344
3345
3346     if (!PL_psig_ptr[sig]) {
3347                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3348                                  PL_sig_name[sig]);
3349                 exit(sig);
3350         }
3351
3352     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3353         /* Max number of items pushed there is 3*n or 4. We cannot fix
3354            infinity, so we fix 4 (in fact 5): */
3355         if (PL_savestack_ix + 15 <= PL_savestack_max) {
3356             flags |= 1;
3357             PL_savestack_ix += 5;               /* Protect save in progress. */
3358             SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3359         }
3360     }
3361     /* sv_2cv is too complicated, try a simpler variant first: */
3362     if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3363         || SvTYPE(cv) != SVt_PVCV) {
3364         HV *st;
3365         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3366     }
3367
3368     if (!cv || !CvROOT(cv)) {
3369         const HEK * const hek = gv
3370                         ? GvENAME_HEK(gv)
3371                         : cv && CvNAMED(cv)
3372                            ? CvNAME_HEK(cv)
3373                            : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL;
3374         if (hek)
3375             Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3376                                 "SIG%s handler \"%" HEKf "\" not defined.\n",
3377                                  PL_sig_name[sig], HEKfARG(hek));
3378              /* diag_listed_as: SIG%s handler "%s" not defined */
3379         else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3380                            "SIG%s handler \"__ANON__\" not defined.\n",
3381                             PL_sig_name[sig]);
3382         goto cleanup;
3383     }
3384
3385     sv = PL_psig_name[sig]
3386             ? SvREFCNT_inc_NN(PL_psig_name[sig])
3387             : newSVpv(PL_sig_name[sig],0);
3388     flags |= 8;
3389     SAVEFREESV(sv);
3390
3391     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3392         /* make sure our assumption about the size of the SAVEs are correct:
3393          * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3394         assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0)  == PL_savestack_ix);
3395     }
3396
3397     PUSHSTACKi(PERLSI_SIGNAL);
3398     PUSHMARK(SP);
3399     PUSHs(sv);
3400 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3401     {
3402          struct sigaction oact;
3403
3404          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3405               if (sip) {
3406                    HV *sih = newHV();
3407                    SV *rv  = newRV_noinc(MUTABLE_SV(sih));
3408                    /* The siginfo fields signo, code, errno, pid, uid,
3409                     * addr, status, and band are defined by POSIX/SUSv3. */
3410                    (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3411                    (void)hv_stores(sih, "code", newSViv(sip->si_code));
3412 #ifdef HAS_SIGINFO_SI_ERRNO
3413                    (void)hv_stores(sih, "errno",      newSViv(sip->si_errno));
3414 #endif
3415 #ifdef HAS_SIGINFO_SI_STATUS
3416                    (void)hv_stores(sih, "status",     newSViv(sip->si_status));
3417 #endif
3418 #ifdef HAS_SIGINFO_SI_UID
3419                    {
3420                         SV *uid = newSV(0);
3421                         sv_setuid(uid, sip->si_uid);
3422                         (void)hv_stores(sih, "uid", uid);
3423                    }
3424 #endif
3425 #ifdef HAS_SIGINFO_SI_PID
3426                    (void)hv_stores(sih, "pid",        newSViv(sip->si_pid));
3427 #endif
3428 #ifdef HAS_SIGINFO_SI_ADDR
3429                    (void)hv_stores(sih, "addr",       newSVuv(PTR2UV(sip->si_addr)));
3430 #endif
3431 #ifdef HAS_SIGINFO_SI_BAND
3432                    (void)hv_stores(sih, "band",       newSViv(sip->si_band));
3433 #endif
3434                    EXTEND(SP, 2);
3435                    PUSHs(rv);
3436                    mPUSHp((char *)sip, sizeof(*sip));
3437               }
3438
3439          }
3440     }
3441 #endif
3442     PUTBACK;
3443
3444     errsv_save = newSVsv(ERRSV);
3445
3446     call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3447
3448     POPSTACK;
3449     {
3450         SV * const errsv = ERRSV;
3451         if (SvTRUE_NN(errsv)) {
3452             SvREFCNT_dec(errsv_save);
3453 #ifndef PERL_MICRO
3454         /* Handler "died", for example to get out of a restart-able read().
3455          * Before we re-do that on its behalf re-enable the signal which was
3456          * blocked by the system when we entered.
3457          */
3458 #ifdef HAS_SIGPROCMASK
3459 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3460             if (sip || uap)
3461 #endif
3462             {
3463                 sigset_t set;
3464                 sigemptyset(&set);
3465                 sigaddset(&set,sig);
3466                 sigprocmask(SIG_UNBLOCK, &set, NULL);
3467             }
3468 #else
3469             /* Not clear if this will work */
3470             (void)rsignal(sig, SIG_IGN);
3471             (void)rsignal(sig, PL_csighandlerp);
3472 #endif
3473 #endif /* !PERL_MICRO */
3474             die_sv(errsv);
3475         }
3476         else {
3477             sv_setsv(errsv, errsv_save);
3478             SvREFCNT_dec(errsv_save);
3479         }
3480     }
3481
3482   cleanup:
3483     /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3484     PL_savestack_ix = old_ss_ix;
3485     if (flags & 8)
3486         SvREFCNT_dec_NN(sv);
3487     PL_op = myop;                       /* Apparently not needed... */
3488
3489     PL_Sv = tSv;                        /* Restore global temporaries. */
3490     PL_Xpv = tXpv;
3491     return;
3492 }
3493
3494
3495 static void
3496 S_restore_magic(pTHX_ const void *p)
3497 {
3498     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3499     SV* const sv = mgs->mgs_sv;
3500     bool bumped;
3501
3502     if (!sv)
3503         return;
3504
3505     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3506         SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3507         if (mgs->mgs_flags)
3508             SvFLAGS(sv) |= mgs->mgs_flags;
3509         else
3510             mg_magical(sv);
3511     }
3512
3513     bumped = mgs->mgs_bumped;
3514     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
3515
3516     /* If we're still on top of the stack, pop us off.  (That condition
3517      * will be satisfied if restore_magic was called explicitly, but *not*
3518      * if it's being called via leave_scope.)
3519      * The reason for doing this is that otherwise, things like sv_2cv()
3520      * may leave alloc gunk on the savestack, and some code
3521      * (e.g. sighandler) doesn't expect that...
3522      */
3523     if (PL_savestack_ix == mgs->mgs_ss_ix)
3524     {
3525         UV popval = SSPOPUV;
3526         assert(popval == SAVEt_DESTRUCTOR_X);
3527         PL_savestack_ix -= 2;
3528         popval = SSPOPUV;
3529         assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3530         PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3531     }
3532     if (bumped) {
3533         if (SvREFCNT(sv) == 1) {
3534             /* We hold the last reference to this SV, which implies that the
3535                SV was deleted as a side effect of the routines we called.
3536                So artificially keep it alive a bit longer.
3537                We avoid turning on the TEMP flag, which can cause the SV's
3538                buffer to get stolen (and maybe other stuff). */
3539             sv_2mortal(sv);
3540             SvTEMP_off(sv);
3541         }
3542         else
3543             SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
3544     }
3545 }
3546
3547 /* clean up the mess created by Perl_sighandler().
3548  * Note that this is only called during an exit in a signal handler;
3549  * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3550  * skipped over. */
3551
3552 static void
3553 S_unwind_handler_stack(pTHX_ const void *p)
3554 {
3555     PERL_UNUSED_ARG(p);
3556
3557     PL_savestack_ix -= 5; /* Unprotect save in progress. */
3558 }
3559
3560 /*
3561 =for apidoc magic_sethint
3562
3563 Triggered by a store to C<%^H>, records the key/value pair to
3564 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
3565 anything that would need a deep copy.  Maybe we should warn if we find a
3566 reference.
3567
3568 =cut
3569 */
3570 int
3571 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3572 {
3573     SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3574         : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3575
3576     PERL_ARGS_ASSERT_MAGIC_SETHINT;
3577
3578     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
3579        an alternative leaf in there, with PL_compiling.cop_hints being used if
3580        it's NULL. If needed for threads, the alternative could lock a mutex,
3581        or take other more complex action.  */
3582
3583     /* Something changed in %^H, so it will need to be restored on scope exit.
3584        Doing this here saves a lot of doing it manually in perl code (and
3585        forgetting to do it, and consequent subtle errors.  */
3586     PL_hints |= HINT_LOCALIZE_HH;
3587     CopHINTHASH_set(&PL_compiling,
3588         cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3589     return 0;
3590 }
3591
3592 /*
3593 =for apidoc magic_clearhint
3594
3595 Triggered by a delete from C<%^H>, records the key to
3596 C<PL_compiling.cop_hints_hash>.
3597
3598 =cut
3599 */
3600 int
3601 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3602 {
3603     PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3604     PERL_UNUSED_ARG(sv);
3605
3606     PL_hints |= HINT_LOCALIZE_HH;
3607     CopHINTHASH_set(&PL_compiling,
3608         mg->mg_len == HEf_SVKEY
3609          ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3610                                  MUTABLE_SV(mg->mg_ptr), 0, 0)
3611          : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3612                                  mg->mg_ptr, mg->mg_len, 0, 0));
3613     return 0;
3614 }
3615
3616 /*
3617 =for apidoc magic_clearhints
3618
3619 Triggered by clearing C<%^H>, resets C<PL_compiling.cop_hints_hash>.
3620
3621 =cut
3622 */
3623 int
3624 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3625 {
3626     PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3627     PERL_UNUSED_ARG(sv);
3628     PERL_UNUSED_ARG(mg);
3629     cophh_free(CopHINTHASH_get(&PL_compiling));
3630     CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3631     return 0;
3632 }
3633
3634 int
3635 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3636                                  const char *name, I32 namlen)
3637 {
3638     MAGIC *nmg;
3639
3640     PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3641     PERL_UNUSED_ARG(sv);
3642     PERL_UNUSED_ARG(name);
3643     PERL_UNUSED_ARG(namlen);
3644
3645     sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3646     nmg = mg_find(nsv, mg->mg_type);
3647     assert(nmg);
3648     if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3649     nmg->mg_ptr = mg->mg_ptr;
3650     nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3651     nmg->mg_flags |= MGf_REFCOUNTED;
3652     return 1;
3653 }
3654
3655 int
3656 Perl_magic_setdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3657     PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR;
3658
3659 #if DBVARMG_SINGLE != 0
3660     assert(mg->mg_private >= DBVARMG_SINGLE);
3661 #endif
3662     assert(mg->mg_private < DBVARMG_COUNT);
3663
3664     PL_DBcontrol[mg->mg_private] = SvIV_nomg(sv);
3665
3666     return 1;
3667 }
3668
3669 int
3670 Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3671     PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR;
3672
3673 #if DBVARMG_SINGLE != 0
3674     assert(mg->mg_private >= DBVARMG_SINGLE);
3675 #endif
3676     assert(mg->mg_private < DBVARMG_COUNT);
3677     sv_setiv(sv, PL_DBcontrol[mg->mg_private]);
3678
3679     return 0;
3680 }
3681
3682 /*
3683  * ex: set ts=8 sts=4 sw=4 et:
3684  */