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 static void
2572 S_set_dollarzero(pTHX_ SV *sv)
2573     PERL_TSA_REQUIRES(PL_dollarzero_mutex)
2574 {
2575 #ifdef USE_ITHREADS
2576     dVAR;
2577 #endif
2578     const char *s;
2579     STRLEN len;
2580 #ifdef HAS_SETPROCTITLE
2581     /* The BSDs don't show the argv[] in ps(1) output, they
2582      * show a string from the process struct and provide
2583      * the setproctitle() routine to manipulate that. */
2584     if (PL_origalen != 1) {
2585         s = SvPV_const(sv, len);
2586 #   if __FreeBSD_version > 410001
2587         /* The leading "-" removes the "perl: " prefix,
2588          * but not the "(perl) suffix from the ps(1)
2589          * output, because that's what ps(1) shows if the
2590          * argv[] is modified. */
2591         setproctitle("-%s", s);
2592 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2593         /* This doesn't really work if you assume that
2594          * $0 = 'foobar'; will wipe out 'perl' from the $0
2595          * because in ps(1) output the result will be like
2596          * sprintf("perl: %s (perl)", s)
2597          * I guess this is a security feature:
2598          * one (a user process) cannot get rid of the original name.
2599          * --jhi */
2600         setproctitle("%s", s);
2601 #   endif
2602     }
2603 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2604     if (PL_origalen != 1) {
2605         union pstun un;
2606         s = SvPV_const(sv, len);
2607         un.pst_command = (char *)s;
2608         pstat(PSTAT_SETCMD, un, len, 0, 0);
2609     }
2610 #else
2611     if (PL_origalen > 1) {
2612         I32 i;
2613         /* PL_origalen is set in perl_parse(). */
2614         s = SvPV_force(sv,len);
2615         if (len >= (STRLEN)PL_origalen-1) {
2616             /* Longer than original, will be truncated. We assume that
2617              * PL_origalen bytes are available. */
2618             Copy(s, PL_origargv[0], PL_origalen-1, char);
2619         }
2620         else {
2621             /* Shorter than original, will be padded. */
2622 #ifdef PERL_DARWIN
2623             /* Special case for Mac OS X: see [perl #38868] */
2624             const int pad = 0;
2625 #else
2626             /* Is the space counterintuitive?  Yes.
2627              * (You were expecting \0?)
2628              * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2629              * --jhi */
2630             const int pad = ' ';
2631 #endif
2632             Copy(s, PL_origargv[0], len, char);
2633             PL_origargv[0][len] = 0;
2634             memset(PL_origargv[0] + len + 1,
2635                    pad,  PL_origalen - len - 1);
2636         }
2637         PL_origargv[0][PL_origalen-1] = 0;
2638         for (i = 1; i < PL_origargc; i++)
2639             PL_origargv[i] = 0;
2640 #ifdef HAS_PRCTL_SET_NAME
2641         /* Set the legacy process name in addition to the POSIX name on Linux */
2642         if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2643             /* diag_listed_as: SKIPME */
2644             Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2645         }
2646 #endif
2647     }
2648 #endif
2649 }
2650
2651 int
2652 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2653 {
2654 #ifdef USE_ITHREADS
2655     dVAR;
2656 #endif
2657     I32 paren;
2658     const REGEXP * rx;
2659     I32 i;
2660     STRLEN len;
2661     MAGIC *tmg;
2662
2663     PERL_ARGS_ASSERT_MAGIC_SET;
2664
2665     if (!mg->mg_ptr) {
2666         paren = mg->mg_len;
2667         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2668           setparen_got_rx:
2669             CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2670         } else {
2671             /* Croak with a READONLY error when a numbered match var is
2672              * set without a previous pattern match. Unless it's C<local $1>
2673              */
2674           croakparen:
2675             if (!PL_localizing) {
2676                 Perl_croak_no_modify();
2677             }
2678         }
2679         return 0;
2680     }
2681
2682     switch (*mg->mg_ptr) {
2683     case '\001':        /* ^A */
2684         if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2685         else SvOK_off(PL_bodytarget);
2686         FmLINES(PL_bodytarget) = 0;
2687         if (SvPOK(PL_bodytarget)) {
2688             char *s = SvPVX(PL_bodytarget);
2689             while ( ((s = strchr(s, '\n'))) ) {
2690                 FmLINES(PL_bodytarget)++;
2691                 s++;
2692             }
2693         }
2694         /* mg_set() has temporarily made sv non-magical */
2695         if (TAINTING_get) {
2696             if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2697                 SvTAINTED_on(PL_bodytarget);
2698             else
2699                 SvTAINTED_off(PL_bodytarget);
2700         }
2701         break;
2702     case '\003':        /* ^C */
2703         PL_minus_c = cBOOL(SvIV(sv));
2704         break;
2705
2706     case '\004':        /* ^D */
2707 #ifdef DEBUGGING
2708         {
2709             const char *s = SvPV_nolen_const(sv);
2710             PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2711             if (DEBUG_x_TEST || DEBUG_B_TEST)
2712                 dump_all_perl(!DEBUG_B_TEST);
2713         }
2714 #else
2715         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2716 #endif
2717         break;
2718     case '\005':  /* ^E */
2719         if (*(mg->mg_ptr+1) == '\0') {
2720 #ifdef VMS
2721             set_vaxc_errno(SvIV(sv));
2722 #else
2723 #  ifdef WIN32
2724             SetLastError( SvIV(sv) );
2725 #  else
2726 #    ifdef OS2
2727             os2_setsyserrno(SvIV(sv));
2728 #    else
2729             /* will anyone ever use this? */
2730             SETERRNO(SvIV(sv), 4);
2731 #    endif
2732 #  endif
2733 #endif
2734         }
2735         else {
2736             unsigned int offset = 1;
2737             bool lex = FALSE;
2738
2739             /* It may be the shadow variable ${E_NCODING} which has lexical
2740              * scope.  See comments at Perl__get_encoding in this file */
2741             if (*(mg->mg_ptr + 1) == '_') {
2742                 if (CopSTASH(PL_curcop) != get_hv("encoding::",0))
2743                     Perl_croak_no_modify();
2744                 lex = TRUE;
2745                 offset++;
2746             }
2747             if (strEQ(mg->mg_ptr + offset, "NCODING")) {
2748                 if (lex) {  /* Use the shadow global */
2749                     SvREFCNT_dec(PL_lex_encoding);
2750                     if (SvOK(sv) || SvGMAGICAL(sv)) {
2751                         PL_lex_encoding = newSVsv(sv);
2752                     }
2753                     else {
2754                         PL_lex_encoding = NULL;
2755                     }
2756                 }
2757                 else { /* Use the regular global */
2758                     SvREFCNT_dec(PL_encoding);
2759                     if (SvOK(sv) || SvGMAGICAL(sv)) {
2760                         if (PL_localizing != 2) {
2761                             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
2762                                           "Setting ${^ENCODING} is deprecated");
2763                         }
2764                         PL_encoding = newSVsv(sv);
2765                     }
2766                     else {
2767                         PL_encoding = NULL;
2768                     }
2769                 }
2770             }
2771         }
2772         break;
2773     case '\006':        /* ^F */
2774         PL_maxsysfd = SvIV(sv);
2775         break;
2776     case '\010':        /* ^H */
2777         PL_hints = SvIV(sv);
2778         break;
2779     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2780         Safefree(PL_inplace);
2781         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2782         break;
2783     case '\016':        /* ^N */
2784         if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2785          && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2786         goto croakparen;
2787     case '\017':        /* ^O */
2788         if (*(mg->mg_ptr+1) == '\0') {
2789             Safefree(PL_osname);
2790             PL_osname = NULL;
2791             if (SvOK(sv)) {
2792                 TAINT_PROPER("assigning to $^O");
2793                 PL_osname = savesvpv(sv);
2794             }
2795         }
2796         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2797             STRLEN len;
2798             const char *const start = SvPV(sv, len);
2799             const char *out = (const char*)memchr(start, '\0', len);
2800             SV *tmp;
2801
2802
2803             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2804             PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2805
2806             /* Opening for input is more common than opening for output, so
2807                ensure that hints for input are sooner on linked list.  */
2808             tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2809                                        SvUTF8(sv))
2810                 : newSVpvs_flags("", SvUTF8(sv));
2811             (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2812             mg_set(tmp);
2813
2814             tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2815                                         SvUTF8(sv));
2816             (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2817             mg_set(tmp);
2818         }
2819         break;
2820     case '\020':        /* ^P */
2821           PL_perldb = SvIV(sv);
2822           if (PL_perldb && !PL_DBsingle)
2823               init_debugger();
2824       break;
2825     case '\024':        /* ^T */
2826 #ifdef BIG_TIME
2827         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2828 #else
2829         PL_basetime = (Time_t)SvIV(sv);
2830 #endif
2831         break;
2832     case '\025':        /* ^UTF8CACHE */
2833          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2834              PL_utf8cache = (signed char) sv_2iv(sv);
2835          }
2836          break;
2837     case '\027':        /* ^W & $^WARNING_BITS */
2838         if (*(mg->mg_ptr+1) == '\0') {
2839             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2840                 i = SvIV(sv);
2841                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2842                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2843             }
2844         }
2845         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2846             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2847                 if (!SvPOK(sv)) {
2848                     PL_compiling.cop_warnings = pWARN_STD;
2849                     break;
2850                 }
2851                 {
2852                     STRLEN len, i;
2853                     int accumulate = 0 ;
2854                     int any_fatals = 0 ;
2855                     const char * const ptr = SvPV_const(sv, len) ;
2856                     for (i = 0 ; i < len ; ++i) {
2857                         accumulate |= ptr[i] ;
2858                         any_fatals |= (ptr[i] & 0xAA) ;
2859                     }
2860                     if (!accumulate) {
2861                         if (!specialWARN(PL_compiling.cop_warnings))
2862                             PerlMemShared_free(PL_compiling.cop_warnings);
2863                         PL_compiling.cop_warnings = pWARN_NONE;
2864                     }
2865                     /* Yuck. I can't see how to abstract this:  */
2866                     else if (isWARN_on(
2867                                 ((STRLEN *)SvPV_nolen_const(sv)) - 1,
2868                                 WARN_ALL)
2869                             && !any_fatals)
2870                     {
2871                         if (!specialWARN(PL_compiling.cop_warnings))
2872                             PerlMemShared_free(PL_compiling.cop_warnings);
2873                         PL_compiling.cop_warnings = pWARN_ALL;
2874                         PL_dowarn |= G_WARN_ONCE ;
2875                     }
2876                     else {
2877                         STRLEN len;
2878                         const char *const p = SvPV_const(sv, len);
2879
2880                         PL_compiling.cop_warnings
2881                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2882                                                          p, len);
2883
2884                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2885                             PL_dowarn |= G_WARN_ONCE ;
2886                     }
2887
2888                 }
2889             }
2890         }
2891 #ifdef WIN32
2892         else if (strEQ(mg->mg_ptr+1, "IN32_SLOPPY_STAT")) {
2893             w32_sloppystat = (bool)sv_true(sv);
2894         }
2895 #endif
2896         break;
2897     case '.':
2898         if (PL_localizing) {
2899             if (PL_localizing == 1)
2900                 SAVESPTR(PL_last_in_gv);
2901         }
2902         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2903             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2904         break;
2905     case '^':
2906         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2907         IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2908         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2909         break;
2910     case '~':
2911         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2912         IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2913         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2914         break;
2915     case '=':
2916         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2917         break;
2918     case '-':
2919         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2920         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2921                 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2922         break;
2923     case '%':
2924         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2925         break;
2926     case '|':
2927         {
2928             IO * const io = GvIO(PL_defoutgv);
2929             if(!io)
2930               break;
2931             if ((SvIV(sv)) == 0)
2932                 IoFLAGS(io) &= ~IOf_FLUSH;
2933             else {
2934                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2935                     PerlIO *ofp = IoOFP(io);
2936                     if (ofp)
2937                         (void)PerlIO_flush(ofp);
2938                     IoFLAGS(io) |= IOf_FLUSH;
2939                 }
2940             }
2941         }
2942         break;
2943     case '/':
2944         {
2945             SV *tmpsv= sv;
2946             if (SvROK(sv)) {
2947                 SV *referent= SvRV(sv);
2948                 const char *reftype= sv_reftype(referent, 0);
2949                 /* XXX: dodgy type check: This leaves me feeling dirty, but the alternative
2950                  * is to copy pretty much the entire sv_reftype() into this routine, or to do
2951                  * a full string comparison on the return of sv_reftype() both of which
2952                  * make me feel worse! NOTE, do not modify this comment without reviewing the
2953                  * corresponding comment in sv_reftype(). - Yves */
2954                 if (reftype[0] == 'S' || reftype[0] == 'L') {
2955                     IV val= SvIV(referent);
2956                     if (val <= 0) {
2957                         tmpsv= &PL_sv_undef;
2958                         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
2959                             "Setting $/ to a reference to %s as a form of slurp is deprecated, treating as undef",
2960                             SvIV(SvRV(sv)) < 0 ? "a negative integer" : "zero"
2961                         );
2962                     }
2963                 } else {
2964                     sv_setsv(sv, PL_rs);
2965               /* diag_listed_as: Setting $/ to %s reference is forbidden */
2966                     Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
2967                                       *reftype == 'A' ? "n" : "", reftype);
2968                 }
2969             }
2970             SvREFCNT_dec(PL_rs);
2971             PL_rs = newSVsv(tmpsv);
2972         }
2973         break;
2974     case '\\':
2975         SvREFCNT_dec(PL_ors_sv);
2976         if (SvOK(sv)) {
2977             PL_ors_sv = newSVsv(sv);
2978         }
2979         else {
2980             PL_ors_sv = NULL;
2981         }
2982         break;
2983     case '[':
2984         if (SvIV(sv) != 0)
2985             Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
2986         break;
2987     case '?':
2988 #ifdef COMPLEX_STATUS
2989         if (PL_localizing == 2) {
2990             SvUPGRADE(sv, SVt_PVLV);
2991             PL_statusvalue = LvTARGOFF(sv);
2992             PL_statusvalue_vms = LvTARGLEN(sv);
2993         }
2994         else
2995 #endif
2996 #ifdef VMSISH_STATUS
2997         if (VMSISH_STATUS)
2998             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2999         else
3000 #endif
3001             STATUS_UNIX_EXIT_SET(SvIV(sv));
3002         break;
3003     case '!':
3004         {
3005 #ifdef VMS
3006 #   define PERL_VMS_BANG vaxc$errno
3007 #else
3008 #   define PERL_VMS_BANG 0
3009 #endif
3010 #if defined(WIN32) && ! defined(UNDER_CE)
3011         SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0),
3012                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
3013 #else
3014         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
3015                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
3016 #endif
3017         }
3018         break;
3019     case '<':
3020         {
3021         /* XXX $< currently silently ignores failures */
3022         const Uid_t new_uid = SvUID(sv);
3023         PL_delaymagic_uid = new_uid;
3024         if (PL_delaymagic) {
3025             PL_delaymagic |= DM_RUID;
3026             break;                              /* don't do magic till later */
3027         }
3028 #ifdef HAS_SETRUID
3029         PERL_UNUSED_RESULT(setruid(new_uid));
3030 #else
3031 #ifdef HAS_SETREUID
3032         PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1));
3033 #else
3034 #ifdef HAS_SETRESUID
3035         PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1));
3036 #else
3037         if (new_uid == PerlProc_geteuid()) {            /* special case $< = $> */
3038 #ifdef PERL_DARWIN
3039             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
3040             if (new_uid != 0 && PerlProc_getuid() == 0)
3041                 PERL_UNUSED_RESULT(PerlProc_setuid(0));
3042 #endif
3043             PERL_UNUSED_RESULT(PerlProc_setuid(new_uid));
3044         } else {
3045             Perl_croak(aTHX_ "setruid() not implemented");
3046         }
3047 #endif
3048 #endif
3049 #endif
3050         break;
3051         }
3052     case '>':
3053         {
3054         /* XXX $> currently silently ignores failures */
3055         const Uid_t new_euid = SvUID(sv);
3056         PL_delaymagic_euid = new_euid;
3057         if (PL_delaymagic) {
3058             PL_delaymagic |= DM_EUID;
3059             break;                              /* don't do magic till later */
3060         }
3061 #ifdef HAS_SETEUID
3062         PERL_UNUSED_RESULT(seteuid(new_euid));
3063 #else
3064 #ifdef HAS_SETREUID
3065         PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid));
3066 #else
3067 #ifdef HAS_SETRESUID
3068         PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1));
3069 #else
3070         if (new_euid == PerlProc_getuid())              /* special case $> = $< */
3071             PERL_UNUSED_RESULT(PerlProc_setuid(new_euid));
3072         else {
3073             Perl_croak(aTHX_ "seteuid() not implemented");
3074         }
3075 #endif
3076 #endif
3077 #endif
3078         break;
3079         }
3080     case '(':
3081         {
3082         /* XXX $( currently silently ignores failures */
3083         const Gid_t new_gid = SvGID(sv);
3084         PL_delaymagic_gid = new_gid;
3085         if (PL_delaymagic) {
3086             PL_delaymagic |= DM_RGID;
3087             break;                              /* don't do magic till later */
3088         }
3089 #ifdef HAS_SETRGID
3090         PERL_UNUSED_RESULT(setrgid(new_gid));
3091 #else
3092 #ifdef HAS_SETREGID
3093         PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1));
3094 #else
3095 #ifdef HAS_SETRESGID
3096         PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1));
3097 #else
3098         if (new_gid == PerlProc_getegid())                      /* special case $( = $) */
3099             PERL_UNUSED_RESULT(PerlProc_setgid(new_gid));
3100         else {
3101             Perl_croak(aTHX_ "setrgid() not implemented");
3102         }
3103 #endif
3104 #endif
3105 #endif
3106         break;
3107         }
3108     case ')':
3109         {
3110 /* (hv) best guess: maybe we'll need configure probes to do a better job,
3111  * but you can override it if you need to.
3112  */
3113 #ifndef INVALID_GID
3114 #define INVALID_GID ((Gid_t)-1)
3115 #endif
3116         /* XXX $) currently silently ignores failures */
3117         Gid_t new_egid;
3118 #ifdef HAS_SETGROUPS
3119         {
3120             const char *p = SvPV_const(sv, len);
3121             Groups_t *gary = NULL;
3122             const char* endptr;
3123             UV uv;
3124 #ifdef _SC_NGROUPS_MAX
3125            int maxgrp = sysconf(_SC_NGROUPS_MAX);
3126
3127            if (maxgrp < 0)
3128                maxgrp = NGROUPS;
3129 #else
3130            int maxgrp = NGROUPS;
3131 #endif
3132
3133             while (isSPACE(*p))
3134                 ++p;
3135             if (grok_atoUV(p, &uv, &endptr))
3136                 new_egid = (Gid_t)uv;
3137             else {
3138                 new_egid = INVALID_GID;
3139                 endptr = NULL;
3140             }
3141             for (i = 0; i < maxgrp; ++i) {
3142                 if (endptr == NULL)
3143                     break;
3144                 p = endptr;
3145                 while (isSPACE(*p))
3146                     ++p;
3147                 if (!*p)
3148                     break;
3149                 if (!gary)
3150                     Newx(gary, i + 1, Groups_t);
3151                 else
3152                     Renew(gary, i + 1, Groups_t);
3153                 if (grok_atoUV(p, &uv, &endptr))
3154                     gary[i] = (Groups_t)uv;
3155                 else {
3156                     gary[i] = INVALID_GID;
3157                     endptr = NULL;
3158                 }
3159             }
3160             if (i)
3161                 PERL_UNUSED_RESULT(setgroups(i, gary));
3162             Safefree(gary);
3163         }
3164 #else  /* HAS_SETGROUPS */
3165         new_egid = SvGID(sv);
3166 #endif /* HAS_SETGROUPS */
3167         PL_delaymagic_egid = new_egid;
3168         if (PL_delaymagic) {
3169             PL_delaymagic |= DM_EGID;
3170             break;                              /* don't do magic till later */
3171         }
3172 #ifdef HAS_SETEGID
3173         PERL_UNUSED_RESULT(setegid(new_egid));
3174 #else
3175 #ifdef HAS_SETREGID
3176         PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid));
3177 #else
3178 #ifdef HAS_SETRESGID
3179         PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1));
3180 #else
3181         if (new_egid == PerlProc_getgid())                      /* special case $) = $( */
3182             PERL_UNUSED_RESULT(PerlProc_setgid(new_egid));
3183         else {
3184             Perl_croak(aTHX_ "setegid() not implemented");
3185         }
3186 #endif
3187 #endif
3188 #endif
3189         break;
3190         }
3191     case ':':
3192         PL_chopset = SvPV_force(sv,len);
3193         break;
3194     case '$': /* $$ */
3195         /* Store the pid in mg->mg_obj so we can tell when a fork has
3196            occurred.  mg->mg_obj points to *$ by default, so clear it. */
3197         if (isGV(mg->mg_obj)) {
3198             if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
3199                 SvREFCNT_dec(mg->mg_obj);
3200             mg->mg_flags |= MGf_REFCOUNTED;
3201             mg->mg_obj = newSViv((IV)PerlProc_getpid());
3202         }
3203         else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
3204         break;
3205     case '0':
3206         LOCK_DOLLARZERO_MUTEX;
3207         S_set_dollarzero(aTHX_ sv);
3208         UNLOCK_DOLLARZERO_MUTEX;
3209         break;
3210     }
3211     return 0;
3212 }
3213
3214 I32
3215 Perl_whichsig_sv(pTHX_ SV *sigsv)
3216 {
3217     const char *sigpv;
3218     STRLEN siglen;
3219     PERL_ARGS_ASSERT_WHICHSIG_SV;
3220     sigpv = SvPV_const(sigsv, siglen);
3221     return whichsig_pvn(sigpv, siglen);
3222 }
3223
3224 I32
3225 Perl_whichsig_pv(pTHX_ const char *sig)
3226 {
3227     PERL_ARGS_ASSERT_WHICHSIG_PV;
3228     return whichsig_pvn(sig, strlen(sig));
3229 }
3230
3231 I32
3232 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3233 {
3234     char* const* sigv;
3235
3236     PERL_ARGS_ASSERT_WHICHSIG_PVN;
3237     PERL_UNUSED_CONTEXT;
3238
3239     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3240         if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3241             return PL_sig_num[sigv - (char* const*)PL_sig_name];
3242 #ifdef SIGCLD
3243     if (memEQs(sig, len, "CHLD"))
3244         return SIGCLD;
3245 #endif
3246 #ifdef SIGCHLD
3247     if (memEQs(sig, len, "CLD"))
3248         return SIGCHLD;
3249 #endif
3250     return -1;
3251 }
3252
3253 Signal_t
3254 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3255 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3256 #else
3257 Perl_sighandler(int sig)
3258 #endif
3259 {
3260 #ifdef PERL_GET_SIG_CONTEXT
3261     dTHXa(PERL_GET_SIG_CONTEXT);
3262 #else
3263     dTHX;
3264 #endif
3265     dSP;
3266     GV *gv = NULL;
3267     SV *sv = NULL;
3268     SV * const tSv = PL_Sv;
3269     CV *cv = NULL;
3270     OP *myop = PL_op;
3271     U32 flags = 0;
3272     XPV * const tXpv = PL_Xpv;
3273     I32 old_ss_ix = PL_savestack_ix;
3274     SV *errsv_save = NULL;
3275
3276
3277     if (!PL_psig_ptr[sig]) {
3278                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3279                                  PL_sig_name[sig]);
3280                 exit(sig);
3281         }
3282
3283     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3284         /* Max number of items pushed there is 3*n or 4. We cannot fix
3285            infinity, so we fix 4 (in fact 5): */
3286         if (PL_savestack_ix + 15 <= PL_savestack_max) {
3287             flags |= 1;
3288             PL_savestack_ix += 5;               /* Protect save in progress. */
3289             SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3290         }
3291     }
3292     /* sv_2cv is too complicated, try a simpler variant first: */
3293     if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3294         || SvTYPE(cv) != SVt_PVCV) {
3295         HV *st;
3296         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3297     }
3298
3299     if (!cv || !CvROOT(cv)) {
3300         const HEK * const hek = gv
3301                         ? GvENAME_HEK(gv)
3302                         : cv && CvNAMED(cv)
3303                            ? CvNAME_HEK(cv)
3304                            : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL;
3305         if (hek)
3306             Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3307                                 "SIG%s handler \"%"HEKf"\" not defined.\n",
3308                                  PL_sig_name[sig], HEKfARG(hek));
3309              /* diag_listed_as: SIG%s handler "%s" not defined */
3310         else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3311                            "SIG%s handler \"__ANON__\" not defined.\n",
3312                             PL_sig_name[sig]);
3313         goto cleanup;
3314     }
3315
3316     sv = PL_psig_name[sig]
3317             ? SvREFCNT_inc_NN(PL_psig_name[sig])
3318             : newSVpv(PL_sig_name[sig],0);
3319     flags |= 8;
3320     SAVEFREESV(sv);
3321
3322     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3323         /* make sure our assumption about the size of the SAVEs are correct:
3324          * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3325         assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0)  == PL_savestack_ix);
3326     }
3327
3328     PUSHSTACKi(PERLSI_SIGNAL);
3329     PUSHMARK(SP);
3330     PUSHs(sv);
3331 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3332     {
3333          struct sigaction oact;
3334
3335          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3336               if (sip) {
3337                    HV *sih = newHV();
3338                    SV *rv  = newRV_noinc(MUTABLE_SV(sih));
3339                    /* The siginfo fields signo, code, errno, pid, uid,
3340                     * addr, status, and band are defined by POSIX/SUSv3. */
3341                    (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3342                    (void)hv_stores(sih, "code", newSViv(sip->si_code));
3343 #ifdef HAS_SIGINFO_SI_ERRNO
3344                    (void)hv_stores(sih, "errno",      newSViv(sip->si_errno));
3345 #endif
3346 #ifdef HAS_SIGINFO_SI_STATUS
3347                    (void)hv_stores(sih, "status",     newSViv(sip->si_status));
3348 #endif
3349 #ifdef HAS_SIGINFO_SI_UID
3350                    {
3351                         SV *uid = newSV(0);
3352                         sv_setuid(uid, sip->si_uid);
3353                         (void)hv_stores(sih, "uid", uid);
3354                    }
3355 #endif
3356 #ifdef HAS_SIGINFO_SI_PID
3357                    (void)hv_stores(sih, "pid",        newSViv(sip->si_pid));
3358 #endif
3359 #ifdef HAS_SIGINFO_SI_ADDR
3360                    (void)hv_stores(sih, "addr",       newSVuv(PTR2UV(sip->si_addr)));
3361 #endif
3362 #ifdef HAS_SIGINFO_SI_BAND
3363                    (void)hv_stores(sih, "band",       newSViv(sip->si_band));
3364 #endif
3365                    EXTEND(SP, 2);
3366                    PUSHs(rv);
3367                    mPUSHp((char *)sip, sizeof(*sip));
3368               }
3369
3370          }
3371     }
3372 #endif
3373     PUTBACK;
3374
3375     errsv_save = newSVsv(ERRSV);
3376
3377     call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3378
3379     POPSTACK;
3380     {
3381         SV * const errsv = ERRSV;
3382         if (SvTRUE_NN(errsv)) {
3383             SvREFCNT_dec(errsv_save);
3384 #ifndef PERL_MICRO
3385         /* Handler "died", for example to get out of a restart-able read().
3386          * Before we re-do that on its behalf re-enable the signal which was
3387          * blocked by the system when we entered.
3388          */
3389 #ifdef HAS_SIGPROCMASK
3390 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3391             if (sip || uap)
3392 #endif
3393             {
3394                 sigset_t set;
3395                 sigemptyset(&set);
3396                 sigaddset(&set,sig);
3397                 sigprocmask(SIG_UNBLOCK, &set, NULL);
3398             }
3399 #else
3400             /* Not clear if this will work */
3401             (void)rsignal(sig, SIG_IGN);
3402             (void)rsignal(sig, PL_csighandlerp);
3403 #endif
3404 #endif /* !PERL_MICRO */
3405             die_sv(errsv);
3406         }
3407         else {
3408             sv_setsv(errsv, errsv_save);
3409             SvREFCNT_dec(errsv_save);
3410         }
3411     }
3412
3413   cleanup:
3414     /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3415     PL_savestack_ix = old_ss_ix;
3416     if (flags & 8)
3417         SvREFCNT_dec_NN(sv);
3418     PL_op = myop;                       /* Apparently not needed... */
3419
3420     PL_Sv = tSv;                        /* Restore global temporaries. */
3421     PL_Xpv = tXpv;
3422     return;
3423 }
3424
3425
3426 static void
3427 S_restore_magic(pTHX_ const void *p)
3428 {
3429     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3430     SV* const sv = mgs->mgs_sv;
3431     bool bumped;
3432
3433     if (!sv)
3434         return;
3435
3436     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3437         SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3438         if (mgs->mgs_flags)
3439             SvFLAGS(sv) |= mgs->mgs_flags;
3440         else
3441             mg_magical(sv);
3442     }
3443
3444     bumped = mgs->mgs_bumped;
3445     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
3446
3447     /* If we're still on top of the stack, pop us off.  (That condition
3448      * will be satisfied if restore_magic was called explicitly, but *not*
3449      * if it's being called via leave_scope.)
3450      * The reason for doing this is that otherwise, things like sv_2cv()
3451      * may leave alloc gunk on the savestack, and some code
3452      * (e.g. sighandler) doesn't expect that...
3453      */
3454     if (PL_savestack_ix == mgs->mgs_ss_ix)
3455     {
3456         UV popval = SSPOPUV;
3457         assert(popval == SAVEt_DESTRUCTOR_X);
3458         PL_savestack_ix -= 2;
3459         popval = SSPOPUV;
3460         assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3461         PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3462     }
3463     if (bumped) {
3464         if (SvREFCNT(sv) == 1) {
3465             /* We hold the last reference to this SV, which implies that the
3466                SV was deleted as a side effect of the routines we called.
3467                So artificially keep it alive a bit longer.
3468                We avoid turning on the TEMP flag, which can cause the SV's
3469                buffer to get stolen (and maybe other stuff). */
3470             sv_2mortal(sv);
3471             SvTEMP_off(sv);
3472         }
3473         else
3474             SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
3475     }
3476 }
3477
3478 /* clean up the mess created by Perl_sighandler().
3479  * Note that this is only called during an exit in a signal handler;
3480  * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3481  * skipped over. */
3482
3483 static void
3484 S_unwind_handler_stack(pTHX_ const void *p)
3485 {
3486     PERL_UNUSED_ARG(p);
3487
3488     PL_savestack_ix -= 5; /* Unprotect save in progress. */
3489 }
3490
3491 /*
3492 =for apidoc magic_sethint
3493
3494 Triggered by a store to C<%^H>, records the key/value pair to
3495 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
3496 anything that would need a deep copy.  Maybe we should warn if we find a
3497 reference.
3498
3499 =cut
3500 */
3501 int
3502 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3503 {
3504     SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3505         : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3506
3507     PERL_ARGS_ASSERT_MAGIC_SETHINT;
3508
3509     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
3510        an alternative leaf in there, with PL_compiling.cop_hints being used if
3511        it's NULL. If needed for threads, the alternative could lock a mutex,
3512        or take other more complex action.  */
3513
3514     /* Something changed in %^H, so it will need to be restored on scope exit.
3515        Doing this here saves a lot of doing it manually in perl code (and
3516        forgetting to do it, and consequent subtle errors.  */
3517     PL_hints |= HINT_LOCALIZE_HH;
3518     CopHINTHASH_set(&PL_compiling,
3519         cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3520     return 0;
3521 }
3522
3523 /*
3524 =for apidoc magic_clearhint
3525
3526 Triggered by a delete from C<%^H>, records the key to
3527 C<PL_compiling.cop_hints_hash>.
3528
3529 =cut
3530 */
3531 int
3532 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3533 {
3534     PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3535     PERL_UNUSED_ARG(sv);
3536
3537     PL_hints |= HINT_LOCALIZE_HH;
3538     CopHINTHASH_set(&PL_compiling,
3539         mg->mg_len == HEf_SVKEY
3540          ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3541                                  MUTABLE_SV(mg->mg_ptr), 0, 0)
3542          : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3543                                  mg->mg_ptr, mg->mg_len, 0, 0));
3544     return 0;
3545 }
3546
3547 /*
3548 =for apidoc magic_clearhints
3549
3550 Triggered by clearing C<%^H>, resets C<PL_compiling.cop_hints_hash>.
3551
3552 =cut
3553 */
3554 int
3555 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3556 {
3557     PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3558     PERL_UNUSED_ARG(sv);
3559     PERL_UNUSED_ARG(mg);
3560     cophh_free(CopHINTHASH_get(&PL_compiling));
3561     CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3562     return 0;
3563 }
3564
3565 int
3566 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3567                                  const char *name, I32 namlen)
3568 {
3569     MAGIC *nmg;
3570
3571     PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3572     PERL_UNUSED_ARG(sv);
3573     PERL_UNUSED_ARG(name);
3574     PERL_UNUSED_ARG(namlen);
3575
3576     sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3577     nmg = mg_find(nsv, mg->mg_type);
3578     assert(nmg);
3579     if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3580     nmg->mg_ptr = mg->mg_ptr;
3581     nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3582     nmg->mg_flags |= MGf_REFCOUNTED;
3583     return 1;
3584 }
3585
3586 int
3587 Perl_magic_setdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3588     PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR;
3589
3590 #if DBVARMG_SINGLE != 0
3591     assert(mg->mg_private >= DBVARMG_SINGLE);
3592 #endif
3593     assert(mg->mg_private < DBVARMG_COUNT);
3594
3595     PL_DBcontrol[mg->mg_private] = SvIV_nomg(sv);
3596
3597     return 1;
3598 }
3599
3600 int
3601 Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3602     PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR;
3603
3604 #if DBVARMG_SINGLE != 0
3605     assert(mg->mg_private >= DBVARMG_SINGLE);
3606 #endif
3607     assert(mg->mg_private < DBVARMG_COUNT);
3608     sv_setiv(sv, PL_DBcontrol[mg->mg_private]);
3609
3610     return 0;
3611 }
3612
3613 /*
3614  * ex: set ts=8 sts=4 sw=4 et:
3615  */