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