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 '\007':                /* ^GLOBAL_PHASE */
 881         if (strEQ(remaining, "LOBAL_PHASE")) {
 882             sv_setpvn(sv, PL_phase_names[PL_phase],
 883                       strlen(PL_phase_names[PL_phase]));
 884         }
 885         break;
 886     case '\010':                /* ^H */
 887         sv_setiv(sv, (IV)PL_hints);
 888         break;
 889     case '\011':                /* ^I */ /* NOT \t in EBCDIC */
 890         sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
 891         break;
 892     case '\017':                /* ^O & ^OPEN */
 893         if (nextchar == '\0') {
 894             sv_setpv(sv, PL_osname);
 895             SvTAINTED_off(sv);
 896         }
 897         else if (strEQ(remaining, "PEN")) {
 898             Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
 899         }
 900         break;
 901     case '\020':
 902         if (nextchar == '\0') {       /* ^P */
 903             sv_setiv(sv, (IV)PL_perldb);
 904         } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
 905             goto do_prematch_fetch;
 906         } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
 907             goto do_postmatch_fetch;
 908         }
 909         break;
 910     case '\023':                /* ^S */
 911         if (nextchar == '\0') {
 912             if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
 913                 SvOK_off(sv);
 914             else if (PL_in_eval)
 915                 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
 916             else
 917                 sv_setiv(sv, 0);
 918         }
 919         break;
 920     case '\024':                /* ^T */
 921         if (nextchar == '\0') {
 922 #ifdef BIG_TIME
 923             sv_setnv(sv, PL_basetime);
 924 #else
 925             sv_setiv(sv, (IV)PL_basetime);
 926 #endif
 927         }
 928         else if (strEQ(remaining, "AINT"))
 929             sv_setiv(sv, PL_tainting
 930                     ? (PL_taint_warn || PL_unsafe ? -1 : 1)
 931                     : 0);
 932         break;
 933     case '\025':                /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
 934         if (strEQ(remaining, "NICODE"))
 935             sv_setuv(sv, (UV) PL_unicode);
 936         else if (strEQ(remaining, "TF8LOCALE"))
 937             sv_setuv(sv, (UV) PL_utf8locale);
 938         else if (strEQ(remaining, "TF8CACHE"))
 939             sv_setiv(sv, (IV) PL_utf8cache);
 940         break;
 941     case '\027':                /* ^W  & $^WARNING_BITS */
 942         if (nextchar == '\0')
 943             sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
 944         else if (strEQ(remaining, "ARNING_BITS")) {
 945             if (PL_compiling.cop_warnings == pWARN_NONE) {
 946                 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
 947             }
 948             else if (PL_compiling.cop_warnings == pWARN_STD) {
 949                 sv_setpvn(
 950                     sv,
 951                     (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
 952                     WARNsize
 953                 );
 954             }
 955             else if (PL_compiling.cop_warnings == pWARN_ALL) {
 956                 /* Get the bit mask for $warnings::Bits{all}, because
 957                  * it could have been extended by warnings::register */
 958                 HV * const bits=get_hv("warnings::Bits", 0);
 959                 if (bits) {
 960                     SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
 961                     if (bits_all)
 962                         sv_setsv(sv, *bits_all);
 963                 }
 964                 else {
 965                     sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
 966                 }
 967             }
 968             else {
 969                 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
 970                           *PL_compiling.cop_warnings);
 971             }
 972             SvPOK_only(sv);
 973         }
 974         break;
 975     case '\015': /* $^MATCH */
 976         if (strEQ(remaining, "ATCH")) {
 977     case '1': case '2': case '3': case '4':
 978     case '5': case '6': case '7': case '8': case '9': case '&':
 979             if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 980                 /*
 981                  * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
 982                  * XXX Does the new way break anything?
 983                  */
 984                 paren = atoi(mg->mg_ptr); /* $& is in [0] */
 985                 CALLREG_NUMBUF_FETCH(rx,paren,sv);
 986                 break;
 987             }
 988             sv_setsv(sv,&PL_sv_undef);
 989         }
 990         break;
 991     case '+':
 992         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 993             if (RX_LASTPAREN(rx)) {
 994                 CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
 995                 break;
 996             }
 997         }
 998         sv_setsv(sv,&PL_sv_undef);
 999         break;
