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 after 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 Report on the SV's length.  See C<sv_magic>.
 292
 293 =cut
 294 */
 295
 296 U32
 297 Perl_mg_length(pTHX_ SV *sv)
 298 {
 299     dVAR;
 300     MAGIC* mg;
 301     STRLEN len;
 302
 303     PERL_ARGS_ASSERT_MG_LENGTH;
 304
 305     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 306         const MGVTBL * const vtbl = mg->mg_virtual;
 307         if (vtbl && vtbl->svt_len) {
 308             const I32 mgs_ix = SSNEW(sizeof(MGS));
 309             save_magic(mgs_ix, sv);
 310             /* omit MGf_GSKIP -- not changed here */
 311             len = vtbl->svt_len(aTHX_ sv, mg);
 312             restore_magic(INT2PTR(void*, (IV)mgs_ix));
 313             return len;
 314         }
 315     }
 316
 317     {
 318         /* You can't know whether it's UTF-8 until you get the string again...
 319          */
 320         const U8 *s = (U8*)SvPV_const(sv, len);
 321
 322         if (DO_UTF8(sv)) {
 323             len = utf8_length(s, s + len);
 324         }
 325     }
 326     return len;
 327 }
 328
 329 I32
 330 Perl_mg_size(pTHX_ SV *sv)
 331 {
 332     MAGIC* mg;
 333
 334     PERL_ARGS_ASSERT_MG_SIZE;
 335
 336     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 337         const MGVTBL* const vtbl = mg->mg_virtual;
 338         if (vtbl && vtbl->svt_len) {
 339             const I32 mgs_ix = SSNEW(sizeof(MGS));
 340             I32 len;
 341             save_magic(mgs_ix, sv);
 342             /* omit MGf_GSKIP -- not changed here */
 343             len = vtbl->svt_len(aTHX_ sv, mg);
 344             restore_magic(INT2PTR(void*, (IV)mgs_ix));
 345             return len;
 346         }
 347     }
 348
 349     switch(SvTYPE(sv)) {
 350         case SVt_PVAV:
 351             return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
 352         case SVt_PVHV:
 353             /* FIXME */
 354         default:
 355             Perl_croak(aTHX_ "Size magic not implemented");
 356             break;
 357     }
 358     return 0;
 359 }
 360
 361 /*
 362 =for apidoc mg_clear
 363
 364 Clear something magical that the SV represents.  See C<sv_magic>.
 365
 366 =cut
 367 */
 368
 369 int
 370 Perl_mg_clear(pTHX_ SV *sv)
 371 {
 372     const I32 mgs_ix = SSNEW(sizeof(MGS));
 373     MAGIC* mg;
 374     MAGIC *nextmg;
 375
 376     PERL_ARGS_ASSERT_MG_CLEAR;
 377
 378     save_magic(mgs_ix, sv);
 379
 380     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
 381         const MGVTBL* const vtbl = mg->mg_virtual;
 382         /* omit GSKIP -- never set here */
 383
 384         nextmg = mg->mg_moremagic; /* it may delete itself */
 385
 386         if (vtbl && vtbl->svt_clear)
 387             vtbl->svt_clear(aTHX_ sv, mg);
 388     }
 389
 390     restore_magic(INT2PTR(void*, (IV)mgs_ix));
 391     return 0;
 392 }
 393
 394 static MAGIC*
 395 S_mg_findext_flags(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
 396 {
 397     PERL_UNUSED_CONTEXT;
 398
 399     assert(flags <= 1);
 400
 401     if (sv) {
 402         MAGIC *mg;
 403
 404         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 405             if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
 406                 return mg;
 407             }
 408         }
 409     }
 410
 411     return NULL;
 412 }
 413
 414 /*
 415 =for apidoc mg_find
 416
 417 Finds the magic pointer for type matching the SV.  See C<sv_magic>.
 418
 419 =cut
 420 */
 421
 422 MAGIC*
 423 Perl_mg_find(pTHX_ const SV *sv, int type)
 424 {
 425     return S_mg_findext_flags(aTHX_ sv, type, NULL, 0);
 426 }
 427
 428 /*
 429 =for apidoc mg_findext
 430
 431 Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>.  See
 432 C<sv_magicext>.
 433
 434 =cut
 435 */
 436
 437 MAGIC*
 438 Perl_mg_findext(pTHX_ const SV *sv, int type, const MGVTBL *vtbl)
 439 {
 440     return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1);
 441 }
 442
 443 /*
 444 =for apidoc mg_copy
 445
 446 Copies the magic from one SV to another.  See C<sv_magic>.
 447
 448 =cut
 449 */
 450
 451 int
 452 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
 453 {
 454     int count = 0;
 455     MAGIC* mg;
 456
 457     PERL_ARGS_ASSERT_MG_COPY;
 458
 459     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 460         const MGVTBL* const vtbl = mg->mg_virtual;
 461         if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
 462             count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
 463         }
 464         else {
 465             const char type = mg->mg_type;
 466             if (isUPPER(type) && type != PERL_MAGIC_uvar) {
 467                 sv_magic(nsv,
 468                      (type == PERL_MAGIC_tied)
 469                         ? SvTIED_obj(sv, mg)
 470                         : (type == PERL_MAGIC_regdata && mg->mg_obj)
 471                             ? sv
 472                             : mg->mg_obj,
 473                      toLOWER(type), key, klen);
 474                 count++;
 475             }
 476         }
 477     }
 478     return count;
 479 }
 480
 481 /*
 482 =for apidoc mg_localize
 483
 484 Copy some of the magic from an existing SV to new localized version of that
 485 SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg
 486 taint, pos).
 487
 488 If setmagic is false then no set magic will be called on the new (empty) SV.
 489 This typically means that assignment will soon follow (e.g. 'local $x = $y'),
 490 and that will handle the magic.
 491
 492 =cut
 493 */
 494
 495 void
 496 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
 497 {
 498     dVAR;
 499     MAGIC *mg;
 500
 501     PERL_ARGS_ASSERT_MG_LOCALIZE;
 502
 503     if (nsv == DEFSV)
 504         return;
 505
 506     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 507         const MGVTBL* const vtbl = mg->mg_virtual;
 508         if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
 509             continue;
 510
 511         if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
 512             (void)vtbl->svt_local(aTHX_ nsv, mg);
 513         else
 514             sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
 515                             mg->mg_ptr, mg->mg_len);
 516
 517         /* container types should remain read-only across localization */
 518         if (!SvIsCOW(sv)) SvFLAGS(nsv) |= SvREADONLY(sv);
 519     }
 520
 521     if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
 522         SvFLAGS(nsv) |= SvMAGICAL(sv);
 523         if (setmagic) {
 524             PL_localizing = 1;
 525             SvSETMAGIC(nsv);
 526             PL_localizing = 0;
 527         }
 528     }
 529 }
 530
 531 #define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
 532 static void
 533 S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
 534 {
 535     const MGVTBL* const vtbl = mg->mg_virtual;
 536     if (vtbl && vtbl->svt_free)
 537         vtbl->svt_free(aTHX_ sv, mg);
 538     if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
 539         if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
 540             Safefree(mg->mg_ptr);
 541         else if (mg->mg_len == HEf_SVKEY)
 542             SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
 543     }
 544     if (mg->mg_flags & MGf_REFCOUNTED)
 545         SvREFCNT_dec(mg->mg_obj);
 546     Safefree(mg);
 547 }
 548
 549 /*
 550 =for apidoc mg_free
 551
 552 Free any magic storage used by the SV.  See C<sv_magic>.
 553
 554 =cut
 555 */
 556
 557 int
 558 Perl_mg_free(pTHX_ SV *sv)
 559 {
 560     MAGIC* mg;
 561     MAGIC* moremagic;
 562
 563     PERL_ARGS_ASSERT_MG_FREE;
 564
 565     for (mg = SvMAGIC(sv); mg; mg = moremagic) {
 566         moremagic = mg->mg_moremagic;
 567         mg_free_struct(sv, mg);
 568         SvMAGIC_set(sv, moremagic);
 569     }
 570     SvMAGIC_set(sv, NULL);
 571     SvMAGICAL_off(sv);
 572     return 0;
 573 }
 574
 575 /*
 576 =for apidoc Am|void|mg_free_type|SV *sv|int how
 577
 578 Remove any magic of type I<how> from the SV I<sv>.  See L</sv_magic>.
 579
 580 =cut
 581 */
 582
 583 void
 584 Perl_mg_free_type(pTHX_ SV *sv, int how)
 585 {
 586     MAGIC *mg, *prevmg, *moremg;
 587     PERL_ARGS_ASSERT_MG_FREE_TYPE;
 588     for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
 589         MAGIC *newhead;
 590         moremg = mg->mg_moremagic;
 591         if (mg->mg_type == how) {
 592             /* temporarily move to the head of the magic chain, in case
 593                custom free code relies on this historical aspect of mg_free */
 594             if (prevmg) {
 595                 prevmg->mg_moremagic = moremg;
 596                 mg->mg_moremagic = SvMAGIC(sv);
 597                 SvMAGIC_set(sv, mg);
 598             }
 599             newhead = mg->mg_moremagic;
 600             mg_free_struct(sv, mg);
 601             SvMAGIC_set(sv, newhead);
 602             mg = prevmg;
 603         }
 604     }
 605     mg_magical(sv);
 606 }
 607
 608 #include <signal.h>
 609
 610 U32
 611 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
 612 {
 613     dVAR;
 614     PERL_UNUSED_ARG(sv);
 615
 616     PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
 617
 618     if (PL_curpm) {
 619         const REGEXP * const rx = PM_GETRE(PL_curpm);
 620         if (rx) {
 621             if (mg->mg_obj) {                   /* @+ */
 622                 /* return the number possible */
 623                 return RX_NPARENS(rx);
 624             } else {                            /* @- */
 625                 I32 paren = RX_LASTPAREN(rx);
 626
 627                 /* return the last filled */
 628                 while ( paren >= 0
 629                         && (RX_OFFS(rx)[paren].start == -1
 630                             || RX_OFFS(rx)[paren].end == -1) )
 631                     paren--;
 632                 return (U32)paren;
 633             }
 634         }
 635     }
 636
 637     return (U32)-1;
 638 }
 639
 640 /* @-, @+ */
 641
 642 int
 643 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
 644 {
 645     dVAR;
 646
 647     PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
 648
 649     if (PL_curpm) {
 650         const REGEXP * const rx = PM_GETRE(PL_curpm);
 651         if (rx) {
 652             const I32 paren = mg->mg_len;
 653             I32 s;
 654             I32 t;
 655             if (paren < 0)
 656                 return 0;
 657             if (paren <= (I32)RX_NPARENS(rx) &&
 658                 (s = RX_OFFS(rx)[paren].start) != -1 &&
 659                 (t = RX_OFFS(rx)[paren].end) != -1)
 660                 {
 661                     I32 i;
 662                     if (mg->mg_obj)             /* @+ */
 663                         i = t;
 664                     else                        /* @- */
 665                         i = s;
 666
 667                     if (i > 0 && RX_MATCH_UTF8(rx)) {
 668                         const char * const b = RX_SUBBEG(rx);
 669                         if (b)
 670                             i = RX_SUBCOFFSET(rx) +
 671                                     utf8_length((U8*)b,
 672                                         (U8*)(b-RX_SUBOFFSET(rx)+i));
 673                     }
 674
 675                     sv_setiv(sv, i);
 676                 }
 677         }
 678     }
 679     return 0;
 680 }
 681
 682 /* @-, @+ */
 683
 684 int
 685 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
 686 {
 687     PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
 688     PERL_UNUSED_ARG(sv);
 689     PERL_UNUSED_ARG(mg);
 690     Perl_croak_no_modify(aTHX);
 691     NORETURN_FUNCTION_END;
 692 }
 693
 694 U32
 695 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
 696 {
 697     dVAR;
 698     I32 paren;
 699     I32 i;
 700     const REGEXP * rx;
 701     const char * const remaining = mg->mg_ptr + 1;
 702
 703     PERL_ARGS_ASSERT_MAGIC_LEN;
 704
 705     switch (*mg->mg_ptr) {
 706     case '\020':
 707       if (*remaining == '\0') { /* ^P */
 708           break;
 709       } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
 710           goto do_prematch;
 711       } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
 712           goto do_postmatch;
 713       }
 714       break;
 715     case '\015': /* $^MATCH */
 716         if (strEQ(remaining, "ATCH")) {
 717         goto do_match;
 718     } else {
 719         break;
 720     }
 721     case '`':
 722       do_prematch:
 723       paren = RX_BUFF_IDX_PREMATCH;
 724       goto maybegetparen;
 725     case '\'':
 726       do_postmatch:
 727       paren = RX_BUFF_IDX_POSTMATCH;
 728       goto maybegetparen;
 729     case '&':
 730       do_match:
 731       paren = RX_BUFF_IDX_FULLMATCH;
 732       goto maybegetparen;
 733     case '1': case '2': case '3': case '4':
 734     case '5': case '6': case '7': case '8': case '9':
 735       paren = atoi(mg->mg_ptr);
 736     maybegetparen:
 737         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 738       getparen:
 739         i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
 740
 741                 if (i < 0)
 742                     Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
 743                 return i;
 744         } else {
 745                 if (ckWARN(WARN_UNINITIALIZED))
 746                     report_uninit(sv);
 747                 return 0;
 748         }
 749     case '+':
 750         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 751             paren = RX_LASTPAREN(rx);
 752             if (paren)
 753                 goto getparen;
 754         }
 755         return 0;
 756     case '\016': /* ^N */
 757         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 758             paren = RX_LASTCLOSEPAREN(rx);
 759             if (paren)
 760                 goto getparen;
 761         }
 762         return 0;
 763     }
 764     magic_get(sv,mg);
 765     if (!SvPOK(sv) && SvNIOK(sv)) {
 766         sv_2pv(sv, 0);
 767     }
 768     if (SvPOK(sv))
 769         return SvCUR(sv);
 770     return 0;
 771 }
 772
 773 #define SvRTRIM(sv) STMT_START { \
 774     if (SvPOK(sv)) { \
 775         STRLEN len = SvCUR(sv); \
 776         char * const p = SvPVX(sv); \
 777         while (len > 0 && isSPACE(p[len-1])) \
 778            --len; \
 779         SvCUR_set(sv, len); \
 780         p[len] = '\0'; \
 781     } \
 782 } STMT_END
 783
 784 void
 785 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
 786 {
 787     PERL_ARGS_ASSERT_EMULATE_COP_IO;
 788
 789     if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
 790         sv_setsv(sv, &PL_sv_undef);
 791     else {
 792         sv_setpvs(sv, "");
 793         SvUTF8_off(sv);
 794         if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
 795             SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
 796             assert(value);
 797             sv_catsv(sv, value);
 798         }
 799         sv_catpvs(sv, "\0");
 800         if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
 801             SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
 802             assert(value);
 803             sv_catsv(sv, value);
 804         }
 805     }
 806 }
 807
 808 #ifdef VMS
 809 #include <descrip.h>
 810 #include <starlet.h>
 811 #endif
 812
 813 int
 814 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 815 {
 816     dVAR;
 817     I32 paren;
 818     const char *s = NULL;
 819     REGEXP *rx;
 820     const char * const remaining = mg->mg_ptr + 1;
 821     const char nextchar = *remaining;
 822
 823     PERL_ARGS_ASSERT_MAGIC_GET;
 824
 825     switch (*mg->mg_ptr) {
 826     case '\001':                /* ^A */
 827         if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
 828         else sv_setsv(sv, &PL_sv_undef);
 829         if (SvTAINTED(PL_bodytarget))
 830             SvTAINTED_on(sv);
 831         break;
 832     case '\003':                /* ^C, ^CHILD_ERROR_NATIVE */
 833         if (nextchar == '\0') {
 834             sv_setiv(sv, (IV)PL_minus_c);
 835         }
 836         else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
 837             sv_setiv(sv, (IV)STATUS_NATIVE);
 838         }
 839         break;
 840
 841     case '\004':                /* ^D */
 842         sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
 843         break;
 844     case '\005':  /* ^E */
 845          if (nextchar == '\0') {
 846 #if defined(VMS)
 847              {
 848                   char msg[255];
 849                   $DESCRIPTOR(msgdsc,msg);
 850                   sv_setnv(sv,(NV) vaxc$errno);
 851                   if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
 852                        sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
 853                   else
 854                        sv_setpvs(sv,"");
 855              }
 856 #elif defined(OS2)
 857              if (!(_emx_env & 0x200)) { /* Under DOS */
 858                   sv_setnv(sv, (NV)errno);
 859                   sv_setpv(sv, errno ? Strerror(errno) : "");
 860              } else {
 861                   if (errno != errno_isOS2) {
 862                        const int tmp = _syserrno();
 863                        if (tmp) /* 2nd call to _syserrno() makes it 0 */
 864                             Perl_rc = tmp;
 865                   }
 866                   sv_setnv(sv, (NV)Perl_rc);
 867                   sv_setpv(sv, os2error(Perl_rc));
 868              }
 869 #elif defined(WIN32)
 870              {
 871                   const DWORD dwErr = GetLastError();
 872                   sv_setnv(sv, (NV)dwErr);
 873                   if (dwErr) {
 874                        PerlProc_GetOSError(sv, dwErr);
 875                   }
 876                   else
 877                        sv_setpvs(sv, "");
 878                   SetLastError(dwErr);
 879              }
 880 #else
 881              {
 882                  dSAVE_ERRNO;
 883                  sv_setnv(sv, (NV)errno);
 884                  sv_setpv(sv, errno ? Strerror(errno) : "");
 885                  RESTORE_ERRNO;
 886              }
 887 #endif
 888              SvRTRIM(sv);
 889              SvNOK_on(sv);      /* what a wonderful hack! */
 890          }
 891          else if (strEQ(remaining, "NCODING"))
 892               sv_setsv(sv, PL_encoding);
 893          break;
 894     case '\006':                /* ^F */
 895         sv_setiv(sv, (IV)PL_maxsysfd);
 896         break;
 897     case '\007':                /* ^GLOBAL_PHASE */
 898         if (strEQ(remaining, "LOBAL_PHASE")) {
 899             sv_setpvn(sv, PL_phase_names[PL_phase],
 900                       strlen(PL_phase_names[PL_phase]));
 901         }
 902         break;
 903     case '\010':                /* ^H */
 904         sv_setiv(sv, (IV)PL_hints);
 905         break;
 906     case '\011':                /* ^I */ /* NOT \t in EBCDIC */
 907         sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
 908         break;
 909     case '\014':                /* ^LAST_FH */
 910         if (strEQ(remaining, "AST_FH")) {
 911             if (PL_last_in_gv) {
 912                 assert(isGV_with_GP(PL_last_in_gv));
 913                 SV_CHECK_THINKFIRST_COW_DROP(sv);
 914                 prepare_SV_for_RV(sv);
 915                 SvOK_off(sv);
 916                 SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv));
 917                 SvROK_on(sv);
 918                 sv_rvweaken(sv);
 919             }
 920             else sv_setsv_nomg(sv, NULL);
 921         }
 922         break;
 923     case '\017':                /* ^O & ^OPEN */
 924         if (nextchar == '\0') {
 925             sv_setpv(sv, PL_osname);
 926             SvTAINTED_off(sv);
 927         }
 928         else if (strEQ(remaining, "PEN")) {
 929             Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
 930         }
 931         break;
 932     case '\020':
 933         if (nextchar == '\0') {       /* ^P */
 934             sv_setiv(sv, (IV)PL_perldb);
 935         } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
 936
 937             paren = RX_BUFF_IDX_CARET_PREMATCH;
 938             goto do_numbuf_fetch;
 939         } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
 940             paren = RX_BUFF_IDX_CARET_POSTMATCH;
 941             goto do_numbuf_fetch;
 942         }
 943         break;
 944     case '\023':                /* ^S */
 945         if (nextchar == '\0') {
 946             if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
 947                 SvOK_off(sv);
 948             else if (PL_in_eval)
 949                 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
 950             else
 951                 sv_setiv(sv, 0);
 952         }
 953         break;
 954     case '\024':                /* ^T */
 955         if (nextchar == '\0') {
 956 #ifdef BIG_TIME
 957             sv_setnv(sv, PL_basetime);
 958 #else
 959             sv_setiv(sv, (IV)PL_basetime);
 960 #endif
 961         }
 962         else if (strEQ(remaining, "AINT"))
 963             sv_setiv(sv, PL_tainting
 964                     ? (PL_taint_warn || PL_unsafe ? -1 : 1)
 965                     : 0);
 966         break;
 967     case '\025':                /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
 968         if (strEQ(remaining, "NICODE"))
 969             sv_setuv(sv, (UV) PL_unicode);
 970         else if (strEQ(remaining, "TF8LOCALE"))
 971             sv_setuv(sv, (UV) PL_utf8locale);
 972         else if (strEQ(remaining, "TF8CACHE"))
 973             sv_setiv(sv, (IV) PL_utf8cache);
 974         break;
 975     case '\027':                /* ^W  & $^WARNING_BITS */
 976         if (nextchar == '\0')
 977             sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
 978         else if (strEQ(remaining, "ARNING_BITS")) {
 979             if (PL_compiling.cop_warnings == pWARN_NONE) {
 980                 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
 981             }
 982             else if (PL_compiling.cop_warnings == pWARN_STD) {
 983                 sv_setsv(sv, &PL_sv_undef);
 984                 break;
 985             }
 986             else if (PL_compiling.cop_warnings == pWARN_ALL) {
 987                 /* Get the bit mask for $warnings::Bits{all}, because
 988                  * it could have been extended by warnings::register */
 989                 HV * const bits = get_hv("warnings::Bits", 0);
 990                 SV ** const bits_all = bits ? hv_fetchs(bits, "all", FALSE) : NULL;
 991                 if (bits_all)
 992                     sv_copypv(sv, *bits_all);
 993                 else
 994                     sv_setpvn(sv, WARN_ALLstring, WARNsize);
 995             }
 996             else {
 997                 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
 998                           *PL_compiling.cop_warnings);
 999             }
