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