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) && !SvIsCOW(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     /* Turning READONLY off for a copy-on-write scalar (including shared
 125        hash keys) is a bad idea.  */
 126     if (!SvIsCOW(sv)) SvREADONLY_off(sv);
 127 }
 128
 129 #define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG)
 130
 131 /*
 132 =for apidoc mg_magical
 133
 134 Turns on the magical status of an SV.  See C<sv_magic>.
 135
 136 =cut
 137 */
 138
 139 void
 140 Perl_mg_magical(pTHX_ SV *sv)
 141 {
 142     const MAGIC* mg;
 143     PERL_ARGS_ASSERT_MG_MAGICAL;
 144     PERL_UNUSED_CONTEXT;
 145
 146     SvMAGICAL_off(sv);
 147     if ((mg = SvMAGIC(sv))) {
 148         do {
 149             const MGVTBL* const vtbl = mg->mg_virtual;
 150             if (vtbl) {
 151                 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
 152                     SvGMAGICAL_on(sv);
 153                 if (vtbl->svt_set)
 154                     SvSMAGICAL_on(sv);
 155                 if (vtbl->svt_clear)
 156                     SvRMAGICAL_on(sv);
 157             }
 158         } while ((mg = mg->mg_moremagic));
 159         if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
 160             SvRMAGICAL_on(sv);
 161     }
 162 }
 163
 164 /*
 165 =for apidoc mg_get
 166
 167 Do magic before a value is retrieved from the SV.  The type of SV must
 168 be >= SVt_PVMG. See C<sv_magic>.
 169
 170 =cut
 171 */
 172
 173 int
 174 Perl_mg_get(pTHX_ SV *sv)
 175 {
 176     dVAR;
 177     const I32 mgs_ix = SSNEW(sizeof(MGS));
 178     bool saved = FALSE;
 179     bool have_new = 0;
 180     MAGIC *newmg, *head, *cur, *mg;
 181
 182     PERL_ARGS_ASSERT_MG_GET;
 183
 184     if (PL_localizing == 1 && sv == DEFSV) return 0;
 185
 186     /* We must call svt_get(sv, mg) for each valid entry in the linked
 187        list of magic. svt_get() may delete the current entry, add new
 188        magic to the head of the list, or upgrade the SV. AMS 20010810 */
 189
 190     newmg = cur = head = mg = SvMAGIC(sv);
 191     while (mg) {
 192         const MGVTBL * const vtbl = mg->mg_virtual;
 193         MAGIC * const nextmg = mg->mg_moremagic;        /* it may delete itself */
 194
 195         if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
 196
 197             /* taint's mg get is so dumb it doesn't need flag saving */
 198             if (!saved && mg->mg_type != PERL_MAGIC_taint) {
 199                 save_magic(mgs_ix, sv);
 200                 saved = TRUE;
 201             }
 202
 203             vtbl->svt_get(aTHX_ sv, mg);
 204
 205             /* guard against magic having been deleted - eg FETCH calling
 206              * untie */
 207             if (!SvMAGIC(sv)) {
 208                 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
 209                 break;
 210             }
 211
 212             /* recalculate flags if this entry was deleted. */
 213             if (mg->mg_flags & MGf_GSKIP)
 214                 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
 215         }
 216         else if (vtbl == &PL_vtbl_utf8) {
 217             /* get-magic can reallocate the PV */
 218             magic_setutf8(sv, mg);
 219         }
 220
 221         mg = nextmg;
 222
 223         if (have_new) {
 224             /* Have we finished with the new entries we saw? Start again
 225                where we left off (unless there are more new entries). */
 226             if (mg == head) {
 227                 have_new = 0;
 228                 mg   = cur;
 229                 head = newmg;
 230             }
 231         }
 232
 233         /* Were any new entries added? */
 234         if (!have_new && (newmg = SvMAGIC(sv)) != head) {
 235             have_new = 1;
 236             cur = mg;
 237             mg  = newmg;
 238             (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
 239         }
 240     }
 241
 242     if (saved)
 243         restore_magic(INT2PTR(void *, (IV)mgs_ix));
 244
 245     return 0;
 246 }
 247
 248 /*
 249 =for apidoc mg_set
 250
 251 Do magic after a value is assigned to the SV.  See C<sv_magic>.
 252
 253 =cut
 254 */
 255
 256 int
 257 Perl_mg_set(pTHX_ SV *sv)
 258 {
 259     dVAR;
 260     const I32 mgs_ix = SSNEW(sizeof(MGS));
 261     MAGIC* mg;
 262     MAGIC* nextmg;
 263
 264     PERL_ARGS_ASSERT_MG_SET;
 265
 266     if (PL_localizing == 2 && sv == DEFSV) return 0;
 267
 268     save_magic_flags(mgs_ix, sv, SVs_GMG|SVs_SMG); /* leave SVs_RMG on */
 269
 270     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
 271         const MGVTBL* vtbl = mg->mg_virtual;
 272         nextmg = mg->mg_moremagic;      /* it may delete itself */
 273         if (mg->mg_flags & MGf_GSKIP) {
 274             mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
 275             (SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
 276         }
 277         if (PL_localizing == 2
 278             && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
 279             continue;
 280         if (vtbl && vtbl->svt_set)
 281             vtbl->svt_set(aTHX_ sv, mg);
 282     }
 283
 284     restore_magic(INT2PTR(void*, (IV)mgs_ix));
 285     return 0;
 286 }
 287
 288 /*
 289 =for apidoc mg_length
 290
 291 Reports on the SV's length in bytes, calling length magic if available,
 292 but does not set the UTF8 flag on the sv.  It will fall back to 'get'
 293 magic if there is no 'length' magic, but with no indication as to
 294 whether it called 'get' magic.  It assumes the sv is a PVMG or
 295 higher.  Use sv_len() instead.
 296
 297 =cut
 298 */
 299
 300 U32
 301 Perl_mg_length(pTHX_ SV *sv)
 302 {
 303     dVAR;
 304     MAGIC* mg;
 305     STRLEN len;
 306
 307     PERL_ARGS_ASSERT_MG_LENGTH;
 308
 309     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 310         const MGVTBL * const vtbl = mg->mg_virtual;
 311         if (vtbl && vtbl->svt_len) {
 312             const I32 mgs_ix = SSNEW(sizeof(MGS));
 313             save_magic(mgs_ix, sv);
 314             /* omit MGf_GSKIP -- not changed here */
 315             len = vtbl->svt_len(aTHX_ sv, mg);
 316             restore_magic(INT2PTR(void*, (IV)mgs_ix));
 317             return len;
 318         }
 319     }
 320
 321     (void)SvPV_const(sv, len);
 322     return len;
 323 }
 324
 325 I32
 326 Perl_mg_size(pTHX_ SV *sv)
 327 {
 328     MAGIC* mg;
 329
 330     PERL_ARGS_ASSERT_MG_SIZE;
 331
 332     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 333         const MGVTBL* const vtbl = mg->mg_virtual;
 334         if (vtbl && vtbl->svt_len) {
 335             const I32 mgs_ix = SSNEW(sizeof(MGS));
 336             I32 len;
 337             save_magic(mgs_ix, sv);
 338             /* omit MGf_GSKIP -- not changed here */
 339             len = vtbl->svt_len(aTHX_ sv, mg);
 340             restore_magic(INT2PTR(void*, (IV)mgs_ix));
 341             return len;
 342         }
 343     }
 344
 345     switch(SvTYPE(sv)) {
 346         case SVt_PVAV:
 347             return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
 348         case SVt_PVHV:
 349             /* FIXME */
 350         default:
 351             Perl_croak(aTHX_ "Size magic not implemented");
 352             break;
 353     }
 354     return 0;
 355 }
 356
 357 /*
 358 =for apidoc mg_clear
 359
 360 Clear something magical that the SV represents.  See C<sv_magic>.
 361
 362 =cut
 363 */
 364
 365 int
 366 Perl_mg_clear(pTHX_ SV *sv)
 367 {
 368     const I32 mgs_ix = SSNEW(sizeof(MGS));
 369     MAGIC* mg;
 370     MAGIC *nextmg;
 371
 372     PERL_ARGS_ASSERT_MG_CLEAR;
 373
 374     save_magic(mgs_ix, sv);
 375
 376     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
 377         const MGVTBL* const vtbl = mg->mg_virtual;
 378         /* omit GSKIP -- never set here */
 379
 380         nextmg = mg->mg_moremagic; /* it may delete itself */
 381
 382         if (vtbl && vtbl->svt_clear)
 383             vtbl->svt_clear(aTHX_ sv, mg);
 384     }
 385
 386     restore_magic(INT2PTR(void*, (IV)mgs_ix));
 387     return 0;
 388 }
 389
 390 static MAGIC*
 391 S_mg_findext_flags(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
 392 {
 393     PERL_UNUSED_CONTEXT;
 394
 395     assert(flags <= 1);
 396
 397     if (sv) {
 398         MAGIC *mg;
 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         if (!SvIsCOW(sv)) 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 >= 0) {
2100             I32 i = found->mg_len;
2101             if (DO_UTF8(lsv))
2102                 sv_pos_b2u(lsv, &i);
2103             sv_setiv(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 int
2305 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2306 {
2307     dVAR;
2308     SV *targ = NULL;
2309
2310     PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2311
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     }
2334     else
2335         targ = LvTARG(sv);
2336     sv_setsv(sv, targ ? targ : &PL_sv_undef);
2337     return 0;
2338 }
2339
2340 int
2341 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2342 {
2343     PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2344     PERL_UNUSED_ARG(mg);
2345     if (LvTARGLEN(sv))
2346         vivify_defelem(sv);
2347     if (LvTARG(sv)) {
2348         sv_setsv(LvTARG(sv), sv);
2349         SvSETMAGIC(LvTARG(sv));
2350     }
2351     return 0;
2352 }
2353
2354 void
2355 Perl_vivify_defelem(pTHX_ SV *sv)
2356 {
2357     dVAR;
2358     MAGIC *mg;
2359     SV *value = NULL;
2360
2361     PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2362
2363     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2364         return;
2365     if (mg->mg_obj) {
2366         SV * const ahv = LvTARG(sv);
2367         HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2368         if (he)
2369             value = HeVAL(he);
2370         if (!value || value == &PL_sv_undef)
2371             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2372     }
2373     else {
2374         AV *const av = MUTABLE_AV(LvTARG(sv));
2375         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2376             LvTARG(sv) = NULL;  /* array can't be extended */
2377         else {
2378             SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2379             if (!svp || (value = *svp) == &PL_sv_undef)
2380                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2381         }
2382     }
2383     SvREFCNT_inc_simple_void(value);
2384     SvREFCNT_dec(LvTARG(sv));
2385     LvTARG(sv) = value;
2386     LvTARGLEN(sv) = 0;
2387     SvREFCNT_dec(mg->mg_obj);
2388     mg->mg_obj = NULL;
2389     mg->mg_flags &= ~MGf_REFCOUNTED;
2390 }
2391
2392 int
2393 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2394 {
2395     PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2396     Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2397     return 0;
2398 }
2399
2400 int
2401 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2402 {
2403     PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2404     PERL_UNUSED_CONTEXT;
2405     PERL_UNUSED_ARG(sv);
2406     mg->mg_len = -1;
2407     return 0;
2408 }
2409
2410 int
2411 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2412 {
2413     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2414
2415     PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2416
2417     if (uf && uf->uf_set)
2418         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2419     return 0;
2420 }
2421
2422 int
2423 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2424 {
2425     const char type = mg->mg_type;
2426
2427     PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2428
2429     if (type == PERL_MAGIC_qr) {
2430     } else if (type == PERL_MAGIC_bm) {
2431         SvTAIL_off(sv);
2432         SvVALID_off(sv);
2433     } else {
2434         assert(type == PERL_MAGIC_fm);
2435     }
2436     return sv_unmagic(sv, type);
2437 }
2438
2439 #ifdef USE_LOCALE_COLLATE
2440 int
2441 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2442 {
2443     PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2444
2445     /*
2446      * RenE<eacute> Descartes said "I think not."
2447      * and vanished with a faint plop.
2448      */
2449     PERL_UNUSED_CONTEXT;
2450     PERL_UNUSED_ARG(sv);
2451     if (mg->mg_ptr) {
2452         Safefree(mg->mg_ptr);
2453         mg->mg_ptr = NULL;
2454         mg->mg_len = -1;
2455     }
2456     return 0;
2457 }
2458 #endif /* USE_LOCALE_COLLATE */
2459
2460 /* Just clear the UTF-8 cache data. */
2461 int
2462 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2463 {
2464     PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2465     PERL_UNUSED_CONTEXT;
2466     PERL_UNUSED_ARG(sv);
2467     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2468     mg->mg_ptr = NULL;
2469     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2470     return 0;
2471 }
2472
2473 int
2474 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2475 {
2476     dVAR;
2477     const char *s;
2478     I32 paren;
2479     const REGEXP * rx;
2480     const char * const remaining = mg->mg_ptr + 1;
2481     I32 i;
2482     STRLEN len;
2483     MAGIC *tmg;
2484
2485     PERL_ARGS_ASSERT_MAGIC_SET;
2486
2487     switch (*mg->mg_ptr) {
2488     case '\015': /* $^MATCH */
2489       if (strEQ(remaining, "ATCH"))
2490           goto do_match;
2491     case '`': /* ${^PREMATCH} caught below */
2492       do_prematch:
2493       paren = RX_BUFF_IDX_PREMATCH;
2494       goto setparen;
2495     case '\'': /* ${^POSTMATCH} caught below */
2496       do_postmatch:
2497       paren = RX_BUFF_IDX_POSTMATCH;
2498       goto setparen;
2499     case '&':
2500       do_match:
2501       paren = RX_BUFF_IDX_FULLMATCH;
2502       goto setparen;
2503     case '1': case '2': case '3': case '4':
2504     case '5': case '6': case '7': case '8': case '9':
2505       paren = atoi(mg->mg_ptr);
2506       setparen:
2507         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2508       setparen_got_rx:
2509             CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2510         } else {
2511             /* Croak with a READONLY error when a numbered match var is
2512              * set without a previous pattern match. Unless it's C<local $1>
2513              */
2514       croakparen:
2515             if (!PL_localizing) {
2516                 Perl_croak_no_modify();
2517             }
2518         }
2519         break;
2520     case '\001':        /* ^A */
2521         if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2522         else SvOK_off(PL_bodytarget);
2523         FmLINES(PL_bodytarget) = 0;
2524         if (SvPOK(PL_bodytarget)) {
2525             char *s = SvPVX(PL_bodytarget);
2526             while ( ((s = strchr(s, '\n'))) ) {
2527                 FmLINES(PL_bodytarget)++;
2528                 s++;
2529             }
2530         }
2531         /* mg_set() has temporarily made sv non-magical */
2532         if (TAINTING_get) {
2533             if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2534                 SvTAINTED_on(PL_bodytarget);
2535             else
2536                 SvTAINTED_off(PL_bodytarget);
2537         }
2538         break;
2539     case '\003':        /* ^C */
2540         PL_minus_c = cBOOL(SvIV(sv));
2541         break;
2542
2543     case '\004':        /* ^D */
2544 #ifdef DEBUGGING
2545         s = SvPV_nolen_const(sv);
2546         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2547         if (DEBUG_x_TEST || DEBUG_B_TEST)
2548             dump_all_perl(!DEBUG_B_TEST);
2549 #else
2550         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2551 #endif
2552         break;
2553     case '\005':  /* ^E */
2554         if (*(mg->mg_ptr+1) == '\0') {
2555 #ifdef VMS
2556             set_vaxc_errno(SvIV(sv));
2557 #else
2558 #  ifdef WIN32
2559             SetLastError( SvIV(sv) );
2560 #  else
2561 #    ifdef OS2
2562             os2_setsyserrno(SvIV(sv));
2563 #    else
2564             /* will anyone ever use this? */
2565             SETERRNO(SvIV(sv), 4);
2566 #    endif
2567 #  endif
2568 #endif
2569         }
2570         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2571             SvREFCNT_dec(PL_encoding);
2572             if (SvOK(sv) || SvGMAGICAL(sv)) {
2573                 PL_encoding = newSVsv(sv);
2574             }
2575             else {
2576                 PL_encoding = NULL;
2577             }
2578         }
2579         break;
2580     case '\006':        /* ^F */
2581         PL_maxsysfd = SvIV(sv);
2582         break;
2583     case '\010':        /* ^H */
2584         PL_hints = SvIV(sv);
2585         break;
2586     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2587         Safefree(PL_inplace);
2588         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2589         break;
2590     case '\016':        /* ^N */
2591         if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2592          && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2593         goto croakparen;
2594     case '\017':        /* ^O */
2595         if (*(mg->mg_ptr+1) == '\0') {
2596             Safefree(PL_osname);
2597             PL_osname = NULL;
2598             if (SvOK(sv)) {
2599                 TAINT_PROPER("assigning to $^O");
2600                 PL_osname = savesvpv(sv);
2601             }
2602         }
2603         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2604             STRLEN len;
2605             const char *const start = SvPV(sv, len);
2606             const char *out = (const char*)memchr(start, '\0', len);
2607             SV *tmp;
2608
2609
2610             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2611             PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2612
2613             /* Opening for input is more common than opening for output, so
2614                ensure that hints for input are sooner on linked list.  */
2615             tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2616                                        SvUTF8(sv))
2617                 : newSVpvs_flags("", SvUTF8(sv));
2618             (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2619             mg_set(tmp);
2620
2621             tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2622                                         SvUTF8(sv));
2623             (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2624             mg_set(tmp);
2625         }
2626         break;
2627     case '\020':        /* ^P */
2628       if (*remaining == '\0') { /* ^P */
2629           PL_perldb = SvIV(sv);
2630           if (PL_perldb && !PL_DBsingle)
2631               init_debugger();
2632           break;
2633       } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2634           goto do_prematch;
2635       } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2636           goto do_postmatch;
2637       }
2638       break;
2639     case '\024':        /* ^T */
2640 #ifdef BIG_TIME
2641         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2642 #else
2643         PL_basetime = (Time_t)SvIV(sv);
2644 #endif
2645         break;
2646     case '\025':        /* ^UTF8CACHE */
2647          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2648              PL_utf8cache = (signed char) sv_2iv(sv);
2649          }
2650          break;
2651     case '\027':        /* ^W & $^WARNING_BITS */
2652         if (*(mg->mg_ptr+1) == '\0') {
2653             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2654                 i = SvIV(sv);
2655                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2656                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2657             }
2658         }
2659         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2660             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2661                 if (!SvPOK(sv)) {
2662                     PL_compiling.cop_warnings = pWARN_STD;
2663                     break;
2664                 }
2665                 {
2666                     STRLEN len, i;
2667                     int accumulate = 0 ;
2668                     int any_fatals = 0 ;
2669                     const char * const ptr = SvPV_const(sv, len) ;
2670                     for (i = 0 ; i < len ; ++i) {
2671                         accumulate |= ptr[i] ;
2672                         any_fatals |= (ptr[i] & 0xAA) ;
2673                     }
2674                     if (!accumulate) {
2675                         if (!specialWARN(PL_compiling.cop_warnings))
2676                             PerlMemShared_free(PL_compiling.cop_warnings);
2677                         PL_compiling.cop_warnings = pWARN_NONE;
2678                     }
2679                     /* Yuck. I can't see how to abstract this:  */
2680                     else if (isWARN_on(
2681                                 ((STRLEN *)SvPV_nolen_const(sv)) - 1,
2682                                 WARN_ALL)
2683                             && !any_fatals)
2684                     {
2685                         if (!specialWARN(PL_compiling.cop_warnings))
2686                             PerlMemShared_free(PL_compiling.cop_warnings);
2687                         PL_compiling.cop_warnings = pWARN_ALL;
2688                         PL_dowarn |= G_WARN_ONCE ;
2689                     }
2690                     else {
2691                         STRLEN len;
2692                         const char *const p = SvPV_const(sv, len);
2693
2694                         PL_compiling.cop_warnings
2695                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2696                                                          p, len);
2697
2698                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2699                             PL_dowarn |= G_WARN_ONCE ;
2700                     }
2701
2702                 }
2703             }
2704         }
2705         break;
2706     case '.':
2707         if (PL_localizing) {
2708             if (PL_localizing == 1)
2709                 SAVESPTR(PL_last_in_gv);
2710         }
2711         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2712             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2713         break;
2714     case '^':
2715         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2716         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2717         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2718         break;
2719     case '~':
2720         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2721         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2722         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2723         break;
2724     case '=':
2725         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2726         break;
2727     case '-':
2728         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2729         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2730                 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2731         break;
2732     case '%':
2733         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2734         break;
2735     case '|':
2736         {
2737             IO * const io = GvIO(PL_defoutgv);
2738             if(!io)
2739               break;
2740             if ((SvIV(sv)) == 0)
2741                 IoFLAGS(io) &= ~IOf_FLUSH;
2742             else {
2743                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2744                     PerlIO *ofp = IoOFP(io);
2745                     if (ofp)
2746                         (void)PerlIO_flush(ofp);
2747                     IoFLAGS(io) |= IOf_FLUSH;
2748                 }
2749             }
2750         }
2751         break;
2752     case '/':
2753         SvREFCNT_dec(PL_rs);
2754         PL_rs = newSVsv(sv);
2755         break;
2756     case '\\':
2757         SvREFCNT_dec(PL_ors_sv);
2758         if (SvOK(sv)) {
2759             PL_ors_sv = newSVsv(sv);
2760         }
2761         else {
2762             PL_ors_sv = NULL;
2763         }
2764         break;
2765     case '[':
2766         if (SvIV(sv) != 0)
2767             Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
2768         break;
2769     case '?':
2770 #ifdef COMPLEX_STATUS
2771         if (PL_localizing == 2) {
2772             SvUPGRADE(sv, SVt_PVLV);
2773             PL_statusvalue = LvTARGOFF(sv);
2774             PL_statusvalue_vms = LvTARGLEN(sv);
2775         }
2776         else
2777 #endif
2778 #ifdef VMSISH_STATUS
2779         if (VMSISH_STATUS)
2780             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2781         else
2782 #endif
2783             STATUS_UNIX_EXIT_SET(SvIV(sv));
2784         break;
2785     case '!':
2786         {
2787 #ifdef VMS
2788 #   define PERL_VMS_BANG vaxc$errno
2789 #else
2790 #   define PERL_VMS_BANG 0
2791 #endif
2792         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2793                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2794         }
2795         break;
2796     case '<':
2797         {
2798         const Uid_t new_uid = SvUID(sv);
2799         PL_delaymagic_uid = new_uid;
2800         if (PL_delaymagic) {
2801             PL_delaymagic |= DM_RUID;
2802             break;                              /* don't do magic till later */
2803         }
2804 #ifdef HAS_SETRUID
2805         (void)setruid(new_uid);
2806 #else
2807 #ifdef HAS_SETREUID
2808         (void)setreuid(new_uid, (Uid_t)-1);
2809 #else
2810 #ifdef HAS_SETRESUID
2811       (void)setresuid(new_uid, (Uid_t)-1, (Uid_t)-1);
2812 #else
2813         if (new_uid == PerlProc_geteuid()) {            /* special case $< = $> */
2814 #ifdef PERL_DARWIN
2815             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2816             if (new_uid != 0 && PerlProc_getuid() == 0)
2817                 (void)PerlProc_setuid(0);
2818 #endif
2819             (void)PerlProc_setuid(new_uid);
2820         } else {
2821             Perl_croak(aTHX_ "setruid() not implemented");
2822         }
2823 #endif
2824 #endif
2825 #endif
2826         break;
2827         }
2828     case '>':
2829         {
2830         const Uid_t new_euid = SvUID(sv);
2831         PL_delaymagic_euid = new_euid;
2832         if (PL_delaymagic) {
2833             PL_delaymagic |= DM_EUID;
2834             break;                              /* don't do magic till later */
2835         }
2836 #ifdef HAS_SETEUID
2837         (void)seteuid(new_euid);
2838 #else
2839 #ifdef HAS_SETREUID
2840         (void)setreuid((Uid_t)-1, new_euid);
2841 #else
2842 #ifdef HAS_SETRESUID
2843         (void)setresuid((Uid_t)-1, new_euid, (Uid_t)-1);
2844 #else
2845         if (new_euid == PerlProc_getuid())              /* special case $> = $< */
2846             PerlProc_setuid(new_euid);
2847         else {
2848             Perl_croak(aTHX_ "seteuid() not implemented");
2849         }
2850 #endif
2851 #endif
2852 #endif
2853         break;
2854         }
2855     case '(':
2856         {
2857         const Gid_t new_gid = SvGID(sv);
2858         PL_delaymagic_gid = new_gid;
2859         if (PL_delaymagic) {
2860             PL_delaymagic |= DM_RGID;
2861             break;                              /* don't do magic till later */
2862         }
2863 #ifdef HAS_SETRGID
2864         (void)setrgid(new_gid);
2865 #else
2866 #ifdef HAS_SETREGID
2867         (void)setregid(new_gid, (Gid_t)-1);
2868 #else
2869 #ifdef HAS_SETRESGID
2870       (void)setresgid(new_gid, (Gid_t)-1, (Gid_t) -1);
2871 #else
2872         if (new_gid == PerlProc_getegid())                      /* special case $( = $) */
2873             (void)PerlProc_setgid(new_gid);
2874         else {
2875             Perl_croak(aTHX_ "setrgid() not implemented");
2876         }
2877 #endif
2878 #endif
2879 #endif
2880         break;
2881         }
2882     case ')':
2883         {
2884         Gid_t new_egid;
2885 #ifdef HAS_SETGROUPS
2886         {
2887             const char *p = SvPV_const(sv, len);
2888             Groups_t *gary = NULL;
2889 #ifdef _SC_NGROUPS_MAX
2890            int maxgrp = sysconf(_SC_NGROUPS_MAX);
2891
2892            if (maxgrp < 0)
2893                maxgrp = NGROUPS;
2894 #else
2895            int maxgrp = NGROUPS;
2896 #endif
2897
2898             while (isSPACE(*p))
2899                 ++p;
2900             new_egid = (Gid_t)Atol(p);
2901             for (i = 0; i < maxgrp; ++i) {
2902                 while (*p && !isSPACE(*p))
2903                     ++p;
2904                 while (isSPACE(*p))
2905                     ++p;
2906                 if (!*p)
2907                     break;
2908                 if(!gary)
2909                     Newx(gary, i + 1, Groups_t);
2910                 else
2911                     Renew(gary, i + 1, Groups_t);
2912                 gary[i] = (Groups_t)Atol(p);
2913             }
2914             if (i)
2915                 (void)setgroups(i, gary);
2916             Safefree(gary);
2917         }
2918 #else  /* HAS_SETGROUPS */
2919         new_egid = SvGID(sv);
2920 #endif /* HAS_SETGROUPS */
2921         PL_delaymagic_egid = new_egid;
2922         if (PL_delaymagic) {
2923             PL_delaymagic |= DM_EGID;
2924             break;                              /* don't do magic till later */
2925         }
2926 #ifdef HAS_SETEGID
2927         (void)setegid(new_egid);
2928 #else
2929 #ifdef HAS_SETREGID
2930         (void)setregid((Gid_t)-1, new_egid);
2931 #else
2932 #ifdef HAS_SETRESGID
2933         (void)setresgid((Gid_t)-1, new_egid, (Gid_t)-1);
2934 #else
2935         if (new_egid == PerlProc_getgid())                      /* special case $) = $( */
2936             (void)PerlProc_setgid(new_egid);
2937         else {
2938             Perl_croak(aTHX_ "setegid() not implemented");
2939         }
2940 #endif
2941 #endif
2942 #endif
2943         break;
2944         }
2945     case ':':
2946         PL_chopset = SvPV_force(sv,len);
2947         break;
2948     case '$': /* $$ */
2949         /* Store the pid in mg->mg_obj so we can tell when a fork has
2950            occurred.  mg->mg_obj points to *$ by default, so clear it. */
2951         if (isGV(mg->mg_obj)) {
2952             if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
2953                 SvREFCNT_dec(mg->mg_obj);
2954             mg->mg_flags |= MGf_REFCOUNTED;
2955             mg->mg_obj = newSViv((IV)PerlProc_getpid());
2956         }
2957         else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
2958         break;
2959     case '0':
2960         LOCK_DOLLARZERO_MUTEX;
2961 #ifdef HAS_SETPROCTITLE
2962         /* The BSDs don't show the argv[] in ps(1) output, they
2963          * show a string from the process struct and provide
2964          * the setproctitle() routine to manipulate that. */
2965         if (PL_origalen != 1) {
2966             s = SvPV_const(sv, len);
2967 #   if __FreeBSD_version > 410001
2968             /* The leading "-" removes the "perl: " prefix,
2969              * but not the "(perl) suffix from the ps(1)
2970              * output, because that's what ps(1) shows if the
2971              * argv[] is modified. */
2972             setproctitle("-%s", s);
2973 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2974             /* This doesn't really work if you assume that
2975              * $0 = 'foobar'; will wipe out 'perl' from the $0
2976              * because in ps(1) output the result will be like
2977              * sprintf("perl: %s (perl)", s)
2978              * I guess this is a security feature:
2979              * one (a user process) cannot get rid of the original name.
2980              * --jhi */
2981             setproctitle("%s", s);
2982 #   endif
2983         }
2984 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2985         if (PL_origalen != 1) {
2986              union pstun un;
2987              s = SvPV_const(sv, len);
2988              un.pst_command = (char *)s;
2989              pstat(PSTAT_SETCMD, un, len, 0, 0);
2990         }
2991 #else
2992         if (PL_origalen > 1) {
2993             /* PL_origalen is set in perl_parse(). */
2994             s = SvPV_force(sv,len);
2995             if (len >= (STRLEN)PL_origalen-1) {
2996                 /* Longer than original, will be truncated. We assume that
2997                  * PL_origalen bytes are available. */
2998                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2999             }
3000             else {
3001                 /* Shorter than original, will be padded. */
3002 #ifdef PERL_DARWIN
3003                 /* Special case for Mac OS X: see [perl #38868] */
3004                 const int pad = 0;
3005 #else
3006                 /* Is the space counterintuitive?  Yes.
3007                  * (You were expecting \0?)
3008                  * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
3009                  * --jhi */
3010                 const int pad = ' ';
3011 #endif
3012                 Copy(s, PL_origargv[0], len, char);
3013                 PL_origargv[0][len] = 0;
3014                 memset(PL_origargv[0] + len + 1,
3015                        pad,  PL_origalen - len - 1);
3016             }
3017             PL_origargv[0][PL_origalen-1] = 0;
3018             for (i = 1; i < PL_origargc; i++)
3019                 PL_origargv[i] = 0;
3020 #ifdef HAS_PRCTL_SET_NAME
3021             /* Set the legacy process name in addition to the POSIX name on Linux */
3022             if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
3023                 /* diag_listed_as: SKIPME */
3024                 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
3025             }
3026 #endif
3027         }
3028 #endif
3029         UNLOCK_DOLLARZERO_MUTEX;
3030         break;
3031     }
3032     return 0;
3033 }
3034
3035 I32
3036 Perl_whichsig_sv(pTHX_ SV *sigsv)
3037 {
3038     const char *sigpv;
3039     STRLEN siglen;
3040     PERL_ARGS_ASSERT_WHICHSIG_SV;
3041     PERL_UNUSED_CONTEXT;
3042     sigpv = SvPV_const(sigsv, siglen);
3043     return whichsig_pvn(sigpv, siglen);
3044 }
3045
3046 I32
3047 Perl_whichsig_pv(pTHX_ const char *sig)
3048 {
3049     PERL_ARGS_ASSERT_WHICHSIG_PV;
3050     PERL_UNUSED_CONTEXT;
3051     return whichsig_pvn(sig, strlen(sig));
3052 }
3053
3054 I32
3055 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3056 {
3057     char* const* sigv;
3058
3059     PERL_ARGS_ASSERT_WHICHSIG_PVN;
3060     PERL_UNUSED_CONTEXT;
3061
3062     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3063         if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3064             return PL_sig_num[sigv - (char* const*)PL_sig_name];
3065 #ifdef SIGCLD
3066     if (memEQs(sig, len, "CHLD"))
3067         return SIGCLD;
3068 #endif
3069 #ifdef SIGCHLD
3070     if (memEQs(sig, len, "CLD"))
3071         return SIGCHLD;
3072 #endif
3073     return -1;
3074 }
3075
3076 Signal_t
3077 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3078 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3079 #else
3080 Perl_sighandler(int sig)
3081 #endif
3082 {
3083 #ifdef PERL_GET_SIG_CONTEXT
3084     dTHXa(PERL_GET_SIG_CONTEXT);
3085 #else
3086     dTHX;
3087 #endif
3088     dSP;
3089     GV *gv = NULL;
3090     SV *sv = NULL;
3091     SV * const tSv = PL_Sv;
3092     CV *cv = NULL;
3093     OP *myop = PL_op;
3094     U32 flags = 0;
3095     XPV * const tXpv = PL_Xpv;
3096     I32 old_ss_ix = PL_savestack_ix;
3097     SV *errsv_save = NULL;
3098
3099
3100     if (!PL_psig_ptr[sig]) {
3101                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3102                                  PL_sig_name[sig]);
3103                 exit(sig);
3104         }
3105
3106     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3107         /* Max number of items pushed there is 3*n or 4. We cannot fix
3108            infinity, so we fix 4 (in fact 5): */
3109         if (PL_savestack_ix + 15 <= PL_savestack_max) {
3110             flags |= 1;
3111             PL_savestack_ix += 5;               /* Protect save in progress. */
3112             SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3113         }
3114     }
3115     /* sv_2cv is too complicated, try a simpler variant first: */
3116     if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3117         || SvTYPE(cv) != SVt_PVCV) {
3118         HV *st;
3119         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3120     }
3121
3122     if (!cv || !CvROOT(cv)) {
3123         Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3124                        PL_sig_name[sig], (gv ? GvENAME(gv)
3125                                           : ((cv && CvGV(cv))
3126                                              ? GvENAME(CvGV(cv))
3127                                              : "__ANON__")));
3128         goto cleanup;
3129     }
3130
3131     sv = PL_psig_name[sig]
3132             ? SvREFCNT_inc_NN(PL_psig_name[sig])
3133             : newSVpv(PL_sig_name[sig],0);
3134     flags |= 8;
3135     SAVEFREESV(sv);
3136
3137     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3138         /* make sure our assumption about the size of the SAVEs are correct:
3139          * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3140         assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0)  == PL_savestack_ix);
3141     }
3142
3143     PUSHSTACKi(PERLSI_SIGNAL);
3144     PUSHMARK(SP);
3145     PUSHs(sv);
3146 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3147     {
3148          struct sigaction oact;
3149
3150          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3151               if (sip) {
3152                    HV *sih = newHV();
3153                    SV *rv  = newRV_noinc(MUTABLE_SV(sih));
3154                    /* The siginfo fields signo, code, errno, pid, uid,
3155                     * addr, status, and band are defined by POSIX/SUSv3. */
3156                    (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3157                    (void)hv_stores(sih, "code", newSViv(sip->si_code));
3158 #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. */
3159                    hv_stores(sih, "errno",      newSViv(sip->si_errno));
3160                    hv_stores(sih, "status",     newSViv(sip->si_status));
3161                    hv_stores(sih, "uid",        newSViv(sip->si_uid));
3162                    hv_stores(sih, "pid",        newSViv(sip->si_pid));
3163                    hv_stores(sih, "addr",       newSVuv(PTR2UV(sip->si_addr)));
3164                    hv_stores(sih, "band",       newSViv(sip->si_band));
3165 #endif
3166                    EXTEND(SP, 2);
3167                    PUSHs(rv);
3168                    mPUSHp((char *)sip, sizeof(*sip));
3169               }
3170
3171          }
3172     }
3173 #endif
3174     PUTBACK;
3175
3176     errsv_save = newSVsv(ERRSV);
3177
3178     call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3179
3180     POPSTACK;
3181     {
3182         SV * const errsv = ERRSV;
3183         if (SvTRUE_NN(errsv)) {
3184             SvREFCNT_dec(errsv_save);
3185 #ifndef PERL_MICRO
3186         /* Handler "died", for example to get out of a restart-able read().
3187          * Before we re-do that on its behalf re-enable the signal which was
3188          * blocked by the system when we entered.
3189          */
3190 #ifdef HAS_SIGPROCMASK
3191 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3192             if (sip || uap)
3193 #endif
3194             {
3195                 sigset_t set;
3196                 sigemptyset(&set);
3197                 sigaddset(&set,sig);
3198                 sigprocmask(SIG_UNBLOCK, &set, NULL);
3199             }
3200 #else
3201             /* Not clear if this will work */
3202             (void)rsignal(sig, SIG_IGN);
3203             (void)rsignal(sig, PL_csighandlerp);
3204 #endif
3205 #endif /* !PERL_MICRO */
3206             die_sv(errsv);
3207         }
3208         else {
3209             sv_setsv(errsv, errsv_save);
3210             SvREFCNT_dec(errsv_save);
3211         }
3212     }
3213
3214 cleanup:
3215     /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3216     PL_savestack_ix = old_ss_ix;
3217     if (flags & 8)
3218         SvREFCNT_dec_NN(sv);
3219     PL_op = myop;                       /* Apparently not needed... */
3220
3221     PL_Sv = tSv;                        /* Restore global temporaries. */
3222     PL_Xpv = tXpv;
3223     return;
3224 }
3225
3226
3227 static void
3228 S_restore_magic(pTHX_ const void *p)
3229 {
3230     dVAR;
3231     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3232     SV* const sv = mgs->mgs_sv;
3233     bool bumped;
3234
3235     if (!sv)
3236         return;
3237
3238     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3239         SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3240 #ifdef PERL_OLD_COPY_ON_WRITE
3241         /* While magic was saved (and off) sv_setsv may well have seen
3242            this SV as a prime candidate for COW.  */
3243         if (SvIsCOW(sv))
3244             sv_force_normal_flags(sv, 0);
3245 #endif
3246         if (mgs->mgs_readonly)
3247             SvREADONLY_on(sv);
3248         if (mgs->mgs_magical)
3249             SvFLAGS(sv) |= mgs->mgs_magical;
3250         else
3251             mg_magical(sv);
3252     }
3253
3254     bumped = mgs->mgs_bumped;
3255     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
3256
3257     /* If we're still on top of the stack, pop us off.  (That condition
3258      * will be satisfied if restore_magic was called explicitly, but *not*
3259      * if it's being called via leave_scope.)
3260      * The reason for doing this is that otherwise, things like sv_2cv()
3261      * may leave alloc gunk on the savestack, and some code
3262      * (e.g. sighandler) doesn't expect that...
3263      */
3264     if (PL_savestack_ix == mgs->mgs_ss_ix)
3265     {
3266         UV popval = SSPOPUV;
3267         assert(popval == SAVEt_DESTRUCTOR_X);
3268         PL_savestack_ix -= 2;
3269         popval = SSPOPUV;
3270         assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3271         PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3272     }
3273     if (bumped) {
3274         if (SvREFCNT(sv) == 1) {
3275             /* We hold the last reference to this SV, which implies that the
3276                SV was deleted as a side effect of the routines we called.
3277                So artificially keep it alive a bit longer.
3278                We avoid turning on the TEMP flag, which can cause the SV's
3279                buffer to get stolen (and maybe other stuff). */
3280             sv_2mortal(sv);
3281             SvTEMP_off(sv);
3282         }
3283         else
3284             SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
3285     }
3286 }
3287
3288 /* clean up the mess created by Perl_sighandler().
3289  * Note that this is only called during an exit in a signal handler;
3290  * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3291  * skipped over. */
3292
3293 static void
3294 S_unwind_handler_stack(pTHX_ const void *p)
3295 {
3296     dVAR;
3297     PERL_UNUSED_ARG(p);
3298
3299     PL_savestack_ix -= 5; /* Unprotect save in progress. */
3300 }
3301
3302 /*
3303 =for apidoc magic_sethint
3304
3305 Triggered by a store to %^H, records the key/value pair to
3306 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
3307 anything that would need a deep copy.  Maybe we should warn if we find a
3308 reference.
3309
3310 =cut
3311 */
3312 int
3313 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3314 {
3315     dVAR;
3316     SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3317         : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3318
3319     PERL_ARGS_ASSERT_MAGIC_SETHINT;
3320
3321     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
3322        an alternative leaf in there, with PL_compiling.cop_hints being used if
3323        it's NULL. If needed for threads, the alternative could lock a mutex,
3324        or take other more complex action.  */
3325
3326     /* Something changed in %^H, so it will need to be restored on scope exit.
3327        Doing this here saves a lot of doing it manually in perl code (and
3328        forgetting to do it, and consequent subtle errors.  */
3329     PL_hints |= HINT_LOCALIZE_HH;
3330     CopHINTHASH_set(&PL_compiling,
3331         cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3332     return 0;
3333 }
3334
3335 /*
3336 =for apidoc magic_clearhint
3337
3338 Triggered by a delete from %^H, records the key to
3339 C<PL_compiling.cop_hints_hash>.
3340
3341 =cut
3342 */
3343 int
3344 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3345 {
3346     dVAR;
3347
3348     PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3349     PERL_UNUSED_ARG(sv);
3350
3351     PL_hints |= HINT_LOCALIZE_HH;
3352     CopHINTHASH_set(&PL_compiling,
3353         mg->mg_len == HEf_SVKEY
3354          ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3355                                  MUTABLE_SV(mg->mg_ptr), 0, 0)
3356          : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3357                                  mg->mg_ptr, mg->mg_len, 0, 0));
3358     return 0;
3359 }
3360
3361 /*
3362 =for apidoc magic_clearhints
3363
3364 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3365
3366 =cut
3367 */
3368 int
3369 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3370 {
3371     PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3372     PERL_UNUSED_ARG(sv);
3373     PERL_UNUSED_ARG(mg);
3374     cophh_free(CopHINTHASH_get(&PL_compiling));
3375     CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3376     return 0;
3377 }
3378
3379 int
3380 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3381                                  const char *name, I32 namlen)
3382 {
3383     MAGIC *nmg;
3384
3385     PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3386     PERL_UNUSED_ARG(sv);
3387     PERL_UNUSED_ARG(name);
3388     PERL_UNUSED_ARG(namlen);
3389
3390     sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3391     nmg = mg_find(nsv, mg->mg_type);
3392     if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3393     nmg->mg_ptr = mg->mg_ptr;
3394     nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3395     nmg->mg_flags |= MGf_REFCOUNTED;
3396     return 1;
3397 }
3398
3399 /*
3400  * Local variables:
3401  * c-indentation-style: bsd
3402  * c-basic-offset: 4
3403  * indent-tabs-mode: nil
3404  * End:
3405  *
3406  * ex: set ts=8 sts=4 sw=4 et:
3407  */