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