mg.c

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