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