mg.c

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