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