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