mg.c

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