mg.c

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