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