mg.c

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