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