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