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