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 && 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, arg1, arg2 are the number of args (in addition to $self) to pass to
1655   the method, and the args themselves
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                    ignore arg1 and arg2.
1660
1661 Returns the SV (if any) returned by the method, or NULL on failure.
1662
1663
1664 =cut
1665 */
1666
1667 SV*
1668 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1669                     U32 argc, ...)
1670 {
1671     dVAR;
1672     dSP;
1673     SV* ret = NULL;
1674
1675     PERL_ARGS_ASSERT_MAGIC_METHCALL;
1676
1677     ENTER;
1678     PUSHSTACKi(PERLSI_MAGIC);
1679     PUSHMARK(SP);
1680
1681     EXTEND(SP, argc+1);
1682     PUSHs(SvTIED_obj(sv, mg));
1683     if (flags & G_UNDEF_FILL) {
1684         while (argc--) {
1685             PUSHs(&PL_sv_undef);
1686         }
1687     } else if (argc > 0) {
1688         va_list args;
1689         va_start(args, argc);
1690
1691         do {
1692             SV *const sv = va_arg(args, SV *);
1693             PUSHs(sv);
1694         } while (--argc);
1695
1696         va_end(args);
1697     }
1698     PUTBACK;
1699     if (flags & G_DISCARD) {
1700         call_method(meth, G_SCALAR|G_DISCARD);
1701     }
1702     else {
1703         if (call_method(meth, G_SCALAR))
1704             ret = *PL_stack_sp--;
1705     }
1706     POPSTACK;
1707     LEAVE;
1708     return ret;
1709 }
1710
1711
1712 /* wrapper for magic_methcall that creates the first arg */
1713
1714 STATIC SV*
1715 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1716     int n, SV *val)
1717 {
1718     dVAR;
1719     SV* arg1 = NULL;
1720
1721     PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1722
1723     if (mg->mg_ptr) {
1724         if (mg->mg_len >= 0) {
1725             arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1726         }
1727         else if (mg->mg_len == HEf_SVKEY)
1728             arg1 = MUTABLE_SV(mg->mg_ptr);
1729     }
1730     else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1731         arg1 = newSViv((IV)(mg->mg_len));
1732         sv_2mortal(arg1);
1733     }
1734     if (!arg1) {
1735         return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1736     }
1737     return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1738 }
1739
1740 STATIC int
1741 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1742 {
1743     dVAR;
1744     SV* ret;
1745
1746     PERL_ARGS_ASSERT_MAGIC_METHPACK;
1747
1748     ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1749     if (ret)
1750         sv_setsv(sv, ret);
1751     return 0;
1752 }
1753
1754 int
1755 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1756 {
1757     PERL_ARGS_ASSERT_MAGIC_GETPACK;
1758
1759     if (mg->mg_type == PERL_MAGIC_tiedelem)
1760         mg->mg_flags |= MGf_GSKIP;
1761     magic_methpack(sv,mg,"FETCH");
1762     return 0;
1763 }
1764
1765 int
1766 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1767 {
1768     dVAR;
1769     MAGIC *tmg;
1770     SV    *val;
1771
1772     PERL_ARGS_ASSERT_MAGIC_SETPACK;
1773
1774     /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1775      * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1776      * public flags indicate its value based on copying from $val. Doing
1777      * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1778      * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1779      * wrong if $val happened to be tainted, as sv hasn't got magic
1780      * enabled, even though taint magic is in the chain. In which case,
1781      * fake up a temporary tainted value (this is easier than temporarily
1782      * re-enabling magic on sv). */
1783
1784     if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
1785         && (tmg->mg_len & 1))
1786     {
1787         val = sv_mortalcopy(sv);
1788         SvTAINTED_on(val);
1789     }
1790     else
1791         val = sv;
1792
1793     magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
1794     return 0;
1795 }
1796
1797 int
1798 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1799 {
1800     PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1801
1802     return magic_methpack(sv,mg,"DELETE");
1803 }
1804
1805
1806 U32
1807 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1808 {
1809     dVAR;
1810     I32 retval = 0;
1811     SV* retsv;
1812
1813     PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1814
1815     retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
1816     if (retsv) {
1817         retval = SvIV(retsv)-1;
1818         if (retval < -1)
1819             Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1820     }
1821     return (U32) retval;
1822 }
1823
1824 int
1825 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1826 {
1827     dVAR;
1828
1829     PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1830
1831     Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
1832     return 0;
1833 }
1834
1835 int
1836 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1837 {
1838     dVAR;
1839     SV* ret;
1840
1841     PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1842
1843     ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
1844         : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
1845     if (ret)
1846         sv_setsv(key,ret);
1847     return 0;
1848 }
1849
1850 int
1851 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1852 {
1853     PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1854
1855     return magic_methpack(sv,mg,"EXISTS");
1856 }
1857
1858 SV *
1859 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1860 {
1861     dVAR;
1862     SV *retval;
1863     SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1864     HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1865
1866     PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1867
1868     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1869         SV *key;
1870         if (HvEITER_get(hv))
1871             /* we are in an iteration so the hash cannot be empty */
1872             return &PL_sv_yes;
1873         /* no xhv_eiter so now use FIRSTKEY */
1874         key = sv_newmortal();
1875         magic_nextpack(MUTABLE_SV(hv), mg, key);
1876         HvEITER_set(hv, NULL);     /* need to reset iterator */
1877         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1878     }
1879
1880     /* there is a SCALAR method that we can call */
1881     retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
1882     if (!retval)
1883         retval = &PL_sv_undef;
1884     return retval;
1885 }
1886
1887 int
1888 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1889 {
1890     dVAR;
1891     GV * const gv = PL_DBline;
1892     const I32 i = SvTRUE(sv);
1893     SV ** const svp = av_fetch(GvAV(gv),
1894                      atoi(MgPV_nolen_const(mg)), FALSE);
1895
1896     PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1897
1898     if (svp && SvIOKp(*svp)) {
1899         OP * const o = INT2PTR(OP*,SvIVX(*svp));
1900         if (o) {
1901             /* set or clear breakpoint in the relevant control op */
1902             if (i)
1903                 o->op_flags |= OPf_SPECIAL;
1904             else
1905                 o->op_flags &= ~OPf_SPECIAL;
1906         }
1907     }
1908     return 0;
1909 }
1910
1911 int
1912 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1913 {
1914     dVAR;
1915     AV * const obj = MUTABLE_AV(mg->mg_obj);
1916
1917     PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1918
1919     if (obj) {
1920         sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1921     } else {
1922         SvOK_off(sv);
1923     }
1924     return 0;
1925 }
1926
1927 int
1928 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1929 {
1930     dVAR;
1931     AV * const obj = MUTABLE_AV(mg->mg_obj);
1932
1933     PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1934
1935     if (obj) {
1936         av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1937     } else {
1938         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1939                        "Attempt to set length of freed array");
1940     }
1941     return 0;
1942 }
1943
1944 int
1945 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1946 {
1947     dVAR;
1948
1949     PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
1950     PERL_UNUSED_ARG(sv);
1951
1952     /* during global destruction, mg_obj may already have been freed */
1953     if (PL_in_clean_all)
1954         return 0;
1955
1956     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1957
1958     if (mg) {
1959         /* arylen scalar holds a pointer back to the array, but doesn't own a
1960            reference. Hence the we (the array) are about to go away with it
1961            still pointing at us. Clear its pointer, else it would be pointing
1962            at free memory. See the comment in sv_magic about reference loops,
1963            and why it can't own a reference to us.  */
1964         mg->mg_obj = 0;
1965     }
1966     return 0;
1967 }
1968
1969 int
1970 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1971 {
1972     dVAR;
1973     SV* const lsv = LvTARG(sv);
1974
1975     PERL_ARGS_ASSERT_MAGIC_GETPOS;
1976     PERL_UNUSED_ARG(mg);
1977
1978     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1979         MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1980         if (found && found->mg_len >= 0) {
1981             I32 i = found->mg_len;
1982             if (DO_UTF8(lsv))
1983                 sv_pos_b2u(lsv, &i);
1984             sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1985             return 0;
1986         }
1987     }
1988     SvOK_off(sv);
1989     return 0;
1990 }
1991
1992 int
1993 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1994 {
1995     dVAR;
1996     SV* const lsv = LvTARG(sv);
1997     SSize_t pos;
1998     STRLEN len;
1999     STRLEN ulen = 0;
2000     MAGIC* found;
2001
2002     PERL_ARGS_ASSERT_MAGIC_SETPOS;
2003     PERL_UNUSED_ARG(mg);
2004
2005     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2006         found = mg_find(lsv, PERL_MAGIC_regex_global);
2007     else
2008         found = NULL;
2009     if (!found) {
2010         if (!SvOK(sv))
2011             return 0;
2012 #ifdef PERL_OLD_COPY_ON_WRITE
2013     if (SvIsCOW(lsv))
2014         sv_force_normal_flags(lsv, 0);
2015 #endif
2016         found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2017                             NULL, 0);
2018     }
2019     else if (!SvOK(sv)) {
2020         found->mg_len = -1;
2021         return 0;
2022     }
2023     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2024
2025     pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
2026
2027     if (DO_UTF8(lsv)) {
2028         ulen = sv_len_utf8(lsv);
2029         if (ulen)
2030             len = ulen;
2031     }
2032
2033     if (pos < 0) {
2034         pos += len;
2035         if (pos < 0)
2036             pos = 0;
2037     }
2038     else if (pos > (SSize_t)len)
2039         pos = len;
2040
2041     if (ulen) {
2042         I32 p = pos;
2043         sv_pos_u2b(lsv, &p, 0);
2044         pos = p;
2045     }
2046
2047     found->mg_len = pos;
2048     found->mg_flags &= ~MGf_MINMATCH;
2049
2050     return 0;
2051 }
2052
2053 int
2054 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2055 {
2056     STRLEN len;
2057     SV * const lsv = LvTARG(sv);
2058     const char * const tmps = SvPV_const(lsv,len);
2059     STRLEN offs = LvTARGOFF(sv);
2060     STRLEN rem = LvTARGLEN(sv);
2061
2062     PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2063     PERL_UNUSED_ARG(mg);
2064
2065     if (SvUTF8(lsv))
2066         offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
2067     if (offs > len)
2068         offs = len;
2069     if (rem > len - offs)
2070         rem = len - offs;
2071     sv_setpvn(sv, tmps + offs, rem);
2072     if (SvUTF8(lsv))
2073         SvUTF8_on(sv);
2074     return 0;
2075 }
2076
2077 int
2078 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2079 {
2080     dVAR;
2081     STRLEN len;
2082     const char * const tmps = SvPV_const(sv, len);
2083     SV * const lsv = LvTARG(sv);
2084     STRLEN lvoff = LvTARGOFF(sv);
2085     STRLEN lvlen = LvTARGLEN(sv);
2086
2087     PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2088     PERL_UNUSED_ARG(mg);
2089
2090     if (DO_UTF8(sv)) {
2091         sv_utf8_upgrade(lsv);
2092         lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2093         sv_insert(lsv, lvoff, lvlen, tmps, len);
2094         LvTARGLEN(sv) = sv_len_utf8(sv);
2095         SvUTF8_on(lsv);
2096     }
2097     else if (lsv && SvUTF8(lsv)) {
2098         const char *utf8;
2099         lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2100         LvTARGLEN(sv) = len;
2101         utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2102         sv_insert(lsv, lvoff, lvlen, utf8, len);
2103         Safefree(utf8);
2104     }
2105     else {
2106         sv_insert(lsv, lvoff, lvlen, tmps, len);
2107         LvTARGLEN(sv) = len;
2108     }
2109
2110     return 0;
2111 }
2112
2113 int
2114 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2115 {
2116     dVAR;
2117
2118     PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2119     PERL_UNUSED_ARG(sv);
2120
2121     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2122     return 0;
2123 }
2124
2125 int
2126 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2127 {
2128     dVAR;
2129
2130     PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2131     PERL_UNUSED_ARG(sv);
2132
2133     /* update taint status */
2134     if (PL_tainted)
2135         mg->mg_len |= 1;
2136     else
2137         mg->mg_len &= ~1;
2138     return 0;
2139 }
2140
2141 int
2142 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2143 {
2144     SV * const lsv = LvTARG(sv);
2145
2146     PERL_ARGS_ASSERT_MAGIC_GETVEC;
2147     PERL_UNUSED_ARG(mg);
2148
2149     if (lsv)
2150         sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2151     else
2152         SvOK_off(sv);
2153
2154     return 0;
2155 }
2156
2157 int
2158 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2159 {
2160     PERL_ARGS_ASSERT_MAGIC_SETVEC;
2161     PERL_UNUSED_ARG(mg);
2162     do_vecset(sv);      /* XXX slurp this routine */
2163     return 0;
2164 }
2165
2166 int
2167 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2168 {
2169     dVAR;
2170     SV *targ = NULL;
2171
2172     PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2173
2174     if (LvTARGLEN(sv)) {
2175         if (mg->mg_obj) {
2176             SV * const ahv = LvTARG(sv);
2177             HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2178             if (he)
2179                 targ = HeVAL(he);
2180         }
2181         else {
2182             AV *const av = MUTABLE_AV(LvTARG(sv));
2183             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2184                 targ = AvARRAY(av)[LvTARGOFF(sv)];
2185         }
2186         if (targ && (targ != &PL_sv_undef)) {
2187             /* somebody else defined it for us */
2188             SvREFCNT_dec(LvTARG(sv));
2189             LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2190             LvTARGLEN(sv) = 0;
2191             SvREFCNT_dec(mg->mg_obj);
2192             mg->mg_obj = NULL;
2193             mg->mg_flags &= ~MGf_REFCOUNTED;
2194         }
2195     }
2196     else
2197         targ = LvTARG(sv);
2198     sv_setsv(sv, targ ? targ : &PL_sv_undef);
2199     return 0;
2200 }
2201
2202 int
2203 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2204 {
2205     PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2206     PERL_UNUSED_ARG(mg);
2207     if (LvTARGLEN(sv))
2208         vivify_defelem(sv);
2209     if (LvTARG(sv)) {
2210         sv_setsv(LvTARG(sv), sv);
2211         SvSETMAGIC(LvTARG(sv));
2212     }
2213     return 0;
2214 }
2215
2216 void
2217 Perl_vivify_defelem(pTHX_ SV *sv)
2218 {
2219     dVAR;
2220     MAGIC *mg;
2221     SV *value = NULL;
2222
2223     PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2224
2225     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2226         return;
2227     if (mg->mg_obj) {
2228         SV * const ahv = LvTARG(sv);
2229         HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2230         if (he)
2231             value = HeVAL(he);
2232         if (!value || value == &PL_sv_undef)
2233             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2234     }
2235     else {
2236         AV *const av = MUTABLE_AV(LvTARG(sv));
2237         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2238             LvTARG(sv) = NULL;  /* array can't be extended */
2239         else {
2240             SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2241             if (!svp || (value = *svp) == &PL_sv_undef)
2242                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2243         }
2244     }
2245     SvREFCNT_inc_simple_void(value);
2246     SvREFCNT_dec(LvTARG(sv));
2247     LvTARG(sv) = value;
2248     LvTARGLEN(sv) = 0;
2249     SvREFCNT_dec(mg->mg_obj);
2250     mg->mg_obj = NULL;
2251     mg->mg_flags &= ~MGf_REFCOUNTED;
2252 }
2253
2254 int
2255 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2256 {
2257     PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2258     return Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2259 }
2260
2261 int
2262 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2263 {
2264     PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2265     PERL_UNUSED_CONTEXT;
2266     mg->mg_len = -1;
2267     if (!isGV_with_GP(sv))
2268         SvSCREAM_off(sv);
2269     return 0;
2270 }
2271
2272 int
2273 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2274 {
2275     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2276
2277     PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2278
2279     if (uf && uf->uf_set)
2280         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2281     return 0;
2282 }
2283
2284 int
2285 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2286 {
2287     const char type = mg->mg_type;
2288
2289     PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2290
2291     if (type == PERL_MAGIC_qr) {
2292     } else if (type == PERL_MAGIC_bm) {
2293         SvTAIL_off(sv);
2294         SvVALID_off(sv);
2295     } else {
2296         assert(type == PERL_MAGIC_fm);
2297         SvCOMPILED_off(sv);
2298     }
2299     return sv_unmagic(sv, type);
2300 }
2301
2302 #ifdef USE_LOCALE_COLLATE
2303 int
2304 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2305 {
2306     PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2307
2308     /*
2309      * RenE<eacute> Descartes said "I think not."
2310      * and vanished with a faint plop.
2311      */
2312     PERL_UNUSED_CONTEXT;
2313     PERL_UNUSED_ARG(sv);
2314     if (mg->mg_ptr) {
2315         Safefree(mg->mg_ptr);
2316         mg->mg_ptr = NULL;
2317         mg->mg_len = -1;
2318     }
2319     return 0;
2320 }
2321 #endif /* USE_LOCALE_COLLATE */
2322
2323 /* Just clear the UTF-8 cache data. */
2324 int
2325 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2326 {
2327     PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2328     PERL_UNUSED_CONTEXT;
2329     PERL_UNUSED_ARG(sv);
2330     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2331     mg->mg_ptr = NULL;
2332     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2333     return 0;
2334 }
2335
2336 int
2337 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2338 {
2339     dVAR;
2340     register const char *s;
2341     register I32 paren;
2342     register const REGEXP * rx;
2343     const char * const remaining = mg->mg_ptr + 1;
2344     I32 i;
2345     STRLEN len;
2346
2347     PERL_ARGS_ASSERT_MAGIC_SET;
2348
2349     switch (*mg->mg_ptr) {
2350     case '\015': /* $^MATCH */
2351       if (strEQ(remaining, "ATCH"))
2352           goto do_match;
2353     case '`': /* ${^PREMATCH} caught below */
2354       do_prematch:
2355       paren = RX_BUFF_IDX_PREMATCH;
2356       goto setparen;
2357     case '\'': /* ${^POSTMATCH} caught below */
2358       do_postmatch:
2359       paren = RX_BUFF_IDX_POSTMATCH;
2360       goto setparen;
2361     case '&':
2362       do_match:
2363       paren = RX_BUFF_IDX_FULLMATCH;
2364       goto setparen;
2365     case '1': case '2': case '3': case '4':
2366     case '5': case '6': case '7': case '8': case '9':
2367       paren = atoi(mg->mg_ptr);
2368       setparen:
2369         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2370             CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2371             break;
2372         } else {
2373             /* Croak with a READONLY error when a numbered match var is
2374              * set without a previous pattern match. Unless it's C<local $1>
2375              */
2376             if (!PL_localizing) {
2377                 Perl_croak(aTHX_ "%s", PL_no_modify);
2378             }
2379         }
2380     case '\001':        /* ^A */
2381         sv_setsv(PL_bodytarget, sv);
2382         break;
2383     case '\003':        /* ^C */
2384         PL_minus_c = cBOOL(SvIV(sv));
2385         break;
2386
2387     case '\004':        /* ^D */
2388 #ifdef DEBUGGING
2389         s = SvPV_nolen_const(sv);
2390         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2391         if (DEBUG_x_TEST || DEBUG_B_TEST)
2392             dump_all_perl(!DEBUG_B_TEST);
2393 #else
2394         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2395 #endif
2396         break;
2397     case '\005':  /* ^E */
2398         if (*(mg->mg_ptr+1) == '\0') {
2399 #ifdef VMS
2400             set_vaxc_errno(SvIV(sv));
2401 #else
2402 #  ifdef WIN32
2403             SetLastError( SvIV(sv) );
2404 #  else
2405 #    ifdef OS2
2406             os2_setsyserrno(SvIV(sv));
2407 #    else
2408             /* will anyone ever use this? */
2409             SETERRNO(SvIV(sv), 4);
2410 #    endif
2411 #  endif
2412 #endif
2413         }
2414         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2415             SvREFCNT_dec(PL_encoding);
2416             if (SvOK(sv) || SvGMAGICAL(sv)) {
2417                 PL_encoding = newSVsv(sv);
2418             }
2419             else {
2420                 PL_encoding = NULL;
2421             }
2422         }
2423         break;
2424     case '\006':        /* ^F */
2425         PL_maxsysfd = SvIV(sv);
2426         break;
2427     case '\010':        /* ^H */
2428         PL_hints = SvIV(sv);
2429         break;
2430     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2431         Safefree(PL_inplace);
2432         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2433         break;
2434     case '\017':        /* ^O */
2435         if (*(mg->mg_ptr+1) == '\0') {
2436             Safefree(PL_osname);
2437             PL_osname = NULL;
2438             if (SvOK(sv)) {
2439                 TAINT_PROPER("assigning to $^O");
2440                 PL_osname = savesvpv(sv);
2441             }
2442         }
2443         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2444             STRLEN len;
2445             const char *const start = SvPV(sv, len);
2446             const char *out = (const char*)memchr(start, '\0', len);
2447             SV *tmp;
2448
2449
2450             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2451             PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2452
2453             /* Opening for input is more common than opening for output, so
2454                ensure that hints for input are sooner on linked list.  */
2455             tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2456                                        SvUTF8(sv))
2457                 : newSVpvs_flags("", SvUTF8(sv));
2458             (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2459             mg_set(tmp);
2460
2461             tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2462                                         SvUTF8(sv));
2463             (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2464             mg_set(tmp);
2465         }
2466         break;
2467     case '\020':        /* ^P */
2468       if (*remaining == '\0') { /* ^P */
2469           PL_perldb = SvIV(sv);
2470           if (PL_perldb && !PL_DBsingle)
2471               init_debugger();
2472           break;
2473       } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2474           goto do_prematch;
2475       } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2476           goto do_postmatch;
2477       }
2478     case '\024':        /* ^T */
2479 #ifdef BIG_TIME
2480         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2481 #else
2482         PL_basetime = (Time_t)SvIV(sv);
2483 #endif
2484         break;
2485     case '\025':        /* ^UTF8CACHE */
2486          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2487              PL_utf8cache = (signed char) sv_2iv(sv);
2488          }
2489          break;
2490     case '\027':        /* ^W & $^WARNING_BITS */
2491         if (*(mg->mg_ptr+1) == '\0') {
2492             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2493                 i = SvIV(sv);
2494                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2495                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2496             }
2497         }
2498         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2499             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2500                 if (!SvPOK(sv) && PL_localizing) {
2501                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2502                     PL_compiling.cop_warnings = pWARN_NONE;
2503                     break;
2504                 }
2505                 {
2506                     STRLEN len, i;
2507                     int accumulate = 0 ;
2508                     int any_fatals = 0 ;
2509                     const char * const ptr = SvPV_const(sv, len) ;
2510                     for (i = 0 ; i < len ; ++i) {
2511                         accumulate |= ptr[i] ;
2512                         any_fatals |= (ptr[i] & 0xAA) ;
2513                     }
2514                     if (!accumulate) {
2515                         if (!specialWARN(PL_compiling.cop_warnings))
2516                             PerlMemShared_free(PL_compiling.cop_warnings);
2517                         PL_compiling.cop_warnings = pWARN_NONE;
2518                     }
2519                     /* Yuck. I can't see how to abstract this:  */
2520                     else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2521                                        WARN_ALL) && !any_fatals) {
2522                         if (!specialWARN(PL_compiling.cop_warnings))
2523                             PerlMemShared_free(PL_compiling.cop_warnings);
2524                         PL_compiling.cop_warnings = pWARN_ALL;
2525                         PL_dowarn |= G_WARN_ONCE ;
2526                     }
2527                     else {
2528                         STRLEN len;
2529                         const char *const p = SvPV_const(sv, len);
2530
2531                         PL_compiling.cop_warnings
2532                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2533                                                          p, len);
2534
2535                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2536                             PL_dowarn |= G_WARN_ONCE ;
2537                     }
2538
2539                 }
2540             }
2541         }
2542         break;
2543     case '.':
2544         if (PL_localizing) {
2545             if (PL_localizing == 1)
2546                 SAVESPTR(PL_last_in_gv);
2547         }
2548         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2549             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2550         break;
2551     case '^':
2552         if (isGV_with_GP(PL_defoutgv)) {
2553             Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2554             s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2555             IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2556         }
2557         break;
2558     case '~':
2559         if (isGV_with_GP(PL_defoutgv)) {
2560             Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2561             s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2562             IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2563         }
2564         break;
2565     case '=':
2566         if (isGV_with_GP(PL_defoutgv))
2567             IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2568         break;
2569     case '-':
2570         if (isGV_with_GP(PL_defoutgv)) {
2571             IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2572             if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2573                 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2574         }
2575         break;
2576     case '%':
2577         if (isGV_with_GP(PL_defoutgv))
2578             IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2579         break;
2580     case '|':
2581         {
2582             IO * const io = GvIO(PL_defoutgv);
2583             if(!io)
2584               break;
2585             if ((SvIV(sv)) == 0)
2586                 IoFLAGS(io) &= ~IOf_FLUSH;
2587             else {
2588                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2589                     PerlIO *ofp = IoOFP(io);
2590                     if (ofp)
2591                         (void)PerlIO_flush(ofp);
2592                     IoFLAGS(io) |= IOf_FLUSH;
2593                 }
2594             }
2595         }
2596         break;
2597     case '/':
2598         SvREFCNT_dec(PL_rs);
2599         PL_rs = newSVsv(sv);
2600         break;
2601     case '\\':
2602         SvREFCNT_dec(PL_ors_sv);
2603         if (SvOK(sv) || SvGMAGICAL(sv)) {
2604             PL_ors_sv = newSVsv(sv);
2605         }
2606         else {
2607             PL_ors_sv = NULL;
2608         }
2609         break;
2610     case '[':
2611         CopARYBASE_set(&PL_compiling, SvIV(sv));
2612         break;
2613     case '?':
2614 #ifdef COMPLEX_STATUS
2615         if (PL_localizing == 2) {
2616             SvUPGRADE(sv, SVt_PVLV);
2617             PL_statusvalue = LvTARGOFF(sv);
2618             PL_statusvalue_vms = LvTARGLEN(sv);
2619         }
2620         else
2621 #endif
2622 #ifdef VMSISH_STATUS
2623         if (VMSISH_STATUS)
2624             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2625         else
2626 #endif
2627             STATUS_UNIX_EXIT_SET(SvIV(sv));
2628         break;
2629     case '!':
2630         {
2631 #ifdef VMS
2632 #   define PERL_VMS_BANG vaxc$errno
2633 #else
2634 #   define PERL_VMS_BANG 0
2635 #endif
2636         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2637                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2638         }
2639         break;
2640     case '<':
2641         PL_uid = SvIV(sv);
2642         if (PL_delaymagic) {
2643             PL_delaymagic |= DM_RUID;
2644             break;                              /* don't do magic till later */
2645         }
2646 #ifdef HAS_SETRUID
2647         (void)setruid((Uid_t)PL_uid);
2648 #else
2649 #ifdef HAS_SETREUID
2650         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2651 #else
2652 #ifdef HAS_SETRESUID
2653       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2654 #else
2655         if (PL_uid == PL_euid) {                /* special case $< = $> */
2656 #ifdef PERL_DARWIN
2657             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2658             if (PL_uid != 0 && PerlProc_getuid() == 0)
2659                 (void)PerlProc_setuid(0);
2660 #endif
2661             (void)PerlProc_setuid(PL_uid);
2662         } else {
2663             PL_uid = PerlProc_getuid();
2664             Perl_croak(aTHX_ "setruid() not implemented");
2665         }
2666 #endif
2667 #endif
2668 #endif
2669         PL_uid = PerlProc_getuid();
2670         break;
2671     case '>':
2672         PL_euid = SvIV(sv);
2673         if (PL_delaymagic) {
2674             PL_delaymagic |= DM_EUID;
2675             break;                              /* don't do magic till later */
2676         }
2677 #ifdef HAS_SETEUID
2678         (void)seteuid((Uid_t)PL_euid);
2679 #else
2680 #ifdef HAS_SETREUID
2681         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2682 #else
2683 #ifdef HAS_SETRESUID
2684         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2685 #else
2686         if (PL_euid == PL_uid)          /* special case $> = $< */
2687             PerlProc_setuid(PL_euid);
2688         else {
2689             PL_euid = PerlProc_geteuid();
2690             Perl_croak(aTHX_ "seteuid() not implemented");
2691         }
2692 #endif
2693 #endif
2694 #endif
2695         PL_euid = PerlProc_geteuid();
2696         break;
2697     case '(':
2698         PL_gid = SvIV(sv);
2699         if (PL_delaymagic) {
2700             PL_delaymagic |= DM_RGID;
2701             break;                              /* don't do magic till later */
2702         }
2703 #ifdef HAS_SETRGID
2704         (void)setrgid((Gid_t)PL_gid);
2705 #else
2706 #ifdef HAS_SETREGID
2707         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2708 #else
2709 #ifdef HAS_SETRESGID
2710       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2711 #else
2712         if (PL_gid == PL_egid)                  /* special case $( = $) */
2713             (void)PerlProc_setgid(PL_gid);
2714         else {
2715             PL_gid = PerlProc_getgid();
2716             Perl_croak(aTHX_ "setrgid() not implemented");
2717         }
2718 #endif
2719 #endif
2720 #endif
2721         PL_gid = PerlProc_getgid();
2722         break;
2723     case ')':
2724 #ifdef HAS_SETGROUPS
2725         {
2726             const char *p = SvPV_const(sv, len);
2727             Groups_t *gary = NULL;
2728 #ifdef _SC_NGROUPS_MAX
2729            int maxgrp = sysconf(_SC_NGROUPS_MAX);
2730
2731            if (maxgrp < 0)
2732                maxgrp = NGROUPS;
2733 #else
2734            int maxgrp = NGROUPS;
2735 #endif
2736
2737             while (isSPACE(*p))
2738                 ++p;
2739             PL_egid = Atol(p);
2740             for (i = 0; i < maxgrp; ++i) {
2741                 while (*p && !isSPACE(*p))
2742                     ++p;
2743                 while (isSPACE(*p))
2744                     ++p;
2745                 if (!*p)
2746                     break;
2747                 if(!gary)
2748                     Newx(gary, i + 1, Groups_t);
2749                 else
2750                     Renew(gary, i + 1, Groups_t);
2751                 gary[i] = Atol(p);
2752             }
2753             if (i)
2754                 (void)setgroups(i, gary);
2755             Safefree(gary);
2756         }
2757 #else  /* HAS_SETGROUPS */
2758         PL_egid = SvIV(sv);
2759 #endif /* HAS_SETGROUPS */
2760         if (PL_delaymagic) {
2761             PL_delaymagic |= DM_EGID;
2762             break;                              /* don't do magic till later */
2763         }
2764 #ifdef HAS_SETEGID
2765         (void)setegid((Gid_t)PL_egid);
2766 #else
2767 #ifdef HAS_SETREGID
2768         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2769 #else
2770 #ifdef HAS_SETRESGID
2771         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2772 #else
2773         if (PL_egid == PL_gid)                  /* special case $) = $( */
2774             (void)PerlProc_setgid(PL_egid);
2775         else {
2776             PL_egid = PerlProc_getegid();
2777             Perl_croak(aTHX_ "setegid() not implemented");
2778         }
2779 #endif
2780 #endif
2781 #endif
2782         PL_egid = PerlProc_getegid();
2783         break;
2784     case ':':
2785         PL_chopset = SvPV_force(sv,len);
2786         break;
2787     case '0':
2788         LOCK_DOLLARZERO_MUTEX;
2789 #ifdef HAS_SETPROCTITLE
2790         /* The BSDs don't show the argv[] in ps(1) output, they
2791          * show a string from the process struct and provide
2792          * the setproctitle() routine to manipulate that. */
2793         if (PL_origalen != 1) {
2794             s = SvPV_const(sv, len);
2795 #   if __FreeBSD_version > 410001
2796             /* The leading "-" removes the "perl: " prefix,
2797              * but not the "(perl) suffix from the ps(1)
2798              * output, because that's what ps(1) shows if the
2799              * argv[] is modified. */
2800             setproctitle("-%s", s);
2801 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2802             /* This doesn't really work if you assume that
2803              * $0 = 'foobar'; will wipe out 'perl' from the $0
2804              * because in ps(1) output the result will be like
2805              * sprintf("perl: %s (perl)", s)
2806              * I guess this is a security feature:
2807              * one (a user process) cannot get rid of the original name.
2808              * --jhi */
2809             setproctitle("%s", s);
2810 #   endif
2811         }
2812 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2813         if (PL_origalen != 1) {
2814              union pstun un;
2815              s = SvPV_const(sv, len);
2816              un.pst_command = (char *)s;
2817              pstat(PSTAT_SETCMD, un, len, 0, 0);
2818         }
2819 #else
2820         if (PL_origalen > 1) {
2821             /* PL_origalen is set in perl_parse(). */
2822             s = SvPV_force(sv,len);
2823             if (len >= (STRLEN)PL_origalen-1) {
2824                 /* Longer than original, will be truncated. We assume that
2825                  * PL_origalen bytes are available. */
2826                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2827             }
2828             else {
2829                 /* Shorter than original, will be padded. */
2830 #ifdef PERL_DARWIN
2831                 /* Special case for Mac OS X: see [perl #38868] */
2832                 const int pad = 0;
2833 #else
2834                 /* Is the space counterintuitive?  Yes.
2835                  * (You were expecting \0?)
2836                  * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2837                  * --jhi */
2838                 const int pad = ' ';
2839 #endif
2840                 Copy(s, PL_origargv[0], len, char);
2841                 PL_origargv[0][len] = 0;
2842                 memset(PL_origargv[0] + len + 1,
2843                        pad,  PL_origalen - len - 1);
2844             }
2845             PL_origargv[0][PL_origalen-1] = 0;
2846             for (i = 1; i < PL_origargc; i++)
2847                 PL_origargv[i] = 0;
2848 #ifdef HAS_PRCTL_SET_NAME
2849             /* Set the legacy process name in addition to the POSIX name on Linux */
2850             if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2851                 /* diag_listed_as: SKIPME */
2852                 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2853             }
2854 #endif
2855         }
2856 #endif
2857         UNLOCK_DOLLARZERO_MUTEX;
2858         break;
2859     }
2860     return 0;
2861 }
2862
2863 I32
2864 Perl_whichsig(pTHX_ const char *sig)
2865 {
2866     register char* const* sigv;
2867
2868     PERL_ARGS_ASSERT_WHICHSIG;
2869     PERL_UNUSED_CONTEXT;
2870
2871     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2872         if (strEQ(sig,*sigv))
2873             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2874 #ifdef SIGCLD
2875     if (strEQ(sig,"CHLD"))
2876         return SIGCLD;
2877 #endif
2878 #ifdef SIGCHLD
2879     if (strEQ(sig,"CLD"))
2880         return SIGCHLD;
2881 #endif
2882     return -1;
2883 }
2884
2885 Signal_t
2886 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2887 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2888 #else
2889 Perl_sighandler(int sig)
2890 #endif
2891 {
2892 #ifdef PERL_GET_SIG_CONTEXT
2893     dTHXa(PERL_GET_SIG_CONTEXT);
2894 #else
2895     dTHX;
2896 #endif
2897     dSP;
2898     GV *gv = NULL;
2899     SV *sv = NULL;
2900     SV * const tSv = PL_Sv;
2901     CV *cv = NULL;
2902     OP *myop = PL_op;
2903     U32 flags = 0;
2904     XPV * const tXpv = PL_Xpv;
2905
2906     if (PL_savestack_ix + 15 <= PL_savestack_max)
2907         flags |= 1;
2908     if (PL_markstack_ptr < PL_markstack_max - 2)
2909         flags |= 4;
2910     if (PL_scopestack_ix < PL_scopestack_max - 3)
2911         flags |= 16;
2912
2913     if (!PL_psig_ptr[sig]) {
2914                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2915                                  PL_sig_name[sig]);
2916                 exit(sig);
2917         }
2918
2919     /* Max number of items pushed there is 3*n or 4. We cannot fix
2920        infinity, so we fix 4 (in fact 5): */
2921     if (flags & 1) {
2922         PL_savestack_ix += 5;           /* Protect save in progress. */
2923         SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2924     }
2925     if (flags & 4)
2926         PL_markstack_ptr++;             /* Protect mark. */
2927     if (flags & 16)
2928         PL_scopestack_ix += 1;
2929     /* sv_2cv is too complicated, try a simpler variant first: */
2930     if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
2931         || SvTYPE(cv) != SVt_PVCV) {
2932         HV *st;
2933         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2934     }
2935
2936     if (!cv || !CvROOT(cv)) {
2937         Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2938                        PL_sig_name[sig], (gv ? GvENAME(gv)
2939                                           : ((cv && CvGV(cv))
2940                                              ? GvENAME(CvGV(cv))
2941                                              : "__ANON__")));
2942         goto cleanup;
2943     }
2944
2945     if(PL_psig_name[sig]) {
2946         sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2947         flags |= 64;
2948 #if !defined(PERL_IMPLICIT_CONTEXT)
2949         PL_sig_sv = sv;
2950 #endif
2951     } else {
2952         sv = sv_newmortal();
2953         sv_setpv(sv,PL_sig_name[sig]);
2954     }
2955
2956     PUSHSTACKi(PERLSI_SIGNAL);
2957     PUSHMARK(SP);
2958     PUSHs(sv);
2959 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2960     {
2961          struct sigaction oact;
2962
2963          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2964               if (sip) {
2965                    HV *sih = newHV();
2966                    SV *rv  = newRV_noinc(MUTABLE_SV(sih));
2967                    /* The siginfo fields signo, code, errno, pid, uid,
2968                     * addr, status, and band are defined by POSIX/SUSv3. */
2969                    (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2970                    (void)hv_stores(sih, "code", newSViv(sip->si_code));
2971 #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. */
2972                    hv_stores(sih, "errno",      newSViv(sip->si_errno));
2973                    hv_stores(sih, "status",     newSViv(sip->si_status));
2974                    hv_stores(sih, "uid",        newSViv(sip->si_uid));
2975                    hv_stores(sih, "pid",        newSViv(sip->si_pid));
2976                    hv_stores(sih, "addr",       newSVuv(PTR2UV(sip->si_addr)));
2977                    hv_stores(sih, "band",       newSViv(sip->si_band));
2978 #endif
2979                    EXTEND(SP, 2);
2980                    PUSHs(rv);
2981                    mPUSHp((char *)sip, sizeof(*sip));
2982               }
2983
2984          }
2985     }
2986 #endif
2987     PUTBACK;
2988
2989     call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
2990
2991     POPSTACK;
2992     if (SvTRUE(ERRSV)) {
2993 #ifndef PERL_MICRO
2994 #ifdef HAS_SIGPROCMASK
2995         /* Handler "died", for example to get out of a restart-able read().
2996          * Before we re-do that on its behalf re-enable the signal which was
2997          * blocked by the system when we entered.
2998          */
2999         sigset_t set;
3000         sigemptyset(&set);
3001         sigaddset(&set,sig);
3002         sigprocmask(SIG_UNBLOCK, &set, NULL);
3003 #else
3004         /* Not clear if this will work */
3005         (void)rsignal(sig, SIG_IGN);
3006         (void)rsignal(sig, PL_csighandlerp);
3007 #endif
3008 #endif /* !PERL_MICRO */
3009         die_sv(ERRSV);
3010     }
3011 cleanup:
3012     if (flags & 1)
3013         PL_savestack_ix -= 8; /* Unprotect save in progress. */
3014     if (flags & 4)
3015         PL_markstack_ptr--;
3016     if (flags & 16)
3017         PL_scopestack_ix -= 1;
3018     if (flags & 64)
3019         SvREFCNT_dec(sv);
3020     PL_op = myop;                       /* Apparently not needed... */
3021
3022     PL_Sv = tSv;                        /* Restore global temporaries. */
3023     PL_Xpv = tXpv;
3024     return;
3025 }
3026
3027
3028 static void
3029 S_restore_magic(pTHX_ const void *p)
3030 {
3031     dVAR;
3032     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3033     SV* const sv = mgs->mgs_sv;
3034
3035     if (!sv)
3036         return;
3037
3038     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3039     {
3040 #ifdef PERL_OLD_COPY_ON_WRITE
3041         /* While magic was saved (and off) sv_setsv may well have seen
3042            this SV as a prime candidate for COW.  */
3043         if (SvIsCOW(sv))
3044             sv_force_normal_flags(sv, 0);
3045 #endif
3046
3047         if (mgs->mgs_readonly)
3048             SvREADONLY_on(sv);
3049         if (mgs->mgs_magical)
3050             SvFLAGS(sv) |= mgs->mgs_magical;
3051         else
3052             mg_magical(sv);
3053         if (SvGMAGICAL(sv)) {
3054             /* downgrade public flags to private,
3055                and discard any other private flags */
3056
3057             const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3058             if (pubflags) {
3059                 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3060                 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3061             }
3062         }
3063     }
3064
3065     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
3066
3067     /* If we're still on top of the stack, pop us off.  (That condition
3068      * will be satisfied if restore_magic was called explicitly, but *not*
3069      * if it's being called via leave_scope.)
3070      * The reason for doing this is that otherwise, things like sv_2cv()
3071      * may leave alloc gunk on the savestack, and some code
3072      * (e.g. sighandler) doesn't expect that...
3073      */
3074     if (PL_savestack_ix == mgs->mgs_ss_ix)
3075     {
3076         UV popval = SSPOPUV;
3077         assert(popval == SAVEt_DESTRUCTOR_X);
3078         PL_savestack_ix -= 2;
3079         popval = SSPOPUV;
3080         assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3081         PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3082     }
3083
3084 }
3085
3086 static void
3087 S_unwind_handler_stack(pTHX_ const void *p)
3088 {
3089     dVAR;
3090     const U32 flags = *(const U32*)p;
3091
3092     PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK;
3093
3094     if (flags & 1)
3095         PL_savestack_ix -= 5; /* Unprotect save in progress. */
3096 #if !defined(PERL_IMPLICIT_CONTEXT)
3097     if (flags & 64)
3098         SvREFCNT_dec(PL_sig_sv);
3099 #endif
3100 }
3101
3102 /*
3103 =for apidoc magic_sethint
3104
3105 Triggered by a store to %^H, records the key/value pair to
3106 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
3107 anything that would need a deep copy.  Maybe we should warn if we find a
3108 reference.
3109
3110 =cut
3111 */
3112 int
3113 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3114 {
3115     dVAR;
3116     SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3117         : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3118
3119     PERL_ARGS_ASSERT_MAGIC_SETHINT;
3120
3121     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
3122        an alternative leaf in there, with PL_compiling.cop_hints being used if
3123        it's NULL. If needed for threads, the alternative could lock a mutex,
3124        or take other more complex action.  */
3125
3126     /* Something changed in %^H, so it will need to be restored on scope exit.
3127        Doing this here saves a lot of doing it manually in perl code (and
3128        forgetting to do it, and consequent subtle errors.  */
3129     PL_hints |= HINT_LOCALIZE_HH;
3130     PL_compiling.cop_hints_hash
3131         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
3132     return 0;
3133 }
3134
3135 /*
3136 =for apidoc magic_clearhint
3137
3138 Triggered by a delete from %^H, records the key to
3139 C<PL_compiling.cop_hints_hash>.
3140
3141 =cut
3142 */
3143 int
3144 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3145 {
3146     dVAR;
3147
3148     PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3149     PERL_UNUSED_ARG(sv);
3150
3151     assert(mg->mg_len == HEf_SVKEY);
3152
3153     PERL_UNUSED_ARG(sv);
3154
3155     PL_hints |= HINT_LOCALIZE_HH;
3156     PL_compiling.cop_hints_hash
3157         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3158                                  MUTABLE_SV(mg->mg_ptr), &PL_sv_placeholder);
3159     return 0;
3160 }
3161
3162 /*
3163 =for apidoc magic_clearhints
3164
3165 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3166
3167 =cut
3168 */
3169 int
3170 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3171 {
3172     PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3173     PERL_UNUSED_ARG(sv);
3174     PERL_UNUSED_ARG(mg);
3175     if (PL_compiling.cop_hints_hash) {
3176         Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3177         PL_compiling.cop_hints_hash = NULL;
3178     }
3179     return 0;
3180 }
3181
3182 /*
3183  * Local variables:
3184  * c-indentation-style: bsd
3185  * c-basic-offset: 4
3186  * indent-tabs-mode: t
3187  * End:
3188  *
3189  * ex: set ts=8 sts=4 sw=4 noet:
3190  */