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_setuid(sv, PerlProc_getuid());
1055         break;
1056     case '>':
1057         sv_setuid(sv, PerlProc_geteuid());
1058         break;
1059     case '(':
1060         sv_setgid(sv, PerlProc_getgid());
1061         goto add_groups;
1062     case ')':
1063         sv_setgid(sv, 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, SV *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_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED);
1749     }
1750     else {
1751         if (call_sv(meth, G_SCALAR|G_METHOD_NAMED))
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 /* wrapper for magic_methcall that creates the first arg */
1762
1763 STATIC SV*
1764 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1765     int n, SV *val)
1766 {
1767     dVAR;
1768     SV* arg1 = NULL;
1769
1770     PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1771
1772     if (mg->mg_ptr) {
1773         if (mg->mg_len >= 0) {
1774             arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1775         }
1776         else if (mg->mg_len == HEf_SVKEY)
1777             arg1 = MUTABLE_SV(mg->mg_ptr);
1778     }
1779     else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1780         arg1 = newSViv((IV)(mg->mg_len));
1781         sv_2mortal(arg1);
1782     }
1783     if (!arg1) {
1784         return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1785     }
1786     return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1787 }
1788
1789 STATIC int
1790 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth)
1791 {
1792     dVAR;
1793     SV* ret;
1794
1795     PERL_ARGS_ASSERT_MAGIC_METHPACK;
1796
1797     ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1798     if (ret)
1799         sv_setsv(sv, ret);
1800     return 0;
1801 }
1802
1803 int
1804 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1805 {
1806     PERL_ARGS_ASSERT_MAGIC_GETPACK;
1807
1808     if (mg->mg_type == PERL_MAGIC_tiedelem)
1809         mg->mg_flags |= MGf_GSKIP;
1810     magic_methpack(sv,mg,SV_CONST(FETCH));
1811     return 0;
1812 }
1813
1814 int
1815 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1816 {
1817     dVAR;
1818     MAGIC *tmg;
1819     SV    *val;
1820
1821     PERL_ARGS_ASSERT_MAGIC_SETPACK;
1822
1823     /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1824      * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1825      * public flags indicate its value based on copying from $val. Doing
1826      * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1827      * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1828      * wrong if $val happened to be tainted, as sv hasn't got magic
1829      * enabled, even though taint magic is in the chain. In which case,
1830      * fake up a temporary tainted value (this is easier than temporarily
1831      * re-enabling magic on sv). */
1832
1833     if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint))
1834         && (tmg->mg_len & 1))
1835     {
1836         val = sv_mortalcopy(sv);
1837         SvTAINTED_on(val);
1838     }
1839     else
1840         val = sv;
1841
1842     magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val);
1843     return 0;
1844 }
1845
1846 int
1847 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1848 {
1849     PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1850
1851     if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
1852     return magic_methpack(sv,mg,SV_CONST(DELETE));
1853 }
1854
1855
1856 U32
1857 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1858 {
1859     dVAR;
1860     I32 retval = 0;
1861     SV* retsv;
1862
1863     PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1864
1865     retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL);
1866     if (retsv) {
1867         retval = SvIV(retsv)-1;
1868         if (retval < -1)
1869             Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1870     }
1871     return (U32) retval;
1872 }
1873
1874 int
1875 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1876 {
1877     dVAR;
1878
1879     PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1880
1881     Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0);
1882     return 0;
1883 }
1884
1885 int
1886 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1887 {
1888     dVAR;
1889     SV* ret;
1890
1891     PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1892
1893     ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key)
1894         : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0);
1895     if (ret)
1896         sv_setsv(key,ret);
1897     return 0;
1898 }
1899
1900 int
1901 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1902 {
1903     PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1904
1905     return magic_methpack(sv,mg,SV_CONST(EXISTS));
1906 }
1907
1908 SV *
1909 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1910 {
1911     dVAR;
1912     SV *retval;
1913     SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1914     HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1915
1916     PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1917
1918     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1919         SV *key;
1920         if (HvEITER_get(hv))
1921             /* we are in an iteration so the hash cannot be empty */
1922             return &PL_sv_yes;
1923         /* no xhv_eiter so now use FIRSTKEY */
1924         key = sv_newmortal();
1925         magic_nextpack(MUTABLE_SV(hv), mg, key);
1926         HvEITER_set(hv, NULL);     /* need to reset iterator */
1927         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1928     }
1929
1930     /* there is a SCALAR method that we can call */
1931     retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0);
1932     if (!retval)
1933         retval = &PL_sv_undef;
1934     return retval;
1935 }
1936
1937 int
1938 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1939 {
1940     dVAR;
1941     GV * const gv = PL_DBline;
1942     const I32 i = SvTRUE(sv);
1943     SV ** const svp = av_fetch(GvAV(gv),
1944                      atoi(MgPV_nolen_const(mg)), FALSE);
1945
1946     PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1947
1948     if (svp && SvIOKp(*svp)) {
1949         OP * const o = INT2PTR(OP*,SvIVX(*svp));
1950         if (o) {
1951 #ifdef PERL_DEBUG_READONLY_OPS
1952             Slab_to_rw(OpSLAB(o));
1953 #endif
1954             /* set or clear breakpoint in the relevant control op */
1955             if (i)
1956                 o->op_flags |= OPf_SPECIAL;
1957             else
1958                 o->op_flags &= ~OPf_SPECIAL;
1959 #ifdef PERL_DEBUG_READONLY_OPS
1960             Slab_to_ro(OpSLAB(o));
1961 #endif
1962         }
1963     }
1964     return 0;
1965 }
1966
1967 int
1968 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1969 {
1970     dVAR;
1971     AV * const obj = MUTABLE_AV(mg->mg_obj);
1972
1973     PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1974
1975     if (obj) {
1976         sv_setiv(sv, AvFILL(obj));
1977     } else {
1978         SvOK_off(sv);
1979     }
1980     return 0;
1981 }
1982
1983 int
1984 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1985 {
1986     dVAR;
1987     AV * const obj = MUTABLE_AV(mg->mg_obj);
1988
1989     PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1990
1991     if (obj) {
1992         av_fill(obj, SvIV(sv));
1993     } else {
1994         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1995                        "Attempt to set length of freed array");
1996     }
1997     return 0;
1998 }
1999
2000 int
2001 Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
2002 {
2003     dVAR;
2004
2005     PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
2006     PERL_UNUSED_ARG(sv);
2007
2008     /* Reset the iterator when the array is cleared */
2009 #if IVSIZE == I32SIZE
2010     *((IV *) &(mg->mg_len)) = 0;
2011 #else
2012     if (mg->mg_ptr)
2013         *((IV *) mg->mg_ptr) = 0;
2014 #endif
2015
2016     return 0;
2017 }
2018
2019 int
2020 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2021 {
2022     dVAR;
2023
2024     PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2025     PERL_UNUSED_ARG(sv);
2026
2027     /* during global destruction, mg_obj may already have been freed */
2028     if (PL_in_clean_all)
2029         return 0;
2030
2031     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2032
2033     if (mg) {
2034         /* arylen scalar holds a pointer back to the array, but doesn't own a
2035            reference. Hence the we (the array) are about to go away with it
2036            still pointing at us. Clear its pointer, else it would be pointing
2037            at free memory. See the comment in sv_magic about reference loops,
2038            and why it can't own a reference to us.  */
2039         mg->mg_obj = 0;
2040     }
2041     return 0;
2042 }
2043
2044 int
2045 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2046 {
2047     dVAR;
2048     SV* const lsv = LvTARG(sv);
2049
2050     PERL_ARGS_ASSERT_MAGIC_GETPOS;
2051     PERL_UNUSED_ARG(mg);
2052
2053     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
2054         MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
2055         if (found && found->mg_len >= 0) {
2056             I32 i = found->mg_len;
2057             if (DO_UTF8(lsv))
2058                 sv_pos_b2u(lsv, &i);
2059             sv_setiv(sv, i);
2060             return 0;
2061         }
2062     }
2063     SvOK_off(sv);
2064     return 0;
2065 }
2066
2067 int
2068 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2069 {
2070     dVAR;
2071     SV* const lsv = LvTARG(sv);
2072     SSize_t pos;
2073     STRLEN len;
2074     STRLEN ulen = 0;
2075     MAGIC* found;
2076     const char *s;
2077
2078     PERL_ARGS_ASSERT_MAGIC_SETPOS;
2079     PERL_UNUSED_ARG(mg);
2080
2081     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2082         found = mg_find(lsv, PERL_MAGIC_regex_global);
2083     else
2084         found = NULL;
2085     if (!found) {
2086         if (!SvOK(sv))
2087             return 0;
2088 #ifdef PERL_OLD_COPY_ON_WRITE
2089     if (SvIsCOW(lsv))
2090         sv_force_normal_flags(lsv, 0);
2091 #endif
2092         found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2093                             NULL, 0);
2094     }
2095     else if (!SvOK(sv)) {
2096         found->mg_len = -1;
2097         return 0;
2098     }
2099     s = SvPV_const(lsv, len);
2100
2101     pos = SvIV(sv);
2102
2103     if (DO_UTF8(lsv)) {
2104         ulen = sv_or_pv_len_utf8(lsv, s, len);
2105         if (ulen)
2106             len = ulen;
2107     }
2108
2109     if (pos < 0) {
2110         pos += len;
2111         if (pos < 0)
2112             pos = 0;
2113     }
2114     else if (pos > (SSize_t)len)
2115         pos = len;
2116
2117     if (ulen) {
2118         pos = sv_or_pv_pos_u2b(lsv, s, pos, 0);
2119     }
2120
2121     found->mg_len = pos;
2122     found->mg_flags &= ~MGf_MINMATCH;
2123
2124     return 0;
2125 }
2126
2127 int
2128 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2129 {
2130     STRLEN len;
2131     SV * const lsv = LvTARG(sv);
2132     const char * const tmps = SvPV_const(lsv,len);
2133     STRLEN offs = LvTARGOFF(sv);
2134     STRLEN rem = LvTARGLEN(sv);
2135     const bool negoff = LvFLAGS(sv) & 1;
2136     const bool negrem = LvFLAGS(sv) & 2;
2137
2138     PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2139     PERL_UNUSED_ARG(mg);
2140
2141     if (!translate_substr_offsets(
2142             SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
2143             negoff ? -(IV)offs : (IV)offs, !negoff,
2144             negrem ? -(IV)rem  : (IV)rem,  !negrem, &offs, &rem
2145     )) {
2146         Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2147         sv_setsv_nomg(sv, &PL_sv_undef);
2148         return 0;
2149     }
2150
2151     if (SvUTF8(lsv))
2152         offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
2153     sv_setpvn(sv, tmps + offs, rem);
2154     if (SvUTF8(lsv))
2155         SvUTF8_on(sv);
2156     return 0;
2157 }
2158
2159 int
2160 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2161 {
2162     dVAR;
2163     STRLEN len, lsv_len, oldtarglen, newtarglen;
2164     const char * const tmps = SvPV_const(sv, len);
2165     SV * const lsv = LvTARG(sv);
2166     STRLEN lvoff = LvTARGOFF(sv);
2167     STRLEN lvlen = LvTARGLEN(sv);
2168     const bool negoff = LvFLAGS(sv) & 1;
2169     const bool neglen = LvFLAGS(sv) & 2;
2170
2171     PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2172     PERL_UNUSED_ARG(mg);
2173
2174     SvGETMAGIC(lsv);
2175     if (SvROK(lsv))
2176         Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2177                             "Attempt to use reference as lvalue in substr"
2178         );
2179     SvPV_force_nomg(lsv,lsv_len);
2180     if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
2181     if (!translate_substr_offsets(
2182             lsv_len,
2183             negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2184             neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2185     ))
2186         Perl_croak(aTHX_ "substr outside of string");
2187     oldtarglen = lvlen;
2188     if (DO_UTF8(sv)) {
2189         sv_utf8_upgrade_nomg(lsv);
2190         lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2191         sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2192         newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
2193         SvUTF8_on(lsv);
2194     }
2195     else if (SvUTF8(lsv)) {
2196         const char *utf8;
2197         lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2198         newtarglen = len;
2199         utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2200         sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2201         Safefree(utf8);
2202     }
2203     else {
2204         sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2205         newtarglen = len;
2206     }
2207     if (!neglen) LvTARGLEN(sv) = newtarglen;
2208     if (negoff)  LvTARGOFF(sv) += newtarglen - oldtarglen;
2209
2210     return 0;
2211 }
2212
2213 int
2214 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2215 {
2216     dVAR;
2217
2218     PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2219     PERL_UNUSED_ARG(sv);
2220 #ifdef NO_TAINT_SUPPORT
2221     PERL_UNUSED_ARG(mg);
2222 #endif
2223
2224     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2225     return 0;
2226 }
2227
2228 int
2229 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2230 {
2231     dVAR;
2232
2233     PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2234     PERL_UNUSED_ARG(sv);
2235
2236     /* update taint status */
2237     if (TAINT_get)
2238         mg->mg_len |= 1;
2239     else
2240         mg->mg_len &= ~1;
2241     return 0;
2242 }
2243
2244 int
2245 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2246 {
2247     SV * const lsv = LvTARG(sv);
2248
2249     PERL_ARGS_ASSERT_MAGIC_GETVEC;
2250     PERL_UNUSED_ARG(mg);
2251
2252     if (lsv)
2253         sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2254     else
2255         SvOK_off(sv);
2256
2257     return 0;
2258 }
2259
2260 int
2261 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2262 {
2263     PERL_ARGS_ASSERT_MAGIC_SETVEC;
2264     PERL_UNUSED_ARG(mg);
2265     do_vecset(sv);      /* XXX slurp this routine */
2266     return 0;
2267 }
2268
2269 int
2270 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2271 {
2272     dVAR;
2273     SV *targ = NULL;
2274
2275     PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2276
2277     if (LvTARGLEN(sv)) {
2278         if (mg->mg_obj) {
2279             SV * const ahv = LvTARG(sv);
2280             HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2281             if (he)
2282                 targ = HeVAL(he);
2283         }
2284         else {
2285             AV *const av = MUTABLE_AV(LvTARG(sv));
2286             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2287                 targ = AvARRAY(av)[LvTARGOFF(sv)];
2288         }
2289         if (targ && (targ != &PL_sv_undef)) {
2290             /* somebody else defined it for us */
2291             SvREFCNT_dec(LvTARG(sv));
2292             LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2293             LvTARGLEN(sv) = 0;
2294             SvREFCNT_dec(mg->mg_obj);
2295             mg->mg_obj = NULL;
2296             mg->mg_flags &= ~MGf_REFCOUNTED;
2297         }
2298     }
2299     else
2300         targ = LvTARG(sv);
2301     sv_setsv(sv, targ ? targ : &PL_sv_undef);
2302     return 0;
2303 }
2304
2305 int
2306 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2307 {
2308     PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2309     PERL_UNUSED_ARG(mg);
2310     if (LvTARGLEN(sv))
2311         vivify_defelem(sv);
2312     if (LvTARG(sv)) {
2313         sv_setsv(LvTARG(sv), sv);
2314         SvSETMAGIC(LvTARG(sv));
2315     }
2316     return 0;
2317 }
2318
2319 void
2320 Perl_vivify_defelem(pTHX_ SV *sv)
2321 {
2322     dVAR;
2323     MAGIC *mg;
2324     SV *value = NULL;
2325
2326     PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2327
2328     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2329         return;
2330     if (mg->mg_obj) {
2331         SV * const ahv = LvTARG(sv);
2332         HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2333         if (he)
2334             value = HeVAL(he);
2335         if (!value || value == &PL_sv_undef)
2336             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2337     }
2338     else {
2339         AV *const av = MUTABLE_AV(LvTARG(sv));
2340         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2341             LvTARG(sv) = NULL;  /* array can't be extended */
2342         else {
2343             SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2344             if (!svp || (value = *svp) == &PL_sv_undef)
2345                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2346         }
2347     }
2348     SvREFCNT_inc_simple_void(value);
2349     SvREFCNT_dec(LvTARG(sv));
2350     LvTARG(sv) = value;
2351     LvTARGLEN(sv) = 0;
2352     SvREFCNT_dec(mg->mg_obj);
2353     mg->mg_obj = NULL;
2354     mg->mg_flags &= ~MGf_REFCOUNTED;
2355 }
2356
2357 int
2358 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2359 {
2360     PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2361     Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2362     return 0;
2363 }
2364
2365 int
2366 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2367 {
2368     PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2369     PERL_UNUSED_CONTEXT;
2370     PERL_UNUSED_ARG(sv);
2371     mg->mg_len = -1;
2372     return 0;
2373 }
2374
2375 int
2376 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2377 {
2378     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2379
2380     PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2381
2382     if (uf && uf->uf_set)
2383         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2384     return 0;
2385 }
2386
2387 int
2388 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2389 {
2390     const char type = mg->mg_type;
2391
2392     PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2393
2394     if (type == PERL_MAGIC_qr) {
2395     } else if (type == PERL_MAGIC_bm) {
2396         SvTAIL_off(sv);
2397         SvVALID_off(sv);
2398     } else {
2399         assert(type == PERL_MAGIC_fm);
2400     }
2401     return sv_unmagic(sv, type);
2402 }
2403
2404 #ifdef USE_LOCALE_COLLATE
2405 int
2406 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2407 {
2408     PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2409
2410     /*
2411      * RenE<eacute> Descartes said "I think not."
2412      * and vanished with a faint plop.
2413      */
2414     PERL_UNUSED_CONTEXT;
2415     PERL_UNUSED_ARG(sv);
2416     if (mg->mg_ptr) {
2417         Safefree(mg->mg_ptr);
2418         mg->mg_ptr = NULL;
2419         mg->mg_len = -1;
2420     }
2421     return 0;
2422 }
2423 #endif /* USE_LOCALE_COLLATE */
2424
2425 /* Just clear the UTF-8 cache data. */
2426 int
2427 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2428 {
2429     PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2430     PERL_UNUSED_CONTEXT;
2431     PERL_UNUSED_ARG(sv);
2432     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2433     mg->mg_ptr = NULL;
2434     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2435     return 0;
2436 }
2437
2438 int
2439 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2440 {
2441     dVAR;
2442     const char *s;
2443     I32 paren;
2444     const REGEXP * rx;
2445     const char * const remaining = mg->mg_ptr + 1;
2446     I32 i;
2447     STRLEN len;
2448     MAGIC *tmg;
2449
2450     PERL_ARGS_ASSERT_MAGIC_SET;
2451
2452     switch (*mg->mg_ptr) {
2453     case '\015': /* $^MATCH */
2454       if (strEQ(remaining, "ATCH"))
2455           goto do_match;
2456     case '`': /* ${^PREMATCH} caught below */
2457       do_prematch:
2458       paren = RX_BUFF_IDX_PREMATCH;
2459       goto setparen;
2460     case '\'': /* ${^POSTMATCH} caught below */
2461       do_postmatch:
2462       paren = RX_BUFF_IDX_POSTMATCH;
2463       goto setparen;
2464     case '&':
2465       do_match:
2466       paren = RX_BUFF_IDX_FULLMATCH;
2467       goto setparen;
2468     case '1': case '2': case '3': case '4':
2469     case '5': case '6': case '7': case '8': case '9':
2470       paren = atoi(mg->mg_ptr);
2471       setparen:
2472         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2473       setparen_got_rx:
2474             CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2475         } else {
2476             /* Croak with a READONLY error when a numbered match var is
2477              * set without a previous pattern match. Unless it's C<local $1>
2478              */
2479       croakparen:
2480             if (!PL_localizing) {
2481                 Perl_croak_no_modify();
2482             }
2483         }
2484         break;
2485     case '\001':        /* ^A */
2486         if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2487         else SvOK_off(PL_bodytarget);
2488         FmLINES(PL_bodytarget) = 0;
2489         if (SvPOK(PL_bodytarget)) {
2490             char *s = SvPVX(PL_bodytarget);
2491             while ( ((s = strchr(s, '\n'))) ) {
2492                 FmLINES(PL_bodytarget)++;
2493                 s++;
2494             }
2495         }
2496         /* mg_set() has temporarily made sv non-magical */
2497         if (TAINTING_get) {
2498             if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2499                 SvTAINTED_on(PL_bodytarget);
2500             else
2501                 SvTAINTED_off(PL_bodytarget);
2502         }
2503         break;
2504     case '\003':        /* ^C */
2505         PL_minus_c = cBOOL(SvIV(sv));
2506         break;
2507
2508     case '\004':        /* ^D */
2509 #ifdef DEBUGGING
2510         s = SvPV_nolen_const(sv);
2511         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2512         if (DEBUG_x_TEST || DEBUG_B_TEST)
2513             dump_all_perl(!DEBUG_B_TEST);
2514 #else
2515         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2516 #endif
2517         break;
2518     case '\005':  /* ^E */
2519         if (*(mg->mg_ptr+1) == '\0') {
2520 #ifdef VMS
2521             set_vaxc_errno(SvIV(sv));
2522 #else
2523 #  ifdef WIN32
2524             SetLastError( SvIV(sv) );
2525 #  else
2526 #    ifdef OS2
2527             os2_setsyserrno(SvIV(sv));
2528 #    else
2529             /* will anyone ever use this? */
2530             SETERRNO(SvIV(sv), 4);
2531 #    endif
2532 #  endif
2533 #endif
2534         }
2535         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2536             SvREFCNT_dec(PL_encoding);
2537             if (SvOK(sv) || SvGMAGICAL(sv)) {
2538                 PL_encoding = newSVsv(sv);
2539             }
2540             else {
2541                 PL_encoding = NULL;
2542             }
2543         }
2544         break;
2545     case '\006':        /* ^F */
2546         PL_maxsysfd = SvIV(sv);
2547         break;
2548     case '\010':        /* ^H */
2549         PL_hints = SvIV(sv);
2550         break;
2551     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2552         Safefree(PL_inplace);
2553         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2554         break;
2555     case '\016':        /* ^N */
2556         if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2557          && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2558         goto croakparen;
2559     case '\017':        /* ^O */
2560         if (*(mg->mg_ptr+1) == '\0') {
2561             Safefree(PL_osname);
2562             PL_osname = NULL;
2563             if (SvOK(sv)) {
2564                 TAINT_PROPER("assigning to $^O");
2565                 PL_osname = savesvpv(sv);
2566             }
2567         }
2568         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2569             STRLEN len;
2570             const char *const start = SvPV(sv, len);
2571             const char *out = (const char*)memchr(start, '\0', len);
2572             SV *tmp;
2573
2574
2575             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2576             PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2577
2578             /* Opening for input is more common than opening for output, so
2579                ensure that hints for input are sooner on linked list.  */
2580             tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2581                                        SvUTF8(sv))
2582                 : newSVpvs_flags("", SvUTF8(sv));
2583             (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2584             mg_set(tmp);
2585
2586             tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2587                                         SvUTF8(sv));
2588             (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2589             mg_set(tmp);
2590         }
2591         break;
2592     case '\020':        /* ^P */
2593       if (*remaining == '\0') { /* ^P */
2594           PL_perldb = SvIV(sv);
2595           if (PL_perldb && !PL_DBsingle)
2596               init_debugger();
2597           break;
2598       } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2599           goto do_prematch;
2600       } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2601           goto do_postmatch;
2602       }
2603       break;
2604     case '\024':        /* ^T */
2605 #ifdef BIG_TIME
2606         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2607 #else
2608         PL_basetime = (Time_t)SvIV(sv);
2609 #endif
2610         break;
2611     case '\025':        /* ^UTF8CACHE */
2612          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2613              PL_utf8cache = (signed char) sv_2iv(sv);
2614          }
2615          break;
2616     case '\027':        /* ^W & $^WARNING_BITS */
2617         if (*(mg->mg_ptr+1) == '\0') {
2618             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2619                 i = SvIV(sv);
2620                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2621                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2622             }
2623         }
2624         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2625             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2626                 if (!SvPOK(sv)) {
2627                     PL_compiling.cop_warnings = pWARN_STD;
2628                     break;
2629                 }
2630                 {
2631                     STRLEN len, i;
2632                     int accumulate = 0 ;
2633                     int any_fatals = 0 ;
2634                     const char * const ptr = SvPV_const(sv, len) ;
2635                     for (i = 0 ; i < len ; ++i) {
2636                         accumulate |= ptr[i] ;
2637                         any_fatals |= (ptr[i] & 0xAA) ;
2638                     }
2639                     if (!accumulate) {
2640                         if (!specialWARN(PL_compiling.cop_warnings))
2641                             PerlMemShared_free(PL_compiling.cop_warnings);
2642                         PL_compiling.cop_warnings = pWARN_NONE;
2643                     }
2644                     /* Yuck. I can't see how to abstract this:  */
2645                     else if (isWARN_on(
2646                                 ((STRLEN *)SvPV_nolen_const(sv)) - 1,
2647                                 WARN_ALL)
2648                             && !any_fatals)
2649                     {
2650                         if (!specialWARN(PL_compiling.cop_warnings))
2651                             PerlMemShared_free(PL_compiling.cop_warnings);
2652                         PL_compiling.cop_warnings = pWARN_ALL;
2653                         PL_dowarn |= G_WARN_ONCE ;
2654                     }
2655                     else {
2656                         STRLEN len;
2657                         const char *const p = SvPV_const(sv, len);
2658
2659                         PL_compiling.cop_warnings
2660                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2661                                                          p, len);
2662
2663                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2664                             PL_dowarn |= G_WARN_ONCE ;
2665                     }
2666
2667                 }
2668             }
2669         }
2670         break;
2671     case '.':
2672         if (PL_localizing) {
2673             if (PL_localizing == 1)
2674                 SAVESPTR(PL_last_in_gv);
2675         }
2676         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2677             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2678         break;
2679     case '^':
2680         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2681         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2682         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2683         break;
2684     case '~':
2685         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2686         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2687         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2688         break;
2689     case '=':
2690         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2691         break;
2692     case '-':
2693         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2694         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2695                 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2696         break;
2697     case '%':
2698         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2699         break;
2700     case '|':
2701         {
2702             IO * const io = GvIO(PL_defoutgv);
2703             if(!io)
2704               break;
2705             if ((SvIV(sv)) == 0)
2706                 IoFLAGS(io) &= ~IOf_FLUSH;
2707             else {
2708                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2709                     PerlIO *ofp = IoOFP(io);
2710                     if (ofp)
2711                         (void)PerlIO_flush(ofp);
2712                     IoFLAGS(io) |= IOf_FLUSH;
2713                 }
2714             }
2715         }
2716         break;
2717     case '/':
2718         SvREFCNT_dec(PL_rs);
2719         PL_rs = newSVsv(sv);
2720         break;
2721     case '\\':
2722         SvREFCNT_dec(PL_ors_sv);
2723         if (SvOK(sv)) {
2724             PL_ors_sv = newSVsv(sv);
2725         }
2726         else {
2727             PL_ors_sv = NULL;
2728         }
2729         break;
2730     case '[':
2731         if (SvIV(sv) != 0)
2732             Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
2733         break;
2734     case '?':
2735 #ifdef COMPLEX_STATUS
2736         if (PL_localizing == 2) {
2737             SvUPGRADE(sv, SVt_PVLV);
2738             PL_statusvalue = LvTARGOFF(sv);
2739             PL_statusvalue_vms = LvTARGLEN(sv);
2740         }
2741         else
2742 #endif
2743 #ifdef VMSISH_STATUS
2744         if (VMSISH_STATUS)
2745             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2746         else
2747 #endif
2748             STATUS_UNIX_EXIT_SET(SvIV(sv));
2749         break;
2750     case '!':
2751         {
2752 #ifdef VMS
2753 #   define PERL_VMS_BANG vaxc$errno
2754 #else
2755 #   define PERL_VMS_BANG 0
2756 #endif
2757         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2758                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2759         }
2760         break;
2761     case '<':
2762         {
2763         const Uid_t new_uid = SvUID(sv);
2764         PL_delaymagic_uid = new_uid;
2765         if (PL_delaymagic) {
2766             PL_delaymagic |= DM_RUID;
2767             break;                              /* don't do magic till later */
2768         }
2769 #ifdef HAS_SETRUID
2770         (void)setruid(new_uid);
2771 #else
2772 #ifdef HAS_SETREUID
2773         (void)setreuid(new_uid, (Uid_t)-1);
2774 #else
2775 #ifdef HAS_SETRESUID
2776       (void)setresuid(new_uid, (Uid_t)-1, (Uid_t)-1);
2777 #else
2778         if (new_uid == PerlProc_geteuid()) {            /* special case $< = $> */
2779 #ifdef PERL_DARWIN
2780             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2781             if (new_uid != 0 && PerlProc_getuid() == 0)
2782                 (void)PerlProc_setuid(0);
2783 #endif
2784             (void)PerlProc_setuid(new_uid);
2785         } else {
2786             Perl_croak(aTHX_ "setruid() not implemented");
2787         }
2788 #endif
2789 #endif
2790 #endif
2791         break;
2792         }
2793     case '>':
2794         {
2795         const Uid_t new_euid = SvUID(sv);
2796         PL_delaymagic_euid = new_euid;
2797         if (PL_delaymagic) {
2798             PL_delaymagic |= DM_EUID;
2799             break;                              /* don't do magic till later */
2800         }
2801 #ifdef HAS_SETEUID
2802         (void)seteuid(new_euid);
2803 #else
2804 #ifdef HAS_SETREUID
2805         (void)setreuid((Uid_t)-1, new_euid);
2806 #else
2807 #ifdef HAS_SETRESUID
2808         (void)setresuid((Uid_t)-1, new_euid, (Uid_t)-1);
2809 #else
2810         if (new_euid == PerlProc_getuid())              /* special case $> = $< */
2811             PerlProc_setuid(new_euid);
2812         else {
2813             Perl_croak(aTHX_ "seteuid() not implemented");
2814         }
2815 #endif
2816 #endif
2817 #endif
2818         break;
2819         }
2820     case '(':
2821         {
2822         const Gid_t new_gid = SvGID(sv);
2823         PL_delaymagic_gid = new_gid;
2824         if (PL_delaymagic) {
2825             PL_delaymagic |= DM_RGID;
2826             break;                              /* don't do magic till later */
2827         }
2828 #ifdef HAS_SETRGID
2829         (void)setrgid(new_gid);
2830 #else
2831 #ifdef HAS_SETREGID
2832         (void)setregid(new_gid, (Gid_t)-1);
2833 #else
2834 #ifdef HAS_SETRESGID
2835       (void)setresgid(new_gid, (Gid_t)-1, (Gid_t) -1);
2836 #else
2837         if (new_gid == PerlProc_getegid())                      /* special case $( = $) */
2838             (void)PerlProc_setgid(new_gid);
2839         else {
2840             Perl_croak(aTHX_ "setrgid() not implemented");
2841         }
2842 #endif
2843 #endif
2844 #endif
2845         break;
2846         }
2847     case ')':
2848         {
2849         Gid_t new_egid;
2850 #ifdef HAS_SETGROUPS
2851         {
2852             const char *p = SvPV_const(sv, len);
2853             Groups_t *gary = NULL;
2854 #ifdef _SC_NGROUPS_MAX
2855            int maxgrp = sysconf(_SC_NGROUPS_MAX);
2856
2857            if (maxgrp < 0)
2858                maxgrp = NGROUPS;
2859 #else
2860            int maxgrp = NGROUPS;
2861 #endif
2862
2863             while (isSPACE(*p))
2864                 ++p;
2865             new_egid = (Gid_t)Atol(p);
2866             for (i = 0; i < maxgrp; ++i) {
2867                 while (*p && !isSPACE(*p))
2868                     ++p;
2869                 while (isSPACE(*p))
2870                     ++p;
2871                 if (!*p)
2872                     break;
2873                 if(!gary)
2874                     Newx(gary, i + 1, Groups_t);
2875                 else
2876                     Renew(gary, i + 1, Groups_t);
2877                 gary[i] = (Groups_t)Atol(p);
2878             }
2879             if (i)
2880                 (void)setgroups(i, gary);
2881             Safefree(gary);
2882         }
2883 #else  /* HAS_SETGROUPS */
2884         new_egid = SvGID(sv);
2885 #endif /* HAS_SETGROUPS */
2886         PL_delaymagic_egid = new_egid;
2887         if (PL_delaymagic) {
2888             PL_delaymagic |= DM_EGID;
2889             break;                              /* don't do magic till later */
2890         }
2891 #ifdef HAS_SETEGID
2892         (void)setegid(new_egid);
2893 #else
2894 #ifdef HAS_SETREGID
2895         (void)setregid((Gid_t)-1, new_egid);
2896 #else
2897 #ifdef HAS_SETRESGID
2898         (void)setresgid((Gid_t)-1, new_egid, (Gid_t)-1);
2899 #else
2900         if (new_egid == PerlProc_getgid())                      /* special case $) = $( */
2901             (void)PerlProc_setgid(new_egid);
2902         else {
2903             Perl_croak(aTHX_ "setegid() not implemented");
2904         }
2905 #endif
2906 #endif
2907 #endif
2908         break;
2909         }
2910     case ':':
2911         PL_chopset = SvPV_force(sv,len);
2912         break;
2913     case '$': /* $$ */
2914         /* Store the pid in mg->mg_obj so we can tell when a fork has
2915            occurred.  mg->mg_obj points to *$ by default, so clear it. */
2916         if (isGV(mg->mg_obj)) {
2917             if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
2918                 SvREFCNT_dec(mg->mg_obj);
2919             mg->mg_flags |= MGf_REFCOUNTED;
2920             mg->mg_obj = newSViv((IV)PerlProc_getpid());
2921         }
2922         else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
2923         break;
2924     case '0':
2925         LOCK_DOLLARZERO_MUTEX;
2926 #ifdef HAS_SETPROCTITLE
2927         /* The BSDs don't show the argv[] in ps(1) output, they
2928          * show a string from the process struct and provide
2929          * the setproctitle() routine to manipulate that. */
2930         if (PL_origalen != 1) {
2931             s = SvPV_const(sv, len);
2932 #   if __FreeBSD_version > 410001
2933             /* The leading "-" removes the "perl: " prefix,
2934              * but not the "(perl) suffix from the ps(1)
2935              * output, because that's what ps(1) shows if the
2936              * argv[] is modified. */
2937             setproctitle("-%s", s);
2938 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2939             /* This doesn't really work if you assume that
2940              * $0 = 'foobar'; will wipe out 'perl' from the $0
2941              * because in ps(1) output the result will be like
2942              * sprintf("perl: %s (perl)", s)
2943              * I guess this is a security feature:
2944              * one (a user process) cannot get rid of the original name.
2945              * --jhi */
2946             setproctitle("%s", s);
2947 #   endif
2948         }
2949 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2950         if (PL_origalen != 1) {
2951              union pstun un;
2952              s = SvPV_const(sv, len);
2953              un.pst_command = (char *)s;
2954              pstat(PSTAT_SETCMD, un, len, 0, 0);
2955         }
2956 #else
2957         if (PL_origalen > 1) {
2958             /* PL_origalen is set in perl_parse(). */
2959             s = SvPV_force(sv,len);
2960             if (len >= (STRLEN)PL_origalen-1) {
2961                 /* Longer than original, will be truncated. We assume that
2962                  * PL_origalen bytes are available. */
2963                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2964             }
2965             else {
2966                 /* Shorter than original, will be padded. */
2967 #ifdef PERL_DARWIN
2968                 /* Special case for Mac OS X: see [perl #38868] */
2969                 const int pad = 0;
2970 #else
2971                 /* Is the space counterintuitive?  Yes.
2972                  * (You were expecting \0?)
2973                  * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2974                  * --jhi */
2975                 const int pad = ' ';
2976 #endif
2977                 Copy(s, PL_origargv[0], len, char);
2978                 PL_origargv[0][len] = 0;
2979                 memset(PL_origargv[0] + len + 1,
2980                        pad,  PL_origalen - len - 1);
2981             }
2982             PL_origargv[0][PL_origalen-1] = 0;
2983             for (i = 1; i < PL_origargc; i++)
2984                 PL_origargv[i] = 0;
2985 #ifdef HAS_PRCTL_SET_NAME
2986             /* Set the legacy process name in addition to the POSIX name on Linux */
2987             if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2988                 /* diag_listed_as: SKIPME */
2989                 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2990             }
2991 #endif
2992         }
2993 #endif
2994         UNLOCK_DOLLARZERO_MUTEX;
2995         break;
2996     }
2997     return 0;
2998 }
2999
3000 I32
3001 Perl_whichsig_sv(pTHX_ SV *sigsv)
3002 {
3003     const char *sigpv;
3004     STRLEN siglen;
3005     PERL_ARGS_ASSERT_WHICHSIG_SV;
3006     PERL_UNUSED_CONTEXT;
3007     sigpv = SvPV_const(sigsv, siglen);
3008     return whichsig_pvn(sigpv, siglen);
3009 }
3010
3011 I32
3012 Perl_whichsig_pv(pTHX_ const char *sig)
3013 {
3014     PERL_ARGS_ASSERT_WHICHSIG_PV;
3015     PERL_UNUSED_CONTEXT;
3016     return whichsig_pvn(sig, strlen(sig));
3017 }
3018
3019 I32
3020 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3021 {
3022     char* const* sigv;
3023
3024     PERL_ARGS_ASSERT_WHICHSIG_PVN;
3025     PERL_UNUSED_CONTEXT;
3026
3027     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3028         if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3029             return PL_sig_num[sigv - (char* const*)PL_sig_name];
3030 #ifdef SIGCLD
3031     if (memEQs(sig, len, "CHLD"))
3032         return SIGCLD;
3033 #endif
3034 #ifdef SIGCHLD
3035     if (memEQs(sig, len, "CLD"))
3036         return SIGCHLD;
3037 #endif
3038     return -1;
3039 }
3040
3041 Signal_t
3042 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3043 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3044 #else
3045 Perl_sighandler(int sig)
3046 #endif
3047 {
3048 #ifdef PERL_GET_SIG_CONTEXT
3049     dTHXa(PERL_GET_SIG_CONTEXT);
3050 #else
3051     dTHX;
3052 #endif
3053     dSP;
3054     GV *gv = NULL;
3055     SV *sv = NULL;
3056     SV * const tSv = PL_Sv;
3057     CV *cv = NULL;
3058     OP *myop = PL_op;
3059     U32 flags = 0;
3060     XPV * const tXpv = PL_Xpv;
3061     I32 old_ss_ix = PL_savestack_ix;
3062     SV *errsv_save = NULL;
3063
3064
3065     if (!PL_psig_ptr[sig]) {
3066                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3067                                  PL_sig_name[sig]);
3068                 exit(sig);
3069         }
3070
3071     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3072         /* Max number of items pushed there is 3*n or 4. We cannot fix
3073            infinity, so we fix 4 (in fact 5): */
3074         if (PL_savestack_ix + 15 <= PL_savestack_max) {
3075             flags |= 1;
3076             PL_savestack_ix += 5;               /* Protect save in progress. */
3077             SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3078         }
3079     }
3080     /* sv_2cv is too complicated, try a simpler variant first: */
3081     if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3082         || SvTYPE(cv) != SVt_PVCV) {
3083         HV *st;
3084         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3085     }
3086
3087     if (!cv || !CvROOT(cv)) {
3088         Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3089                        PL_sig_name[sig], (gv ? GvENAME(gv)
3090                                           : ((cv && CvGV(cv))
3091                                              ? GvENAME(CvGV(cv))
3092                                              : "__ANON__")));
3093         goto cleanup;
3094     }
3095
3096     sv = PL_psig_name[sig]
3097             ? SvREFCNT_inc_NN(PL_psig_name[sig])
3098             : newSVpv(PL_sig_name[sig],0);
3099     flags |= 8;
3100     SAVEFREESV(sv);
3101
3102     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3103         /* make sure our assumption about the size of the SAVEs are correct:
3104          * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3105         assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0)  == PL_savestack_ix);
3106     }
3107
3108     PUSHSTACKi(PERLSI_SIGNAL);
3109     PUSHMARK(SP);
3110     PUSHs(sv);
3111 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3112     {
3113          struct sigaction oact;
3114
3115          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3116               if (sip) {
3117                    HV *sih = newHV();
3118                    SV *rv  = newRV_noinc(MUTABLE_SV(sih));
3119                    /* The siginfo fields signo, code, errno, pid, uid,
3120                     * addr, status, and band are defined by POSIX/SUSv3. */
3121                    (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3122                    (void)hv_stores(sih, "code", newSViv(sip->si_code));
3123 #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. */
3124                    hv_stores(sih, "errno",      newSViv(sip->si_errno));
3125                    hv_stores(sih, "status",     newSViv(sip->si_status));
3126                    hv_stores(sih, "uid",        newSViv(sip->si_uid));
3127                    hv_stores(sih, "pid",        newSViv(sip->si_pid));
3128                    hv_stores(sih, "addr",       newSVuv(PTR2UV(sip->si_addr)));
3129                    hv_stores(sih, "band",       newSViv(sip->si_band));
3130 #endif
3131                    EXTEND(SP, 2);
3132                    PUSHs(rv);
3133                    mPUSHp((char *)sip, sizeof(*sip));
3134               }
3135
3136          }
3137     }
3138 #endif
3139     PUTBACK;
3140
3141     errsv_save = newSVsv(ERRSV);
3142
3143     call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3144
3145     POPSTACK;
3146     {
3147         SV * const errsv = ERRSV;
3148         if (SvTRUE_NN(errsv)) {
3149             SvREFCNT_dec(errsv_save);
3150 #ifndef PERL_MICRO
3151         /* Handler "died", for example to get out of a restart-able read().
3152          * Before we re-do that on its behalf re-enable the signal which was
3153          * blocked by the system when we entered.
3154          */
3155 #ifdef HAS_SIGPROCMASK
3156 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3157             if (sip || uap)
3158 #endif
3159             {
3160                 sigset_t set;
3161                 sigemptyset(&set);
3162                 sigaddset(&set,sig);
3163                 sigprocmask(SIG_UNBLOCK, &set, NULL);
3164             }
3165 #else
3166             /* Not clear if this will work */
3167             (void)rsignal(sig, SIG_IGN);
3168             (void)rsignal(sig, PL_csighandlerp);
3169 #endif
3170 #endif /* !PERL_MICRO */
3171             die_sv(errsv);
3172         }
3173         else {
3174             sv_setsv(errsv, errsv_save);
3175             SvREFCNT_dec(errsv_save);
3176         }
3177     }
3178
3179 cleanup:
3180     /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3181     PL_savestack_ix = old_ss_ix;
3182     if (flags & 8)
3183         SvREFCNT_dec_NN(sv);
3184     PL_op = myop;                       /* Apparently not needed... */
3185
3186     PL_Sv = tSv;                        /* Restore global temporaries. */
3187     PL_Xpv = tXpv;
3188     return;
3189 }
3190
3191
3192 static void
3193 S_restore_magic(pTHX_ const void *p)
3194 {
3195     dVAR;
3196     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3197     SV* const sv = mgs->mgs_sv;
3198     bool bumped;
3199
3200     if (!sv)
3201         return;
3202
3203     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3204         SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3205 #ifdef PERL_OLD_COPY_ON_WRITE
3206         /* While magic was saved (and off) sv_setsv may well have seen
3207            this SV as a prime candidate for COW.  */
3208         if (SvIsCOW(sv))
3209             sv_force_normal_flags(sv, 0);
3210 #endif
3211         if (mgs->mgs_readonly)
3212             SvREADONLY_on(sv);
3213         if (mgs->mgs_magical)
3214             SvFLAGS(sv) |= mgs->mgs_magical;
3215         else
3216             mg_magical(sv);
3217     }
3218
3219     bumped = mgs->mgs_bumped;
3220     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
3221
3222     /* If we're still on top of the stack, pop us off.  (That condition
3223      * will be satisfied if restore_magic was called explicitly, but *not*
3224      * if it's being called via leave_scope.)
3225      * The reason for doing this is that otherwise, things like sv_2cv()
3226      * may leave alloc gunk on the savestack, and some code
3227      * (e.g. sighandler) doesn't expect that...
3228      */
3229     if (PL_savestack_ix == mgs->mgs_ss_ix)
3230     {
3231         UV popval = SSPOPUV;
3232         assert(popval == SAVEt_DESTRUCTOR_X);
3233         PL_savestack_ix -= 2;
3234         popval = SSPOPUV;
3235         assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3236         PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3237     }
3238     if (bumped) {
3239         if (SvREFCNT(sv) == 1) {
3240             /* We hold the last reference to this SV, which implies that the
3241                SV was deleted as a side effect of the routines we called.
3242                So artificially keep it alive a bit longer.
3243                We avoid turning on the TEMP flag, which can cause the SV's
3244                buffer to get stolen (and maybe other stuff). */
3245             sv_2mortal(sv);
3246             SvTEMP_off(sv);
3247         }
3248         else
3249             SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
3250     }
3251 }
3252
3253 /* clean up the mess created by Perl_sighandler().
3254  * Note that this is only called during an exit in a signal handler;
3255  * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3256  * skipped over. */
3257
3258 static void
3259 S_unwind_handler_stack(pTHX_ const void *p)
3260 {
3261     dVAR;
3262     PERL_UNUSED_ARG(p);
3263
3264     PL_savestack_ix -= 5; /* Unprotect save in progress. */
3265 }
3266
3267 /*
3268 =for apidoc magic_sethint
3269
3270 Triggered by a store to %^H, records the key/value pair to
3271 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
3272 anything that would need a deep copy.  Maybe we should warn if we find a
3273 reference.
3274
3275 =cut
3276 */
3277 int
3278 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3279 {
3280     dVAR;
3281     SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3282         : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3283
3284     PERL_ARGS_ASSERT_MAGIC_SETHINT;
3285
3286     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
3287        an alternative leaf in there, with PL_compiling.cop_hints being used if
3288        it's NULL. If needed for threads, the alternative could lock a mutex,
3289        or take other more complex action.  */
3290
3291     /* Something changed in %^H, so it will need to be restored on scope exit.
3292        Doing this here saves a lot of doing it manually in perl code (and
3293        forgetting to do it, and consequent subtle errors.  */
3294     PL_hints |= HINT_LOCALIZE_HH;
3295     CopHINTHASH_set(&PL_compiling,
3296         cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3297     return 0;
3298 }
3299
3300 /*
3301 =for apidoc magic_clearhint
3302
3303 Triggered by a delete from %^H, records the key to
3304 C<PL_compiling.cop_hints_hash>.
3305
3306 =cut
3307 */
3308 int
3309 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3310 {
3311     dVAR;
3312
3313     PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3314     PERL_UNUSED_ARG(sv);
3315
3316     PL_hints |= HINT_LOCALIZE_HH;
3317     CopHINTHASH_set(&PL_compiling,
3318         mg->mg_len == HEf_SVKEY
3319          ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3320                                  MUTABLE_SV(mg->mg_ptr), 0, 0)
3321          : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3322                                  mg->mg_ptr, mg->mg_len, 0, 0));
3323     return 0;
3324 }
3325
3326 /*
3327 =for apidoc magic_clearhints
3328
3329 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3330
3331 =cut
3332 */
3333 int
3334 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3335 {
3336     PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3337     PERL_UNUSED_ARG(sv);
3338     PERL_UNUSED_ARG(mg);
3339     cophh_free(CopHINTHASH_get(&PL_compiling));
3340     CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3341     return 0;
3342 }
3343
3344 int
3345 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3346                                  const char *name, I32 namlen)
3347 {
3348     MAGIC *nmg;
3349
3350     PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3351     PERL_UNUSED_ARG(sv);
3352     PERL_UNUSED_ARG(name);
3353     PERL_UNUSED_ARG(namlen);
3354
3355     sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3356     nmg = mg_find(nsv, mg->mg_type);
3357     if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3358     nmg->mg_ptr = mg->mg_ptr;
3359     nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3360     nmg->mg_flags |= MGf_REFCOUNTED;
3361     return 1;
3362 }
3363
3364 /*
3365  * Local variables:
3366  * c-indentation-style: bsd
3367  * c-basic-offset: 4
3368  * indent-tabs-mode: nil
3369  * End:
3370  *
3371  * ex: set ts=8 sts=4 sw=4 et:
3372  */