1000         }
1001         break;
1002     case '\015': /* $^MATCH */
1003         if (strEQ(remaining, "ATCH")) {
1004             paren = RX_BUFF_IDX_CARET_FULLMATCH;
1005             goto do_numbuf_fetch;
1006         }
1007
1008     case '1': case '2': case '3': case '4':
1009     case '5': case '6': case '7': case '8': case '9': case '&':
1010         /*
1011          * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
1012          * XXX Does the new way break anything?
1013          */
1014         paren = atoi(mg->mg_ptr); /* $& is in [0] */
1015       do_numbuf_fetch:
1016         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1017             CALLREG_NUMBUF_FETCH(rx,paren,sv);
1018             break;
1019         }
1020         sv_setsv(sv,&PL_sv_undef);
1021         break;
1022     case '+':
1023         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1024             paren = RX_LASTPAREN(rx);
1025             if (paren)
1026                 goto do_numbuf_fetch;
1027         }
1028         sv_setsv(sv,&PL_sv_undef);
1029         break;
1030     case '\016':                /* ^N */
1031         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1032             paren = RX_LASTCLOSEPAREN(rx);
1033             if (paren)
1034                 goto do_numbuf_fetch;
1035         }
1036         sv_setsv(sv,&PL_sv_undef);
1037         break;
1038     case '`':
1039         paren = RX_BUFF_IDX_PREMATCH;
1040         goto do_numbuf_fetch;
1041     case '\'':
1042         paren = RX_BUFF_IDX_POSTMATCH;
1043         goto do_numbuf_fetch;
1044     case '.':
1045         if (GvIO(PL_last_in_gv)) {
1046             sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
1047         }
1048         break;
1049     case '?':
1050         {
1051             sv_setiv(sv, (IV)STATUS_CURRENT);
1052 #ifdef COMPLEX_STATUS
1053             SvUPGRADE(sv, SVt_PVLV);
1054             LvTARGOFF(sv) = PL_statusvalue;
1055             LvTARGLEN(sv) = PL_statusvalue_vms;
1056 #endif
1057         }
1058         break;
1059     case '^':
1060         if (GvIOp(PL_defoutgv))
1061                 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1062         if (s)
1063             sv_setpv(sv,s);
1064         else {
1065             sv_setpv(sv,GvENAME(PL_defoutgv));
1066             sv_catpvs(sv,"_TOP");
1067         }
1068         break;
1069     case '~':
1070         if (GvIOp(PL_defoutgv))
1071             s = IoFMT_NAME(GvIOp(PL_defoutgv));
1072         if (!s)
1073             s = GvENAME(PL_defoutgv);
1074         sv_setpv(sv,s);
1075         break;
1076     case '=':
1077         if (GvIO(PL_defoutgv))
1078             sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1079         break;
1080     case '-':
1081         if (GvIO(PL_defoutgv))
1082             sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1083         break;
1084     case '%':
1085         if (GvIO(PL_defoutgv))
1086             sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1087         break;
1088     case ':':
1089         break;
1090     case '/':
1091         break;
1092     case '[':
1093         sv_setiv(sv, 0);
1094         break;
1095     case '|':
1096         if (GvIO(PL_defoutgv))
1097             sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1098         break;
1099     case '\\':
1100         if (PL_ors_sv)
1101             sv_copypv(sv, PL_ors_sv);
1102         else
1103             sv_setsv(sv, &PL_sv_undef);
1104         break;
1105     case '$': /* $$ */
1106         {
1107             IV const pid = (IV)PerlProc_getpid();
1108             if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
1109                 /* never set manually, or at least not since last fork */
1110                 sv_setiv(sv, pid);
1111                 /* never unsafe, even if reading in a tainted expression */
1112                 SvTAINTED_off(sv);
1113             }
1114             /* else a value has been assigned manually, so do nothing */
1115         }
1116         break;
1117
1118     case '!':
1119         {
1120         dSAVE_ERRNO;
1121 #ifdef VMS
1122         sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1123 #else
1124         sv_setnv(sv, (NV)errno);
1125 #endif
1126 #ifdef OS2
1127         if (errno == errno_isOS2 || errno == errno_isOS2_set)
1128             sv_setpv(sv, os2error(Perl_rc));
1129         else
1130 #endif
1131         sv_setpv(sv, errno ? Strerror(errno) : "");
1132         RESTORE_ERRNO;
1133         }
1134
1135         SvRTRIM(sv);
1136         SvNOK_on(sv);   /* what a wonderful hack! */
1137         break;
1138     case '<':
1139         sv_setiv(sv, (IV)PerlProc_getuid());
1140         break;
1141     case '>':
1142         sv_setiv(sv, (IV)PerlProc_geteuid());
1143         break;
1144     case '(':
1145         sv_setiv(sv, (IV)PerlProc_getgid());
1146         goto add_groups;
1147     case ')':
1148         sv_setiv(sv, (IV)PerlProc_getegid());
1149       add_groups:
1150 #ifdef HAS_GETGROUPS
1151         {
1152             Groups_t *gary = NULL;
1153             I32 i, num_groups = getgroups(0, gary);
1154             Newx(gary, num_groups, Groups_t);
1155             num_groups = getgroups(num_groups, gary);
1156             for (i = 0; i < num_groups; i++)
1157                 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1158             Safefree(gary);
1159         }
1160         (void)SvIOK_on(sv);     /* what a wonderful hack! */
1161 #endif
1162         break;
1163     case '0':
1164         break;
1165     }
1166     return 0;
1167 }
1168
1169 int
1170 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1171 {
1172     struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1173
1174     PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1175
1176     if (uf && uf->uf_val)
1177         (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1178     return 0;
1179 }
1180
1181 int
1182 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1183 {
1184     dVAR;
1185     STRLEN len = 0, klen;
1186     const char * const key = MgPV_const(mg,klen);
1187     const char *s = NULL;
1188
1189     PERL_ARGS_ASSERT_MAGIC_SETENV;
1190
1191     SvGETMAGIC(sv);
1192     if (SvOK(sv)) {
1193         /* defined environment variables are byte strings; unfortunately
1194            there is no SvPVbyte_force_nomg(), so we must do this piecewise */
1195         (void)SvPV_force_nomg_nolen(sv);
1196         sv_utf8_downgrade(sv, /* fail_ok */ TRUE);
1197         if (SvUTF8(sv)) {
1198             Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv");
1199             SvUTF8_off(sv);
1200         }
1201         s = SvPVX(sv);
1202         len = SvCUR(sv);
1203     }
1204     my_setenv(key, s); /* does the deed */
1205
1206 #ifdef DYNAMIC_ENV_FETCH
1207      /* We just undefd an environment var.  Is a replacement */
1208      /* waiting in the wings? */
1209     if (!len) {
1210         SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE);
1211         if (valp)
1212             s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1213     }
1214 #endif
1215
1216 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1217                             /* And you'll never guess what the dog had */
1218                             /*   in its mouth... */
1219     if (PL_tainting) {
1220         MgTAINTEDDIR_off(mg);
1221 #ifdef VMS
1222         if (s && klen == 8 && strEQ(key, "DCL$PATH")) {
1223             char pathbuf[256], eltbuf[256], *cp, *elt;
1224             int i = 0, j = 0;
1225
1226             my_strlcpy(eltbuf, s, sizeof(eltbuf));
1227             elt = eltbuf;
1228             do {          /* DCL$PATH may be a search list */
1229                 while (1) {   /* as may dev portion of any element */
1230                     if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1231                         if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1232                              cando_by_name(S_IWUSR,0,elt) ) {
1233                             MgTAINTEDDIR_on(mg);
1234                             return 0;
1235                         }
1236                     }
1237                     if ((cp = strchr(elt, ':')) != NULL)
1238                         *cp = '\0';
1239                     if (my_trnlnm(elt, eltbuf, j++))
1240                         elt = eltbuf;
1241                     else
1242                         break;
1243                 }
1244                 j = 0;
1245             } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1246         }
1247 #endif /* VMS */
1248         if (s && klen == 4 && strEQ(key,"PATH")) {
1249             const char * const strend = s + len;
1250
1251             while (s < strend) {
1252                 char tmpbuf[256];
1253                 Stat_t st;
1254                 I32 i;
1255 #ifdef VMS  /* Hmm.  How do we get $Config{path_sep} from C? */
1256                 const char path_sep = '|';
1257 #else
1258                 const char path_sep = ':';
1259 #endif
1260                 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1261                              s, strend, path_sep, &i);
1262                 s++;
1263                 if (i >= (I32)sizeof tmpbuf   /* too long -- assume the worst */
1264 #ifdef VMS
1265                       || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1266 #else
1267                       || *tmpbuf != '/'       /* no starting slash -- assume relative path */
1268 #endif
1269                       || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1270                     MgTAINTEDDIR_on(mg);
1271                     return 0;
1272                 }
1273             }
1274         }
1275     }
1276 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1277
1278     return 0;
1279 }
1280
1281 int
1282 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1283 {
1284     PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1285     PERL_UNUSED_ARG(sv);
1286     my_setenv(MgPV_nolen_const(mg),NULL);
1287     return 0;
1288 }
1289
1290 int
1291 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1292 {
1293     dVAR;
1294     PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1295     PERL_UNUSED_ARG(mg);
1296 #if defined(VMS)
1297     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1298 #else
1299     if (PL_localizing) {
1300         HE* entry;
1301         my_clearenv();
1302         hv_iterinit(MUTABLE_HV(sv));
1303         while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1304             I32 keylen;
1305             my_setenv(hv_iterkey(entry, &keylen),
1306                       SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1307         }
1308     }
1309 #endif
1310     return 0;
1311 }
1312
1313 int
1314 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1315 {
1316     dVAR;
1317     PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1318     PERL_UNUSED_ARG(sv);
1319     PERL_UNUSED_ARG(mg);
1320 #if defined(VMS)
1321     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1322 #else
1323     my_clearenv();
1324 #endif
1325     return 0;
1326 }
1327
1328 #ifndef PERL_MICRO
1329 #ifdef HAS_SIGPROCMASK
1330 static void
1331 restore_sigmask(pTHX_ SV *save_sv)
1332 {
1333     const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1334     (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1335 }
1336 #endif
1337 int
1338 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1339 {
1340     dVAR;
1341     /* Are we fetching a signal entry? */
1342     int i = (I16)mg->mg_private;
1343
1344     PERL_ARGS_ASSERT_MAGIC_GETSIG;
1345
1346     if (!i) {
1347         STRLEN siglen;
1348         const char * sig = MgPV_const(mg, siglen);
1349         mg->mg_private = i = whichsig_pvn(sig, siglen);
1350     }
1351
1352     if (i > 0) {
1353         if(PL_psig_ptr[i])
1354             sv_setsv(sv,PL_psig_ptr[i]);
1355         else {
1356             Sighandler_t sigstate = rsignal_state(i);
1357 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1358             if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1359                 sigstate = SIG_IGN;
1360 #endif
1361 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1362             if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1363                 sigstate = SIG_DFL;
1364 #endif
1365             /* cache state so we don't fetch it again */
1366             if(sigstate == (Sighandler_t) SIG_IGN)
1367                 sv_setpvs(sv,"IGNORE");
1368             else
1369                 sv_setsv(sv,&PL_sv_undef);
1370             PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1371             SvTEMP_off(sv);
1372         }
1373     }
1374     return 0;
1375 }
1376 int
1377 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1378 {
1379     PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1380
1381     magic_setsig(NULL, mg);
1382     return sv_unmagic(sv, mg->mg_type);
1383 }
1384
1385 Signal_t
1386 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1387 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1388 #else
1389 Perl_csighandler(int sig)
1390 #endif
1391 {
1392 #ifdef PERL_GET_SIG_CONTEXT
1393     dTHXa(PERL_GET_SIG_CONTEXT);
1394 #else
1395     dTHX;
1396 #endif
1397 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1398     (void) rsignal(sig, PL_csighandlerp);
1399     if (PL_sig_ignoring[sig]) return;
1400 #endif
1401 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1402     if (PL_sig_defaulting[sig])
1403 #ifdef KILL_BY_SIGPRC
1404             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1405 #else
1406             exit(1);
1407 #endif
1408 #endif
1409     if (
1410 #ifdef SIGILL
1411            sig == SIGILL ||
1412 #endif
1413 #ifdef SIGBUS
1414            sig == SIGBUS ||
1415 #endif
1416 #ifdef SIGSEGV
1417            sig == SIGSEGV ||
1418 #endif
1419            (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1420         /* Call the perl level handler now--
1421          * with risk we may be in malloc() or being destructed etc. */
1422 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1423         (*PL_sighandlerp)(sig, NULL, NULL);
1424 #else
1425         (*PL_sighandlerp)(sig);
1426 #endif
1427     else {
1428         if (!PL_psig_pend) return;
1429         /* Set a flag to say this signal is pending, that is awaiting delivery after
1430          * the current Perl opcode completes */
1431         PL_psig_pend[sig]++;
1432
1433 #ifndef SIG_PENDING_DIE_COUNT
1434 #  define SIG_PENDING_DIE_COUNT 120
1435 #endif
1436         /* Add one to say _a_ signal is pending */
1437         if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1438             Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1439                        (unsigned long)SIG_PENDING_DIE_COUNT);
1440     }
1441 }
1442
1443 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1444 void
1445 Perl_csighandler_init(void)
1446 {
1447     int sig;
1448     if (PL_sig_handlers_initted) return;
1449
1450     for (sig = 1; sig < SIG_SIZE; sig++) {
1451 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1452         dTHX;
1453         PL_sig_defaulting[sig] = 1;
1454         (void) rsignal(sig, PL_csighandlerp);
1455 #endif
1456 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1457         PL_sig_ignoring[sig] = 0;
1458 #endif
1459     }
1460     PL_sig_handlers_initted = 1;
1461 }
1462 #endif
1463
1464 #if defined HAS_SIGPROCMASK
1465 static void
1466 unblock_sigmask(pTHX_ void* newset)
1467 {
1468     sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1469 }
1470 #endif
1471
1472 void
1473 Perl_despatch_signals(pTHX)
1474 {
1475     dVAR;
1476     int sig;
1477     PL_sig_pending = 0;
1478     for (sig = 1; sig < SIG_SIZE; sig++) {
1479         if (PL_psig_pend[sig]) {
1480             dSAVE_ERRNO;
1481 #ifdef HAS_SIGPROCMASK
1482             /* From sigaction(2) (FreeBSD man page):
1483              * | Signal routines normally execute with the signal that
1484              * | caused their invocation blocked, but other signals may
1485              * | yet occur.
1486              * Emulation of this behavior (from within Perl) is enabled
1487              * using sigprocmask
1488              */
1489             int was_blocked;
1490             sigset_t newset, oldset;
1491
1492             sigemptyset(&newset);
1493             sigaddset(&newset, sig);
1494             sigprocmask(SIG_BLOCK, &newset, &oldset);
1495             was_blocked = sigismember(&oldset, sig);
1496             if (!was_blocked) {
1497                 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1498                 ENTER;
1499                 SAVEFREESV(save_sv);
1500                 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1501             }
1502 #endif
1503             PL_psig_pend[sig] = 0;
1504 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1505             (*PL_sighandlerp)(sig, NULL, NULL);
1506 #else
1507             (*PL_sighandlerp)(sig);
1508 #endif
1509 #ifdef HAS_SIGPROCMASK
1510             if (!was_blocked)
1511                 LEAVE;
1512 #endif
1513             RESTORE_ERRNO;
1514         }
1515     }
1516 }
1517
1518 /* sv of NULL signifies that we're acting as magic_clearsig.  */
1519 int
1520 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1521 {
1522     dVAR;
1523     I32 i;
1524     SV** svp = NULL;
1525     /* Need to be careful with SvREFCNT_dec(), because that can have side
1526      * effects (due to closures). We must make sure that the new disposition
1527      * is in place before it is called.
1528      */
1529     SV* to_dec = NULL;
1530     STRLEN len;
1531 #ifdef HAS_SIGPROCMASK
1532     sigset_t set, save;
1533     SV* save_sv;
1534 #endif
1535     const char *s = MgPV_const(mg,len);
1536
1537     PERL_ARGS_ASSERT_MAGIC_SETSIG;
1538
1539     if (*s == '_') {
1540         if (memEQs(s, len, "__DIE__"))
1541             svp = &PL_diehook;
1542         else if (memEQs(s, len, "__WARN__")
1543                  && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1544             /* Merge the existing behaviours, which are as follows:
1545                magic_setsig, we always set svp to &PL_warnhook
1546                (hence we always change the warnings handler)
1547                For magic_clearsig, we don't change the warnings handler if it's
1548                set to the &PL_warnhook.  */
1549             svp = &PL_warnhook;
1550         } else if (sv) {
1551             SV *tmp = sv_newmortal();
1552             Perl_croak(aTHX_ "No such hook: %s",
1553                                 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1554         }
1555         i = 0;
1556         if (svp && *svp) {
1557             if (*svp != PERL_WARNHOOK_FATAL)
1558                 to_dec = *svp;
1559             *svp = NULL;
1560         }
1561     }
1562     else {
1563         i = (I16)mg->mg_private;
1564         if (!i) {
1565             i = whichsig_pvn(s, len);   /* ...no, a brick */
1566             mg->mg_private = (U16)i;
1567         }
1568         if (i <= 0) {
1569             if (sv) {
1570                 SV *tmp = sv_newmortal();
1571                 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1572                                             pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1573             }
1574             return 0;
1575         }
1576 #ifdef HAS_SIGPROCMASK
1577         /* Avoid having the signal arrive at a bad time, if possible. */
1578         sigemptyset(&set);
1579         sigaddset(&set,i);
1580         sigprocmask(SIG_BLOCK, &set, &save);
1581         ENTER;
1582         save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1583         SAVEFREESV(save_sv);
1584         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1585 #endif
1586         PERL_ASYNC_CHECK();
1587 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1588         if (!PL_sig_handlers_initted) Perl_csighandler_init();
1589 #endif
1590 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1591         PL_sig_ignoring[i] = 0;
1592 #endif
1593 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1594         PL_sig_defaulting[i] = 0;
1595 #endif
1596         to_dec = PL_psig_ptr[i];
1597         if (sv) {
1598             PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1599             SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1600
1601             /* Signals don't change name during the program's execution, so once
1602                they're cached in the appropriate slot of PL_psig_name, they can
1603                stay there.
1604
1605                Ideally we'd find some way of making SVs at (C) compile time, or
1606                at least, doing most of the work.  */
1607             if (!PL_psig_name[i]) {
1608                 PL_psig_name[i] = newSVpvn(s, len);
1609                 SvREADONLY_on(PL_psig_name[i]);
1610             }
1611         } else {
1612             SvREFCNT_dec(PL_psig_name[i]);
1613             PL_psig_name[i] = NULL;
1614             PL_psig_ptr[i] = NULL;
1615         }
1616     }
1617     if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1618         if (i) {
1619             (void)rsignal(i, PL_csighandlerp);
1620         }
1621         else
1622             *svp = SvREFCNT_inc_simple_NN(sv);
1623     } else {
1624         if (sv && SvOK(sv)) {
1625             s = SvPV_force(sv, len);
1626         } else {
1627             sv = NULL;
1628         }
1629         if (sv && memEQs(s, len,"IGNORE")) {
1630             if (i) {
1631 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1632                 PL_sig_ignoring[i] = 1;
1633                 (void)rsignal(i, PL_csighandlerp);
1634 #else
1635                 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1636 #endif
1637             }
1638         }
1639         else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
1640             if (i) {
1641 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1642                 PL_sig_defaulting[i] = 1;
1643                 (void)rsignal(i, PL_csighandlerp);
1644 #else
1645                 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1646 #endif
1647             }
1648         }
1649         else {
1650             /*
1651              * We should warn if HINT_STRICT_REFS, but without
1652              * access to a known hint bit in a known OP, we can't
1653              * tell whether HINT_STRICT_REFS is in force or not.
1654              */
1655             if (!strchr(s,':') && !strchr(s,'\''))
1656                 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1657                                      SV_GMAGIC);
1658             if (i)
1659                 (void)rsignal(i, PL_csighandlerp);
1660             else
1661                 *svp = SvREFCNT_inc_simple_NN(sv);
1662         }
1663     }
1664
1665 #ifdef HAS_SIGPROCMASK
1666     if(i)
1667         LEAVE;
1668 #endif
1669     SvREFCNT_dec(to_dec);
1670     return 0;
1671 }
1672 #endif /* !PERL_MICRO */
1673
1674 int
1675 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1676 {
1677     dVAR;
1678     PERL_ARGS_ASSERT_MAGIC_SETISA;
1679     PERL_UNUSED_ARG(sv);
1680
1681     /* Skip _isaelem because _isa will handle it shortly */
1682     if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1683         return 0;
1684
1685     return magic_clearisa(NULL, mg);
1686 }
1687
1688 /* sv of NULL signifies that we're acting as magic_setisa.  */
1689 int
1690 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1691 {
1692     dVAR;
1693     HV* stash;
1694
1695     PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1696
1697     /* Bail out if destruction is going on */
1698     if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1699
1700     if (sv)
1701         av_clear(MUTABLE_AV(sv));
1702
1703     if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1704         /* This occurs with setisa_elem magic, which calls this
1705            same function. */
1706         mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1707
1708     if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1709         SV **svp = AvARRAY((AV *)mg->mg_obj);
1710         I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1711         while (items--) {
1712             stash = GvSTASH((GV *)*svp++);
1713             if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1714         }
1715
1716         return 0;
1717     }
1718
1719     stash = GvSTASH(
1720         (const GV *)mg->mg_obj
1721     );
1722
1723     /* The stash may have been detached from the symbol table, so check its
1724        name before doing anything. */
1725     if (stash && HvENAME_get(stash))
1726         mro_isa_changed_in(stash);
1727
1728     return 0;
1729 }
1730
1731 int
1732 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1733 {
1734     HV * const hv = MUTABLE_HV(LvTARG(sv));
1735     I32 i = 0;
1736
1737     PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1738     PERL_UNUSED_ARG(mg);
1739
1740     if (hv) {
1741          (void) hv_iterinit(hv);
1742          if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1743              i = HvUSEDKEYS(hv);
1744          else {
1745              while (hv_iternext(hv))
1746                  i++;
1747          }
1748     }
1749
1750     sv_setiv(sv, (IV)i);
1751     return 0;
1752 }
1753
1754 int
1755 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1756 {
1757     PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1758     PERL_UNUSED_ARG(mg);
1759     if (LvTARG(sv)) {
1760         hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1761     }
1762     return 0;
1763 }
1764
1765 /*
1766 =for apidoc magic_methcall
1767
1768 Invoke a magic method (like FETCH).
1769
1770 C<sv> and C<mg> are the tied thingy and the tie magic.
1771
1772 C<meth> is the name of the method to call.
1773
1774 C<argc> is the number of args (in addition to $self) to pass to the method.
1775
1776 The C<flags> can be:
1777
1778     G_DISCARD     invoke method with G_DISCARD flag and don't
1779                   return a value
1780     G_UNDEF_FILL  fill the stack with argc pointers to
1781                   PL_sv_undef
1782
1783 The arguments themselves are any values following the C<flags> argument.
1784
1785 Returns the SV (if any) returned by the method, or NULL on failure.
1786
1787
1788 =cut
1789 */
1790
1791 SV*
1792 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1793                     U32 argc, ...)
1794 {
1795     dVAR;
1796     dSP;
1797     SV* ret = NULL;
1798
1799     PERL_ARGS_ASSERT_MAGIC_METHCALL;
1800
1801     ENTER;
1802
1803     if (flags & G_WRITING_TO_STDERR) {
1804         SAVETMPS;
1805
1806         save_re_context();
1807         SAVESPTR(PL_stderrgv);
1808         PL_stderrgv = NULL;
1809     }
1810
1811     PUSHSTACKi(PERLSI_MAGIC);
1812     PUSHMARK(SP);
1813
1814     EXTEND(SP, argc+1);
1815     PUSHs(SvTIED_obj(sv, mg));
1816     if (flags & G_UNDEF_FILL) {
1817         while (argc--) {
1818             PUSHs(&PL_sv_undef);
1819         }
1820     } else if (argc > 0) {
1821         va_list args;
1822         va_start(args, argc);
1823
1824         do {
1825             SV *const sv = va_arg(args, SV *);
1826             PUSHs(sv);
1827         } while (--argc);
1828
1829         va_end(args);
1830     }
1831     PUTBACK;
1832     if (flags & G_DISCARD) {
1833         call_method(meth, G_SCALAR|G_DISCARD);
1834     }
1835     else {
1836         if (call_method(meth, G_SCALAR))
1837             ret = *PL_stack_sp--;
1838     }
1839     POPSTACK;
1840     if (flags & G_WRITING_TO_STDERR)
1841         FREETMPS;
1842     LEAVE;
1843     return ret;
1844 }
1845
1846
1847 /* wrapper for magic_methcall that creates the first arg */
1848
1849 STATIC SV*
1850 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1851     int n, SV *val)
1852 {
1853     dVAR;
1854     SV* arg1 = NULL;
1855
1856     PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1857
1858     if (mg->mg_ptr) {
1859         if (mg->mg_len >= 0) {
1860             arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1861         }
1862         else if (mg->mg_len == HEf_SVKEY)
1863             arg1 = MUTABLE_SV(mg->mg_ptr);
1864     }
1865     else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1866         arg1 = newSViv((IV)(mg->mg_len));
1867         sv_2mortal(arg1);
1868     }
1869     if (!arg1) {
1870         return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1871     }
1872     return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1873 }
1874
1875 STATIC int
1876 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1877 {
1878     dVAR;
1879     SV* ret;
1880
1881     PERL_ARGS_ASSERT_MAGIC_METHPACK;
1882
1883     ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1884     if (ret)
1885         sv_setsv(sv, ret);
1886     return 0;
1887 }
1888
1889 int
1890 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1891 {
1892     PERL_ARGS_ASSERT_MAGIC_GETPACK;
1893
1894     if (mg->mg_type == PERL_MAGIC_tiedelem)
1895         mg->mg_flags |= MGf_GSKIP;
1896     magic_methpack(sv,mg,"FETCH");
1897     return 0;
1898 }
1899
1900 int
1901 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1902 {
1903     dVAR;
1904     MAGIC *tmg;
1905     SV    *val;
1906
1907     PERL_ARGS_ASSERT_MAGIC_SETPACK;
1908
1909     /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1910      * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1911      * public flags indicate its value based on copying from $val. Doing
1912      * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1913      * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1914      * wrong if $val happened to be tainted, as sv hasn't got magic
1915      * enabled, even though taint magic is in the chain. In which case,
1916      * fake up a temporary tainted value (this is easier than temporarily
1917      * re-enabling magic on sv). */
1918
1919     if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
1920         && (tmg->mg_len & 1))
1921     {
1922         val = sv_mortalcopy(sv);
1923         SvTAINTED_on(val);
1924     }
1925     else
1926         val = sv;
1927
1928     magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
1929     return 0;
1930 }
1931
1932 int
1933 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1934 {
1935     PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1936
1937     if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
1938     return magic_methpack(sv,mg,"DELETE");
1939 }
1940
1941
1942 U32
1943 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1944 {
1945     dVAR;
1946     I32 retval = 0;
1947     SV* retsv;
1948
1949     PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1950
1951     retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
1952     if (retsv) {
1953         retval = SvIV(retsv)-1;
1954         if (retval < -1)
1955             Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1956     }
1957     return (U32) retval;
1958 }
1959
1960 int
1961 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1962 {
1963     dVAR;
1964
1965     PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1966
1967     Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
1968     return 0;
1969 }
1970
1971 int
1972 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1973 {
1974     dVAR;
1975     SV* ret;
1976
1977     PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1978
1979     ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
1980         : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
1981     if (ret)
1982         sv_setsv(key,ret);
1983     return 0;
1984 }
1985
1986 int
1987 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1988 {
1989     PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1990
1991     return magic_methpack(sv,mg,"EXISTS");
1992 }
1993
1994 SV *
1995 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1996 {
1997     dVAR;
1998     SV *retval;
1999     SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
2000     HV * const pkg = SvSTASH((const SV *)SvRV(tied));
2001
2002     PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
2003
2004     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
2005         SV *key;
2006         if (HvEITER_get(hv))
2007             /* we are in an iteration so the hash cannot be empty */
2008             return &PL_sv_yes;
2009         /* no xhv_eiter so now use FIRSTKEY */
2010         key = sv_newmortal();
2011         magic_nextpack(MUTABLE_SV(hv), mg, key);
2012         HvEITER_set(hv, NULL);     /* need to reset iterator */
2013         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
2014     }
2015
2016     /* there is a SCALAR method that we can call */
2017     retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
2018     if (!retval)
2019         retval = &PL_sv_undef;
2020     return retval;
2021 }
2022
2023 int
2024 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
2025 {
2026     dVAR;
2027     GV * const gv = PL_DBline;
2028     const I32 i = SvTRUE(sv);
2029     SV ** const svp = av_fetch(GvAV(gv),
2030                      atoi(MgPV_nolen_const(mg)), FALSE);
2031
2032     PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
2033
2034     if (svp && SvIOKp(*svp)) {
2035         OP * const o = INT2PTR(OP*,SvIVX(*svp));
2036         if (o) {
2037 #ifdef PERL_DEBUG_READONLY_OPS
2038             Slab_to_rw(OpSLAB(o));
2039 #endif
2040             /* set or clear breakpoint in the relevant control op */
2041             if (i)
2042                 o->op_flags |= OPf_SPECIAL;
2043             else
2044                 o->op_flags &= ~OPf_SPECIAL;
2045 #ifdef PERL_DEBUG_READONLY_OPS
2046             Slab_to_ro(OpSLAB(o));
2047 #endif
2048         }
2049     }
2050     return 0;
2051 }
2052
2053 int
2054 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
2055 {
2056     dVAR;
2057     AV * const obj = MUTABLE_AV(mg->mg_obj);
2058
2059     PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2060
2061     if (obj) {
2062         sv_setiv(sv, AvFILL(obj));
2063     } else {
2064         SvOK_off(sv);
2065     }
2066     return 0;
2067 }
2068
2069 int
2070 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2071 {
2072     dVAR;
2073     AV * const obj = MUTABLE_AV(mg->mg_obj);
2074
2075     PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2076
2077     if (obj) {
2078         av_fill(obj, SvIV(sv));
2079     } else {
2080         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2081                        "Attempt to set length of freed array");
2082     }
2083     return 0;
2084 }
2085
2086 int
2087 Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
2088 {
2089     dVAR;
2090
2091     PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
2092     PERL_UNUSED_ARG(sv);
2093
2094     /* Reset the iterator when the array is cleared */
2095 #if IVSIZE == I32SIZE
2096     *((IV *) &(mg->mg_len)) = 0;
2097 #else
2098     if (mg->mg_ptr)
2099         *((IV *) mg->mg_ptr) = 0;
2100 #endif
2101
2102     return 0;
2103 }
2104
2105 int
2106 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2107 {
2108     dVAR;
2109
2110     PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2111     PERL_UNUSED_ARG(sv);
2112
2113     /* during global destruction, mg_obj may already have been freed */
2114     if (PL_in_clean_all)
2115         return 0;
2116
2117     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2118
2119     if (mg) {
2120         /* arylen scalar holds a pointer back to the array, but doesn't own a
2121            reference. Hence the we (the array) are about to go away with it
2122            still pointing at us. Clear its pointer, else it would be pointing
2123            at free memory. See the comment in sv_magic about reference loops,
2124            and why it can't own a reference to us.  */
2125         mg->mg_obj = 0;
2126     }
2127     return 0;
2128 }
2129
2130 int
2131 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2132 {
2133     dVAR;
2134     SV* const lsv = LvTARG(sv);
2135
2136     PERL_ARGS_ASSERT_MAGIC_GETPOS;
2137     PERL_UNUSED_ARG(mg);
2138
2139     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
2140         MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
2141         if (found && found->mg_len >= 0) {
2142             I32 i = found->mg_len;
2143             if (DO_UTF8(lsv))
2144                 sv_pos_b2u(lsv, &i);
2145             sv_setiv(sv, i);
2146             return 0;
2147         }
2148     }
2149     SvOK_off(sv);
2150     return 0;
2151 }
2152
2153 int
2154 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2155 {
2156     dVAR;
2157     SV* const lsv = LvTARG(sv);
2158     SSize_t pos;
2159     STRLEN len;
2160     STRLEN ulen = 0;
2161     MAGIC* found;
2162
2163     PERL_ARGS_ASSERT_MAGIC_SETPOS;
2164     PERL_UNUSED_ARG(mg);
2165
2166     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2167         found = mg_find(lsv, PERL_MAGIC_regex_global);
2168     else
2169         found = NULL;
2170     if (!found) {
2171         if (!SvOK(sv))
2172             return 0;
2173 #ifdef PERL_OLD_COPY_ON_WRITE
2174     if (SvIsCOW(lsv))
2175         sv_force_normal_flags(lsv, 0);
2176 #endif
2177         found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2178                             NULL, 0);
2179     }
2180     else if (!SvOK(sv)) {
2181         found->mg_len = -1;
2182         return 0;
2183     }
2184     len = SvPOK_nog(lsv) ? SvCUR(lsv) : sv_len(lsv);
2185
2186     pos = SvIV(sv);
2187
2188     if (DO_UTF8(lsv)) {
2189         ulen = sv_len_utf8_nomg(lsv);
2190         if (ulen)
2191             len = ulen;
2192     }
2193
2194     if (pos < 0) {
2195         pos += len;
2196         if (pos < 0)
2197             pos = 0;
2198     }
2199     else if (pos > (SSize_t)len)
2200         pos = len;
2201
2202     if (ulen) {
2203         pos = sv_pos_u2b_flags(lsv, pos, 0, 0);
2204     }
2205
2206     found->mg_len = pos;
2207     found->mg_flags &= ~MGf_MINMATCH;
2208
2209     return 0;
2210 }
2211
2212 int
2213 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2214 {
2215     STRLEN len;
2216     SV * const lsv = LvTARG(sv);
2217     const char * const tmps = SvPV_const(lsv,len);
2218     STRLEN offs = LvTARGOFF(sv);
2219     STRLEN rem = LvTARGLEN(sv);
2220     const bool negoff = LvFLAGS(sv) & 1;
2221     const bool negrem = LvFLAGS(sv) & 2;
2222
2223     PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2224     PERL_UNUSED_ARG(mg);
2225
2226     if (!translate_substr_offsets(
2227             SvUTF8(lsv) ? sv_len_utf8_nomg(lsv) : len,
2228             negoff ? -(IV)offs : (IV)offs, !negoff,
2229             negrem ? -(IV)rem  : (IV)rem,  !negrem, &offs, &rem
2230     )) {
2231         Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2232         sv_setsv_nomg(sv, &PL_sv_undef);
2233         return 0;
2234     }
2235
2236     if (SvUTF8(lsv))
2237         offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
2238     sv_setpvn(sv, tmps + offs, rem);
2239     if (SvUTF8(lsv))
2240         SvUTF8_on(sv);
2241     return 0;
2242 }
2243
2244 int
2245 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2246 {
2247     dVAR;
2248     STRLEN len, lsv_len, oldtarglen, newtarglen;
2249     const char * const tmps = SvPV_const(sv, len);
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     if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
2265     else (void)SvPV_nomg(lsv,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(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  */