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