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