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