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