mg.c

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