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