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