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