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