mg.c

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