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