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