mg.c

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