mg.c

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