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