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 const 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     Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2259     return 0;
2260 }
2261
2262 int
2263 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2264 {
2265     PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2266     PERL_UNUSED_CONTEXT;
2267     mg->mg_len = -1;
2268     if (!isGV_with_GP(sv))
2269         SvSCREAM_off(sv);
2270     return 0;
2271 }
2272
2273 int
2274 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2275 {
2276     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2277
2278     PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2279
2280     if (uf && uf->uf_set)
2281         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2282     return 0;
2283 }
2284
2285 int
2286 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2287 {
2288     const char type = mg->mg_type;
2289
2290     PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2291
2292     if (type == PERL_MAGIC_qr) {
2293     } else if (type == PERL_MAGIC_bm) {
2294         SvTAIL_off(sv);
2295         SvVALID_off(sv);
2296     } else {
2297         assert(type == PERL_MAGIC_fm);
2298         SvCOMPILED_off(sv);
2299     }
2300     return sv_unmagic(sv, type);
2301 }
2302
2303 #ifdef USE_LOCALE_COLLATE
2304 int
2305 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2306 {
2307     PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2308
2309     /*
2310      * RenE<eacute> Descartes said "I think not."
2311      * and vanished with a faint plop.
2312      */
2313     PERL_UNUSED_CONTEXT;
2314     PERL_UNUSED_ARG(sv);
2315     if (mg->mg_ptr) {
2316         Safefree(mg->mg_ptr);
2317         mg->mg_ptr = NULL;
2318         mg->mg_len = -1;
2319     }
2320     return 0;
2321 }
2322 #endif /* USE_LOCALE_COLLATE */
2323
2324 /* Just clear the UTF-8 cache data. */
2325 int
2326 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2327 {
2328     PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2329     PERL_UNUSED_CONTEXT;
2330     PERL_UNUSED_ARG(sv);
2331     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2332     mg->mg_ptr = NULL;
2333     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2334     return 0;
2335 }
2336
2337 int
2338 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2339 {
2340     dVAR;
2341     register const char *s;
2342     register I32 paren;
2343     register const REGEXP * rx;
2344     const char * const remaining = mg->mg_ptr + 1;
2345     I32 i;
2346     STRLEN len;
2347
2348     PERL_ARGS_ASSERT_MAGIC_SET;
2349
2350     switch (*mg->mg_ptr) {
2351     case '\015': /* $^MATCH */
2352       if (strEQ(remaining, "ATCH"))
2353           goto do_match;
2354     case '`': /* ${^PREMATCH} caught below */
2355       do_prematch:
2356       paren = RX_BUFF_IDX_PREMATCH;
2357       goto setparen;
2358     case '\'': /* ${^POSTMATCH} caught below */
2359       do_postmatch:
2360       paren = RX_BUFF_IDX_POSTMATCH;
2361       goto setparen;
2362     case '&':
2363       do_match:
2364       paren = RX_BUFF_IDX_FULLMATCH;
2365       goto setparen;
2366     case '1': case '2': case '3': case '4':
2367     case '5': case '6': case '7': case '8': case '9':
2368       paren = atoi(mg->mg_ptr);
2369       setparen:
2370         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2371             CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2372             break;
2373         } else {
2374             /* Croak with a READONLY error when a numbered match var is
2375              * set without a previous pattern match. Unless it's C<local $1>
2376              */
2377             if (!PL_localizing) {
2378                 Perl_croak_no_modify(aTHX);
2379             }
2380         }
2381     case '\001':        /* ^A */
2382         sv_setsv(PL_bodytarget, sv);
2383         break;
2384     case '\003':        /* ^C */
2385         PL_minus_c = cBOOL(SvIV(sv));
2386         break;
2387
2388     case '\004':        /* ^D */
2389 #ifdef DEBUGGING
2390         s = SvPV_nolen_const(sv);
2391         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2392         if (DEBUG_x_TEST || DEBUG_B_TEST)
2393             dump_all_perl(!DEBUG_B_TEST);
2394 #else
2395         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2396 #endif
2397         break;
2398     case '\005':  /* ^E */
2399         if (*(mg->mg_ptr+1) == '\0') {
2400 #ifdef VMS
2401             set_vaxc_errno(SvIV(sv));
2402 #else
2403 #  ifdef WIN32
2404             SetLastError( SvIV(sv) );
2405 #  else
2406 #    ifdef OS2
2407             os2_setsyserrno(SvIV(sv));
2408 #    else
2409             /* will anyone ever use this? */
2410             SETERRNO(SvIV(sv), 4);
2411 #    endif
2412 #  endif
2413 #endif
2414         }
2415         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2416             SvREFCNT_dec(PL_encoding);
2417             if (SvOK(sv) || SvGMAGICAL(sv)) {
2418                 PL_encoding = newSVsv(sv);
2419             }
2420             else {
2421                 PL_encoding = NULL;
2422             }
2423         }
2424         break;
2425     case '\006':        /* ^F */
2426         PL_maxsysfd = SvIV(sv);
2427         break;
2428     case '\010':        /* ^H */
2429         PL_hints = SvIV(sv);
2430         break;
2431     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2432         Safefree(PL_inplace);
2433         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2434         break;
2435     case '\017':        /* ^O */
2436         if (*(mg->mg_ptr+1) == '\0') {
2437             Safefree(PL_osname);
2438             PL_osname = NULL;
2439             if (SvOK(sv)) {
2440                 TAINT_PROPER("assigning to $^O");
2441                 PL_osname = savesvpv(sv);
2442             }
2443         }
2444         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2445             STRLEN len;
2446             const char *const start = SvPV(sv, len);
2447             const char *out = (const char*)memchr(start, '\0', len);
2448             SV *tmp;
2449
2450
2451             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2452             PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2453
2454             /* Opening for input is more common than opening for output, so
2455                ensure that hints for input are sooner on linked list.  */
2456             tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2457                                        SvUTF8(sv))
2458                 : newSVpvs_flags("", SvUTF8(sv));
2459             (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2460             mg_set(tmp);
2461
2462             tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2463                                         SvUTF8(sv));
2464             (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2465             mg_set(tmp);
2466         }
2467         break;
2468     case '\020':        /* ^P */
2469       if (*remaining == '\0') { /* ^P */
2470           PL_perldb = SvIV(sv);
2471           if (PL_perldb && !PL_DBsingle)
2472               init_debugger();
2473           break;
2474       } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2475           goto do_prematch;
2476       } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2477           goto do_postmatch;
2478       }
2479     case '\024':        /* ^T */
2480 #ifdef BIG_TIME
2481         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2482 #else
2483         PL_basetime = (Time_t)SvIV(sv);
2484 #endif
2485         break;
2486     case '\025':        /* ^UTF8CACHE */
2487          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2488              PL_utf8cache = (signed char) sv_2iv(sv);
2489          }
2490          break;
2491     case '\027':        /* ^W & $^WARNING_BITS */
2492         if (*(mg->mg_ptr+1) == '\0') {
2493             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2494                 i = SvIV(sv);
2495                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2496                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2497             }
2498         }
2499         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2500             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2501                 if (!SvPOK(sv) && PL_localizing) {
2502                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2503                     PL_compiling.cop_warnings = pWARN_NONE;
2504                     break;
2505                 }
2506                 {
2507                     STRLEN len, i;
2508                     int accumulate = 0 ;
2509                     int any_fatals = 0 ;
2510                     const char * const ptr = SvPV_const(sv, len) ;
2511                     for (i = 0 ; i < len ; ++i) {
2512                         accumulate |= ptr[i] ;
2513                         any_fatals |= (ptr[i] & 0xAA) ;
2514                     }
2515                     if (!accumulate) {
2516                         if (!specialWARN(PL_compiling.cop_warnings))
2517                             PerlMemShared_free(PL_compiling.cop_warnings);
2518                         PL_compiling.cop_warnings = pWARN_NONE;
2519                     }
2520                     /* Yuck. I can't see how to abstract this:  */
2521                     else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2522                                        WARN_ALL) && !any_fatals) {
2523                         if (!specialWARN(PL_compiling.cop_warnings))
2524                             PerlMemShared_free(PL_compiling.cop_warnings);
2525                         PL_compiling.cop_warnings = pWARN_ALL;
2526                         PL_dowarn |= G_WARN_ONCE ;
2527                     }
2528                     else {
2529                         STRLEN len;
2530                         const char *const p = SvPV_const(sv, len);
2531
2532                         PL_compiling.cop_warnings
2533                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2534                                                          p, len);
2535
2536                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2537                             PL_dowarn |= G_WARN_ONCE ;
2538                     }
2539
2540                 }
2541             }
2542         }
2543         break;
2544     case '.':
2545         if (PL_localizing) {
2546             if (PL_localizing == 1)
2547                 SAVESPTR(PL_last_in_gv);
2548         }
2549         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2550             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2551         break;
2552     case '^':
2553         if (isGV_with_GP(PL_defoutgv)) {
2554             Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2555             s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2556             IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2557         }
2558         break;
2559     case '~':
2560         if (isGV_with_GP(PL_defoutgv)) {
2561             Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2562             s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2563             IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2564         }
2565         break;
2566     case '=':
2567         if (isGV_with_GP(PL_defoutgv))
2568             IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2569         break;
2570     case '-':
2571         if (isGV_with_GP(PL_defoutgv)) {
2572             IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2573             if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2574                 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2575         }
2576         break;
2577     case '%':
2578         if (isGV_with_GP(PL_defoutgv))
2579             IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2580         break;
2581     case '|':
2582         {
2583             IO * const io = GvIO(PL_defoutgv);
2584             if(!io)
2585               break;
2586             if ((SvIV(sv)) == 0)
2587                 IoFLAGS(io) &= ~IOf_FLUSH;
2588             else {
2589                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2590                     PerlIO *ofp = IoOFP(io);
2591                     if (ofp)
2592                         (void)PerlIO_flush(ofp);
2593                     IoFLAGS(io) |= IOf_FLUSH;
2594                 }
2595             }
2596         }
2597         break;
2598     case '/':
2599         SvREFCNT_dec(PL_rs);
2600         PL_rs = newSVsv(sv);
2601         break;
2602     case '\\':
2603         SvREFCNT_dec(PL_ors_sv);
2604         if (SvOK(sv) || SvGMAGICAL(sv)) {
2605             PL_ors_sv = newSVsv(sv);
2606         }
2607         else {
2608             PL_ors_sv = NULL;
2609         }
2610         break;
2611     case '[':
2612         CopARYBASE_set(&PL_compiling, SvIV(sv));
2613         break;
2614     case '?':
2615 #ifdef COMPLEX_STATUS
2616         if (PL_localizing == 2) {
2617             SvUPGRADE(sv, SVt_PVLV);
2618             PL_statusvalue = LvTARGOFF(sv);
2619             PL_statusvalue_vms = LvTARGLEN(sv);
2620         }
2621         else
2622 #endif
2623 #ifdef VMSISH_STATUS
2624         if (VMSISH_STATUS)
2625             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2626         else
2627 #endif
2628             STATUS_UNIX_EXIT_SET(SvIV(sv));
2629         break;
2630     case '!':
2631         {
2632 #ifdef VMS
2633 #   define PERL_VMS_BANG vaxc$errno
2634 #else
2635 #   define PERL_VMS_BANG 0
2636 #endif
2637         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2638                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2639         }
2640         break;
2641     case '<':
2642         PL_uid = SvIV(sv);
2643         if (PL_delaymagic) {
2644             PL_delaymagic |= DM_RUID;
2645             break;                              /* don't do magic till later */
2646         }
2647 #ifdef HAS_SETRUID
2648         (void)setruid((Uid_t)PL_uid);
2649 #else
2650 #ifdef HAS_SETREUID
2651         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2652 #else
2653 #ifdef HAS_SETRESUID
2654       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2655 #else
2656         if (PL_uid == PL_euid) {                /* special case $< = $> */
2657 #ifdef PERL_DARWIN
2658             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2659             if (PL_uid != 0 && PerlProc_getuid() == 0)
2660                 (void)PerlProc_setuid(0);
2661 #endif
2662             (void)PerlProc_setuid(PL_uid);
2663         } else {
2664             PL_uid = PerlProc_getuid();
2665             Perl_croak(aTHX_ "setruid() not implemented");
2666         }
2667 #endif
2668 #endif
2669 #endif
2670         PL_uid = PerlProc_getuid();
2671         break;
2672     case '>':
2673         PL_euid = SvIV(sv);
2674         if (PL_delaymagic) {
2675             PL_delaymagic |= DM_EUID;
2676             break;                              /* don't do magic till later */
2677         }
2678 #ifdef HAS_SETEUID
2679         (void)seteuid((Uid_t)PL_euid);
2680 #else
2681 #ifdef HAS_SETREUID
2682         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2683 #else
2684 #ifdef HAS_SETRESUID
2685         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2686 #else
2687         if (PL_euid == PL_uid)          /* special case $> = $< */
2688             PerlProc_setuid(PL_euid);
2689         else {
2690             PL_euid = PerlProc_geteuid();
2691             Perl_croak(aTHX_ "seteuid() not implemented");
2692         }
2693 #endif
2694 #endif
2695 #endif
2696         PL_euid = PerlProc_geteuid();
2697         break;
2698     case '(':
2699         PL_gid = SvIV(sv);
2700         if (PL_delaymagic) {
2701             PL_delaymagic |= DM_RGID;
2702             break;                              /* don't do magic till later */
2703         }
2704 #ifdef HAS_SETRGID
2705         (void)setrgid((Gid_t)PL_gid);
2706 #else
2707 #ifdef HAS_SETREGID
2708         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2709 #else
2710 #ifdef HAS_SETRESGID
2711       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2712 #else
2713         if (PL_gid == PL_egid)                  /* special case $( = $) */
2714             (void)PerlProc_setgid(PL_gid);
2715         else {
2716             PL_gid = PerlProc_getgid();
2717             Perl_croak(aTHX_ "setrgid() not implemented");
2718         }
2719 #endif
2720 #endif
2721 #endif
2722         PL_gid = PerlProc_getgid();
2723         break;
2724     case ')':
2725 #ifdef HAS_SETGROUPS
2726         {
2727             const char *p = SvPV_const(sv, len);
2728             Groups_t *gary = NULL;
2729 #ifdef _SC_NGROUPS_MAX
2730            int maxgrp = sysconf(_SC_NGROUPS_MAX);
2731
2732            if (maxgrp < 0)
2733                maxgrp = NGROUPS;
2734 #else
2735            int maxgrp = NGROUPS;
2736 #endif
2737
2738             while (isSPACE(*p))
2739                 ++p;
2740             PL_egid = Atol(p);
2741             for (i = 0; i < maxgrp; ++i) {
2742                 while (*p && !isSPACE(*p))
2743                     ++p;
2744                 while (isSPACE(*p))
2745                     ++p;
2746                 if (!*p)
2747                     break;
2748                 if(!gary)
2749                     Newx(gary, i + 1, Groups_t);
2750                 else
2751                     Renew(gary, i + 1, Groups_t);
2752                 gary[i] = Atol(p);
2753             }
2754             if (i)
2755                 (void)setgroups(i, gary);
2756             Safefree(gary);
2757         }
2758 #else  /* HAS_SETGROUPS */
2759         PL_egid = SvIV(sv);
2760 #endif /* HAS_SETGROUPS */
2761         if (PL_delaymagic) {
2762             PL_delaymagic |= DM_EGID;
2763             break;                              /* don't do magic till later */
2764         }
2765 #ifdef HAS_SETEGID
2766         (void)setegid((Gid_t)PL_egid);
2767 #else
2768 #ifdef HAS_SETREGID
2769         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2770 #else
2771 #ifdef HAS_SETRESGID
2772         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2773 #else
2774         if (PL_egid == PL_gid)                  /* special case $) = $( */
2775             (void)PerlProc_setgid(PL_egid);
2776         else {
2777             PL_egid = PerlProc_getegid();
2778             Perl_croak(aTHX_ "setegid() not implemented");
2779         }
2780 #endif
2781 #endif
2782 #endif
2783         PL_egid = PerlProc_getegid();
2784         break;
2785     case ':':
2786         PL_chopset = SvPV_force(sv,len);
2787         break;
2788     case '0':
2789         LOCK_DOLLARZERO_MUTEX;
2790 #ifdef HAS_SETPROCTITLE
2791         /* The BSDs don't show the argv[] in ps(1) output, they
2792          * show a string from the process struct and provide
2793          * the setproctitle() routine to manipulate that. */
2794         if (PL_origalen != 1) {
2795             s = SvPV_const(sv, len);
2796 #   if __FreeBSD_version > 410001
2797             /* The leading "-" removes the "perl: " prefix,
2798              * but not the "(perl) suffix from the ps(1)
2799              * output, because that's what ps(1) shows if the
2800              * argv[] is modified. */
2801             setproctitle("-%s", s);
2802 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2803             /* This doesn't really work if you assume that
2804              * $0 = 'foobar'; will wipe out 'perl' from the $0
2805              * because in ps(1) output the result will be like
2806              * sprintf("perl: %s (perl)", s)
2807              * I guess this is a security feature:
2808              * one (a user process) cannot get rid of the original name.
2809              * --jhi */
2810             setproctitle("%s", s);
2811 #   endif
2812         }
2813 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2814         if (PL_origalen != 1) {
2815              union pstun un;
2816              s = SvPV_const(sv, len);
2817              un.pst_command = (char *)s;
2818              pstat(PSTAT_SETCMD, un, len, 0, 0);
2819         }
2820 #else
2821         if (PL_origalen > 1) {
2822             /* PL_origalen is set in perl_parse(). */
2823             s = SvPV_force(sv,len);
2824             if (len >= (STRLEN)PL_origalen-1) {
2825                 /* Longer than original, will be truncated. We assume that
2826                  * PL_origalen bytes are available. */
2827                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2828             }
2829             else {
2830                 /* Shorter than original, will be padded. */
2831 #ifdef PERL_DARWIN
2832                 /* Special case for Mac OS X: see [perl #38868] */
2833                 const int pad = 0;
2834 #else
2835                 /* Is the space counterintuitive?  Yes.
2836                  * (You were expecting \0?)
2837                  * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2838                  * --jhi */
2839                 const int pad = ' ';
2840 #endif
2841                 Copy(s, PL_origargv[0], len, char);
2842                 PL_origargv[0][len] = 0;
2843                 memset(PL_origargv[0] + len + 1,
2844                        pad,  PL_origalen - len - 1);
2845             }
2846             PL_origargv[0][PL_origalen-1] = 0;
2847             for (i = 1; i < PL_origargc; i++)
2848                 PL_origargv[i] = 0;
2849 #ifdef HAS_PRCTL_SET_NAME
2850             /* Set the legacy process name in addition to the POSIX name on Linux */
2851             if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2852                 /* diag_listed_as: SKIPME */
2853                 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2854             }
2855 #endif
2856         }
2857 #endif
2858         UNLOCK_DOLLARZERO_MUTEX;
2859         break;
2860     }
2861     return 0;
2862 }
2863
2864 I32
2865 Perl_whichsig(pTHX_ const char *sig)
2866 {
2867     register char* const* sigv;
2868
2869     PERL_ARGS_ASSERT_WHICHSIG;
2870     PERL_UNUSED_CONTEXT;
2871
2872     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2873         if (strEQ(sig,*sigv))
2874             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2875 #ifdef SIGCLD
2876     if (strEQ(sig,"CHLD"))
2877         return SIGCLD;
2878 #endif
2879 #ifdef SIGCHLD
2880     if (strEQ(sig,"CLD"))
2881         return SIGCHLD;
2882 #endif
2883     return -1;
2884 }
2885
2886 Signal_t
2887 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2888 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2889 #else
2890 Perl_sighandler(int sig)
2891 #endif
2892 {
2893 #ifdef PERL_GET_SIG_CONTEXT
2894     dTHXa(PERL_GET_SIG_CONTEXT);
2895 #else
2896     dTHX;
2897 #endif
2898     dSP;
2899     GV *gv = NULL;
2900     SV *sv = NULL;
2901     SV * const tSv = PL_Sv;
2902     CV *cv = NULL;
2903     OP *myop = PL_op;
2904     U32 flags = 0;
2905     XPV * const tXpv = PL_Xpv;
2906
2907     if (PL_savestack_ix + 15 <= PL_savestack_max)
2908         flags |= 1;
2909     if (PL_markstack_ptr < PL_markstack_max - 2)
2910         flags |= 4;
2911     if (PL_scopestack_ix < PL_scopestack_max - 3)
2912         flags |= 16;
2913
2914     if (!PL_psig_ptr[sig]) {
2915                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2916                                  PL_sig_name[sig]);
2917                 exit(sig);
2918         }
2919
2920     /* Max number of items pushed there is 3*n or 4. We cannot fix
2921        infinity, so we fix 4 (in fact 5): */
2922     if (flags & 1) {
2923         PL_savestack_ix += 5;           /* Protect save in progress. */
2924         SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2925     }
2926     if (flags & 4)
2927         PL_markstack_ptr++;             /* Protect mark. */
2928     if (flags & 16)
2929         PL_scopestack_ix += 1;
2930     /* sv_2cv is too complicated, try a simpler variant first: */
2931     if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
2932         || SvTYPE(cv) != SVt_PVCV) {
2933         HV *st;
2934         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2935     }
2936
2937     if (!cv || !CvROOT(cv)) {
2938         Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2939                        PL_sig_name[sig], (gv ? GvENAME(gv)
2940                                           : ((cv && CvGV(cv))
2941                                              ? GvENAME(CvGV(cv))
2942                                              : "__ANON__")));
2943         goto cleanup;
2944     }
2945
2946     if(PL_psig_name[sig]) {
2947         sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2948         flags |= 64;
2949 #if !defined(PERL_IMPLICIT_CONTEXT)
2950         PL_sig_sv = sv;
2951 #endif
2952     } else {
2953         sv = sv_newmortal();
2954         sv_setpv(sv,PL_sig_name[sig]);
2955     }
2956
2957     PUSHSTACKi(PERLSI_SIGNAL);
2958     PUSHMARK(SP);
2959     PUSHs(sv);
2960 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2961     {
2962          struct sigaction oact;
2963
2964          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2965               if (sip) {
2966                    HV *sih = newHV();
2967                    SV *rv  = newRV_noinc(MUTABLE_SV(sih));
2968                    /* The siginfo fields signo, code, errno, pid, uid,
2969                     * addr, status, and band are defined by POSIX/SUSv3. */
2970                    (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2971                    (void)hv_stores(sih, "code", newSViv(sip->si_code));
2972 #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. */
2973                    hv_stores(sih, "errno",      newSViv(sip->si_errno));
2974                    hv_stores(sih, "status",     newSViv(sip->si_status));
2975                    hv_stores(sih, "uid",        newSViv(sip->si_uid));
2976                    hv_stores(sih, "pid",        newSViv(sip->si_pid));
2977                    hv_stores(sih, "addr",       newSVuv(PTR2UV(sip->si_addr)));
2978                    hv_stores(sih, "band",       newSViv(sip->si_band));
2979 #endif
2980                    EXTEND(SP, 2);
2981                    PUSHs(rv);
2982                    mPUSHp((char *)sip, sizeof(*sip));
2983               }
2984
2985          }
2986     }
2987 #endif
2988     PUTBACK;
2989
2990     call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
2991
2992     POPSTACK;
2993     if (SvTRUE(ERRSV)) {
2994 #ifndef PERL_MICRO
2995 #ifdef HAS_SIGPROCMASK
2996         /* Handler "died", for example to get out of a restart-able read().
2997          * Before we re-do that on its behalf re-enable the signal which was
2998          * blocked by the system when we entered.
2999          */
3000         sigset_t set;
3001         sigemptyset(&set);
3002         sigaddset(&set,sig);
3003         sigprocmask(SIG_UNBLOCK, &set, NULL);
3004 #else
3005         /* Not clear if this will work */
3006         (void)rsignal(sig, SIG_IGN);
3007         (void)rsignal(sig, PL_csighandlerp);
3008 #endif
3009 #endif /* !PERL_MICRO */
3010         die_sv(ERRSV);
3011     }
3012 cleanup:
3013     if (flags & 1)
3014         PL_savestack_ix -= 8; /* Unprotect save in progress. */
3015     if (flags & 4)
3016         PL_markstack_ptr--;
3017     if (flags & 16)
3018         PL_scopestack_ix -= 1;
3019     if (flags & 64)
3020         SvREFCNT_dec(sv);
3021     PL_op = myop;                       /* Apparently not needed... */
3022
3023     PL_Sv = tSv;                        /* Restore global temporaries. */
3024     PL_Xpv = tXpv;
3025     return;
3026 }
3027
3028
3029 static void
3030 S_restore_magic(pTHX_ const void *p)
3031 {
3032     dVAR;
3033     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3034     SV* const sv = mgs->mgs_sv;
3035
3036     if (!sv)
3037         return;
3038
3039     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3040     {
3041 #ifdef PERL_OLD_COPY_ON_WRITE
3042         /* While magic was saved (and off) sv_setsv may well have seen
3043            this SV as a prime candidate for COW.  */
3044         if (SvIsCOW(sv))
3045             sv_force_normal_flags(sv, 0);
3046 #endif
3047
3048         if (mgs->mgs_readonly)
3049             SvREADONLY_on(sv);
3050         if (mgs->mgs_magical)
3051             SvFLAGS(sv) |= mgs->mgs_magical;
3052         else
3053             mg_magical(sv);
3054         if (SvGMAGICAL(sv)) {
3055             /* downgrade public flags to private,
3056                and discard any other private flags */
3057
3058             const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3059             if (pubflags) {
3060                 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3061                 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3062             }
3063         }
3064     }
3065
3066     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
3067
3068     /* If we're still on top of the stack, pop us off.  (That condition
3069      * will be satisfied if restore_magic was called explicitly, but *not*
3070      * if it's being called via leave_scope.)
3071      * The reason for doing this is that otherwise, things like sv_2cv()
3072      * may leave alloc gunk on the savestack, and some code
3073      * (e.g. sighandler) doesn't expect that...
3074      */
3075     if (PL_savestack_ix == mgs->mgs_ss_ix)
3076     {
3077         UV popval = SSPOPUV;
3078         assert(popval == SAVEt_DESTRUCTOR_X);
3079         PL_savestack_ix -= 2;
3080         popval = SSPOPUV;
3081         assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3082         PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3083     }
3084
3085 }
3086
3087 static void
3088 S_unwind_handler_stack(pTHX_ const void *p)
3089 {
3090     dVAR;
3091     const U32 flags = *(const U32*)p;
3092
3093     PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK;
3094
3095     if (flags & 1)
3096         PL_savestack_ix -= 5; /* Unprotect save in progress. */
3097 #if !defined(PERL_IMPLICIT_CONTEXT)
3098     if (flags & 64)
3099         SvREFCNT_dec(PL_sig_sv);
3100 #endif
3101 }
3102
3103 /*
3104 =for apidoc magic_sethint
3105
3106 Triggered by a store to %^H, records the key/value pair to
3107 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
3108 anything that would need a deep copy.  Maybe we should warn if we find a
3109 reference.
3110
3111 =cut
3112 */
3113 int
3114 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3115 {
3116     dVAR;
3117     SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3118         : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3119
3120     PERL_ARGS_ASSERT_MAGIC_SETHINT;
3121
3122     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
3123        an alternative leaf in there, with PL_compiling.cop_hints being used if
3124        it's NULL. If needed for threads, the alternative could lock a mutex,
3125        or take other more complex action.  */
3126
3127     /* Something changed in %^H, so it will need to be restored on scope exit.
3128        Doing this here saves a lot of doing it manually in perl code (and
3129        forgetting to do it, and consequent subtle errors.  */
3130     PL_hints |= HINT_LOCALIZE_HH;
3131     PL_compiling.cop_hints_hash
3132         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
3133     return 0;
3134 }
3135
3136 /*
3137 =for apidoc magic_clearhint
3138
3139 Triggered by a delete from %^H, records the key to
3140 C<PL_compiling.cop_hints_hash>.
3141
3142 =cut
3143 */
3144 int
3145 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3146 {
3147     dVAR;
3148
3149     PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3150     PERL_UNUSED_ARG(sv);
3151
3152     assert(mg->mg_len == HEf_SVKEY);
3153
3154     PERL_UNUSED_ARG(sv);
3155
3156     PL_hints |= HINT_LOCALIZE_HH;
3157     PL_compiling.cop_hints_hash
3158         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3159                                  MUTABLE_SV(mg->mg_ptr), &PL_sv_placeholder);
3160     return 0;
3161 }
3162
3163 /*
3164 =for apidoc magic_clearhints
3165
3166 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3167
3168 =cut
3169 */
3170 int
3171 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3172 {
3173     PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3174     PERL_UNUSED_ARG(sv);
3175     PERL_UNUSED_ARG(mg);
3176     if (PL_compiling.cop_hints_hash) {
3177         Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3178         PL_compiling.cop_hints_hash = NULL;
3179     }
3180     return 0;
3181 }
3182
3183 /*
3184  * Local variables:
3185  * c-indentation-style: bsd
3186  * c-basic-offset: 4
3187  * indent-tabs-mode: t
3188  * End:
3189  *
3190  * ex: set ts=8 sts=4 sw=4 noet:
3191  */