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