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