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     const char *s;
2161
2162     PERL_ARGS_ASSERT_MAGIC_SETPOS;
2163     PERL_UNUSED_ARG(mg);
2164
2165     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2166         found = mg_find(lsv, PERL_MAGIC_regex_global);
2167     else
2168         found = NULL;
2169     if (!found) {
2170         if (!SvOK(sv))
2171             return 0;
2172 #ifdef PERL_OLD_COPY_ON_WRITE
2173     if (SvIsCOW(lsv))
2174         sv_force_normal_flags(lsv, 0);
2175 #endif
2176         found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2177                             NULL, 0);
2178     }
2179     else if (!SvOK(sv)) {
2180         found->mg_len = -1;
2181         return 0;
2182     }
2183     s = SvPV_const(lsv, len);
2184
2185     pos = SvIV(sv);
2186
2187     if (DO_UTF8(lsv)) {
2188         ulen = sv_or_pv_len_utf8(lsv, s, len);
2189         if (ulen)
2190             len = ulen;
2191     }
2192
2193     if (pos < 0) {
2194         pos += len;
2195         if (pos < 0)
2196             pos = 0;
2197     }
2198     else if (pos > (SSize_t)len)
2199         pos = len;
2200
2201     if (ulen) {
2202         pos = sv_or_pv_pos_u2b(lsv, s, pos, 0);
2203     }
2204
2205     found->mg_len = pos;
2206     found->mg_flags &= ~MGf_MINMATCH;
2207
2208     return 0;
2209 }
2210
2211 int
2212 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2213 {
2214     STRLEN len;
2215     SV * const lsv = LvTARG(sv);
2216     const char * const tmps = SvPV_const(lsv,len);
2217     STRLEN offs = LvTARGOFF(sv);
2218     STRLEN rem = LvTARGLEN(sv);
2219     const bool negoff = LvFLAGS(sv) & 1;
2220     const bool negrem = LvFLAGS(sv) & 2;
2221
2222     PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2223     PERL_UNUSED_ARG(mg);
2224
2225     if (!translate_substr_offsets(
2226             SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
2227             negoff ? -(IV)offs : (IV)offs, !negoff,
2228             negrem ? -(IV)rem  : (IV)rem,  !negrem, &offs, &rem
2229     )) {
2230         Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2231         sv_setsv_nomg(sv, &PL_sv_undef);
2232         return 0;
2233     }
2234
2235     if (SvUTF8(lsv))
2236         offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
2237     sv_setpvn(sv, tmps + offs, rem);
2238     if (SvUTF8(lsv))
2239         SvUTF8_on(sv);
2240     return 0;
2241 }
2242
2243 int
2244 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2245 {
2246     dVAR;
2247     STRLEN len, lsv_len, oldtarglen, newtarglen;
2248     const char * const tmps = SvPV_const(sv, len);
2249     const char *targs;
2250     SV * const lsv = LvTARG(sv);
2251     STRLEN lvoff = LvTARGOFF(sv);
2252     STRLEN lvlen = LvTARGLEN(sv);
2253     const bool negoff = LvFLAGS(sv) & 1;
2254     const bool neglen = LvFLAGS(sv) & 2;
2255
2256     PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2257     PERL_UNUSED_ARG(mg);
2258
2259     SvGETMAGIC(lsv);
2260     if (SvROK(lsv))
2261         Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2262                             "Attempt to use reference as lvalue in substr"
2263         );
2264     targs = SvPV_nomg(lsv,lsv_len);
2265     if (SvUTF8(lsv)) lsv_len = sv_or_pv_len_utf8(lsv,targs,lsv_len);
2266     if (!translate_substr_offsets(
2267             lsv_len,
2268             negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2269             neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2270     ))
2271         Perl_croak(aTHX_ "substr outside of string");
2272     oldtarglen = lvlen;
2273     if (DO_UTF8(sv)) {
2274         sv_utf8_upgrade_nomg(lsv);
2275         lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2276         sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2277         newtarglen = sv_len_utf8(sv);
2278         SvUTF8_on(lsv);
2279     }
2280     else if (lsv && SvUTF8(lsv)) {
2281         const char *utf8;
2282         lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2283         newtarglen = len;
2284         utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2285         sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2286         Safefree(utf8);
2287     }
2288     else {
2289         sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2290         newtarglen = len;
2291     }
2292     if (!neglen) LvTARGLEN(sv) = newtarglen;
2293     if (negoff)  LvTARGOFF(sv) += newtarglen - oldtarglen;
2294
2295     return 0;
2296 }
2297
2298 int
2299 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2300 {
2301     dVAR;
2302
2303     PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2304     PERL_UNUSED_ARG(sv);
2305
2306     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2307     return 0;
2308 }
2309
2310 int
2311 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2312 {
2313     dVAR;
2314
2315     PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2316     PERL_UNUSED_ARG(sv);
2317
2318     /* update taint status */
2319     if (PL_tainted)
2320         mg->mg_len |= 1;
2321     else
2322         mg->mg_len &= ~1;
2323     return 0;
2324 }
2325
2326 int
2327 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2328 {
2329     SV * const lsv = LvTARG(sv);
2330
2331     PERL_ARGS_ASSERT_MAGIC_GETVEC;
2332     PERL_UNUSED_ARG(mg);
2333
2334     if (lsv)
2335         sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2336     else
2337         SvOK_off(sv);
2338
2339     return 0;
2340 }
2341
2342 int
2343 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2344 {
2345     PERL_ARGS_ASSERT_MAGIC_SETVEC;
2346     PERL_UNUSED_ARG(mg);
2347     do_vecset(sv);      /* XXX slurp this routine */
2348     return 0;
2349 }
2350
2351 int
2352 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2353 {
2354     dVAR;
2355     SV *targ = NULL;
2356
2357     PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2358
2359     if (LvTARGLEN(sv)) {
2360         if (mg->mg_obj) {
2361             SV * const ahv = LvTARG(sv);
2362             HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2363             if (he)
2364                 targ = HeVAL(he);
2365         }
2366         else {
2367             AV *const av = MUTABLE_AV(LvTARG(sv));
2368             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2369                 targ = AvARRAY(av)[LvTARGOFF(sv)];
2370         }
2371         if (targ && (targ != &PL_sv_undef)) {
2372             /* somebody else defined it for us */
2373             SvREFCNT_dec(LvTARG(sv));
2374             LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2375             LvTARGLEN(sv) = 0;
2376             SvREFCNT_dec(mg->mg_obj);
2377             mg->mg_obj = NULL;
2378             mg->mg_flags &= ~MGf_REFCOUNTED;
2379         }
2380     }
2381     else
2382         targ = LvTARG(sv);
2383     sv_setsv(sv, targ ? targ : &PL_sv_undef);
2384     return 0;
2385 }
2386
2387 int
2388 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2389 {
2390     PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2391     PERL_UNUSED_ARG(mg);
2392     if (LvTARGLEN(sv))
2393         vivify_defelem(sv);
2394     if (LvTARG(sv)) {
2395         sv_setsv(LvTARG(sv), sv);
2396         SvSETMAGIC(LvTARG(sv));
2397     }
2398     return 0;
2399 }
2400
2401 void
2402 Perl_vivify_defelem(pTHX_ SV *sv)
2403 {
2404     dVAR;
2405     MAGIC *mg;
2406     SV *value = NULL;
2407
2408     PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2409
2410     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2411         return;
2412     if (mg->mg_obj) {
2413         SV * const ahv = LvTARG(sv);
2414         HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2415         if (he)
2416             value = HeVAL(he);
2417         if (!value || value == &PL_sv_undef)
2418             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2419     }
2420     else {
2421         AV *const av = MUTABLE_AV(LvTARG(sv));
2422         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2423             LvTARG(sv) = NULL;  /* array can't be extended */
2424         else {
2425             SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2426             if (!svp || (value = *svp) == &PL_sv_undef)
2427                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2428         }
2429     }
2430     SvREFCNT_inc_simple_void(value);
2431     SvREFCNT_dec(LvTARG(sv));
2432     LvTARG(sv) = value;
2433     LvTARGLEN(sv) = 0;
2434     SvREFCNT_dec(mg->mg_obj);
2435     mg->mg_obj = NULL;
2436     mg->mg_flags &= ~MGf_REFCOUNTED;
2437 }
2438
2439 int
2440 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2441 {
2442     PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2443     Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2444     return 0;
2445 }
2446
2447 int
2448 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2449 {
2450     PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2451     PERL_UNUSED_CONTEXT;
2452     PERL_UNUSED_ARG(sv);
2453     mg->mg_len = -1;
2454     return 0;
2455 }
2456
2457 int
2458 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2459 {
2460     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2461
2462     PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2463
2464     if (uf && uf->uf_set)
2465         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2466     return 0;
2467 }
2468
2469 int
2470 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2471 {
2472     const char type = mg->mg_type;
2473
2474     PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2475
2476     if (type == PERL_MAGIC_qr) {
2477     } else if (type == PERL_MAGIC_bm) {
2478         SvTAIL_off(sv);
2479         SvVALID_off(sv);
2480     } else {
2481         assert(type == PERL_MAGIC_fm);
2482     }
2483     return sv_unmagic(sv, type);
2484 }
2485
2486 #ifdef USE_LOCALE_COLLATE
2487 int
2488 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2489 {
2490     PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2491
2492     /*
2493      * RenE<eacute> Descartes said "I think not."
2494      * and vanished with a faint plop.
2495      */
2496     PERL_UNUSED_CONTEXT;
2497     PERL_UNUSED_ARG(sv);
2498     if (mg->mg_ptr) {
2499         Safefree(mg->mg_ptr);
2500         mg->mg_ptr = NULL;
2501         mg->mg_len = -1;
2502     }
2503     return 0;
2504 }
2505 #endif /* USE_LOCALE_COLLATE */
2506
2507 /* Just clear the UTF-8 cache data. */
2508 int
2509 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2510 {
2511     PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2512     PERL_UNUSED_CONTEXT;
2513     PERL_UNUSED_ARG(sv);
2514     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2515     mg->mg_ptr = NULL;
2516     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2517     return 0;
2518 }
2519
2520 int
2521 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2522 {
2523     dVAR;
2524     const char *s;
2525     I32 paren;
2526     const REGEXP * rx;
2527     const char * const remaining = mg->mg_ptr + 1;
2528     I32 i;
2529     STRLEN len;
2530     MAGIC *tmg;
2531
2532     PERL_ARGS_ASSERT_MAGIC_SET;
2533
2534     switch (*mg->mg_ptr) {
2535     case '\015': /* $^MATCH */
2536       if (strEQ(remaining, "ATCH"))
2537           goto do_match;
2538     case '`': /* ${^PREMATCH} caught below */
2539       do_prematch:
2540       paren = RX_BUFF_IDX_PREMATCH;
2541       goto setparen;
2542     case '\'': /* ${^POSTMATCH} caught below */
2543       do_postmatch:
2544       paren = RX_BUFF_IDX_POSTMATCH;
2545       goto setparen;
2546     case '&':
2547       do_match:
2548       paren = RX_BUFF_IDX_FULLMATCH;
2549       goto setparen;
2550     case '1': case '2': case '3': case '4':
2551     case '5': case '6': case '7': case '8': case '9':
2552       paren = atoi(mg->mg_ptr);
2553       setparen:
2554         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2555       setparen_got_rx:
2556             CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2557         } else {
2558             /* Croak with a READONLY error when a numbered match var is
2559              * set without a previous pattern match. Unless it's C<local $1>
2560              */
2561       croakparen:
2562             if (!PL_localizing) {
2563                 Perl_croak_no_modify(aTHX);
2564             }
2565         }
2566         break;
2567     case '\001':        /* ^A */
2568         if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2569         else SvOK_off(PL_bodytarget);
2570         FmLINES(PL_bodytarget) = 0;
2571         if (SvPOK(PL_bodytarget)) {
2572             char *s = SvPVX(PL_bodytarget);
2573             while ( ((s = strchr(s, '\n'))) ) {
2574                 FmLINES(PL_bodytarget)++;
2575                 s++;
2576             }
2577         }
2578         /* mg_set() has temporarily made sv non-magical */
2579         if (PL_tainting) {
2580             if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2581                 SvTAINTED_on(PL_bodytarget);
2582             else
2583                 SvTAINTED_off(PL_bodytarget);
2584         }
2585         break;
2586     case '\003':        /* ^C */
2587         PL_minus_c = cBOOL(SvIV(sv));
2588         break;
2589
2590     case '\004':        /* ^D */
2591 #ifdef DEBUGGING
2592         s = SvPV_nolen_const(sv);
2593         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2594         if (DEBUG_x_TEST || DEBUG_B_TEST)
2595             dump_all_perl(!DEBUG_B_TEST);
2596 #else
2597         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2598 #endif
2599         break;
2600     case '\005':  /* ^E */
2601         if (*(mg->mg_ptr+1) == '\0') {
2602 #ifdef VMS
2603             set_vaxc_errno(SvIV(sv));
2604 #else
2605 #  ifdef WIN32
2606             SetLastError( SvIV(sv) );
2607 #  else
2608 #    ifdef OS2
2609             os2_setsyserrno(SvIV(sv));
2610 #    else
2611             /* will anyone ever use this? */
2612             SETERRNO(SvIV(sv), 4);
2613 #    endif
2614 #  endif
2615 #endif
2616         }
2617         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2618             SvREFCNT_dec(PL_encoding);
2619             if (SvOK(sv) || SvGMAGICAL(sv)) {
2620                 PL_encoding = newSVsv(sv);
2621             }
2622             else {
2623                 PL_encoding = NULL;
2624             }
2625         }
2626         break;
2627     case '\006':        /* ^F */
2628         PL_maxsysfd = SvIV(sv);
2629         break;
2630     case '\010':        /* ^H */
2631         PL_hints = SvIV(sv);
2632         break;
2633     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2634         Safefree(PL_inplace);
2635         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2636         break;
2637     case '\016':        /* ^N */
2638         if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2639          && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2640         goto croakparen;
2641     case '\017':        /* ^O */
2642         if (*(mg->mg_ptr+1) == '\0') {
2643             Safefree(PL_osname);
2644             PL_osname = NULL;
2645             if (SvOK(sv)) {
2646                 TAINT_PROPER("assigning to $^O");
2647                 PL_osname = savesvpv(sv);
2648             }
2649         }
2650         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2651             STRLEN len;
2652             const char *const start = SvPV(sv, len);
2653             const char *out = (const char*)memchr(start, '\0', len);
2654             SV *tmp;
2655
2656
2657             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2658             PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2659
2660             /* Opening for input is more common than opening for output, so
2661                ensure that hints for input are sooner on linked list.  */
2662             tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2663                                        SvUTF8(sv))
2664                 : newSVpvs_flags("", SvUTF8(sv));
2665             (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2666             mg_set(tmp);
2667
2668             tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2669                                         SvUTF8(sv));
2670             (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2671             mg_set(tmp);
2672         }
2673         break;
2674     case '\020':        /* ^P */
2675       if (*remaining == '\0') { /* ^P */
2676           PL_perldb = SvIV(sv);
2677           if (PL_perldb && !PL_DBsingle)
2678               init_debugger();
2679           break;
2680       } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2681           goto do_prematch;
2682       } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2683           goto do_postmatch;
2684       }
2685       break;
2686     case '\024':        /* ^T */
2687 #ifdef BIG_TIME
2688         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2689 #else
2690         PL_basetime = (Time_t)SvIV(sv);
2691 #endif
2692         break;
2693     case '\025':        /* ^UTF8CACHE */
2694          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2695              PL_utf8cache = (signed char) sv_2iv(sv);
2696          }
2697          break;
2698     case '\027':        /* ^W & $^WARNING_BITS */
2699         if (*(mg->mg_ptr+1) == '\0') {
2700             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2701                 i = SvIV(sv);
2702                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2703                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2704             }
2705         }
2706         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2707             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2708                 if (!SvPOK(sv)) {
2709                     PL_compiling.cop_warnings = pWARN_STD;
2710                     break;
2711                 }
2712                 {
2713                     STRLEN len, i;
2714                     int accumulate = 0 ;
2715                     int any_fatals = 0 ;
2716                     const char * const ptr = SvPV_const(sv, len) ;
2717                     for (i = 0 ; i < len ; ++i) {
2718                         accumulate |= ptr[i] ;
2719                         any_fatals |= (ptr[i] & 0xAA) ;
2720                     }
2721                     if (!accumulate) {
2722                         if (!specialWARN(PL_compiling.cop_warnings))
2723                             PerlMemShared_free(PL_compiling.cop_warnings);
2724                         PL_compiling.cop_warnings = pWARN_NONE;
2725                     }
2726                     /* Yuck. I can't see how to abstract this:  */
2727                     else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2728                                        WARN_ALL) && !any_fatals) {
2729                         if (!specialWARN(PL_compiling.cop_warnings))
2730                             PerlMemShared_free(PL_compiling.cop_warnings);
2731                         PL_compiling.cop_warnings = pWARN_ALL;
2732                         PL_dowarn |= G_WARN_ONCE ;
2733                     }
2734                     else {
2735                         STRLEN len;
2736                         const char *const p = SvPV_const(sv, len);
2737
2738                         PL_compiling.cop_warnings
2739                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2740                                                          p, len);
2741
2742                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2743                             PL_dowarn |= G_WARN_ONCE ;
2744                     }
2745
2746                 }
2747             }
2748         }
2749         break;
2750     case '.':
2751         if (PL_localizing) {
2752             if (PL_localizing == 1)
2753                 SAVESPTR(PL_last_in_gv);
2754         }
2755         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2756             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2757         break;
2758     case '^':
2759         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2760         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2761         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2762         break;
2763     case '~':
2764         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2765         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2766         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2767         break;
2768     case '=':
2769         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2770         break;
2771     case '-':
2772         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2773         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2774                 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2775         break;
2776     case '%':
2777         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2778         break;
2779     case '|':
2780         {
2781             IO * const io = GvIO(PL_defoutgv);
2782             if(!io)
2783               break;
2784             if ((SvIV(sv)) == 0)
2785                 IoFLAGS(io) &= ~IOf_FLUSH;
2786             else {
2787                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2788                     PerlIO *ofp = IoOFP(io);
2789                     if (ofp)
2790                         (void)PerlIO_flush(ofp);
2791                     IoFLAGS(io) |= IOf_FLUSH;
2792                 }
2793             }
2794         }
2795         break;
2796     case '/':
2797         SvREFCNT_dec(PL_rs);
2798         PL_rs = newSVsv(sv);
2799         break;
2800     case '\\':
2801         SvREFCNT_dec(PL_ors_sv);
2802         if (SvOK(sv)) {
2803             PL_ors_sv = newSVsv(sv);
2804         }
2805         else {
2806             PL_ors_sv = NULL;
2807         }
2808         break;
2809     case '[':
2810         if (SvIV(sv) != 0)
2811             Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
2812         break;
2813     case '?':
2814 #ifdef COMPLEX_STATUS
2815         if (PL_localizing == 2) {
2816             SvUPGRADE(sv, SVt_PVLV);
2817             PL_statusvalue = LvTARGOFF(sv);
2818             PL_statusvalue_vms = LvTARGLEN(sv);
2819         }
2820         else
2821 #endif
2822 #ifdef VMSISH_STATUS
2823         if (VMSISH_STATUS)
2824             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2825         else
2826 #endif
2827             STATUS_UNIX_EXIT_SET(SvIV(sv));
2828         break;
2829     case '!':
2830         {
2831 #ifdef VMS
2832 #   define PERL_VMS_BANG vaxc$errno
2833 #else
2834 #   define PERL_VMS_BANG 0
2835 #endif
2836         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2837                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2838         }
2839         break;
2840     case '<':
2841         {
2842         const IV new_uid = SvIV(sv);
2843         PL_delaymagic_uid = new_uid;
2844         if (PL_delaymagic) {
2845             PL_delaymagic |= DM_RUID;
2846             break;                              /* don't do magic till later */
2847         }
2848 #ifdef HAS_SETRUID
2849         (void)setruid((Uid_t)new_uid);
2850 #else
2851 #ifdef HAS_SETREUID
2852         (void)setreuid((Uid_t)new_uid, (Uid_t)-1);
2853 #else
2854 #ifdef HAS_SETRESUID
2855       (void)setresuid((Uid_t)new_uid, (Uid_t)-1, (Uid_t)-1);
2856 #else
2857         if (new_uid == PerlProc_geteuid()) {            /* special case $< = $> */
2858 #ifdef PERL_DARWIN
2859             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2860             if (new_uid != 0 && PerlProc_getuid() == 0)
2861                 (void)PerlProc_setuid(0);
2862 #endif
2863             (void)PerlProc_setuid(new_uid);
2864         } else {
2865             Perl_croak(aTHX_ "setruid() not implemented");
2866         }
2867 #endif
2868 #endif
2869 #endif
2870         break;
2871         }
2872     case '>':
2873         {
2874         const UV new_euid = SvIV(sv);
2875         PL_delaymagic_euid = new_euid;
2876         if (PL_delaymagic) {
2877             PL_delaymagic |= DM_EUID;
2878             break;                              /* don't do magic till later */
2879         }
2880 #ifdef HAS_SETEUID
2881         (void)seteuid((Uid_t)new_euid);
2882 #else
2883 #ifdef HAS_SETREUID
2884         (void)setreuid((Uid_t)-1, (Uid_t)new_euid);
2885 #else
2886 #ifdef HAS_SETRESUID
2887         (void)setresuid((Uid_t)-1, (Uid_t)new_euid, (Uid_t)-1);
2888 #else
2889         if (new_euid == PerlProc_getuid())              /* special case $> = $< */
2890             PerlProc_setuid(new_euid);
2891         else {
2892             Perl_croak(aTHX_ "seteuid() not implemented");
2893         }
2894 #endif
2895 #endif
2896 #endif
2897         break;
2898         }
2899     case '(':
2900         {
2901         const UV new_gid = SvIV(sv);
2902         PL_delaymagic_gid = new_gid;
2903         if (PL_delaymagic) {
2904             PL_delaymagic |= DM_RGID;
2905             break;                              /* don't do magic till later */
2906         }
2907 #ifdef HAS_SETRGID
2908         (void)setrgid((Gid_t)new_gid);
2909 #else
2910 #ifdef HAS_SETREGID
2911         (void)setregid((Gid_t)new_gid, (Gid_t)-1);
2912 #else
2913 #ifdef HAS_SETRESGID
2914       (void)setresgid((Gid_t)new_gid, (Gid_t)-1, (Gid_t) -1);
2915 #else
2916         if (new_gid == PerlProc_getegid())                      /* special case $( = $) */
2917             (void)PerlProc_setgid(new_gid);
2918         else {
2919             Perl_croak(aTHX_ "setrgid() not implemented");
2920         }
2921 #endif
2922 #endif
2923 #endif
2924         break;
2925         }
2926     case ')':
2927         {
2928         UV new_egid;
2929 #ifdef HAS_SETGROUPS
2930         {
2931             const char *p = SvPV_const(sv, len);
2932             Groups_t *gary = NULL;
2933 #ifdef _SC_NGROUPS_MAX
2934            int maxgrp = sysconf(_SC_NGROUPS_MAX);
2935
2936            if (maxgrp < 0)
2937                maxgrp = NGROUPS;
2938 #else
2939            int maxgrp = NGROUPS;
2940 #endif
2941
2942             while (isSPACE(*p))
2943                 ++p;
2944             new_egid = Atol(p);
2945             for (i = 0; i < maxgrp; ++i) {
2946                 while (*p && !isSPACE(*p))
2947                     ++p;
2948                 while (isSPACE(*p))
2949                     ++p;
2950                 if (!*p)
2951                     break;
2952                 if(!gary)
2953                     Newx(gary, i + 1, Groups_t);
2954                 else
2955                     Renew(gary, i + 1, Groups_t);
2956                 gary[i] = Atol(p);
2957             }
2958             if (i)
2959                 (void)setgroups(i, gary);
2960             Safefree(gary);
2961         }
2962 #else  /* HAS_SETGROUPS */
2963         new_egid = SvIV(sv);
2964 #endif /* HAS_SETGROUPS */
2965         PL_delaymagic_egid = new_egid;
2966         if (PL_delaymagic) {
2967             PL_delaymagic |= DM_EGID;
2968             break;                              /* don't do magic till later */
2969         }
2970 #ifdef HAS_SETEGID
2971         (void)setegid((Gid_t)new_egid);
2972 #else
2973 #ifdef HAS_SETREGID
2974         (void)setregid((Gid_t)-1, (Gid_t)new_egid);
2975 #else
2976 #ifdef HAS_SETRESGID
2977         (void)setresgid((Gid_t)-1, (Gid_t)new_egid, (Gid_t)-1);
2978 #else
2979         if (new_egid == PerlProc_getgid())                      /* special case $) = $( */
2980             (void)PerlProc_setgid(new_egid);
2981         else {
2982             Perl_croak(aTHX_ "setegid() not implemented");
2983         }
2984 #endif
2985 #endif
2986 #endif
2987         break;
2988         }
2989     case ':':
2990         PL_chopset = SvPV_force(sv,len);
2991         break;
2992     case '$': /* $$ */
2993         /* Store the pid in mg->mg_obj so we can tell when a fork has
2994            occurred.  mg->mg_obj points to *$ by default, so clear it. */
2995         if (isGV(mg->mg_obj)) {
2996             if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
2997                 SvREFCNT_dec(mg->mg_obj);
2998             mg->mg_flags |= MGf_REFCOUNTED;
2999             mg->mg_obj = newSViv((IV)PerlProc_getpid());
3000         }
3001         else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
3002         break;
3003     case '0':
3004         LOCK_DOLLARZERO_MUTEX;
3005 #ifdef HAS_SETPROCTITLE
3006         /* The BSDs don't show the argv[] in ps(1) output, they
3007          * show a string from the process struct and provide
3008          * the setproctitle() routine to manipulate that. */
3009         if (PL_origalen != 1) {
3010             s = SvPV_const(sv, len);
3011 #   if __FreeBSD_version > 410001
3012             /* The leading "-" removes the "perl: " prefix,
3013              * but not the "(perl) suffix from the ps(1)
3014              * output, because that's what ps(1) shows if the
3015              * argv[] is modified. */
3016             setproctitle("-%s", s);
3017 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
3018             /* This doesn't really work if you assume that
3019              * $0 = 'foobar'; will wipe out 'perl' from the $0
3020              * because in ps(1) output the result will be like
3021              * sprintf("perl: %s (perl)", s)
3022              * I guess this is a security feature:
3023              * one (a user process) cannot get rid of the original name.
3024              * --jhi */
3025             setproctitle("%s", s);
3026 #   endif
3027         }
3028 #elif defined(__hpux) && defined(PSTAT_SETCMD)
3029         if (PL_origalen != 1) {
3030              union pstun un;
3031              s = SvPV_const(sv, len);
3032              un.pst_command = (char *)s;
3033              pstat(PSTAT_SETCMD, un, len, 0, 0);
3034         }
3035 #else
3036         if (PL_origalen > 1) {
3037             /* PL_origalen is set in perl_parse(). */
3038             s = SvPV_force(sv,len);
3039             if (len >= (STRLEN)PL_origalen-1) {
3040                 /* Longer than original, will be truncated. We assume that
3041                  * PL_origalen bytes are available. */
3042                 Copy(s, PL_origargv[0], PL_origalen-1, char);
3043             }
3044             else {
3045                 /* Shorter than original, will be padded. */
3046 #ifdef PERL_DARWIN
3047                 /* Special case for Mac OS X: see [perl #38868] */
3048                 const int pad = 0;
3049 #else
3050                 /* Is the space counterintuitive?  Yes.
3051                  * (You were expecting \0?)
3052                  * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
3053                  * --jhi */
3054                 const int pad = ' ';
3055 #endif
3056                 Copy(s, PL_origargv[0], len, char);
3057                 PL_origargv[0][len] = 0;
3058                 memset(PL_origargv[0] + len + 1,
3059                        pad,  PL_origalen - len - 1);
3060             }
3061             PL_origargv[0][PL_origalen-1] = 0;
3062             for (i = 1; i < PL_origargc; i++)
3063                 PL_origargv[i] = 0;
3064 #ifdef HAS_PRCTL_SET_NAME
3065             /* Set the legacy process name in addition to the POSIX name on Linux */
3066             if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
3067                 /* diag_listed_as: SKIPME */
3068                 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
3069             }
3070 #endif
3071         }
3072 #endif
3073         UNLOCK_DOLLARZERO_MUTEX;
3074         break;
3075     }
3076     return 0;
3077 }
3078
3079 I32
3080 Perl_whichsig_sv(pTHX_ SV *sigsv)
3081 {
3082     const char *sigpv;
3083     STRLEN siglen;
3084     PERL_ARGS_ASSERT_WHICHSIG_SV;
3085     PERL_UNUSED_CONTEXT;
3086     sigpv = SvPV_const(sigsv, siglen);
3087     return whichsig_pvn(sigpv, siglen);
3088 }
3089
3090 I32
3091 Perl_whichsig_pv(pTHX_ const char *sig)
3092 {
3093     PERL_ARGS_ASSERT_WHICHSIG_PV;
3094     PERL_UNUSED_CONTEXT;
3095     return whichsig_pvn(sig, strlen(sig));
3096 }
3097
3098 I32
3099 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3100 {
3101     char* const* sigv;
3102
3103     PERL_ARGS_ASSERT_WHICHSIG_PVN;
3104     PERL_UNUSED_CONTEXT;
3105
3106     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3107         if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3108             return PL_sig_num[sigv - (char* const*)PL_sig_name];
3109 #ifdef SIGCLD
3110     if (memEQs(sig, len, "CHLD"))
3111         return SIGCLD;
3112 #endif
3113 #ifdef SIGCHLD
3114     if (memEQs(sig, len, "CLD"))
3115         return SIGCHLD;
3116 #endif
3117     return -1;
3118 }
3119
3120 Signal_t
3121 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3122 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3123 #else
3124 Perl_sighandler(int sig)
3125 #endif
3126 {
3127 #ifdef PERL_GET_SIG_CONTEXT
3128     dTHXa(PERL_GET_SIG_CONTEXT);
3129 #else
3130     dTHX;
3131 #endif
3132     dSP;
3133     GV *gv = NULL;
3134     SV *sv = NULL;
3135     SV * const tSv = PL_Sv;
3136     CV *cv = NULL;
3137     OP *myop = PL_op;
3138     U32 flags = 0;
3139     XPV * const tXpv = PL_Xpv;
3140     I32 old_ss_ix = PL_savestack_ix;
3141     SV *errsv_save = NULL;
3142
3143
3144     if (!PL_psig_ptr[sig]) {
3145                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3146                                  PL_sig_name[sig]);
3147                 exit(sig);
3148         }
3149
3150     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3151         /* Max number of items pushed there is 3*n or 4. We cannot fix
3152            infinity, so we fix 4 (in fact 5): */
3153         if (PL_savestack_ix + 15 <= PL_savestack_max) {
3154             flags |= 1;
3155             PL_savestack_ix += 5;               /* Protect save in progress. */
3156             SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3157         }
3158     }
3159     /* sv_2cv is too complicated, try a simpler variant first: */
3160     if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3161         || SvTYPE(cv) != SVt_PVCV) {
3162         HV *st;
3163         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3164     }
3165
3166     if (!cv || !CvROOT(cv)) {
3167         Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3168                        PL_sig_name[sig], (gv ? GvENAME(gv)
3169                                           : ((cv && CvGV(cv))
3170                                              ? GvENAME(CvGV(cv))
3171                                              : "__ANON__")));
3172         goto cleanup;
3173     }
3174
3175     sv = PL_psig_name[sig]
3176             ? SvREFCNT_inc_NN(PL_psig_name[sig])
3177             : newSVpv(PL_sig_name[sig],0);
3178     flags |= 8;
3179     SAVEFREESV(sv);
3180
3181     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3182         /* make sure our assumption about the size of the SAVEs are correct:
3183          * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3184         assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0)  == PL_savestack_ix);
3185     }
3186
3187     PUSHSTACKi(PERLSI_SIGNAL);
3188     PUSHMARK(SP);
3189     PUSHs(sv);
3190 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3191     {
3192          struct sigaction oact;
3193
3194          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3195               if (sip) {
3196                    HV *sih = newHV();
3197                    SV *rv  = newRV_noinc(MUTABLE_SV(sih));
3198                    /* The siginfo fields signo, code, errno, pid, uid,
3199                     * addr, status, and band are defined by POSIX/SUSv3. */
3200                    (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3201                    (void)hv_stores(sih, "code", newSViv(sip->si_code));
3202 #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. */
3203                    hv_stores(sih, "errno",      newSViv(sip->si_errno));
3204                    hv_stores(sih, "status",     newSViv(sip->si_status));
3205                    hv_stores(sih, "uid",        newSViv(sip->si_uid));
3206                    hv_stores(sih, "pid",        newSViv(sip->si_pid));
3207                    hv_stores(sih, "addr",       newSVuv(PTR2UV(sip->si_addr)));
3208                    hv_stores(sih, "band",       newSViv(sip->si_band));
3209 #endif
3210                    EXTEND(SP, 2);
3211                    PUSHs(rv);
3212                    mPUSHp((char *)sip, sizeof(*sip));
3213               }
3214
3215          }
3216     }
3217 #endif
3218     PUTBACK;
3219
3220     errsv_save = newSVsv(ERRSV);
3221
3222     call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3223
3224     POPSTACK;
3225     if (SvTRUE(ERRSV)) {
3226         SvREFCNT_dec(errsv_save);
3227 #ifndef PERL_MICRO
3228         /* Handler "died", for example to get out of a restart-able read().
3229          * Before we re-do that on its behalf re-enable the signal which was
3230          * blocked by the system when we entered.
3231          */
3232 #ifdef HAS_SIGPROCMASK
3233 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3234        if (sip || uap)
3235 #endif
3236         {
3237             sigset_t set;
3238             sigemptyset(&set);
3239             sigaddset(&set,sig);
3240             sigprocmask(SIG_UNBLOCK, &set, NULL);
3241         }
3242 #else
3243         /* Not clear if this will work */
3244         (void)rsignal(sig, SIG_IGN);
3245         (void)rsignal(sig, PL_csighandlerp);
3246 #endif
3247 #endif /* !PERL_MICRO */
3248         die_sv(ERRSV);
3249     }
3250     else {
3251         sv_setsv(ERRSV, errsv_save);
3252         SvREFCNT_dec(errsv_save);
3253     }
3254
3255 cleanup:
3256     /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3257     PL_savestack_ix = old_ss_ix;
3258     if (flags & 8)
3259         SvREFCNT_dec(sv);
3260     PL_op = myop;                       /* Apparently not needed... */
3261
3262     PL_Sv = tSv;                        /* Restore global temporaries. */
3263     PL_Xpv = tXpv;
3264     return;
3265 }
3266
3267
3268 static void
3269 S_restore_magic(pTHX_ const void *p)
3270 {
3271     dVAR;
3272     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3273     SV* const sv = mgs->mgs_sv;
3274     bool bumped;
3275
3276     if (!sv)
3277         return;
3278
3279     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3280         SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3281 #ifdef PERL_OLD_COPY_ON_WRITE
3282         /* While magic was saved (and off) sv_setsv may well have seen
3283            this SV as a prime candidate for COW.  */
3284         if (SvIsCOW(sv))
3285             sv_force_normal_flags(sv, 0);
3286 #endif
3287         if (mgs->mgs_readonly)
3288             SvREADONLY_on(sv);
3289         if (mgs->mgs_magical)
3290             SvFLAGS(sv) |= mgs->mgs_magical;
3291         else
3292             mg_magical(sv);
3293     }
3294
3295     bumped = mgs->mgs_bumped;
3296     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
3297
3298     /* If we're still on top of the stack, pop us off.  (That condition
3299      * will be satisfied if restore_magic was called explicitly, but *not*
3300      * if it's being called via leave_scope.)
3301      * The reason for doing this is that otherwise, things like sv_2cv()
3302      * may leave alloc gunk on the savestack, and some code
3303      * (e.g. sighandler) doesn't expect that...
3304      */
3305     if (PL_savestack_ix == mgs->mgs_ss_ix)
3306     {
3307         UV popval = SSPOPUV;
3308         assert(popval == SAVEt_DESTRUCTOR_X);
3309         PL_savestack_ix -= 2;
3310         popval = SSPOPUV;
3311         assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3312         PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3313     }
3314     if (bumped) {
3315         if (SvREFCNT(sv) == 1) {
3316             /* We hold the last reference to this SV, which implies that the
3317                SV was deleted as a side effect of the routines we called.
3318                So artificially keep it alive a bit longer.
3319                We avoid turning on the TEMP flag, which can cause the SV's
3320                buffer to get stolen (and maybe other stuff). */
3321             sv_2mortal(sv);
3322             SvTEMP_off(sv);
3323         }
3324         else
3325             SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */
3326     }
3327 }
3328
3329 /* clean up the mess created by Perl_sighandler().
3330  * Note that this is only called during an exit in a signal handler;
3331  * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3332  * skipped over. */
3333
3334 static void
3335 S_unwind_handler_stack(pTHX_ const void *p)
3336 {
3337     dVAR;
3338     PERL_UNUSED_ARG(p);
3339
3340     PL_savestack_ix -= 5; /* Unprotect save in progress. */
3341 }
3342
3343 /*
3344 =for apidoc magic_sethint
3345
3346 Triggered by a store to %^H, records the key/value pair to
3347 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
3348 anything that would need a deep copy.  Maybe we should warn if we find a
3349 reference.
3350
3351 =cut
3352 */
3353 int
3354 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3355 {
3356     dVAR;
3357     SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3358         : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3359
3360     PERL_ARGS_ASSERT_MAGIC_SETHINT;
3361
3362     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
3363        an alternative leaf in there, with PL_compiling.cop_hints being used if
3364        it's NULL. If needed for threads, the alternative could lock a mutex,
3365        or take other more complex action.  */
3366
3367     /* Something changed in %^H, so it will need to be restored on scope exit.
3368        Doing this here saves a lot of doing it manually in perl code (and
3369        forgetting to do it, and consequent subtle errors.  */
3370     PL_hints |= HINT_LOCALIZE_HH;
3371     CopHINTHASH_set(&PL_compiling,
3372         cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3373     return 0;
3374 }
3375
3376 /*
3377 =for apidoc magic_clearhint
3378
3379 Triggered by a delete from %^H, records the key to
3380 C<PL_compiling.cop_hints_hash>.
3381
3382 =cut
3383 */
3384 int
3385 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3386 {
3387     dVAR;
3388
3389     PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3390     PERL_UNUSED_ARG(sv);
3391
3392     PL_hints |= HINT_LOCALIZE_HH;
3393     CopHINTHASH_set(&PL_compiling,
3394         mg->mg_len == HEf_SVKEY
3395          ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3396                                  MUTABLE_SV(mg->mg_ptr), 0, 0)
3397          : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3398                                  mg->mg_ptr, mg->mg_len, 0, 0));
3399     return 0;
3400 }
3401
3402 /*
3403 =for apidoc magic_clearhints
3404
3405 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3406
3407 =cut
3408 */
3409 int
3410 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3411 {
3412     PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3413     PERL_UNUSED_ARG(sv);
3414     PERL_UNUSED_ARG(mg);
3415     cophh_free(CopHINTHASH_get(&PL_compiling));
3416     CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3417     return 0;
3418 }
3419
3420 int
3421 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3422                                  const char *name, I32 namlen)
3423 {
3424     MAGIC *nmg;
3425
3426     PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3427     PERL_UNUSED_ARG(sv);
3428     PERL_UNUSED_ARG(name);
3429     PERL_UNUSED_ARG(namlen);
3430
3431     sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3432     nmg = mg_find(nsv, mg->mg_type);
3433     if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3434     nmg->mg_ptr = mg->mg_ptr;
3435     nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3436     nmg->mg_flags |= MGf_REFCOUNTED;
3437     return 1;
3438 }
3439
3440 /*
3441  * Local variables:
3442  * c-indentation-style: bsd
3443  * c-basic-offset: 4
3444  * indent-tabs-mode: nil
3445  * End:
3446  *
3447  * ex: set ts=8 sts=4 sw=4 et:
3448  */