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