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_flags;
  88     bool mgs_bumped;
  89 };
  90 /* MGS is typedef'ed to struct magic_state in perl.h */
  91
  92 STATIC void
  93 S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags)
  94 {
  95     MGS* mgs;
  96     bool bumped = FALSE;
  97
  98     PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS;
  99
 100     assert(SvMAGICAL(sv));
 101
 102     /* we shouldn't really be called here with RC==0, but it can sometimes
 103      * happen via mg_clear() (which also shouldn't be called when RC==0,
 104      * but it can happen). Handle this case gracefully(ish) by not RC++
 105      * and thus avoiding the resultant double free */
 106     if (SvREFCNT(sv) > 0) {
 107     /* guard against sv getting freed midway through the mg clearing,
 108      * by holding a private reference for the duration. */
 109         SvREFCNT_inc_simple_void_NN(sv);
 110         bumped = TRUE;
 111     }
 112
 113     SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
 114
 115     mgs = SSPTR(mgs_ix, MGS*);
 116     mgs->mgs_sv = sv;
 117     mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
 118     mgs->mgs_ss_ix = PL_savestack_ix;   /* points after the saved destructor */
 119     mgs->mgs_bumped = bumped;
 120
 121     SvFLAGS(sv) &= ~flags;
 122     SvREADONLY_off(sv);
 123 }
 124
 125 #define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG)
 126
 127 /*
 128 =for apidoc mg_magical
 129
 130 Turns on the magical status of an SV.  See C<sv_magic>.
 131
 132 =cut
 133 */
 134
 135 void
 136 Perl_mg_magical(SV *sv)
 137 {
 138     const MAGIC* mg;
 139     PERL_ARGS_ASSERT_MG_MAGICAL;
 140
 141     SvMAGICAL_off(sv);
 142     if ((mg = SvMAGIC(sv))) {
 143         do {
 144             const MGVTBL* const vtbl = mg->mg_virtual;
 145             if (vtbl) {
 146                 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
 147                     SvGMAGICAL_on(sv);
 148                 if (vtbl->svt_set)
 149                     SvSMAGICAL_on(sv);
 150                 if (vtbl->svt_clear)
 151                     SvRMAGICAL_on(sv);
 152             }
 153         } while ((mg = mg->mg_moremagic));
 154         if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
 155             SvRMAGICAL_on(sv);
 156     }
 157 }
 158
 159 /*
 160 =for apidoc mg_get
 161
 162 Do magic before a value is retrieved from the SV.  The type of SV must
 163 be >= SVt_PVMG.  See C<sv_magic>.
 164
 165 =cut
 166 */
 167
 168 int
 169 Perl_mg_get(pTHX_ SV *sv)
 170 {
 171     const I32 mgs_ix = SSNEW(sizeof(MGS));
 172     bool saved = FALSE;
 173     bool have_new = 0;
 174     MAGIC *newmg, *head, *cur, *mg;
 175
 176     PERL_ARGS_ASSERT_MG_GET;
 177
 178     if (PL_localizing == 1 && sv == DEFSV) return 0;
 179
 180     /* We must call svt_get(sv, mg) for each valid entry in the linked
 181        list of magic. svt_get() may delete the current entry, add new
 182        magic to the head of the list, or upgrade the SV. AMS 20010810 */
 183
 184     newmg = cur = head = mg = SvMAGIC(sv);
 185     while (mg) {
 186         const MGVTBL * const vtbl = mg->mg_virtual;
 187         MAGIC * const nextmg = mg->mg_moremagic;        /* it may delete itself */
 188
 189         if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
 190
 191             /* taint's mg get is so dumb it doesn't need flag saving */
 192             if (!saved && mg->mg_type != PERL_MAGIC_taint) {
 193                 save_magic(mgs_ix, sv);
 194                 saved = TRUE;
 195             }
 196
 197             vtbl->svt_get(aTHX_ sv, mg);
 198
 199             /* guard against magic having been deleted - eg FETCH calling
 200              * untie */
 201             if (!SvMAGIC(sv)) {
 202                 /* recalculate flags */
 203                 (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
 204                 break;
 205             }
 206
 207             /* recalculate flags if this entry was deleted. */
 208             if (mg->mg_flags & MGf_GSKIP)
 209                 (SSPTR(mgs_ix, MGS *))->mgs_flags &=
 210                      ~(SVs_GMG|SVs_SMG|SVs_RMG);
 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             /* recalculate flags */
 235             (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
 236         }
 237     }
 238
 239     if (saved)
 240         restore_magic(INT2PTR(void *, (IV)mgs_ix));
 241
 242     return 0;
 243 }
 244
 245 /*
 246 =for apidoc mg_set
 247
 248 Do magic after a value is assigned to the SV.  See C<sv_magic>.
 249
 250 =cut
 251 */
 252
 253 int
 254 Perl_mg_set(pTHX_ SV *sv)
 255 {
 256     const I32 mgs_ix = SSNEW(sizeof(MGS));
 257     MAGIC* mg;
 258     MAGIC* nextmg;
 259
 260     PERL_ARGS_ASSERT_MG_SET;
 261
 262     if (PL_localizing == 2 && sv == DEFSV) return 0;
 263
 264     save_magic_flags(mgs_ix, sv, SVs_GMG|SVs_SMG); /* leave SVs_RMG on */
 265
 266     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
 267         const MGVTBL* vtbl = mg->mg_virtual;
 268         nextmg = mg->mg_moremagic;      /* it may delete itself */
 269         if (mg->mg_flags & MGf_GSKIP) {
 270             mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
 271             (SSPTR(mgs_ix, MGS*))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
 272         }
 273         if (PL_localizing == 2
 274             && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
 275             continue;
 276         if (vtbl && vtbl->svt_set)
 277             vtbl->svt_set(aTHX_ sv, mg);
 278     }
 279
 280     restore_magic(INT2PTR(void*, (IV)mgs_ix));
 281     return 0;
 282 }
 283
 284 /*
 285 =for apidoc mg_length
 286
 287 Reports on the SV's length in bytes, calling length magic if available,
 288 but does not set the UTF8 flag on the sv.  It will fall back to 'get'
 289 magic if there is no 'length' magic, but with no indication as to
 290 whether it called 'get' magic.  It assumes the sv is a PVMG or
 291 higher.  Use sv_len() instead.
 292
 293 =cut
 294 */
 295
 296 U32
 297 Perl_mg_length(pTHX_ SV *sv)
 298 {
 299     MAGIC* mg;
 300     STRLEN len;
 301
 302     PERL_ARGS_ASSERT_MG_LENGTH;
 303
 304     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 305         const MGVTBL * const vtbl = mg->mg_virtual;
 306         if (vtbl && vtbl->svt_len) {
 307             const I32 mgs_ix = SSNEW(sizeof(MGS));
 308             save_magic(mgs_ix, sv);
 309             /* omit MGf_GSKIP -- not changed here */
 310             len = vtbl->svt_len(aTHX_ sv, mg);
 311             restore_magic(INT2PTR(void*, (IV)mgs_ix));
 312             return len;
 313         }
 314     }
 315
 316     (void)SvPV_const(sv, len);
 317     return len;
 318 }
 319
 320 I32
 321 Perl_mg_size(pTHX_ SV *sv)
 322 {
 323     MAGIC* mg;
 324
 325     PERL_ARGS_ASSERT_MG_SIZE;
 326
 327     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 328         const MGVTBL* const vtbl = mg->mg_virtual;
 329         if (vtbl && vtbl->svt_len) {
 330             const I32 mgs_ix = SSNEW(sizeof(MGS));
 331             I32 len;
 332             save_magic(mgs_ix, sv);
 333             /* omit MGf_GSKIP -- not changed here */
 334             len = vtbl->svt_len(aTHX_ sv, mg);
 335             restore_magic(INT2PTR(void*, (IV)mgs_ix));
 336             return len;
 337         }
 338     }
 339
 340     switch(SvTYPE(sv)) {
 341         case SVt_PVAV:
 342             return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
 343         case SVt_PVHV:
 344             /* FIXME */
 345         default:
 346             Perl_croak(aTHX_ "Size magic not implemented");
 347
 348     }
 349     NOT_REACHED; /* NOTREACHED */
 350 }
 351
 352 /*
 353 =for apidoc mg_clear
 354
 355 Clear something magical that the SV represents.  See C<sv_magic>.
 356
 357 =cut
 358 */
 359
 360 int
 361 Perl_mg_clear(pTHX_ SV *sv)
 362 {
 363     const I32 mgs_ix = SSNEW(sizeof(MGS));
 364     MAGIC* mg;
 365     MAGIC *nextmg;
 366
 367     PERL_ARGS_ASSERT_MG_CLEAR;
 368
 369     save_magic(mgs_ix, sv);
 370
 371     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
 372         const MGVTBL* const vtbl = mg->mg_virtual;
 373         /* omit GSKIP -- never set here */
 374
 375         nextmg = mg->mg_moremagic; /* it may delete itself */
 376
 377         if (vtbl && vtbl->svt_clear)
 378             vtbl->svt_clear(aTHX_ sv, mg);
 379     }
 380
 381     restore_magic(INT2PTR(void*, (IV)mgs_ix));
 382     return 0;
 383 }
 384
 385 static MAGIC*
 386 S_mg_findext_flags(const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
 387 {
 388     assert(flags <= 1);
 389
 390     if (sv) {
 391         MAGIC *mg;
 392
 393         assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)));
 394
 395         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 396             if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
 397                 return mg;
 398             }
 399         }
 400     }
 401
 402     return NULL;
 403 }
 404
 405 /*
 406 =for apidoc mg_find
 407
 408 Finds the magic pointer for type matching the SV.  See C<sv_magic>.
 409
 410 =cut
 411 */
 412
 413 MAGIC*
 414 Perl_mg_find(const SV *sv, int type)
 415 {
 416     return S_mg_findext_flags(sv, type, NULL, 0);
 417 }
 418
 419 /*
 420 =for apidoc mg_findext
 421
 422 Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>.  See
 423 C<sv_magicext>.
 424
 425 =cut
 426 */
 427
 428 MAGIC*
 429 Perl_mg_findext(const SV *sv, int type, const MGVTBL *vtbl)
 430 {
 431     return S_mg_findext_flags(sv, type, vtbl, 1);
 432 }
 433
 434 MAGIC *
 435 Perl_mg_find_mglob(pTHX_ SV *sv)
 436 {
 437     PERL_ARGS_ASSERT_MG_FIND_MGLOB;
 438     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
 439         /* This sv is only a delegate.  //g magic must be attached to
 440            its target. */
 441         vivify_defelem(sv);
 442         sv = LvTARG(sv);
 443     }
 444     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
 445         return S_mg_findext_flags(sv, PERL_MAGIC_regex_global, 0, 0);
 446     return NULL;
 447 }
 448
 449 /*
 450 =for apidoc mg_copy
 451
 452 Copies the magic from one SV to another.  See C<sv_magic>.
 453
 454 =cut
 455 */
 456
 457 int
 458 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
 459 {
 460     int count = 0;
 461     MAGIC* mg;
 462
 463     PERL_ARGS_ASSERT_MG_COPY;
 464
 465     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 466         const MGVTBL* const vtbl = mg->mg_virtual;
 467         if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
 468             count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
 469         }
 470         else {
 471             const char type = mg->mg_type;
 472             if (isUPPER(type) && type != PERL_MAGIC_uvar) {
 473                 sv_magic(nsv,
 474                      (type == PERL_MAGIC_tied)
 475                         ? SvTIED_obj(sv, mg)
 476                         : (type == PERL_MAGIC_regdata && mg->mg_obj)
 477                             ? sv
 478                             : mg->mg_obj,
 479                      toLOWER(type), key, klen);
 480                 count++;
 481             }
 482         }
 483     }
 484     return count;
 485 }
 486
 487 /*
 488 =for apidoc mg_localize
 489
 490 Copy some of the magic from an existing SV to new localized version of that
 491 SV.  Container magic (eg %ENV, $1, tie)
 492 gets copied, value magic doesn't (eg
 493 taint, pos).
 494
 495 If setmagic is false then no set magic will be called on the new (empty) SV.
 496 This typically means that assignment will soon follow (e.g. 'local $x = $y'),
 497 and that will handle the magic.
 498
 499 =cut
 500 */
 501
 502 void
 503 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
 504 {
 505     MAGIC *mg;
 506
 507     PERL_ARGS_ASSERT_MG_LOCALIZE;
 508
 509     if (nsv == DEFSV)
 510         return;
 511
 512     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 513         const MGVTBL* const vtbl = mg->mg_virtual;
 514         if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
 515             continue;
 516
 517         if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
 518             (void)vtbl->svt_local(aTHX_ nsv, mg);
 519         else
 520             sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
 521                             mg->mg_ptr, mg->mg_len);
 522
 523         /* container types should remain read-only across localization */
 524         SvFLAGS(nsv) |= SvREADONLY(sv);
 525     }
 526
 527     if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
 528         SvFLAGS(nsv) |= SvMAGICAL(sv);
 529         if (setmagic) {
 530             PL_localizing = 1;
 531             SvSETMAGIC(nsv);
 532             PL_localizing = 0;
 533         }
 534     }
 535 }
 536
 537 #define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
 538 static void
 539 S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
 540 {
 541     const MGVTBL* const vtbl = mg->mg_virtual;
 542     if (vtbl && vtbl->svt_free)
 543         vtbl->svt_free(aTHX_ sv, mg);
 544     if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
 545         if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
 546             Safefree(mg->mg_ptr);
 547         else if (mg->mg_len == HEf_SVKEY)
 548             SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
 549     }
 550     if (mg->mg_flags & MGf_REFCOUNTED)
 551         SvREFCNT_dec(mg->mg_obj);
 552     Safefree(mg);
 553 }
 554
 555 /*
 556 =for apidoc mg_free
 557
 558 Free any magic storage used by the SV.  See C<sv_magic>.
 559
 560 =cut
 561 */
 562
 563 int
 564 Perl_mg_free(pTHX_ SV *sv)
 565 {
 566     MAGIC* mg;
 567     MAGIC* moremagic;
 568
 569     PERL_ARGS_ASSERT_MG_FREE;
 570
 571     for (mg = SvMAGIC(sv); mg; mg = moremagic) {
 572         moremagic = mg->mg_moremagic;
 573         mg_free_struct(sv, mg);
 574         SvMAGIC_set(sv, moremagic);
 575     }
 576     SvMAGIC_set(sv, NULL);
 577     SvMAGICAL_off(sv);
 578     return 0;
 579 }
 580
 581 /*
 582 =for apidoc Am|void|mg_free_type|SV *sv|int how
 583
 584 Remove any magic of type I<how> from the SV I<sv>.  See L</sv_magic>.
 585
 586 =cut
 587 */
 588
 589 void
 590 Perl_mg_free_type(pTHX_ SV *sv, int how)
 591 {
 592     MAGIC *mg, *prevmg, *moremg;
 593     PERL_ARGS_ASSERT_MG_FREE_TYPE;
 594     for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
 595         MAGIC *newhead;
 596         moremg = mg->mg_moremagic;
 597         if (mg->mg_type == how) {
 598             /* temporarily move to the head of the magic chain, in case
 599                custom free code relies on this historical aspect of mg_free */
 600             if (prevmg) {
 601                 prevmg->mg_moremagic = moremg;
 602                 mg->mg_moremagic = SvMAGIC(sv);
 603                 SvMAGIC_set(sv, mg);
 604             }
 605             newhead = mg->mg_moremagic;
 606             mg_free_struct(sv, mg);
 607             SvMAGIC_set(sv, newhead);
 608             mg = prevmg;
 609         }
 610     }
 611     mg_magical(sv);
 612 }
 613
 614 #include <signal.h>
 615
 616 U32
 617 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
 618 {
 619     PERL_UNUSED_ARG(sv);
 620
 621     PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
 622
 623     if (PL_curpm) {
 624         const REGEXP * const rx = PM_GETRE(PL_curpm);
 625         if (rx) {
 626             if (mg->mg_obj) {                   /* @+ */
 627                 /* return the number possible */
 628                 return RX_NPARENS(rx);
 629             } else {                            /* @- */
 630                 I32 paren = RX_LASTPAREN(rx);
 631
 632                 /* return the last filled */
 633                 while ( paren >= 0
 634                         && (RX_OFFS(rx)[paren].start == -1
 635                             || RX_OFFS(rx)[paren].end == -1) )
 636                     paren--;
 637                 return (U32)paren;
 638             }
 639         }
 640     }
 641
 642     return (U32)-1;
 643 }
 644
 645 /* @-, @+ */
 646
 647 int
 648 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
 649 {
 650     PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
 651
 652     if (PL_curpm) {
 653         const REGEXP * const rx = PM_GETRE(PL_curpm);
 654         if (rx) {
 655             const I32 paren = mg->mg_len;
 656             SSize_t s;
 657             SSize_t t;
 658             if (paren < 0)
 659                 return 0;
 660             if (paren <= (I32)RX_NPARENS(rx) &&
 661                 (s = RX_OFFS(rx)[paren].start) != -1 &&
 662                 (t = RX_OFFS(rx)[paren].end) != -1)
 663                 {
 664                     SSize_t i;
 665                     if (mg->mg_obj)             /* @+ */
 666                         i = t;
 667                     else                        /* @- */
 668                         i = s;
 669
 670                     if (RX_MATCH_UTF8(rx)) {
 671                         const char * const b = RX_SUBBEG(rx);
 672                         if (b)
 673                             i = RX_SUBCOFFSET(rx) +
 674                                     utf8_length((U8*)b,
 675                                         (U8*)(b-RX_SUBOFFSET(rx)+i));
 676                     }
 677
 678                     sv_setuv(sv, i);
 679                     return 0;
 680                 }
 681         }
 682     }
 683     sv_setsv(sv, NULL);
 684     return 0;
 685 }
 686
 687 /* @-, @+ */
 688
 689 int
 690 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
 691 {
 692     PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
 693     PERL_UNUSED_CONTEXT;
 694     PERL_UNUSED_ARG(sv);
 695     PERL_UNUSED_ARG(mg);
 696     Perl_croak_no_modify();
 697     NORETURN_FUNCTION_END;
 698 }
 699
 700 #define SvRTRIM(sv) STMT_START { \
 701     if (SvPOK(sv)) { \
 702         STRLEN len = SvCUR(sv); \
 703         char * const p = SvPVX(sv); \
 704         while (len > 0 && isSPACE(p[len-1])) \
 705            --len; \
 706         SvCUR_set(sv, len); \
 707         p[len] = '\0'; \
 708     } \
 709 } STMT_END
 710
 711 void
 712 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
 713 {
 714     PERL_ARGS_ASSERT_EMULATE_COP_IO;
 715
 716     if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
 717         sv_setsv(sv, &PL_sv_undef);
 718     else {
 719         sv_setpvs(sv, "");
 720         SvUTF8_off(sv);
 721         if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
 722             SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
 723             assert(value);
 724             sv_catsv(sv, value);
 725         }
 726         sv_catpvs(sv, "\0");
 727         if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
 728             SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
 729             assert(value);
 730             sv_catsv(sv, value);
 731         }
 732     }
 733 }
 734
 735 STATIC void
 736 S_fixup_errno_string(pTHX_ SV* sv)
 737 {
 738     /* Do what is necessary to fixup the non-empty string in 'sv' for return to
 739      * Perl space. */
 740
 741     PERL_ARGS_ASSERT_FIXUP_ERRNO_STRING;
 742
 743     assert(SvOK(sv));
 744
 745     if(strEQ(SvPVX(sv), "")) {
 746         sv_catpv(sv, UNKNOWN_ERRNO_MSG);
 747     }
 748     else {
 749
 750         /* In some locales the error string may come back as UTF-8, in which
 751          * case we should turn on that flag.  This didn't use to happen, and to
 752          * avoid as many possible backward compatibility issues as possible, we
 753          * don't turn on the flag unless we have to.  So the flag stays off for
 754          * an entirely ASCII string.  We assume that if the string looks like
 755          * UTF-8, it really is UTF-8:  "text in any other encoding that uses
 756          * bytes with the high bit set is extremely unlikely to pass a UTF-8
 757          * validity test" (http://en.wikipedia.org/wiki/Charset_detection).
 758          * There is a potential that we will get it wrong however, especially
 759          * on short error message text.  (If it turns out to be necessary, we
 760          * could also keep track if the current LC_MESSAGES locale is UTF-8) */
 761         if (! IN_BYTES  /* respect 'use bytes' */
 762             && ! is_ascii_string((U8*) SvPVX_const(sv), SvCUR(sv))
 763             && is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv)))
 764         {
 765             SvUTF8_on(sv);
 766         }
 767     }
 768 }
 769
 770 #ifdef VMS
 771 #include <descrip.h>
 772 #include <starlet.h>
 773 #endif
 774
 775 int
 776 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 777 {
 778     I32 paren;
 779     const char *s = NULL;
 780     REGEXP *rx;
 781     const char * const remaining = mg->mg_ptr + 1;
 782     char nextchar;
 783
 784     PERL_ARGS_ASSERT_MAGIC_GET;
 785
 786     if (!mg->mg_ptr) {
 787         paren = mg->mg_len;
 788         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 789           do_numbuf_fetch:
 790             CALLREG_NUMBUF_FETCH(rx,paren,sv);
 791         } else {
 792             sv_setsv(sv,&PL_sv_undef);
 793         }
 794         return 0;
 795     }
 796
 797     nextchar = *remaining;
 798     switch (*mg->mg_ptr) {
 799     case '\001':                /* ^A */
 800         if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
 801         else sv_setsv(sv, &PL_sv_undef);
 802         if (SvTAINTED(PL_bodytarget))
 803             SvTAINTED_on(sv);
 804         break;
 805     case '\003':                /* ^C, ^CHILD_ERROR_NATIVE */
 806         if (nextchar == '\0') {
 807             sv_setiv(sv, (IV)PL_minus_c);
 808         }
 809         else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
 810             sv_setiv(sv, (IV)STATUS_NATIVE);
 811         }
 812         break;
 813
 814     case '\004':                /* ^D */
 815         sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
 816         break;
 817     case '\005':  /* ^E */
 818          if (nextchar != '\0') {
 819             if (strEQ(remaining, "NCODING"))
 820                 sv_setsv(sv, PL_encoding);
 821             break;
 822         }
 823
 824 #if defined(VMS) || defined(OS2) || defined(WIN32)
 825 #   if defined(VMS)
 826         {
 827             char msg[255];
 828             $DESCRIPTOR(msgdsc,msg);
 829             sv_setnv(sv,(NV) vaxc$errno);
 830             if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
 831                 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
 832             else
 833                 sv_setpvs(sv,"");
 834         }
 835 #elif defined(OS2)
 836         if (!(_emx_env & 0x200)) {      /* Under DOS */
 837             sv_setnv(sv, (NV)errno);
 838             sv_setpv(sv, errno ? my_strerror(errno) : "");
 839         } else {
 840             if (errno != errno_isOS2) {
 841                 const int tmp = _syserrno();
 842                 if (tmp)        /* 2nd call to _syserrno() makes it 0 */
 843                     Perl_rc = tmp;
 844             }
 845             sv_setnv(sv, (NV)Perl_rc);
 846             sv_setpv(sv, os2error(Perl_rc));
 847         }
 848         if (SvOK(sv) && strNE(SvPVX(sv), "")) {
 849             fixup_errno_string(sv);
 850         }
 851 #   elif defined(WIN32)
 852         {
 853             const DWORD dwErr = GetLastError();
 854             sv_setnv(sv, (NV)dwErr);
 855             if (dwErr) {
 856                 PerlProc_GetOSError(sv, dwErr);
 857                 fixup_errno_string(sv);
 858             }
 859             else
 860                 sv_setpvs(sv, "");
 861             SetLastError(dwErr);
 862         }
 863 #   else
 864 #   error Missing code for platform
 865 #   endif
 866         SvRTRIM(sv);
 867         SvNOK_on(sv);   /* what a wonderful hack! */
 868         break;
 869 #endif  /* End of platforms with special handling for $^E; others just fall
 870            through to $! */
 871
 872     case '!':
 873         {
 874             dSAVE_ERRNO;
 875 #ifdef VMS
 876             sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
 877 #else
 878             sv_setnv(sv, (NV)errno);
 879 #endif
 880 #ifdef OS2
 881             if (errno == errno_isOS2 || errno == errno_isOS2_set)
 882                 sv_setpv(sv, os2error(Perl_rc));
 883             else
 884 #endif
 885             if (! errno) {
 886                 sv_setpvs(sv, "");
 887             }
 888             else {
 889
 890                 /* Strerror can return NULL on some platforms, which will
 891                  * result in 'sv' not being considered SvOK.  The SvNOK_on()
 892                  * below will cause just the number part to be valid */
 893                 sv_setpv(sv, my_strerror(errno));
 894                 if (SvOK(sv)) {
 895                     fixup_errno_string(sv);
 896                 }
 897             }
 898             RESTORE_ERRNO;
 899         }
 900
 901         SvRTRIM(sv);
 902         SvNOK_on(sv);   /* what a wonderful hack! */
 903         break;
 904
 905     case '\006':                /* ^F */
 906         sv_setiv(sv, (IV)PL_maxsysfd);
 907         break;
 908     case '\007':                /* ^GLOBAL_PHASE */
 909         if (strEQ(remaining, "LOBAL_PHASE")) {
 910             sv_setpvn(sv, PL_phase_names[PL_phase],
 911                       strlen(PL_phase_names[PL_phase]));
 912         }
 913         break;
 914     case '\010':                /* ^H */
 915         sv_setiv(sv, (IV)PL_hints);
 916         break;
 917     case '\011':                /* ^I */ /* NOT \t in EBCDIC */
 918         sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
 919         break;
 920     case '\014':                /* ^LAST_FH */
 921         if (strEQ(remaining, "AST_FH")) {
 922             if (PL_last_in_gv) {
 923                 assert(isGV_with_GP(PL_last_in_gv));
 924                 SV_CHECK_THINKFIRST_COW_DROP(sv);
 925                 prepare_SV_for_RV(sv);
 926                 SvOK_off(sv);
 927                 SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv));
 928                 SvROK_on(sv);
 929                 sv_rvweaken(sv);
 930             }
 931             else sv_setsv_nomg(sv, NULL);
 932         }
 933         break;
 934     case '\017':                /* ^O & ^OPEN */
 935         if (nextchar == '\0') {
 936             sv_setpv(sv, PL_osname);
 937             SvTAINTED_off(sv);
 938         }
 939         else if (strEQ(remaining, "PEN")) {
 940             Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
 941         }
 942         break;
 943     case '\020':
 944         sv_setiv(sv, (IV)PL_perldb);
 945         break;
 946     case '\023':                /* ^S */
 947         {
 948             if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
 949                 SvOK_off(sv);
 950             else if (PL_in_eval)
 951                 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
 952             else
 953                 sv_setiv(sv, 0);
 954         }
 955         break;
 956     case '\024':                /* ^T */
 957         if (nextchar == '\0') {
 958 #ifdef BIG_TIME
 959             sv_setnv(sv, PL_basetime);
 960 #else
 961             sv_setiv(sv, (IV)PL_basetime);
 962 #endif
 963         }
 964         else if (strEQ(remaining, "AINT"))
 965             sv_setiv(sv, TAINTING_get
 966                     ? (TAINT_WARN_get || PL_unsafe ? -1 : 1)
 967                     : 0);
 968         break;
 969     case '\025':                /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
 970         if (strEQ(remaining, "NICODE"))
 971             sv_setuv(sv, (UV) PL_unicode);
 972         else if (strEQ(remaining, "TF8LOCALE"))
 973             sv_setuv(sv, (UV) PL_utf8locale);
 974         else if (strEQ(remaining, "TF8CACHE"))
 975             sv_setiv(sv, (IV) PL_utf8cache);
 976         break;
 977     case '\027':                /* ^W  & $^WARNING_BITS */
 978         if (nextchar == '\0')
 979             sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
 980         else if (strEQ(remaining, "ARNING_BITS")) {
 981             if (PL_compiling.cop_warnings == pWARN_NONE) {
 982                 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
 983             }
 984             else if (PL_compiling.cop_warnings == pWARN_STD) {
 985                 sv_setsv(sv, &PL_sv_undef);
 986                 break;
 987             }
 988             else if (PL_compiling.cop_warnings == pWARN_ALL) {
 989                 /* Get the bit mask for $warnings::Bits{all}, because
 990                  * it could have been extended by warnings::register */
 991                 HV * const bits = get_hv("warnings::Bits", 0);
 992                 SV ** const bits_all = bits ? hv_fetchs(bits, "all", FALSE) : NULL;
 993                 if (bits_all)
 994                     sv_copypv(sv, *bits_all);
 995                 else
 996                     sv_setpvn(sv, WARN_ALLstring, WARNsize);
 997             }
 998             else {
 999                 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
1000                           *PL_compiling.cop_warnings);
1001             }
1002         }
1003         break;
1004     case '+':
1005         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1006             paren = RX_LASTPAREN(rx);
1007             if (paren)
1008                 goto do_numbuf_fetch;
1009         }
1010         sv_setsv(sv,&PL_sv_undef);
1011         break;
1012     case '\016':                /* ^N */
1013         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1014             paren = RX_LASTCLOSEPAREN(rx);
1015             if (paren)
1016                 goto do_numbuf_fetch;
1017         }
1018         sv_setsv(sv,&PL_sv_undef);
1019         break;
1020     case '.':
1021         if (GvIO(PL_last_in_gv)) {
1022             sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
1023         }
1024         break;
1025     case '?':
1026         {
1027             sv_setiv(sv, (IV)STATUS_CURRENT);
1028 #ifdef COMPLEX_STATUS
1029             SvUPGRADE(sv, SVt_PVLV);
1030             LvTARGOFF(sv) = PL_statusvalue;
1031             LvTARGLEN(sv) = PL_statusvalue_vms;
1032 #endif
1033         }
1034         break;
1035     case '^':
1036         if (GvIOp(PL_defoutgv))
1037                 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1038         if (s)
1039             sv_setpv(sv,s);
1040         else {
1041             sv_setpv(sv,GvENAME(PL_defoutgv));
1042             sv_catpvs(sv,"_TOP");
1043         }
1044         break;
1045     case '~':
1046         if (GvIOp(PL_defoutgv))
1047             s = IoFMT_NAME(GvIOp(PL_defoutgv));
1048         if (!s)
1049             s = GvENAME(PL_defoutgv);
1050         sv_setpv(sv,s);
1051         break;
1052     case '=':
1053         if (GvIO(PL_defoutgv))
1054             sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1055         break;
1056     case '-':
1057         if (GvIO(PL_defoutgv))
1058             sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1059         break;
1060     case '%':
1061         if (GvIO(PL_defoutgv))
1062             sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1063         break;
1064     case ':':
1065         break;
1066     case '/':
1067         break;
1068     case '[':
1069         sv_setiv(sv, 0);
1070         break;
1071     case '|':
1072         if (GvIO(PL_defoutgv))
1073             sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1074         break;
1075     case '\\':
1076         if (PL_ors_sv)
1077             sv_copypv(sv, PL_ors_sv);
1078         else
1079             sv_setsv(sv, &PL_sv_undef);
1080         break;
1081     case '$': /* $$ */
1082         {
1083             IV const pid = (IV)PerlProc_getpid();
1084             if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
1085                 /* never set manually, or at least not since last fork */
1086                 sv_setiv(sv, pid);
1087                 /* never unsafe, even if reading in a tainted expression */
1088                 SvTAINTED_off(sv);
1089             }
1090             /* else a value has been assigned manually, so do nothing */
1091         }
1092         break;
1093     case '<':
1094         sv_setuid(sv, PerlProc_getuid());
1095         break;
1096     case '>':
1097         sv_setuid(sv, PerlProc_geteuid());
1098         break;
1099     case '(':
1100         sv_setgid(sv, PerlProc_getgid());
1101         goto add_groups;
1102     case ')':
1103         sv_setgid(sv, PerlProc_getegid());
1104       add_groups:
1105 #ifdef HAS_GETGROUPS
1106         {
1107             Groups_t *gary = NULL;
1108             I32 i;
1109             I32 num_groups = getgroups(0, gary);
1110             if (num_groups > 0) {
1111                 Newx(gary, num_groups, Groups_t);
1112                 num_groups = getgroups(num_groups, gary);
1113                 for (i = 0; i < num_groups; i++)
1114                     Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1115                 Safefree(gary);
1116             }
1117         }
1118         (void)SvIOK_on(sv);     /* what a wonderful hack! */
1119 #endif
1120         break;
1121     case '0':
1122         break;
1123     }
1124     return 0;
1125 }
1126
1127 int
1128 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1129 {
1130     struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1131
1132     PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1133
1134     if (uf && uf->uf_val)
1135         (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1136     return 0;
1137 }
1138
1139 int
1140 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1141 {
1142     STRLEN len = 0, klen;
1143     const char * const key = MgPV_const(mg,klen);
1144     const char *s = "";
1145
1146     PERL_ARGS_ASSERT_MAGIC_SETENV;
1147
1148     SvGETMAGIC(sv);
1149     if (SvOK(sv)) {
1150         /* defined environment variables are byte strings; unfortunately
1151            there is no SvPVbyte_force_nomg(), so we must do this piecewise */
1152         (void)SvPV_force_nomg_nolen(sv);
1153         sv_utf8_downgrade(sv, /* fail_ok */ TRUE);
1154         if (SvUTF8(sv)) {
1155             Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv");
1156             SvUTF8_off(sv);
1157         }
1158         s = SvPVX(sv);
1159         len = SvCUR(sv);
1160     }
1161     my_setenv(key, s); /* does the deed */
1162
1163 #ifdef DYNAMIC_ENV_FETCH
1164      /* We just undefd an environment var.  Is a replacement */
1165      /* waiting in the wings? */
1166     if (!len) {
1167         SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE);
1168         if (valp)
1169             s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1170     }
1171 #endif
1172
1173 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1174                             /* And you'll never guess what the dog had */
1175                             /*   in its mouth... */
1176     if (TAINTING_get) {
1177         MgTAINTEDDIR_off(mg);
1178 #ifdef VMS
1179         if (s && klen == 8 && strEQ(key, "DCL$PATH")) {
1180             char pathbuf[256], eltbuf[256], *cp, *elt;
1181             int i = 0, j = 0;
1182
1183             my_strlcpy(eltbuf, s, sizeof(eltbuf));
1184             elt = eltbuf;
1185             do {          /* DCL$PATH may be a search list */
1186                 while (1) {   /* as may dev portion of any element */
1187                     if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1188                         if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1189                              cando_by_name(S_IWUSR,0,elt) ) {
1190                             MgTAINTEDDIR_on(mg);
1191                             return 0;
1192                         }
1193                     }
1194                     if ((cp = strchr(elt, ':')) != NULL)
1195                         *cp = '\0';
1196                     if (my_trnlnm(elt, eltbuf, j++))
1197                         elt = eltbuf;
1198                     else
1199                         break;
1200                 }
1201                 j = 0;
1202             } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1203         }
1204 #endif /* VMS */
1205         if (s && klen == 4 && strEQ(key,"PATH")) {
1206             const char * const strend = s + len;
1207
1208             while (s < strend) {
1209                 char tmpbuf[256];
1210                 Stat_t st;
1211                 I32 i;
1212 #ifdef VMS  /* Hmm.  How do we get $Config{path_sep} from C? */
1213                 const char path_sep = '|';
1214 #else
1215                 const char path_sep = ':';
1216 #endif
1217                 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1218                              s, strend, path_sep, &i);
1219                 s++;
1220                 if (i >= (I32)sizeof tmpbuf   /* too long -- assume the worst */
1221 #ifdef VMS
1222                       || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1223 #else
1224                       || *tmpbuf != '/'       /* no starting slash -- assume relative path */
1225 #endif
1226                       || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1227                     MgTAINTEDDIR_on(mg);
1228                     return 0;
1229                 }
1230             }
1231         }
1232     }
1233 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1234
1235     return 0;
1236 }
1237
1238 int
1239 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1240 {
1241     PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1242     PERL_UNUSED_ARG(sv);
1243     my_setenv(MgPV_nolen_const(mg),NULL);
1244     return 0;
1245 }
1246
1247 int
1248 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1249 {
1250     PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1251     PERL_UNUSED_ARG(mg);
1252 #if defined(VMS)
1253     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1254 #else
1255     if (PL_localizing) {
1256         HE* entry;
1257         my_clearenv();
1258         hv_iterinit(MUTABLE_HV(sv));
1259         while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1260             I32 keylen;
1261             my_setenv(hv_iterkey(entry, &keylen),
1262                       SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1263         }
1264     }
1265 #endif
1266     return 0;
1267 }
1268
1269 int
1270 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1271 {
1272     PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1273     PERL_UNUSED_ARG(sv);
1274     PERL_UNUSED_ARG(mg);
1275 #if defined(VMS)
1276     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1277 #else
1278     my_clearenv();
1279 #endif
1280     return 0;
1281 }
1282
1283 #ifndef PERL_MICRO
1284 #ifdef HAS_SIGPROCMASK
1285 static void
1286 restore_sigmask(pTHX_ SV *save_sv)
1287 {
1288     const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1289     (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1290 }
1291 #endif
1292 int
1293 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1294 {
1295     /* Are we fetching a signal entry? */
1296     int i = (I16)mg->mg_private;
1297
1298     PERL_ARGS_ASSERT_MAGIC_GETSIG;
1299
1300     if (!i) {
1301         STRLEN siglen;
1302         const char * sig = MgPV_const(mg, siglen);
1303         mg->mg_private = i = whichsig_pvn(sig, siglen);
1304     }
1305
1306     if (i > 0) {
1307         if(PL_psig_ptr[i])
1308             sv_setsv(sv,PL_psig_ptr[i]);
1309         else {
1310             Sighandler_t sigstate = rsignal_state(i);
1311 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1312             if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1313                 sigstate = SIG_IGN;
1314 #endif
1315 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1316             if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1317                 sigstate = SIG_DFL;
1318 #endif
1319             /* cache state so we don't fetch it again */
1320             if(sigstate == (Sighandler_t) SIG_IGN)
1321                 sv_setpvs(sv,"IGNORE");
1322             else
1323                 sv_setsv(sv,&PL_sv_undef);
1324             PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1325             SvTEMP_off(sv);
1326         }
1327     }
1328     return 0;
1329 }
1330 int
1331 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1332 {
1333     PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1334
1335     magic_setsig(NULL, mg);
1336     return sv_unmagic(sv, mg->mg_type);
1337 }
1338
1339 Signal_t
1340 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1341 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1342 #else
1343 Perl_csighandler(int sig)
1344 #endif
1345 {
1346 #ifdef PERL_GET_SIG_CONTEXT
1347     dTHXa(PERL_GET_SIG_CONTEXT);
1348 #else
1349     dTHX;
1350 #endif
1351 #if defined(__cplusplus) && defined(__GNUC__)
1352     /* g++ doesn't support PERL_UNUSED_DECL, so the sip and uap
1353      * parameters would be warned about. */
1354     PERL_UNUSED_ARG(sip);
1355     PERL_UNUSED_ARG(uap);
1356 #endif
1357 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1358     (void) rsignal(sig, PL_csighandlerp);
1359     if (PL_sig_ignoring[sig]) return;
1360 #endif
1361 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1362     if (PL_sig_defaulting[sig])
1363 #ifdef KILL_BY_SIGPRC
1364             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1365 #else
1366             exit(1);
1367 #endif
1368 #endif
1369     if (
1370 #ifdef SIGILL
1371            sig == SIGILL ||
1372 #endif
1373 #ifdef SIGBUS
1374            sig == SIGBUS ||
1375 #endif
1376 #ifdef SIGSEGV
1377            sig == SIGSEGV ||
1378 #endif
1379            (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1380         /* Call the perl level handler now--
1381          * with risk we may be in malloc() or being destructed etc. */
1382 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1383         (*PL_sighandlerp)(sig, NULL, NULL);
1384 #else
1385         (*PL_sighandlerp)(sig);
1386 #endif
1387     else {
1388         if (!PL_psig_pend) return;
1389         /* Set a flag to say this signal is pending, that is awaiting delivery after
1390          * the current Perl opcode completes */
1391         PL_psig_pend[sig]++;
1392
1393 #ifndef SIG_PENDING_DIE_COUNT
1394 #  define SIG_PENDING_DIE_COUNT 120
1395 #endif
1396         /* Add one to say _a_ signal is pending */
1397         if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1398             Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1399                        (unsigned long)SIG_PENDING_DIE_COUNT);
1400     }
1401 }
1402
1403 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1404 void
1405 Perl_csighandler_init(void)
1406 {
1407     int sig;
1408     if (PL_sig_handlers_initted) return;
1409
1410     for (sig = 1; sig < SIG_SIZE; sig++) {
1411 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1412         dTHX;
1413         PL_sig_defaulting[sig] = 1;
1414         (void) rsignal(sig, PL_csighandlerp);
1415 #endif
1416 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1417         PL_sig_ignoring[sig] = 0;
1418 #endif
1419     }
1420     PL_sig_handlers_initted = 1;
1421 }
1422 #endif
1423
1424 #if defined HAS_SIGPROCMASK
1425 static void
1426 unblock_sigmask(pTHX_ void* newset)
1427 {
1428     PERL_UNUSED_CONTEXT;
1429     sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1430 }
1431 #endif
1432
1433 void
1434 Perl_despatch_signals(pTHX)
1435 {
1436     int sig;
1437     PL_sig_pending = 0;
1438     for (sig = 1; sig < SIG_SIZE; sig++) {
1439         if (PL_psig_pend[sig]) {
1440             dSAVE_ERRNO;
1441 #ifdef HAS_SIGPROCMASK
1442             /* From sigaction(2) (FreeBSD man page):
1443              * | Signal routines normally execute with the signal that
1444              * | caused their invocation blocked, but other signals may
1445              * | yet occur.
1446              * Emulation of this behavior (from within Perl) is enabled
1447              * using sigprocmask
1448              */
1449             int was_blocked;
1450             sigset_t newset, oldset;
1451
1452             sigemptyset(&newset);
1453             sigaddset(&newset, sig);
1454             sigprocmask(SIG_BLOCK, &newset, &oldset);
1455             was_blocked = sigismember(&oldset, sig);
1456             if (!was_blocked) {
1457                 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1458                 ENTER;
1459                 SAVEFREESV(save_sv);
1460                 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1461             }
1462 #endif
1463             PL_psig_pend[sig] = 0;
1464 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1465             (*PL_sighandlerp)(sig, NULL, NULL);
1466 #else
1467             (*PL_sighandlerp)(sig);
1468 #endif
1469 #ifdef HAS_SIGPROCMASK
1470             if (!was_blocked)
1471                 LEAVE;
1472 #endif
1473             RESTORE_ERRNO;
1474         }
1475     }
1476 }
1477
1478 /* sv of NULL signifies that we're acting as magic_clearsig.  */
1479 int
1480 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1481 {
1482     dVAR;
1483     I32 i;
1484     SV** svp = NULL;
1485     /* Need to be careful with SvREFCNT_dec(), because that can have side
1486      * effects (due to closures). We must make sure that the new disposition
1487      * is in place before it is called.
1488      */
1489     SV* to_dec = NULL;
1490     STRLEN len;
1491 #ifdef HAS_SIGPROCMASK
1492     sigset_t set, save;
1493     SV* save_sv;
1494 #endif
1495     const char *s = MgPV_const(mg,len);
1496
1497     PERL_ARGS_ASSERT_MAGIC_SETSIG;
1498
1499     if (*s == '_') {
1500         if (memEQs(s, len, "__DIE__"))
1501             svp = &PL_diehook;
1502         else if (memEQs(s, len, "__WARN__")
1503                  && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1504             /* Merge the existing behaviours, which are as follows:
1505                magic_setsig, we always set svp to &PL_warnhook
1506                (hence we always change the warnings handler)
1507                For magic_clearsig, we don't change the warnings handler if it's
1508                set to the &PL_warnhook.  */
1509             svp = &PL_warnhook;
1510         } else if (sv) {
1511             SV *tmp = sv_newmortal();
1512             Perl_croak(aTHX_ "No such hook: %s",
1513                                 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1514         }
1515         i = 0;
1516         if (svp && *svp) {
1517             if (*svp != PERL_WARNHOOK_FATAL)
1518                 to_dec = *svp;
1519             *svp = NULL;
1520         }
1521     }
1522     else {
1523         i = (I16)mg->mg_private;
1524         if (!i) {
1525             i = whichsig_pvn(s, len);   /* ...no, a brick */
1526             mg->mg_private = (U16)i;
1527         }
1528         if (i <= 0) {
1529             if (sv) {
1530                 SV *tmp = sv_newmortal();
1531                 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1532                                             pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1533             }
1534             return 0;
1535         }
1536 #ifdef HAS_SIGPROCMASK
1537         /* Avoid having the signal arrive at a bad time, if possible. */
1538         sigemptyset(&set);
1539         sigaddset(&set,i);
1540         sigprocmask(SIG_BLOCK, &set, &save);
1541         ENTER;
1542         save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1543         SAVEFREESV(save_sv);
1544         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1545 #endif
1546         PERL_ASYNC_CHECK();
1547 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1548         if (!PL_sig_handlers_initted) Perl_csighandler_init();
1549 #endif
1550 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1551         PL_sig_ignoring[i] = 0;
1552 #endif
1553 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1554         PL_sig_defaulting[i] = 0;
1555 #endif
1556         to_dec = PL_psig_ptr[i];
1557         if (sv) {
1558             PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1559             SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1560
1561             /* Signals don't change name during the program's execution, so once
1562                they're cached in the appropriate slot of PL_psig_name, they can
1563                stay there.
1564
1565                Ideally we'd find some way of making SVs at (C) compile time, or
1566                at least, doing most of the work.  */
1567             if (!PL_psig_name[i]) {
1568                 PL_psig_name[i] = newSVpvn(s, len);
1569                 SvREADONLY_on(PL_psig_name[i]);
1570             }
1571         } else {
1572             SvREFCNT_dec(PL_psig_name[i]);
1573             PL_psig_name[i] = NULL;
1574             PL_psig_ptr[i] = NULL;
1575         }
1576     }
1577     if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1578         if (i) {
1579             (void)rsignal(i, PL_csighandlerp);
1580         }
1581         else
1582             *svp = SvREFCNT_inc_simple_NN(sv);
1583     } else {
1584         if (sv && SvOK(sv)) {
1585             s = SvPV_force(sv, len);
1586         } else {
1587             sv = NULL;
1588         }
1589         if (sv && memEQs(s, len,"IGNORE")) {
1590             if (i) {
1591 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1592                 PL_sig_ignoring[i] = 1;
1593                 (void)rsignal(i, PL_csighandlerp);
1594 #else
1595                 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1596 #endif
1597             }
1598         }
1599         else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
1600             if (i) {
1601 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1602                 PL_sig_defaulting[i] = 1;
1603                 (void)rsignal(i, PL_csighandlerp);
1604 #else
1605                 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1606 #endif
1607             }
1608         }
1609         else {
1610             /*
1611              * We should warn if HINT_STRICT_REFS, but without
1612              * access to a known hint bit in a known OP, we can't
1613              * tell whether HINT_STRICT_REFS is in force or not.
1614              */
1615             if (!strchr(s,':') && !strchr(s,'\''))
1616                 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1617                                      SV_GMAGIC);
1618             if (i)
1619                 (void)rsignal(i, PL_csighandlerp);
1620             else
1621                 *svp = SvREFCNT_inc_simple_NN(sv);
1622         }
1623     }
1624
1625 #ifdef HAS_SIGPROCMASK
1626     if(i)
1627         LEAVE;
1628 #endif
1629     SvREFCNT_dec(to_dec);
1630     return 0;
1631 }
1632 #endif /* !PERL_MICRO */
1633
1634 int
1635 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1636 {
1637     PERL_ARGS_ASSERT_MAGIC_SETISA;
1638     PERL_UNUSED_ARG(sv);
1639
1640     /* Skip _isaelem because _isa will handle it shortly */
1641     if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1642         return 0;
1643
1644     return magic_clearisa(NULL, mg);
1645 }
1646
1647 /* sv of NULL signifies that we're acting as magic_setisa.  */
1648 int
1649 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1650 {
1651     HV* stash;
1652     PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1653
1654     /* Bail out if destruction is going on */
1655     if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1656
1657     if (sv)
1658         av_clear(MUTABLE_AV(sv));
1659
1660     if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1661         /* This occurs with setisa_elem magic, which calls this
1662            same function. */
1663         mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1664
1665     assert(mg);
1666     if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1667         SV **svp = AvARRAY((AV *)mg->mg_obj);
1668         I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1669         while (items--) {
1670             stash = GvSTASH((GV *)*svp++);
1671             if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1672         }
1673
1674         return 0;
1675     }
1676
1677     stash = GvSTASH(
1678         (const GV *)mg->mg_obj
1679     );
1680
1681     /* The stash may have been detached from the symbol table, so check its
1682        name before doing anything. */
1683     if (stash && HvENAME_get(stash))
1684         mro_isa_changed_in(stash);
1685
1686     return 0;
1687 }
1688
1689 int
1690 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1691 {
1692     HV * const hv = MUTABLE_HV(LvTARG(sv));
1693     I32 i = 0;
1694
1695     PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1696     PERL_UNUSED_ARG(mg);
1697
1698     if (hv) {
1699          (void) hv_iterinit(hv);
1700          if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1701              i = HvUSEDKEYS(hv);
1702          else {
1703              while (hv_iternext(hv))
1704                  i++;
1705          }
1706     }
1707
1708     sv_setiv(sv, (IV)i);
1709     return 0;
1710 }
1711
1712 int
1713 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1714 {
1715     PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1716     PERL_UNUSED_ARG(mg);
1717     if (LvTARG(sv)) {
1718         hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1719     }
1720     return 0;
1721 }
1722
1723 /*
1724 =for apidoc magic_methcall
1725
1726 Invoke a magic method (like FETCH).
1727
1728 C<sv> and C<mg> are the tied thingy and the tie magic.
1729
1730 C<meth> is the name of the method to call.
1731
1732 C<argc> is the number of args (in addition to $self) to pass to the method.
1733
1734 The C<flags> can be:
1735
1736     G_DISCARD     invoke method with G_DISCARD flag and don't
1737                   return a value
1738     G_UNDEF_FILL  fill the stack with argc pointers to
1739                   PL_sv_undef
1740
1741 The arguments themselves are any values following the C<flags> argument.
1742
1743 Returns the SV (if any) returned by the method, or NULL on failure.
1744
1745
1746 =cut
1747 */
1748
1749 SV*
1750 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1751                     U32 argc, ...)
1752 {
1753     dSP;
1754     SV* ret = NULL;
1755
1756     PERL_ARGS_ASSERT_MAGIC_METHCALL;
1757
1758     ENTER;
1759
1760     if (flags & G_WRITING_TO_STDERR) {
1761         SAVETMPS;
1762
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         const HEK * const hek = gv
3129                         ? GvENAME_HEK(gv)
3130                         : cv && CvNAMED(cv)
3131                            ? CvNAME_HEK(cv)
3132                            : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL;
3133         if (hek)
3134             Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3135                                 "SIG%s handler \"%"HEKf"\" not defined.\n",
3136                                  PL_sig_name[sig], hek);
3137              /* diag_listed_as: SIG%s handler "%s" not defined */
3138         else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3139                            "SIG%s handler \"__ANON__\" not defined.\n",
3140                             PL_sig_name[sig]);
3141         goto cleanup;
3142     }
3143
3144     sv = PL_psig_name[sig]
3145             ? SvREFCNT_inc_NN(PL_psig_name[sig])
3146             : newSVpv(PL_sig_name[sig],0);
3147     flags |= 8;
3148     SAVEFREESV(sv);
3149
3150     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3151         /* make sure our assumption about the size of the SAVEs are correct:
3152          * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3153         assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0)  == PL_savestack_ix);
3154     }
3155
3156     PUSHSTACKi(PERLSI_SIGNAL);
3157     PUSHMARK(SP);
3158     PUSHs(sv);
3159 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3160     {
3161          struct sigaction oact;
3162
3163          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3164               if (sip) {
3165                    HV *sih = newHV();
3166                    SV *rv  = newRV_noinc(MUTABLE_SV(sih));
3167                    /* The siginfo fields signo, code, errno, pid, uid,
3168                     * addr, status, and band are defined by POSIX/SUSv3. */
3169                    (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3170                    (void)hv_stores(sih, "code", newSViv(sip->si_code));
3171 #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. */
3172                    hv_stores(sih, "errno",      newSViv(sip->si_errno));
3173                    hv_stores(sih, "status",     newSViv(sip->si_status));
3174                    hv_stores(sih, "uid",        newSViv(sip->si_uid));
3175                    hv_stores(sih, "pid",        newSViv(sip->si_pid));
3176                    hv_stores(sih, "addr",       newSVuv(PTR2UV(sip->si_addr)));
3177                    hv_stores(sih, "band",       newSViv(sip->si_band));
3178 #endif
3179                    EXTEND(SP, 2);
3180                    PUSHs(rv);
3181                    mPUSHp((char *)sip, sizeof(*sip));
3182               }
3183
3184          }
3185     }
3186 #endif
3187     PUTBACK;
3188
3189     errsv_save = newSVsv(ERRSV);
3190
3191     call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3192
3193     POPSTACK;
3194     {
3195         SV * const errsv = ERRSV;
3196         if (SvTRUE_NN(errsv)) {
3197             SvREFCNT_dec(errsv_save);
3198 #ifndef PERL_MICRO
3199         /* Handler "died", for example to get out of a restart-able read().
3200          * Before we re-do that on its behalf re-enable the signal which was
3201          * blocked by the system when we entered.
3202          */
3203 #ifdef HAS_SIGPROCMASK
3204 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3205             if (sip || uap)
3206 #endif
3207             {
3208                 sigset_t set;
3209                 sigemptyset(&set);
3210                 sigaddset(&set,sig);
3211                 sigprocmask(SIG_UNBLOCK, &set, NULL);
3212             }
3213 #else
3214             /* Not clear if this will work */
3215             (void)rsignal(sig, SIG_IGN);
3216             (void)rsignal(sig, PL_csighandlerp);
3217 #endif
3218 #endif /* !PERL_MICRO */
3219             die_sv(errsv);
3220         }
3221         else {
3222             sv_setsv(errsv, errsv_save);
3223             SvREFCNT_dec(errsv_save);
3224         }
3225     }
3226
3227 cleanup:
3228     /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3229     PL_savestack_ix = old_ss_ix;
3230     if (flags & 8)
3231         SvREFCNT_dec_NN(sv);
3232     PL_op = myop;                       /* Apparently not needed... */
3233
3234     PL_Sv = tSv;                        /* Restore global temporaries. */
3235     PL_Xpv = tXpv;
3236     return;
3237 }
3238
3239
3240 static void
3241 S_restore_magic(pTHX_ const void *p)
3242 {
3243     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3244     SV* const sv = mgs->mgs_sv;
3245     bool bumped;
3246
3247     if (!sv)
3248         return;
3249
3250     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3251         SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3252 #ifdef PERL_OLD_COPY_ON_WRITE
3253         /* While magic was saved (and off) sv_setsv may well have seen
3254            this SV as a prime candidate for COW.  */
3255         if (SvIsCOW(sv))
3256             sv_force_normal_flags(sv, 0);
3257 #endif
3258         if (mgs->mgs_flags)
3259             SvFLAGS(sv) |= mgs->mgs_flags;
3260         else
3261             mg_magical(sv);
3262     }
3263
3264     bumped = mgs->mgs_bumped;
3265     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
3266
3267     /* If we're still on top of the stack, pop us off.  (That condition
3268      * will be satisfied if restore_magic was called explicitly, but *not*
3269      * if it's being called via leave_scope.)
3270      * The reason for doing this is that otherwise, things like sv_2cv()
3271      * may leave alloc gunk on the savestack, and some code
3272      * (e.g. sighandler) doesn't expect that...
3273      */
3274     if (PL_savestack_ix == mgs->mgs_ss_ix)
3275     {
3276         UV popval = SSPOPUV;
3277         assert(popval == SAVEt_DESTRUCTOR_X);
3278         PL_savestack_ix -= 2;
3279         popval = SSPOPUV;
3280         assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3281         PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3282     }
3283     if (bumped) {
3284         if (SvREFCNT(sv) == 1) {
3285             /* We hold the last reference to this SV, which implies that the
3286                SV was deleted as a side effect of the routines we called.
3287                So artificially keep it alive a bit longer.
3288                We avoid turning on the TEMP flag, which can cause the SV's
3289                buffer to get stolen (and maybe other stuff). */
3290             sv_2mortal(sv);
3291             SvTEMP_off(sv);
3292         }
3293         else
3294             SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
3295     }
3296 }
3297
3298 /* clean up the mess created by Perl_sighandler().
3299  * Note that this is only called during an exit in a signal handler;
3300  * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3301  * skipped over. */
3302
3303 static void
3304 S_unwind_handler_stack(pTHX_ const void *p)
3305 {
3306     PERL_UNUSED_ARG(p);
3307
3308     PL_savestack_ix -= 5; /* Unprotect save in progress. */
3309 }
3310
3311 /*
3312 =for apidoc magic_sethint
3313
3314 Triggered by a store to %^H, records the key/value pair to
3315 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
3316 anything that would need a deep copy.  Maybe we should warn if we find a
3317 reference.
3318
3319 =cut
3320 */
3321 int
3322 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3323 {
3324     SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3325         : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3326
3327     PERL_ARGS_ASSERT_MAGIC_SETHINT;
3328
3329     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
3330        an alternative leaf in there, with PL_compiling.cop_hints being used if
3331        it's NULL. If needed for threads, the alternative could lock a mutex,
3332        or take other more complex action.  */
3333
3334     /* Something changed in %^H, so it will need to be restored on scope exit.
3335        Doing this here saves a lot of doing it manually in perl code (and
3336        forgetting to do it, and consequent subtle errors.  */
3337     PL_hints |= HINT_LOCALIZE_HH;
3338     CopHINTHASH_set(&PL_compiling,
3339         cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3340     return 0;
3341 }
3342
3343 /*
3344 =for apidoc magic_clearhint
3345
3346 Triggered by a delete from %^H, records the key to
3347 C<PL_compiling.cop_hints_hash>.
3348
3349 =cut
3350 */
3351 int
3352 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3353 {
3354     PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3355     PERL_UNUSED_ARG(sv);
3356
3357     PL_hints |= HINT_LOCALIZE_HH;
3358     CopHINTHASH_set(&PL_compiling,
3359         mg->mg_len == HEf_SVKEY
3360          ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3361                                  MUTABLE_SV(mg->mg_ptr), 0, 0)
3362          : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3363                                  mg->mg_ptr, mg->mg_len, 0, 0));
3364     return 0;
3365 }
3366
3367 /*
3368 =for apidoc magic_clearhints
3369
3370 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3371
3372 =cut
3373 */
3374 int
3375 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3376 {
3377     PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3378     PERL_UNUSED_ARG(sv);
3379     PERL_UNUSED_ARG(mg);
3380     cophh_free(CopHINTHASH_get(&PL_compiling));
3381     CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3382     return 0;
3383 }
3384
3385 int
3386 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3387                                  const char *name, I32 namlen)
3388 {
3389     MAGIC *nmg;
3390
3391     PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3392     PERL_UNUSED_ARG(sv);
3393     PERL_UNUSED_ARG(name);
3394     PERL_UNUSED_ARG(namlen);
3395
3396     sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3397     nmg = mg_find(nsv, mg->mg_type);
3398     assert(nmg);
3399     if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3400     nmg->mg_ptr = mg->mg_ptr;
3401     nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3402     nmg->mg_flags |= MGf_REFCOUNTED;
3403     return 1;
3404 }
3405
3406 /*
3407  * Local variables:
3408  * c-indentation-style: bsd
3409  * c-basic-offset: 4
3410  * indent-tabs-mode: nil
3411  * End:
3412  *
3413  * ex: set ts=8 sts=4 sw=4 et:
3414  */