mg.c

   1 /*    mg.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  *  Sam sat on the ground and put his head in his hands.  'I wish I had never
  13  *  come here, and I don't want to see no more magic,' he said, and fell silent.
  14  *
  15  *     [p.363 of _The Lord of the Rings_, II/vii: "The Mirror of Galadriel"]
  16  */
  17
  18 /*
  19 =head1 Magical Functions
  20 "Magic" is special data attached to SV structures in order to give them
  21 "magical" properties.  When any Perl code tries to read from, or assign to,
  22 an SV marked as magical, it calls the 'get' or 'set' function associated
  23 with that SV's magic.  A get is called prior to reading an SV, in order to
  24 give it a chance to update its internal value (get on $. writes the line
  25 number of the last read filehandle into the SV's IV slot), while
  26 set is called after an SV has been written to, in order to allow it to make
  27 use of its changed value (set on $/ copies the SV's new value to the
  28 PL_rs global variable).
  29
  30 Magic is implemented as a linked list of MAGIC structures attached to the
  31 SV.  Each MAGIC struct holds the type of the magic, a pointer to an array
  32 of functions that implement the get(), set(), length() etc functions,
  33 plus space for some flags and pointers.  For example, a tied variable has
  34 a MAGIC structure that contains a pointer to the object associated with the
  35 tie.
  36
  37 =cut
  38
  39 */
  40
  41 #include "EXTERN.h"
  42 #define PERL_IN_MG_C
  43 #include "perl.h"
  44
  45 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
  46 #  ifdef I_GRP
  47 #    include <grp.h>
  48 #  endif
  49 #endif
  50
  51 #if defined(HAS_SETGROUPS)
  52 #  ifndef NGROUPS
  53 #    define NGROUPS 32
  54 #  endif
  55 #endif
  56
  57 #ifdef __hpux
  58 #  include <sys/pstat.h>
  59 #endif
  60
  61 #ifdef HAS_PRCTL_SET_NAME
  62 #  include <sys/prctl.h>
  63 #endif
  64
  65 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
  66 Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
  67 #else
  68 Signal_t Perl_csighandler(int sig);
  69 #endif
  70
  71 #ifdef __Lynx__
  72 /* Missing protos on LynxOS */
  73 void setruid(uid_t id);
  74 void seteuid(uid_t id);
  75 void setrgid(uid_t id);
  76 void setegid(uid_t id);
  77 #endif
  78
  79 /*
  80  * Pre-magic setup and post-magic takedown.
  81  * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
  82  */
  83
  84 struct magic_state {
  85     SV* mgs_sv;
  86     I32 mgs_ss_ix;
  87     U32 mgs_flags;
  88     bool mgs_bumped;
  89 };
  90 /* MGS is typedef'ed to struct magic_state in perl.h */
  91
  92 STATIC void
  93 S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags)
  94 {
  95     MGS* mgs;
  96     bool bumped = FALSE;
  97
  98     PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS;
  99
 100     assert(SvMAGICAL(sv));
 101
 102     /* we shouldn't really be called here with RC==0, but it can sometimes
 103      * happen via mg_clear() (which also shouldn't be called when RC==0,
 104      * but it can happen). Handle this case gracefully(ish) by not RC++
 105      * and thus avoiding the resultant double free */
 106     if (SvREFCNT(sv) > 0) {
 107     /* guard against sv getting freed midway through the mg clearing,
 108      * by holding a private reference for the duration. */
 109         SvREFCNT_inc_simple_void_NN(sv);
 110         bumped = TRUE;
 111     }
 112
 113     SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
 114
 115     mgs = SSPTR(mgs_ix, MGS*);
 116     mgs->mgs_sv = sv;
 117     mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
 118     mgs->mgs_ss_ix = PL_savestack_ix;   /* points after the saved destructor */
 119     mgs->mgs_bumped = bumped;
 120
 121     SvFLAGS(sv) &= ~flags;
 122     SvREADONLY_off(sv);
 123 }
 124
 125 #define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG)
 126
 127 /*
 128 =for apidoc mg_magical
 129
 130 Turns on the magical status of an SV.  See C<L</sv_magic>>.
 131
 132 =cut
 133 */
 134
 135 void
 136 Perl_mg_magical(SV *sv)
 137 {
 138     const MAGIC* mg;
 139     PERL_ARGS_ASSERT_MG_MAGICAL;
 140
 141     SvMAGICAL_off(sv);
 142     if ((mg = SvMAGIC(sv))) {
 143         do {
 144             const MGVTBL* const vtbl = mg->mg_virtual;
 145             if (vtbl) {
 146                 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
 147                     SvGMAGICAL_on(sv);
 148                 if (vtbl->svt_set)
 149                     SvSMAGICAL_on(sv);
 150                 if (vtbl->svt_clear)
 151                     SvRMAGICAL_on(sv);
 152             }
 153         } while ((mg = mg->mg_moremagic));
 154         if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
 155             SvRMAGICAL_on(sv);
 156     }
 157 }
 158
 159 /*
 160 =for apidoc mg_get
 161
 162 Do magic before a value is retrieved from the SV.  The type of SV must
 163 be >= C<SVt_PVMG>.  See C<L</sv_magic>>.
 164
 165 =cut
 166 */
 167
 168 int
 169 Perl_mg_get(pTHX_ SV *sv)
 170 {
 171     const I32 mgs_ix = SSNEW(sizeof(MGS));
 172     bool saved = FALSE;
 173     bool have_new = 0;
 174     bool taint_only = TRUE; /* the only get method seen is taint */
 175     MAGIC *newmg, *head, *cur, *mg;
 176
 177     PERL_ARGS_ASSERT_MG_GET;
 178
 179     if (PL_localizing == 1 && sv == DEFSV) return 0;
 180
 181     /* We must call svt_get(sv, mg) for each valid entry in the linked
 182        list of magic. svt_get() may delete the current entry, add new
 183        magic to the head of the list, or upgrade the SV. AMS 20010810 */
 184
 185     newmg = cur = head = mg = SvMAGIC(sv);
 186     while (mg) {
 187         const MGVTBL * const vtbl = mg->mg_virtual;
 188         MAGIC * const nextmg = mg->mg_moremagic;        /* it may delete itself */
 189
 190         if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
 191
 192             /* taint's mg get is so dumb it doesn't need flag saving */
 193             if (mg->mg_type != PERL_MAGIC_taint) {
 194                 taint_only = FALSE;
 195                 if (!saved) {
 196                     save_magic(mgs_ix, sv);
 197                     saved = TRUE;
 198                 }
 199             }
 200
 201             vtbl->svt_get(aTHX_ sv, mg);
 202
 203             /* guard against magic having been deleted - eg FETCH calling
 204              * untie */
 205             if (!SvMAGIC(sv)) {
 206                 /* recalculate flags */
 207                 (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
 208                 break;
 209             }
 210
 211             /* recalculate flags if this entry was deleted. */
 212             if (mg->mg_flags & MGf_GSKIP)
 213                 (SSPTR(mgs_ix, MGS *))->mgs_flags &=
 214                      ~(SVs_GMG|SVs_SMG|SVs_RMG);
 215         }
 216         else if (vtbl == &PL_vtbl_utf8) {
 217             /* get-magic can reallocate the PV, unless there's only taint
 218              * magic */
 219             if (taint_only) {
 220                 MAGIC *mg2;
 221                 for (mg2 = nextmg; mg2; mg2 = mg2->mg_moremagic) {
 222                     if (   mg2->mg_type != PERL_MAGIC_taint
 223                         && !(mg2->mg_flags & MGf_GSKIP)
 224                         && mg2->mg_virtual
 225                         && mg2->mg_virtual->svt_get
 226                     ) {
 227                         taint_only = FALSE;
 228                         break;
 229                     }
 230                 }
 231             }
 232             if (!taint_only)
 233                 magic_setutf8(sv, mg);
 234         }
 235
 236         mg = nextmg;
 237
 238         if (have_new) {
 239             /* Have we finished with the new entries we saw? Start again
 240                where we left off (unless there are more new entries). */
 241             if (mg == head) {
 242                 have_new = 0;
 243                 mg   = cur;
 244                 head = newmg;
 245             }
 246         }
 247
 248         /* Were any new entries added? */
 249         if (!have_new && (newmg = SvMAGIC(sv)) != head) {
 250             have_new = 1;
 251             cur = mg;
 252             mg  = newmg;
 253             /* recalculate flags */
 254             (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
 255         }
 256     }
 257
 258     if (saved)
 259         restore_magic(INT2PTR(void *, (IV)mgs_ix));
 260
 261     return 0;
 262 }
 263
 264 /*
 265 =for apidoc mg_set
 266
 267 Do magic after a value is assigned to the SV.  See C<L</sv_magic>>.
 268
 269 =cut
 270 */
 271
 272 int
 273 Perl_mg_set(pTHX_ SV *sv)
 274 {
 275     const I32 mgs_ix = SSNEW(sizeof(MGS));
 276     MAGIC* mg;
 277     MAGIC* nextmg;
 278
 279     PERL_ARGS_ASSERT_MG_SET;
 280
 281     if (PL_localizing == 2 && sv == DEFSV) return 0;
 282
 283     save_magic_flags(mgs_ix, sv, SVs_GMG|SVs_SMG); /* leave SVs_RMG on */
 284
 285     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
 286         const MGVTBL* vtbl = mg->mg_virtual;
 287         nextmg = mg->mg_moremagic;      /* it may delete itself */
 288         if (mg->mg_flags & MGf_GSKIP) {
 289             mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
 290             (SSPTR(mgs_ix, MGS*))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
 291         }
 292         if (PL_localizing == 2
 293             && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
 294             continue;
 295         if (vtbl && vtbl->svt_set)
 296             vtbl->svt_set(aTHX_ sv, mg);
 297     }
 298
 299     restore_magic(INT2PTR(void*, (IV)mgs_ix));
 300     return 0;
 301 }
 302
 303 /*
 304 =for apidoc mg_length
 305
 306 Reports on the SV's length in bytes, calling length magic if available,
 307 but does not set the UTF8 flag on C<sv>.  It will fall back to 'get'
 308 magic if there is no 'length' magic, but with no indication as to
 309 whether it called 'get' magic.  It assumes C<sv> is a C<PVMG> or
 310 higher.  Use C<sv_len()> instead.
 311
 312 =cut
 313 */
 314
 315 U32
 316 Perl_mg_length(pTHX_ SV *sv)
 317 {
 318     MAGIC* mg;
 319     STRLEN len;
 320
 321     PERL_ARGS_ASSERT_MG_LENGTH;
 322
 323     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 324         const MGVTBL * const vtbl = mg->mg_virtual;
 325         if (vtbl && vtbl->svt_len) {
 326             const I32 mgs_ix = SSNEW(sizeof(MGS));
 327             save_magic(mgs_ix, sv);
 328             /* omit MGf_GSKIP -- not changed here */
 329             len = vtbl->svt_len(aTHX_ sv, mg);
 330             restore_magic(INT2PTR(void*, (IV)mgs_ix));
 331             return len;
 332         }
 333     }
 334
 335     (void)SvPV_const(sv, len);
 336     return len;
 337 }
 338
 339 I32
 340 Perl_mg_size(pTHX_ SV *sv)
 341 {
 342     MAGIC* mg;
 343
 344     PERL_ARGS_ASSERT_MG_SIZE;
 345
 346     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 347         const MGVTBL* const vtbl = mg->mg_virtual;
 348         if (vtbl && vtbl->svt_len) {
 349             const I32 mgs_ix = SSNEW(sizeof(MGS));
 350             I32 len;
 351             save_magic(mgs_ix, sv);
 352             /* omit MGf_GSKIP -- not changed here */
 353             len = vtbl->svt_len(aTHX_ sv, mg);
 354             restore_magic(INT2PTR(void*, (IV)mgs_ix));
 355             return len;
 356         }
 357     }
 358
 359     switch(SvTYPE(sv)) {
 360         case SVt_PVAV:
 361             return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
 362         case SVt_PVHV:
 363             /* FIXME */
 364         default:
 365             Perl_croak(aTHX_ "Size magic not implemented");
 366
 367     }
 368     NOT_REACHED; /* NOTREACHED */
 369 }
 370
 371 /*
 372 =for apidoc mg_clear
 373
 374 Clear something magical that the SV represents.  See C<L</sv_magic>>.
 375
 376 =cut
 377 */
 378
 379 int
 380 Perl_mg_clear(pTHX_ SV *sv)
 381 {
 382     const I32 mgs_ix = SSNEW(sizeof(MGS));
 383     MAGIC* mg;
 384     MAGIC *nextmg;
 385
 386     PERL_ARGS_ASSERT_MG_CLEAR;
 387
 388     save_magic(mgs_ix, sv);
 389
 390     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
 391         const MGVTBL* const vtbl = mg->mg_virtual;
 392         /* omit GSKIP -- never set here */
 393
 394         nextmg = mg->mg_moremagic; /* it may delete itself */
 395
 396         if (vtbl && vtbl->svt_clear)
 397             vtbl->svt_clear(aTHX_ sv, mg);
 398     }
 399
 400     restore_magic(INT2PTR(void*, (IV)mgs_ix));
 401     return 0;
 402 }
 403
 404 static MAGIC*
 405 S_mg_findext_flags(const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
 406 {
 407     assert(flags <= 1);
 408
 409     if (sv) {
 410         MAGIC *mg;
 411
 412         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 413             if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
 414                 return mg;
 415             }
 416         }
 417     }
 418
 419     return NULL;
 420 }
 421
 422 /*
 423 =for apidoc mg_find
 424
 425 Finds the magic pointer for C<type> matching the SV.  See C<L</sv_magic>>.
 426
 427 =cut
 428 */
 429
 430 MAGIC*
 431 Perl_mg_find(const SV *sv, int type)
 432 {
 433     return S_mg_findext_flags(sv, type, NULL, 0);
 434 }
 435
 436 /*
 437 =for apidoc mg_findext
 438
 439 Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>.  See
 440 C<L</sv_magicext>>.
 441
 442 =cut
 443 */
 444
 445 MAGIC*
 446 Perl_mg_findext(const SV *sv, int type, const MGVTBL *vtbl)
 447 {
 448     return S_mg_findext_flags(sv, type, vtbl, 1);
 449 }
 450
 451 MAGIC *
 452 Perl_mg_find_mglob(pTHX_ SV *sv)
 453 {
 454     PERL_ARGS_ASSERT_MG_FIND_MGLOB;
 455     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
 456         /* This sv is only a delegate.  //g magic must be attached to
 457            its target. */
 458         vivify_defelem(sv);
 459         sv = LvTARG(sv);
 460     }
 461     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
 462         return S_mg_findext_flags(sv, PERL_MAGIC_regex_global, 0, 0);
 463     return NULL;
 464 }
 465
 466 /*
 467 =for apidoc mg_copy
 468
 469 Copies the magic from one SV to another.  See C<L</sv_magic>>.
 470
 471 =cut
 472 */
 473
 474 int
 475 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
 476 {
 477     int count = 0;
 478     MAGIC* mg;
 479
 480     PERL_ARGS_ASSERT_MG_COPY;
 481
 482     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 483         const MGVTBL* const vtbl = mg->mg_virtual;
 484         if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
 485             count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
 486         }
 487         else {
 488             const char type = mg->mg_type;
 489             if (isUPPER(type) && type != PERL_MAGIC_uvar) {
 490                 sv_magic(nsv,
 491                      (type == PERL_MAGIC_tied)
 492                         ? SvTIED_obj(sv, mg)
 493                         : mg->mg_obj,
 494                      toLOWER(type), key, klen);
 495                 count++;
 496             }
 497         }
 498     }
 499     return count;
 500 }
 501
 502 /*
 503 =for apidoc mg_localize
 504
 505 Copy some of the magic from an existing SV to new localized version of that
 506 SV.  Container magic (I<e.g.>, C<%ENV>, C<$1>, C<tie>)
 507 gets copied, value magic doesn't (I<e.g.>,
 508 C<taint>, C<pos>).
 509
 510 If C<setmagic> is false then no set magic will be called on the new (empty) SV.
 511 This typically means that assignment will soon follow (e.g. S<C<'local $x = $y'>>),
 512 and that will handle the magic.
 513
 514 =cut
 515 */
 516
 517 void
 518 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
 519 {
 520     MAGIC *mg;
 521
 522     PERL_ARGS_ASSERT_MG_LOCALIZE;
 523
 524     if (nsv == DEFSV)
 525         return;
 526
 527     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 528         const MGVTBL* const vtbl = mg->mg_virtual;
 529         if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
 530             continue;
 531
 532         if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
 533             (void)vtbl->svt_local(aTHX_ nsv, mg);
 534         else
 535             sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
 536                             mg->mg_ptr, mg->mg_len);
 537
 538         /* container types should remain read-only across localization */
 539         SvFLAGS(nsv) |= SvREADONLY(sv);
 540     }
 541
 542     if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
 543         SvFLAGS(nsv) |= SvMAGICAL(sv);
 544         if (setmagic) {
 545             PL_localizing = 1;
 546             SvSETMAGIC(nsv);
 547             PL_localizing = 0;
 548         }
 549     }
 550 }
 551
 552 #define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
 553 static void
 554 S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
 555 {
 556     const MGVTBL* const vtbl = mg->mg_virtual;
 557     if (vtbl && vtbl->svt_free)
 558         vtbl->svt_free(aTHX_ sv, mg);
 559     if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
 560         if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
 561             Safefree(mg->mg_ptr);
 562         else if (mg->mg_len == HEf_SVKEY)
 563             SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
 564     }
 565     if (mg->mg_flags & MGf_REFCOUNTED)
 566         SvREFCNT_dec(mg->mg_obj);
 567     Safefree(mg);
 568 }
 569
 570 /*
 571 =for apidoc mg_free
 572
 573 Free any magic storage used by the SV.  See C<L</sv_magic>>.
 574
 575 =cut
 576 */
 577
 578 int
 579 Perl_mg_free(pTHX_ SV *sv)
 580 {
 581     MAGIC* mg;
 582     MAGIC* moremagic;
 583
 584     PERL_ARGS_ASSERT_MG_FREE;
 585
 586     for (mg = SvMAGIC(sv); mg; mg = moremagic) {
 587         moremagic = mg->mg_moremagic;
 588         mg_free_struct(sv, mg);
 589         SvMAGIC_set(sv, moremagic);
 590     }
 591     SvMAGIC_set(sv, NULL);
 592     SvMAGICAL_off(sv);
 593     return 0;
 594 }
 595
 596 /*
 597 =for apidoc Am|void|mg_free_type|SV *sv|int how
 598
 599 Remove any magic of type C<how> from the SV C<sv>.  See L</sv_magic>.
 600
 601 =cut
 602 */
 603
 604 void
 605 Perl_mg_free_type(pTHX_ SV *sv, int how)
 606 {
 607     MAGIC *mg, *prevmg, *moremg;
 608     PERL_ARGS_ASSERT_MG_FREE_TYPE;
 609     for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
 610         moremg = mg->mg_moremagic;
 611         if (mg->mg_type == how) {
 612             MAGIC *newhead;
 613             /* temporarily move to the head of the magic chain, in case
 614                custom free code relies on this historical aspect of mg_free */
 615             if (prevmg) {
 616                 prevmg->mg_moremagic = moremg;
 617                 mg->mg_moremagic = SvMAGIC(sv);
 618                 SvMAGIC_set(sv, mg);
 619             }
 620             newhead = mg->mg_moremagic;
 621             mg_free_struct(sv, mg);
 622             SvMAGIC_set(sv, newhead);
 623             mg = prevmg;
 624         }
 625     }
 626     mg_magical(sv);
 627 }
 628
 629 #include <signal.h>
 630
 631 U32
 632 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
 633 {
 634     PERL_UNUSED_ARG(sv);
 635
 636     PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
 637
 638     if (PL_curpm) {
 639         REGEXP * const rx = PM_GETRE(PL_curpm);
 640         if (rx) {
 641             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 num_groups = getgroups(0, gary);
1142             if (num_groups > 0) {
1143                 I32 i;
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     MAGIC* found;
2153     const char *s;
2154
2155     PERL_ARGS_ASSERT_MAGIC_SETPOS;
2156     PERL_UNUSED_ARG(mg);
2157
2158     found = mg_find_mglob(lsv);
2159     if (!found) {
2160         if (!SvOK(sv))
2161             return 0;
2162         found = sv_magicext_mglob(lsv);
2163     }
2164     else if (!SvOK(sv)) {
2165         found->mg_len = -1;
2166         return 0;
2167     }
2168     s = SvPV_const(lsv, len);
2169
2170     pos = SvIV(sv);
2171
2172     if (DO_UTF8(lsv)) {
2173         const STRLEN ulen = sv_or_pv_len_utf8(lsv, s, len);
2174         if (ulen)
2175             len = ulen;
2176     }
2177
2178     if (pos < 0) {
2179         pos += len;
2180         if (pos < 0)
2181             pos = 0;
2182     }
2183     else if (pos > (SSize_t)len)
2184         pos = len;
2185
2186     found->mg_len = pos;
2187     found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES);
2188
2189     return 0;
2190 }
2191
2192 int
2193 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2194 {
2195     STRLEN len;
2196     SV * const lsv = LvTARG(sv);
2197     const char * const tmps = SvPV_const(lsv,len);
2198     STRLEN offs = LvTARGOFF(sv);
2199     STRLEN rem = LvTARGLEN(sv);
2200     const bool negoff = LvFLAGS(sv) & 1;
2201     const bool negrem = LvFLAGS(sv) & 2;
2202
2203     PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2204     PERL_UNUSED_ARG(mg);
2205
2206     if (!translate_substr_offsets(
2207             SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
2208             negoff ? -(IV)offs : (IV)offs, !negoff,
2209             negrem ? -(IV)rem  : (IV)rem,  !negrem, &offs, &rem
2210     )) {
2211         Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2212         sv_set_undef(sv);
2213         return 0;
2214     }
2215
2216     if (SvUTF8(lsv))
2217         offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
2218     sv_setpvn(sv, tmps + offs, rem);
2219     if (SvUTF8(lsv))
2220         SvUTF8_on(sv);
2221     return 0;
2222 }
2223
2224 int
2225 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2226 {
2227     STRLEN len, lsv_len, oldtarglen, newtarglen;
2228     const char * const tmps = SvPV_const(sv, len);
2229     SV * const lsv = LvTARG(sv);
2230     STRLEN lvoff = LvTARGOFF(sv);
2231     STRLEN lvlen = LvTARGLEN(sv);
2232     const bool negoff = LvFLAGS(sv) & 1;
2233     const bool neglen = LvFLAGS(sv) & 2;
2234
2235     PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2236     PERL_UNUSED_ARG(mg);
2237
2238     SvGETMAGIC(lsv);
2239     if (SvROK(lsv))
2240         Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2241                             "Attempt to use reference as lvalue in substr"
2242         );
2243     SvPV_force_nomg(lsv,lsv_len);
2244     if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
2245     if (!translate_substr_offsets(
2246             lsv_len,
2247             negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2248             neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2249     ))
2250         Perl_croak(aTHX_ "substr outside of string");
2251     oldtarglen = lvlen;
2252     if (DO_UTF8(sv)) {
2253         sv_utf8_upgrade_nomg(lsv);
2254         lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2255         sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2256         newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
2257         SvUTF8_on(lsv);
2258     }
2259     else if (SvUTF8(lsv)) {
2260         const char *utf8;
2261         lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2262         newtarglen = len;
2263         utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2264         sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2265         Safefree(utf8);
2266     }
2267     else {
2268         sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2269         newtarglen = len;
2270     }
2271     if (!neglen) LvTARGLEN(sv) = newtarglen;
2272     if (negoff)  LvTARGOFF(sv) += newtarglen - oldtarglen;
2273
2274     return 0;
2275 }
2276
2277 int
2278 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2279 {
2280     PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2281     PERL_UNUSED_ARG(sv);
2282 #ifdef NO_TAINT_SUPPORT
2283     PERL_UNUSED_ARG(mg);
2284 #endif
2285
2286     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1) && IN_PERL_RUNTIME);
2287     return 0;
2288 }
2289
2290 int
2291 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2292 {
2293     PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2294     PERL_UNUSED_ARG(sv);
2295
2296     /* update taint status */
2297     if (TAINT_get)
2298         mg->mg_len |= 1;
2299     else
2300         mg->mg_len &= ~1;
2301     return 0;
2302 }
2303
2304 int
2305 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2306 {
2307     SV * const lsv = LvTARG(sv);
2308
2309     PERL_ARGS_ASSERT_MAGIC_GETVEC;
2310     PERL_UNUSED_ARG(mg);
2311
2312     sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2313
2314     return 0;
2315 }
2316
2317 int
2318 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2319 {
2320     PERL_ARGS_ASSERT_MAGIC_SETVEC;
2321     PERL_UNUSED_ARG(mg);
2322     do_vecset(sv);      /* XXX slurp this routine */
2323     return 0;
2324 }
2325
2326 SV *
2327 Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg)
2328 {
2329     SV *targ = NULL;
2330     PERL_ARGS_ASSERT_DEFELEM_TARGET;
2331     if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem);
2332     assert(mg);
2333     if (LvTARGLEN(sv)) {
2334         if (mg->mg_obj) {
2335             SV * const ahv = LvTARG(sv);
2336             HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2337             if (he)
2338                 targ = HeVAL(he);
2339         }
2340         else if (LvSTARGOFF(sv) >= 0) {
2341             AV *const av = MUTABLE_AV(LvTARG(sv));
2342             if (LvSTARGOFF(sv) <= AvFILL(av))
2343             {
2344               if (SvRMAGICAL(av)) {
2345                 SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0);
2346                 targ = svp ? *svp : NULL;
2347               }
2348               else
2349                 targ = AvARRAY(av)[LvSTARGOFF(sv)];
2350             }
2351         }
2352         if (targ && (targ != &PL_sv_undef)) {
2353             /* somebody else defined it for us */
2354             SvREFCNT_dec(LvTARG(sv));
2355             LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2356             LvTARGLEN(sv) = 0;
2357             SvREFCNT_dec(mg->mg_obj);
2358             mg->mg_obj = NULL;
2359             mg->mg_flags &= ~MGf_REFCOUNTED;
2360         }
2361         return targ;
2362     }
2363     else
2364         return LvTARG(sv);
2365 }
2366
2367 int
2368 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2369 {
2370     PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2371
2372     sv_setsv(sv, defelem_target(sv, mg));
2373     return 0;
2374 }
2375
2376 int
2377 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2378 {
2379     PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2380     PERL_UNUSED_ARG(mg);
2381     if (LvTARGLEN(sv))
2382         vivify_defelem(sv);
2383     if (LvTARG(sv)) {
2384         sv_setsv(LvTARG(sv), sv);
2385         SvSETMAGIC(LvTARG(sv));
2386     }
2387     return 0;
2388 }
2389
2390 void
2391 Perl_vivify_defelem(pTHX_ SV *sv)
2392 {
2393     MAGIC *mg;
2394     SV *value = NULL;
2395
2396     PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2397
2398     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2399         return;
2400     if (mg->mg_obj) {
2401         SV * const ahv = LvTARG(sv);
2402         HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2403         if (he)
2404             value = HeVAL(he);
2405         if (!value || value == &PL_sv_undef)
2406             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2407     }
2408     else if (LvSTARGOFF(sv) < 0)
2409         Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2410     else {
2411         AV *const av = MUTABLE_AV(LvTARG(sv));
2412         if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av))
2413             LvTARG(sv) = NULL;  /* array can't be extended */
2414         else {
2415             SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE);
2416             if (!svp || !(value = *svp))
2417                 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2418         }
2419     }
2420     SvREFCNT_inc_simple_void(value);
2421     SvREFCNT_dec(LvTARG(sv));
2422     LvTARG(sv) = value;
2423     LvTARGLEN(sv) = 0;
2424     SvREFCNT_dec(mg->mg_obj);
2425     mg->mg_obj = NULL;
2426     mg->mg_flags &= ~MGf_REFCOUNTED;
2427 }
2428
2429 int
2430 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2431 {
2432     PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2433     Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2434     return 0;
2435 }
2436
2437 int
2438 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2439 {
2440     PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2441     PERL_UNUSED_CONTEXT;
2442     PERL_UNUSED_ARG(sv);
2443     mg->mg_len = -1;
2444     return 0;
2445 }
2446
2447 int
2448 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2449 {
2450     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2451
2452     PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2453
2454     if (uf && uf->uf_set)
2455         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2456     return 0;
2457 }
2458
2459 int
2460 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2461 {
2462     const char type = mg->mg_type;
2463
2464     PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2465
2466     assert(    type == PERL_MAGIC_fm
2467             || type == PERL_MAGIC_qr
2468             || type == PERL_MAGIC_bm);
2469     return sv_unmagic(sv, type);
2470 }
2471
2472 #ifdef USE_LOCALE_COLLATE
2473 int
2474 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2475 {
2476     PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2477
2478     /*
2479      * RenE<eacute> Descartes said "I think not."
2480      * and vanished with a faint plop.
2481      */
2482     PERL_UNUSED_CONTEXT;
2483     PERL_UNUSED_ARG(sv);
2484     if (mg->mg_ptr) {
2485         Safefree(mg->mg_ptr);
2486         mg->mg_ptr = NULL;
2487         mg->mg_len = -1;
2488     }
2489     return 0;
2490 }
2491 #endif /* USE_LOCALE_COLLATE */
2492
2493 /* Just clear the UTF-8 cache data. */
2494 int
2495 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2496 {
2497     PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2498     PERL_UNUSED_CONTEXT;
2499     PERL_UNUSED_ARG(sv);
2500     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2501     mg->mg_ptr = NULL;
2502     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2503     return 0;
2504 }
2505
2506 int
2507 Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg)
2508 {
2509     const char *bad = NULL;
2510     PERL_ARGS_ASSERT_MAGIC_SETLVREF;
2511     if (!SvROK(sv)) Perl_croak(aTHX_ "Assigned value is not a reference");
2512     switch (mg->mg_private & OPpLVREF_TYPE) {
2513     case OPpLVREF_SV:
2514         if (SvTYPE(SvRV(sv)) > SVt_PVLV)
2515             bad = " SCALAR";
2516         break;
2517     case OPpLVREF_AV:
2518         if (SvTYPE(SvRV(sv)) != SVt_PVAV)
2519             bad = "n ARRAY";
2520         break;
2521     case OPpLVREF_HV:
2522         if (SvTYPE(SvRV(sv)) != SVt_PVHV)
2523             bad = " HASH";
2524         break;
2525     case OPpLVREF_CV:
2526         if (SvTYPE(SvRV(sv)) != SVt_PVCV)
2527             bad = " CODE";
2528     }
2529     if (bad)
2530         /* diag_listed_as: Assigned value is not %s reference */
2531         Perl_croak(aTHX_ "Assigned value is not a%s reference", bad);
2532     switch (mg->mg_obj ? SvTYPE(mg->mg_obj) : 0) {
2533     case 0:
2534     {
2535         SV * const old = PAD_SV(mg->mg_len);
2536         PAD_SETSV(mg->mg_len, SvREFCNT_inc_NN(SvRV(sv)));
2537         SvREFCNT_dec(old);
2538         break;
2539     }
2540     case SVt_PVGV:
2541         gv_setref(mg->mg_obj, sv);
2542         SvSETMAGIC(mg->mg_obj);
2543         break;
2544     case SVt_PVAV:
2545         av_store((AV *)mg->mg_obj, SvIV((SV *)mg->mg_ptr),
2546                  SvREFCNT_inc_simple_NN(SvRV(sv)));
2547         break;
2548     case SVt_PVHV:
2549         (void)hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr,
2550                            SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
2551     }
2552     if (mg->mg_flags & MGf_PERSIST)
2553         NOOP; /* This sv is in use as an iterator var and will be reused,
2554                  so we must leave the magic.  */
2555     else
2556         /* This sv could be returned by the assignment op, so clear the
2557            magic, as lvrefs are an implementation detail that must not be
2558            leaked to the user.  */
2559         sv_unmagic(sv, PERL_MAGIC_lvref);
2560     return 0;
2561 }
2562
2563 static void
2564 S_set_dollarzero(pTHX_ SV *sv)
2565     PERL_TSA_REQUIRES(PL_dollarzero_mutex)
2566 {
2567 #ifdef USE_ITHREADS
2568     dVAR;
2569 #endif
2570     const char *s;
2571     STRLEN len;
2572 #ifdef HAS_SETPROCTITLE
2573     /* The BSDs don't show the argv[] in ps(1) output, they
2574      * show a string from the process struct and provide
2575      * the setproctitle() routine to manipulate that. */
2576     if (PL_origalen != 1) {
2577         s = SvPV_const(sv, len);
2578 #   if __FreeBSD_version > 410001 || defined(__DragonFly__)
2579         /* The leading "-" removes the "perl: " prefix,
2580          * but not the "(perl) suffix from the ps(1)
2581          * output, because that's what ps(1) shows if the
2582          * argv[] is modified. */
2583         setproctitle("-%s", s);
2584 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2585         /* This doesn't really work if you assume that
2586          * $0 = 'foobar'; will wipe out 'perl' from the $0
2587          * because in ps(1) output the result will be like
2588          * sprintf("perl: %s (perl)", s)
2589          * I guess this is a security feature:
2590          * one (a user process) cannot get rid of the original name.
2591          * --jhi */
2592         setproctitle("%s", s);
2593 #   endif
2594     }
2595 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2596     if (PL_origalen != 1) {
2597         union pstun un;
2598         s = SvPV_const(sv, len);
2599         un.pst_command = (char *)s;
2600         pstat(PSTAT_SETCMD, un, len, 0, 0);
2601     }
2602 #else
2603     if (PL_origalen > 1) {
2604         I32 i;
2605         /* PL_origalen is set in perl_parse(). */
2606         s = SvPV_force(sv,len);
2607         if (len >= (STRLEN)PL_origalen-1) {
2608             /* Longer than original, will be truncated. We assume that
2609              * PL_origalen bytes are available. */
2610             Copy(s, PL_origargv[0], PL_origalen-1, char);
2611         }
2612         else {
2613             /* Shorter than original, will be padded. */
2614 #ifdef PERL_DARWIN
2615             /* Special case for Mac OS X: see [perl #38868] */
2616             const int pad = 0;
2617 #else
2618             /* Is the space counterintuitive?  Yes.
2619              * (You were expecting \0?)
2620              * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2621              * --jhi */
2622             const int pad = ' ';
2623 #endif
2624             Copy(s, PL_origargv[0], len, char);
2625             PL_origargv[0][len] = 0;
2626             memset(PL_origargv[0] + len + 1,
2627                    pad,  PL_origalen - len - 1);
2628         }
2629         PL_origargv[0][PL_origalen-1] = 0;
2630         for (i = 1; i < PL_origargc; i++)
2631             PL_origargv[i] = 0;
2632 #ifdef HAS_PRCTL_SET_NAME
2633         /* Set the legacy process name in addition to the POSIX name on Linux */
2634         if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2635             /* diag_listed_as: SKIPME */
2636             Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2637         }
2638 #endif
2639     }
2640 #endif
2641 }
2642
2643 int
2644 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2645 {
2646 #ifdef USE_ITHREADS
2647     dVAR;
2648 #endif
2649     I32 paren;
2650     const REGEXP * rx;
2651     I32 i;
2652     STRLEN len;
2653     MAGIC *tmg;
2654
2655     PERL_ARGS_ASSERT_MAGIC_SET;
2656
2657     if (!mg->mg_ptr) {
2658         paren = mg->mg_len;
2659         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2660           setparen_got_rx:
2661             CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2662         } else {
2663             /* Croak with a READONLY error when a numbered match var is
2664              * set without a previous pattern match. Unless it's C<local $1>
2665              */
2666           croakparen:
2667             if (!PL_localizing) {
2668                 Perl_croak_no_modify();
2669             }
2670         }
2671         return 0;
2672     }
2673
2674     switch (*mg->mg_ptr) {
2675     case '\001':        /* ^A */
2676         if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2677         else SvOK_off(PL_bodytarget);
2678         FmLINES(PL_bodytarget) = 0;
2679         if (SvPOK(PL_bodytarget)) {
2680             char *s = SvPVX(PL_bodytarget);
2681             while ( ((s = strchr(s, '\n'))) ) {
2682                 FmLINES(PL_bodytarget)++;
2683                 s++;
2684             }
2685         }
2686         /* mg_set() has temporarily made sv non-magical */
2687         if (TAINTING_get) {
2688             if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2689                 SvTAINTED_on(PL_bodytarget);
2690             else
2691                 SvTAINTED_off(PL_bodytarget);
2692         }
2693         break;
2694     case '\003':        /* ^C */
2695         PL_minus_c = cBOOL(SvIV(sv));
2696         break;
2697
2698     case '\004':        /* ^D */
2699 #ifdef DEBUGGING
2700         {
2701             const char *s = SvPV_nolen_const(sv);
2702             PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2703             if (DEBUG_x_TEST || DEBUG_B_TEST)
2704                 dump_all_perl(!DEBUG_B_TEST);
2705         }
2706 #else
2707         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2708 #endif
2709         break;
2710     case '\005':  /* ^E */
2711         if (*(mg->mg_ptr+1) == '\0') {
2712 #ifdef VMS
2713             set_vaxc_errno(SvIV(sv));
2714 #else
2715 #  ifdef WIN32
2716             SetLastError( SvIV(sv) );
2717 #  else
2718 #    ifdef OS2
2719             os2_setsyserrno(SvIV(sv));
2720 #    else
2721             /* will anyone ever use this? */
2722             SETERRNO(SvIV(sv), 4);
2723 #    endif
2724 #  endif
2725 #endif
2726         }
2727         else {
2728             if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv))
2729                         if (PL_localizing != 2) {
2730                             deprecate_fatal_in("5.28",
2731                                "${^ENCODING} is no longer supported");
2732                         }
2733         }
2734         break;
2735     case '\006':        /* ^F */
2736         PL_maxsysfd = SvIV(sv);
2737         break;
2738     case '\010':        /* ^H */
2739         {
2740             U32 save_hints = PL_hints;
2741             PL_hints = SvUV(sv);
2742
2743             /* If wasn't UTF-8, and now is, notify the parser */
2744             if ((PL_hints & HINT_UTF8) && ! (save_hints & HINT_UTF8)) {
2745                 notify_parser_that_changed_to_utf8();
2746             }
2747         }
2748         break;
2749     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2750         Safefree(PL_inplace);
2751         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2752         break;
2753     case '\016':        /* ^N */
2754         if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2755          && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2756         goto croakparen;
2757     case '\017':        /* ^O */
2758         if (*(mg->mg_ptr+1) == '\0') {
2759             Safefree(PL_osname);
2760             PL_osname = NULL;
2761             if (SvOK(sv)) {
2762                 TAINT_PROPER("assigning to $^O");
2763                 PL_osname = savesvpv(sv);
2764             }
2765         }
2766         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2767             STRLEN len;
2768             const char *const start = SvPV(sv, len);
2769             const char *out = (const char*)memchr(start, '\0', len);
2770             SV *tmp;
2771
2772
2773             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2774             PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2775
2776             /* Opening for input is more common than opening for output, so
2777                ensure that hints for input are sooner on linked list.  */
2778             tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2779                                        SvUTF8(sv))
2780                 : newSVpvs_flags("", SvUTF8(sv));
2781             (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2782             mg_set(tmp);
2783
2784             tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2785                                         SvUTF8(sv));
2786             (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2787             mg_set(tmp);
2788         }
2789         break;
2790     case '\020':        /* ^P */
2791           PL_perldb = SvIV(sv);
2792           if (PL_perldb && !PL_DBsingle)
2793               init_debugger();
2794       break;
2795     case '\024':        /* ^T */
2796 #ifdef BIG_TIME
2797         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2798 #else
2799         PL_basetime = (Time_t)SvIV(sv);
2800 #endif
2801         break;
2802     case '\025':        /* ^UTF8CACHE */
2803          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2804              PL_utf8cache = (signed char) sv_2iv(sv);
2805          }
2806          break;
2807     case '\027':        /* ^W & $^WARNING_BITS */
2808         if (*(mg->mg_ptr+1) == '\0') {
2809             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2810                 i = SvIV(sv);
2811                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2812                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2813             }
2814         }
2815         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2816             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2817                 if (!SvPOK(sv)) {
2818                     PL_compiling.cop_warnings = pWARN_STD;
2819                     break;
2820                 }
2821                 {
2822                     STRLEN len, i;
2823                     int accumulate = 0 ;
2824                     int any_fatals = 0 ;
2825                     const char * const ptr = SvPV_const(sv, len) ;
2826                     for (i = 0 ; i < len ; ++i) {
2827                         accumulate |= ptr[i] ;
2828                         any_fatals |= (ptr[i] & 0xAA) ;
2829                     }
2830                     if (!accumulate) {
2831                         if (!specialWARN(PL_compiling.cop_warnings))
2832                             PerlMemShared_free(PL_compiling.cop_warnings);
2833                         PL_compiling.cop_warnings = pWARN_NONE;
2834                     }
2835                     /* Yuck. I can't see how to abstract this:  */
2836                     else if (isWARN_on(
2837                                 ((STRLEN *)SvPV_nolen_const(sv)) - 1,
2838                                 WARN_ALL)
2839                             && !any_fatals)
2840                     {
2841                         if (!specialWARN(PL_compiling.cop_warnings))
2842                             PerlMemShared_free(PL_compiling.cop_warnings);
2843                         PL_compiling.cop_warnings = pWARN_ALL;
2844                         PL_dowarn |= G_WARN_ONCE ;
2845                     }
2846                     else {
2847                         STRLEN len;
2848                         const char *const p = SvPV_const(sv, len);
2849
2850                         PL_compiling.cop_warnings
2851                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2852                                                          p, len);
2853
2854                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2855                             PL_dowarn |= G_WARN_ONCE ;
2856                     }
2857
2858                 }
2859             }
2860         }
2861 #ifdef WIN32
2862         else if (strEQ(mg->mg_ptr+1, "IN32_SLOPPY_STAT")) {
2863             w32_sloppystat = (bool)sv_true(sv);
2864         }
2865 #endif
2866         break;
2867     case '.':
2868         if (PL_localizing) {
2869             if (PL_localizing == 1)
2870                 SAVESPTR(PL_last_in_gv);
2871         }
2872         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2873             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2874         break;
2875     case '^':
2876         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2877         IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2878         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2879         break;
2880     case '~':
2881         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2882         IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2883         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2884         break;
2885     case '=':
2886         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2887         break;
2888     case '-':
2889         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2890         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2891                 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2892         break;
2893     case '%':
2894         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2895         break;
2896     case '|':
2897         {
2898             IO * const io = GvIO(PL_defoutgv);
2899             if(!io)
2900               break;
2901             if ((SvIV(sv)) == 0)
2902                 IoFLAGS(io) &= ~IOf_FLUSH;
2903             else {
2904                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2905                     PerlIO *ofp = IoOFP(io);
2906                     if (ofp)
2907                         (void)PerlIO_flush(ofp);
2908                     IoFLAGS(io) |= IOf_FLUSH;
2909                 }
2910             }
2911         }
2912         break;
2913     case '/':
2914         {
2915             SV *tmpsv= sv;
2916             if (SvROK(sv)) {
2917                 SV *referent= SvRV(sv);
2918                 const char *reftype= sv_reftype(referent, 0);
2919                 /* XXX: dodgy type check: This leaves me feeling dirty, but
2920                  * the alternative is to copy pretty much the entire
2921                  * sv_reftype() into this routine, or to do a full string
2922                  * comparison on the return of sv_reftype() both of which
2923                  * make me feel worse! NOTE, do not modify this comment
2924                  * without reviewing the corresponding comment in
2925                  * sv_reftype(). - Yves */
2926                 if (reftype[0] == 'S' || reftype[0] == 'L') {
2927                     IV val= SvIV(referent);
2928                     if (val <= 0) {
2929                         tmpsv= &PL_sv_undef;
2930                         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
2931                             "Setting $/ to a reference to %s as a form of slurp is deprecated, treating as undef. This will be fatal in Perl 5.28",
2932                             SvIV(SvRV(sv)) < 0 ? "a negative integer" : "zero"
2933                         );
2934                     }
2935                 } else {
2936                     sv_setsv(sv, PL_rs);
2937               /* diag_listed_as: Setting $/ to %s reference is forbidden */
2938                     Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
2939                                       *reftype == 'A' ? "n" : "", reftype);
2940                 }
2941             }
2942             SvREFCNT_dec(PL_rs);
2943             PL_rs = newSVsv(tmpsv);
2944         }
2945         break;
2946     case '\\':
2947         SvREFCNT_dec(PL_ors_sv);
2948         if (SvOK(sv)) {
2949             PL_ors_sv = newSVsv(sv);
2950         }
2951         else {
2952             PL_ors_sv = NULL;
2953         }
2954         break;
2955     case '[':
2956         if (SvIV(sv) != 0)
2957             Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
2958         break;
2959     case '?':
2960 #ifdef COMPLEX_STATUS
2961         if (PL_localizing == 2) {
2962             SvUPGRADE(sv, SVt_PVLV);
2963             PL_statusvalue = LvTARGOFF(sv);
2964             PL_statusvalue_vms = LvTARGLEN(sv);
2965         }
2966         else
2967 #endif
2968 #ifdef VMSISH_STATUS
2969         if (VMSISH_STATUS)
2970             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2971         else
2972 #endif
2973             STATUS_UNIX_EXIT_SET(SvIV(sv));
2974         break;
2975     case '!':
2976         {
2977 #ifdef VMS
2978 #   define PERL_VMS_BANG vaxc$errno
2979 #else
2980 #   define PERL_VMS_BANG 0
2981 #endif
2982 #if defined(WIN32) && ! defined(UNDER_CE)
2983         SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0),
2984                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2985 #else
2986         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2987                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2988 #endif
2989         }
2990         break;
2991     case '<':
2992         {
2993         /* XXX $< currently silently ignores failures */
2994         const Uid_t new_uid = SvUID(sv);
2995         PL_delaymagic_uid = new_uid;
2996         if (PL_delaymagic) {
2997             PL_delaymagic |= DM_RUID;
2998             break;                              /* don't do magic till later */
2999         }
3000 #ifdef HAS_SETRUID
3001         PERL_UNUSED_RESULT(setruid(new_uid));
3002 #else
3003 #ifdef HAS_SETREUID
3004         PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1));
3005 #else
3006 #ifdef HAS_SETRESUID
3007         PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1));
3008 #else
3009         if (new_uid == PerlProc_geteuid()) {            /* special case $< = $> */
3010 #ifdef PERL_DARWIN
3011             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
3012             if (new_uid != 0 && PerlProc_getuid() == 0)
3013                 PERL_UNUSED_RESULT(PerlProc_setuid(0));
3014 #endif
3015             PERL_UNUSED_RESULT(PerlProc_setuid(new_uid));
3016         } else {
3017             Perl_croak(aTHX_ "setruid() not implemented");
3018         }
3019 #endif
3020 #endif
3021 #endif
3022         break;
3023         }
3024     case '>':
3025         {
3026         /* XXX $> currently silently ignores failures */
3027         const Uid_t new_euid = SvUID(sv);
3028         PL_delaymagic_euid = new_euid;
3029         if (PL_delaymagic) {
3030             PL_delaymagic |= DM_EUID;
3031             break;                              /* don't do magic till later */
3032         }
3033 #ifdef HAS_SETEUID
3034         PERL_UNUSED_RESULT(seteuid(new_euid));
3035 #else
3036 #ifdef HAS_SETREUID
3037         PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid));
3038 #else
3039 #ifdef HAS_SETRESUID
3040         PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1));
3041 #else
3042         if (new_euid == PerlProc_getuid())              /* special case $> = $< */
3043             PERL_UNUSED_RESULT(PerlProc_setuid(new_euid));
3044         else {
3045             Perl_croak(aTHX_ "seteuid() not implemented");
3046         }
3047 #endif
3048 #endif
3049 #endif
3050         break;
3051         }
3052     case '(':
3053         {
3054         /* XXX $( currently silently ignores failures */
3055         const Gid_t new_gid = SvGID(sv);
3056         PL_delaymagic_gid = new_gid;
3057         if (PL_delaymagic) {
3058             PL_delaymagic |= DM_RGID;
3059             break;                              /* don't do magic till later */
3060         }
3061 #ifdef HAS_SETRGID
3062         PERL_UNUSED_RESULT(setrgid(new_gid));
3063 #else
3064 #ifdef HAS_SETREGID
3065         PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1));
3066 #else
3067 #ifdef HAS_SETRESGID
3068         PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1));
3069 #else
3070         if (new_gid == PerlProc_getegid())                      /* special case $( = $) */
3071             PERL_UNUSED_RESULT(PerlProc_setgid(new_gid));
3072         else {
3073             Perl_croak(aTHX_ "setrgid() not implemented");
3074         }
3075 #endif
3076 #endif
3077 #endif
3078         break;
3079         }
3080     case ')':
3081         {
3082 /* (hv) best guess: maybe we'll need configure probes to do a better job,
3083  * but you can override it if you need to.
3084  */
3085 #ifndef INVALID_GID
3086 #define INVALID_GID ((Gid_t)-1)
3087 #endif
3088         /* XXX $) currently silently ignores failures */
3089         Gid_t new_egid;
3090 #ifdef HAS_SETGROUPS
3091         {
3092             const char *p = SvPV_const(sv, len);
3093             Groups_t *gary = NULL;
3094             const char* endptr;
3095             UV uv;
3096 #ifdef _SC_NGROUPS_MAX
3097            int maxgrp = sysconf(_SC_NGROUPS_MAX);
3098
3099            if (maxgrp < 0)
3100                maxgrp = NGROUPS;
3101 #else
3102            int maxgrp = NGROUPS;
3103 #endif
3104
3105             while (isSPACE(*p))
3106                 ++p;
3107             if (grok_atoUV(p, &uv, &endptr))
3108                 new_egid = (Gid_t)uv;
3109             else {
3110                 new_egid = INVALID_GID;
3111                 endptr = NULL;
3112             }
3113             for (i = 0; i < maxgrp; ++i) {
3114                 if (endptr == NULL)
3115                     break;
3116                 p = endptr;
3117                 while (isSPACE(*p))
3118                     ++p;
3119                 if (!*p)
3120                     break;
3121                 if (!gary)
3122                     Newx(gary, i + 1, Groups_t);
3123                 else
3124                     Renew(gary, i + 1, Groups_t);
3125                 if (grok_atoUV(p, &uv, &endptr))
3126                     gary[i] = (Groups_t)uv;
3127                 else {
3128                     gary[i] = INVALID_GID;
3129                     endptr = NULL;
3130                 }
3131             }
3132             if (i)
3133                 PERL_UNUSED_RESULT(setgroups(i, gary));
3134             Safefree(gary);
3135         }
3136 #else  /* HAS_SETGROUPS */
3137         new_egid = SvGID(sv);
3138 #endif /* HAS_SETGROUPS */
3139         PL_delaymagic_egid = new_egid;
3140         if (PL_delaymagic) {
3141             PL_delaymagic |= DM_EGID;
3142             break;                              /* don't do magic till later */
3143         }
3144 #ifdef HAS_SETEGID
3145         PERL_UNUSED_RESULT(setegid(new_egid));
3146 #else
3147 #ifdef HAS_SETREGID
3148         PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid));
3149 #else
3150 #ifdef HAS_SETRESGID
3151         PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1));
3152 #else
3153         if (new_egid == PerlProc_getgid())                      /* special case $) = $( */
3154             PERL_UNUSED_RESULT(PerlProc_setgid(new_egid));
3155         else {
3156             Perl_croak(aTHX_ "setegid() not implemented");
3157         }
3158 #endif
3159 #endif
3160 #endif
3161         break;
3162         }
3163     case ':':
3164         PL_chopset = SvPV_force(sv,len);
3165         break;
3166     case '$': /* $$ */
3167         /* Store the pid in mg->mg_obj so we can tell when a fork has
3168            occurred.  mg->mg_obj points to *$ by default, so clear it. */
3169         if (isGV(mg->mg_obj)) {
3170             if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
3171                 SvREFCNT_dec(mg->mg_obj);
3172             mg->mg_flags |= MGf_REFCOUNTED;
3173             mg->mg_obj = newSViv((IV)PerlProc_getpid());
3174         }
3175         else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
3176         break;
3177     case '0':
3178         LOCK_DOLLARZERO_MUTEX;
3179         S_set_dollarzero(aTHX_ sv);
3180         UNLOCK_DOLLARZERO_MUTEX;
3181         break;
3182     }
3183     return 0;
3184 }
3185
3186 I32
3187 Perl_whichsig_sv(pTHX_ SV *sigsv)
3188 {
3189     const char *sigpv;
3190     STRLEN siglen;
3191     PERL_ARGS_ASSERT_WHICHSIG_SV;
3192     sigpv = SvPV_const(sigsv, siglen);
3193     return whichsig_pvn(sigpv, siglen);
3194 }
3195
3196 I32
3197 Perl_whichsig_pv(pTHX_ const char *sig)
3198 {
3199     PERL_ARGS_ASSERT_WHICHSIG_PV;
3200     return whichsig_pvn(sig, strlen(sig));
3201 }
3202
3203 I32
3204 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3205 {
3206     char* const* sigv;
3207
3208     PERL_ARGS_ASSERT_WHICHSIG_PVN;
3209     PERL_UNUSED_CONTEXT;
3210
3211     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3212         if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3213             return PL_sig_num[sigv - (char* const*)PL_sig_name];
3214 #ifdef SIGCLD
3215     if (memEQs(sig, len, "CHLD"))
3216         return SIGCLD;
3217 #endif
3218 #ifdef SIGCHLD
3219     if (memEQs(sig, len, "CLD"))
3220         return SIGCHLD;
3221 #endif
3222     return -1;
3223 }
3224
3225 Signal_t
3226 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3227 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3228 #else
3229 Perl_sighandler(int sig)
3230 #endif
3231 {
3232 #ifdef PERL_GET_SIG_CONTEXT
3233     dTHXa(PERL_GET_SIG_CONTEXT);
3234 #else
3235     dTHX;
3236 #endif
3237     dSP;
3238     GV *gv = NULL;
3239     SV *sv = NULL;
3240     SV * const tSv = PL_Sv;
3241     CV *cv = NULL;
3242     OP *myop = PL_op;
3243     U32 flags = 0;
3244     XPV * const tXpv = PL_Xpv;
3245     I32 old_ss_ix = PL_savestack_ix;
3246     SV *errsv_save = NULL;
3247
3248
3249     if (!PL_psig_ptr[sig]) {
3250                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3251                                  PL_sig_name[sig]);
3252                 exit(sig);
3253         }
3254
3255     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3256         /* Max number of items pushed there is 3*n or 4. We cannot fix
3257            infinity, so we fix 4 (in fact 5): */
3258         if (PL_savestack_ix + 15 <= PL_savestack_max) {
3259             flags |= 1;
3260             PL_savestack_ix += 5;               /* Protect save in progress. */
3261             SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3262         }
3263     }
3264     /* sv_2cv is too complicated, try a simpler variant first: */
3265     if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3266         || SvTYPE(cv) != SVt_PVCV) {
3267         HV *st;
3268         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3269     }
3270
3271     if (!cv || !CvROOT(cv)) {
3272         const HEK * const hek = gv
3273                         ? GvENAME_HEK(gv)
3274                         : cv && CvNAMED(cv)
3275                            ? CvNAME_HEK(cv)
3276                            : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL;
3277         if (hek)
3278             Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3279                                 "SIG%s handler \"%" HEKf "\" not defined.\n",
3280                                  PL_sig_name[sig], HEKfARG(hek));
3281              /* diag_listed_as: SIG%s handler "%s" not defined */
3282         else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3283                            "SIG%s handler \"__ANON__\" not defined.\n",
3284                             PL_sig_name[sig]);
3285         goto cleanup;
3286     }
3287
3288     sv = PL_psig_name[sig]
3289             ? SvREFCNT_inc_NN(PL_psig_name[sig])
3290             : newSVpv(PL_sig_name[sig],0);
3291     flags |= 8;
3292     SAVEFREESV(sv);
3293
3294     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3295         /* make sure our assumption about the size of the SAVEs are correct:
3296          * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3297         assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0)  == PL_savestack_ix);
3298     }
3299
3300     PUSHSTACKi(PERLSI_SIGNAL);
3301     PUSHMARK(SP);
3302     PUSHs(sv);
3303 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3304     {
3305          struct sigaction oact;
3306
3307          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3308               if (sip) {
3309                    HV *sih = newHV();
3310                    SV *rv  = newRV_noinc(MUTABLE_SV(sih));
3311                    /* The siginfo fields signo, code, errno, pid, uid,
3312                     * addr, status, and band are defined by POSIX/SUSv3. */
3313                    (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3314                    (void)hv_stores(sih, "code", newSViv(sip->si_code));
3315 #ifdef HAS_SIGINFO_SI_ERRNO
3316                    (void)hv_stores(sih, "errno",      newSViv(sip->si_errno));
3317 #endif
3318 #ifdef HAS_SIGINFO_SI_STATUS
3319                    (void)hv_stores(sih, "status",     newSViv(sip->si_status));
3320 #endif
3321 #ifdef HAS_SIGINFO_SI_UID
3322                    {
3323                         SV *uid = newSV(0);
3324                         sv_setuid(uid, sip->si_uid);
3325                         (void)hv_stores(sih, "uid", uid);
3326                    }
3327 #endif
3328 #ifdef HAS_SIGINFO_SI_PID
3329                    (void)hv_stores(sih, "pid",        newSViv(sip->si_pid));
3330 #endif
3331 #ifdef HAS_SIGINFO_SI_ADDR
3332                    (void)hv_stores(sih, "addr",       newSVuv(PTR2UV(sip->si_addr)));
3333 #endif
3334 #ifdef HAS_SIGINFO_SI_BAND
3335                    (void)hv_stores(sih, "band",       newSViv(sip->si_band));
3336 #endif
3337                    EXTEND(SP, 2);
3338                    PUSHs(rv);
3339                    mPUSHp((char *)sip, sizeof(*sip));
3340               }
3341
3342          }
3343     }
3344 #endif
3345     PUTBACK;
3346
3347     errsv_save = newSVsv(ERRSV);
3348
3349     call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3350
3351     POPSTACK;
3352     {
3353         SV * const errsv = ERRSV;
3354         if (SvTRUE_NN(errsv)) {
3355             SvREFCNT_dec(errsv_save);
3356 #ifndef PERL_MICRO
3357         /* Handler "died", for example to get out of a restart-able read().
3358          * Before we re-do that on its behalf re-enable the signal which was
3359          * blocked by the system when we entered.
3360          */
3361 #ifdef HAS_SIGPROCMASK
3362 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3363             if (sip || uap)
3364 #endif
3365             {
3366                 sigset_t set;
3367                 sigemptyset(&set);
3368                 sigaddset(&set,sig);
3369                 sigprocmask(SIG_UNBLOCK, &set, NULL);
3370             }
3371 #else
3372             /* Not clear if this will work */
3373             (void)rsignal(sig, SIG_IGN);
3374             (void)rsignal(sig, PL_csighandlerp);
3375 #endif
3376 #endif /* !PERL_MICRO */
3377             die_sv(errsv);
3378         }
3379         else {
3380             sv_setsv(errsv, errsv_save);
3381             SvREFCNT_dec(errsv_save);
3382         }
3383     }
3384
3385   cleanup:
3386     /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3387     PL_savestack_ix = old_ss_ix;
3388     if (flags & 8)
3389         SvREFCNT_dec_NN(sv);
3390     PL_op = myop;                       /* Apparently not needed... */
3391
3392     PL_Sv = tSv;                        /* Restore global temporaries. */
3393     PL_Xpv = tXpv;
3394     return;
3395 }
3396
3397
3398 static void
3399 S_restore_magic(pTHX_ const void *p)
3400 {
3401     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3402     SV* const sv = mgs->mgs_sv;
3403     bool bumped;
3404
3405     if (!sv)
3406         return;
3407
3408     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3409         SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3410         if (mgs->mgs_flags)
3411             SvFLAGS(sv) |= mgs->mgs_flags;
3412         else
3413             mg_magical(sv);
3414     }
3415
3416     bumped = mgs->mgs_bumped;
3417     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
3418
3419     /* If we're still on top of the stack, pop us off.  (That condition
3420      * will be satisfied if restore_magic was called explicitly, but *not*
3421      * if it's being called via leave_scope.)
3422      * The reason for doing this is that otherwise, things like sv_2cv()
3423      * may leave alloc gunk on the savestack, and some code
3424      * (e.g. sighandler) doesn't expect that...
3425      */
3426     if (PL_savestack_ix == mgs->mgs_ss_ix)
3427     {
3428         UV popval = SSPOPUV;
3429         assert(popval == SAVEt_DESTRUCTOR_X);
3430         PL_savestack_ix -= 2;
3431         popval = SSPOPUV;
3432         assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3433         PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3434     }
3435     if (bumped) {
3436         if (SvREFCNT(sv) == 1) {
3437             /* We hold the last reference to this SV, which implies that the
3438                SV was deleted as a side effect of the routines we called.
3439                So artificially keep it alive a bit longer.
3440                We avoid turning on the TEMP flag, which can cause the SV's
3441                buffer to get stolen (and maybe other stuff). */
3442             sv_2mortal(sv);
3443             SvTEMP_off(sv);
3444         }
3445         else
3446             SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
3447     }
3448 }
3449
3450 /* clean up the mess created by Perl_sighandler().
3451  * Note that this is only called during an exit in a signal handler;
3452  * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3453  * skipped over. */
3454
3455 static void
3456 S_unwind_handler_stack(pTHX_ const void *p)
3457 {
3458     PERL_UNUSED_ARG(p);
3459
3460     PL_savestack_ix -= 5; /* Unprotect save in progress. */
3461 }
3462
3463 /*
3464 =for apidoc magic_sethint
3465
3466 Triggered by a store to C<%^H>, records the key/value pair to
3467 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
3468 anything that would need a deep copy.  Maybe we should warn if we find a
3469 reference.
3470
3471 =cut
3472 */
3473 int
3474 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3475 {
3476     SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3477         : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3478
3479     PERL_ARGS_ASSERT_MAGIC_SETHINT;
3480
3481     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
3482        an alternative leaf in there, with PL_compiling.cop_hints being used if
3483        it's NULL. If needed for threads, the alternative could lock a mutex,
3484        or take other more complex action.  */
3485
3486     /* Something changed in %^H, so it will need to be restored on scope exit.
3487        Doing this here saves a lot of doing it manually in perl code (and
3488        forgetting to do it, and consequent subtle errors.  */
3489     PL_hints |= HINT_LOCALIZE_HH;
3490     CopHINTHASH_set(&PL_compiling,
3491         cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3492     return 0;
3493 }
3494
3495 /*
3496 =for apidoc magic_clearhint
3497
3498 Triggered by a delete from C<%^H>, records the key to
3499 C<PL_compiling.cop_hints_hash>.
3500
3501 =cut
3502 */
3503 int
3504 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3505 {
3506     PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3507     PERL_UNUSED_ARG(sv);
3508
3509     PL_hints |= HINT_LOCALIZE_HH;
3510     CopHINTHASH_set(&PL_compiling,
3511         mg->mg_len == HEf_SVKEY
3512          ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3513                                  MUTABLE_SV(mg->mg_ptr), 0, 0)
3514          : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3515                                  mg->mg_ptr, mg->mg_len, 0, 0));
3516     return 0;
3517 }
3518
3519 /*
3520 =for apidoc magic_clearhints
3521
3522 Triggered by clearing C<%^H>, resets C<PL_compiling.cop_hints_hash>.
3523
3524 =cut
3525 */
3526 int
3527 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3528 {
3529     PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3530     PERL_UNUSED_ARG(sv);
3531     PERL_UNUSED_ARG(mg);
3532     cophh_free(CopHINTHASH_get(&PL_compiling));
3533     CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3534     return 0;
3535 }
3536
3537 int
3538 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3539                                  const char *name, I32 namlen)
3540 {
3541     MAGIC *nmg;
3542
3543     PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3544     PERL_UNUSED_ARG(sv);
3545     PERL_UNUSED_ARG(name);
3546     PERL_UNUSED_ARG(namlen);
3547
3548     sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3549     nmg = mg_find(nsv, mg->mg_type);
3550     assert(nmg);
3551     if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3552     nmg->mg_ptr = mg->mg_ptr;
3553     nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3554     nmg->mg_flags |= MGf_REFCOUNTED;
3555     return 1;
3556 }
3557
3558 int
3559 Perl_magic_setdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3560     PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR;
3561
3562 #if DBVARMG_SINGLE != 0
3563     assert(mg->mg_private >= DBVARMG_SINGLE);
3564 #endif
3565     assert(mg->mg_private < DBVARMG_COUNT);
3566
3567     PL_DBcontrol[mg->mg_private] = SvIV_nomg(sv);
3568
3569     return 1;
3570 }
3571
3572 int
3573 Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3574     PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR;
3575
3576 #if DBVARMG_SINGLE != 0
3577     assert(mg->mg_private >= DBVARMG_SINGLE);
3578 #endif
3579     assert(mg->mg_private < DBVARMG_COUNT);
3580     sv_setiv(sv, PL_DBcontrol[mg->mg_private]);
3581
3582     return 0;
3583 }
3584
3585 /*
3586  * ex: set ts=8 sts=4 sw=4 et:
3587  */