mg.c

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