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