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