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