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