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