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