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