mg.c

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