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