mg.c

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