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