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