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