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