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