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