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