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