1000     case '\016':                /* ^N */
1001         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1002             if (RX_LASTCLOSEPAREN(rx)) {
1003                 CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
1004                 break;
1005             }
1006
1007         }
1008         sv_setsv(sv,&PL_sv_undef);
1009         break;
1010     case '`':
1011       do_prematch_fetch:
1012         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1013             CALLREG_NUMBUF_FETCH(rx,-2,sv);
1014             break;
1015         }
1016         sv_setsv(sv,&PL_sv_undef);
1017         break;
1018     case '\'':
1019       do_postmatch_fetch:
1020         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1021             CALLREG_NUMBUF_FETCH(rx,-1,sv);
1022             break;
1023         }
1024         sv_setsv(sv,&PL_sv_undef);
1025         break;
1026     case '.':
1027         if (GvIO(PL_last_in_gv)) {
1028             sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
1029         }
1030         break;
1031     case '?':
1032         {
1033             sv_setiv(sv, (IV)STATUS_CURRENT);
1034 #ifdef COMPLEX_STATUS
1035             SvUPGRADE(sv, SVt_PVLV);
1036             LvTARGOFF(sv) = PL_statusvalue;
1037             LvTARGLEN(sv) = PL_statusvalue_vms;
1038 #endif
1039         }
1040         break;
1041     case '^':
1042         if (!isGV_with_GP(PL_defoutgv))
1043             s = "";
1044         else if (GvIOp(PL_defoutgv))
1045                 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1046         if (s)
1047             sv_setpv(sv,s);
1048         else {
1049             sv_setpv(sv,GvENAME(PL_defoutgv));
1050             sv_catpvs(sv,"_TOP");
1051         }
1052         break;
1053     case '~':
1054         if (!isGV_with_GP(PL_defoutgv))
1055             s = "";
1056         else if (GvIOp(PL_defoutgv))
1057             s = IoFMT_NAME(GvIOp(PL_defoutgv));
1058         if (!s)
1059             s = GvENAME(PL_defoutgv);
1060         sv_setpv(sv,s);
1061         break;
1062     case '=':
1063         if (GvIO(PL_defoutgv))
1064             sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1065         break;
1066     case '-':
1067         if (GvIO(PL_defoutgv))
1068             sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1069         break;
1070     case '%':
1071         if (GvIO(PL_defoutgv))
1072             sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1073         break;
1074     case ':':
1075         break;
1076     case '/':
1077         break;
1078     case '[':
1079         sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
1080         break;
1081     case '|':
1082         if (GvIO(PL_defoutgv))
1083             sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1084         break;
1085     case '\\':
1086         if (PL_ors_sv)
1087             sv_copypv(sv, PL_ors_sv);
1088         break;
1089     case '!':
1090         {
1091         dSAVE_ERRNO;
1092 #ifdef VMS
1093         sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1094 #else
1095         sv_setnv(sv, (NV)errno);
1096 #endif
1097 #ifdef OS2
1098         if (errno == errno_isOS2 || errno == errno_isOS2_set)
1099             sv_setpv(sv, os2error(Perl_rc));
1100         else
1101 #endif
1102         sv_setpv(sv, errno ? Strerror(errno) : "");
1103         if (SvPOKp(sv))
1104             SvPOK_on(sv);    /* may have got removed during taint processing */
1105         RESTORE_ERRNO;
1106         }
1107
1108         SvRTRIM(sv);
1109         SvNOK_on(sv);   /* what a wonderful hack! */
1110         break;
1111     case '<':
1112         sv_setiv(sv, (IV)PL_uid);
1113         break;
1114     case '>':
1115         sv_setiv(sv, (IV)PL_euid);
1116         break;
1117     case '(':
1118         sv_setiv(sv, (IV)PL_gid);
1119         goto add_groups;
1120     case ')':
1121         sv_setiv(sv, (IV)PL_egid);
1122       add_groups:
1123 #ifdef HAS_GETGROUPS
1124         {
1125             Groups_t *gary = NULL;
1126             I32 i, num_groups = getgroups(0, gary);
1127             Newx(gary, num_groups, Groups_t);
1128             num_groups = getgroups(num_groups, gary);
1129             for (i = 0; i < num_groups; i++)
1130                 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1131             Safefree(gary);
1132         }
1133         (void)SvIOK_on(sv);     /* what a wonderful hack! */
1134 #endif
1135         break;
1136     case '0':
1137         break;
1138     }
1139     return 0;
1140 }
1141
1142 int
1143 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1144 {
1145     struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1146
1147     PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1148
1149     if (uf && uf->uf_val)
1150         (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1151     return 0;
1152 }
1153
1154 int
1155 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1156 {
1157     dVAR;
1158     STRLEN len = 0, klen;
1159     const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1160     const char * const ptr = MgPV_const(mg,klen);
1161     my_setenv(ptr, s);
1162
1163     PERL_ARGS_ASSERT_MAGIC_SETENV;
1164
1165 #ifdef DYNAMIC_ENV_FETCH
1166      /* We just undefd an environment var.  Is a replacement */
1167      /* waiting in the wings? */
1168     if (!len) {
1169         SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1170         if (valp)
1171             s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1172     }
1173 #endif
1174
1175 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1176                             /* And you'll never guess what the dog had */
1177                             /*   in its mouth... */
1178     if (PL_tainting) {
1179         MgTAINTEDDIR_off(mg);
1180 #ifdef VMS
1181         if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1182             char pathbuf[256], eltbuf[256], *cp, *elt;
1183             Stat_t sbuf;
1184             int i = 0, j = 0;
1185
1186             my_strlcpy(eltbuf, s, sizeof(eltbuf));
1187             elt = eltbuf;
1188             do {          /* DCL$PATH may be a search list */
1189                 while (1) {   /* as may dev portion of any element */
1190                     if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1191                         if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1192                              cando_by_name(S_IWUSR,0,elt) ) {
1193                             MgTAINTEDDIR_on(mg);
1194                             return 0;
1195                         }
1196                     }
1197                     if ((cp = strchr(elt, ':')) != NULL)
1198                         *cp = '\0';
1199                     if (my_trnlnm(elt, eltbuf, j++))
1200                         elt = eltbuf;
1201                     else
1202                         break;
1203                 }
1204                 j = 0;
1205             } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1206         }
1207 #endif /* VMS */
1208         if (s && klen == 4 && strEQ(ptr,"PATH")) {
1209             const char * const strend = s + len;
1210
1211             while (s < strend) {
1212                 char tmpbuf[256];
1213                 Stat_t st;
1214                 I32 i;
1215 #ifdef VMS  /* Hmm.  How do we get $Config{path_sep} from C? */
1216                 const char path_sep = '|';
1217 #else
1218                 const char path_sep = ':';
1219 #endif
1220                 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1221                              s, strend, path_sep, &i);
1222                 s++;
1223                 if (i >= (I32)sizeof tmpbuf   /* too long -- assume the worst */
1224 #ifdef VMS
1225                       || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1226 #else
1227                       || *tmpbuf != '/'       /* no starting slash -- assume relative path */
1228 #endif
1229                       || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1230                     MgTAINTEDDIR_on(mg);
1231                     return 0;
1232                 }
1233             }
1234         }
1235     }
1236 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1237
1238     return 0;
1239 }
1240
1241 int
1242 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1243 {
1244     PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1245     PERL_UNUSED_ARG(sv);
1246     my_setenv(MgPV_nolen_const(mg),NULL);
1247     return 0;
1248 }
1249
1250 int
1251 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1252 {
1253     dVAR;
1254     PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1255     PERL_UNUSED_ARG(mg);
1256 #if defined(VMS)
1257     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1258 #else
1259     if (PL_localizing) {
1260         HE* entry;
1261         my_clearenv();
1262         hv_iterinit(MUTABLE_HV(sv));
1263         while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1264             I32 keylen;
1265             my_setenv(hv_iterkey(entry, &keylen),
1266                       SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1267         }
1268     }
1269 #endif
1270     return 0;
1271 }
1272
1273 int
1274 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1275 {
1276     dVAR;
1277     PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1278     PERL_UNUSED_ARG(sv);
1279     PERL_UNUSED_ARG(mg);
1280 #if defined(VMS)
1281     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1282 #else
1283     my_clearenv();
1284 #endif
1285     return 0;
1286 }
1287
1288 #ifndef PERL_MICRO
1289 #ifdef HAS_SIGPROCMASK
1290 static void
1291 restore_sigmask(pTHX_ SV *save_sv)
1292 {
1293     const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1294     (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1295 }
1296 #endif
1297 int
1298 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1299 {
1300     dVAR;
1301     /* Are we fetching a signal entry? */
1302     int i = (I16)mg->mg_private;
1303
1304     PERL_ARGS_ASSERT_MAGIC_GETSIG;
1305
1306     if (!i) {
1307         mg->mg_private = i = whichsig(MgPV_nolen_const(mg));
1308     }
1309
1310     if (i > 0) {
1311         if(PL_psig_ptr[i])
1312             sv_setsv(sv,PL_psig_ptr[i]);
1313         else {
1314             Sighandler_t sigstate = rsignal_state(i);
1315 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1316             if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1317                 sigstate = SIG_IGN;
1318 #endif
1319 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1320             if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1321                 sigstate = SIG_DFL;
1322 #endif
1323             /* cache state so we don't fetch it again */
1324             if(sigstate == (Sighandler_t) SIG_IGN)
1325                 sv_setpvs(sv,"IGNORE");
1326             else
1327                 sv_setsv(sv,&PL_sv_undef);
1328             PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1329             SvTEMP_off(sv);
1330         }
1331     }
1332     return 0;
1333 }
1334 int
1335 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1336 {
1337     PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1338     PERL_UNUSED_ARG(sv);
1339
1340     magic_setsig(NULL, mg);
1341     return sv_unmagic(sv, mg->mg_type);
1342 }
1343
1344 Signal_t
1345 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1346 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1347 #else
1348 Perl_csighandler(int sig)
1349 #endif
1350 {
1351 #ifdef PERL_GET_SIG_CONTEXT
1352     dTHXa(PERL_GET_SIG_CONTEXT);
1353 #else
1354     dTHX;
1355 #endif
1356 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1357     (void) rsignal(sig, PL_csighandlerp);
1358     if (PL_sig_ignoring[sig]) return;
1359 #endif
1360 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1361     if (PL_sig_defaulting[sig])
1362 #ifdef KILL_BY_SIGPRC
1363             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1364 #else
1365             exit(1);
1366 #endif
1367 #endif
1368     if (
1369 #ifdef SIGILL
1370            sig == SIGILL ||
1371 #endif
1372 #ifdef SIGBUS
1373            sig == SIGBUS ||
1374 #endif
1375 #ifdef SIGSEGV
1376            sig == SIGSEGV ||
1377 #endif
1378            (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1379         /* Call the perl level handler now--
1380          * with risk we may be in malloc() or being destructed etc. */
1381 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1382         (*PL_sighandlerp)(sig, NULL, NULL);
1383 #else
1384         (*PL_sighandlerp)(sig);
1385 #endif
1386     else {
1387         if (!PL_psig_pend) return;
1388         /* Set a flag to say this signal is pending, that is awaiting delivery after
1389          * the current Perl opcode completes */
1390         PL_psig_pend[sig]++;
1391
1392 #ifndef SIG_PENDING_DIE_COUNT
1393 #  define SIG_PENDING_DIE_COUNT 120
1394 #endif
1395         /* Add one to say _a_ signal is pending */
1396         if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1397             Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1398                        (unsigned long)SIG_PENDING_DIE_COUNT);
1399     }
1400 }
1401
1402 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1403 void
1404 Perl_csighandler_init(void)
1405 {
1406     int sig;
1407     if (PL_sig_handlers_initted) return;
1408
1409     for (sig = 1; sig < SIG_SIZE; sig++) {
1410 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1411         dTHX;
1412         PL_sig_defaulting[sig] = 1;
1413         (void) rsignal(sig, PL_csighandlerp);
1414 #endif
1415 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1416         PL_sig_ignoring[sig] = 0;
1417 #endif
1418     }
1419     PL_sig_handlers_initted = 1;
1420 }
1421 #endif
1422
1423 void
1424 Perl_despatch_signals(pTHX)
1425 {
1426     dVAR;
1427     int sig;
1428     PL_sig_pending = 0;
1429     for (sig = 1; sig < SIG_SIZE; sig++) {
1430         if (PL_psig_pend[sig]) {
1431             dSAVE_ERRNO;
1432             PERL_BLOCKSIG_ADD(set, sig);
1433             PL_psig_pend[sig] = 0;
1434             PERL_BLOCKSIG_BLOCK(set);
1435 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1436             (*PL_sighandlerp)(sig, NULL, NULL);
1437 #else
1438             (*PL_sighandlerp)(sig);
1439 #endif
1440             PERL_BLOCKSIG_UNBLOCK(set);
1441             RESTORE_ERRNO;
1442         }
1443     }
1444 }
1445
1446 /* sv of NULL signifies that we're acting as magic_clearsig.  */
1447 int
1448 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1449 {
1450     dVAR;
1451     I32 i;
1452     SV** svp = NULL;
1453     /* Need to be careful with SvREFCNT_dec(), because that can have side
1454      * effects (due to closures). We must make sure that the new disposition
1455      * is in place before it is called.
1456      */
1457     SV* to_dec = NULL;
1458     STRLEN len;
1459 #ifdef HAS_SIGPROCMASK
1460     sigset_t set, save;
1461     SV* save_sv;
1462 #endif
1463     register const char *s = MgPV_const(mg,len);
1464
1465     PERL_ARGS_ASSERT_MAGIC_SETSIG;
1466
1467     if (*s == '_') {
1468         if (strEQ(s,"__DIE__"))
1469             svp = &PL_diehook;
1470         else if (strEQ(s,"__WARN__")
1471                  && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1472             /* Merge the existing behaviours, which are as follows:
1473                magic_setsig, we always set svp to &PL_warnhook
1474                (hence we always change the warnings handler)
1475                For magic_clearsig, we don't change the warnings handler if it's
1476                set to the &PL_warnhook.  */
1477             svp = &PL_warnhook;
1478         } else if (sv)
1479             Perl_croak(aTHX_ "No such hook: %s", s);
1480         i = 0;
1481         if (svp && *svp) {
1482             if (*svp != PERL_WARNHOOK_FATAL)
1483                 to_dec = *svp;
1484             *svp = NULL;
1485         }
1486     }
1487     else {
1488         i = (I16)mg->mg_private;
1489         if (!i) {
1490             i = whichsig(s);    /* ...no, a brick */
1491             mg->mg_private = (U16)i;
1492         }
1493         if (i <= 0) {
1494             if (sv)
1495                 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1496             return 0;
1497         }
1498 #ifdef HAS_SIGPROCMASK
1499         /* Avoid having the signal arrive at a bad time, if possible. */
1500         sigemptyset(&set);
1501         sigaddset(&set,i);
1502         sigprocmask(SIG_BLOCK, &set, &save);
1503         ENTER;
1504         save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1505         SAVEFREESV(save_sv);
1506         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1507 #endif
1508         PERL_ASYNC_CHECK();
1509 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1510         if (!PL_sig_handlers_initted) Perl_csighandler_init();
1511 #endif
1512 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1513         PL_sig_ignoring[i] = 0;
1514 #endif
1515 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1516         PL_sig_defaulting[i] = 0;
1517 #endif
1518         to_dec = PL_psig_ptr[i];
1519         if (sv) {
1520             PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1521             SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1522
1523             /* Signals don't change name during the program's execution, so once
1524                they're cached in the appropriate slot of PL_psig_name, they can
1525                stay there.
1526
1527                Ideally we'd find some way of making SVs at (C) compile time, or
1528                at least, doing most of the work.  */
1529             if (!PL_psig_name[i]) {
1530                 PL_psig_name[i] = newSVpvn(s, len);
1531                 SvREADONLY_on(PL_psig_name[i]);
1532             }
1533         } else {
1534             SvREFCNT_dec(PL_psig_name[i]);
1535             PL_psig_name[i] = NULL;
1536             PL_psig_ptr[i] = NULL;
1537         }
1538     }
1539     if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1540         if (i) {
1541             (void)rsignal(i, PL_csighandlerp);
1542         }
1543         else
1544             *svp = SvREFCNT_inc_simple_NN(sv);
1545     } else {
1546         if (sv && SvOK(sv)) {
1547             s = SvPV_force(sv, len);
1548         } else {
1549             sv = NULL;
1550         }
1551         if (sv && strEQ(s,"IGNORE")) {
1552             if (i) {
1553 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1554                 PL_sig_ignoring[i] = 1;
1555                 (void)rsignal(i, PL_csighandlerp);
1556 #else
1557                 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1558 #endif
1559             }
1560         }
1561         else if (!sv || strEQ(s,"DEFAULT") || !len) {
1562             if (i) {
1563 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1564                 PL_sig_defaulting[i] = 1;
1565                 (void)rsignal(i, PL_csighandlerp);
1566 #else
1567                 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1568 #endif
1569             }
1570         }
1571         else {
1572             /*
1573              * We should warn if HINT_STRICT_REFS, but without
1574              * access to a known hint bit in a known OP, we can't
1575              * tell whether HINT_STRICT_REFS is in force or not.
1576              */
1577             if (!strchr(s,':') && !strchr(s,'\''))
1578                 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1579                                      SV_GMAGIC);
1580             if (i)
1581                 (void)rsignal(i, PL_csighandlerp);
1582             else
1583                 *svp = SvREFCNT_inc_simple_NN(sv);
1584         }
1585     }
1586
1587 #ifdef HAS_SIGPROCMASK
1588     if(i)
1589         LEAVE;
1590 #endif
1591     SvREFCNT_dec(to_dec);
1592     return 0;
1593 }
1594 #endif /* !PERL_MICRO */
1595
1596 int
1597 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1598 {
1599     dVAR;
1600     PERL_ARGS_ASSERT_MAGIC_SETISA;
1601     PERL_UNUSED_ARG(sv);
1602
1603     /* Skip _isaelem because _isa will handle it shortly */
1604     if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1605         return 0;
1606
1607     return magic_clearisa(NULL, mg);
1608 }
1609
1610 /* sv of NULL signifies that we're acting as magic_setisa.  */
1611 int
1612 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1613 {
1614     dVAR;
1615     HV* stash;
1616
1617     PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1618
1619     /* Bail out if destruction is going on */
1620     if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1621
1622     if (sv)
1623         av_clear(MUTABLE_AV(sv));
1624
1625     if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1626         /* This occurs with setisa_elem magic, which calls this
1627            same function. */
1628         mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1629
1630     if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1631         SV **svp = AvARRAY((AV *)mg->mg_obj);
1632         I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1633         while (items--) {
1634             stash = GvSTASH((GV *)*svp++);
1635             if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1636         }
1637
1638         return 0;
1639     }
1640
1641     stash = GvSTASH(
1642         (const GV *)mg->mg_obj
1643     );
1644
1645     /* The stash may have been detached from the symbol table, so check its
1646        name before doing anything. */
1647     if (stash && HvENAME_get(stash))
1648         mro_isa_changed_in(stash);
1649
1650     return 0;
1651 }
1652
1653 int
1654 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1655 {
1656     dVAR;
1657     PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1658     PERL_UNUSED_ARG(sv);
1659     PERL_UNUSED_ARG(mg);
1660     PL_amagic_generation++;
1661
1662     return 0;
1663 }
1664
1665 int
1666 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1667 {
1668     HV * const hv = MUTABLE_HV(LvTARG(sv));
1669     I32 i = 0;
1670
1671     PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1672     PERL_UNUSED_ARG(mg);
1673
1674     if (hv) {
1675          (void) hv_iterinit(hv);
1676          if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1677              i = HvKEYS(hv);
1678          else {
1679              while (hv_iternext(hv))
1680                  i++;
1681          }
1682     }
1683
1684     sv_setiv(sv, (IV)i);
1685     return 0;
1686 }
1687
1688 int
1689 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1690 {
1691     PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1692     PERL_UNUSED_ARG(mg);
1693     if (LvTARG(sv)) {
1694         hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1695     }
1696     return 0;
1697 }
1698
1699 /*
1700 =for apidoc magic_methcall
1701
1702 Invoke a magic method (like FETCH).
1703
1704 * sv and mg are the tied thinggy and the tie magic;
1705 * meth is the name of the method to call;
1706 * argc is the number of args (in addition to $self) to pass to the method;
1707        the args themselves are any values following the argc argument.
1708 * flags:
1709     G_DISCARD:     invoke method with G_DISCARD flag and don't return a value
1710     G_UNDEF_FILL:  fill the stack with argc pointers to PL_sv_undef.
1711
1712 Returns the SV (if any) returned by the method, or NULL on failure.
1713
1714
1715 =cut
1716 */
1717
1718 SV*
1719 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1720                     U32 argc, ...)
1721 {
1722     dVAR;
1723     dSP;
1724     SV* ret = NULL;
1725
1726     PERL_ARGS_ASSERT_MAGIC_METHCALL;
1727
1728     ENTER;
1729     PUSHSTACKi(PERLSI_MAGIC);
1730     PUSHMARK(SP);
1731
1732     EXTEND(SP, argc+1);
1733     PUSHs(SvTIED_obj(sv, mg));
1734     if (flags & G_UNDEF_FILL) {
1735         while (argc--) {
1736             PUSHs(&PL_sv_undef);
1737         }
1738     } else if (argc > 0) {
1739         va_list args;
1740         va_start(args, argc);
1741
1742         do {
1743             SV *const sv = va_arg(args, SV *);
1744             PUSHs(sv);
1745         } while (--argc);
1746
1747         va_end(args);
1748     }
1749     PUTBACK;
1750     if (flags & G_DISCARD) {
1751         call_method(meth, G_SCALAR|G_DISCARD);
1752     }
1753     else {
1754         if (call_method(meth, G_SCALAR))
1755             ret = *PL_stack_sp--;
1756     }
1757     POPSTACK;
1758     LEAVE;
1759     return ret;
1760 }
1761
1762
1763 /* wrapper for magic_methcall that creates the first arg */
1764
1765 STATIC SV*
1766 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1767     int n, SV *val)
1768 {
1769     dVAR;
1770     SV* arg1 = NULL;
1771
1772     PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1773
1774     if (mg->mg_ptr) {
1775         if (mg->mg_len >= 0) {
1776             arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1777         }
1778         else if (mg->mg_len == HEf_SVKEY)
1779             arg1 = MUTABLE_SV(mg->mg_ptr);
1780     }
1781     else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1782         arg1 = newSViv((IV)(mg->mg_len));
1783         sv_2mortal(arg1);
1784     }
1785     if (!arg1) {
1786         return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1787     }
1788     return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1789 }
1790
1791 STATIC int
1792 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1793 {
1794     dVAR;
1795     SV* ret;
1796
1797     PERL_ARGS_ASSERT_MAGIC_METHPACK;
1798
1799     ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1800     if (ret)
1801         sv_setsv(sv, ret);
1802     return 0;
1803 }
1804
1805 int
1806 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1807 {
1808     PERL_ARGS_ASSERT_MAGIC_GETPACK;
1809
1810     if (mg->mg_type == PERL_MAGIC_tiedelem)
1811         mg->mg_flags |= MGf_GSKIP;
1812     magic_methpack(sv,mg,"FETCH");
1813     return 0;
1814 }
1815
1816 int
1817 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1818 {
1819     dVAR;
1820     MAGIC *tmg;
1821     SV    *val;
1822
1823     PERL_ARGS_ASSERT_MAGIC_SETPACK;
1824
1825     /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1826      * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1827      * public flags indicate its value based on copying from $val. Doing
1828      * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1829      * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1830      * wrong if $val happened to be tainted, as sv hasn't got magic
1831      * enabled, even though taint magic is in the chain. In which case,
1832      * fake up a temporary tainted value (this is easier than temporarily
1833      * re-enabling magic on sv). */
1834
1835     if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
1836         && (tmg->mg_len & 1))
1837     {
1838         val = sv_mortalcopy(sv);
1839         SvTAINTED_on(val);
1840     }
1841     else
1842         val = sv;
1843
1844     magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
1845     return 0;
1846 }
1847
1848 int
1849 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1850 {
1851     PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1852
1853     return magic_methpack(sv,mg,"DELETE");
1854 }
1855
1856
1857 U32
1858 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1859 {
1860     dVAR;
1861     I32 retval = 0;
1862     SV* retsv;
1863
1864     PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1865
1866     retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
1867     if (retsv) {
1868         retval = SvIV(retsv)-1;
1869         if (retval < -1)
1870             Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1871     }
1872     return (U32) retval;
1873 }
1874
1875 int
1876 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1877 {
1878     dVAR;
1879
1880     PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1881
1882     Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
1883     return 0;
1884 }
1885
1886 int
1887 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1888 {
1889     dVAR;
1890     SV* ret;
1891
1892     PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1893
1894     ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
1895         : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
1896     if (ret)
1897         sv_setsv(key,ret);
1898     return 0;
1899 }
1900
1901 int
1902 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1903 {
1904     PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1905
1906     return magic_methpack(sv,mg,"EXISTS");
1907 }
1908
1909 SV *
1910 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1911 {
1912     dVAR;
1913     SV *retval;
1914     SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1915     HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1916
1917     PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1918
1919     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1920         SV *key;
1921         if (HvEITER_get(hv))
1922             /* we are in an iteration so the hash cannot be empty */
1923             return &PL_sv_yes;
1924         /* no xhv_eiter so now use FIRSTKEY */
1925         key = sv_newmortal();
1926         magic_nextpack(MUTABLE_SV(hv), mg, key);
1927         HvEITER_set(hv, NULL);     /* need to reset iterator */
1928         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1929     }
1930
1931     /* there is a SCALAR method that we can call */
1932     retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
1933     if (!retval)
1934         retval = &PL_sv_undef;
1935     return retval;
1936 }
1937
1938 int
1939 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1940 {
1941     dVAR;
1942     GV * const gv = PL_DBline;
1943     const I32 i = SvTRUE(sv);
1944     SV ** const svp = av_fetch(GvAV(gv),
1945                      atoi(MgPV_nolen_const(mg)), FALSE);
1946
1947     PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1948
1949     if (svp && SvIOKp(*svp)) {
1950         OP * const o = INT2PTR(OP*,SvIVX(*svp));
1951         if (o) {
1952             /* set or clear breakpoint in the relevant control op */
1953             if (i)
1954                 o->op_flags |= OPf_SPECIAL;
1955             else
1956                 o->op_flags &= ~OPf_SPECIAL;
1957         }
1958     }
1959     return 0;
1960 }
1961
1962 int
1963 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1964 {
1965     dVAR;
1966     AV * const obj = MUTABLE_AV(mg->mg_obj);
1967
1968     PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1969
1970     if (obj) {
1971         sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1972     } else {
1973         SvOK_off(sv);
1974     }
1975     return 0;
1976 }
1977
1978 int
1979 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1980 {
1981     dVAR;
1982     AV * const obj = MUTABLE_AV(mg->mg_obj);
1983
1984     PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1985
1986     if (obj) {
1987         av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1988     } else {
1989         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1990                        "Attempt to set length of freed array");
1991     }
1992     return 0;
1993 }
1994
1995 int
1996 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1997 {
1998     dVAR;
1999
2000     PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2001     PERL_UNUSED_ARG(sv);
2002
2003     /* during global destruction, mg_obj may already have been freed */
2004     if (PL_in_clean_all)
2005         return 0;
2006
2007     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2008
2009     if (mg) {
2010         /* arylen scalar holds a pointer back to the array, but doesn't own a
2011            reference. Hence the we (the array) are about to go away with it
2012            still pointing at us. Clear its pointer, else it would be pointing
2013            at free memory. See the comment in sv_magic about reference loops,
2014            and why it can't own a reference to us.  */
2015         mg->mg_obj = 0;
2016     }
2017     return 0;
2018 }
2019
2020 int
2021 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2022 {
2023     dVAR;
2024     SV* const lsv = LvTARG(sv);
2025
2026     PERL_ARGS_ASSERT_MAGIC_GETPOS;
2027     PERL_UNUSED_ARG(mg);
2028
2029     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
2030         MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
2031         if (found && found->mg_len >= 0) {
2032             I32 i = found->mg_len;
2033             if (DO_UTF8(lsv))
2034                 sv_pos_b2u(lsv, &i);
2035             sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
2036             return 0;
2037         }
2038     }
2039     SvOK_off(sv);
2040     return 0;
2041 }
2042
2043 int
2044 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2045 {
2046     dVAR;
2047     SV* const lsv = LvTARG(sv);
2048     SSize_t pos;
2049     STRLEN len;
2050     STRLEN ulen = 0;
2051     MAGIC* found;
2052
2053     PERL_ARGS_ASSERT_MAGIC_SETPOS;
2054     PERL_UNUSED_ARG(mg);
2055
2056     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2057         found = mg_find(lsv, PERL_MAGIC_regex_global);
2058     else
2059         found = NULL;
2060     if (!found) {
2061         if (!SvOK(sv))
2062             return 0;
2063 #ifdef PERL_OLD_COPY_ON_WRITE
2064     if (SvIsCOW(lsv))
2065         sv_force_normal_flags(lsv, 0);
2066 #endif
2067         found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2068                             NULL, 0);
2069     }
2070     else if (!SvOK(sv)) {
2071         found->mg_len = -1;
2072         return 0;
2073     }
2074     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2075
2076     pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
2077
2078     if (DO_UTF8(lsv)) {
2079         ulen = sv_len_utf8(lsv);
2080         if (ulen)
2081             len = ulen;
2082     }
2083
2084     if (pos < 0) {
2085         pos += len;
2086         if (pos < 0)
2087             pos = 0;
2088     }
2089     else if (pos > (SSize_t)len)
2090         pos = len;
2091
2092     if (ulen) {
2093         I32 p = pos;
2094         sv_pos_u2b(lsv, &p, 0);
2095         pos = p;
2096     }
2097
2098     found->mg_len = pos;
2099     found->mg_flags &= ~MGf_MINMATCH;
2100
2101     return 0;
2102 }
2103
2104 int
2105 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2106 {
2107     STRLEN len;
2108     SV * const lsv = LvTARG(sv);
2109     const char * const tmps = SvPV_const(lsv,len);
2110     STRLEN offs = LvTARGOFF(sv);
2111     STRLEN rem = LvTARGLEN(sv);
2112
2113     PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2114     PERL_UNUSED_ARG(mg);
2115
2116     if (SvUTF8(lsv))
2117         offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
2118     if (offs > len)
2119         offs = len;
2120     if (rem > len - offs)
2121         rem = len - offs;
2122     sv_setpvn(sv, tmps + offs, rem);
2123     if (SvUTF8(lsv))
2124         SvUTF8_on(sv);
2125     return 0;
2126 }
2127
2128 int
2129 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2130 {
2131     dVAR;
2132     STRLEN len;
2133     const char * const tmps = SvPV_const(sv, len);
2134     SV * const lsv = LvTARG(sv);
2135     STRLEN lvoff = LvTARGOFF(sv);
2136     STRLEN lvlen = LvTARGLEN(sv);
2137
2138     PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2139     PERL_UNUSED_ARG(mg);
2140
2141     if (DO_UTF8(sv)) {
2142         sv_utf8_upgrade(lsv);
2143         lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2144         sv_insert(lsv, lvoff, lvlen, tmps, len);
2145         LvTARGLEN(sv) = sv_len_utf8(sv);
2146         SvUTF8_on(lsv);
2147     }
2148     else if (lsv && SvUTF8(lsv)) {
2149         const char *utf8;
2150         lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2151         LvTARGLEN(sv) = len;
2152         utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2153         sv_insert(lsv, lvoff, lvlen, utf8, len);
2154         Safefree(utf8);
2155     }
2156     else {
2157         sv_insert(lsv, lvoff, lvlen, tmps, len);
2158         LvTARGLEN(sv) = len;
2159     }
2160
2161     return 0;
2162 }
2163
2164 int
2165 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2166 {
2167     dVAR;
2168
2169     PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2170     PERL_UNUSED_ARG(sv);
2171
2172     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2173     return 0;
2174 }
2175
2176 int
2177 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2178 {
2179     dVAR;
2180
2181     PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2182     PERL_UNUSED_ARG(sv);
2183
2184     /* update taint status */
2185     if (PL_tainted)
2186         mg->mg_len |= 1;
2187     else
2188         mg->mg_len &= ~1;
2189     return 0;
2190 }
2191
2192 int
2193 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2194 {
2195     SV * const lsv = LvTARG(sv);
2196
2197     PERL_ARGS_ASSERT_MAGIC_GETVEC;
2198     PERL_UNUSED_ARG(mg);
2199
2200     if (lsv)
2201         sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2202     else
2203         SvOK_off(sv);
2204
2205     return 0;
2206 }
2207
2208 int
2209 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2210 {
2211     PERL_ARGS_ASSERT_MAGIC_SETVEC;
2212     PERL_UNUSED_ARG(mg);
2213     do_vecset(sv);      /* XXX slurp this routine */
2214     return 0;
2215 }
2216
2217 int
2218 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2219 {
2220     dVAR;
2221     SV *targ = NULL;
2222
2223     PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2224
2225     if (LvTARGLEN(sv)) {
2226         if (mg->mg_obj) {
2227             SV * const ahv = LvTARG(sv);
2228             HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2229             if (he)
2230                 targ = HeVAL(he);
2231         }
2232         else {
2233             AV *const av = MUTABLE_AV(LvTARG(sv));
2234             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2235                 targ = AvARRAY(av)[LvTARGOFF(sv)];
2236         }
2237         if (targ && (targ != &PL_sv_undef)) {
2238             /* somebody else defined it for us */
2239             SvREFCNT_dec(LvTARG(sv));
2240             LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2241             LvTARGLEN(sv) = 0;
2242             SvREFCNT_dec(mg->mg_obj);
2243             mg->mg_obj = NULL;
2244             mg->mg_flags &= ~MGf_REFCOUNTED;
2245         }
2246     }
2247     else
2248         targ = LvTARG(sv);
2249     sv_setsv(sv, targ ? targ : &PL_sv_undef);
2250     return 0;
2251 }
2252
2253 int
2254 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2255 {
2256     PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2257     PERL_UNUSED_ARG(mg);
2258     if (LvTARGLEN(sv))
2259         vivify_defelem(sv);
2260     if (LvTARG(sv)) {
2261         sv_setsv(LvTARG(sv), sv);
2262         SvSETMAGIC(LvTARG(sv));
2263     }
2264     return 0;
2265 }
2266
2267 void
2268 Perl_vivify_defelem(pTHX_ SV *sv)
2269 {
2270     dVAR;
2271     MAGIC *mg;
2272     SV *value = NULL;
2273
2274     PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2275
2276     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2277         return;
2278     if (mg->mg_obj) {
2279         SV * const ahv = LvTARG(sv);
2280         HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2281         if (he)
2282             value = HeVAL(he);
2283         if (!value || value == &PL_sv_undef)
2284             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2285     }
2286     else {
2287         AV *const av = MUTABLE_AV(LvTARG(sv));
2288         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2289             LvTARG(sv) = NULL;  /* array can't be extended */
2290         else {
2291             SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2292             if (!svp || (value = *svp) == &PL_sv_undef)
2293                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2294         }
2295     }
2296     SvREFCNT_inc_simple_void(value);
2297     SvREFCNT_dec(LvTARG(sv));
2298     LvTARG(sv) = value;
2299     LvTARGLEN(sv) = 0;
2300     SvREFCNT_dec(mg->mg_obj);
2301     mg->mg_obj = NULL;
2302     mg->mg_flags &= ~MGf_REFCOUNTED;
2303 }
2304
2305 int
2306 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2307 {
2308     PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2309     Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2310     return 0;
2311 }
2312
2313 int
2314 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2315 {
2316     PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2317     PERL_UNUSED_CONTEXT;
2318     mg->mg_len = -1;
2319     if (!isGV_with_GP(sv))
2320         SvSCREAM_off(sv);
2321     return 0;
2322 }
2323
2324 int
2325 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2326 {
2327     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2328
2329     PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2330
2331     if (uf && uf->uf_set)
2332         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2333     return 0;
2334 }
2335
2336 int
2337 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2338 {
2339     const char type = mg->mg_type;
2340
2341     PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2342
2343     if (type == PERL_MAGIC_qr) {
2344     } else if (type == PERL_MAGIC_bm) {
2345         SvTAIL_off(sv);
2346         SvVALID_off(sv);
2347     } else {
2348         assert(type == PERL_MAGIC_fm);
2349         SvCOMPILED_off(sv);
2350     }
2351     return sv_unmagic(sv, type);
2352 }
2353
2354 #ifdef USE_LOCALE_COLLATE
2355 int
2356 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2357 {
2358     PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2359
2360     /*
2361      * RenE<eacute> Descartes said "I think not."
2362      * and vanished with a faint plop.
2363      */
2364     PERL_UNUSED_CONTEXT;
2365     PERL_UNUSED_ARG(sv);
2366     if (mg->mg_ptr) {
2367         Safefree(mg->mg_ptr);
2368         mg->mg_ptr = NULL;
2369         mg->mg_len = -1;
2370     }
2371     return 0;
2372 }
2373 #endif /* USE_LOCALE_COLLATE */
2374
2375 /* Just clear the UTF-8 cache data. */
2376 int
2377 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2378 {
2379     PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2380     PERL_UNUSED_CONTEXT;
2381     PERL_UNUSED_ARG(sv);
2382     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2383     mg->mg_ptr = NULL;
2384     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2385     return 0;
2386 }
2387
2388 int
2389 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2390 {
2391     dVAR;
2392     register const char *s;
2393     register I32 paren;
2394     register const REGEXP * rx;
2395     const char * const remaining = mg->mg_ptr + 1;
2396     I32 i;
2397     STRLEN len;
2398
2399     PERL_ARGS_ASSERT_MAGIC_SET;
2400
2401     switch (*mg->mg_ptr) {
2402     case '\015': /* $^MATCH */
2403       if (strEQ(remaining, "ATCH"))
2404           goto do_match;
2405     case '`': /* ${^PREMATCH} caught below */
2406       do_prematch:
2407       paren = RX_BUFF_IDX_PREMATCH;
2408       goto setparen;
2409     case '\'': /* ${^POSTMATCH} caught below */
2410       do_postmatch:
2411       paren = RX_BUFF_IDX_POSTMATCH;
2412       goto setparen;
2413     case '&':
2414       do_match:
2415       paren = RX_BUFF_IDX_FULLMATCH;
2416       goto setparen;
2417     case '1': case '2': case '3': case '4':
2418     case '5': case '6': case '7': case '8': case '9':
2419       paren = atoi(mg->mg_ptr);
2420       setparen:
2421         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2422             CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2423         } else {
2424             /* Croak with a READONLY error when a numbered match var is
2425              * set without a previous pattern match. Unless it's C<local $1>
2426              */
2427             if (!PL_localizing) {
2428                 Perl_croak_no_modify(aTHX);
2429             }
2430         }
2431         break;
2432     case '\001':        /* ^A */
2433         sv_setsv(PL_bodytarget, sv);
2434         break;
2435     case '\003':        /* ^C */
2436         PL_minus_c = cBOOL(SvIV(sv));
2437         break;
2438
2439     case '\004':        /* ^D */
2440 #ifdef DEBUGGING
2441         s = SvPV_nolen_const(sv);
2442         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2443         if (DEBUG_x_TEST || DEBUG_B_TEST)
2444             dump_all_perl(!DEBUG_B_TEST);
2445 #else
2446         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2447 #endif
2448         break;
2449     case '\005':  /* ^E */
2450         if (*(mg->mg_ptr+1) == '\0') {
2451 #ifdef VMS
2452             set_vaxc_errno(SvIV(sv));
2453 #else
2454 #  ifdef WIN32
2455             SetLastError( SvIV(sv) );
2456 #  else
2457 #    ifdef OS2
2458             os2_setsyserrno(SvIV(sv));
2459 #    else
2460             /* will anyone ever use this? */
2461             SETERRNO(SvIV(sv), 4);
2462 #    endif
2463 #  endif
2464 #endif
2465         }
2466         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2467             SvREFCNT_dec(PL_encoding);
2468             if (SvOK(sv) || SvGMAGICAL(sv)) {
2469                 PL_encoding = newSVsv(sv);
2470             }
2471             else {
2472                 PL_encoding = NULL;
2473             }
2474         }
2475         break;
2476     case '\006':        /* ^F */
2477         PL_maxsysfd = SvIV(sv);
2478         break;
2479     case '\010':        /* ^H */
2480         PL_hints = SvIV(sv);
2481         break;
2482     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2483         Safefree(PL_inplace);
2484         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2485         break;
2486     case '\017':        /* ^O */
2487         if (*(mg->mg_ptr+1) == '\0') {
2488             Safefree(PL_osname);
2489             PL_osname = NULL;
2490             if (SvOK(sv)) {
2491                 TAINT_PROPER("assigning to $^O");
2492                 PL_osname = savesvpv(sv);
2493             }
2494         }
2495         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2496             STRLEN len;
2497             const char *const start = SvPV(sv, len);
2498             const char *out = (const char*)memchr(start, '\0', len);
2499             SV *tmp;
2500
2501
2502             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2503             PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2504
2505             /* Opening for input is more common than opening for output, so
2506                ensure that hints for input are sooner on linked list.  */
2507             tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2508                                        SvUTF8(sv))
2509                 : newSVpvs_flags("", SvUTF8(sv));
2510             (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2511             mg_set(tmp);
2512
2513             tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2514                                         SvUTF8(sv));
2515             (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2516             mg_set(tmp);
2517         }
2518         break;
2519     case '\020':        /* ^P */
2520       if (*remaining == '\0') { /* ^P */
2521           PL_perldb = SvIV(sv);
2522           if (PL_perldb && !PL_DBsingle)
2523               init_debugger();
2524           break;
2525       } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2526           goto do_prematch;
2527       } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2528           goto do_postmatch;
2529       }
2530       break;
2531     case '\024':        /* ^T */
2532 #ifdef BIG_TIME
2533         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2534 #else
2535         PL_basetime = (Time_t)SvIV(sv);
2536 #endif
2537         break;
2538     case '\025':        /* ^UTF8CACHE */
2539          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2540              PL_utf8cache = (signed char) sv_2iv(sv);
2541          }
2542          break;
2543     case '\027':        /* ^W & $^WARNING_BITS */
2544         if (*(mg->mg_ptr+1) == '\0') {
2545             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2546                 i = SvIV(sv);
2547                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2548                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2549             }
2550         }
2551         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2552             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2553                 if (!SvPOK(sv) && PL_localizing) {
2554                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2555                     PL_compiling.cop_warnings = pWARN_NONE;
2556                     break;
2557                 }
2558                 {
2559                     STRLEN len, i;
2560                     int accumulate = 0 ;
2561                     int any_fatals = 0 ;
2562                     const char * const ptr = SvPV_const(sv, len) ;
2563                     for (i = 0 ; i < len ; ++i) {
2564                         accumulate |= ptr[i] ;
2565                         any_fatals |= (ptr[i] & 0xAA) ;
2566                     }
2567                     if (!accumulate) {
2568                         if (!specialWARN(PL_compiling.cop_warnings))
2569                             PerlMemShared_free(PL_compiling.cop_warnings);
2570                         PL_compiling.cop_warnings = pWARN_NONE;
2571                     }
2572                     /* Yuck. I can't see how to abstract this:  */
2573                     else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2574                                        WARN_ALL) && !any_fatals) {
2575                         if (!specialWARN(PL_compiling.cop_warnings))
2576                             PerlMemShared_free(PL_compiling.cop_warnings);
2577                         PL_compiling.cop_warnings = pWARN_ALL;
2578                         PL_dowarn |= G_WARN_ONCE ;
2579                     }
2580                     else {
2581                         STRLEN len;
2582                         const char *const p = SvPV_const(sv, len);
2583
2584                         PL_compiling.cop_warnings
2585                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2586                                                          p, len);
2587
2588                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2589                             PL_dowarn |= G_WARN_ONCE ;
2590                     }
2591
2592                 }
2593             }
2594         }
2595         break;
2596     case '.':
2597         if (PL_localizing) {
2598             if (PL_localizing == 1)
2599                 SAVESPTR(PL_last_in_gv);
2600         }
2601         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2602             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2603         break;
2604     case '^':
2605         if (isGV_with_GP(PL_defoutgv)) {
2606             Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2607             s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2608             IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2609         }
2610         break;
2611     case '~':
2612         if (isGV_with_GP(PL_defoutgv)) {
2613             Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2614             s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2615             IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2616         }
2617         break;
2618     case '=':
2619         if (isGV_with_GP(PL_defoutgv))
2620             IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2621         break;
2622     case '-':
2623         if (isGV_with_GP(PL_defoutgv)) {
2624             IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2625             if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2626                 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2627         }
2628         break;
2629     case '%':
2630         if (isGV_with_GP(PL_defoutgv))
2631             IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2632         break;
2633     case '|':
2634         {
2635             IO * const io = GvIO(PL_defoutgv);
2636             if(!io)
2637               break;
2638             if ((SvIV(sv)) == 0)
2639                 IoFLAGS(io) &= ~IOf_FLUSH;
2640             else {
2641                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2642                     PerlIO *ofp = IoOFP(io);
2643                     if (ofp)
2644                         (void)PerlIO_flush(ofp);
2645                     IoFLAGS(io) |= IOf_FLUSH;
2646                 }
2647             }
2648         }
2649         break;
2650     case '/':
2651         SvREFCNT_dec(PL_rs);
2652         PL_rs = newSVsv(sv);
2653         break;
2654     case '\\':
2655         SvREFCNT_dec(PL_ors_sv);
2656         if (SvOK(sv) || SvGMAGICAL(sv)) {
2657             PL_ors_sv = newSVsv(sv);
2658         }
2659         else {
2660             PL_ors_sv = NULL;
2661         }
2662         break;
2663     case '[':
2664         CopARYBASE_set(&PL_compiling, SvIV(sv));
2665         break;
2666     case '?':
2667 #ifdef COMPLEX_STATUS
2668         if (PL_localizing == 2) {
2669             SvUPGRADE(sv, SVt_PVLV);
2670             PL_statusvalue = LvTARGOFF(sv);
2671             PL_statusvalue_vms = LvTARGLEN(sv);
2672         }
2673         else
2674 #endif
2675 #ifdef VMSISH_STATUS
2676         if (VMSISH_STATUS)
2677             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2678         else
2679 #endif
2680             STATUS_UNIX_EXIT_SET(SvIV(sv));
2681         break;
2682     case '!':
2683         {
2684 #ifdef VMS
2685 #   define PERL_VMS_BANG vaxc$errno
2686 #else
2687 #   define PERL_VMS_BANG 0
2688 #endif
2689         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2690                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2691         }
2692         break;
2693     case '<':
2694         PL_uid = SvIV(sv);
2695         if (PL_delaymagic) {
2696             PL_delaymagic |= DM_RUID;
2697             break;                              /* don't do magic till later */
2698         }
2699 #ifdef HAS_SETRUID
2700         (void)setruid((Uid_t)PL_uid);
2701 #else
2702 #ifdef HAS_SETREUID
2703         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2704 #else
2705 #ifdef HAS_SETRESUID
2706       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2707 #else
2708         if (PL_uid == PL_euid) {                /* special case $< = $> */
2709 #ifdef PERL_DARWIN
2710             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2711             if (PL_uid != 0 && PerlProc_getuid() == 0)
2712                 (void)PerlProc_setuid(0);
2713 #endif
2714             (void)PerlProc_setuid(PL_uid);
2715         } else {
2716             PL_uid = PerlProc_getuid();
2717             Perl_croak(aTHX_ "setruid() not implemented");
2718         }
2719 #endif
2720 #endif
2721 #endif
2722         PL_uid = PerlProc_getuid();
2723         break;
2724     case '>':
2725         PL_euid = SvIV(sv);
2726         if (PL_delaymagic) {
2727             PL_delaymagic |= DM_EUID;
2728             break;                              /* don't do magic till later */
2729         }
2730 #ifdef HAS_SETEUID
2731         (void)seteuid((Uid_t)PL_euid);
2732 #else
2733 #ifdef HAS_SETREUID
2734         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2735 #else
2736 #ifdef HAS_SETRESUID
2737         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2738 #else
2739         if (PL_euid == PL_uid)          /* special case $> = $< */
2740             PerlProc_setuid(PL_euid);
2741         else {
2742             PL_euid = PerlProc_geteuid();
2743             Perl_croak(aTHX_ "seteuid() not implemented");
2744         }
2745 #endif
2746 #endif
2747 #endif
2748         PL_euid = PerlProc_geteuid();
2749         break;
2750     case '(':
2751         PL_gid = SvIV(sv);
2752         if (PL_delaymagic) {
2753             PL_delaymagic |= DM_RGID;
2754             break;                              /* don't do magic till later */
2755         }
2756 #ifdef HAS_SETRGID
2757         (void)setrgid((Gid_t)PL_gid);
2758 #else
2759 #ifdef HAS_SETREGID
2760         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2761 #else
2762 #ifdef HAS_SETRESGID
2763       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2764 #else
2765         if (PL_gid == PL_egid)                  /* special case $( = $) */
2766             (void)PerlProc_setgid(PL_gid);
2767         else {
2768             PL_gid = PerlProc_getgid();
2769             Perl_croak(aTHX_ "setrgid() not implemented");
2770         }
2771 #endif
2772 #endif
2773 #endif
2774         PL_gid = PerlProc_getgid();
2775         break;
2776     case ')':
2777 #ifdef HAS_SETGROUPS
2778         {
2779             const char *p = SvPV_const(sv, len);
2780             Groups_t *gary = NULL;
2781 #ifdef _SC_NGROUPS_MAX
2782            int maxgrp = sysconf(_SC_NGROUPS_MAX);
2783
2784            if (maxgrp < 0)
2785                maxgrp = NGROUPS;
2786 #else
2787            int maxgrp = NGROUPS;
2788 #endif
2789
2790             while (isSPACE(*p))
2791                 ++p;
2792             PL_egid = Atol(p);
2793             for (i = 0; i < maxgrp; ++i) {
2794                 while (*p && !isSPACE(*p))
2795                     ++p;
2796                 while (isSPACE(*p))
2797                     ++p;
2798                 if (!*p)
2799                     break;
2800                 if(!gary)
2801                     Newx(gary, i + 1, Groups_t);
2802                 else
2803                     Renew(gary, i + 1, Groups_t);
2804                 gary[i] = Atol(p);
2805             }
2806             if (i)
2807                 (void)setgroups(i, gary);
2808             Safefree(gary);
2809         }
2810 #else  /* HAS_SETGROUPS */
2811         PL_egid = SvIV(sv);
2812 #endif /* HAS_SETGROUPS */
2813         if (PL_delaymagic) {
2814             PL_delaymagic |= DM_EGID;
2815             break;                              /* don't do magic till later */
2816         }
2817 #ifdef HAS_SETEGID
2818         (void)setegid((Gid_t)PL_egid);
2819 #else
2820 #ifdef HAS_SETREGID
2821         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2822 #else
2823 #ifdef HAS_SETRESGID
2824         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2825 #else
2826         if (PL_egid == PL_gid)                  /* special case $) = $( */
2827             (void)PerlProc_setgid(PL_egid);
2828         else {
2829             PL_egid = PerlProc_getegid();
2830             Perl_croak(aTHX_ "setegid() not implemented");
2831         }
2832 #endif
2833 #endif
2834 #endif
2835         PL_egid = PerlProc_getegid();
2836         break;
2837     case ':':
2838         PL_chopset = SvPV_force(sv,len);
2839         break;
2840     case '0':
2841         LOCK_DOLLARZERO_MUTEX;
2842 #ifdef HAS_SETPROCTITLE
2843         /* The BSDs don't show the argv[] in ps(1) output, they
2844          * show a string from the process struct and provide
2845          * the setproctitle() routine to manipulate that. */
2846         if (PL_origalen != 1) {
2847             s = SvPV_const(sv, len);
2848 #   if __FreeBSD_version > 410001
2849             /* The leading "-" removes the "perl: " prefix,
2850              * but not the "(perl) suffix from the ps(1)
2851              * output, because that's what ps(1) shows if the
2852              * argv[] is modified. */
2853             setproctitle("-%s", s);
2854 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2855             /* This doesn't really work if you assume that
2856              * $0 = 'foobar'; will wipe out 'perl' from the $0
2857              * because in ps(1) output the result will be like
2858              * sprintf("perl: %s (perl)", s)
2859              * I guess this is a security feature:
2860              * one (a user process) cannot get rid of the original name.
2861              * --jhi */
2862             setproctitle("%s", s);
2863 #   endif
2864         }
2865 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2866         if (PL_origalen != 1) {
2867              union pstun un;
2868              s = SvPV_const(sv, len);
2869              un.pst_command = (char *)s;
2870              pstat(PSTAT_SETCMD, un, len, 0, 0);
2871         }
2872 #else
2873         if (PL_origalen > 1) {
2874             /* PL_origalen is set in perl_parse(). */
2875             s = SvPV_force(sv,len);
2876             if (len >= (STRLEN)PL_origalen-1) {
2877                 /* Longer than original, will be truncated. We assume that
2878                  * PL_origalen bytes are available. */
2879                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2880             }
2881             else {
2882                 /* Shorter than original, will be padded. */
2883 #ifdef PERL_DARWIN
2884                 /* Special case for Mac OS X: see [perl #38868] */
2885                 const int pad = 0;
2886 #else
2887                 /* Is the space counterintuitive?  Yes.
2888                  * (You were expecting \0?)
2889                  * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2890                  * --jhi */
2891                 const int pad = ' ';
2892 #endif
2893                 Copy(s, PL_origargv[0], len, char);
2894                 PL_origargv[0][len] = 0;
2895                 memset(PL_origargv[0] + len + 1,
2896                        pad,  PL_origalen - len - 1);
2897             }
2898             PL_origargv[0][PL_origalen-1] = 0;
2899             for (i = 1; i < PL_origargc; i++)
2900                 PL_origargv[i] = 0;
2901 #ifdef HAS_PRCTL_SET_NAME
2902             /* Set the legacy process name in addition to the POSIX name on Linux */
2903             if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2904                 /* diag_listed_as: SKIPME */
2905                 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2906             }
2907 #endif
2908         }
2909 #endif
2910         UNLOCK_DOLLARZERO_MUTEX;
2911         break;
2912     }
2913     return 0;
2914 }
2915
2916 I32
2917 Perl_whichsig(pTHX_ const char *sig)
2918 {
2919     register char* const* sigv;
2920
2921     PERL_ARGS_ASSERT_WHICHSIG;
2922     PERL_UNUSED_CONTEXT;
2923
2924     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2925         if (strEQ(sig,*sigv))
2926             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2927 #ifdef SIGCLD
2928     if (strEQ(sig,"CHLD"))
2929         return SIGCLD;
2930 #endif
2931 #ifdef SIGCHLD
2932     if (strEQ(sig,"CLD"))
2933         return SIGCHLD;
2934 #endif
2935     return -1;
2936 }
2937
2938 Signal_t
2939 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2940 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2941 #else
2942 Perl_sighandler(int sig)
2943 #endif
2944 {
2945 #ifdef PERL_GET_SIG_CONTEXT
2946     dTHXa(PERL_GET_SIG_CONTEXT);
2947 #else
2948     dTHX;
2949 #endif
2950     dSP;
2951     GV *gv = NULL;
2952     SV *sv = NULL;
2953     SV * const tSv = PL_Sv;
2954     CV *cv = NULL;
2955     OP *myop = PL_op;
2956     U32 flags = 0;
2957     XPV * const tXpv = PL_Xpv;
2958     I32 old_ss_ix = PL_savestack_ix;
2959
2960
2961     if (!PL_psig_ptr[sig]) {
2962                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2963                                  PL_sig_name[sig]);
2964                 exit(sig);
2965         }
2966
2967     /* Max number of items pushed there is 3*n or 4. We cannot fix
2968        infinity, so we fix 4 (in fact 5): */
2969     if (PL_savestack_ix + 15 <= PL_savestack_max) {
2970         flags |= 1;
2971         PL_savestack_ix += 5;           /* Protect save in progress. */
2972         SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
2973     }
2974     if (PL_markstack_ptr < PL_markstack_max - 2) {
2975         flags |= 2;
2976         PL_markstack_ptr++;             /* Protect mark. */
2977     }
2978     if (PL_scopestack_ix < PL_scopestack_max - 3) {
2979         flags |= 4;
2980         PL_scopestack_ix++;
2981     }
2982     /* sv_2cv is too complicated, try a simpler variant first: */
2983     if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
2984         || SvTYPE(cv) != SVt_PVCV) {
2985         HV *st;
2986         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2987     }
2988
2989     if (!cv || !CvROOT(cv)) {
2990         Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2991                        PL_sig_name[sig], (gv ? GvENAME(gv)
2992                                           : ((cv && CvGV(cv))
2993                                              ? GvENAME(CvGV(cv))
2994                                              : "__ANON__")));
2995         goto cleanup;
2996     }
2997
2998     sv = PL_psig_name[sig]
2999             ? SvREFCNT_inc_NN(PL_psig_name[sig])
3000             : newSVpv(PL_sig_name[sig],0);
3001     flags |= 8;
3002     SAVEFREESV(sv);
3003
3004     /* make sure our assumption about the size of the SAVEs are correct:
3005      * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3006     assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0)  == PL_savestack_ix);
3007
3008     PUSHSTACKi(PERLSI_SIGNAL);
3009     PUSHMARK(SP);
3010     PUSHs(sv);
3011 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3012     {
3013          struct sigaction oact;
3014
3015          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3016               if (sip) {
3017                    HV *sih = newHV();
3018                    SV *rv  = newRV_noinc(MUTABLE_SV(sih));
3019                    /* The siginfo fields signo, code, errno, pid, uid,
3020                     * addr, status, and band are defined by POSIX/SUSv3. */
3021                    (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3022                    (void)hv_stores(sih, "code", newSViv(sip->si_code));
3023 #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. */
3024                    hv_stores(sih, "errno",      newSViv(sip->si_errno));
3025                    hv_stores(sih, "status",     newSViv(sip->si_status));
3026                    hv_stores(sih, "uid",        newSViv(sip->si_uid));
3027                    hv_stores(sih, "pid",        newSViv(sip->si_pid));
3028                    hv_stores(sih, "addr",       newSVuv(PTR2UV(sip->si_addr)));
3029                    hv_stores(sih, "band",       newSViv(sip->si_band));
3030 #endif
3031                    EXTEND(SP, 2);
3032                    PUSHs(rv);
3033                    mPUSHp((char *)sip, sizeof(*sip));
3034               }
3035
3036          }
3037     }
3038 #endif
3039     PUTBACK;
3040
3041     call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3042
3043     POPSTACK;
3044     if (SvTRUE(ERRSV)) {
3045 #ifndef PERL_MICRO
3046 #ifdef HAS_SIGPROCMASK
3047         /* Handler "died", for example to get out of a restart-able read().
3048          * Before we re-do that on its behalf re-enable the signal which was
3049          * blocked by the system when we entered.
3050          */
3051         sigset_t set;
3052         sigemptyset(&set);
3053         sigaddset(&set,sig);
3054         sigprocmask(SIG_UNBLOCK, &set, NULL);
3055 #else
3056         /* Not clear if this will work */
3057         (void)rsignal(sig, SIG_IGN);
3058         (void)rsignal(sig, PL_csighandlerp);
3059 #endif
3060 #endif /* !PERL_MICRO */
3061         die_sv(ERRSV);
3062     }
3063 cleanup:
3064     /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3065     PL_savestack_ix = old_ss_ix;
3066     if (flags & 2)
3067         PL_markstack_ptr--;
3068     if (flags & 4)
3069         PL_scopestack_ix -= 1;
3070     if (flags & 8)
3071         SvREFCNT_dec(sv);
3072     PL_op = myop;                       /* Apparently not needed... */
3073
3074     PL_Sv = tSv;                        /* Restore global temporaries. */
3075     PL_Xpv = tXpv;
3076     return;
3077 }
3078
3079
3080 static void
3081 S_restore_magic(pTHX_ const void *p)
3082 {
3083     dVAR;
3084     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3085     SV* const sv = mgs->mgs_sv;
3086
3087     if (!sv)
3088         return;
3089
3090     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3091     {
3092 #ifdef PERL_OLD_COPY_ON_WRITE
3093         /* While magic was saved (and off) sv_setsv may well have seen
3094            this SV as a prime candidate for COW.  */
3095         if (SvIsCOW(sv))
3096             sv_force_normal_flags(sv, 0);
3097 #endif
3098
3099         if (mgs->mgs_readonly)
3100             SvREADONLY_on(sv);
3101         if (mgs->mgs_magical)
3102             SvFLAGS(sv) |= mgs->mgs_magical;
3103         else
3104             mg_magical(sv);
3105         if (SvGMAGICAL(sv)) {
3106             /* downgrade public flags to private,
3107                and discard any other private flags */
3108
3109             const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3110             if (pubflags) {
3111                 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3112                 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3113             }
3114         }
3115     }
3116
3117     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
3118
3119     /* If we're still on top of the stack, pop us off.  (That condition
3120      * will be satisfied if restore_magic was called explicitly, but *not*
3121      * if it's being called via leave_scope.)
3122      * The reason for doing this is that otherwise, things like sv_2cv()
3123      * may leave alloc gunk on the savestack, and some code
3124      * (e.g. sighandler) doesn't expect that...
3125      */
3126     if (PL_savestack_ix == mgs->mgs_ss_ix)
3127     {
3128         UV popval = SSPOPUV;
3129         assert(popval == SAVEt_DESTRUCTOR_X);
3130         PL_savestack_ix -= 2;
3131         popval = SSPOPUV;
3132         assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3133         PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3134     }
3135
3136 }
3137
3138 /* clean up the mess created by Perl_sighandler().
3139  * Note that this is only called during an exit in a signal handler;
3140  * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3141  * skipped over. This is why we don't need to fix up the markstack and
3142  * scopestack - they're going to be set to 0 anyway */
3143
3144 static void
3145 S_unwind_handler_stack(pTHX_ const void *p)
3146 {
3147     dVAR;
3148     PERL_UNUSED_ARG(p);
3149
3150     PL_savestack_ix -= 5; /* Unprotect save in progress. */
3151 }
3152
3153 /*
3154 =for apidoc magic_sethint
3155
3156 Triggered by a store to %^H, records the key/value pair to
3157 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
3158 anything that would need a deep copy.  Maybe we should warn if we find a
3159 reference.
3160
3161 =cut
3162 */
3163 int
3164 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3165 {
3166     dVAR;
3167     SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3168         : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3169
3170     PERL_ARGS_ASSERT_MAGIC_SETHINT;
3171
3172     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
3173        an alternative leaf in there, with PL_compiling.cop_hints being used if
3174        it's NULL. If needed for threads, the alternative could lock a mutex,
3175        or take other more complex action.  */
3176
3177     /* Something changed in %^H, so it will need to be restored on scope exit.
3178        Doing this here saves a lot of doing it manually in perl code (and
3179        forgetting to do it, and consequent subtle errors.  */
3180     PL_hints |= HINT_LOCALIZE_HH;
3181     CopHINTHASH_set(&PL_compiling,
3182         cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3183     return 0;
3184 }
3185
3186 /*
3187 =for apidoc magic_clearhint
3188
3189 Triggered by a delete from %^H, records the key to
3190 C<PL_compiling.cop_hints_hash>.
3191
3192 =cut
3193 */
3194 int
3195 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3196 {
3197     dVAR;
3198
3199     PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3200     PERL_UNUSED_ARG(sv);
3201
3202     assert(mg->mg_len == HEf_SVKEY);
3203
3204     PERL_UNUSED_ARG(sv);
3205
3206     PL_hints |= HINT_LOCALIZE_HH;
3207     CopHINTHASH_set(&PL_compiling,
3208         cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3209                                  MUTABLE_SV(mg->mg_ptr), 0, 0));
3210     return 0;
3211 }
3212
3213 /*
3214 =for apidoc magic_clearhints
3215
3216 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3217
3218 =cut
3219 */
3220 int
3221 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3222 {
3223     PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3224     PERL_UNUSED_ARG(sv);
3225     PERL_UNUSED_ARG(mg);
3226     cophh_free(CopHINTHASH_get(&PL_compiling));
3227     CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3228     return 0;
3229 }
3230
3231 /*
3232  * Local variables:
3233  * c-indentation-style: bsd
3234  * c-basic-offset: 4
3235  * indent-tabs-mode: t
3236  * End:
3237  *
3238  * ex: set ts=8 sts=4 sw=4 noet:
3239  */