mg.c

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