mg.c

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