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