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