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