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