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