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