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