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